Updated 2010-02-12 01:47:11 by bob

Richard Suchenwirth 2001-04-24 - Pipe servers are understood here as executables that take command lines from stdin and return results (and also errors) via stdout. Thus they can be used with [open |$pipe r+] and communicated with, from Tcl, in a simple protocol (give a line, take a line; if the result line starts with "error", the Tcl wrapper raises one with that message).

In Outsourcing C helpers, it was shown how to generate and "make" simple C programs from Tcl that do one task and exit. This is OK for small tasks (compare exec wc -l), but for more elaborate uses, e.g. where state is maintained between calls, a pipe server is more appropriate (also, starting up an executable takes about 90 milliseconds, while a call to a "living" pipe server costs ~0.85 msec on my P200/W95 - generation and compilation time was ~2.5 seconds). So here comes another C code generator in Tcl, as second part of my Xmas2000 project...
 cserver (servertype) (methods) (args)
 e.g.: cserver bitmap_sv {new {max} {..} ...} -cc acc -with {#define ONE 1}

creates a "C server" (generates code, compiles, links, generates Tcl wrapper) named servertype, where methods is a sequence of cproc-like triples of methodname argl cbody (cbody is C code to be spliced in for that method). Special (optional) methods are:

  • new - "constructor", executed at cserver startup
  • finally - "destructor", executed when cserver is closed

In any method, you may write results to stdout, but without linefeeds (in order to keep sync); you'll get a newline after the code is run. For your C codelets, you have {stdio,stdlib,string}.h included, and the macros FATAL, ERROR (for fatal and non-fatal errors - the latter won't kill the server) with a constant string, ERRORF with one printf argument, and EQ (for string comparison) available. Include other files as needed.

The argl part of a method definition emulates Tcl's proc command pretty closely: you can specify default values like {x 0}, and if you name the last argument args, it will be a pointer to the rest of the input string. If there were no rest arguments, args points to an empty string. Such a string with words separated by whitespace can be walked with the FOREACH(i,s) macro, where char *i (must be declared before) steps over the words in char *s - trying to bring some Tcl convenience into C ;-) See foo's yodel method for an example. FOREACH can't be nested, though.

The args to cserver is a flag-value pairlist to override defaults and add toplevel C code (with -with, like in cproc). The -ccflags switch also allows to add include or lib pathes. The cserver proc may fail with compile warnings (I prefer to have many warning switches on) or errors, but also if a server of that type is still running.
 (servertype) (instancename) (args)
 e.g.: bitmap_sv foo 1000

instantiates an existing C server (opens it as pipe server), where servertype is one used with the cserver command. The structure of args must match the one specified in the cserver's new method, or be empty if there was no explicit constructor.
 (instancename) (method) (args)
 e.g.: foo set 123 1

sends the message method with args to the cserver instance, and returns its result. Method can be any of those defined in the cserver command, plus the predefined

  • "empty method" (send an empty string, and you get a "self-portrait", a list specifying the server type and the list of known methods), and
  • close (guess what that does ;-).

