From: Larry Wall Date: Mon, 8 Jun 1992 04:52:11 +0000 (+0000) Subject: perl 4.0 patch 30: patch #20, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=32c2e4fbb7ba898d9e58e8d2292dd45b8692070d;p=p5sagit%2Fp5-mst-13.2.git perl 4.0 patch 30: patch #20, continued See patch #20. --- diff --git a/atarist/test/pi.pl b/atarist/test/pi.pl new file mode 100644 index 0000000..b7766bb --- /dev/null +++ b/atarist/test/pi.pl @@ -0,0 +1,174 @@ +# --------------------------------------------------------------------------- +# pi.perl computes pi (3.14...) about 5120 Digits +# +# W. Kebsch, July-1988 {uunet!mcvax}!unido!nixpbe!kebsch + +$my_name = $0; +$version = $my_name . "-1.2"; + +# some working parameter + +$smax = 5120; # max digits +$lmax = 4; # digits per one array element +$hmax = 10000; # one array element contains: 0..9999 +$smin = $lmax; # min digits +$mag = 7; # magic number + +# subroutines + +sub mul_tm # multiply the tm array with a long value +{ + $cb = pop(@_); # elements(array) + $x = pop(@_); # value + + $c = 0; + for($i = 1; $i <= $cb; $i++) + { + $z = $tm[$i] * $x + $c; + $c = int($z / $hmax); + $tm[$i] = $z - $c * $hmax; + } +} + +sub mul_pm # multiply the pm array with a long value +{ + $cb = pop(@_); # elements(array) + $x = pop(@_); # value + + $c = 0; + for($i = 1; $i <= $cb; $i++) + { + $z = $pm[$i] * $x + $c; + $c = int($z / $hmax); + $pm[$i] = $z - $c * $hmax; + } +} + +sub divide # divide the tm array by a long value +{ + $cb = pop(@_); # elements(array) + $x = pop(@_); # value + + $c = 0; + for($i = $cb; $i >= 1; $i--) + { + $z = $tm[$i] + $c; + $q = int($z / $x); + $tm[$i] = $q; + $c = ($z - $q * $x) * $hmax; + } +} + +sub add # add tm array to pm array +{ + $cb = pop(@_); # elements(array) + + $c = 0; + for($i = 1; $i <= $cb; $i++) + { + $z = $pm[$i] + $tm[$i] + $c; + if($z >= $hmax) + { + $pm[$i] = $z - $hmax; + $c = 1; + } + else + { + $pm[$i] = $z; + $c = 0; + } + } +} + +$m0 = 0; $m1 = 0; $m2 = 0; + +sub check_xb # reduce current no. of elements (speed up!) +{ + $cb = pop(@_); # current no. of elements + + if(($pm[$cb] == $m0) && ($pm[$cb - 1] == $m1) && ($pm[$cb - 2] == $m2)) + { + $cb--; + } + $m0 = $pm[$cb]; + $m1 = $pm[$cb - 1]; + $m2 = $pm[$cb - 2]; + $cb; +} + +sub display # show the result +{ + $cb = pop(@_); # elements(array); + + printf("\n%3d.", $pm[$cb]); + $j = $mag - $lmax; + for($i = $cb - 1; $i >= $j; $i--) + { + printf(" %04d", $pm[$i]); + } + print "\n"; +} + +sub the_job # let's do the job +{ + $s = pop(@_); # no. of digits + + $s = int(($s + $lmax - 1) / $lmax) * $lmax; + $b = int($s / $lmax) + $mag - $lmax; + $xb = $b; + $t = int($s * 5 / 3); + + for($i = 1; $i <= $b; $i++) # init arrays + { + $pm[$i] = 0; + $tm[$i] = 0; + } + $pm[$b - 1] = $hmax / 2; + $tm[$b - 1] = $hmax / 2; + + printf("digits:%5d, terms:%5d, elements:%5d\n", $s, $t, $b); + for($n = 1; $n <= $t; $n++) + { + printf("\r\t\t\t term:%5d", $n); + if($n < 200) + { + do mul_tm((4 * ($n * $n - $n) + 1), $xb); + } + else + { + do mul_tm((2 * $n - 1), $xb); + do mul_tm((2 * $n - 1), $xb); + } + if($n < 100) + { + do divide(($n * (16 * $n + 8)), $xb); + } + else + { + do divide((8 * $n), $xb); + do divide((2 * $n + 1), $xb); + } + do add($xb); + if($xb > $mag) + { + $xb = do check_xb($xb); + } + } + do mul_pm(6, $b); + do display($b); + ($user,$sys,$cuser,$csys) = times; + printf("\n[u=%g s=%g cu=%g cs=%g]\n",$user, $sys, $cuser, $csys); +} + +# main block ---------------------------------------------------------------- + +$no_of_args = $#ARGV + 1; +print("$version, "); +die("usage: $my_name ") unless($no_of_args == 1); +$digits = int($ARGV[0]); +die("no. of digits out of range [$smin\..$smax]") + unless(($digits >= $smin) && ($digits <= $smax)); +do the_job($digits); +exit 0; + +# That's all ---------------------------------------------------------------- diff --git a/atarist/test/readme b/atarist/test/readme new file mode 100644 index 0000000..9b75f99 --- /dev/null +++ b/atarist/test/readme @@ -0,0 +1,3 @@ +this directory contain simple tests for the atariST port. to run a test +simply enter + perl file diff --git a/hints/ultrix_1.sh b/hints/ultrix_1.sh new file mode 100644 index 0000000..7569e48 --- /dev/null +++ b/hints/ultrix_1.sh @@ -0,0 +1 @@ +ccflags="$ccflags -DULTRIX_STDIO_BOTCH" diff --git a/lib/pwd.pl b/lib/pwd.pl index 09ba1d2..89fc230 100644 --- a/lib/pwd.pl +++ b/lib/pwd.pl @@ -1,8 +1,11 @@ ;# pwd.pl - keeps track of current working directory in PWD environment var ;# -;# $Header: pwd.pl,v 4.0 91/03/20 01:26:03 lwall Locked $ +;# $RCSfile: pwd.pl,v $$Revision: 4.0.1.1 $$Date: 92/06/08 13:45:22 $ ;# ;# $Log: pwd.pl,v $ +;# Revision 4.0.1.1 92/06/08 13:45:22 lwall +;# patch20: support added to pwd.pl to strip automounter crud +;# ;# Revision 4.0 91/03/20 01:26:03 lwall ;# 4.0 baseline. ;# @@ -25,9 +28,20 @@ sub main'initpwd { if ($ENV{'PWD'}) { local($dd,$di) = stat('.'); local($pd,$pi) = stat($ENV{'PWD'}); - return if $di == $pi && $dd == $pd; + if ($di != $pi || $dd != $pd) { + chop($ENV{'PWD'} = `pwd`); + } + } + else { + chop($ENV{'PWD'} = `pwd`); + } + if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { + local($pd,$pi) = stat($2); + local($dd,$di) = stat($1); + if ($di == $pi && $dd == $pd) { + $ENV{'PWD'}="$2$3"; + } } - chop($ENV{'PWD'} = `pwd`); } sub main'chdir { diff --git a/patchlevel.h b/patchlevel.h index 46afcbb..256548d 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 29 +#define PATCHLEVEL 30 diff --git a/perly.y b/perly.y index 5f31fd1..abcac23 100644 --- a/perly.y +++ b/perly.y @@ -1,4 +1,4 @@ -/* $RCSfile: perly.y,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:17:38 $ +/* $RCSfile: perly.y,v $$Revision: 4.0.1.4 $$Date: 92/06/08 17:33:25 $ * * Copyright (c) 1991, Larry Wall * @@ -6,6 +6,17 @@ * License or the Artistic License, as specified in the README file. * * $Log: perly.y,v $ + * Revision 4.0.1.4 92/06/08 17:33:25 lwall + * patch20: one of the backdoors to expectterm was on the wrong reduction + * + * Revision 4.0.1.3 92/06/08 15:18:16 lwall + * patch20: an expression may now start with a bareword + * patch20: relaxed requirement for semicolon at the end of a block + * patch20: added ... as variant on .. + * patch20: fixed double debug break in foreach with implicit array assignment + * patch20: if {block} {block} didn't work any more + * patch20: deleted some minor memory leaks + * * Revision 4.0.1.2 91/11/05 18:17:38 lwall * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!) * patch11: once-thru blocks didn't display right in the debugger @@ -47,8 +58,8 @@ ARG *arg5; %token '{' ')' -%token WORD -%token APPEND OPEN SSELECT LOOPEX +%token WORD LABEL +%token APPEND OPEN SSELECT LOOPEX DOTDOT %token USING FORMAT DO SHIFT PUSH POP LVALFUN %token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST %token FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25 @@ -95,6 +106,7 @@ prog : /* NULL */ { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); + expectterm = 2; #endif } /*CONTINUED*/ lineseq @@ -116,15 +128,16 @@ else : /* NULL */ { $$ = $2; } | ELSIF '(' expr ')' compblock { cmdline = $1; - $$ = make_ccmd(C_ELSIF,$3,$5); } + $$ = make_ccmd(C_ELSIF,1,$3,$5); } ; block : '{' remember lineseq '}' { $$ = block_head($3); - if (cmdline > $1) + if (cmdline > (line_t)$1) cmdline = $1; if (savestack->ary_fill > $2) - restorelist($2); } + restorelist($2); + expectterm = 2; } ; remember: /* NULL */ /* in case they push a package name */ @@ -150,9 +163,11 @@ line : decl else { $$ = Nullcmd; cmdline = NOLINE; - } } + } + expectterm = 2; } | label sideff ';' - { $$ = add_label($1,$2); } + { $$ = add_label($1,$2); + expectterm = 2; } ; sideff : error @@ -181,28 +196,28 @@ cond : IF '(' expr ')' compblock $$ = invert(make_icmd(C_IF,$3,$5)); } | IF block compblock { cmdline = $1; - $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); } + $$ = make_icmd(C_IF,cmd_to_arg($2),$3); } | UNLESS block compblock { cmdline = $1; - $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); } + $$ = invert(make_icmd(C_IF,cmd_to_arg($2),$3)); } ; loop : label WHILE '(' texpr ')' compblock { cmdline = $2; $$ = wopt(add_label($1, - make_ccmd(C_WHILE,$4,$6) )); } + make_ccmd(C_WHILE,1,$4,$6) )); } | label UNTIL '(' expr ')' compblock { cmdline = $2; $$ = wopt(add_label($1, - invert(make_ccmd(C_WHILE,$4,$6)) )); } + invert(make_ccmd(C_WHILE,1,$4,$6)) )); } | label WHILE block compblock { cmdline = $2; $$ = wopt(add_label($1, - make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); } + make_ccmd(C_WHILE, 1, cmd_to_arg($3),$4) )); } | label UNTIL block compblock { cmdline = $2; $$ = wopt(add_label($1, - invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); } + invert(make_ccmd(C_WHILE,1,cmd_to_arg($3),$4)) )); } | label FOR REG '(' expr crp compblock { cmdline = $2; /* @@ -229,7 +244,7 @@ loop : label WHILE '(' texpr ')' compblock Nullarg)), Nullarg), wopt(over($3,add_label($1, - make_ccmd(C_WHILE, + make_ccmd(C_WHILE, 0, make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), Nullarg,Nullarg ), @@ -239,7 +254,7 @@ loop : label WHILE '(' texpr ')' compblock } else { $$ = wopt(over($3,add_label($1, - make_ccmd(C_WHILE,$5,$7) ))); + make_ccmd(C_WHILE,1,$5,$7) ))); } } | label FOR '(' expr crp compblock @@ -256,7 +271,7 @@ loop : label WHILE '(' texpr ')' compblock Nullarg)), Nullarg), wopt(over(defstab,add_label($1, - make_ccmd(C_WHILE, + make_ccmd(C_WHILE, 0, make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), Nullarg,Nullarg ), @@ -266,7 +281,7 @@ loop : label WHILE '(' texpr ')' compblock } else { /* lisp, anyone? */ $$ = wopt(over(defstab,add_label($1, - make_ccmd(C_WHILE,$4,$6) ))); + make_ccmd(C_WHILE,1,$4,$6) ))); } } | label FOR '(' nexpr ';' texpr ';' nexpr ')' block @@ -275,9 +290,9 @@ loop : label WHILE '(' texpr ')' compblock yyval.compval.comp_alt = $8; cmdline = $2; $$ = append_line($4,wopt(add_label($1, - make_ccmd(C_WHILE,$6,yyval.compval) ))); } + make_ccmd(C_WHILE,1,$6,yyval.compval) ))); } | label compblock /* a block is a loop that happens once */ - { $$ = add_label($1,make_ccmd(C_BLOCK,Nullarg,$2)); } + { $$ = add_label($1,make_ccmd(C_BLOCK,1,Nullarg,$2)); } ; nexpr : /* NULL */ @@ -286,13 +301,13 @@ nexpr : /* NULL */ ; texpr : /* NULL means true */ - { (void)scanstr("1"); $$ = yylval.arg; } + { (void)scanstr("1",SCAN_DEF); $$ = yylval.arg; } | expr ; label : /* empty */ { $$ = Nullch; } - | WORD ':' + | LABEL ; decl : format @@ -339,6 +354,7 @@ package : PACKAGE WORD ';' curstash->tbl_coeffsize = 0; Safefree($2); $2 = Nullch; cmdline = NOLINE; + expectterm = 2; } ; @@ -409,7 +425,8 @@ sexpr : sexpr '=' sexpr { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); } | sexpr DOTDOT sexpr { arg4 = Nullarg; - $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); } + $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); + $$[0].arg_flags |= $2; } | sexpr ANDAND sexpr { $$ = make_op(O_AND, 2, $1, $3, Nullarg); } | sexpr OROR sexpr @@ -449,6 +466,7 @@ term : '-' term %prec UMINUS $$ = make_op($1, 1, stab2arg(A_STAB,stabent($2,TRUE)), Nullarg, Nullarg); + Safefree($2); $2 = Nullch; } | FILETEST sexpr { opargs[$1] = 1; @@ -487,11 +505,12 @@ term : '-' term %prec UMINUS { $$ = make_op(O_ARRAY, 1, stab2arg(A_STAB,$1), Nullarg, Nullarg); } - | REG '{' expr '}' %prec '(' + | REG '{' expr ';' '}' %prec '(' { $$ = make_op(O_HELEM, 2, stab2arg(A_STAB,hadd($1)), jmaybe($3), - Nullarg); } + Nullarg); + expectterm = FALSE; } | '(' expr crp '[' expr ']' %prec '(' { $$ = make_op(O_LSLICE, 3, Nullarg, @@ -507,16 +526,24 @@ term : '-' term %prec UMINUS stab2arg(A_STAB,aadd($1)), listish(make_list($3)), Nullarg); } - | ARY '{' expr '}' %prec '(' + | ARY '{' expr ';' '}' %prec '(' { $$ = make_op(O_HSLICE, 2, stab2arg(A_STAB,hadd($1)), listish(make_list($3)), - Nullarg); } - | DELETE REG '{' expr '}' %prec '(' + Nullarg); + expectterm = FALSE; } + | DELETE REG '{' expr ';' '}' %prec '(' { $$ = make_op(O_DELETE, 2, stab2arg(A_STAB,hadd($2)), jmaybe($4), - Nullarg); } + Nullarg); + expectterm = FALSE; } + | DELETE '(' REG '{' expr ';' '}' ')' %prec '(' + { $$ = make_op(O_DELETE, 2, + stab2arg(A_STAB,hadd($3)), + jmaybe($4), + Nullarg); + expectterm = FALSE; } | ARYLEN %prec '(' { $$ = stab2arg(A_ARYLEN,$1); } | RSTRING %prec '(' @@ -543,17 +570,22 @@ term : '-' term %prec UMINUS stab2arg(A_WORD,stabent($2,MULTI)), make_list(Nullarg), Nullarg); + Safefree($2); $2 = Nullch; $$->arg_flags |= AF_DEPR; } | AMPER WORD '(' ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,MULTI)), make_list(Nullarg), - Nullarg); } + Nullarg); + Safefree($2); $2 = Nullch; + } | AMPER WORD { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,MULTI)), Nullarg, - Nullarg); } + Nullarg); + Safefree($2); $2 = Nullch; + } | DO REG '(' expr crp { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), @@ -609,12 +641,16 @@ term : '-' term %prec UMINUS { $$ = make_op(O_OPEN, 2, stab2arg(A_WORD,stabent($2,TRUE)), stab2arg(A_STAB,stabent($2,TRUE)), - Nullarg); } + Nullarg); + Safefree($2); $2 = Nullch; + } | OPEN '(' WORD ')' { $$ = make_op(O_OPEN, 2, stab2arg(A_WORD,stabent($3,TRUE)), stab2arg(A_STAB,stabent($3,TRUE)), - Nullarg); } + Nullarg); + Safefree($3); $3 = Nullch; + } | OPEN '(' handle cexpr ')' { $$ = make_op(O_OPEN, 2, $3, @@ -763,7 +799,9 @@ listop : LISTOP { $$ = make_op($1,2, stab2arg(A_WORD,stabent($2,TRUE)), stab2arg(A_STAB,defstab), - Nullarg); } + Nullarg); + Safefree($2); $2 = Nullch; + } | LISTOP WORD expr { $$ = make_op($1,2, stab2arg(A_WORD,stabent($2,TRUE)), @@ -823,6 +861,7 @@ bareword: WORD warn( "\"%s\" may clash with future reserved word", $1 ); + Safefree($1); $1 = Nullch; } ; %% /* PROGRAM */ diff --git a/pstruct b/pstruct new file mode 100644 index 0000000..99ce646 --- /dev/null +++ b/pstruct @@ -0,0 +1,1071 @@ +#!/usr/local/bin/perl +# +# +# c2ph (aka pstruct) +# Tom Christiansen, +# +# As pstruct, dump C structures as generated from 'cc -g -S' stabs. +# As c2ph, do this PLUS generate perl code for getting at the structures. +# +# See the usage message for more. If this isn't enough, read the code. +# + +$RCSID = '$RCSfile: pstruct,v $$Revision: 4.0.1.1 $$Date: 92/06/08 15:19:40 $'; + + +###################################################################### + +# some handy data definitions. many of these can be reset later. + +$bitorder = 'b'; # ascending; set to B for descending bit fields + +%intrinsics = +%template = ( + 'char', 'c', + 'unsigned char', 'C', + 'short', 's', + 'short int', 's', + 'unsigned short', 'S', + 'unsigned short int', 'S', + 'short unsigned int', 'S', + 'int', 'i', + 'unsigned int', 'I', + 'long', 'l', + 'long int', 'l', + 'unsigned long', 'L', + 'unsigned long', 'L', + 'long unsigned int', 'L', + 'unsigned long int', 'L', + 'long long', 'q', + 'long long int', 'q', + 'unsigned long long', 'Q', + 'unsigned long long int', 'Q', + 'float', 'f', + 'double', 'd', + 'pointer', 'p', + 'null', 'x', + 'neganull', 'X', + 'bit', $bitorder, +); + +&buildscrunchlist; +delete $intrinsics{'neganull'}; +delete $intrinsics{'bit'}; +delete $intrinsics{'null'}; + +# use -s to recompute sizes +%sizeof = ( + 'char', '1', + 'unsigned char', '1', + 'short', '2', + 'short int', '2', + 'unsigned short', '2', + 'unsigned short int', '2', + 'short unsigned int', '2', + 'int', '4', + 'unsigned int', '4', + 'long', '4', + 'long int', '4', + 'unsigned long', '4', + 'unsigned long int', '4', + 'long unsigned int', '4', + 'long long', '8', + 'long long int', '8', + 'unsigned long long', '8', + 'unsigned long long int', '8', + 'float', '4', + 'double', '8', + 'pointer', '4', +); + +($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); + +($offset_fmt, $size_fmt) = ('d', 'd'); + +$indent = 2; + +$CC = 'cc'; +$CFLAGS = '-g -S'; +$DEFINES = ''; + +$perl++ if $0 =~ m#/?c2ph$#; + +require 'getopts.pl'; + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +&Getopts('aixdpvtnws:') || &usage(0); + +$opt_d && $debug++; +$opt_t && $trace++; +$opt_p && $perl++; +$opt_v && $verbose++; +$opt_n && ($perl = 0); + +if ($opt_w) { + ($type_width, $member_width, $offset_width) = (45, 35, 8); +} +if ($opt_x) { + ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); +} + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +sub PLUMBER { + select(STDERR); + print "oops, apperent pager foulup\n"; + $isatty++; + &usage(1); +} + +sub usage { + local($oops) = @_; + unless (-t STDOUT) { + select(STDERR); + } elsif (!$oops) { + $isatty++; + $| = 1; + print "hit for further explanation: "; + ; + open (PIPE, "|". ($ENV{PAGER} || 'more')); + $SIG{PIPE} = PLUMBER; + select(PIPE); + } + + print "usage: $0 [-dpnP] [var=val] [files ...]\n"; + + exit unless $isatty; + + print < 1) { + warn "Only one *.s file allowed!\n"; + &usage; + } + } + elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { + local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; + $chdir = "cd $dir; " if $dir; + &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; + $ARGV[0] =~ s/\.c$/.s/; + } + else { + $TMP = "/tmp/c2ph.$$.c"; + &system("cat @ARGV > $TMP") && exit 1; + &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; + unlink $TMP; + $TMP =~ s/\.c$/.s/; + @ARGV = ($TMP); + } +} + +if ($opt_s) { + for (split(/[\s,]+/, $opt_s)) { + $interested{$_}++; + } +} + + +$| = 1 if $debug; + +main: { + + if ($trace) { + if (-t && !@ARGV) { + print STDERR "reading from your keyboard: "; + } else { + print STDERR "reading from " . (@ARGV ? "@ARGV" : "").": "; + } + } + +STAB: while (<>) { + if ($trace && !($. % 10)) { + $lineno = $..''; + print STDERR $lineno, "\b" x length($lineno); + } + next unless /^\s*\.stabs\s+/; + $line = $_; + s/^\s*\.stabs\s+//; + &stab; + } + print STDERR "$.\n" if $trace; + unlink $TMP if $TMP; + + &compute_intrinsics if $perl && !$opt_i; + + print STDERR "resolving types\n" if $trace; + + &resolve_types; + &adjust_start_addrs; + + $sum = 2 + $type_width + $member_width; + $pmask1 = "%-${type_width}s %-${member_width}s"; + $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; + + if ($perl) { + # resolve template -- should be in stab define order, but even this isn't enough. + print STDERR "\nbuilding type templates: " if $trace; + for $i (reverse 0..$#type) { + next unless defined($name = $type[$i]); + next unless defined $struct{$name}; + $build_recursed = 0; + &build_template($name) unless defined $template{&psou($name)} || + $opt_s && !$interested{$name}; + } + print STDERR "\n\n" if $trace; + } + + print STDERR "dumping structs: " if $trace; + + + foreach $name (sort keys %struct) { + next if $opt_s && !$interested{$name}; + print STDERR "$name " if $trace; + + undef @sizeof; + undef @typedef; + undef @offsetof; + undef @indices; + undef @typeof; + + $mname = &munge($name); + + $fname = &psou($name); + + print "# " if $perl && $verbose; + $pcode = ''; + print "$fname {\n" if !$perl || $verbose; + $template{$fname} = &scrunch($template{$fname}) if $perl; + &pstruct($name,$name,0); + print "# " if $perl && $verbose; + print "}\n" if !$perl || $verbose; + print "\n" if $perl && $verbose; + + if ($perl) { + print "$pcode"; + + printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); + + print < $sizeof{$b}; } + + + foreach $name (sort keys %intrinsics) { + print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; + } + + print "\n1;\n"; + + exit; +} + +######################################################################################## + + +sub stab { + next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun + s/"// || next; + s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; + + next if /^\s*$/; + + $size = $3 if $3; + + + $line = $_; + + if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { + print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; + &pdecl($pdecl); + next; + } + + + + if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { + local($ident) = $2; + push(@intrinsics, $ident); + $typeno = &typeno($3); + $type[$typeno] = $ident; + print STDERR "intrinsic $ident in new type $typeno\n" if $debug; + next; + } + + if (($name, $typeordef, $typeno, $extra, $struct, $_) + = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) + { + $typeno = &typeno($typeno); # sun foolery + } + elsif (/^[\$\w]+:/) { + next; # variable + } + else { + warn "can't grok stab: <$_> in: $line " if $_; + next; + } + + #warn "got size $size for $name\n"; + $sizeof{$name} = $size if $size; + + s/;[-\d]*;[-\d]*;$//; # we don't care about ranges + + $typenos{$name} = $typeno; + + unless (defined $type[$typeno]) { + &panic("type 0??") unless $typeno; + $type[$typeno] = $name unless defined $type[$typeno]; + printf "new type $typeno is $name" if $debug; + if ($extra =~ /\*/ && defined $type[$struct]) { + print ", a typedef for a pointer to " , $type[$struct] if $debug; + } + } else { + printf "%s is type %d", $name, $typeno if $debug; + print ", a typedef for " , $type[$typeno] if $debug; + } + print "\n" if $debug; + #next unless $extra =~ /[su*]/; + + #$type[$struct] = $name; + + if ($extra =~ /[us*]/) { + &sou($name, $extra); + $_ = &sdecl($name, $_, 0); + } + elsif (/^=ar/) { + print "it's a bare array typedef -- that's pretty sick\n" if $debug; + $_ = "$typeno$_"; + $scripts = ''; + $_ = &adecl($_,1); + + } + elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc + push(@intrinsics, $2); + $typeno = &typeno($3); + $type[$typeno] = $2; + print STDERR "intrinsic $2 in new type $typeno\n" if $debug; + } + elsif (s/^=e//) { # blessed by thy compiler; mine won't do this + &edecl; + } + else { + warn "Funny remainder for $name on line $_ left in $line " if $_; + } +} + +sub typeno { # sun thinks types are (0,27) instead of just 27 + local($_) = @_; + s/\(\d+,(\d+)\)/$1/; + $_; +} + +sub pstruct { + local($what,$prefix,$base) = @_; + local($field, $fieldname, $typeno, $count, $offset, $entry); + local($fieldtype); + local($type, $tname); + local($mytype, $mycount, $entry2); + local($struct_count) = 0; + local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); + local($bits,$bytes); + local($template); + + + local($mname) = &munge($name); + + sub munge { + local($_) = @_; + s/[\s\$\.]/_/g; + $_; + } + + local($sname) = &psou($what); + + $nesting++; + + for $field (split(/;/, $struct{$what})) { + $pad = $prepad = 0; + $entry = ''; + ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); + + $type = $type[$typeno]; + + $type =~ /([^[]*)(\[.*\])?/; + $mytype = $1; + $count .= $2; + $fieldtype = &psou($mytype); + + local($fname) = &psou($name); + + if ($build_templates) { + + $pad = ($offset - ($lastoffset + $lastlength))/8 + if defined $lastoffset; + + if (! $finished_template{$sname}) { + if ($isaunion{$what}) { + $template{$sname} .= 'X' x $revpad . ' ' if $revpad; + } else { + $template{$sname} .= 'x' x $pad . ' ' if $pad; + } + } + + $template = &fetch_template($type) x + ($count ? &scripts2count($count) : 1); + + if (! $finished_template{$sname}) { + $template{$sname} .= $template; + } + + $revpad = $length/8 if $isaunion{$what}; + + ($lastoffset, $lastlength) = ($offset, $length); + + } else { + print '# ' if $perl && $verbose; + $entry = sprintf($pmask1, + ' ' x ($nesting * $indent) . $fieldtype, + "$prefix.$fieldname" . $count); + + $entry =~ s/(\*+)( )/$2$1/; + + printf $pmask2, + $entry, + ($base+$offset)/8, + ($bits = ($base+$offset)%8) ? ".$bits" : " ", + $length/8, + ($bits = $length % 8) ? ".$bits": "" + if !$perl || $verbose; + + + if ($perl && $nesting == 1) { + $template = &scrunch(&fetch_template($type) x + ($count ? &scripts2count($count) : 1)); + push(@sizeof, int($length/8) .",\t# $fieldname"); + push(@offsetof, int($offset/8) .",\t# $fieldname"); + push(@typedef, "'$template', \t# $fieldname"); + $type =~ s/(struct|union) //; + push(@typeof, "'$type" . ($count ? $count : '') . + "',\t# $fieldname"); + } + + print ' ', ' ' x $indent x $nesting, $template + if $perl && $verbose; + + print "\n" if !$perl || $verbose; + + } + if ($perl) { + local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; + $mycount *= &scripts2count($count) if $count; + if ($nesting==1 && !$build_templates) { + $pcode .= sprintf("sub %-32s { %4d; }\n", + "${mname}'${fieldname}", $struct_count); + push(@indices, $struct_count); + } + $struct_count += $mycount; + } + + + &pstruct($type, "$prefix.$fieldname", $base+$offset) + if $recurse && defined $struct{$type}; + } + + $countof{$what} = $struct_count unless defined $countof{$whati}; + + $template{$sname} .= '$' if $build_templates; + $finished_template{$sname}++; + + if ($build_templates && !defined $sizeof{$name}) { + local($fmt) = &scrunch($template{$sname}); + print STDERR "no size for $name, punting with $fmt..." if $debug; + eval '$sizeof{$name} = length(pack($fmt, ()))'; + if ($@) { + chop $@; + warn "couldn't get size for \$name: $@"; + } else { + print STDERR $sizeof{$name}, "\n" if $debUg; + } + } + + --$nesting; +} + + +sub psize { + local($me) = @_; + local($amstruct) = $struct{$me} ? 'struct ' : ''; + + print '$sizeof{\'', $amstruct, $me, '\'} = '; + printf "%d;\n", $sizeof{$me}; +} + +sub pdecl { + local($pdecl) = @_; + local(@pdecls); + local($tname); + + warn "pdecl: $pdecl\n" if $debug; + + $pdecl =~ s/\(\d+,(\d+)\)/$1/g; + $pdecl =~ s/\*//g; + @pdecls = split(/=/, $pdecl); + $typeno = $pdecls[0]; + $tname = pop @pdecls; + + if ($tname =~ s/^f//) { $tname = "$tname&"; } + #else { $tname = "$tname*"; } + + for (reverse @pdecls) { + $tname .= s/^f// ? "&" : "*"; + #$tname =~ s/^f(.*)/$1&/; + print "type[$_] is $tname\n" if $debug; + $type[$_] = $tname unless defined $type[$_]; + } +} + + + +sub adecl { + ($arraytype, $unknown, $lower, $upper) = (); + #local($typeno); + # global $typeno, @type + local($_, $typedef) = @_; + + while (s/^((\d+)=)?ar(\d+);//) { + ($arraytype, $unknown) = ($2, $3); + if (s/^(\d+);(\d+);//) { + ($lower, $upper) = ($1, $2); + $scripts .= '[' . ($upper+1) . ']'; + } else { + warn "can't find array bounds: $_"; + } + } + if (s/^([\d*f=]*),(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + local($whatis) = $1; + if ($whatis =~ /^(\d+)=/) { + $typeno = $1; + &pdecl($whatis); + } else { + $typeno = $whatis; + } + } elsif (s/^(\d+)(=[*suf]\d*)//) { + local($whatis) = $2; + + if ($whatis =~ /[f*]/) { + &pdecl($whatis); + } elsif ($whatis =~ /[su]/) { # + print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" + if $debug; + #$type[$typeno] = $name unless defined $type[$typeno]; + ##printf "new type $typeno is $name" if $debug; + $typeno = $1; + $type[$typeno] = "$prefix.$fieldname"; + local($name) = $type[$typeno]; + &sou($name, $whatis); + $_ = &sdecl($name, $_, $start+$offset); + 1; + $start = $start{$name}; + $offset = $sizeof{$name}; + $length = $offset; + } else { + warn "what's this? $whatis in $line "; + } + } elsif (/^\d+$/) { + $typeno = $_; + } else { + warn "bad array stab: $_ in $line "; + next STAB; + } + #local($wasdef) = defined($type[$typeno]) && $debug; + #if ($typedef) { + #print "redefining $type[$typeno] to " if $wasdef; + #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; + #print "$type[$typeno]\n" if $wasdef; + #} else { + #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; + #} + $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; + print "type[$arraytype] is $type[$arraytype]\n" if $debug; + print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; + $_; +} + + + +sub sdecl { + local($prefix, $_, $offset) = @_; + + local($fieldname, $scripts, $type, $arraytype, $unknown, + $whatis, $pdecl, $upper,$lower, $start,$length) = (); + local($typeno,$sou); + + +SFIELD: + while (/^([^;]+);/) { + $scripts = ''; + warn "sdecl $_\n" if $debug; + if (s/^([\$\w]+)://) { + $fieldname = $1; + } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # + $typeno = &typeno($1); + $type[$typeno] = "$prefix.$fieldname"; + local($name) = "$prefix.$fieldname"; + &sou($name,$2); + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $offset += $sizeof{$name}; + #print "done with anon, start is $start, offset is $offset\n"; + #next SFIELD; + } else { + warn "weird field $_ of $line" if $debug; + next STAB; + #$fieldname = &gensym; + #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + } + + if (/^\d+=ar/) { + $_ = &adecl($_); + } + elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + &panic("no length?") unless $length; + $typeno = &typeno($1) if $1; + } + elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { + ($pdecl, $start, $length) = ($1,$5,$6); + &pdecl($pdecl); + } + elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct + ($typeno, $sou) = ($1, $2); + $typeno = &typeno($typeno); + if (defined($type[$typeno])) { + warn "now how did we get type $1 in $fieldname of $line?"; + } else { + print "anon type $typeno is $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; + }; + local($name) = "$prefix.$fieldname"; + &sou($name,$sou); + print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname"; + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $length = $sizeof{$name}; + } + else { + warn "can't grok stab for $name ($_) in line $line "; + next STAB; + } + + &panic("no length for $prefix.$fieldname") unless $length; + $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; + } + if (s/;\d*,(\d+),(\d+);//) { + local($start, $size) = ($1, $2); + $sizeof{$prefix} = $size; + print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; + $start{$prefix} = $start; + } + $_; +} + +sub edecl { + s/;$//; + $enum{$name} = $_; + $_ = ''; +} + +sub resolve_types { + local($sou); + for $i (0 .. $#type) { + next unless defined $type[$i]; + $_ = $type[$i]; + unless (/\d/) { + print "type[$i] $type[$i]\n" if $debug; + next; + } + print "type[$i] $_ ==> " if $debug; + s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; + s/^(\d+)\&/&type($1)/e; + s/^(\d+)/&type($1)/e; + s/(\*+)([^*]+)(\*+)/$1$3$2/; + s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; + s/^(\d+)([\*\[].*)/&type($1).$2/e; + #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; + $type[$i] = $_; + print "$_\n" if $debug; + } +} +sub type { &psou($type[$_[0]] || ""); } + +sub adjust_start_addrs { + for (sort keys %start) { + ($basename = $_) =~ s/\.[^.]+$//; + $start{$_} += $start{$basename}; + print "start: $_ @ $start{$_}\n" if $debug; + } +} + +sub sou { + local($what, $_) = @_; + /u/ && $isaunion{$what}++; + /s/ && $isastruct{$what}++; +} + +sub psou { + local($what) = @_; + local($prefix) = ''; + if ($isaunion{$what}) { + $prefix = 'union '; + } elsif ($isastruct{$what}) { + $prefix = 'struct '; + } + $prefix . $what; +} + +sub scrunch { + local($_) = @_; + + study; + + s/\$//g; + s/ / /g; + 1 while s/(\w) \1/$1$1/g; + + # i wanna say this, but perl resists my efforts: + # s/(\w)(\1+)/$2 . length($1)/ge; + + &quick_scrunch; + + s/ $//; + + $_; +} + +sub buildscrunchlist { + $scrunch_code = "sub quick_scrunch {\n"; + for (values %intrinsics) { + $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n"; + } + $scrunch_code .= "}\n"; + print "$scrunch_code" if $debug; + eval $scrunch_code; + &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; +} + +sub fetch_template { + local($mytype) = @_; + local($fmt); + local($count) = 1; + + &panic("why do you care?") unless $perl; + + if ($mytype =~ s/(\[\d+\])+$//) { + $count .= $1; + } + + if ($mytype =~ /\*/) { + $fmt = $template{'pointer'}; + } + elsif (defined $template{$mytype}) { + $fmt = $template{$mytype}; + } + elsif (defined $struct{$mytype}) { + if (!defined $template{&psou($mytype)}) { + &build_template($mytype) unless $mytype eq $name; + } + elsif ($template{&psou($mytype)} !~ /\$$/) { + #warn "incomplete template for $mytype\n"; + } + $fmt = $template{&psou($mytype)} || '?'; + } + else { + warn "unknown fmt for $mytype\n"; + $fmt = '?'; + } + + $fmt x $count . ' '; +} + +sub compute_intrinsics { + local($TMP) = "/tmp/c2ph-i.$$.c"; + open (TMP, ">$TMP") || die "can't open $TMP: $!"; + select(TMP); + + print STDERR "computing intrinsic sizes: " if $trace; + + undef %intrinsics; + + print <<'EOF'; +main() { + char *mask = "%d %s\n"; +EOF + + for $type (@intrinsics) { + next if $type eq 'void'; + print <<"EOF"; + printf(mask,sizeof($type), "$type"); +EOF + } + + print <<'EOF'; + printf(mask,sizeof(char *), "pointer"); + exit(0); +} +EOF + close TMP; + + select(STDOUT); + open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); + while () { + chop; + split(' ',$_,2);; + print "intrinsic $_[1] is size $_[0]\n" if $debug; + $sizeof{$_[1]} = $_[0]; + $intrinsics{$_[1]} = $template{$_[0]}; + } + close(PIPE) || die "couldn't read intrinsics!"; + unlink($TMP, '/tmp/a.out'); + print STDERR "done\n" if $trace; +} + +sub scripts2count { + local($_) = @_; + + s/^\[//; + s/\]$//; + s/\]\[/*/g; + $_ = eval; + &panic("$_: $@") if $@; + $_; +} + +sub system { + print STDERR "@_\n" if $trace; + system @_; +} + +sub build_template { + local($name) = @_; + + &panic("already got a template for $name") if defined $template{$name}; + + local($build_templates) = 1; + + local($lparen) = '(' x $build_recursed; + local($rparen) = ')' x $build_recursed; + + print STDERR "$lparen$name$rparen " if $trace; + $build_recursed++; + &pstruct($name,$name,0); + print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; + --$build_recursed; +} + + +sub panic { + + select(STDERR); + + print "\npanic: @_\n"; + + exit 1 if $] <= 4.003; # caller broken + + local($i,$_); + local($p,$f,$l,$s,$h,$a,@a,@sub); + for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = @DB'args; + for (@a) { + if (/^StB\000/ && length($_) == length($_main{'_main'})) { + $_ = sprintf("%s",$_); + } + else { + s/'/\\'/g; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + push(@sub, "$w&$s$a from file $f line $l\n"); + last if $signal; + } + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + print $sub[$i]; + } + exit 1; +} + +sub squishseq { + local($num); + local($last) = -1e8; + local($string); + local($seq) = '..'; + + while (defined($num = shift)) { + if ($num == ($last + 1)) { + $string .= $seq unless $inseq++; + $last = $num; + next; + } elsif ($inseq) { + $string .= $last unless $last == -1e8; + } + + $string .= ',' if defined $string; + $string .= $num; + $last = $num; + $inseq = 0; + } + $string .= $last if $inseq && $last != -e18; + $string; +} diff --git a/t/op/readdir.t b/t/op/readdir.t index 8125bd4..1800699 100644 --- a/t/op/readdir.t +++ b/t/op/readdir.t @@ -6,13 +6,13 @@ if ($@) { print "1..0\n"; exit; } print "1..3\n"; if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } -@D = grep(/^[^\.]/, readdir(OP)); +@D = grep(/^[^\.].*\.t$/, readdir(OP)); closedir(OP); if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } @R = sort @D; -@G = ; +@G = ; while (@R && @G && "op/".$R[0] eq $G[0]) { shift(@R); shift(@G);