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=d5e662234ddba0951fb59b300469b22a3e9821d3;hb=a3466b322998a623a15907a5c3520b4f30d1c050;hpb=82f88c53ddb84e42c770c23feb9bb0ee18341188 diff --git a/base/tcmdifgen b/base/tcmdifgen index d5e6622..f944799 100755 --- a/base/tcmdifgen +++ b/base/tcmdifgen @@ -1,5 +1,22 @@ #!/usr/bin/perl +# code generator to help with writing Tcl extensions +# 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 +# published by the Free Software Foundation; either version 2 of the +# License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this library; if not, see . + + # Input format is line-based, ws-significant, offside rule (some kind # of, anyway). # @@ -56,7 +73,7 @@ # Arranges for generated .h files to #include the specified # file. C-INCLUDE-SPECIFIER should include the <..> or "..". # -# Table TABLENAME C-ENTRY-TYPE +# Table [*]TABLENAME C-ENTRY-TYPE # Starts a table of commands or subcommands. The generated .h # will contain a definition of C-ENTRY-TYPE containing # const char *name; @@ -66,7 +83,7 @@ # where C-ARRAY-NAME is TABLENAME, with `_entries' appended # and `cht_' prepended. The entries are indented one level (one # or more spaces) and look like this: -# ENTRYNAME +# ENTRYNAME [ C-EXTRA-ENTRY-VALUES ] # FORMALARGNAME TYPE # ... # [ => RESULT-TYPE ] @@ -77,25 +94,40 @@ # 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 # arguments, processes the command, and sets any result, as # applicable. # -# ExtraEntry C-ENTRY-TYPE +# `*' should be used if the table name is not useful for error +# messages. It suppresses `TABLENAME ' from the front of the +# autogenerated argument parsing error strings. +# +# EntryExtra C-ENTRY-TYPE # Introduces a section of additional C code which will be inserted # into the definition of C-ENTRY-TYPE by `Table'. The C # code, which follows on several indented lines, should be # structure member definitions. # -# When ExtraEntry is used, in the corresponding Table, each +# When EntryExtra is used, in the corresponding Table, each # ENTRYNAME should be followed on the same line by whitespace and # EXTRA-VALUES; the EXTRA-VALUES are used as initialisers for the # additional structure elements. @@ -178,11 +210,12 @@ sub parse ($$) { unshift @i, $this_indent; } - if (@i==0 && m/^Table\s+(\w+)\s+(\w+)$/) { + if (@i==0 && m/^Table\s+(\*?)(\w+)\s+(\w+)$/) { zilch(); - $c_table= $1; - $table_x{$c_table}{C}= $2; - $entrytype_x{$2}= '' unless exists $entrytype_x{$2}; + $c_table= $2; + $table_x{$c_table}{T}= $1; + $table_x{$c_table}{C}= $3; + $entrytype_x{$3}= '' unless exists $entrytype_x{$3}; } elsif (@i==0 && m/^Untabled$/) { zilch(); $c_table= ''; @@ -208,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); @@ -276,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= ''; @@ -291,7 +335,8 @@ foreach $c_table (sort keys %tables) { $any_eerr= 0; $any_eargc= 0; $pa_hint= ''; - $pa_hint .= "$c_table " if length $c_table; + $pa_hint .= "$c_table " if length $c_table && + !length $table_x{$c_table}{T}; $pa_hint.= $c_entry; foreach $arg (@{ $r_entry->{A} }) { $n= $arg->{N}; @@ -360,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"; @@ -403,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\",",