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 [ftp://ftp.reed.edu/pub/users/greaber/ec-0.1.tar.gz] was designed 
to allow you to include C code in your scripts.  It worked on OSF and SunOS.



<<categories>> Foreign Interfaces