Diff

Differences From Artifact [cb9913280b]:

To Artifact [cdff98c77e]:


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30















31
32
33
34
35
36


37
38
39

40
41
42
43
44



45
46
47


48
49
50

51
52
53
54


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
173
174

175
176

177
178
179
180
181
182
183
184
185
186
187
188



189
190
191
192
193
194
195
1
2
3
4


5


6
7
8
9
10
11
12
13
14


15


16

17
18
19
20


21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39


40
41

42

43
44




45
46
47
48


49
50

51

52
53
54


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




-
-

-
-









-
-

-
-

-
+



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




-
-
+
+
-

-
+

-
-
-
-
+
+
+

-
-
+
+
-

-
+


-
-
+
+

-
-
+
-
-
+
-

+
-
-
-
+
+
+
-

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

-
-
+
-

-
-
-
-
+
-
-
+
+
+

+
-
+
-

+
-
-
+
+

-
-
-
+
+
+

-
-
-
-
-


-



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

-
-
-
+
-
-

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

-
-
+
-
-
+

-
-
-
-







+
+
+







# tcc.tcl - library routines for the tcc wrapper (Mark Janssen)

namespace eval tcc4tcl {
	variable dir 
	variable libs
	variable includes
	variable count
	variable command_count
	variable commands

	set dir [file dirname [info script]]
	if {[info command ::tcc4tcl] == ""} {
		catch { load {} tcc4tcl }
	}
	if {[info command ::tcc4tcl] == ""} {
		load [file join $dir tcc4tcl[info sharedlibextension]] tcc4tcl
	}

	set libs $dir/lib
	set includes $dir/include
	set count 0
	set command_count 0
	array set commands {}

