Check-in [daa895fdb4]
Overview
Comment:Rewrote high-level API to support a handle-based interface
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:daa895fdb417b960e251fa6233508753dff2eb97
User & Date: rkeene on 2014-06-18 04:45:59
Other Links: manifest | tags
Context
2014-06-18
05:05
Updated to allow output to file (DLL/SO) to work -- but segfaults check-in: c208e3c07f user: rkeene tags: trunk
04:45
Rewrote high-level API to support a handle-based interface check-in: daa895fdb4 user: rkeene tags: trunk
2014-06-17
16:56
Updated to treat NULL return values as errors from most types of return types check-in: fbca0aea0c user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [cb9913280b] to [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
...
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
...
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
...
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
# 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"}} {
		variable dir
		variable count

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

		return $handle



	}

	proc tclcommand {handle name ccode} {
		variable commands
		variable command_count


		set cname _tcc_tcl_command_[incr command_count]


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


		$handle compile $code

		set commands($handle,$name) $cname

		return


	}


	proc compile {handle} {
		variable commands


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

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

			$handle command $tclcommand $cname
		}



		return

	}
}



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

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

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

		set f [open [file join $::tcc4tcl::dir lib dllmain.c]]
		$handle compile [read $f]
		close $f
	} else {
		$handle define DLL_EXPORT ""


	}



	$handle compile $code
	$handle output_file $dll

	rename $handle {}


}

proc ::tcc4tcl::Log {args} {
	# puts $args


}

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} {
	variable tcc

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

	$tcc(cc) compile $code
}

#----------------------------------------------------------- New DLL API
namespace eval ::tcc4tcl::dll {}
proc ::tcc4tcl::dll {{name ""}} {
	variable count

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

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

	proc ::$name {cmd args} "::tcc4tcl::dll::\$cmd $name \$args"
	return $name
}

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


	return
}

proc ::tcc4tcl::dll::cproc {name argl} {
	foreach {pname pargs rtype body} $argl break




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

	lappend ${name}::cmds $pname cx_$pname
	append ${name}::code "\n" $code


	return





}

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


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

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

	::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 {}




	# 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]
	}

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

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

	# Return types supported by critcl
	#   void
	#   ok
	#   int
................................................................................
		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 "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
}

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




<
<

<
<









<
<

<
<

|



|
|

|
>
>
>
|

<
<
<
>

<
<
>
|
|
<
<
>

|
|
<

<
>
>
|
>

|
|
>

<
|
|

|
|
<
|
>
>

<
>

|
>
>

<
<
<
|


|
|

|
<
<

<
<
<
<
<
>
>
|
>

>
|
<

<
>
>
|

<
<
>
>
|

<
<
<
<
<


<



<
<
<
<
<
<
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|


<
<
>
>
>
|
<

<
<
>

<
>
>
>
>
>
|

<
<
<
<
<
<
>
|
<
<

<
<
<
<
<
<
<
<
<







>
>
>







 







<
<
<
<
<







 







|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|

<
<
>
|
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
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
...
146
147
148
149
150
151
152





153
154
155
156
157
158
159
...
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
...
267
268
269
270
271
272
273




































































274
275


276
277

278


















































































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

namespace eval tcc4tcl {
	variable dir 


	variable count



	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 count 0



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

		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 _cproc {handle name adefs rtype {body "#"}} {
		upvar #0 $handle state

		set wrap [::tcc4tcl::wrap $name $adefs $rtype $body]

		set wrapped [lindex $wrap 0]
		set wrapper [lindex $wrap 1]
		set tclname [lindex $wrap 2]


		append state(code) $wrapped "\n"
		append state(code) $wrapper "\n"

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

		tcc4tcl $dir $state(type) tcc
		tcc compile $state(code)



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



		rename $handle ""
		unset $handle
	}






}


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::cproc {name adefs rtype {body "#"}} {



	set handle [::tcc4tcl::new]


























	$handle cproc $name $adefs $rtype $body
	return [$handle go]
}



proc ::tcc4tcl::wrap {name adefs rtype {body "#"} {cname ""}} {
	if {$cname == ""} {
		set cname c_[tcc4tcl::cleanname $name]
	}




	set wname tcl_[tcc4tcl::cleanname $name]


	# Fully qualified proc name
	if {![string match "::*" $name]} {
		set nsfrom [uplevel 1 {namespace current}]    
		if {$nsfrom eq "::"} {
			set nsfrom ""
		}







		set name "${nsfrom}::${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]
	}

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






	# 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"
................................................................................
			}
		}
	}
	append cbody "\n"

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

	# Return types supported by critcl
	#   void
	#   ok
	#   int
................................................................................
		default        { append cbody "  Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" "\n" }
	}

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





































































	append cbody "}" "\n"



	return [list $code $cbody $wname]
}




















































































namespace eval tcc4tcl {namespace export cproc new}