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
(servertype) (instancename) (args) e.g.: bitmap_sv foo 1000instantiates 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 1sends 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 ;-).
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