Arguments are split on whitespace, grouping with braces is honored (took some helper C functions to 'wrap' and 'unwrap' a string). Empty words come in as literal "{}". When a pipe server is closed, the optional destructor code is executed, and the instance proc is removed as well.
 proc cserver {name methods args} {
    if [llength [info command $name]] {error "$name exists"}
    array set a [list -cc gcc -ccflags {-s -Wall -W -ansi -pedantic} \
            -dir $::env(TEMP) -with {}]
    array set a $args          ;# maybe override default settings
    set mcode ""
    set mnames [list {} close] ;# the default methods
    set constructor "\{"       ;# see note in genConstr for reason
    set destructor "\}"
    foreach {mname margs mbody} $methods {
      switch -- $mname {
       new     {set constructor "[CParseArgv $name  $margs]
       finally {set destructor "$mbody\}" ;# ignore margs}
       default {
            lappend mnames $mname
            append mcode "[addMethod $mname $margs _line_]
            {[escapeSpecials $mbody]\t\t}"
    set cbody [CTemplate]
    set with [escapeSpecials [CFunctions]$a(-with)]
    foreach i {name with constructor mnames mcode destructor} {
        regsub -all @$i $cbody [set $i] cbody
    #regsub -all {\n[ \t]+#} $cbody "\n#" cbody ;# make cpp happy?
    set nname [file nativename [file join $a(-dir) $name]]
    set    fp [open $nname.c w]
    puts  $fp $cbody
    close $fp
    eval exec $a(-cc) $a(-ccflags) [list $nname.c -o $nname]
    makeTclWrapper $name $nname
 proc escapeSpecials s {
    regsub -all {\\} $s {\\\\} s
    regsub -all {\&} $s {\\&}  s
    set s

# This is the C source framework - specifics will replace @... words
 proc CTemplate {} {
    return {/* @name.c - generated by cserver */
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
 #define EQ(_s1,_s2) !strcmp(_s1,_s2)
 #define ERROR(_s)     {printf("%s","error: "_s"\n"); fflush(stdout); continue;}
 #define ERRORF(_s,_a) {printf("error: "_s"\n",_a); fflush(stdout); continue;}
 #define FATAL(_s)     {puts("error! "_s); return -1;}
 #define FOREACH(_i,_s) for(strcpy(_line_,_s),_i=w_strtok(_line_," \t");\
                         _i;_i=w_strtok(NULL," \t"))
 #define MAXLINE 256
 #define MAXWORD 128
  int main(int argc, char *argv[]) {
     char _line_[MAXLINE]="", _cmd_[MAXWORD], _guard_;
     puts(w_wordn("",1)); fflush(stdout);
     (void)_guard_; (void)argc; (void)argv; (void)w_strtok;
     while(1) {
        fgets(_line_, sizeof(_line_), stdin);
        if(feof(stdin)) break;
        _line_[strlen(_line_)-1] = '\0';
        sscanf(_line_, "%s ", _cmd_);
        if(!strlen(_line_) || EQ(_cmd_,"{}")) {
            printf("%s","@name [email protected]}"); /* self-portrait */
        } else if(EQ(_cmd_,"close")) {
        } else ERRORF("%s? Use one of: @mnames", _cmd_);
        puts(""); fflush(stdout);
    puts(""); return 0;

# Here are helpful C functions - wrapping braced strings, getting nth word
 proc CFunctions {} {return {
    static char *w_wrap(char *s) {
      int br = 0; char *cp;
      for (cp = s; *cp; cp++) switch (*cp) {
          case '{': if(!(br++) && *(cp+1)!='}') *cp=' '; break;
          case '}': if(!(--br) && *(cp-1)!='{') *cp=' '; break;
          case ' ': case '\t': if(br) *cp='\01'; break;
      } return s;
    static char *w_unwrap(char *s) {
       char *cp;
       if(s) for(cp = s; *cp; cp++) if(*cp=='\01') *cp=' ';
       return s;
    static char *w_strtok(char *s, char *sepa) {
        if(s) w_wrap(s);
        return(w_unwrap(strtok(s, sepa)));
    static char *w_wordn(char *cp, int n) {
        char *res = NULL; int br = 0;
        if(cp && n>=1)
            for(res=cp; n>1 && *cp; cp++) {
                if(*cp=='{') br++; if(*cp=='}') br--;
                res = (!br && *cp==' ' && *(cp+1)!=' ')? n--,cp+1 : "";
        return res;

 proc CParseArgv {name argl} {
     set j 0
     set maxargs [set minargs [expr [llength $argl]+1]]
     foreach i $argl {
        incr j
         if {$i=="args" && $j==[llength $argl]} {
            incr minargs -1
            set maxargs 127
            append res "\n\t\tchar $i\[MAXLINE\]=\"\";
             int _i_;
             for(_i_=$j; _i_<argc; _i_++) {
                if(_i_<(argc-1)) strcat($i,\" \");
        } else {
                foreach {argname default} $i break
                append res "
                 char *$argname = (argc>$j)?argv\[$j\] : \"$default\";"
                incr minargs -1
     append res "\n\t if(argc<$minargs || argc>$maxargs)
              FATAL(\"usage: $name $argl\");"

# This generates C code for a general method (except con/destructors)
 proc addMethod {method margs var} {
    set _ \n\t\t\t          ;# indentation, for better looks
    set mcode "\n\n\t\t\} else if (EQ(_cmd_,\"$method\")) \{"
    set scan    "$_ char _scan_\[MAXLINE\];"
    append scan "$_ int _n_ = sscanf(w_wrap(strcpy(_scan_,$var)),\"%s"
    set argnames [list {}] ;# to get the right # commas at empty list
    set narg 1             ;# method name will be first argument
    set maxargs [set minargs [expr [llength $margs]+1]]
    foreach i $margs {
        incr narg
        if {$i=="args" && $narg==$maxargs} {
            append mcode "$_ char *$i = w_wordn($var,$narg);"
            incr minargs -1  ;# args might be empty...
            set  maxargs 127 ;#... or very long
        } else {
            foreach {argname default} $i break
            append mcode "$_ char $argname\[MAXWORD\] = \"$default\";"
            if {[llength $i]>1} {incr minargs -1}
            lappend argnames [lindex $i 0]
            append scan " %s"
    if {$minargs>1} {
        append mcode "$scan %c\",$_\t _cmd_[join $argnames ,], \\&_guard_);"
        append mcode "$_ if(_n_<$minargs || _n_>$maxargs)
                  ERRORF(\"wrong # args %d, should be '$method $margs'\",_n_);$_ "
        foreach i [lrange $argnames 1 end] {append mcode "w_unwrap($i); "}
    set mcode

# This produces a server proc, which in turn produces an instance proc
 proc makeTclWrapper {name nname} {
    regsub -all @nname {
        if [llength [info command $instname]] {error "$instname exists"}
        set fp [open [concat |[list [email protected]}] $args] r+]
        fconfigure $fp -buffering line -translation lf
        gets $fp line
        if [regexp ^error $line] {error $line}
        regsub -all @fp {
            puts @fp $args
            gets @fp line
            if [regexp ^error $line] {error $line}
            if {[lindex $args 0]=="close"} {
                close @fp
                rename [lindex [info level 0] 0] {} ;# suicide
            set line
        } $fp ibody
        proc $instname {args} $ibody
        set line
    } $nname body
    proc $name {instname args} $body
    set name

if 0 {For testing, here's an almost non-trivial example: a bitmap server which keeps a tightly-packed bit vector from 0 to the specified maximum, with a set method (without 2nd argument, it retrieves a bit's value). The yodel method was added only to test the args feature and brace wrapping. }
 catch {rename bitmap_sv ""; foo close} ;# good for repeated sourcing
 cserver bitmap_sv {
    new {{max 1024}} {
       #define LONGBITS (sizeof(long)*8/sizeof(char))
        int imax = atoi(max);
        long *map = (long*)calloc((imax+LONGBITS-1)/LONGBITS,sizeof(long));
        if(imax<=0) FATAL("max must be > 0");
        if(!map)    FATAL("no memory for map");
    yodel {first args} {
        char *i;
        printf("holladihoo '%s','%s'!", first, args);
        FOREACH(i,args) printf(" '%s'(%d)", i, strlen(i));
    llength list {
        int n = 0;
        if(list && !EQ(list,"{}")) {
            char *i;
            FOREACH(i,list) n++;
        printf("%d", n);
    lindex {list index} {
        int n = atoi(index);
        char *i;
        FOREACH(i,list) if (!(n--)) break;
        if(!i) i="";
        printf("%s", i);
    set {bitno {val -1}} {
        int ibit = atoi(bitno);
       #define BIT (1<<(ibit%LONGBITS))
       #define WORD map[ibit/LONGBITS]
        if(ibit>imax || ibit<0)
            ERRORF("out of bitmap bounds, must be in 0..%d", imax);
        if     (EQ(val, "1"))  WORD |=  BIT;
        else if(EQ(val, "0"))  WORD &= ~BIT;
        else if(EQ(val,"-1"))  sprintf(val,"%d", (0 != (WORD & BIT)));
        else                 ERROR("value must be 0 or 1, or not set");
    finally {} {free(map); printf("Thank you.");}
 bitmap_sv foo 999
 foo set 123 1
 foo yodel must be [foo set 123]

C code generators - Arts and crafts of Tcl-Tk programming - Category Foreign Interfaces