base/tcmdifgen

   1 #!/usr/bin/perl
   2
   3 use IO;
   4 use Data::Dumper;
   5
   6 parse('builtins','DATA');
   7
   8 while (@ARGV) {
   9     $_= shift @ARGV;
  10     if (m/^\-p(\w+)/) {
  11         $prefix= $1;
  12     } elsif (m/^\-w(c|h)$/) {
  13         $write= $1;
  14     } elsif (m/^\-o(.+)$/) {
  15         $output= $1;
  16     } elsif (m/^\-/) {
  17         die "unknown option $_\n";
  18     } else {
  19         if (!defined $prefix) { $prefix= $_;  $prefix =~ s/\.[^.]+$//; }
  20         $x= new IO::File $_,'r' or die "$_: $!\n";
  21         parse($_,$x);
  22     }
  23 }
  24
  25 die "must say -w<something>\n" if !defined $write;
  26
  27 sub zilch () {
  28     undef $c_table;
  29     undef $c_entryextra;
  30     undef $c_of;
  31 }
  32
  33 sub parse ($$) {
  34     my ($wh,$f) = @_;
  35     while (defined($_= $f->getline)) {
  36         chomp; s/\s+$//;
  37         next if m/^\s*\#/;
  38         next if !m/\S/;
  39         s/\t/ ' 'x(8-(length $`) % 8) /eg;
  40
  41         s/^\s*//;
  42         $this_indent= length $&;
  43         while (@i && $this_indent < $i[0]) {
  44             shift @i;
  45         }
  46         if ($this_indent && (!@i || $this_indent > $i[0])) {
  47             unshift @i, $this_indent;
  48         }
  49
  50         if (@i==0 && m/^Table\s+(\w+)$/) {
  51             zilch();
  52             $c_table= $1;
  53             $table_x{$c_table}{C}= 'ParserCommandTableEntry';
  54             $entrytype_x{ParserCommandTableEntry}= '';
  55         } elsif (@i==0 && m/^Untabled$/) {
  56             zilch();
  57             $c_table= '';
  58         } elsif (@i==0 && m/^(C|H)\-Include\s+(\S.*)$/) {
  59             o(lc $1, 30, "#include $2\n");
  60         } elsif (@i==1 && m/^Of\s+(\w+)$/ && defined $c_table) {
  61             die unless length $c_table;
  62             $table_x{$c_table}{C}= $1;
  63             $entrytype_x{$1}= '';
  64         } elsif (@i==0 && m/^EntryExtra\s+(\w+)$/) {
  65             zilch();
  66             $c_entryextra= $1;
  67         } elsif (@i>=1 && defined $c_entryextra) {
  68             $entrytype_x{$c_entryextra} .= "  $_\n";
  69         } elsif (@i==1 && m/^[a-z].*$/ && defined $c_table) {
  70             if (m/^\w+$/) {
  71                 $c_entry= $_;
  72             } elsif (m/^(\w+)\s+(\S.*)$/) {
  73                 $c_entry= $1;
  74                 $tables{$c_table}{$c_entry}{I} .= ", $2";
  75             } else {
  76                 badsyntax($wh,$.,"bad entry");
  77             }
  78             $tables{$c_table}{$c_entry}{A} = [ ];
  79         } elsif (@i==2 && m/^(\w+)\s+\.\.\.$/ && defined $c_entry) {
  80             $tables{$c_table}{$c_entry}{V}= $1;
  81         } elsif (@i==2 && m/^(\??)([a-z]\w*)\s*(\S.*)/
  82                  && defined $c_entry) {
  83             ($opt, $var, $type) = ($1,$2,$3);
  84             if ($type =~ m/^\w+$/) {
  85                 $xtypeargs='';
  86             } elsif ($type =~ m/^(\w+)\((.+)\)$/) {
  87                 $type= $1;
  88                 $xtypeargs= $2;
  89             }
  90             push @{ $tables{$c_table}{$c_entry}{A} },
  91                 { N => $var, T => $type, A => $xtypeargs, O => ($opt eq '?') };
  92         } elsif (@i==2 && m/^\=\>\s*(\S.*)$/ && defined $c_entry) {
  93             $tables{$c_table}{$c_entry}{R}= $1;
  94         } elsif (@i==0 && m/^Type\s+([^\:]+)\:\s+(\S.*)$/) {
  95             ($typename,$ctype)= ($1,$2);
  96             $ctype .= ' @' unless $ctype =~ m/\@/;
  97             if ($typename =~ m/^\w+$/) {
  98                 $xtypeargs='';
  99             } elsif ($typename =~ m/^(\w+)\((.+)\)$/) {
 100                 $typename=$1;
 101                 $xtypeargs=$2;
 102             } else {
 103                 badsyntax($wh,$.,"bad type name/args");
 104             }
 105             $types{$typename}= { C => $ctype, X => $xtypeargs };
 106         } elsif (@i==0 && s/^Init\s+(\w+)\s+(\S.*)//) {
 107             $type_init{$1}= $2;
 108         } else {
 109             badsyntax($wh,$., sprintf
 110                       "bad directive (indent level %d)", scalar @i);
 111         }
 112     }
 113     $f->error and die $!;
 114     $f->close;
 115 }
 116
 117 #print Dumper(\%tables),"\n";
 118 #print Dumper(\%types),"\n";
 119
 120 foreach $t (sort keys %types) {
 121     $type= $types{$t};
 122     $c= $type->{C};
 123     $xta= $type->{X};
 124     $decl= "int pat_$t(Tcl_Interp*, Tcl_Obj*, ";
 125     $decl .= subst_in_decl('*', $c, "type $t");
 126     $decl .= ", $xta",  if length $xta;
 127     $decl .= ");\n";
 128     o('h',160, $decl);
 129
 130     $decl= "Tcl_Obj *ret_$t(Tcl_Interp*, ".subst_in_decl('',$c).");\n";
 131     o('h',170, $decl);
 132 }
 133
 134 foreach $c_entrytype (sort keys %entrytype_x) {
 135     o('h', 20, "typedef struct $c_entrytype $c_entrytype;\n");
 136     o('h', 100,
 137       "struct $c_entrytype {\n".
 138       "  const char *name;\n".
 139       "  Tcl_ObjCmdProc *func;\n".
 140       $entrytype_x{$c_entrytype}.
 141       "};\n\n");
 142 }
 143
 144 foreach $c_table (sort keys %tables) {
 145     $r_table= $tables{$c_table};
 146     $x_table= $table_x{$c_table};
 147     $op_tab= '';
 148
 149     foreach $c_entry (keys %$r_table) {
 150         $r_entry= $r_table->{$c_entry};
 151         $pa_decl= "int pa_${c_table}_${c_entry}(ClientData cd,".
 152             " Tcl_Interp *ip, int objc, Tcl_Obj *const *objv)";
 153         $do_decl= "int do_${c_table}_${c_entry}(";
 154         @do_al= ('ClientData cd', 'Tcl_Interp *ip');
 155         @do_aa= qw(cd ip);
 156         $pa_init= '';
 157         $pa_argc= "  objc--; objv++;\n";
 158         $pa_vars= "  int rc;\n";
 159         $pa_body= '';
 160         $pa_rslt= '';
 161         $pa_free= '';
 162         $pa_fini= '';
 163         $any_mand= 0;
 164         $any_optl= 0;
 165         $any_eerr= 0;
 166         foreach $arg (@{ $r_entry->{A} }) {
 167             $n= $arg->{N};
 168             $t= $arg->{T};
 169             $a= $arg->{A};
 170             push @do_al, make_decl($n, $t, $arg->{A});
 171             $pa_vars .= make_decl_init("a_$n", $t, $a, \$pa_init);
 172             if ($arg->{O}) {
 173                 if ($any_mand) {
 174                     $pa_argc .= "  if (objc < $any_mand) {".
 175                         " e=\"too few args\"; goto e_err; }\n";
 176                     $pa_body .= "  objc -= $any_mand;\n";
 177                     $any_mand= 0;
 178                     $any_eerr= 1;
 179                 }
 180                 $pa_body .= "  if (!objc--) goto end_optional;\n";
 181                 $any_optl= 1;
 182             } else {
 183                 $any_mand++;
 184             }
 185             $paarg= "&a_$n";
 186             $pafin= '';
 187             if ($t eq 'enum') {
 188                 $pa_vars .= "  const void *v_$n= 0;\n";
 189                 $paarg= "&v_$n";
 190                 $pafin= "\n  a_$n= v_$n; ";
 191                 $a =~ m/\,/ or die; $a = "$', sizeof($`)";
 192                 o('h', 210, "extern const $` $'".'[]'.";\n");
 193             }
 194             $pa_body .= "  rc= pat_$t(ip, *objv++, $paarg";
 195             $pa_body .= ", ".$a if length $a;
 196             $pa_body .= ");$pafin if (rc) goto rc_err;\n";
 197             push @do_aa, "a_$n";
 198         }
 199         if (exists $r_entry->{V}) {
 200             $va= $r_entry->{V};
 201             push @do_al, subst_in_decl("${va}c", 'int @');
 202             push @do_al, subst_in_decl("${va}v", 'Tcl_Obj *const *@');
 203             push @do_aa, "objc-1", "objv+1";
 204         } else {
 205             $pa_body .= "  if (--objc) { e=\"too many args\"; goto e_err; }\n";
 206             $any_eerr= 1;
 207         }
 208         if ($any_optl) {
 209             $pa_body .= "end_optional:\n";
 210         }
 211         if (exists $r_entry->{R}) {
 212             $t= $r_entry->{R};
 213             push @do_al, make_decl("*result", $t);
 214             $pa_vars .= make_decl_init("result", $t, '', \$pa_init);
 215             push @do_aa, "&result";
 216             $pa_rslt .= "  Tcl_SetObjResult(ip, ret_$t(ip, result));\n";
 217         }
 218         $pa_body .= "\n";
 219         $pa_body .= "  rc= do_${c_table}_${c_entry}(";
 220         $pa_body .= join ', ', @do_aa;
 221         $pa_body .= ");\n";
 222         $pa_body .= "  if (rc) goto rc_err;\n";
 223
 224         $pa_rslt .= "  rc= TCL_OK;\n\n";
 225         $pa_rslt .= "rc_err:\n";
 226
 227         $pa_fini .= "  return rc;\n";
 228         if ($any_eerr) {
 229             $pa_vars .= "  const char *e;\n";
 230             $pa_fini .= "\n";
 231             $pa_fini .= "e_err:\n";
 232             $pa_fini .= "  setstringresult(ip,e);";
 233             $pa_fini .= "  rc= TCL_ERROR; goto rc_err;\n";
 234         }
 235         $pa_vars .= "\n";
 236         $pa_init .= "\n" if length $pa_init;
 237         $pa_fini .= "}\n\n";
 238
 239         if (length $c_table) {
 240             $static= 'static ';
 241         } else {
 242             $static= '';
 243             o('h',90, "$pa_decl;\n");
 244         }
 245         o('c',100,
 246           $static.$pa_decl." {\n".
 247           $pa_vars.
 248           $pa_init.
 249           $pa_argc.
 250           $pa_body.
 251           $pa_rslt.
 252           $pa_free.
 253           $pa_fini);
 254         $do_decl .= join ', ', @do_al;
 255         $do_decl .= ")";
 256         o('h',100, $do_decl.";\n") or die $!;
 257
 258
 259         $op_tab .= sprintf("  { %-20s, %-50s%s },\n",
 260                            "\"$c_entry\"",
 261                            "pa_${c_table}_${c_entry}",
 262                            $r_entry->{I});
 263     }
 264     if (length $c_table) {
 265         $decl= "const $x_table->{C} pcmdtab_$c_table".'[]';
 266         o('h', 500, "extern $decl;\n");
 267         o('c', 100,
 268           "$decl = {\n".
 269           $op_tab.
 270           "  { 0 }\n".
 271           "};\n\n");
 272     }
 273 }
 274
 275 o(c, 0, "#include \"$prefix.h\"\n");
 276
 277 o(h, 0,
 278   "#ifndef INCLUDED_\U${prefix}_H\n".
 279   "#define INCLUDED_\U${prefix}_H\n\n".
 280   "#include <tcl.h>\n");
 281
 282 o(h, 400,
 283   "void setstringresult(Tcl_Interp*, const char*);\n".
 284   "int pat_enum(Tcl_Interp*, Tcl_Obj*, const void**, const void*, size_t);\n");
 285
 286 o(h, 999,
 287   "#endif /*INCLUDED_\U${prefix}_H*/\n");
 288
 289 if (defined $output) {
 290     $oh= new IO::File "$output.tmp", 'w' or die "$output.tmp: $!\n";
 291 } else {
 292     $oh= 'STDOUT';
 293 }
 294
 295 print $oh "/* AUTOGENERATED - DO NOT EDIT */\n" or die $!;
 296 foreach $pr (sort keys %{ $o{$write} }) {
 297     print $oh "\n" or die $!;
 298     print $oh $o{$write}{$pr} or die $!;
 299 }
 300
 301 die if $oh->error;
 302 die $! unless $oh->close;
 303
 304 if (defined $output) {
 305     rename "$output.tmp", $output or die $!;
 306 }
 307
 308 sub o ($$) {
 309     my ($wh,$pr,$s) = @_;
 310     $o{$wh}{sprintf "%010d", $pr} .= $s;
 311 }
 312
 313 sub make_decl_init ($$$$) {
 314     my ($n, $t, $a, $initcode) = @_;
 315     my ($o,$init);
 316     $o= make_decl($n,$t,$a);
 317     if (exists $type_init{$t}) {
 318         $init= $type_init{$t};
 319         $$initcode .= "  ".subst_in("$n", $init)."\n"
 320             if length $init;
 321     } else {
 322         $o .= ' =0';
 323     }
 324     return "  ".$o.";\n";
 325 }
 326
 327 sub make_decl ($$$) {
 328     my ($n, $t, $ta) = @_;
 329     my ($type);
 330     if ($t eq 'enum') {
 331         $ta =~ m/\,/ or die "enum with bad args \`$ta'\n";
 332         $c= "const $` *@";
 333     } else {
 334         defined $types{$t} or die "unknown type $t\n";
 335         $c= $types{$t}{C};
 336     }
 337     return subst_in_decl($n,$c);
 338 }
 339
 340 sub subst_in_decl ($$$) {
 341     my ($val, $pat, $why) = @_;
 342     local ($_) = subst_in($val, $pat, $why);
 343     s/ *(\**) *$/$1/;
 344     return $_;
 345 }
 346
 347 sub subst_in ($$$) {
 348     my ($val, $pat, $why) = @_;
 349     $pat =~ m/\@/ or die "$pat for $val in $why ?";
 350     $pat =~ s/\@/$val/g;
 351     return $pat;
 352 }
 353
 354 sub badsyntax ($$$) {
 355     die "$_[0]:$_[1]: $_[2]\n";
 356 }
 357
 358 __DATA__
 359 Type int:                       int
 360 Type obj:                       Tcl_Obj *@
 361 Type charfrom(const char*):     int