From 9f10950ab67992a0ff2304639673c2fc97744e0d Mon Sep 17 00:00:00 2001 From: ian Date: Sat, 31 Aug 2002 12:56:18 +0000 Subject: [PATCH] Generates tables. Does not compile. --- base/tables-examples.tct | 9 +- base/tcmdifgen | 191 +++++++++++++++++++++++++++++++++++---- base/troglodyte-Makefile | 18 +++- 3 files changed, 193 insertions(+), 25 deletions(-) diff --git a/base/tables-examples.tct b/base/tables-examples.tct index 53fd239..553f768 100644 --- a/base/tables-examples.tct +++ b/base/tables-examples.tct @@ -1,5 +1,8 @@ -Type hb: Tcl_Obj/*hbytes*/ *@ -Type hbv: Tcl_Obj/*hbytes*/ *@ +Type hb: HBytes_Value @ +Init hb @.start=0; @.end=0; +Type hbv: HBytes_Value *@ + +H-Include "hbytes.h" Table hbytes raw2h @@ -31,7 +34,7 @@ Table hbytes => hb pkcs5 meth enum(PadMethodInfo,padmethodinfos) - arg ... + obj ... blockcipher encrypt charfrom("de") v hbv diff --git a/base/tcmdifgen b/base/tcmdifgen index da7b428..4f4d154 100755 --- a/base/tcmdifgen +++ b/base/tcmdifgen @@ -7,11 +7,23 @@ parse('builtins','DATA'); while (@ARGV) { $_= shift @ARGV; - die if m/^\-/; - $x= new IO::File $_,'r' or die "$_: $!\n"; - parse($_,$x); + if (m/^\-p(\w+)/) { + $prefix= $1; + } elsif (m/^\-w(c|h)$/) { + $write= $1; + } elsif (m/^\-o(.+)$/) { + $output= $1; + } elsif (m/^\-/) { + die "unknown option $_\n"; + } else { + if (!defined $prefix) { $prefix= $_; $prefix =~ s/\.[^.]+$//; } + $x= new IO::File $_,'r' or die "$_: $!\n"; + parse($_,$x); + } } +die "must say -w\n" if !defined $write; + sub parse ($$) { my ($wh,$f) = @_; while (defined($_= $f->getline)) { @@ -32,6 +44,8 @@ sub parse ($$) { if (@i==0 && m/^Table\s+(\w+)$/) { $c_table= $1; undef $c_entry; + } elsif (@i==0 && m/^(C|H)\-Include\s+(\S.*)$/) { + o(lc $1, 30, "#include $2\n"); } elsif (@i==1 && m/^([a-z]\w*)$/ && defined $c_table) { $c_entry= $1; $tables{$c_table}{$c_entry}{A} = [ ]; @@ -62,9 +76,9 @@ sub parse ($$) { badsyntax($wh,$.,"bad type name/args"); } $types{$typename}= { C => $ctype, X => $xtypeargs }; + } elsif (@i==0 && s/^Init\s+(\w+)\s+(\S.*)//) { + $type_init{$1}= $2; } else { - printf STDERR ">%d<\n", - scalar m/^Type\s+([^\:]+)\:\s+(\S.*)$/; badsyntax($wh,$., sprintf "bad directive (indent level %d)", scalar @i); } @@ -76,28 +90,166 @@ sub parse ($$) { #print Dumper(\%tables),"\n"; #print Dumper(\%types),"\n"; +foreach $t (sort keys %types) { + $type= $types{$t}; + $c= $type->{C}; + $xta= $type->{X}; + $decl= "int pat_$t(Tcl_Interp, Tcl_Obj*, "; + $decl .= subst_in('*', $c, "type $t"); + $decl .= ", $xta", if length $xta; + $decl .= ")\n"; + o('h',160, $decl); + + $decl= "Tcl_Obj *ret_$t(Tcl_Interp, ".subst_in('',$c).");\n"; + o('h',170, $decl); +} + foreach $c_table (sort keys %tables) { $r_table= $tables{$c_table}; foreach $c_entry (keys %$r_table) { $r_entry= $r_table->{$c_entry}; - $pa_decl= "int fn_${c_table}_${c_entry}("; - @pa_al= (); + $pa_decl= "int pa_${c_table}_${c_entry}(ClientData cd,". + " Tcl_Interp ip, int objc, Tcl_Obj *const *objv)"; + $do_decl= "int do_${c_table}_${c_entry}("; + @do_al= (); + @do_aa= qw(cd ip); + $pa_init= ''; + $pa_argc= " objc--; objv++;\n"; + $pa_vars= " int rc;\n"; + $pa_body= ''; + $pa_rslt= ''; + $pa_free= ''; + $pa_fini= ''; + $any_mand= 0; + $any_optl= 0; + $any_eerr= 0; foreach $arg (@{ $r_entry->{A} }) { - push @pa_al, make_decl($arg->{N}, $arg->{T}, $arg->{A}); + $n= $arg->{N}; + $t= $arg->{T}; + $a= $arg->{A}; + push @do_al, make_decl($n, $t, $arg->{A}); + $pa_vars .= make_decl_init("a_$n", $t, $a, \$pa_init); + if ($arg->{O}) { + if ($any_mand) { + $pa_argc .= " if (objc < $any_mand) {". + " e=\"too few args\"; goto e_err; }\n"; + $pa_body .= " objc -= $any_mand;\n"; + $any_mand= 0; + $any_eerr= 0; + } + $pa_body .= " if (!objc--) goto end_optional;\n"; + $any_optl= 1; + } else { + $any_mand++; + } + $pa_body .= " rc= pat_$t(ip, *objv++, &a_$n"; + if ($t eq 'enum') { + $a =~ m/\,/ or die; $a = "$', sizeof($`)"; + } + $pa_body .= ", ".$a if length $a; + $pa_body .= "); if (rc) goto rc_err;\n"; + push @do_aa, "a_$n"; } if (exists $r_entry->{V}) { $va= $r_entry->{V}; - push @pa_al, make_decl_c("${va}c", 'int @'); - push @pa_al, make_decl_c("${va}v", 'Tcl_Obj *const *@'); + push @do_al, subst_in("${va}c", 'int @'); + push @do_al, subst_in("${va}v", 'Tcl_Obj *const *@'); + push @do_aa, "objc-1", "objv+1"; + } else { + $pa_body .= " if (--objc) { e=\"too many args\"; goto e_err; }\n"; + $any_eerr= 0; + } + if ($any_optl) { + $pa_body .= "end_optional:\n"; } if (exists $r_entry->{R}) { $t= $r_entry->{R}; - push @pa_al, make_decl("*result", $t); + push @do_al, make_decl("*result", $t); + $pa_vars .= make_decl_init("result", $t, '', \$pa_init); + push @do_aa, "&result"; + $pa_rslt .= " Tcl_SetObjResult(ip, ret_$t(ip, result));\n"; } - $pa_decl .= join ', ', @pa_al; - $pa_decl .= ");\n"; - print $pa_decl or die $!; + $pa_body .= "\n"; + $pa_body .= " rc= do_${c_table}_${c_entry}("; + $pa_body .= join ', ', @do_aa; + $pa_body .= ");\n"; + $pa_body .= " if (rc) goto rc_err;\n"; + + $pa_rslt .= " rc= TCL_OK;\n\n"; + $pa_rslt .= "rc_err:\n"; + + $pa_fini .= " return rc;\n"; + if ($any_eerr) { + $pa_vars .= " const char *e;\n"; + $pa_fini .= "\n"; + $pa_fini .= "e_err:"; + $pa_fini .= " setstringresult(ip,e);"; + $pa_fini .= " rc= TCL_ERROR; goto rc_err;\n"; + } + $pa_vars .= "\n"; + $pa_init .= "\n" if length $pa_init; + $pa_fini .= "}\n\n"; + o('c',100, + "static ".$pa_decl." {\n". + $pa_vars. + $pa_init. + $pa_argc. + $pa_body. + $pa_rslt. + $pa_free. + $pa_fini); + $do_decl .= join ', ', @do_al; + $do_decl .= ")"; + o('h',100, $do_decl.";\n") or die $!; + } +} + +o(c, 0, "#include \"$prefix.h\"\n"); + +o(h, 0, + "#ifndef INCLUDED_\U${prefix}_H\n". + "#define INCLUDED_\U${prefix}_H\n\n". + "#include \n"); + +o(h, 999, + "#endif /*INCLUDED_\U${prefix}_H*/\n"); + +if (defined $output) { + $oh= new IO::File "$output.tmp", 'w' or die "$output.tmp: $!\n"; +} else { + $oh= 'STDOUT'; +} + +print $oh "/* AUTOGENERATED - DO NOT EDIT */\n" or die $!; +foreach $pr (sort keys %{ $o{$write} }) { + print $oh "\n" or die $!; + print $oh $o{$write}{$pr} or die $!; +} + +die if $oh->error; +die $! unless $oh->close; + +if (defined $output) { + rename "$output.tmp", $output or die $!; +} + +sub o ($$) { + my ($wh,$pr,$s) = @_; + $o{$wh}{sprintf "%010d", $pr} .= $s; +} + +sub make_decl_init ($$$$) { + my ($n, $t, $a, $initcode) = @_; + my ($o,$init); + $o= make_decl($n,$t,$a); + if (exists $type_init{$t}) { + $init= $type_init{$t}; + $$initcode .= " ".subst_in("$n", $init)."\n" + if length $init; + } else { + $o .= ' =0'; } + return " ".$o.";\n"; } sub make_decl ($$$) { @@ -110,13 +262,14 @@ sub make_decl ($$$) { defined $types{$t} or die "unknown type $t\n"; $c= $types{$t}{C}; } - return make_decl_c($n,$c); + return subst_in($n,$c); } -sub make_decl_c ($$) { - my ($n, $c) = @_; - $c =~ m/\@/ or die "$c for $n?"; - return "$`$n$'"; +sub subst_in ($$$) { + my ($val, $pat, $why) = @_; + $pat =~ m/\@/ or die "$pat for $val in $why ?"; + $pat =~ s/\@/$val/g; + return $pat; } sub badsyntax ($$$) { diff --git a/base/troglodyte-Makefile b/base/troglodyte-Makefile index 765d5e4..9c67ece 100644 --- a/base/troglodyte-Makefile +++ b/base/troglodyte-Makefile @@ -1,17 +1,29 @@ -OBJS= hbytes.o \ +OBJS= tables.o \ + hbytes.o \ enum.o -HDRS= hbytes.h +HDRS= hbytes.h \ + $(AUTO_HDRS) + +AUTO_HDRS= tables.h +AUTO_SRCS= tables.c +AUTOS= $(AUTO_HDRS) $(AUTO_SRCS) TARGETS= hbytes.so CFLAGS= -g -Wall -O -all: $(TARGETS) +all: $(TARGETS) $(AUTOS) hbytes.so: $(OBJS) $(CC) $(CFLAGS) $(LDFLAGS) -o $@ -shared $(OBJS) $(LDLIBS) +%.c: %.tct + ./tcmdifgen -wc -o$@ $< + +%.h: %.tct + ./tcmdifgen -wh -o$@ $< + %.o: %.c $(HDRS) $(CC) $(CFLAGS) $(CPPFLAGS) -o $@ -c $< -- 2.30.2