[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]
             \{$mbody"}
       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
  @with
  int main(int argc, char *argv[]) {
     char _line_[MAXLINE]="", _cmd_[MAXWORD], _guard_;
     @constructor
     puts(w_wordn("",1)); fflush(stdout);
     (void)_guard_; (void)argc; (void)argv; (void)w_strtok;
     while(1) {
        fgets(_line_, sizeof(_line_)-1, stdin);
        if(feof(stdin)) break;
        _line_[strlen(_line_)-1] = '\0';
        sscanf(_line_, "%s ", _cmd_);
        if(!strlen(_line_) || EQ(_cmd_,"{}")) {
            printf("%s","@name {@mnames}"); /* self-portrait */
        } else if(EQ(_cmd_,"close")) {
            break;\
        @mcode
        } else ERRORF("%s? Use one of: @mnames", _cmd_);
        puts(""); fflush(stdout);
    }
    @destructor
    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_++) {
                strcat($i,argv\[_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 {@nname}] $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");
        printf(val);
    }
    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]