pstruct

   1 #!/usr/local/bin/perl
   2 #
   3 #
   4 #   c2ph (aka pstruct)
   5 #   Tom Christiansen, <tchrist@convex.com>
   6 #
   7 #   As pstruct, dump C structures as generated from 'cc -g -S' stabs.
   8 #   As c2ph, do this PLUS generate perl code for getting at the structures.
   9 #
  10 #   See the usage message for more.  If this isn't enough, read the code.
  11 #
  12
  13 $RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.1 $$Date: 92/08/07 17:19:10 $';
  14
  15
  16 ######################################################################
  17
  18 # some handy data definitions.   many of these can be reset later.
  19
  20 $bitorder = 'b';  # ascending; set to B for descending bit fields
  21
  22 %intrinsics =
  23 %template = (
  24     'char',                     'c',
  25     'unsigned char',            'C',
  26     'short',                    's',
  27     'short int',                's',
  28     'unsigned short',           'S',
  29     'unsigned short int',       'S',
  30     'short unsigned int',       'S',
  31     'int',                      'i',
  32     'unsigned int',             'I',
  33     'long',                     'l',
  34     'long int',                 'l',
  35     'unsigned long',            'L',
  36     'unsigned long',            'L',
  37     'long unsigned int',        'L',
  38     'unsigned long int',        'L',
  39     'long long',                'q',
  40     'long long int',            'q',
  41     'unsigned long long',       'Q',
  42     'unsigned long long int',   'Q',
  43     'float',                    'f',
  44     'double',                   'd',
  45     'pointer',                  'p',
  46     'null',                     'x',
  47     'neganull',                 'X',
  48     'bit',                      $bitorder,
  49 );
  50
  51 &buildscrunchlist;
  52 delete $intrinsics{'neganull'};
  53 delete $intrinsics{'bit'};
  54 delete $intrinsics{'null'};
  55
  56 # use -s to recompute sizes
  57 %sizeof = (
  58     'char',                     '1',
  59     'unsigned char',            '1',
  60     'short',                    '2',
  61     'short int',                '2',
  62     'unsigned short',           '2',
  63     'unsigned short int',       '2',
  64     'short unsigned int',       '2',
  65     'int',                      '4',
  66     'unsigned int',             '4',
  67     'long',                     '4',
  68     'long int',                 '4',
  69     'unsigned long',            '4',
  70     'unsigned long int',        '4',
  71     'long unsigned int',        '4',
  72     'long long',                '8',
  73     'long long int',            '8',
  74     'unsigned long long',       '8',
  75     'unsigned long long int',   '8',
  76     'float',                    '4',
  77     'double',                   '8',
  78     'pointer',                  '4',
  79 );
  80
  81 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
  82
  83 ($offset_fmt, $size_fmt) = ('d', 'd');
  84
  85 $indent = 2;
  86
  87 $CC = 'cc';
  88 $CFLAGS = '-g -S';
  89 $DEFINES = '';
  90
  91 $perl++ if $0 =~ m#/?c2ph$#;
  92
  93 require 'getopts.pl';
  94
  95 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
  96
  97 &Getopts('aixdpvtnws:') || &usage(0);
  98
  99 $opt_d && $debug++;
 100 $opt_t && $trace++;
 101 $opt_p && $perl++;
 102 $opt_v && $verbose++;
 103 $opt_n && ($perl = 0);
 104
 105 if ($opt_w) {
 106     ($type_width, $member_width, $offset_width) = (45, 35, 8);
 107 }
 108 if ($opt_x) {
 109     ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
 110 }
 111
 112 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
 113
 114 sub PLUMBER {
 115     select(STDERR);
 116     print "oops, apperent pager foulup\n";
 117     $isatty++;
 118     &usage(1);
 119 }
 120
 121 sub usage {
 122     local($oops) = @_;
 123     unless (-t STDOUT) {
 124         select(STDERR);
 125     } elsif (!$oops) {
 126         $isatty++;
 127         $| = 1;
 128         print "hit <RETURN> for further explanation: ";
 129         <STDIN>;
 130         open (PIPE, "|". ($ENV{PAGER} || 'more'));
 131         $SIG{PIPE} = PLUMBER;
 132         select(PIPE);
 133     }
 134
 135     print "usage: $0 [-dpnP] [var=val] [files ...]\n";
 136
 137     exit unless $isatty;
 138
 139     print <<EOF;
 140
 141 Options:
 142
 143 -w      wide; short for: type_width=45 member_width=35 offset_width=8
 144 -x      hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
 145
 146 -n      do not generate perl code  (default when invoked as pstruct)
 147 -p      generate perl code         (default when invoked as c2ph)
 148 -v      generate perl code, with C decls as comments
 149
 150 -i      do NOT recompute sizes for intrinsic datatypes
 151 -a      dump information on intrinsics also
 152
 153 -t      trace execution
 154 -d      spew reams of debugging output
 155
 156 -slist  give comma-separated list a structures to dump
 157
 158
 159 Var Name        Default Value    Meaning
 160
 161 EOF
 162
 163     &defvar('CC', 'which_compiler to call');
 164     &defvar('CFLAGS', 'how to generate *.s files with stabs');
 165     &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
 166
 167     print "\n";
 168
 169     &defvar('type_width', 'width of type field   (column 1)');
 170     &defvar('member_width', 'width of member field (column 2)');
 171     &defvar('offset_width', 'width of offset field (column 3)');
 172     &defvar('size_width', 'width of size field   (column 4)');
 173
 174     print "\n";
 175
 176     &defvar('offset_fmt', 'sprintf format type for offset');
 177     &defvar('size_fmt', 'sprintf format type for size');
 178
 179     print "\n";
 180
 181     &defvar('indent', 'how far to indent each nesting level');
 182
 183    print <<'EOF';
 184
 185     If any *.[ch] files are given, these will be catted together into
 186     a temporary *.c file and sent through:
 187             $CC $CFLAGS $DEFINES
 188     and the resulting *.s groped for stab information.  If no files are
 189     supplied, then stdin is read directly with the assumption that it
 190     contains stab information.  All other liens will be ignored.  At
 191     most one *.s file should be supplied.
 192
 193 EOF
 194     close PIPE;
 195     exit 1;
 196 }
 197
 198 sub defvar {
 199     local($var, $msg) = @_;
 200     printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;
 201 }
 202
 203 $recurse = 1;
 204
 205 if (@ARGV) {
 206     if (grep(!/\.[csh]$/,@ARGV)) {
 207         warn "Only *.[csh] files expected!\n";
 208         &usage;
 209     }
 210     elsif (grep(/\.s$/,@ARGV)) {
 211         if (@ARGV > 1) {
 212             warn "Only one *.s file allowed!\n";
 213             &usage;
 214         }
 215     }
 216     elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
 217         local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
 218         $chdir = "cd $dir; " if $dir;
 219         &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
 220         $ARGV[0] =~ s/\.c$/.s/;
 221     }
 222     else {
 223         $TMP = "/tmp/c2ph.$$.c";
 224         &system("cat @ARGV > $TMP") && exit 1;
 225         &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
 226         unlink $TMP;
 227         $TMP =~ s/\.c$/.s/;
 228         @ARGV = ($TMP);
 229     }
 230 }
 231
 232 if ($opt_s) {
 233     for (split(/[\s,]+/, $opt_s)) {
 234         $interested{$_}++;
 235     }
 236 }
 237
 238
 239 $| = 1 if $debug;
 240
 241 main: {
 242
 243     if ($trace) {
 244         if (-t && !@ARGV) {
 245             print STDERR "reading from your keyboard: ";
 246         } else {
 247             print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
 248         }
 249     }
 250
 251 STAB: while (<>) {
 252         if ($trace && !($. % 10)) {
 253             $lineno = $..'';
 254             print STDERR $lineno, "\b" x length($lineno);
 255         }
 256         next unless /^\s*\.stabs\s+/;
 257         $line = $_;
 258         s/^\s*\.stabs\s+//;
 259         &stab;
 260     }
 261     print STDERR "$.\n" if $trace;
 262     unlink $TMP if $TMP;
 263
 264     &compute_intrinsics if $perl && !$opt_i;
 265
 266     print STDERR "resolving types\n" if $trace;
 267
 268     &resolve_types;
 269     &adjust_start_addrs;
 270
 271     $sum = 2 + $type_width + $member_width;
 272     $pmask1 = "%-${type_width}s %-${member_width}s";
 273     $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
 274
 275     if ($perl) {
 276         # resolve template -- should be in stab define order, but even this isn't enough.
 277         print STDERR "\nbuilding type templates: " if $trace;
 278         for $i (reverse 0..$#type) {
 279             next unless defined($name = $type[$i]);
 280             next unless defined $struct{$name};
 281             $build_recursed = 0;
 282             &build_template($name) unless defined $template{&psou($name)} ||
 283                                         $opt_s && !$interested{$name};
 284         }
 285         print STDERR "\n\n" if $trace;
 286     }
 287
 288     print STDERR "dumping structs: " if $trace;
 289
 290
 291     foreach $name (sort keys %struct) {
 292         next if $opt_s && !$interested{$name};
 293         print STDERR "$name " if $trace;
 294
 295         undef @sizeof;
 296         undef @typedef;
 297         undef @offsetof;
 298         undef @indices;
 299         undef @typeof;
 300
 301         $mname = &munge($name);
 302
 303         $fname = &psou($name);
 304
 305         print "# " if $perl && $verbose;
 306         $pcode = '';
 307         print "$fname {\n" if !$perl || $verbose;
 308         $template{$fname} = &scrunch($template{$fname}) if $perl;
 309         &pstruct($name,$name,0);
 310         print "# " if $perl && $verbose;
 311         print "}\n" if !$perl || $verbose;
 312         print "\n" if $perl && $verbose;
 313
 314         if ($perl) {
 315             print "$pcode";
 316
 317             printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
 318
 319             print <<EOF;
 320 sub ${mname}'typedef {
 321     local(\$${mname}'index) = shift;
 322     defined \$${mname}'index
 323         ? \$${mname}'typedef[\$${mname}'index]
 324         : \$${mname}'typedef;
 325 }
 326 EOF
 327
 328             print <<EOF;
 329 sub ${mname}'sizeof {
 330     local(\$${mname}'index) = shift;
 331     defined \$${mname}'index
 332         ? \$${mname}'sizeof[\$${mname}'index]
 333         : \$${mname}'sizeof;
 334 }
 335 EOF
 336
 337             print <<EOF;
 338 sub ${mname}'offsetof {
 339     local(\$${mname}'index) = shift;
 340     defined \$${mname}index
 341         ? \$${mname}'offsetof[\$${mname}'index]
 342         : \$${mname}'sizeof;
 343 }
 344 EOF
 345
 346             print <<EOF;
 347 sub ${mname}'typeof {
 348     local(\$${mname}'index) = shift;
 349     defined \$${mname}index
 350         ? \$${mname}'typeof[\$${mname}'index]
 351         : '$name';
 352 }
 353 EOF
 354
 355
 356             print "\$${mname}'typedef = '" . &scrunch($template{$fname})
 357                 . "';\n";
 358
 359             print "\$${mname}'sizeof = $sizeof{$name};\n\n";
 360
 361
 362             print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
 363
 364             print "\n";
 365
 366             print "\@${mname}'typedef[\@${mname}'indices] = (",
 367                         join("\n\t", '', @typedef), "\n    );\n\n";
 368             print "\@${mname}'sizeof[\@${mname}'indices] = (",
 369                         join("\n\t", '', @sizeof), "\n    );\n\n";
 370             print "\@${mname}'offsetof[\@${mname}'indices] = (",
 371                         join("\n\t", '', @offsetof), "\n    );\n\n";
 372             print "\@${mname}'typeof[\@${mname}'indices] = (",
 373                         join("\n\t", '', @typeof), "\n    );\n\n";
 374
 375             $template_printed{$fname}++;
 376             $size_printed{$fname}++;
 377         }
 378         print "\n";
 379     }
 380
 381     print STDERR "\n" if $trace;
 382
 383     unless ($perl && $opt_a) {
 384         print "\n1;\n";
 385         exit;
 386     }
 387
 388
 389
 390     foreach $name (sort bysizevalue keys %intrinsics) {
 391         next if $size_printed{$name};
 392         print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
 393     }
 394
 395     print "\n";
 396
 397     sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
 398
 399
 400     foreach $name (sort keys %intrinsics) {
 401         print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
 402     }
 403
 404     print "\n1;\n";
 405
 406     exit;
 407 }
 408
 409 ########################################################################################
 410
 411
 412 sub stab {
 413     next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/;  # (\d+,\d+) is for sun
 414     s/"//                                               || next;
 415     s/",([x\d]+),([x\d]+),([x\d]+),.*//                 || next;
 416
 417     next if /^\s*$/;
 418
 419     $size = $3 if $3;
 420
 421
 422     $line = $_;
 423
 424     if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
 425         print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
 426         &pdecl($pdecl);
 427         next;
 428     }
 429
 430
 431
 432     if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
 433         local($ident) = $2;
 434         push(@intrinsics, $ident);
 435         $typeno = &typeno($3);
 436         $type[$typeno] = $ident;
 437         print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
 438         next;
 439     }
 440
 441     if (($name, $typeordef, $typeno, $extra, $struct, $_)
 442         = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
 443     {
 444         $typeno = &typeno($typeno);  # sun foolery
 445     }
 446     elsif (/^[\$\w]+:/) {
 447         next; # variable
 448     }
 449     else {
 450         warn "can't grok stab: <$_> in: $line " if $_;
 451         next;
 452     }
 453
 454     #warn "got size $size for $name\n";
 455     $sizeof{$name} = $size if $size;
 456
 457     s/;[-\d]*;[-\d]*;$//;  # we don't care about ranges
 458
 459     $typenos{$name} = $typeno;
 460
 461     unless (defined $type[$typeno]) {
 462         &panic("type 0??") unless $typeno;
 463         $type[$typeno] = $name unless defined $type[$typeno];
 464         printf "new type $typeno is $name" if $debug;
 465         if ($extra =~ /\*/ && defined $type[$struct]) {
 466             print ", a typedef for a pointer to " , $type[$struct] if $debug;
 467         }
 468     } else {
 469         printf "%s is type %d", $name, $typeno if $debug;
 470         print ", a typedef for " , $type[$typeno] if $debug;
 471     }
 472     print "\n" if $debug;
 473     #next unless $extra =~ /[su*]/;
 474
 475     #$type[$struct] = $name;
 476
 477     if ($extra =~ /[us*]/) {
 478         &sou($name, $extra);
 479         $_ = &sdecl($name, $_, 0);
 480     }
 481     elsif (/^=ar/) {
 482         print "it's a bare array typedef -- that's pretty sick\n" if $debug;
 483         $_ = "$typeno$_";
 484         $scripts = '';
 485         $_ = &adecl($_,1);
 486
 487     }
 488     elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) {  # the ?'s are for gcc
 489         push(@intrinsics, $2);
 490         $typeno = &typeno($3);
 491         $type[$typeno] = $2;
 492         print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
 493     }
 494     elsif (s/^=e//) { # blessed by thy compiler; mine won't do this
 495         &edecl;
 496     }
 497     else {
 498         warn "Funny remainder for $name on line $_ left in $line " if $_;
 499     }
 500 }
 501
 502 sub typeno {  # sun thinks types are (0,27) instead of just 27
 503     local($_) = @_;
 504     s/\(\d+,(\d+)\)/$1/;
 505     $_;
 506 }
 507
 508 sub pstruct {
 509     local($what,$prefix,$base) = @_;
 510     local($field, $fieldname, $typeno, $count, $offset, $entry);
 511     local($fieldtype);
 512     local($type, $tname);
 513     local($mytype, $mycount, $entry2);
 514     local($struct_count) = 0;
 515     local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
 516     local($bits,$bytes);
 517     local($template);
 518
 519
 520     local($mname) = &munge($name);
 521
 522     sub munge {
 523         local($_) = @_;
 524         s/[\s\$\.]/_/g;
 525         $_;
 526     }
 527
 528     local($sname) = &psou($what);
 529
 530     $nesting++;
 531
 532     for $field (split(/;/, $struct{$what})) {
 533         $pad = $prepad = 0;
 534         $entry = '';
 535         ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
 536
 537         $type = $type[$typeno];
 538
 539         $type =~ /([^[]*)(\[.*\])?/;
 540         $mytype = $1;
 541         $count .= $2;
 542         $fieldtype = &psou($mytype);
 543
 544         local($fname) = &psou($name);
 545
 546         if ($build_templates) {
 547
 548             $pad = ($offset - ($lastoffset + $lastlength))/8
 549                 if defined $lastoffset;
 550
 551             if (! $finished_template{$sname}) {
 552                 if ($isaunion{$what}) {
 553                     $template{$sname} .= 'X' x $revpad . ' '    if $revpad;
 554                 } else {
 555                     $template{$sname} .= 'x' x $pad    . ' '    if $pad;
 556                 }
 557             }
 558
 559             $template = &fetch_template($type) x
 560                             ($count ? &scripts2count($count) : 1);
 561
 562             if (! $finished_template{$sname}) {
 563                 $template{$sname} .= $template;
 564             }
 565
 566             $revpad = $length/8 if $isaunion{$what};
 567
 568             ($lastoffset, $lastlength) = ($offset, $length);
 569
 570         } else {
 571             print '# ' if $perl && $verbose;
 572             $entry = sprintf($pmask1,
 573                         ' ' x ($nesting * $indent) . $fieldtype,
 574                         "$prefix.$fieldname" . $count);
 575
 576             $entry =~ s/(\*+)( )/$2$1/;
 577
 578             printf $pmask2,
 579                     $entry,
 580                     ($base+$offset)/8,
 581                     ($bits = ($base+$offset)%8) ? ".$bits" : "  ",
 582                     $length/8,
 583                     ($bits = $length % 8) ? ".$bits": ""
 584                         if !$perl || $verbose;
 585
 586
 587             if ($perl && $nesting == 1) {
 588                 $template = &scrunch(&fetch_template($type) x
 589                                 ($count ? &scripts2count($count) : 1));
 590                 push(@sizeof, int($length/8) .",\t# $fieldname");
 591                 push(@offsetof, int($offset/8) .",\t# $fieldname");
 592                 push(@typedef, "'$template', \t# $fieldname");
 593                 $type =~ s/(struct|union) //;
 594                 push(@typeof, "'$type" . ($count ? $count : '') .
 595                     "',\t# $fieldname");
 596             }
 597
 598             print '  ', ' ' x $indent x $nesting, $template
 599                                 if $perl && $verbose;
 600
 601             print "\n" if !$perl || $verbose;
 602
 603         }
 604         if ($perl) {
 605             local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
 606             $mycount *= &scripts2count($count) if $count;
 607             if ($nesting==1 && !$build_templates) {
 608                 $pcode .= sprintf("sub %-32s { %4d; }\n",
 609                         "${mname}'${fieldname}", $struct_count);
 610                 push(@indices, $struct_count);
 611             }
 612             $struct_count += $mycount;
 613         }
 614
 615
 616         &pstruct($type, "$prefix.$fieldname", $base+$offset)
 617                 if $recurse && defined $struct{$type};
 618     }
 619
 620     $countof{$what} = $struct_count unless defined $countof{$whati};
 621
 622     $template{$sname} .= '$' if $build_templates;
 623     $finished_template{$sname}++;
 624
 625     if ($build_templates && !defined $sizeof{$name}) {
 626         local($fmt) = &scrunch($template{$sname});
 627         print STDERR "no size for $name, punting with $fmt..." if $debug;
 628         eval '$sizeof{$name} = length(pack($fmt, ()))';
 629         if ($@) {
 630             chop $@;
 631             warn "couldn't get size for \$name: $@";
 632         } else {
 633             print STDERR $sizeof{$name}, "\n" if $debUg;
 634         }
 635     }
 636
 637     --$nesting;
 638 }
 639
 640
 641 sub psize {
 642     local($me) = @_;
 643     local($amstruct) = $struct{$me} ?  'struct ' : '';
 644
 645     print '$sizeof{\'', $amstruct, $me, '\'} = ';
 646     printf "%d;\n", $sizeof{$me};
 647 }
 648
 649 sub pdecl {
 650     local($pdecl) = @_;
 651     local(@pdecls);
 652     local($tname);
 653
 654     warn "pdecl: $pdecl\n" if $debug;
 655
 656     $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
 657     $pdecl =~ s/\*//g;
 658     @pdecls = split(/=/, $pdecl);
 659     $typeno = $pdecls[0];
 660     $tname = pop @pdecls;
 661
 662     if ($tname =~ s/^f//) { $tname = "$tname&"; }
 663     #else { $tname = "$tname*"; }
 664
 665     for (reverse @pdecls) {
 666         $tname  .= s/^f// ? "&" : "*";
 667         #$tname =~ s/^f(.*)/$1&/;
 668         print "type[$_] is $tname\n" if $debug;
 669         $type[$_] = $tname unless defined $type[$_];
 670     }
 671 }
 672
 673
 674
 675 sub adecl {
 676     ($arraytype, $unknown, $lower, $upper) = ();
 677     #local($typeno);
 678     # global $typeno, @type
 679     local($_, $typedef) = @_;
 680
 681     while (s/^((\d+)=)?ar(\d+);//) {
 682         ($arraytype, $unknown) = ($2, $3);
 683         if (s/^(\d+);(\d+);//) {
 684             ($lower, $upper) = ($1, $2);
 685             $scripts .= '[' .  ($upper+1) . ']';
 686         } else {
 687             warn "can't find array bounds: $_";
 688         }
 689     }
 690     if (s/^([\d*f=]*),(\d+),(\d+);//) {
 691         ($start, $length) = ($2, $3);
 692         local($whatis) = $1;
 693         if ($whatis =~ /^(\d+)=/) {
 694             $typeno = $1;
 695             &pdecl($whatis);
 696         } else {
 697             $typeno = $whatis;
 698         }
 699     } elsif (s/^(\d+)(=[*suf]\d*)//) {
 700         local($whatis) = $2;
 701
 702         if ($whatis =~ /[f*]/) {
 703             &pdecl($whatis);
 704         } elsif ($whatis =~ /[su]/) {  #
 705             print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
 706                 if $debug;
 707             #$type[$typeno] = $name unless defined $type[$typeno];
 708             ##printf "new type $typeno is $name" if $debug;
 709             $typeno = $1;
 710             $type[$typeno] = "$prefix.$fieldname";
 711             local($name) = $type[$typeno];
 712             &sou($name, $whatis);
 713             $_ = &sdecl($name, $_, $start+$offset);
 714             1;
 715             $start = $start{$name};
 716             $offset = $sizeof{$name};
 717             $length = $offset;
 718         } else {
 719             warn "what's this? $whatis in $line ";
 720         }
 721     } elsif (/^\d+$/) {
 722         $typeno = $_;
 723     } else {
 724         warn "bad array stab: $_ in $line ";
 725         next STAB;
 726     }
 727     #local($wasdef) = defined($type[$typeno]) && $debug;
 728     #if ($typedef) {
 729         #print "redefining $type[$typeno] to " if $wasdef;
 730         #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
 731         #print "$type[$typeno]\n" if $wasdef;
 732     #} else {
 733         #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
 734     #}
 735     $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
 736     print "type[$arraytype] is $type[$arraytype]\n" if $debug;
 737     print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
 738     $_;
 739 }
 740
 741
 742
 743 sub sdecl {
 744     local($prefix, $_, $offset) = @_;
 745
 746     local($fieldname, $scripts, $type, $arraytype, $unknown,
 747     $whatis, $pdecl, $upper,$lower, $start,$length) = ();
 748     local($typeno,$sou);
 749
 750
 751 SFIELD:
 752     while (/^([^;]+);/) {
 753         $scripts = '';
 754         warn "sdecl $_\n" if $debug;
 755         if (s/^([\$\w]+)://) {
 756             $fieldname = $1;
 757         } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
 758             $typeno = &typeno($1);
 759             $type[$typeno] = "$prefix.$fieldname";
 760             local($name) = "$prefix.$fieldname";
 761             &sou($name,$2);
 762             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
 763             $start = $start{$name};
 764             $offset += $sizeof{$name};
 765             #print "done with anon, start is $start, offset is $offset\n";
 766             #next SFIELD;
 767         } else  {
 768             warn "weird field $_ of $line" if $debug;
 769             next STAB;
 770             #$fieldname = &gensym;
 771             #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
 772         }
 773
 774         if (/^\d+=ar/) {
 775             $_ = &adecl($_);
 776         }
 777         elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
 778             ($start, $length) =  ($2, $3);
 779             &panic("no length?") unless $length;
 780             $typeno = &typeno($1) if $1;
 781         }
 782         elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
 783             ($pdecl, $start, $length) =  ($1,$5,$6);
 784             &pdecl($pdecl);
 785         }
 786         elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
 787             ($typeno, $sou) = ($1, $2);
 788             $typeno = &typeno($typeno);
 789             if (defined($type[$typeno])) {
 790                 warn "now how did we get type $1 in $fieldname of $line?";
 791             } else {
 792                 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
 793                 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
 794             };
 795             local($name) = "$prefix.$fieldname";
 796             &sou($name,$sou);
 797             print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
 798             $type[$typeno] = "$prefix.$fieldname";
 799             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
 800             $start = $start{$name};
 801             $length = $sizeof{$name};
 802         }
 803         else {
 804             warn "can't grok stab for $name ($_) in line $line ";
 805             next STAB;
 806         }
 807
 808         &panic("no length for $prefix.$fieldname") unless $length;
 809         $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
 810     }
 811     if (s/;\d*,(\d+),(\d+);//) {
 812         local($start, $size) = ($1, $2);
 813         $sizeof{$prefix} = $size;
 814         print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
 815         $start{$prefix} = $start;
 816     }
 817     $_;
 818 }
 819
 820 sub edecl {
 821     s/;$//;
 822     $enum{$name} = $_;
 823     $_ = '';
 824 }
 825
 826 sub resolve_types {
 827     local($sou);
 828     for $i (0 .. $#type) {
 829         next unless defined $type[$i];
 830         $_ = $type[$i];
 831         unless (/\d/) {
 832             print "type[$i] $type[$i]\n" if $debug;
 833             next;
 834         }
 835         print "type[$i] $_ ==> " if $debug;
 836         s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
 837         s/^(\d+)\&/&type($1)/e;
 838         s/^(\d+)/&type($1)/e;
 839         s/(\*+)([^*]+)(\*+)/$1$3$2/;
 840         s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
 841         s/^(\d+)([\*\[].*)/&type($1).$2/e;
 842         #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
 843         $type[$i] = $_;
 844         print "$_\n" if $debug;
 845     }
 846 }
 847 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
 848
 849 sub adjust_start_addrs {
 850     for (sort keys %start) {
 851         ($basename = $_) =~ s/\.[^.]+$//;
 852         $start{$_} += $start{$basename};
 853         print "start: $_ @ $start{$_}\n" if $debug;
 854     }
 855 }
 856
 857 sub sou {
 858     local($what, $_) = @_;
 859     /u/ && $isaunion{$what}++;
 860     /s/ && $isastruct{$what}++;
 861 }
 862
 863 sub psou {
 864     local($what) = @_;
 865     local($prefix) = '';
 866     if ($isaunion{$what})  {
 867         $prefix = 'union ';
 868     } elsif ($isastruct{$what})  {
 869         $prefix = 'struct ';
 870     }
 871     $prefix . $what;
 872 }
 873
 874 sub scrunch {
 875     local($_) = @_;
 876
 877     study;
 878
 879     s/\$//g;
 880     s/  / /g;
 881     1 while s/(\w) \1/$1$1/g;
 882
 883     # i wanna say this, but perl resists my efforts:
 884     #      s/(\w)(\1+)/$2 . length($1)/ge;
 885
 886     &quick_scrunch;
 887
 888     s/ $//;
 889
 890     $_;
 891 }
 892
 893 sub buildscrunchlist {
 894     $scrunch_code = "sub quick_scrunch {\n";
 895     for (values %intrinsics) {
 896         $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n";
 897     }
 898     $scrunch_code .= "}\n";
 899     print "$scrunch_code" if $debug;
 900     eval $scrunch_code;
 901     &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
 902 }
 903
 904 sub fetch_template {
 905     local($mytype) = @_;
 906     local($fmt);
 907     local($count) = 1;
 908
 909     &panic("why do you care?") unless $perl;
 910
 911     if ($mytype =~ s/(\[\d+\])+$//) {
 912         $count .= $1;
 913     }
 914
 915     if ($mytype =~ /\*/) {
 916         $fmt = $template{'pointer'};
 917     }
 918     elsif (defined $template{$mytype}) {
 919         $fmt = $template{$mytype};
 920     }
 921     elsif (defined $struct{$mytype}) {
 922         if (!defined $template{&psou($mytype)}) {
 923             &build_template($mytype) unless $mytype eq $name;
 924         }
 925         elsif ($template{&psou($mytype)} !~ /\$$/) {
 926             #warn "incomplete template for $mytype\n";
 927         }
 928         $fmt = $template{&psou($mytype)} || '?';
 929     }
 930     else {
 931         warn "unknown fmt for $mytype\n";
 932         $fmt = '?';
 933     }
 934
 935     $fmt x $count . ' ';
 936 }
 937
 938 sub compute_intrinsics {
 939     local($TMP) = "/tmp/c2ph-i.$$.c";
 940     open (TMP, ">$TMP") || die "can't open $TMP: $!";
 941     select(TMP);
 942
 943     print STDERR "computing intrinsic sizes: " if $trace;
 944
 945     undef %intrinsics;
 946
 947     print <<'EOF';
 948 main() {
 949     char *mask = "%d %s\n";
 950 EOF
 951
 952     for $type (@intrinsics) {
 953         next if $type eq 'void';
 954         print <<"EOF";
 955     printf(mask,sizeof($type), "$type");
 956 EOF
 957     }
 958
 959     print <<'EOF';
 960     printf(mask,sizeof(char *), "pointer");
 961     exit(0);
 962 }
 963 EOF
 964     close TMP;
 965
 966     select(STDOUT);
 967     open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
 968     while (<PIPE>) {
 969         chop;
 970         split(' ',$_,2);;
 971         print "intrinsic $_[1] is size $_[0]\n" if $debug;
 972         $sizeof{$_[1]} = $_[0];
 973         $intrinsics{$_[1]} = $template{$_[0]};
 974     }
 975     close(PIPE) || die "couldn't read intrinsics!";
 976     unlink($TMP, '/tmp/a.out');
 977     print STDERR "done\n" if $trace;
 978 }
 979
 980 sub scripts2count {
 981     local($_) = @_;
 982
 983     s/^\[//;
 984     s/\]$//;
 985     s/\]\[/*/g;
 986     $_ = eval;
 987     &panic("$_: $@") if $@;
 988     $_;
 989 }
 990
 991 sub system {
 992     print STDERR "@_\n" if $trace;
 993     system @_;
 994 }
 995
 996 sub build_template {
 997     local($name) = @_;
 998
 999     &panic("already got a template for $name") if defined $template{$name};
1000
1001     local($build_templates) = 1;
1002
1003     local($lparen) = '(' x $build_recursed;
1004     local($rparen) = ')' x $build_recursed;
1005
1006     print STDERR "$lparen$name$rparen " if $trace;
1007     $build_recursed++;
1008     &pstruct($name,$name,0);
1009     print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1010     --$build_recursed;
1011 }
1012
1013
1014 sub panic {
1015
1016     select(STDERR);
1017
1018     print "\npanic: @_\n";
1019
1020     exit 1 if $] <= 4.003;  # caller broken
1021
1022     local($i,$_);
1023     local($p,$f,$l,$s,$h,$a,@a,@sub);
1024     for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1025         @a = @DB'args;
1026         for (@a) {
1027             if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1028                 $_ = sprintf("%s",$_);
1029             }
1030             else {
1031                 s/'/\\'/g;
1032                 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1033                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1034                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1035             }
1036         }
1037         $w = $w ? '@ = ' : '$ = ';
1038         $a = $h ? '(' . join(', ', @a) . ')' : '';
1039         push(@sub, "$w&$s$a from file $f line $l\n");
1040         last if $signal;
1041     }
1042     for ($i=0; $i <= $#sub; $i++) {
1043         last if $signal;
1044         print $sub[$i];
1045     }
1046     exit 1;
1047 }
1048
1049 sub squishseq {
1050     local($num);
1051     local($last) = -1e8;
1052     local($string);
1053     local($seq) = '..';
1054
1055     while (defined($num = shift)) {
1056         if ($num == ($last + 1)) {
1057             $string .= $seq unless $inseq++;
1058             $last = $num;
1059             next;
1060         } elsif ($inseq) {
1061             $string .= $last unless $last == -1e8;
1062         }
1063
1064         $string .= ',' if defined $string;
1065         $string .= $num;
1066         $last = $num;
1067         $inseq = 0;
1068     }
1069     $string .= $last if $inseq && $last != -e18;
1070     $string;
1071 }