fix unused vars

[chiark-tcl.git] / base / tcmdifgen

diff --git a/base/tcmdifgen b/base/tcmdifgen
index f4c77fc95695c05cd44d4aed217ea639c676af3a..f94479994410c8a3ee608bb41ea7d584354d6dce 100755 (executable)
--- 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\",",