X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=chiark-tcl.git;a=blobdiff_plain;f=base%2Ftcmdifgen;h=3a317549d62e7c003caa17ee5afa225847b0a01f;hp=4f4d154d9a57c187539a11ffa993a2b4cf305dd7;hb=310a482133795d0bee9621003c0a0b3813a47037;hpb=9f10950ab67992a0ff2304639673c2fc97744e0d diff --git a/base/tcmdifgen b/base/tcmdifgen index 4f4d154..3a31754 100755 --- a/base/tcmdifgen +++ b/base/tcmdifgen @@ -24,6 +24,12 @@ while (@ARGV) { die "must say -w\n" if !defined $write; +sub zilch () { + undef $c_table; + undef $c_entryextra; + undef $c_of; +} + sub parse ($$) { my ($wh,$f) = @_; while (defined($_= $f->getline)) { @@ -42,12 +48,33 @@ sub parse ($$) { } if (@i==0 && m/^Table\s+(\w+)$/) { + zilch(); $c_table= $1; - undef $c_entry; + $table_x{$c_table}{C}= 'ParserCommandTableEntry'; + $entrytype_x{ParserCommandTableEntry}= ''; + } elsif (@i==0 && m/^Untabled$/) { + zilch(); + $c_table= ''; } 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; + } elsif (@i==1 && m/^Of\s+(\w+)$/ && defined $c_table) { + die unless length $c_table; + $table_x{$c_table}{C}= $1; + $entrytype_x{$1}= ''; + } elsif (@i==0 && m/^EntryExtra\s+(\w+)$/) { + zilch(); + $c_entryextra= $1; + } elsif (@i>=1 && defined $c_entryextra) { + $entrytype_x{$c_entryextra} .= " $_\n"; + } elsif (@i==1 && m/^[a-z].*$/ && defined $c_table) { + if (m/^\w+$/) { + $c_entry= $_; + } elsif (m/^(\w+)\s+(\S.*)$/) { + $c_entry= $1; + $tables{$c_table}{$c_entry}{I} .= ", $2"; + } else { + badsyntax($wh,$.,"bad entry"); + } $tables{$c_table}{$c_entry}{A} = [ ]; } elsif (@i==2 && m/^(\w+)\s+\.\.\.$/ && defined $c_entry) { $tables{$c_table}{$c_entry}{V}= $1; @@ -94,24 +121,37 @@ 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= "int pat_$t(Tcl_Interp*, Tcl_Obj*, "; + $decl .= subst_in_decl('*', $c, "type $t"); $decl .= ", $xta", if length $xta; - $decl .= ")\n"; + $decl .= ");\n"; o('h',160, $decl); - $decl= "Tcl_Obj *ret_$t(Tcl_Interp, ".subst_in('',$c).");\n"; + $decl= "Tcl_Obj *ret_$t(Tcl_Interp*, ".subst_in_decl('',$c).");\n"; o('h',170, $decl); } +foreach $c_entrytype (sort keys %entrytype_x) { + o('h', 20, "typedef struct $c_entrytype $c_entrytype;\n"); + o('h', 100, + "struct $c_entrytype {\n". + " const char *name;\n". + " Tcl_ObjCmdProc *func;\n". + $entrytype_x{$c_entrytype}. + "};\n\n"); +} + foreach $c_table (sort keys %tables) { $r_table= $tables{$c_table}; + $x_table= $table_x{$c_table}; + $op_tab= ''; + foreach $c_entry (keys %$r_table) { $r_entry= $r_table->{$c_entry}; $pa_decl= "int pa_${c_table}_${c_entry}(ClientData cd,". - " Tcl_Interp ip, int objc, Tcl_Obj *const *objv)"; + " Tcl_Interp *ip, int objc, Tcl_Obj *const *objv)"; $do_decl= "int do_${c_table}_${c_entry}("; - @do_al= (); + @do_al= ('ClientData cd', 'Tcl_Interp *ip'); @do_aa= qw(cd ip); $pa_init= ''; $pa_argc= " objc--; objv++;\n"; @@ -135,29 +175,35 @@ foreach $c_table (sort keys %tables) { " e=\"too few args\"; goto e_err; }\n"; $pa_body .= " objc -= $any_mand;\n"; $any_mand= 0; - $any_eerr= 0; + $any_eerr= 1; } $pa_body .= " if (!objc--) goto end_optional;\n"; $any_optl= 1; } else { $any_mand++; } - $pa_body .= " rc= pat_$t(ip, *objv++, &a_$n"; + $paarg= "&a_$n"; + $pafin= ''; if ($t eq 'enum') { + $pa_vars .= " const void *v_$n= 0;\n"; + $paarg= "&v_$n"; + $pafin= "\n a_$n= v_$n; "; $a =~ m/\,/ or die; $a = "$', sizeof($`)"; + o('h', 210, "extern const $` $'".'[]'.";\n"); } + $pa_body .= " rc= pat_$t(ip, *objv++, $paarg"; $pa_body .= ", ".$a if length $a; - $pa_body .= "); if (rc) goto rc_err;\n"; + $pa_body .= ");$pafin if (rc) goto rc_err;\n"; push @do_aa, "a_$n"; } if (exists $r_entry->{V}) { $va= $r_entry->{V}; - push @do_al, subst_in("${va}c", 'int @'); - push @do_al, subst_in("${va}v", 'Tcl_Obj *const *@'); + push @do_al, subst_in_decl("${va}c", 'int @'); + push @do_al, subst_in_decl("${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; + $any_eerr= 1; } if ($any_optl) { $pa_body .= "end_optional:\n"; @@ -182,15 +228,22 @@ foreach $c_table (sort keys %tables) { if ($any_eerr) { $pa_vars .= " const char *e;\n"; $pa_fini .= "\n"; - $pa_fini .= "e_err:"; + $pa_fini .= "e_err:\n"; $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"; + + if (length $c_table) { + $static= 'static '; + } else { + $static= ''; + o('h',90, "$pa_decl;\n"); + } o('c',100, - "static ".$pa_decl." {\n". + $static.$pa_decl." {\n". $pa_vars. $pa_init. $pa_argc. @@ -201,6 +254,21 @@ foreach $c_table (sort keys %tables) { $do_decl .= join ', ', @do_al; $do_decl .= ")"; o('h',100, $do_decl.";\n") or die $!; + + + $op_tab .= sprintf(" { %-20s, %-50s%s },\n", + "\"$c_entry\"", + "pa_${c_table}_${c_entry}", + $r_entry->{I}); + } + if (length $c_table) { + $decl= "const $x_table->{C} pcmdtab_$c_table".'[]'; + o('h', 500, "extern $decl;\n"); + o('c', 100, + "$decl = {\n". + $op_tab. + " { 0 }\n". + "};\n\n"); } } @@ -211,6 +279,10 @@ o(h, 0, "#define INCLUDED_\U${prefix}_H\n\n". "#include \n"); +o(h, 400, + "void setstringresult(Tcl_Interp*, const char*);\n". + "int pat_enum(Tcl_Interp*, Tcl_Obj*, const void**, const void*, size_t);\n"); + o(h, 999, "#endif /*INCLUDED_\U${prefix}_H*/\n"); @@ -262,9 +334,16 @@ sub make_decl ($$$) { defined $types{$t} or die "unknown type $t\n"; $c= $types{$t}{C}; } - return subst_in($n,$c); + return subst_in_decl($n,$c); } +sub subst_in_decl ($$$) { + my ($val, $pat, $why) = @_; + local ($_) = subst_in($val, $pat, $why); + s/ *(\**) *$/$1/; + return $_; +} + sub subst_in ($$$) { my ($val, $pat, $why) = @_; $pat =~ m/\@/ or die "$pat for $val in $why ?";