From: Ian Jackson Date: Tue, 24 Apr 2018 19:19:13 +0000 (+0100) Subject: tcmdifgen: Turn on warnings and `use strict' and fix everything. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=chiark-tcl.git;a=commitdiff_plain;h=e73ac85c1317bde14832ba640f32caee05d90faa tcmdifgen: Turn on warnings and `use strict' and fix everything. Signed-off-by: Ian Jackson --- diff --git a/base/tcmdifgen b/base/tcmdifgen index c85161d..6ce038a 100755 --- a/base/tcmdifgen +++ b/base/tcmdifgen @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w # code generator to help with writing Tcl extensions # Copyright 2006-2012 Ian Jackson @@ -151,9 +151,22 @@ # and the two predefined types `int' (C `int') and `obj' (Tcl_Obj*, # unmodified.) The corresponding definitions are in tcmdiflib.c. +use strict; use IO::File; use Data::Dumper; +our (%o, $oh); +our ($prefix, $write, $output); +our (%tables, %table_x, %entrytype_x); +our (%types, %type_init, %type_fini); + +sub parse ($$); +sub subst_in_decl ($$;$); +sub subst_in ($$;$); +sub o ($$$); +sub make_decl ($$$;$); +sub make_decl_init ($$$$;$); + parse('builtins','DATA'); while (@ARGV) { @@ -169,13 +182,16 @@ while (@ARGV) { die "unknown option $_\n"; } else { if (!defined $prefix) { $prefix= $_; $prefix =~ s/\.[^.]+$//; } - $x= new IO::File $_,'r' or die "$_: $!\n"; + my $x= new IO::File $_,'r' or die "$_: $!\n"; parse($_,$x); } } die "must say -w\n" if !defined $write; +our ($c_entry, $c_entrytype); +our ($c_table, $c_entryextra, $c_of); + sub zilch () { undef $c_table; undef $c_entryextra; @@ -195,6 +211,7 @@ sub enumargs ($) { sub parse ($$) { my ($wh,$f) = @_; + my @i; while (defined($_= $f->getline)) { chomp; s/\s+$//; next if m/^\s*\#/; @@ -202,7 +219,7 @@ sub parse ($$) { while (s/\t/ ' 'x(8 - (length $`) % 8) /e) { } s/^\s*//; - $this_indent= length $&; + my $this_indent= length $&; while (@i && $this_indent < $i[0]) { shift @i; } @@ -250,18 +267,18 @@ sub parse ($$) { { 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); - ($type, $xtypeargs) = split_type_args($type); + my ($opt, $var, $typea) = ($1,$2,$3); + my ($type, $xtypeargs) = split_type_args($wh,$typea); 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) { - ($type, $xtypeargs) = split_type_args($1); + my ($type, $xtypeargs) = split_type_args($wh,$1); $tables{$c_table}{$c_entry}{R}= $type; $tables{$c_table}{$c_entry}{X}= $xtypeargs; } elsif (@i==0 && m/^Type\s+([^\:]+)\:\s+(\S.*)$/) { - ($typename,$ctype)= ($1,$2); + my ($typenamea,$ctype)= ($1,$2); $ctype .= ' @' unless $ctype =~ m/\@/; - ($typename,$xtypeargs) = split_type_args($typename); + my ($typename,$xtypeargs) = split_type_args($wh,$typenamea); $types{$typename}= { C => $ctype, X => $xtypeargs }; } elsif (@i==0 && s/^Init\s+(\w+)\s+(\S.*)//) { $type_init{$1}= $2; @@ -279,11 +296,11 @@ sub parse ($$) { #print Dumper(\%tables),"\n"; #print Dumper(\%types),"\n"; -foreach $t (sort keys %types) { - $type= $types{$t}; - $c= $type->{C}; - $xta= $type->{X}; - $decl= "int cht_pat_$t(Tcl_Interp *ip, Tcl_Obj *obj, "; +foreach my $t (sort keys %types) { + my $type= $types{$t}; + my $c= $type->{C}; + my $xta= $type->{X}; + my $decl= "int cht_pat_$t(Tcl_Interp *ip, Tcl_Obj *obj, "; $decl .= subst_in_decl('*val', $c, "type $t"); $decl .= ", $xta", if length $xta; $decl .= ");\n"; @@ -306,42 +323,44 @@ foreach $c_entrytype (sort keys %entrytype_x) { "};\n\n"); } +our (%dispatch_done); + foreach $c_table (sort keys %tables) { - $r_table= $tables{$c_table}; - $x_table= $table_x{$c_table}; - $op_tab= ''; + my $r_table= $tables{$c_table}; + my $x_table= $table_x{$c_table}; + my $op_tab= ''; foreach $c_entry (sort keys %$r_table) { - $c_entry_c= $c_entry; $c_entry_c =~ y/-/_/; - $r_entry= $r_table->{$c_entry}; - $pa_decl= "int pa_${c_table}_${c_entry_c}(ClientData cd,". + my $c_entry_c= $c_entry; $c_entry_c =~ y/-/_/; + my $r_entry= $r_table->{$c_entry}; + my $pa_decl= "int pa_${c_table}_${c_entry_c}(ClientData cd,". " Tcl_Interp *ip, int objc, Tcl_Obj *const *objv)"; - $pa_func= "cht_do_${c_table}_${c_entry_c}"; + my $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= ''; - $pa_argc= " objc--; objv++;\n"; - $pa_vars= " int rc;\n"; - $pa_body= ''; - $pa_rslt= ''; - $pa_free= ''; - $pa_fini= ''; - $any_mand= 0; - $any_optl= 0; - $any_eerr= 0; - $any_eargc= 0; - $pa_hint= ''; + my $do_decl= "int $pa_func("; + my @do_al= ('ClientData cd', 'Tcl_Interp *ip'); + my @do_aa= qw(cd ip); + my $pa_init= ''; + my $pa_argc= " objc--; objv++;\n"; + my $pa_vars= " int rc;\n"; + my $pa_body= ''; + my $pa_rslt= ''; + my $pa_free= ''; + my $pa_fini= ''; + my $any_mand= 0; + my $any_optl= 0; + my $any_eerr= 0; + my $any_eargc= 0; + my $pa_hint= ''; $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}; - $t= $arg->{T}; - $a= $arg->{A}; + foreach my $arg (@{ $r_entry->{A} }) { + my $n= $arg->{N}; + my $t= $arg->{T}; + my $a= $arg->{A}; push @do_al, make_decl($n, $t, $arg->{A}, "table $c_table entry $c_entry arg $n"); $pa_vars .= make_decl_init("a_$n", $t, $a, \$pa_init, "pa_vars"); @@ -360,13 +379,13 @@ foreach $c_table (sort keys %tables) { $any_eargc= 1; die if $any_optl; } - $paarg= "&a_$n"; - $pafin= ''; + my $paarg= "&a_$n"; + my $pafin= ''; if ($t eq 'enum') { $pa_vars .= " const void *v_$n= 0;\n"; $paarg= "&v_$n"; $pafin= "\n a_$n= v_$n; "; - ($a_tab, $ee_type, $estr) = enumargs($a); + my ($a_tab, $ee_type, $estr) = enumargs($a); $a = "cht_$a_tab, sizeof($ee_type), $estr"; o('h', 210, "extern const $ee_type cht_$a_tab".'[]'.";\n"); } @@ -380,7 +399,7 @@ foreach $c_table (sort keys %tables) { } if (exists $r_entry->{V}) { $pa_hint .= " ..."; - $va= $r_entry->{V}; + my $va= $r_entry->{V}; push @do_al, subst_in_decl("${va}c", 'int @'); push @do_al, subst_in_decl("${va}v", 'Tcl_Obj *const *@'); push @do_aa, "objc+1", "objv-1"; @@ -394,8 +413,8 @@ foreach $c_table (sort keys %tables) { $pa_body .= "end_optional:\n"; } if (exists $r_entry->{R}) { - $t= $r_entry->{R}; - $xta= $r_entry->{X}; + my $t= $r_entry->{R}; + my $xta= $r_entry->{X}; push @do_al, make_decl("*result", $t, "cht_do_al result"); $pa_vars .= make_decl_init("result", $t, $xta, \$pa_init, "pa_vars result"); @@ -431,6 +450,7 @@ foreach $c_table (sort keys %tables) { $pa_init .= "\n" if length $pa_init; $pa_fini .= "}\n\n"; + my $static; if (length $c_table) { $static= 'static '; } else { @@ -461,14 +481,13 @@ foreach $c_table (sort keys %tables) { } else { o('h',100, $do_decl.";\n") or die $!; } - $op_tab .= sprintf(" { %-20s %-40s%s },\n", "\"$c_entry\",", "pa_${c_table}_${c_entry_c}", - $r_entry->{I}); + ($r_entry->{I}) // ''); } if (length $c_table) { - $decl= "const $x_table->{C} cht_${c_table}_entries[]"; + my $decl= "const $x_table->{C} cht_${c_table}_entries[]"; o('h', 500, "extern $decl;\n"); o('c', 100, "$decl = {\n". @@ -478,13 +497,13 @@ foreach $c_table (sort keys %tables) { } } -o(c, 0, "#include \"$prefix.h\"\n"); +o('c', 0, "#include \"$prefix.h\"\n"); -o(h, 0, +o('h', 0, "#ifndef INCLUDED_\U${prefix}_H\n". "#define INCLUDED_\U${prefix}_H\n\n"); -o(h, 999, +o('h', 999, "#endif /*INCLUDED_\U${prefix}_H*/\n"); if (defined $output) { @@ -494,7 +513,7 @@ if (defined $output) { } print $oh "/* AUTOGENERATED - DO NOT EDIT */\n" or die $!; -foreach $pr (sort keys %{ $o{$write} }) { +foreach my $pr (sort keys %{ $o{$write} }) { print $oh "\n" or die $!; print $oh $o{$write}{$pr} or die $!; } @@ -506,13 +525,13 @@ if (defined $output) { rename "$output.tmp", $output or die $!; } -sub o ($$) { +sub o ($$$) { my ($wh,$pr,$s) = @_; $o{$wh}{sprintf "%010d", $pr} .= $s; } -sub split_type_args ($) { - my ($type) = @_; +sub split_type_args ($$) { + my ($wh,$type) = @_; my ($xtypeargs); if ($type =~ m/^\w+$/) { $xtypeargs=''; @@ -525,7 +544,7 @@ sub split_type_args ($) { return ($type,$xtypeargs); } -sub make_decl_init ($$$$$) { +sub make_decl_init ($$$$;$) { my ($n, $t, $a, $initcode, $why) = @_; my ($o,$init); $o= make_decl($n,$t,$a,"$why _init"); @@ -539,11 +558,11 @@ sub make_decl_init ($$$$$) { return " ".$o.";\n"; } -sub make_decl ($$$$) { +sub make_decl ($$$;$) { my ($n, $t, $ta, $why) = @_; - my ($type); + my ($type, $c); if ($t eq 'enum') { - ($a_tab, $ee_type, $estr) = enumargs($ta); + my ($a_tab, $ee_type, $estr) = enumargs($ta); $c= "const $ee_type* @"; } else { defined $types{$t} or die "unknown type $t ($why)\n"; @@ -552,14 +571,14 @@ sub make_decl ($$$$) { return subst_in_decl($n,$c); } -sub subst_in_decl ($$$) { +sub subst_in_decl ($$;$) { my ($val, $pat, $why) = @_; local ($_) = subst_in($val, $pat, $why); s/ *(\**) *$/$1/; return $_; } -sub subst_in ($$$) { +sub subst_in ($$;$) { my ($val, $pat, $why) = @_; $pat =~ m/\@/ or die "$pat for $val in $why ?"; $pat =~ s/\@/$val/g; diff --git a/debian/changelog b/debian/changelog index eb8a4ce..4dff38a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,7 @@ chiark-tcl (1.2.2~) unstable; urgency=medium tcmdifgen: + * Turn on warnings and `use strict' and fix everything. * Replace deprecated `use IO;' with `use IO::File'. --