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