# 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 ""} {pkgName ""}} {
variable dir
variable count
set handle ::tcc4tcl::tcc_[incr count]
if {$output == ""} {
set type "memory"
} else {
if {$pkgName == ""} {
set type "exe"
} else {
set type "package"
}
}
array set $handle [list code "" type $type filename $output package $pkgName add_inc_path "" add_lib_path "" add_lib ""]
proc $handle {cmd args} [string map [list @@HANDLE@@ $handle] {
set handle {@@HANDLE@@}
if {$cmd == "go"} {
set args [list 0 {*}$args]
}
if {$cmd == "code"} {
set cmd "go"
set args [list 1 {*}$args]
}
set callcmd ::tcc4tcl::_$cmd
if {[info command $callcmd] == ""} {
return -code error "unknown or ambiguous subcommand \"$cmd\": must be cproc, linktclcommand, code, tk, or go"
}
uplevel 1 [list $callcmd $handle {*}$args]
}]
return $handle
}
proc _linktclcommand {handle cSymbol tclCommand} {
upvar #0 $handle state
lappend state(procs) $cSymbol $tclCommand
}
proc _add_include_path {handle args} {
upvar #0 $handle state
lappend state(add_inc_path) {*}$args
}
proc _add_library_path {handle args} {
upvar #0 $handle state
lappend state(add_lib_path) {*}$args
}
proc _add_library {handle args} {
upvar #0 $handle state
lappend state(add_lib) {*}$args
}
proc _cwrap {handle name adefs rtype} {
upvar #0 $handle state
set wrap [uplevel 1 [list ::tcc4tcl::wrap $name $adefs $rtype "#" "" 1]]
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 _cproc {handle name adefs rtype {body "#"}} {
upvar #0 $handle state
set wrap [uplevel 1 [list ::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 "\n"
}
proc _tk {handle} {
upvar #0 $handle state
set state(tk) 1
}
proc _delete {handle} {
rename $handle ""
unset $handle
}
proc _proc {handle cname adefs rtype body args} {
# Convert body into a C-style string
binary scan $body H* cbody
set cbody [regsub -all {..} $cbody {\\x&}]
# Parse optional arguments
foreach {argname argval} $args {
switch -- $argname {
"-error" {
set returnErrorValue $argval
}
}
}
# Argument definitions (in C style) initialization
set adefs_c [list]
# Names of all arguments initialization
set args [list]
# If we aren't creating a new interp, it must be the first argument
# If the definition of this proc already includes the interp
# argument, use it -- otherwise add one
set newInterp 1
foreach {type var} $adefs {
if {$type == "Tcl_Interp*"} {
set newInterp 0
set interp_name $var
break
}
}
# Create the C-style argument definition
foreach {type var} $adefs {
lappend adefs_c [list $type $var]
set types($var) $type
if {$type == "Tcl_Interp*"} {
continue
}
lappend args $var
}
if {[llength $adefs_c] == 0} {
set adefs_c "void"
} else {
set adefs_c [join $adefs_c {, }]
}
# Determine how to return in failure
if {$rtype != "void"} {
if {[info exists returnErrorValue]} {
set return_failure "return(${returnErrorValue})"
} else {
switch -- $rtype {
int - long - Tcl_WideInt {
set return_failure "return(-1)"
}
ok {
set return_failure "return(TCL_ERROR)"
}
double - float {
set return_failure "return(($rtype) ((($rtype) 1.0) / (($rtype) 0.0)))"
}
default {
set return_failure "return(NULL)"
}
}
}
} else {
set return_failure "return"
}
# Define the C function
_ccode $handle "$rtype $cname\($adefs_c) \{"
## Define the Tcl return value checking variable
_ccode $handle " int tclrv;"
## If the interpreters return value is relevant, create a variable to store it
if {$rtype != "ok" && $rtype != "void"} {
_ccode $handle " Tcl_Obj *rv_interp;"
}
## If we are returning a value, declare a variable for that
if {$rtype != "void"} {
_ccode $handle " $rtype rv;"
}
## If we need to create a new interpreter, do so
if {$newInterp} {
set interp_name "ip"
_ccode $handle " Tcl_Interp *${interp_name};"
}
# Declare Tcl_Obj variables
_ccode $handle " Tcl_Obj *_[join $args {, *_}];"
_ccode $handle ""
# Create a new interp if needed, otherwise create a temporary procedure
if {$newInterp} {
_ccode $handle " ${interp_name} = Tcl_CreateInterp();"
_ccode $handle " if (!${interp_name}) $return_failure;"
_ccode $handle ""
set procname ""
} else {
set procname "::tcc4tcl::tmp::proc[clock clicks]"
set cbody "namespace eval ::tcc4tcl {}; namespace eval ::tcc4tcl::tmp {}; proc ${procname} {$args} { $cbody }"
}
# Process all arguments
foreach arg $args {
set type $types($arg)
switch -- $type {
int - long - Tcl_WideInt - float - double {
switch -- $type {
float {
set convCmd Double
}
Tcl_WideInt {
set convCmd WideInt
}
default {
set convCmd [string totitle $type]
}
}
_ccode $handle " _$arg = Tcl_New${convCmd}Obj($arg);"
_ccode $handle " if (!_$arg) $return_failure;"
}
char* {
if {[info exists types(${arg}_MemberCount)] && [info exists types(${arg}_MemberLength)]} {
_ccode $handle " _$arg = Tcl_NewByteArrayObj($arg, ${arg}_MemberCount * ${arg}_MemberLength);"
} elseif {[info exists types(${arg}_Length)]} {
_ccode $handle " _$arg = Tcl_NewByteArrayObj($arg, ${arg}_Length);"
} else {
_ccode $handle " _$arg = Tcl_NewStringObj($arg, -1);"
}
}
Tcl_Obj* {
_ccode $handle " _$arg = $arg;"
}
default {
return -code error "Unknown type: $type"
}
}
if {$procname == ""} {
_ccode $handle " if (!Tcl_ObjSetVar2(${interp_name}, Tcl_NewStringObj(\"${arg}\", -1), NULL, _$arg, 0)) $return_failure;"
}
}
_ccode $handle ""
# Evaluate script
if {$procname != ""} {
_ccode $handle " static int proc_defined = 0;"
_ccode $handle " if (proc_defined == 0) \{"
_ccode $handle " proc_defined = 1;"
set extra_space " "
} else {
set extra_space ""
}
_ccode $handle "${extra_space} tclrv = Tcl_Eval($interp_name, \"$cbody\");"
_ccode $handle "${extra_space} if (tclrv != TCL_OK && tclrv != TCL_RETURN) $return_failure;"
if {$procname != ""} {
_ccode $handle " \}"
set i 0
_ccode $handle " Tcl_Obj *objv\[[expr {[llength $args] + 1}]\];"
_ccode $handle " objv\[$i\] = Tcl_NewStringObj(\"$procname\", -1);"
foreach arg $args {
incr i
_ccode $handle " objv\[$i\] = _$arg;"
}
_ccode $handle " tclrv = Tcl_EvalObjv($interp_name, [expr {[llength $args] + 1}], objv, 0);"
}
_ccode $handle " if (tclrv != TCL_OK && tclrv != TCL_RETURN) $return_failure;"
_ccode $handle ""
# Handle return value
if {$rtype != "ok" && $rtype != "void"} {
_ccode $handle " rv_interp = Tcl_GetObjResult(${interp_name});"
}
switch -- $rtype {
void { }
ok {
_ccode $handle " rv = 0;"
}
int {
_ccode $handle " if (Tcl_GetIntFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
}
long {
_ccode $handle " if (Tcl_GetLongFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
}
Tcl_WideInt {
_ccode $handle " if (Tcl_GetWideIntFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
}
float {
_ccode $handle " {"
_ccode $handle " double t;"
_ccode $handle " if (Tcl_GetDoubleFromObj(ip, rv_interp, &t) != TCL_OK) $return_failure;"
_ccode $handle " rv = (float) t;"
_ccode $handle " }"
}
double {
_ccode $handle " if (Tcl_GetDoubleFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
}
char* {
_ccode $handle " rv = Tcl_GetString(rv_interp);"
}
Tcl_Obj* {
_ccode $handle " rv = rv_interp;"
}
}
# Cleanup created interp if needed
if {$newInterp} {
_ccode $handle " Tcl_DeleteInterp(${interp_name});"
}
# Return value
_ccode $handle ""
if {$rtype != "void"} {
_ccode $handle " return(rv);"
} else {
_ccode $handle " return;"
}
_ccode $handle "\}"
}
proc _go {handle {outputOnly 0}} {
variable dir
upvar #0 $handle state
set code $state(code)
if {$state(type) == "exe" || $state(type) == "dll"} {
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
set code "int _initProcs(Tcl_Interp *interp);\n\n$code"
}
}
if {[info exists state(tk)]} {
set code "#include <tk.h>\n$code"
}
set code "#include <tcl.h>\n\n$code"
# Append additional generated code to support the output type
switch -- $state(type) {
"memory" {
# No additional code needed
if {$outputOnly} {
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
foreach {procname cname} $state(procs) {
append code "/* Immediate: Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL); */\n"
}
}
}
}
"exe" - "dll" {
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
append code "int _initProcs(Tcl_Interp *interp) \{\n"
foreach {procname cname} $state(procs) {
append code " Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
}
append code "\}"
}
}
"package" {
set packageName [lindex $state(package) 0]
set packageVersion [lindex $state(package) 1]
if {$packageVersion == ""} {
set packageVersion "0"
}
append code "int [string totitle $packageName]_Init(Tcl_Interp *interp) \{\n"
append code "#ifdef USE_TCL_STUBS\n"
append code " if (Tcl_InitStubs(interp, TCL_VERSION, 0) == 0L) \{\n"
append code " return TCL_ERROR;\n"
append code " \}\n"
append code "#endif\n"
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
foreach {procname cname} $state(procs) {
append code " Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
}
}
append code " Tcl_PkgProvide(interp, \"$packageName\", \"$packageVersion\");\n"
append code " return(TCL_OK);\n"
append code "\}"
}
}
if {$outputOnly} {
return $code
}
# Generate output code
switch -- $state(type) {
"package" {
set tcc_type "dll"
}
default {
set tcc_type $state(type)
}
}
if {[info command ::tcc4tcl] == ""} {
return -code error "Unable to load tcc4tcl library"
}
::tcc4tcl $dir $tcc_type tcc
foreach path $state(add_inc_path) {
tcc add_include_path $path
}
foreach path $state(add_lib_path) {
tcc add_library_path $path
}
foreach lib $state(add_lib) {
tcc add_library $lib
}
switch -- $state(type) {
"memory" {
tcc compile $code
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
foreach {procname cname} $state(procs) {
tcc command $procname $cname
}
}
}
"package" - "dll" - "exe" {
switch -glob -- $::tcl_platform(os)-$::tcl_platform(pointerSize) {
"Linux-8" {
tcc add_library_path "/lib64"
tcc add_library_path "/usr/lib64"
tcc add_library_path "/lib"
tcc add_library_path "/usr/lib"
}
"SunOS-8" {
tcc add_library_path "/lib/64"
tcc add_library_path "/usr/lib/64"
tcc add_library_path "/lib"
tcc add_library_path "/usr/lib"
}
"Linux-*" {
tcc add_library_path "/lib32"
tcc add_library_path "/usr/lib32"
tcc add_library_path "/lib"
tcc add_library_path "/usr/lib"
}
default {
if {$::tcl_platform(platform) == "unix"} {
tcc add_library_path "/lib"
tcc add_library_path "/usr/lib"
}
}
}
tcc compile $code
tcc output_file $state(filename)
}
}
# Cleanup
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 ""} {includePrototype 0}} {
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]
}
foreach {t n} $adefs {
set types($n) $t
lappend varnames $n
lappend cnames _$n
lappend cargs "$t $n"
}
# Handle return type
switch -- $rtype {
ok {
set rtype2 "int"
}
string - dstring - vstring {
set rtype2 "char*"
}
default {
set rtype2 $rtype
}
}
# Create wrapped function
if {[llength $cargs] != 0} {
set cargs_str [join $cargs {, }]
} else {
set cargs_str "void"
}
if {$body ne "#"} {
append code "static $rtype2 ${cname}($cargs_str) \{\n"
append code $body
append code "\}\n"
} else {
set cname [namespace tail $name]
if {$includePrototype} {
append code "$rtype2 ${cname}($cargs_str);\n"
}
}
# Create wrapper function
## Supported input types
## Tcl_Interp*
## int
## long
## float
## double
## char*
## Tcl_Obj*
## void*
## Tcl_WideInt
foreach x $varnames {
set t $types($x)
switch -- $t {
int - long - float - double - char* - Tcl_WideInt - 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 $varnames] + 1}]) {" "\n"
append cbody " Tcl_WrongNumArgs(ip, 1, objv, \"[join $varnames { }]\");\n"
append cbody " return TCL_ERROR;" "\n"
append cbody " }" "\n"
set n 0
foreach x $varnames {
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"
}
Tcl_WideInt {
append cbody " if (Tcl_GetWideIntFromObj(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"
# Call wrapped function
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*)
# Tcl_WideInt
switch -- $rtype {
void - ok - int - long - float - double - Tcl_WideInt {}
default {
append cbody " if (rv == NULL) {\n"
append cbody " return(TCL_ERROR);\n"
append cbody " }\n"
}
}
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" }
Tcl_WideInt { append cbody " Tcl_SetWideIntObj(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"
}
append cbody "}" "\n"
return [list $code $cbody $wname]
}
namespace eval tcc4tcl {namespace export cproc new}
package provide tcc4tcl "@@VERS@@"