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
|
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
|
-
+
-
-
+
+
-
+
-
-
+
-
-
-
-
+
|
# tcc.tcl - library routines for the tcc wrapper (Mark Janssen)
namespace eval tcc {
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 ::tcc] == ""} {
catch { load {} tcc }
if {[info command ::tcc4tcl] == ""} {
catch { load {} tcc4tcl }
}
if {[info command ::tcc] == ""} {
if {[info command ::tcc4tcl] == ""} {
switch -exact -- $::tcl_platform(platform) {
windows { load $dir/tcc04.dll tcc }
unix { load $dir/libtcc0.4.so tcc }
default {error "unsupport platform"}
}
tcc $dir $handle
tcc4tcl $dir $handle
return tcc_$count
}
proc tclcommand {handle name ccode} {
variable commands
variable command_count
set cname _tcc_tcl_command_[incr command_count]
set code {#include "tcl.h"}
|
| ︙ | | |
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
|
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
|
-
-
+
+
-
-
-
+
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
+
-
-
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
+
-
+
-
+
-
+
|
set tclcommand [join [lrange [split $cmd ,] 1 end] {}]
set handle [lindex [split $cmd ,] 0]
$handle command $tclcommand $cname
}
return
}
}
proc tcc::to_dll {code dll {libs {}}} {
tcc $::tcc::dir dll tcc_1
proc tcc4tcl::to_dll {code dll {libs {}}} {
tcc4tcl $::tcc4tcl::dir dll tcc_1
tcc_1 add_library tcl8.5
tcc_1 add_library_path .
set f [open $::tcc::dir/c/dllcrt1.c]
set f [open $::tcc4tcl::dir/c/dllcrt1.c]
tcc_1 compile [read $f]
close $f
set f [open $::tcc::dir/c/dllmain.c]
set f [open $::tcc4tcl::dir/c/dllmain.c]
tcc_1 compile [read $f]
close $f
} else {
tcc_1 define DLL_EXPORT ""
}
tcc_1 compile $code
tcc_1 output_file $dll
rename tcc_1 {}
}
proc ::tcc::Log {args} {
proc ::tcc4tcl::Log {args} {
# puts $args
}
proc ::tcc::reset {} {
proc ::tcc4tcl::reset {} {
variable tcc
set tcc(code) ""
set tcc(cfiles) [list]
set tcc(tk) 0
}
# Custom helpers
proc ::tcc::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
proc ::tcc::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}
proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
proc ::tcc4tcl::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}
proc ::tcc::ccode {code} {
proc ::tcc4tcl::ccode {code} {
variable tcc
Log "INJECTING CCODE"
append tcc(code) $code \n
}
proc ::tcc::cc {code} {
proc ::tcc4tcl::cc {code} {
variable tcc
if {![info exists tcc(cc)]} {
set tcc(cc) tcc1
tcc $tcc::dir $tcc(cc)
tcc4tcl $::tcc4tcl::dir $tcc(cc)
$tcc(cc) add_library tcl8.5
$tcc(cc) add_include_path [file join $::tcc::dir include]
proc ::tcc::dll {{name ""}} {
proc ::tcc4tcl::dll {{name ""}} {
variable count
if {$name eq ""} {set name dll[incr count]}
namespace eval ::tcc::dll::$name {
namespace eval ::tcc4tcl::dll::$name {
variable code "#include <tcl.h>\n" ;# always needed
variable cmds {}
}
proc ::$name {cmd args} "::tcc::dll::\$cmd $name \$args"
proc ::$name {cmd args} "::tcc4tcl::dll::\$cmd $name \$args"
return $name
}
namespace eval ::tcc::dll {}
proc ::tcc::dll::ccode {name argl} {
namespace eval ::tcc4tcl::dll {}
proc ::tcc4tcl::dll::ccode {name argl} {
append ${name}::code \n [lindex $argl 0]
return
}
proc ::tcc::dll::cproc {name argl} {
proc ::tcc4tcl::dll::cproc {name argl} {
foreach {pname pargs rtype body} $argl break
set code [::tcc::wrapCmd $pname $pargs $rtype cx_$pname $body]
set code [::tcc4tcl::wrapCmd $pname $pargs $rtype cx_$pname $body]
lappend ${name}::cmds $pname cx_$pname
append ${name}::code \n $code
return
}
proc ::tcc::dll::write {name argl} {
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 \
[::tcc::wrapExport $(-name) [set ${name}::cmds] $(-code)]
[::tcc4tcl::wrapExport $(-name) [set ${name}::cmds] $(-code)]
set outfile $(-dir)/$(-name)[info sharedlibextension]
::tcc::to_dll [set ${name}::code] $outfile $(-libs)
::tcc4tcl::to_dll [set ${name}::code] $outfile $(-libs)
}
#---------------------------------------------------------------------
proc ::tcc::wrap {name adefs rtype {body "#"}} {
proc ::tcc4tcl::wrap {name adefs rtype {body "#"}} {
set cname c_$name
set wname tcl_$name
array set types {}
set names {}
set cargs {}
set cnames {}
# if first arg is "Tcl_Interp*", pass it without counting it as a cmd arg
|
| ︙ | | |
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
|
-
+
-
+
-
+
-
+
|
}
if {$rtype != "ok"} {append cbody " return TCL_OK;" \n}
#puts ----code:\n$code
#puts ----cbody:\n$cbody
list $code $cbody
}
proc ::tcc::wrapCmd {tclname argl rtype cname body} {
proc ::tcc4tcl::wrapCmd {tclname argl rtype cname body} {
foreach {code cbody} [wrap $tclname $argl $rtype $body] break
append code "\nstatic int $cname"
append code {(ClientData cdata,Tcl_Interp *ip,
int objc,Tcl_Obj* CONST objv[])} " \{"
append code \n$cbody \n\}\n
}
proc ::tcc::wrapExport {name cmds {body ""}} {
proc ::tcc4tcl::wrapExport {name cmds {body ""}} {
set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp)"
append code " \{\n"
foreach {tclname cname} $cmds {
append code \
"Tcl_CreateObjCommand(interp,\"$tclname\",$cname,NULL,NULL);\n"
}
append code $body
append code "\nreturn TCL_OK;\n\}"
}
#---------------------------------------------------------------------
proc ::tcc::cproc {name adefs rtype {body "#"}} {
proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
foreach {code cbody} [wrap $name $adefs $rtype $body] break
ccode $code
set ns [namespace current]
uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody]
}
#---------------------------------------------------------------------
proc ::tcc::cdata {name data} {
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 {
|
| ︙ | | |
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
-
+
|
append cbody "Tcl_SetByteArrayObj(Tcl_GetObjResult(ip), (unsigned char*) script, $count);\n"
append cbody "return TCL_OK;" "\n"
set ns [namespace current]
uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody]
return $name
}
#-------------------------------------------------------------------
proc ::tcc::ccommand {procname anames args} {
proc ::tcc4tcl::ccommand {procname anames args} {
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 ""}
|
| ︙ | | |
365
366
367
368
369
370
371
372
373
374
375
376
377
378
|
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
-
+
-
-
+
+
|
append code "}" "\n"
set ns [namespace current]
uplevel 1 [list ${ns}::cc $code]
Log "CREATING TCL COMMAND $procname / $cname"
uplevel 1 [list $tcc(cc) command $procname $cname]
unset tcc(cc) ;# can't be used for compiling anymore
}
proc ::tcc::tk {args} {
proc ::tcc4tcl::tk {args} {
variable tcc
set tcc(tk) 1
}
::tcc::reset
namespace eval tcc {namespace export cproc ccode cdata}
::tcc4tcl::reset
namespace eval tcc4tcl {namespace export cproc ccode cdata}
|