X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=chiark-tcl.git;a=blobdiff_plain;f=base%2Ftcmdifgen;h=f94479994410c8a3ee608bb41ea7d584354d6dce;hp=f4c77fc95695c05cd44d4aed217ea639c676af3a;hb=a3466b322998a623a15907a5c3520b4f30d1c050;hpb=5dca360f2da544c9b6baf9d18ad8cd0b0e073e60

diff --git a/base/tcmdifgen b/base/tcmdifgen
index f4c77fc..f944799 100755
--- a/base/tcmdifgen
+++ b/base/tcmdifgen
@@ -1,7 +1,7 @@
 #!/usr/bin/perl
 
 # code generator to help with writing Tcl extensions
-# Copyright 2006 Ian Jackson
+# Copyright 2006-2012 Ian Jackson
 #
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the GNU General Public License as
@@ -14,9 +14,7 @@
 # General Public License for more details.
 #
 # You should have received a copy of the GNU General Public License
-# along with this library; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-# 02110-1301, USA.
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
 
 
 # Input format is line-based, ws-significant, offside rule (some kind
@@ -96,12 +94,23 @@
 #     implement the function.  If the `=> RESULT-TYPE' is omitted, so
 #     is the result argument to the function.  Each argument to the
 #     function is of the C type corresponding to the specified type.
+#     TYPE may be `...', in which case the C function will be passed
+#     two args (int objc, Tcl_Obj *const *objv) for the remaining
+#     arguments.
+#
 #     The cht_do_... function should not eat any memory associated with
 #     the arguments.  The result buffer (if any) will be initialised
 #     using the `Init' and should on success contain the relevant
 #     result.  On failure it should leave the result unmodified (or at
 #     least, not in need of freeing).
 #
+#     As an alternative, the arguments can be replaced with just
+#            dispatch(TYPE-ARGS-FOR-ENUM)
+#     which is a shorthand for
+#            subcmd   enum(TYPE-ARGS-FOR-ENUM)
+#            args     ...
+#     and also generates and uses a standard dispatch function.
+#
 #     There will be an entry in C-ARRAY-NAME for every table entry.
 #     The name will be ENTRYNAME, and the func will be a function
 #     suitable for use as a Tcl command procedure, which parses the
@@ -232,6 +241,13 @@ sub parse ($$) {
 	    $tables{$c_table}{$c_entry}{A} = [ ];
 	} elsif (@i==2 && m/^\.\.\.\s+(\w+)$/ && defined $c_entry) {
 	    $tables{$c_table}{$c_entry}{V}= $1;
+	} elsif (@i==2 && m:^dispatch\(((.*)/(.*)\,.*)\)$: && defined $c_entry) {
+	    my $enumargs= $1;
+	    my $subcmdtype= $2.$3;
+	    $tables{$c_table}{$c_entry}{D}= $subcmdtype;
+	    $tables{$c_table}{$c_entry}{V}= 'obj';
+	    push @{ $tables{$c_table}{$c_entry}{A} },
+	        { N => 'subcmd', T => 'enum', A => $enumargs, O => '' };
 	} elsif (@i==2 && m/^(\??)([a-z]\w*)\s*(\S.*)/
 		 && defined $c_entry) {
 	    ($opt, $var, $type) = ($1,$2,$3);
@@ -300,7 +316,11 @@ foreach $c_table (sort keys %tables) {
 	$r_entry= $r_table->{$c_entry};
 	$pa_decl= "int pa_${c_table}_${c_entry_c}(ClientData cd,".
 	    " Tcl_Interp *ip, int objc, Tcl_Obj *const *objv)";
-	$do_decl= "int cht_do_${c_table}_${c_entry_c}(";
+	$pa_func= "cht_do_${c_table}_${c_entry_c}";
+	if (exists $r_entry->{D}) {
+	    $pa_func= "cht_dispatch_$r_entry->{D}";
+	}
+	$do_decl= "int $pa_func(";
 	@do_al= ('ClientData cd', 'Tcl_Interp *ip');
 	@do_aa= qw(cd ip);
 	$pa_init= '';
@@ -385,7 +405,7 @@ foreach $c_table (sort keys %tables) {
 	    $pa_rslt .= "));\n";
 	}
 	$pa_body .= "\n";
-	$pa_body .= "  rc= cht_do_${c_table}_${c_entry_c}(";
+	$pa_body .= "  rc= $pa_func(";
 	$pa_body .= join ', ', @do_aa;
 	$pa_body .= ");\n";
 	$pa_body .= "  if (rc) goto rc_err;\n";
@@ -428,8 +448,19 @@ foreach $c_table (sort keys %tables) {
 	  $pa_fini);
 	$do_decl .= join ', ', @do_al;
 	$do_decl .= ")";
-	o('h',100, $do_decl.";\n") or die $!;
-	
+
+	if (exists $r_entry->{D}) {
+	    my $subcmdtype= $r_entry->{D};
+	    if (!exists $dispatch_done{$subcmdtype}) {
+		my $di_body='';
+		$di_body .= "static $do_decl {\n";
+		$di_body .= "  return subcmd->func(0,ip,objc,objv);\n";
+		$di_body .= "}\n";
+		o('c',50, $di_body) or die $!;
+	    }
+	} else {
+	    o('h',100, $do_decl.";\n") or die $!;
+	}
 
 	$op_tab .= sprintf("  { %-20s %-40s%s },\n",
 			   "\"$c_entry\",",