utils/c2ph.PL

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