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     die if m/^\-/;
  11     $x= new IO::File $_,'r' or die "$_: $!\n";
  12     parse($_,$x);
  13 }
  14
  15 sub parse ($$) {
  16     my ($wh,$f) = @_;
  17     while (defined($_= $f->getline)) {
  18         chomp; s/\s+$//;
  19         next if m/^\s*\#/;
  20         next if !m/\S/;
  21         s/\t/ ' 'x(8-(length $`) % 8) /eg;
  22
  23         s/^\s*//;
  24         $this_indent= length $&;
  25         while (@i && $this_indent < $i[0]) {
  26             shift @i;
  27         }
  28         if ($this_indent && (!@i || $this_indent > $i[0])) {
  29             unshift @i, $this_indent;
  30         }
  31
  32         if (@i==0 && m/^Table\s+(\w+)$/) {
  33             $c_table= $1;
  34             undef $c_entry;
  35         } elsif (@i==1 && m/^([a-z]\w*)$/ && defined $c_table) {
  36             $c_entry= $1;
  37             $tables{$c_table}{$c_entry}{A} = [ ];
  38         } elsif (@i==2 && m/^(\w+)\s+\.\.\.$/ && defined $c_entry) {
  39             $tables{$c_table}{$c_entry}{V}= $1;
  40         } elsif (@i==2 && m/^(\??)([a-z]\w*)\s*(\S.*)/
  41                  && defined $c_entry) {
  42             ($opt, $var, $type) = ($1,$2,$3);
  43             if ($type =~ m/^\w+$/) {
  44                 $xtypeargs='';
  45             } elsif ($type =~ m/^(\w+)\((.+)\)$/) {
  46                 $type= $1;
  47                 $xtypeargs= $2;
  48             }
  49             push @{ $tables{$c_table}{$c_entry}{A} },
  50                 { N => $var, T => $type, A => $xtypeargs, O => ($opt eq '?') };
  51         } elsif (@i==2 && m/^\=\>\s*(\S.*)$/ && defined $c_entry) {
  52             $tables{$c_table}{$c_entry}{R}= $1;
  53         } elsif (@i==0 && m/^Type\s+([^\:]+)\:\s+(\S.*)$/) {
  54             ($typename,$ctype)= ($1,$2);
  55             $ctype .= ' @' unless $ctype =~ m/\@/;
  56             if ($typename =~ m/^\w+$/) {
  57                 $xtypeargs='';
  58             } elsif ($typename =~ m/^(\w+)\((.+)\)$/) {
  59                 $typename=$1;
  60                 $xtypeargs=$2;
  61             } else {
  62                 badsyntax($wh,$.,"bad type name/args");
  63             }
  64             $types{$typename}= { C => $ctype, X => $xtypeargs };
  65         } else {
  66             printf STDERR ">%d<\n",
  67                 scalar m/^Type\s+([^\:]+)\:\s+(\S.*)$/;
  68             badsyntax($wh,$., sprintf
  69                       "bad directive (indent level %d)", scalar @i);
  70         }
  71     }
  72     $f->error and die $!;
  73     $f->close;
  74 }
  75
  76 #print Dumper(\%tables),"\n";
  77 #print Dumper(\%types),"\n";
  78
  79 foreach $c_table (sort keys %tables) {
  80     $r_table= $tables{$c_table};
  81     foreach $c_entry (keys %$r_table) {
  82         $r_entry= $r_table->{$c_entry};
  83         $pa_decl= "int fn_${c_table}_${c_entry}(";
  84         @pa_al= ();
  85         foreach $arg (@{ $r_entry->{A} }) {
  86             push @pa_al, make_decl($arg->{N}, $arg->{T}, $arg->{A});
  87         }
  88         if (exists $r_entry->{V}) {
  89             $va= $r_entry->{V};
  90             push @pa_al, make_decl_c("${va}c", 'int @');
  91             push @pa_al, make_decl_c("${va}v", 'Tcl_Obj *const *@');
  92         }
  93         if (exists $r_entry->{R}) {
  94             $t= $r_entry->{R};
  95             push @pa_al, make_decl("*result", $t);
  96         }
  97         $pa_decl .= join ', ', @pa_al;
  98         $pa_decl .= ");\n";
  99         print $pa_decl or die $!;
 100     }
 101 }
 102
 103 sub make_decl ($$$) {
 104     my ($n, $t, $ta) = @_;
 105     my ($type);
 106     if ($t eq 'enum') {
 107         $ta =~ m/\,/ or die "enum with bad args \`$ta'\n";
 108         $c= "const $` *@";
 109     } else {
 110         defined $types{$t} or die "unknown type $t\n";
 111         $c= $types{$t}{C};
 112     }
 113     return make_decl_c($n,$c);
 114 }
 115
 116 sub make_decl_c ($$) {
 117     my ($n, $c) = @_;
 118     $c =~ m/\@/ or die "$c for $n?";
 119     return "$`$n$'";
 120 }
 121
 122 sub badsyntax ($$$) {
 123     die "$_[0]:$_[1]: $_[2]\n";
 124 }
 125
 126 __DATA__
 127 Type int:                       int
 128 Type obj:                       Tcl_Obj *@
 129 Type charfrom(const char*):     int