From: ian <ian>
Date: Fri, 30 Aug 2002 21:33:48 +0000 (+0000)
Subject: Fix up filename change.  Generates decls !
X-Git-Tag: debian/1.1.1~178
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=chiark-tcl.git;a=commitdiff_plain;h=427c2d3d8b6ae6b580c773400c00322242014558

Fix up filename change.  Generates decls !
---

diff --git a/base/tables-examples.tct b/base/tables-examples.tct
index 1119be8..53fd239 100644
--- a/base/tables-examples.tct
+++ b/base/tables-examples.tct
@@ -1,23 +1,22 @@
-Type hb				Tcl_Obj *
-Type hbv			Tcl_Obj *
+Type hb:			Tcl_Obj/*hbytes*/ *@
+Type hbv:			Tcl_Obj/*hbytes*/ *@
 
 Table hbytes
-Entries
 	raw2h
 		binary	obj
 		=>	hb
 	h2raw
-		hex	hex
+		hex	hb
 		=>	obj
 	prefix
 		v	hbv
-		...
+		str	...
 	append
 		v	hbv
-		...
+		str	...
 	concat
 		v	hbv
-		...
+		str	...
 	unprepend
 		v	hbv
 		length	int
@@ -32,7 +31,7 @@ Entries
 		=>	hb
 	pkcs5
 		meth	enum(PadMethodInfo,padmethodinfos)
-		...
+		arg	...
 	blockcipher
 		encrypt	charfrom("de")
 		v	hbv
@@ -51,8 +50,7 @@ Entries
 		maclen	int
 		=>	hb
 
-Table padmethodinfos
-	FuncArgs
-	Info
-		int algname;
-Entries
+#Table padmethodinfos
+#	Info
+#		int algname;
+#Entries
diff --git a/base/tcmdifgen b/base/tcmdifgen
index 498ae50..da7b428 100755
--- 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