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:
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
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_), 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