# tcc.tcl - library routines for the tcc wrapper (Mark Janssen) namespace eval tcc { 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 ::tcc] == ""} { switch -exact -- $::tcl_platform(platform) { windows { load $dir/tcc04.dll tcc } unix { load $dir/libtcc0.4.so tcc } default {error "unsupport platform"} } } 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 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"} append code "\n int $cname" append code "(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*] { puts $cmd puts $commands($cmd) set cname $commands($cmd) 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 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] tcc_1 compile [read $f] close $f set f [open $::tcc::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} { # puts $args } proc ::tcc::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 ::tcc::ccode {code} { variable tcc Log "INJECTING CCODE" append tcc(code) $code \n } proc ::tcc::cc {code} { variable tcc if {![info exists tcc(cc)]} { set tcc(cc) tcc1 tcc $tcc::dir $tcc(cc) $tcc(cc) add_library tcl8.5 $tcc(cc) add_include_path [file join $::tcc::dir include] } Log code:$code $tcc(cc) compile $code } #----------------------------------------------------------- New DLL API proc ::tcc::dll {{name ""}} { variable count if {$name eq ""} {set name dll[incr count]} namespace eval ::tcc::dll::$name { variable code "#include \n" ;# always needed variable cmds {} } proc ::$name {cmd args} "::tcc::dll::\$cmd $name \$args" return $name } namespace eval ::tcc::dll {} proc ::tcc::dll::ccode {name argl} { append ${name}::code \n [lindex $argl 0] return } proc ::tcc::dll::cproc {name argl} { foreach {pname pargs rtype body} $argl break set code [::tcc::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} { 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)] set outfile $(-dir)/$(-name)[info sharedlibextension] ::tcc::to_dll [set ${name}::code] $outfile $(-libs) } #--------------------------------------------------------------------- proc ::tcc::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 if {[lindex $adefs 0] eq "Tcl_Interp*"} { lappend cnames ip lappend cargs [lrange $adefs 0 1] set adefs [lrange $adefs 2 end] } foreach {t n} $adefs { set types($n) $t lappend names $n lappend cnames _$n lappend cargs "$t $n" } switch -- $rtype { ok { set rtype2 "int" } string - dstring - vstring { set rtype2 "char*" } default { set rtype2 $rtype } } set code "" append code "\n#include " "\n" if {[info exists tcc(tk)] && $tcc(tk)} { append code "\#include " "\n" } if {$body ne "#"} { append code "static $rtype2" "\n" append code "${cname}([join $cargs {, }]) \{\n" append code $body append code "\}" "\n" } else { append code "#define $cname $name" "\n" } # Supported input types # Tcl_Interp* # int # long # float # double # char* # Tcl_Obj* # void* foreach x $names { set t $types($x) switch -- $t { int - long - float - double - char* - Tcl_Obj* { append cbody " $types($x) _$x;" "\n" } default {append cbody " void *_$x;" "\n"} } } if {$rtype ne "void"} { append cbody " $rtype2 rv;" "\n" } append cbody " if (objc != [expr {[llength $names] + 1}]) {" "\n" append cbody " Tcl_WrongNumArgs(ip, 1, objv, \"[join $names { }]\");\n" append cbody " return TCL_ERROR;" "\n" append cbody " }" "\n" set n 0 foreach x $names { incr n switch -- $types($x) { int { append cbody " if (Tcl_GetIntFromObj(ip, objv\[$n], &_$x) != TCL_OK)" append cbody " return TCL_ERROR;" "\n" } long { append cbody " if (Tcl_GetLongFromObj(ip, objv\[$n], &_$x) != TCL_OK)" append cbody " return TCL_ERROR;" "\n" } float { append cbody " {" "\n" append cbody " double t;" "\n" append cbody " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &t) != TCL_OK)" append cbody " return TCL_ERROR;" "\n" append cbody " _$x = (float) t;" "\n" append cbody " }" "\n" } double { append cbody " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &_$x) != TCL_OK)" append cbody " return TCL_ERROR;" "\n" } char* { append cbody " _$x = Tcl_GetString(objv\[$n]);" "\n" } default { append cbody " _$x = objv\[$n];" "\n" } } } append cbody "\n " if {$rtype != "void"} {append cbody "rv = "} append cbody "${cname}([join $cnames {, }]);" "\n" # Return types supported by critcl # void # ok # int # long # float # double # char* (TCL_STATIC char*) # string (TCL_DYNAMIC char*) # dstring (TCL_DYNAMIC char*) # vstring (TCL_VOLATILE char*) # default (Tcl_Obj*) # Our extensions # wide switch -- $rtype { void { } ok { append cbody " return rv;" "\n" } int { append cbody " Tcl_SetIntObj(Tcl_GetObjResult(ip), rv);" "\n" } long { append cbody " Tcl_SetLongObj(Tcl_GetObjResult(ip), rv);" "\n" } float - double { append cbody " Tcl_SetDoubleObj(Tcl_GetObjResult(ip), rv);" "\n" } char* { append cbody " Tcl_SetResult(ip, rv, TCL_STATIC);" "\n" } string - dstring { append cbody " Tcl_SetResult(ip, rv, TCL_DYNAMIC);" "\n" } vstring { append cbody " Tcl_SetResult(ip, rv, TCL_VOLATILE);" "\n" } default { append cbody " Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" "\n" } } 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} { 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 ""}} { 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 "#"}} { 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} { # 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" set ns [namespace current] uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody] return $name } #------------------------------------------------------------------- proc ::tcc::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 ""} 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 " "\n" } if {[info exists tcc(code)] && [string length $tcc(code)]>0} { append code $tcc(code) append code "\n" } append code "int $cname (ClientData $v(clientdata),Tcl_Interp *$v(interp)," append code "int $v(objc),Tcl_Obj *CONST $v(objv)\[\]) {" "\n" append code [lindex $args end] "\n" 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} { variable tcc set tcc(tk) 1 } ::tcc::reset namespace eval tcc {namespace export cproc ccode cdata}