Extending Tcl in C from Tcl

In Extending Tcl in C from Tcl, Richard Suchenwirth presents cextend, a command that generates a custom Tcl interpreter that exposes a function written in C

For a much simpler way to do this, see tcltcc :^)

Richard Suchenwirth - Here's the third part of my Xmas2000 project that dealt with C code generators in Tcl (see also Outsourcing C helpers, Pipe servers in C from Tcl). The following script generates a custom tclsh or wish as C source, compiles, and links that. You specify the desired extensions like this:

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

where both "parameter" fields are pairlists of type varname, type being one of char*, double, int, long. cbody holds literal C code, which can use the variables from inparameters and also define more as needed. The outparameter field specifies which single variable (and of which type) to return as result. Such specification is slightly clumsier that either Tcl or C, but still very compact compared to the 15 lines of C code generated for this function ;-)

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.

Category Foreign Interfaces