chiark / gitweb /
Table-generated stuff. Now need parsing funcs.
[chiark-tcl.git] / base / tcmdifgen
index 4f4d154..3a31754 100755 (executable)
@@ -24,6 +24,12 @@ while (@ARGV) {
 
 die "must say -w<something>\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 <tcl.h>\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 ?";