Check-in [1a7d494008]
Overview
Comment:Added a command called "code" to get the generated code
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1a7d494008f59c433c1303970742640f7a57673e
User & Date: rkeene on 2014-06-18 19:46:13
Other Links: manifest | tags
Context
2014-06-18
19:50
Added new API tests check-in: 2a9dcf9840 user: rkeene tags: trunk
19:46
Added a command called "code" to get the generated code check-in: 1a7d494008 user: rkeene tags: trunk
19:04
Updated to use pointerSize to determine 32/64-bit library paths so that i386 code can be emitted when running a 32-bit Tcl on a 64-bit box check-in: 0d7d9afa0a user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [9e249ac45d] to [602c05c493].

31
32
33
34
35
36
37









38
39
40
41
42
43
44
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53







+
+
+
+
+
+
+
+
+







			}
		}

		array set $handle [list tcc $tcc_handle code "" type $type filename $output package $pkgName]

		proc $handle {cmd args} [string map [list @@HANDLE@@ $handle] {
			set handle {@@HANDLE@@}
			if {$cmd == "go"} {
				set args [list 0 {*}$args]
			}

			if {$cmd == "code"} {
				set cmd "go"
				set args [list 1 {*}$args]
			}

			uplevel 1 [list ::tcc4tcl::_$cmd $handle {*}$args]
		}]

		return $handle
	}

	proc _cproc {handle name adefs rtype {body "#"}} {
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69
70
71

72
73
74
75


76
77

78
79

80
81
82
83
84







85
86
87
88

89
90
91

92
93
94

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109






110
111
112
113

114
115
116
117
118
119



120
121




122
123
124
125
126
127
128
129
130
131

132
133
134
135
136

137

138
139



140
141
142
143
144
145
146
147
148
149
150






151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

166
167
168
169
170
171
172
64
65
66
67
68
69
70

71
72
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87

88
89

90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107
108

109
110
111

112
113
114
115
116
117
118
119
120
121






122
123
124
125
126
127
128
129
130

131
132
133
134



135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158

159
160
161


162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202
203







-
+








-
+




+
+

-
+

-
+





+
+
+
+
+
+
+



-
+


-
+


-
+









-
-
-
-
-
-
+
+
+
+
+
+



-
+



-
-
-
+
+
+


+
+
+
+










+




-
+

+
-
-
+
+
+











+
+
+
+
+
+














-
+








		lappend state(procs) $name $tclname
	}

	proc _ccode {handle code} {
		upvar #0 $handle state

		append state(code) $code
		append state(code) $code "\n"
	}

	proc _tk {handle} {
		upvar #0 $handle state

		set state(tk) 1
	}

	proc _go {handle} {
	proc _go {handle {outputOnly 0}} {
		variable dir

		upvar #0 $handle state

		set code $state(code)

		if {[info exists state(tk)]} {
			set state(code) "#include <tk.h>\n$state(code)"
			set code "#include <tk.h>\n$code"
		}
		set state(code) "#include <tcl.h>\n\n$state(code)"
		set code "#include <tcl.h>\n\n$code"

		# Append additional generated code to support the output type
		switch -- $state(type) {
			"memory" {
				# No additional code needed
				if {$outputOnly} {
					if {[info exists state(procs)] && [llength $state(procs)] > 0} {
						foreach {procname cname} $state(procs) {
							append code "/* Immediate: Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL); */\n"
						}
					}
				}
			}
			"exe" - "dll" {
				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
					append state(code) "int _initProcs(Tcl_Interp *interp) \{\n"
					append code "int _initProcs(Tcl_Interp *interp) \{\n"
					
					foreach {procname cname} $state(procs) {
						append state(code) "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);"
						append code "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
					}

					append state(code) "\}"
					append code "\}"
				}
			}
			"package" {
				set packageName [lindex $state(package) 0]
				set packageVersion [lindex $state(package) 1]
				if {$packageVersion == ""} {
					set packageVersion "0"
				}

				append state(code) "int [string totitle $packageName]_Init(Tcl_Interp *interp) \{\n"
				append state(code) "#ifdef USE_TCL_STUBS\n"
				append state(code) "  if (Tcl_InitStubs(interp, \"8.4\" , 0) == 0L) \{\n"
				append state(code) "    return TCL_ERROR;\n"
				append state(code) "  \}\n"
				append state(code) "#endif\n"
				append code "int [string totitle $packageName]_Init(Tcl_Interp *interp) \{\n"
				append code "#ifdef USE_TCL_STUBS\n"
				append code "  if (Tcl_InitStubs(interp, \"8.4\" , 0) == 0L) \{\n"
				append code "    return TCL_ERROR;\n"
				append code "  \}\n"
				append code "#endif\n"

				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
					foreach {procname cname} $state(procs) {
						append state(code) "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);"
						append code "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
					}
				}

				append state(code) "Tcl_PkgProvide(interp, \"$packageName\", \"$packageVersion\");\n"
				append state(code) "  return(TCL_OK);\n"
				append state(code) "\}"
				append code "  Tcl_PkgProvide(interp, \"$packageName\", \"$packageVersion\");\n"
				append code "  return(TCL_OK);\n"
				append code "\}"
			}
		}

		if {$outputOnly} {
			return $code
		}

		# Generate output code
		switch -- $state(type) {
			"package" {
				set tcc_type "dll"
			}
			default {
				set tcc_type $state(type)
			}
		}

		tcc4tcl $dir $tcc_type tcc

		switch -- $state(type) {
			"memory" {
				tcc compile $state(code)
				tcc compile $code

				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
				foreach {procname cname} $state(procs) {
					tcc command $procname $cname
					foreach {procname cname} $state(procs) {
						tcc command $procname $cname
					}
				}
			}

			"package" - "dll" - "exe" {
				switch -glob -- $::tcl_platform(os)-$::tcl_platform(pointerSize) {
					"Linux-8" {
						tcc add_library_path "/lib64"
						tcc add_library_path "/usr/lib64"
						tcc add_library_path "/lib"
						tcc add_library_path "/usr/lib"
					}
					"SunOS-8" {
						tcc add_library_path "/lib/64"
						tcc add_library_path "/usr/lib/64"
						tcc add_library_path "/lib"
						tcc add_library_path "/usr/lib"
					}
					"Linux-*" {
						tcc add_library_path "/lib32"
						tcc add_library_path "/usr/lib32"
						tcc add_library_path "/lib"
						tcc add_library_path "/usr/lib"
					}
					default {
						if {$::tcl_platform(platform) == "unix"} {
							tcc add_library_path "/lib"
							tcc add_library_path "/usr/lib"
						}
					}
				}

				tcc compile $state(code)
				tcc compile $code

				tcc output_file $state(filename)
			}
		}

		# Cleanup
		rename $handle ""