	proc new {{output "memory"}} {
	proc new {{output ""}} {
		variable dir
		variable count

		set handle tcc_[incr count]
		tcc4tcl $dir $output $handle
		set handle ::tcc4tcl::tcc_[incr count]
		set tcc_handle ::tcc4tcl::tcc_[incr count]

		if {$output == ""} {
			set type "memory"
		} else {
			set type "dll"
		}

		array set $handle [list tcc $tcc_handle code "" type $type]

		proc $handle {cmd args} [string map [list @@HANDLE@@ $handle] {
			set handle {@@HANDLE@@}
			uplevel 1 [list ::tcc4tcl::_$cmd $handle {*}$args]
		}]

		return $handle
	}

	proc tclcommand {handle name ccode} {
		variable commands
	proc _cproc {handle name adefs rtype {body "#"}} {
		upvar #0 $handle state
		variable command_count

		set cname _tcc_tcl_command_[incr command_count]
		set wrap [::tcc4tcl::wrap $name $adefs $rtype $body]

		set code    {#include "tcl.h"}
		append code "\nint $cname(ClientData cdata,Tcl_Interp *interp,int objc,Tcl_Obj* CONST objv\[\]) \{"
		append code "\n$ccode"
		append code "\}"
		set wrapped [lindex $wrap 0]
		set wrapper [lindex $wrap 1]
		set tclname [lindex $wrap 2]

		$handle compile $code

		append state(code) $wrapped "\n"
		append state(code) $wrapper "\n"
		set commands($handle,$name) $cname

		return
		lappend state(procs) $name $tclname
	}

	proc compile {handle} {
		variable commands
	proc _ccode {handle code} {
		upvar #0 $handle state

		foreach cmd [array names commands ${handle},*] {
			set cname $commands($cmd)
		append state(code) $code
			set tclcommand [join [lrange [split $cmd ,] 1 end] {}]

	}
			set handle [lindex [split $cmd ,] 0]

	proc _tk {handle} {
			$handle command $tclcommand $cname
		}

		upvar #0 $handle state

		set state(tk) 1
		return
	}
}

proc tcc4tcl::to_dll {code dll {libs {}}} {
	set handle [::tcc4tcl::new dll]
	foreach lib $libs {
		$handle add_library $lib
	}


	proc _go {handle} {
	if {$::tcl_platform(platform) eq "windows"} {
		$handle define DLL_EXPORT {__declspec(dllexport)} 
		variable dir

		set f [open [file join $::tcc4tcl::dir lib dllcrt1.c]]
		$handle compile [read $f]
		upvar #0 $handle state
		close $f

		set f [open [file join $::tcc4tcl::dir lib dllmain.c]]
		$handle compile [read $f]
		close $f
	} else {
		if {[info exists state(tk)]} {
		$handle define DLL_EXPORT ""
	}
			set state(code) "#include <tk.h>\n$state(code)"
		}
		set state(code) "#include <tcl.h>\n\n$state(code)"

		tcc4tcl $dir $state(type) tcc
	$handle compile $code
		tcc compile $state(code)
	$handle output_file $dll

		foreach {procname cname} $state(procs) {
	rename $handle {}
}
			tcc command $procname $cname
		}

proc ::tcc4tcl::Log {args} {
	# puts $args
}
		rename $handle ""
		unset $handle
	}

proc ::tcc4tcl::reset {} {
	variable tcc
	set tcc(code)   ""
	set tcc(cfiles) [list]
	set tcc(tk) 0
}

# Custom helpers
proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
proc ::tcc4tcl::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}

proc ::tcc4tcl::ccode {code} {
	variable tcc

	Log "INJECTING CCODE"

	append tcc(code) $code \n
}

proc ::tcc4tcl::cc {code} {
proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
	variable tcc

	if {![info exists tcc(cc)]} {
		set tcc(cc) [::tcc4tcl::new]
	set handle [::tcc4tcl::new]
	}

	$handle cproc $name $adefs $rtype $body
	$tcc(cc) compile $code
}

	return [$handle go]
#----------------------------------------------------------- New DLL API
namespace eval ::tcc4tcl::dll {}
proc ::tcc4tcl::dll {{name ""}} {
	variable count

}
	if {$name eq ""} {
		set name dll[incr count]
	}


proc ::tcc4tcl::wrap {name adefs rtype {body "#"} {cname ""}} {
	namespace eval ::tcc4tcl::dll::$name {
		variable code "#include <tcl.h>\n" ;# always needed
		variable cmds {}
	}

	if {$cname == ""} {
	proc ::$name {cmd args} "::tcc4tcl::dll::\$cmd $name \$args"
	return $name
}
		set cname c_[tcc4tcl::cleanname $name]
	}

proc ::tcc4tcl::dll::ccode {name argl} {
	append ${name}::code "\n" [lindex $argl 0]

	return
}

	set wname tcl_[tcc4tcl::cleanname $name]
proc ::tcc4tcl::dll::cproc {name argl} {
	foreach {pname pargs rtype body} $argl break

	set code [::tcc4tcl::wrapCmd $pname $pargs $rtype cx_$pname $body]

	# Fully qualified proc name
	lappend ${name}::cmds $pname cx_$pname
	append ${name}::code "\n" $code

	if {![string match "::*" $name]} {
	return
}

		set nsfrom [uplevel 1 {namespace current}]    
proc ::tcc4tcl::dll::write {name argl} {
	set (-dir) .
	set (-code) "" ;# possible extra code to go into the _Init function
	set (-libs) ""
		if {$nsfrom eq "::"} {
	set (-name) [string tolower $name]
	array set "" $argl

			set nsfrom ""
		}
	append ${name}::code "\n" \
		[::tcc4tcl::wrapExport $(-name) [set ${name}::cmds] $(-code)]

	set outfile $(-dir)/$(-name)[info sharedlibextension]

		set name "${nsfrom}::${name}"
	::tcc4tcl::to_dll [set ${name}::code] $outfile $(-libs)
}
	}

#---------------------------------------------------------------------
proc ::tcc4tcl::wrap {name adefs rtype {body "#"}} {
	set cname c_[tcc4tcl::cleanname $name]
	set wname tcl_$name
	array set types {}
	set varnames {}
	set cargs {}
	set cnames {}  
	set cbody {}
	set code {}

	# Write wrapper
	append cbody "int $wname\(ClientData dummy, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv\[\]) {" "\n"

	# if first arg is "Tcl_Interp*", pass it without counting it as a cmd arg
	if {[lindex $adefs 0] eq "Tcl_Interp*"} {
		lappend cnames ip
		lappend cargs [lrange $adefs 0 1]
		set adefs [lrange $adefs 2 end]
	}

209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
146
147
148
149
150
151
152





153
154
155
156
157
158
159







-
-
-
-
-







			set rtype2 "char*"
		}
		default {
			set rtype2 $rtype
		}
	}

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

	# Create wrapped function
	if {$body ne "#"} {
		append code "static $rtype2 ${cname}([join $cargs {, }]) \{\n"
		append code $body
		append code "\}\n"
	} else {
		append code "#define $cname $name" "\n"
291
292
293
294
295
296
297
298

299
300
301
302
303
304
305
223
224
225
226
227
228
229

230
231
232
233
234
235
236
237







-
+







			}
		}
	}
	append cbody "\n"

	# Call wrapped function
	if {$rtype != "void"} {
		append cbody "rv = "
		append cbody "  rv = "
	}
	append cbody "${cname}([join $cnames {, }]);" "\n"

	# Return types supported by critcl
	#   void
	#   ok
	#   int
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410

