Fix up filename change. Generates decls !

[chiark-tcl.git] / base / tcmdifgen

diff --git a/base/tcmdifgen b/base/tcmdifgen
index 498ae50d22cda9df415593e4362319b0f05ec151..da7b428144895064004d86888740bd3d04443434 100755 (executable)
--- a/base/tcmdifgen
+++ b/base/tcmdifgen
@@ -8,21 +8,23 @@ parse('builtins','DATA');
 while (@ARGV) {
     $_= shift @ARGV;
     die if m/^\-/;
-    $x= new IO::File $_,'r';
+    $x= new IO::File $_,'r' or die "$_: $!\n";
     parse($_,$x);
 }
 
 sub parse ($$) {
     my ($wh,$f) = @_;
     while (defined($_= $f->getline)) {
-       chomp; s/^\s+//; s/\s+$//;
-       next if m/^\#/;
+       chomp; s/\s+$//;
+       next if m/^\s*\#/;
        next if !m/\S/;
        s/\t/ ' 'x(8-(length $`) % 8) /eg;
 
-       s/^\s+//;
+       s/^\s*//;
        $this_indent= length $&;
-       while (@i && $this_indent < $i[0]) { shift @i; }
+       while (@i && $this_indent < $i[0]) {
+           shift @i;
+       }
        if ($this_indent && (!@i || $this_indent > $i[0])) {
            unshift @i, $this_indent;
        }
@@ -33,19 +35,36 @@ sub parse ($$) {
        } elsif (@i==1 && m/^([a-z]\w*)$/ && defined $c_table) {
            $c_entry= $1;
            $tables{$c_table}{$c_entry}{A} = [ ];
-       } elsif (@i==2 && m/^(?:\?)?([a-z]\w*)\s.*(\S.*)/
+       } elsif (@i==2 && m/^(\w+)\s+\.\.\.$/ && defined $c_entry) {
+           $tables{$c_table}{$c_entry}{V}= $1;
+       } elsif (@i==2 && m/^(\??)([a-z]\w*)\s*(\S.*)/
                 && defined $c_entry) {
-           push @{ $tables{$c_table}{$c_entry}{A} }, [ $2, $3, $1 eq '?' ];
-       } elsif (@i==2 && m/^\=\>\s.*(\S.*)/ && defined $c_entry) {
+           ($opt, $var, $type) = ($1,$2,$3);
+           if ($type =~ m/^\w+$/) {
+               $xtypeargs='';
+           } elsif ($type =~ m/^(\w+)\((.+)\)$/) {
+               $type= $1;
+               $xtypeargs= $2;
+           }
+           push @{ $tables{$c_table}{$c_entry}{A} },
+               { N => $var, T => $type, A => $xtypeargs, O => ($opt eq '?') };
+       } elsif (@i==2 && m/^\=\>\s*(\S.*)$/ && defined $c_entry) {
            $tables{$c_table}{$c_entry}{R}= $1;
-       } elsif (@i==2 && m/^\.\.\.$/ && defined $c_entry) {
-           $tables{$c_table}{$c_entry}{V}= 1;
-       } elsif (@i==0 && s/^Type\s+$//) {
-           
-           ($typename,$_)= ($1,$2);
-           $_ .= '@' unless m/\@/;
-           $types{$typename}= $_;
+       } elsif (@i==0 && m/^Type\s+([^\:]+)\:\s+(\S.*)$/) {
+           ($typename,$ctype)= ($1,$2);
+           $ctype .= ' @' unless $ctype =~ m/\@/;
+           if ($typename =~ m/^\w+$/) {
+               $xtypeargs='';
+           } elsif ($typename =~ m/^(\w+)\((.+)\)$/) {
+               $typename=$1;
+               $xtypeargs=$2;
+           } else {
+               badsyntax($wh,$.,"bad type name/args");
+           }
+           $types{$typename}= { C => $ctype, X => $xtypeargs };
        } else {
+           printf STDERR ">%d<\n",
+               scalar m/^Type\s+([^\:]+)\:\s+(\S.*)$/;
            badsyntax($wh,$., sprintf
                      "bad directive (indent level %d)", scalar @i);
        }
@@ -54,17 +73,57 @@ sub parse ($$) {
     $f->close;
 }
 
-print Dumper(\%tables),"\n";
-print Dumper(\%types),"\n";
+#print Dumper(\%tables),"\n";
+#print Dumper(\%types),"\n";
+
+foreach $c_table (sort keys %tables) {
+    $r_table= $tables{$c_table};
+    foreach $c_entry (keys %$r_table) {
+       $r_entry= $r_table->{$c_entry};
+       $pa_decl= "int fn_${c_table}_${c_entry}(";
+       @pa_al= ();
+       foreach $arg (@{ $r_entry->{A} }) {
+           push @pa_al, make_decl($arg->{N}, $arg->{T}, $arg->{A});
+       }
+       if (exists $r_entry->{V}) {
+           $va= $r_entry->{V};
+           push @pa_al, make_decl_c("${va}c", 'int @');
+           push @pa_al, make_decl_c("${va}v", 'Tcl_Obj *const *@');
+       }
+       if (exists $r_entry->{R}) {
+           $t= $r_entry->{R};
+           push @pa_al, make_decl("*result", $t);
+       }
+       $pa_decl .= join ', ', @pa_al;
+       $pa_decl .= ");\n";
+       print $pa_decl or die $!;
+    }
+}
+
+sub make_decl ($$$) {
+    my ($n, $t, $ta) = @_;
+    my ($type);
+    if ($t eq 'enum') {
+       $ta =~ m/\,/ or die "enum with bad args \`$ta'\n";
+       $c= "const $` *@";
+    } else { 
+       defined $types{$t} or die "unknown type $t\n";
+       $c= $types{$t}{C};
+    }
+    return make_decl_c($n,$c);
+}
+
+sub make_decl_c ($$) {
+    my ($n, $c) = @_;
+    $c =~ m/\@/ or die "$c for $n?";
+    return "$`$n$'";
+}
 
 sub badsyntax ($$$) {
     die "$_[0]:$_[1]: $_[2]\n";
 }
 
 __DATA__
-Type int
-       int
-Type obj
-       Tcl_Obj *
-Type charfrom
-       (const char*)
+Type int:                      int
+Type obj:                      Tcl_Obj *@
+Type charfrom(const char*):    int