Diff

Differences From Artifact [c56e45f7c0]:

To Artifact [40e66e4fa1]:


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
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] == ""} {
       load [file join $dir tcctcl[info sharedlibextension]] tcc
   if {[info command ::tcc4tcl] == ""} {
       load [file join $dir tcltcc[info sharedlibextension]] tcc4tcl
   }
   set libs $dir/lib
   set includes $dir/include
   set count 0
   set command_count 0
   array set commands {}
   proc new {} {
       variable dir
       variable count
       set handle tcc_[incr count]
       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"}
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
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







-
-
+
+





-
+


-
+









-
+


-
+






-
-
+
+

-
+




-
+



-
+

-
+





-
+


-
+



-
+


-
-
+
+



-
+

-
+




-
+






-
+

-
+


-
+







           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 .
    foreach lib $libs {tcc_1 add_library $lib}
    if {$::tcl_platform(platform) eq "windows"} {
        tcc_1 define DLL_EXPORT {__declspec(dllexport)} 
        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]
      $tcc(cc) add_include_path [file join $::tcc4tcl::dir include]
  }
  Log code:$code
  $tcc(cc) compile $code
}
#----------------------------------------------------------- New DLL API
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
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
297
298
299
300
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
297
298
299
300







-
+






-
+










-
+






-
+







  }
  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 {
317
318
319
320
321
322
323
324

325
326
327
328
329
330
331
317
318
319
320
321
322
323

324
325
326
327
328
329
330
331







-
+







  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 ""}
361
362
363
364
365
366
367
368

369
370
371
372
373


374
361
362
363
364
365
366
367

368
369
370
371


372
373
374







-
+



-
-
+
+

  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}