c2ph.SH

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