cxtend -Tk 1 -name mywish -cc gcc -ccflags {-s -Wall} -cmd {
plus1 {int i} {i++;} {int i}
strrev {char* s} {
char *cp0, *cp1, t;
for(cp0=s, cp1=s+strlen(s)-1; cp1>cp0; cp0++, cp1--) {
t=*cp0; *cp0=*cp1; *cp1=t;
}
} {char* s}
} -dir .and get a new wish that also understands the plus1 command to increment a numeric value (example from Brent Welch's book), and strrev to revert an 8-bit string in place. In contrast to the earlier cproc and cserver, the specification of a new command is now in four parts:- name inparameters cbody outparameter
proc cxtend {args} {
array set a {
-name {} -Tk 1 -cc gcc -ccflags {-Wall -s -pedantic}
-dir . -cmd {}
}
array set a $args
if $a(-Tk) {
if {$a(-name) eq {}} {set a(-name) cxwish}
set i tk; set main Tk_Main
} else {
if {$a(-name) eq {}} {set a(-name) cxtclsh}
set i tcl; set main Tcl_Main
}
set nname [file nativename [file join $a(-dir) $a(-name)]]
set fp [open $nname.c w]
puts $fp "/* $a(-name).c - Generated by cxtend */"
puts $fp "#include <$i.h>"
set cmds [list]
foreach {cname cin cbody cout} $a(-cmd) {
puts $fp [genCmd $cname $cin $cbody $cout]
lappend cmds $cname
}
puts $fp "int AppInit(Tcl_Interp *interp) \{
if(Tcl_Init(interp) == TCL_ERROR) return TCL_ERROR;"
if $a(-Tk) {
puts $fp "\t\tif(Tk_Init(interp) == TCL_ERROR) return TCL_ERROR;"
}
foreach i $cmds {
puts $fp "\t\tTcl_CreateObjCommand(interp,\"$i\",${i}cmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);"
}
puts $fp "
Tcl_SetVar(interp,\"tcl_rcFileName\",\"~/.wishrc\",TCL_GLOBAL_ONLY);
return TCL_OK;
\}
int main(int argc, char *argv\[\]) {
${main}(argc, argv, AppInit); return 0; }"
close $fp
puts "$a(-cc) $a(-ccflags) [list $nname.c -o $nname]"
eval exec $a(-cc) $a(-ccflags) [list $nname.c -o $nname]
set nname
}
proc genCmd {cname cin cbody cout} {
array set what {char* String double Double int Int long Long}
set res "int ${cname}cmd(ClientData cd, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv\[\]) \{
Tcl_Obj *optr;
"
set nargs 1; set names [list]
foreach {type name} $cin {
if {![info exists what($type)]} {error "bad type $type"}
append res "$type $name; "
lappend names $name
incr nargs
}
append res "\n\tif(objc!=$nargs) \{
Tcl_WrongNumArgs(interp,1,objv,\"Usage: $cname $names\");
return TCL_ERROR;
\}
"
set i 0
foreach {type name} $cin {
if ![regexp {[*]$} $type] {
append res "
if(Tcl_Get$what($type)FromObj(interp,objv\[[incr i]\],&$name)!=TCL_OK)
return TCL_ERROR;
"
} else {
append res "
if(!(s=Tcl_GetStringFromObj(objv\[[incr i]\],NULL)))
return TCL_ERROR;
"
}
}
foreach {type name} $cout break
if {$type=="char*"} {set name $name,-1}
append res "
{$cbody}
optr = Tcl_GetObjResult(interp);
Tcl_Set$what($type)Obj(optr, $name);
return TCL_OK;
\}
"
}Disclaimer: Holidays are over, and on the last evening I brought this to generate a nice-looking and well-compiling source, but linking was only possible under bash (makes a slim 3.5K executable with the -s option), not from inside Tcl. Lib-path specification problems. Worked alright on Sun after I added platform-specific defaults:if {$::tcl_platform(os)=="SunOS"} {
append a(-ccflags) " -I/tools/RC/include/ -I/usr/openwin/include \
-L/tools/RC/lib -ltcl -ltk"
}Afterthought: To extend a running wish application with compiled C code, it would be smarter to make a shared lib/DLL from the generated source and load that. Hmm - more to learn...The Embedded C application [1] was designed to allow you to include C code in your scripts. It worked on OSF and SunOS.
