tcc4tcl
Check-in [1a7d494008]
Login
HomeTimelineFilesBranchesTagsTicketsWiki
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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

︙︙
31
32
33
34
35
36
37









38
39
40
41
42
43
44

			}
		}

		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@@}









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

		return $handle
	}

	proc _cproc {handle name adefs rtype {body "#"}} {








>
>
>
>
>
>
>
>
>








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


		lappend state(procs) $name $tclname
	}

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

		append state(code) $code
	}

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

		set state(tk) 1
	}

	proc _go {handle} {
		variable dir

		upvar #0 $handle state



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

		# Append additional generated code to support the output type
		switch -- $state(type) {
			"memory" {
				# No additional code needed







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

					append state(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"

				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 state(code) "Tcl_PkgProvide(interp, \"$packageName\", \"$packageVersion\");\n"
				append state(code) "  return(TCL_OK);\n"
				append state(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)


				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"
					}






					"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 output_file $state(filename)
			}
		}

		# Cleanup
		rename $handle ""








|








|




>
>

|

|





>
>
>
>
>
>
>



|


|


|









|
|
|
|
|
|



|



|
|
|


>
>
>
>










>




|

>
|
|
>











>
>
>
>
>
>














|








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 "\n"
	}

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

		set state(tk) 1
	}

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

		upvar #0 $handle state

		set code $state(code)

		if {[info exists state(tk)]} {
			set code "#include <tk.h>\n$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 code "int _initProcs(Tcl_Interp *interp) \{\n"
					
					foreach {procname cname} $state(procs) {
						append code "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
					}

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

				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 code "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
					}
				}

				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 $code

				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
					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 $code

				tcc output_file $state(filename)
			}
		}

		# Cleanup
		rename $handle ""
︙︙

Powered by Fossil · RSS