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 parse ($$) {
  28     my ($wh,$f) = @_;
  29     while (defined($_= $f->getline)) {
  30         chomp; s/\s+$//;
  31         next if m/^\s*\#/;
  32         next if !m/\S/;
  33         s/\t/ ' 'x(8-(length $`) % 8) /eg;
  34
  35         s/^\s*//;
  36         $this_indent= length $&;
  37         while (@i && $this_indent < $i[0]) {
  38             shift @i;
  39         }
  40         if ($this_indent && (!@i || $this_indent > $i[0])) {
  41             unshift @i, $this_indent;
  42         }
  43
  44         if (@i==0 && m/^Table\s+(\w+)$/) {
  45             $c_table= $1;
  46             undef $c_entry;
  47         } elsif (@i==0 && m/^(C|H)\-Include\s+(\S.*)$/) {
  48             o(lc $1, 30, "#include $2\n");
  49         } elsif (@i==1 && m/^([a-z]\w*)$/ && defined $c_table) {
  50             $c_entry= $1;
  51             $tables{$c_table}{$c_entry}{A} = [ ];
  52         } elsif (@i==2 && m/^(\w+)\s+\.\.\.$/ && defined $c_entry) {
  53             $tables{$c_table}{$c_entry}{V}= $1;
  54         } elsif (@i==2 && m/^(\??)([a-z]\w*)\s*(\S.*)/
  55                  && defined $c_entry) {
  56             ($opt, $var, $type) = ($1,$2,$3);
  57             if ($type =~ m/^\w+$/) {
  58                 $xtypeargs='';
  59             } elsif ($type =~ m/^(\w+)\((.+)\)$/) {
  60                 $type= $1;
  61                 $xtypeargs= $2;
  62             }
  63             push @{ $tables{$c_table}{$c_entry}{A} },
  64                 { N => $var, T => $type, A => $xtypeargs, O => ($opt eq '?') };
  65         } elsif (@i==2 && m/^\=\>\s*(\S.*)$/ && defined $c_entry) {
  66             $tables{$c_table}{$c_entry}{R}= $1;
  67         } elsif (@i==0 && m/^Type\s+([^\:]+)\:\s+(\S.*)$/) {
  68             ($typename,$ctype)= ($1,$2);
  69             $ctype .= ' @' unless $ctype =~ m/\@/;
  70             if ($typename =~ m/^\w+$/) {
  71                 $xtypeargs='';
  72             } elsif ($typename =~ m/^(\w+)\((.+)\)$/) {
  73                 $typename=$1;
  74                 $xtypeargs=$2;
  75             } else {
  76                 badsyntax($wh,$.,"bad type name/args");
  77             }
  78             $types{$typename}= { C => $ctype, X => $xtypeargs };
  79         } elsif (@i==0 && s/^Init\s+(\w+)\s+(\S.*)//) {
  80             $type_init{$1}= $2;
  81         } else {
  82             badsyntax($wh,$., sprintf
  83                       "bad directive (indent level %d)", scalar @i);
  84         }
  85     }
  86     $f->error and die $!;
  87     $f->close;
  88 }
  89
  90 #print Dumper(\%tables),"\n";
  91 #print Dumper(\%types),"\n";
  92
  93 foreach $t (sort keys %types) {
  94     $type= $types{$t};
  95     $c= $type->{C};
  96     $xta= $type->{X};
  97     $decl= "int pat_$t(Tcl_Interp, Tcl_Obj*, ";
  98     $decl .= subst_in('*', $c, "type $t");
  99     $decl .= ", $xta",  if length $xta;
 100     $decl .= ")\n";
 101     o('h',160, $decl);
 102
 103     $decl= "Tcl_Obj *ret_$t(Tcl_Interp, ".subst_in('',$c).");\n";
 104     o('h',170, $decl);
 105 }
 106
 107 foreach $c_table (sort keys %tables) {
 108     $r_table= $tables{$c_table};
 109     foreach $c_entry (keys %$r_table) {
 110         $r_entry= $r_table->{$c_entry};
 111         $pa_decl= "int pa_${c_table}_${c_entry}(ClientData cd,".
 112             " Tcl_Interp ip, int objc, Tcl_Obj *const *objv)";
 113         $do_decl= "int do_${c_table}_${c_entry}(";
 114         @do_al= ();
 115         @do_aa= qw(cd ip);
 116         $pa_init= '';
 117         $pa_argc= "  objc--; objv++;\n";
 118         $pa_vars= "  int rc;\n";
 119         $pa_body= '';
 120         $pa_rslt= '';
 121         $pa_free= '';
 122         $pa_fini= '';
 123         $any_mand= 0;
 124         $any_optl= 0;
 125         $any_eerr= 0;
 126         foreach $arg (@{ $r_entry->{A} }) {
 127             $n= $arg->{N};
 128             $t= $arg->{T};
 129             $a= $arg->{A};
 130             push @do_al, make_decl($n, $t, $arg->{A});
 131             $pa_vars .= make_decl_init("a_$n", $t, $a, \$pa_init);
 132             if ($arg->{O}) {
 133                 if ($any_mand) {
 134                     $pa_argc .= "  if (objc < $any_mand) {".
 135                         " e=\"too few args\"; goto e_err; }\n";
 136                     $pa_body .= "  objc -= $any_mand;\n";
 137                     $any_mand= 0;
 138                     $any_eerr= 0;
 139                 }
 140                 $pa_body .= "  if (!objc--) goto end_optional;\n";
 141                 $any_optl= 1;
 142             } else {
 143                 $any_mand++;
 144             }
 145             $pa_body .= "  rc= pat_$t(ip, *objv++, &a_$n";
 146             if ($t eq 'enum') {
 147                 $a =~ m/\,/ or die; $a = "$', sizeof($`)";
 148             }
 149             $pa_body .= ", ".$a if length $a;
 150             $pa_body .= "); if (rc) goto rc_err;\n";
 151             push @do_aa, "a_$n";
 152         }
 153         if (exists $r_entry->{V}) {
 154             $va= $r_entry->{V};
 155             push @do_al, subst_in("${va}c", 'int @');
 156             push @do_al, subst_in("${va}v", 'Tcl_Obj *const *@');
 157             push @do_aa, "objc-1", "objv+1";
 158         } else {
 159             $pa_body .= "  if (--objc) { e=\"too many args\"; goto e_err; }\n";
 160             $any_eerr= 0;
 161         }
 162         if ($any_optl) {
 163             $pa_body .= "end_optional:\n";
 164         }
 165         if (exists $r_entry->{R}) {
 166             $t= $r_entry->{R};
 167             push @do_al, make_decl("*result", $t);
 168             $pa_vars .= make_decl_init("result", $t, '', \$pa_init);
 169             push @do_aa, "&result";
 170             $pa_rslt .= "  Tcl_SetObjResult(ip, ret_$t(ip, result));\n";
 171         }
 172         $pa_body .= "\n";
 173         $pa_body .= "  rc= do_${c_table}_${c_entry}(";
 174         $pa_body .= join ', ', @do_aa;
 175         $pa_body .= ");\n";
 176         $pa_body .= "  if (rc) goto rc_err;\n";
 177
 178         $pa_rslt .= "  rc= TCL_OK;\n\n";
 179         $pa_rslt .= "rc_err:\n";
 180
 181         $pa_fini .= "  return rc;\n";
 182         if ($any_eerr) {
 183             $pa_vars .= "  const char *e;\n";
 184             $pa_fini .= "\n";
 185             $pa_fini .= "e_err:";
 186             $pa_fini .= "  setstringresult(ip,e);";
 187             $pa_fini .= "  rc= TCL_ERROR; goto rc_err;\n";
 188         }
 189         $pa_vars .= "\n";
 190         $pa_init .= "\n" if length $pa_init;
 191         $pa_fini .= "}\n\n";
 192         o('c',100,
 193           "static ".$pa_decl." {\n".
 194           $pa_vars.
 195           $pa_init.
 196           $pa_argc.
 197           $pa_body.
 198           $pa_rslt.
 199           $pa_free.
 200           $pa_fini);
 201         $do_decl .= join ', ', @do_al;
 202         $do_decl .= ")";
 203         o('h',100, $do_decl.";\n") or die $!;
 204     }
 205 }
 206
 207 o(c, 0, "#include \"$prefix.h\"\n");
 208
 209 o(h, 0,
 210   "#ifndef INCLUDED_\U${prefix}_H\n".
 211   "#define INCLUDED_\U${prefix}_H\n\n".
 212   "#include <tcl.h>\n");
 213
 214 o(h, 999,
 215   "#endif /*INCLUDED_\U${prefix}_H*/\n");
 216
 217 if (defined $output) {
 218     $oh= new IO::File "$output.tmp", 'w' or die "$output.tmp: $!\n";
 219 } else {
 220     $oh= 'STDOUT';
 221 }
 222
 223 print $oh "/* AUTOGENERATED - DO NOT EDIT */\n" or die $!;
 224 foreach $pr (sort keys %{ $o{$write} }) {
 225     print $oh "\n" or die $!;
 226     print $oh $o{$write}{$pr} or die $!;
 227 }
 228
 229 die if $oh->error;
 230 die $! unless $oh->close;
 231
 232 if (defined $output) {
 233     rename "$output.tmp", $output or die $!;
 234 }
 235
 236 sub o ($$) {
 237     my ($wh,$pr,$s) = @_;
 238     $o{$wh}{sprintf "%010d", $pr} .= $s;
 239 }
 240
 241 sub make_decl_init ($$$$) {
 242     my ($n, $t, $a, $initcode) = @_;
 243     my ($o,$init);
 244     $o= make_decl($n,$t,$a);
 245     if (exists $type_init{$t}) {
 246         $init= $type_init{$t};
 247         $$initcode .= "  ".subst_in("$n", $init)."\n"
 248             if length $init;
 249     } else {
 250         $o .= ' =0';
 251     }
 252     return "  ".$o.";\n";
 253 }
 254
 255 sub make_decl ($$$) {
 256     my ($n, $t, $ta) = @_;
 257     my ($type);
 258     if ($t eq 'enum') {
 259         $ta =~ m/\,/ or die "enum with bad args \`$ta'\n";
 260         $c= "const $` *@";
 261     } else {
 262         defined $types{$t} or die "unknown type $t\n";
 263         $c= $types{$t}{C};
 264     }
 265     return subst_in($n,$c);
 266 }
 267
 268 sub subst_in ($$$) {
 269     my ($val, $pat, $why) = @_;
 270     $pat =~ m/\@/ or die "$pat for $val in $why ?";
 271     $pat =~ s/\@/$val/g;
 272     return $pat;
 273 }
 274
 275 sub badsyntax ($$$) {
 276     die "$_[0]:$_[1]: $_[2]\n";
 277 }
 278
 279 __DATA__
 280 Type int:                       int
 281 Type obj:                       Tcl_Obj *@
 282 Type charfrom(const char*):     int