411
412
413
414
415
416
417

418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499

267
268
269
270
271
272
273





































































274
275






276
277
278
















































































279







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

-
-
-
-
-
-
+


-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
		default        { append cbody "  Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" "\n" }
	}

	if {$rtype != "ok"} {
		append cbody "  return TCL_OK;\n"
	}

	return [list $code $cbody]
}

proc ::tcc4tcl::wrapCmd {tclname argl rtype cname body} {
	foreach {code cbody} [wrap $tclname $argl $rtype $body] break

	append code "\nstatic int $cname(ClientData cdata,Tcl_Interp *ip, int objc,Tcl_Obj* CONST objv\[\]) \{\n"
	append code "\n$cbody\n\}\n"

	return $code
}

proc ::tcc4tcl::wrapExport {name cmds {body ""}} {
	set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp) \{\n"

	foreach {tclname cname} $cmds {
		append code "Tcl_CreateObjCommand(interp, \"$tclname\", $cname, NULL, NULL);\n"
	}

	append code $body
	append code "\nreturn TCL_OK;\n\}"

	return $code
}

#---------------------------------------------------------------------
proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
	foreach {code cbody} [wrap $name $adefs $rtype $body] break

	::tcc4tcl::ccode $code

	uplevel 1 [list ::tcc4tcl::ccommand $name {dummy ip objc objv} $cbody]
}

#---------------------------------------------------------------------
proc ::tcc4tcl::cdata {name data} {
	# Extract bytes from data
	binary scan $data c* bytes

	set inittext "\n"
	set line ""
	set n 0
	set l 0
	foreach c $bytes {
		if {$n > 0} {
			append inittext ","
		}
		if {$l > 20} {
			append inittext "\n"
			set l 0
		}

		if {$l==0} {
			append inittext "  "
		}

		append inittext [format "0x%02X" [expr {$c & 0xff}]]
		incr n
		incr l
	}

	append inittext "\n"

	set count [llength $bytes]  

	set cbody ""
	append cbody "static unsigned char script\[$count\] = \{" "\n"
	append cbody $inittext
	append cbody "\};" "\n"
	append cbody "}" "\n"

	append cbody "Tcl_SetByteArrayObj(Tcl_GetObjResult(ip), (unsigned char*) script, $count);\n"
	append cbody "return TCL_OK;" "\n"

	uplevel 1 [list tcc4tcl::ccommand $name {dummy ip objc objv} $cbody]

	return $name
	return [list $code $cbody $wname]
}

#-------------------------------------------------------------------
proc ::tcc4tcl::ccommand {procname anames body} {
	variable tcc

	# Fully qualified proc name
	if {[string match "::*" $procname]} {
		# procname is already absolute
	} else {
		set nsfrom [uplevel 1 {namespace current}]    
		if {$nsfrom eq "::"} {
			set nsfrom ""
		}

		set procname "${nsfrom}::${procname}"
	}

	set v(clientdata) clientdata
	set v(interp)     interp
	set v(objc)       objc
	set v(objv)       objv

	set id 0

	foreach defname {clientdata interp objc objv} {
		if {[llength $anames] > $id} {
			set vname [lindex $anames $id]

			if {![checkname $vname]} {
				error "invalid variable name \"$vname\""
			}
		} else {
			set vname $defname
		}

		set v($defname) $vname

		incr id
	}

	set cname Cmd_N${id}_[cleanname $procname]
	set code ""

	if {[info exists tcc(tk)] && $tcc(tk)} {
		append code "\#include <tk.h>" "\n"
	}

	if {[info exists tcc(code)]} {
		append code $tcc(code)
		append code "\n"
	}
	set tcc(code) ""

	append code "int $cname (ClientData $v(clientdata),Tcl_Interp *$v(interp),"
	append code "int $v(objc),Tcl_Obj *CONST $v(objv)\[\]) {" "\n"
	append code $body "\n"
	append code "}" "\n"

	if {[catch {
		uplevel 1 [list tcc4tcl::cc $code]
	} err]} {
		unset tcc(cc)
		tcc4tcl::reset

		return -code error $err
	}

	Log "CREATING TCL COMMAND $procname / $cname"
	uplevel 1 [list $tcc(cc) command $procname $cname]

	unset tcc(cc) ;# can't be used for compiling anymore
	tcc4tcl::reset
}

proc ::tcc4tcl::tk {args} {
	variable tcc
	set tcc(tk) 1
}

::tcc4tcl::reset
namespace eval tcc4tcl {namespace export cproc ccode cdata}
namespace eval tcc4tcl {namespace export cproc new}