utils/c2ph.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5 use Cwd;
   6 use subs qw(link);
   7
   8 sub link { # This is a cut-down version of installperl:link().
   9     my($from,$to) = @_;
  10     my($success) = 0;
  11
  12     eval {
  13         CORE::link($from, $to)
  14             ? $success++
  15             : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
  16               ? die "AFS"  # okay inside eval {}
  17               : die "Couldn't link $from to $to: $!\n";
  18     };
  19     if ($@) {
  20         warn $@;
  21         require File::Copy;
  22         File::Copy::copy($from, $to)
  23             ? $success++
  24             : warn "Couldn't copy $from to $to: $!\n";
  25     }
  26     $success;
  27 }
  28
  29 # List explicitly here the variables you want Configure to
  30 # generate.  Metaconfig only looks for shell variables, so you
  31 # have to mention them as if they were shell variables, not
  32 # %Config entries.  Thus you write
  33 #  $startperl
  34 # to ensure Configure will look for $Config{startperl}.
  35
  36 # This forces PL files to create target in same directory as PL file.
  37 # This is so that make depend always knows where to find PL derivatives.
  38 $origdir = cwd;
  39 chdir dirname($0);
  40 $file = basename($0, '.PL');
  41 $file .= '.com' if $^O eq 'VMS';
  42
  43 open OUT,">$file" or die "Can't create $file: $!";
  44
  45 print "Extracting $file (with variable substitutions)\n";
  46
  47 # In this section, perl variables will be expanded during extraction.
  48 # You can use $Config{...} to use Configure variables.
  49
  50 print OUT <<"!GROK!THIS!";
  51 $Config{startperl}
  52     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  53         if \$running_under_some_shell;
  54 !GROK!THIS!
  55
  56 # In the following, perl variables are not expanded during extraction.
  57
  58 print OUT <<'!NO!SUBS!';
  59 #
  60 #
  61 #   c2ph (aka pstruct)
  62 #   Tom Christiansen, <tchrist@convex.com>
  63 #
  64 #   As pstruct, dump C structures as generated from 'cc -g -S' stabs.
  65 #   As c2ph, do this PLUS generate perl code for getting at the structures.
  66 #
  67 #   See the usage message for more.  If this isn't enough, read the code.
  68 #
  69
  70 =head1 NAME
  71
  72 c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
  73
  74 =head1 SYNOPSIS
  75
  76     c2ph [-dpnP] [var=val] [files ...]
  77
  78 =head2 OPTIONS
  79
  80     Options:
  81
  82     -w  wide; short for: type_width=45 member_width=35 offset_width=8
  83     -x  hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
  84
  85     -n  do not generate perl code  (default when invoked as pstruct)
  86     -p  generate perl code         (default when invoked as c2ph)
  87     -v  generate perl code, with C decls as comments
  88
  89     -i  do NOT recompute sizes for intrinsic datatypes
  90     -a  dump information on intrinsics also
  91
  92     -t  trace execution
  93     -d  spew reams of debugging output
  94
  95     -slist  give comma-separated list a structures to dump
  96
  97 =head1 DESCRIPTION
  98
  99 The following is the old c2ph.doc documentation by Tom Christiansen
 100 <tchrist@perl.com>
 101 Date: 25 Jul 91 08:10:21 GMT
 102
 103 Once upon a time, I wrote a program called pstruct.  It was a perl
 104 program that tried to parse out C structures and display their member
 105 offsets for you.  This was especially useful for people looking at
 106 binary dumps or poking around the kernel.
 107
 108 Pstruct was not a pretty program.  Neither was it particularly robust.
 109 The problem, you see, was that the C compiler was much better at parsing
 110 C than I could ever hope to be.
 111
 112 So I got smart:  I decided to be lazy and let the C compiler parse the C,
 113 which would spit out debugger stabs for me to read.  These were much
 114 easier to parse.  It's still not a pretty program, but at least it's more
 115 robust.
 116
 117 Pstruct takes any .c or .h files, or preferably .s ones, since that's
 118 the format it is going to massage them into anyway, and spits out
 119 listings like this:
 120
 121  struct tty {
 122    int                          tty.t_locker                         000      4
 123    int                          tty.t_mutex_index                    004      4
 124    struct tty *                 tty.t_tp_virt                        008      4
 125    struct clist                 tty.t_rawq                           00c     20
 126      int                        tty.t_rawq.c_cc                      00c      4
 127      int                        tty.t_rawq.c_cmax                    010      4
 128      int                        tty.t_rawq.c_cfx                     014      4
 129      int                        tty.t_rawq.c_clx                     018      4
 130      struct tty *               tty.t_rawq.c_tp_cpu                  01c      4
 131      struct tty *               tty.t_rawq.c_tp_iop                  020      4
 132      unsigned char *            tty.t_rawq.c_buf_cpu                 024      4
 133      unsigned char *            tty.t_rawq.c_buf_iop                 028      4
 134    struct clist                 tty.t_canq                           02c     20
 135      int                        tty.t_canq.c_cc                      02c      4
 136      int                        tty.t_canq.c_cmax                    030      4
 137      int                        tty.t_canq.c_cfx                     034      4
 138      int                        tty.t_canq.c_clx                     038      4
 139      struct tty *               tty.t_canq.c_tp_cpu                  03c      4
 140      struct tty *               tty.t_canq.c_tp_iop                  040      4
 141      unsigned char *            tty.t_canq.c_buf_cpu                 044      4
 142      unsigned char *            tty.t_canq.c_buf_iop                 048      4
 143    struct clist                 tty.t_outq                           04c     20
 144      int                        tty.t_outq.c_cc                      04c      4
 145      int                        tty.t_outq.c_cmax                    050      4
 146      int                        tty.t_outq.c_cfx                     054      4
 147      int                        tty.t_outq.c_clx                     058      4
 148      struct tty *               tty.t_outq.c_tp_cpu                  05c      4
 149      struct tty *               tty.t_outq.c_tp_iop                  060      4
 150      unsigned char *            tty.t_outq.c_buf_cpu                 064      4
 151      unsigned char *            tty.t_outq.c_buf_iop                 068      4
 152    (*int)()                     tty.t_oproc_cpu                      06c      4
 153    (*int)()                     tty.t_oproc_iop                      070      4
 154    (*int)()                     tty.t_stopproc_cpu                   074      4
 155    (*int)()                     tty.t_stopproc_iop                   078      4
 156    struct thread *              tty.t_rsel                           07c      4
 157
 158 etc.
 159
 160
 161 Actually, this was generated by a particular set of options.  You can control
 162 the formatting of each column, whether you prefer wide or fat, hex or decimal,
 163 leading zeroes or whatever.
 164
 165 All you need to be able to use this is a C compiler than generates
 166 BSD/GCC-style stabs.  The B<-g> option on native BSD compilers and GCC
 167 should get this for you.
 168
 169 To learn more, just type a bogus option, like B<-\?>, and a long usage message
 170 will be provided.  There are a fair number of possibilities.
 171
 172 If you're only a C programmer, than this is the end of the message for you.
 173 You can quit right now, and if you care to, save off the source and run it
 174 when you feel like it.  Or not.
 175
 176
 177
 178 But if you're a perl programmer, then for you I have something much more
 179 wondrous than just a structure offset printer.
 180
 181 You see, if you call pstruct by its other incybernation, c2ph, you have a code
 182 generator that translates C code into perl code!  Well, structure and union
 183 declarations at least, but that's quite a bit.
 184
 185 Prior to this point, anyone programming in perl who wanted to interact
 186 with C programs, like the kernel, was forced to guess the layouts of
 187 the C structures, and then hardwire these into his program.  Of course,
 188 when you took your wonderfully crafted program to a system where the
 189 sgtty structure was laid out differently, your program broke.  Which is
 190 a shame.
 191
 192 We've had Larry's h2ph translator, which helped, but that only works on
 193 cpp symbols, not real C, which was also very much needed.  What I offer
 194 you is a symbolic way of getting at all the C structures.  I've couched
 195 them in terms of packages and functions.  Consider the following program:
 196
 197     #!/usr/local/bin/perl
 198
 199     require 'syscall.ph';
 200     require 'sys/time.ph';
 201     require 'sys/resource.ph';
 202
 203     $ru = "\0" x &rusage'sizeof();
 204
 205     syscall(&SYS_getrusage, &RUSAGE_SELF, $ru)      && die "getrusage: $!";
 206
 207     @ru = unpack($t = &rusage'typedef(), $ru);
 208
 209     $utime =  $ru[ &rusage'ru_utime + &timeval'tv_sec  ]
 210            + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
 211
 212     $stime =  $ru[ &rusage'ru_stime + &timeval'tv_sec  ]
 213            + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
 214
 215     printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
 216
 217
 218 As you see, the name of the package is the name of the structure.  Regular
 219 fields are just their own names.  Plus the following accessor functions are
 220 provided for your convenience:
 221
 222     struct      This takes no arguments, and is merely the number of first-level
 223                 elements in the structure.  You would use this for indexing
 224                 into arrays of structures, perhaps like this
 225
 226
 227                     $usec = $u[ &user'u_utimer
 228                                 + (&ITIMER_VIRTUAL * &itimerval'struct)
 229                                 + &itimerval'it_value
 230                                 + &timeval'tv_usec
 231                               ];
 232
 233     sizeof      Returns the bytes in the structure, or the member if
 234                 you pass it an argument, such as
 235
 236                         &rusage'sizeof(&rusage'ru_utime)
 237
 238     typedef     This is the perl format definition for passing to pack and
 239                 unpack.  If you ask for the typedef of a nothing, you get
 240                 the whole structure, otherwise you get that of the member
 241                 you ask for.  Padding is taken care of, as is the magic to
 242                 guarantee that a union is unpacked into all its aliases.
 243                 Bitfields are not quite yet supported however.
 244
 245     offsetof    This function is the byte offset into the array of that
 246                 member.  You may wish to use this for indexing directly
 247                 into the packed structure with vec() if you're too lazy
 248                 to unpack it.
 249
 250     typeof      Not to be confused with the typedef accessor function, this
 251                 one returns the C type of that field.  This would allow
 252                 you to print out a nice structured pretty print of some
 253                 structure without knoning anything about it beforehand.
 254                 No args to this one is a noop.  Someday I'll post such
 255                 a thing to dump out your u structure for you.
 256
 257
 258 The way I see this being used is like basically this:
 259
 260         % h2ph <some_include_file.h  >  /usr/lib/perl/tmp.ph
 261         % c2ph  some_include_file.h  >> /usr/lib/perl/tmp.ph
 262         % install
 263
 264 It's a little tricker with c2ph because you have to get the includes right.
 265 I can't know this for your system, but it's not usually too terribly difficult.
 266
 267 The code isn't pretty as I mentioned  -- I never thought it would be a 1000-
 268 line program when I started, or I might not have begun. :-)  But I would have
 269 been less cavalier in how the parts of the program communicated with each
 270 other, etc.  It might also have helped if I didn't have to divine the makeup
 271 of the stabs on the fly, and then account for micro differences between my
 272 compiler and gcc.
 273
 274 Anyway, here it is.  Should run on perl v4 or greater.  Maybe less.
 275
 276
 277  --tom
 278
 279 =cut
 280
 281 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
 282
 283
 284 ######################################################################
 285
 286 # some handy data definitions.   many of these can be reset later.
 287
 288 $bitorder = 'b';  # ascending; set to B for descending bit fields
 289
 290 %intrinsics =
 291 %template = (
 292     'char',                     'c',
 293     'unsigned char',            'C',
 294     'short',                    's',
 295     'short int',                's',
 296     'unsigned short',           'S',
 297     'unsigned short int',       'S',
 298     'short unsigned int',       'S',
 299     'int',                      'i',
 300     'unsigned int',             'I',
 301     'long',                     'l',
 302     'long int',                 'l',
 303     'unsigned long',            'L',
 304     'unsigned long',            'L',
 305     'long unsigned int',        'L',
 306     'unsigned long int',        'L',
 307     'long long',                'q',
 308     'long long int',            'q',
 309     'unsigned long long',       'Q',
 310     'unsigned long long int',   'Q',
 311     'float',                    'f',
 312     'double',                   'd',
 313     'pointer',                  'p',
 314     'null',                     'x',
 315     'neganull',                 'X',
 316     'bit',                      $bitorder,
 317 );
 318
 319 &buildscrunchlist;
 320 delete $intrinsics{'neganull'};
 321 delete $intrinsics{'bit'};
 322 delete $intrinsics{'null'};
 323
 324 # use -s to recompute sizes
 325 %sizeof = (
 326     'char',                     '1',
 327     'unsigned char',            '1',
 328     'short',                    '2',
 329     'short int',                '2',
 330     'unsigned short',           '2',
 331     'unsigned short int',       '2',
 332     'short unsigned int',       '2',
 333     'int',                      '4',
 334     'unsigned int',             '4',
 335     'long',                     '4',
 336     'long int',                 '4',
 337     'unsigned long',            '4',
 338     'unsigned long int',        '4',
 339     'long unsigned int',        '4',
 340     'long long',                '8',
 341     'long long int',            '8',
 342     'unsigned long long',       '8',
 343     'unsigned long long int',   '8',
 344     'float',                    '4',
 345     'double',                   '8',
 346     'pointer',                  '4',
 347 );
 348
 349 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
 350
 351 ($offset_fmt, $size_fmt) = ('d', 'd');
 352
 353 $indent = 2;
 354
 355 $CC = 'cc';
 356 !NO!SUBS!
 357
 358 if (($Config{gccversion} || '') =~ /^(\d+)\.(\d+)/
 359   and ($1 > 3 or ($1 == 3 and $2 >= 2))) {
 360     print OUT q/$CFLAGS = '-gstabs -S';/;
 361 } else {
 362     print OUT q/$CFLAGS = '-g -S';/;
 363 }
 364
 365 print OUT <<'!NO!SUBS!';
 366
 367 $DEFINES = '';
 368
 369 $perl++ if $0 =~ m#/?c2ph$#;
 370
 371 require 'getopts.pl';
 372
 373 use File::Temp 'tempdir';
 374
 375 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
 376
 377 &Getopts('aixdpvtnws:') || &usage(0);
 378
 379 $opt_d && $debug++;
 380 $opt_t && $trace++;
 381 $opt_p && $perl++;
 382 $opt_v && $verbose++;
 383 $opt_n && ($perl = 0);
 384
 385 if ($opt_w) {
 386     ($type_width, $member_width, $offset_width) = (45, 35, 8);
 387 }
 388 if ($opt_x) {
 389     ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
 390 }
 391
 392 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
 393
 394 sub PLUMBER {
 395     select(STDERR);
 396     print "oops, apperent pager foulup\n";
 397     $isatty++;
 398     &usage(1);
 399 }
 400
 401 sub usage {
 402     local($oops) = @_;
 403     unless (-t STDOUT) {
 404         select(STDERR);
 405     } elsif (!$oops) {
 406         $isatty++;
 407         $| = 1;
 408         print "hit <RETURN> for further explanation: ";
 409         <STDIN>;
 410         open (PIPE, "|". ($ENV{PAGER} || 'more'));
 411         $SIG{PIPE} = PLUMBER;
 412         select(PIPE);
 413     }
 414
 415     print "usage: $0 [-dpnP] [var=val] [files ...]\n";
 416
 417     exit unless $isatty;
 418
 419     print <<EOF;
 420
 421 Options:
 422
 423 -w      wide; short for: type_width=45 member_width=35 offset_width=8
 424 -x      hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
 425
 426 -n      do not generate perl code  (default when invoked as pstruct)
 427 -p      generate perl code         (default when invoked as c2ph)
 428 -v      generate perl code, with C decls as comments
 429
 430 -i      do NOT recompute sizes for intrinsic datatypes
 431 -a      dump information on intrinsics also
 432
 433 -t      trace execution
 434 -d      spew reams of debugging output
 435
 436 -slist  give comma-separated list a structures to dump
 437
 438
 439 Var Name        Default Value    Meaning
 440
 441 EOF
 442
 443     &defvar('CC', 'which_compiler to call');
 444     &defvar('CFLAGS', 'how to generate *.s files with stabs');
 445     &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
 446
 447     print "\n";
 448
 449     &defvar('type_width', 'width of type field   (column 1)');
 450     &defvar('member_width', 'width of member field (column 2)');
 451     &defvar('offset_width', 'width of offset field (column 3)');
 452     &defvar('size_width', 'width of size field   (column 4)');
 453
 454     print "\n";
 455
 456     &defvar('offset_fmt', 'sprintf format type for offset');
 457     &defvar('size_fmt', 'sprintf format type for size');
 458
 459     print "\n";
 460
 461     &defvar('indent', 'how far to indent each nesting level');
 462
 463    print <<'EOF';
 464
 465     If any *.[ch] files are given, these will be catted together into
 466     a temporary *.c file and sent through:
 467             $CC $CFLAGS $DEFINES
 468     and the resulting *.s groped for stab information.  If no files are
 469     supplied, then stdin is read directly with the assumption that it
 470     contains stab information.  All other liens will be ignored.  At
 471     most one *.s file should be supplied.
 472
 473 EOF
 474     close PIPE;
 475     exit 1;
 476 }
 477
 478 sub defvar {
 479     local($var, $msg) = @_;
 480     printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;
 481 }
 482
 483 $recurse = 1;
 484
 485 if (@ARGV) {
 486     if (grep(!/\.[csh]$/,@ARGV)) {
 487         warn "Only *.[csh] files expected!\n";
 488         &usage;
 489     }
 490     elsif (grep(/\.s$/,@ARGV)) {
 491         if (@ARGV > 1) {
 492             warn "Only one *.s file allowed!\n";
 493             &usage;
 494         }
 495     }
 496     elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
 497         local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
 498         $chdir = "cd $dir; " if $dir;
 499         &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
 500         $ARGV[0] =~ s/\.c$/.s/;
 501     }
 502     else {
 503         $TMPDIR = tempdir(CLEANUP => 1);
 504         $TMP = "$TMPDIR/c2ph.$$.c";
 505         &system("cat @ARGV > $TMP") && exit 1;
 506         &system("cd $TMPDIR; $CC $CFLAGS $DEFINES $TMP") && exit 1;
 507         unlink $TMP;
 508         $TMP =~ s/\.c$/.s/;
 509         @ARGV = ($TMP);
 510     }
 511 }
 512
 513 if ($opt_s) {
 514     for (split(/[\s,]+/, $opt_s)) {
 515         $interested{$_}++;
 516     }
 517 }
 518
 519
 520 $| = 1 if $debug;
 521
 522 main: {
 523
 524     if ($trace) {
 525         if (-t && !@ARGV) {
 526             print STDERR "reading from your keyboard: ";
 527         } else {
 528             print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
 529         }
 530     }
 531
 532 STAB: while (<>) {
 533         if ($trace && !($. % 10)) {
 534             $lineno = $..'';
 535             print STDERR $lineno, "\b" x length($lineno);
 536         }
 537         next unless /^\s*\.stabs\s+/;
 538         $line = $_;
 539         s/^\s*\.stabs\s+//;
 540         if (s/\\\\"[d,]+$//) {
 541             $saveline .= $line;
 542             $savebar  = $_;
 543             next STAB;
 544         }
 545         if ($saveline) {
 546             s/^"//;
 547             $_ = $savebar . $_;
 548             $line = $saveline;
 549         }
 550         &stab;
 551         $savebar = $saveline = undef;
 552     }
 553     print STDERR "$.\n" if $trace;
 554     unlink $TMP if $TMP;
 555
 556     &compute_intrinsics if $perl && !$opt_i;
 557
 558     print STDERR "resolving types\n" if $trace;
 559
 560     &resolve_types;
 561     &adjust_start_addrs;
 562
 563     $sum = 2 + $type_width + $member_width;
 564     $pmask1 = "%-${type_width}s %-${member_width}s";
 565     $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
 566
 567
 568
 569     if ($perl) {
 570         # resolve template -- should be in stab define order, but even this isn't enough.
 571         print STDERR "\nbuilding type templates: " if $trace;
 572         for $i (reverse 0..$#type) {
 573             next unless defined($name = $type[$i]);
 574             next unless defined $struct{$name};
 575             ($iname = $name) =~ s/\..*//;
 576             $build_recursed = 0;
 577             &build_template($name) unless defined $template{&psou($name)} ||
 578                                         $opt_s && !$interested{$iname};
 579         }
 580         print STDERR "\n\n" if $trace;
 581     }
 582
 583     print STDERR "dumping structs: " if $trace;
 584
 585     local($iam);
 586
 587
 588
 589     foreach $name (sort keys %struct) {
 590         ($iname = $name) =~ s/\..*//;
 591         next if $opt_s && !$interested{$iname};
 592         print STDERR "$name " if $trace;
 593
 594         undef @sizeof;
 595         undef @typedef;
 596         undef @offsetof;
 597         undef @indices;
 598         undef @typeof;
 599         undef @fieldnames;
 600
 601         $mname = &munge($name);
 602
 603         $fname = &psou($name);
 604
 605         print "# " if $perl && $verbose;
 606         $pcode = '';
 607         print "$fname {\n" if !$perl || $verbose;
 608         $template{$fname} = &scrunch($template{$fname}) if $perl;
 609         &pstruct($name,$name,0);
 610         print "# " if $perl && $verbose;
 611         print "}\n" if !$perl || $verbose;
 612         print "\n" if $perl && $verbose;
 613
 614         if ($perl) {
 615             print "$pcode";
 616
 617             printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
 618
 619             print <<EOF;
 620 sub ${mname}'typedef {
 621     local(\$${mname}'index) = shift;
 622     defined \$${mname}'index
 623         ? \$${mname}'typedef[\$${mname}'index]
 624         : \$${mname}'typedef;
 625 }
 626 EOF
 627
 628             print <<EOF;
 629 sub ${mname}'sizeof {
 630     local(\$${mname}'index) = shift;
 631     defined \$${mname}'index
 632         ? \$${mname}'sizeof[\$${mname}'index]
 633         : \$${mname}'sizeof;
 634 }
 635 EOF
 636
 637             print <<EOF;
 638 sub ${mname}'offsetof {
 639     local(\$${mname}'index) = shift;
 640     defined \$${mname}index
 641         ? \$${mname}'offsetof[\$${mname}'index]
 642         : \$${mname}'sizeof;
 643 }
 644 EOF
 645
 646             print <<EOF;
 647 sub ${mname}'typeof {
 648     local(\$${mname}'index) = shift;
 649     defined \$${mname}index
 650         ? \$${mname}'typeof[\$${mname}'index]
 651         : '$name';
 652 }
 653 EOF
 654
 655             print <<EOF;
 656 sub ${mname}'fieldnames {
 657     \@${mname}'fieldnames;
 658 }
 659 EOF
 660
 661         $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
 662
 663             print <<EOF;
 664 sub ${mname}'isastruct {
 665     '$iam';
 666 }
 667 EOF
 668
 669             print "\$${mname}'typedef = '" . &scrunch($template{$fname})
 670                 . "';\n";
 671
 672             print "\$${mname}'sizeof = $sizeof{$name};\n\n";
 673
 674
 675             print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
 676
 677             print "\n";
 678
 679             print "\@${mname}'typedef[\@${mname}'indices] = (",
 680                         join("\n\t", '', @typedef), "\n    );\n\n";
 681             print "\@${mname}'sizeof[\@${mname}'indices] = (",
 682                         join("\n\t", '', @sizeof), "\n    );\n\n";
 683             print "\@${mname}'offsetof[\@${mname}'indices] = (",
 684                         join("\n\t", '', @offsetof), "\n    );\n\n";
 685             print "\@${mname}'typeof[\@${mname}'indices] = (",
 686                         join("\n\t", '', @typeof), "\n    );\n\n";
 687             print "\@${mname}'fieldnames[\@${mname}'indices] = (",
 688                         join("\n\t", '', @fieldnames), "\n    );\n\n";
 689
 690             $template_printed{$fname}++;
 691             $size_printed{$fname}++;
 692         }
 693         print "\n";
 694     }
 695
 696     print STDERR "\n" if $trace;
 697
 698     unless ($perl && $opt_a) {
 699         print "\n1;\n" if $perl;
 700         exit;
 701     }
 702
 703
 704
 705     foreach $name (sort bysizevalue keys %intrinsics) {
 706         next if $size_printed{$name};
 707         print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
 708     }
 709
 710     print "\n";
 711
 712     sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
 713
 714
 715     foreach $name (sort keys %intrinsics) {
 716         print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
 717     }
 718
 719     print "\n1;\n" if $perl;
 720
 721     exit;
 722 }
 723
 724 ########################################################################################
 725
 726
 727 sub stab {
 728     next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/;  # (\d+,\d+) is for sun
 729     s/"//                                               || next;
 730     s/",([x\d]+),([x\d]+),([x\d]+),.*//                 || next;
 731
 732     next if /^\s*$/;
 733
 734     $size = $3 if $3;
 735     $_ = $continued . $_ if length($continued);
 736     if (s/\\\\$//) {
 737       # if last 2 chars of string are '\\' then stab is continued
 738       # in next stab entry
 739       chop;
 740       $continued = $_;
 741       next;
 742     }
 743     $continued = '';
 744
 745
 746     $line = $_;
 747
 748     if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
 749         print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
 750         &pdecl($pdecl);
 751         next;
 752     }
 753
 754
 755
 756     if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
 757         local($ident) = $2;
 758         push(@intrinsics, $ident);
 759         $typeno = &typeno($3);
 760         $type[$typeno] = $ident;
 761         print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
 762         next;
 763     }
 764
 765     if (($name, $typeordef, $typeno, $extra, $struct, $_)
 766         = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
 767     {
 768         $typeno = &typeno($typeno);  # sun foolery
 769     }
 770     elsif (/^[\$\w]+:/) {
 771         next; # variable
 772     }
 773     else {
 774         warn "can't grok stab: <$_> in: $line " if $_;
 775         next;
 776     }
 777
 778     #warn "got size $size for $name\n";
 779     $sizeof{$name} = $size if $size;
 780
 781     s/;[-\d]*;[-\d]*;$//;  # we don't care about ranges
 782
 783     $typenos{$name} = $typeno;
 784
 785     unless (defined $type[$typeno]) {
 786         &panic("type 0??") unless $typeno;
 787         $type[$typeno] = $name unless defined $type[$typeno];
 788         printf "new type $typeno is $name" if $debug;
 789         if ($extra =~ /\*/ && defined $type[$struct]) {
 790             print ", a typedef for a pointer to " , $type[$struct] if $debug;
 791         }
 792     } else {
 793         printf "%s is type %d", $name, $typeno if $debug;
 794         print ", a typedef for " , $type[$typeno] if $debug;
 795     }
 796     print "\n" if $debug;
 797     #next unless $extra =~ /[su*]/;
 798
 799     #$type[$struct] = $name;
 800
 801     if ($extra =~ /[us*]/) {
 802         &sou($name, $extra);
 803         $_ = &sdecl($name, $_, 0);
 804     }
 805     elsif (/^=ar/) {
 806         print "it's a bare array typedef -- that's pretty sick\n" if $debug;
 807         $_ = "$typeno$_";
 808         $scripts = '';
 809         $_ = &adecl($_,1);
 810
 811     }
 812     elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) {  # the ?'s are for gcc
 813         push(@intrinsics, $2);
 814         $typeno = &typeno($3);
 815         $type[$typeno] = $2;
 816         print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
 817     }
 818     elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
 819         &edecl;
 820     }
 821     else {
 822         warn "Funny remainder for $name on line $_ left in $line " if $_;
 823     }
 824 }
 825
 826 sub typeno {  # sun thinks types are (0,27) instead of just 27
 827     local($_) = @_;
 828     s/\(\d+,(\d+)\)/$1/;
 829     $_;
 830 }
 831
 832 sub pstruct {
 833     local($what,$prefix,$base) = @_;
 834     local($field, $fieldname, $typeno, $count, $offset, $entry);
 835     local($fieldtype);
 836     local($type, $tname);
 837     local($mytype, $mycount, $entry2);
 838     local($struct_count) = 0;
 839     local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
 840     local($bits,$bytes);
 841     local($template);
 842
 843
 844     local($mname) = &munge($name);
 845
 846     sub munge {
 847         local($_) = @_;
 848         s/[\s\$\.]/_/g;
 849         $_;
 850     }
 851
 852     local($sname) = &psou($what);
 853
 854     $nesting++;
 855
 856     for $field (split(/;/, $struct{$what})) {
 857         $pad = $prepad = 0;
 858         $entry = '';
 859         ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
 860
 861         $type = $type[$typeno];
 862
 863         $type =~ /([^[]*)(\[.*\])?/;
 864         $mytype = $1;
 865         $count .= $2;
 866         $fieldtype = &psou($mytype);
 867
 868         local($fname) = &psou($name);
 869
 870         if ($build_templates) {
 871
 872             $pad = ($offset - ($lastoffset + $lastlength))/8
 873                 if defined $lastoffset;
 874
 875             if (! $finished_template{$sname}) {
 876                 if ($isaunion{$what}) {
 877                     $template{$sname} .= 'X' x $revpad . ' '    if $revpad;
 878                 } else {
 879                     $template{$sname} .= 'x' x $pad    . ' '    if $pad;
 880                 }
 881             }
 882
 883             $template = &fetch_template($type);
 884             &repeat_template($template,$count);
 885
 886             if (! $finished_template{$sname}) {
 887                 $template{$sname} .= $template;
 888             }
 889
 890             $revpad = $length/8 if $isaunion{$what};
 891
 892             ($lastoffset, $lastlength) = ($offset, $length);
 893
 894         } else {
 895             print '# ' if $perl && $verbose;
 896             $entry = sprintf($pmask1,
 897                         ' ' x ($nesting * $indent) . $fieldtype,
 898                         "$prefix.$fieldname" . $count);
 899
 900             $entry =~ s/(\*+)( )/$2$1/;
 901
 902             printf $pmask2,
 903                     $entry,
 904                     ($base+$offset)/8,
 905                     ($bits = ($base+$offset)%8) ? ".$bits" : "  ",
 906                     $length/8,
 907                     ($bits = $length % 8) ? ".$bits": ""
 908                         if !$perl || $verbose;
 909
 910             if ($perl) {
 911                 $template = &fetch_template($type);
 912                 &repeat_template($template,$count);
 913             }
 914
 915             if ($perl && $nesting == 1) {
 916
 917                 push(@sizeof, int($length/8) .",\t# $fieldname");
 918                 push(@offsetof, int($offset/8) .",\t# $fieldname");
 919                 local($little) = &scrunch($template);
 920                 push(@typedef, "'$little', \t# $fieldname");
 921                 $type =~ s/(struct|union) //;
 922                 push(@typeof, "'$mytype" . ($count ? $count : '') .
 923                     "',\t# $fieldname");
 924                 push(@fieldnames, "'$fieldname',");
 925             }
 926
 927             print '  ', ' ' x $indent x $nesting, $template
 928                                 if $perl && $verbose;
 929
 930             print "\n" if !$perl || $verbose;
 931
 932         }
 933         if ($perl) {
 934             local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
 935             $mycount *= &scripts2count($count) if $count;
 936             if ($nesting==1 && !$build_templates) {
 937                 $pcode .= sprintf("sub %-32s { %4d; }\n",
 938                         "${mname}'${fieldname}", $struct_count);
 939                 push(@indices, $struct_count);
 940             }
 941             $struct_count += $mycount;
 942         }
 943
 944
 945         &pstruct($type, "$prefix.$fieldname", $base+$offset)
 946                 if $recurse && defined $struct{$type};
 947     }
 948
 949     $countof{$what} = $struct_count unless defined $countof{$whati};
 950
 951     $template{$sname} .= '$' if $build_templates;
 952     $finished_template{$sname}++;
 953
 954     if ($build_templates && !defined $sizeof{$name}) {
 955         local($fmt) = &scrunch($template{$sname});
 956         print STDERR "no size for $name, punting with $fmt..." if $debug;
 957         eval '$sizeof{$name} = length(pack($fmt, ()))';
 958         if ($@) {
 959             chop $@;
 960             warn "couldn't get size for \$name: $@";
 961         } else {
 962             print STDERR $sizeof{$name}, "\n" if $debUg;
 963         }
 964     }
 965
 966     --$nesting;
 967 }
 968
 969
 970 sub psize {
 971     local($me) = @_;
 972     local($amstruct) = $struct{$me} ?  'struct ' : '';
 973
 974     print '$sizeof{\'', $amstruct, $me, '\'} = ';
 975     printf "%d;\n", $sizeof{$me};
 976 }
 977
 978 sub pdecl {
 979     local($pdecl) = @_;
 980     local(@pdecls);
 981     local($tname);
 982
 983     warn "pdecl: $pdecl\n" if $debug;
 984
 985     $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
 986     $pdecl =~ s/\*//g;
 987     @pdecls = split(/=/, $pdecl);
 988     $typeno = $pdecls[0];
 989     $tname = pop @pdecls;
 990
 991     if ($tname =~ s/^f//) { $tname = "$tname&"; }
 992     #else { $tname = "$tname*"; }
 993
 994     for (reverse @pdecls) {
 995         $tname  .= s/^f// ? "&" : "*";
 996         #$tname =~ s/^f(.*)/$1&/;
 997         print "type[$_] is $tname\n" if $debug;
 998         $type[$_] = $tname unless defined $type[$_];
 999     }
1000 }
1001
1002
1003
1004 sub adecl {
1005     ($arraytype, $unknown, $lower, $upper) = ();
1006     #local($typeno);
1007     # global $typeno, @type
1008     local($_, $typedef) = @_;
1009
1010     while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
1011         ($arraytype, $unknown) = ($2, $3);
1012         $arraytype = &typeno($arraytype);
1013         $unknown = &typeno($unknown);
1014         if (s/^(\d+);(\d+);//) {
1015             ($lower, $upper) = ($1, $2);
1016             $scripts .= '[' .  ($upper+1) . ']';
1017         } else {
1018             warn "can't find array bounds: $_";
1019         }
1020     }
1021     if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
1022         ($start, $length) = ($2, $3);
1023         $whatis = $1;
1024         if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
1025             $typeno = &typeno($1);
1026             &pdecl($whatis);
1027         } else {
1028             $typeno = &typeno($whatis);
1029         }
1030     } elsif (s/^(\d+)(=[*suf]\d*)//) {
1031         local($whatis) = $2;
1032
1033         if ($whatis =~ /[f*]/) {
1034             &pdecl($whatis);
1035         } elsif ($whatis =~ /[su]/) {  #
1036             print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
1037                 if $debug;
1038             #$type[$typeno] = $name unless defined $type[$typeno];
1039             ##printf "new type $typeno is $name" if $debug;
1040             $typeno = $1;
1041             $type[$typeno] = "$prefix.$fieldname";
1042             local($name) = $type[$typeno];
1043             &sou($name, $whatis);
1044             $_ = &sdecl($name, $_, $start+$offset);
1045             1;
1046             $start = $start{$name};
1047             $offset = $sizeof{$name};
1048             $length = $offset;
1049         } else {
1050             warn "what's this? $whatis in $line ";
1051         }
1052     } elsif (/^\d+$/) {
1053         $typeno = $_;
1054     } else {
1055         warn "bad array stab: $_ in $line ";
1056         next STAB;
1057     }
1058     #local($wasdef) = defined($type[$typeno]) && $debug;
1059     #if ($typedef) {
1060         #print "redefining $type[$typeno] to " if $wasdef;
1061         #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1062         #print "$type[$typeno]\n" if $wasdef;
1063     #} else {
1064         #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1065     #}
1066     $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1067     print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1068     print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1069     $_;
1070 }
1071
1072
1073
1074 sub sdecl {
1075     local($prefix, $_, $offset) = @_;
1076
1077     local($fieldname, $scripts, $type, $arraytype, $unknown,
1078     $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1079     local($typeno,$sou);
1080
1081
1082 SFIELD:
1083     while (/^([^;]+);/) {
1084         $scripts = '';
1085         warn "sdecl $_\n" if $debug;
1086         if (s/^([\$\w]+)://) {
1087             $fieldname = $1;
1088         } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
1089             $typeno = &typeno($1);
1090             $type[$typeno] = "$prefix.$fieldname";
1091             local($name) = "$prefix.$fieldname";
1092             &sou($name,$2);
1093             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1094             $start = $start{$name};
1095             $offset += $sizeof{$name};
1096             #print "done with anon, start is $start, offset is $offset\n";
1097             #next SFIELD;
1098         } else  {
1099             warn "weird field $_ of $line" if $debug;
1100             next STAB;
1101             #$fieldname = &gensym;
1102             #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1103         }
1104
1105         if (/^(\d+|\(\d+,\d+\))=ar/) {
1106             $_ = &adecl($_);
1107         }
1108         elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
1109           ($start, $length) =  ($2, $3);
1110           &panic("no length?") unless $length;
1111           $typeno = &typeno($1) if $1;
1112         }
1113         elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
1114             ($start, $length) =  ($2, $3);
1115             &panic("no length?") unless $length;
1116             $typeno = &typeno($1) if $1;
1117         }
1118         elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
1119             ($pdecl, $start, $length) =  ($1,$5,$6);
1120             &pdecl($pdecl);
1121         }
1122         elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1123             ($typeno, $sou) = ($1, $2);
1124             $typeno = &typeno($typeno);
1125             if (defined($type[$typeno])) {
1126                 warn "now how did we get type $1 in $fieldname of $line?";
1127             } else {
1128                 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1129                 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1130             };
1131             local($name) = "$prefix.$fieldname";
1132             &sou($name,$sou);
1133             print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1134             $type[$typeno] = "$prefix.$fieldname";
1135             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1136             $start = $start{$name};
1137             $length = $sizeof{$name};
1138         }
1139         else {
1140             warn "can't grok stab for $name ($_) in line $line ";
1141             next STAB;
1142         }
1143
1144         &panic("no length for $prefix.$fieldname") unless $length;
1145         $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1146     }
1147     if (s/;\d*,(\d+),(\d+);//) {
1148         local($start, $size) = ($1, $2);
1149         $sizeof{$prefix} = $size;
1150         print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1151         $start{$prefix} = $start;
1152     }
1153     $_;
1154 }
1155
1156 sub edecl {
1157     s/;$//;
1158     $enum{$name} = $_;
1159     $_ = '';
1160 }
1161
1162 sub resolve_types {
1163     local($sou);
1164     for $i (0 .. $#type) {
1165         next unless defined $type[$i];
1166         $_ = $type[$i];
1167         unless (/\d/) {
1168             print "type[$i] $type[$i]\n" if $debug;
1169             next;
1170         }
1171         print "type[$i] $_ ==> " if $debug;
1172         s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
1173         s/^(\d+)\&/&type($1)/e;
1174         s/^(\d+)/&type($1)/e;
1175         s/(\*+)([^*]+)(\*+)/$1$3$2/;
1176         s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1177         s/^(\d+)([\*\[].*)/&type($1).$2/e;
1178         #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1179         $type[$i] = $_;
1180         print "$_\n" if $debug;
1181     }
1182 }
1183 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
1184
1185 sub adjust_start_addrs {
1186     for (sort keys %start) {
1187         ($basename = $_) =~ s/\.[^.]+$//;
1188         $start{$_} += $start{$basename};
1189         print "start: $_ @ $start{$_}\n" if $debug;
1190     }
1191 }
1192
1193 sub sou {
1194     local($what, $_) = @_;
1195     /u/ && $isaunion{$what}++;
1196     /s/ && $isastruct{$what}++;
1197 }
1198
1199 sub psou {
1200     local($what) = @_;
1201     local($prefix) = '';
1202     if ($isaunion{$what})  {
1203         $prefix = 'union ';
1204     } elsif ($isastruct{$what})  {
1205         $prefix = 'struct ';
1206     }
1207     $prefix . $what;
1208 }
1209
1210 sub scrunch {
1211     local($_) = @_;
1212
1213     return '' if $_ eq '';
1214
1215     study;
1216
1217     s/\$//g;
1218     s/  / /g;
1219     1 while s/(\w) \1/$1$1/g;
1220
1221     # i wanna say this, but perl resists my efforts:
1222     #      s/(\w)(\1+)/$2 . length($1)/ge;
1223
1224     &quick_scrunch;
1225
1226     s/ $//;
1227
1228     $_;
1229 }
1230
1231 sub buildscrunchlist {
1232     $scrunch_code = "sub quick_scrunch {\n";
1233     for (values %intrinsics) {
1234         $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
1235     }
1236     $scrunch_code .= "}\n";
1237     print "$scrunch_code" if $debug;
1238     eval $scrunch_code;
1239     &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1240 }
1241
1242 sub fetch_template {
1243     local($mytype) = @_;
1244     local($fmt);
1245     local($count) = 1;
1246
1247     &panic("why do you care?") unless $perl;
1248
1249     if ($mytype =~ s/(\[\d+\])+$//) {
1250         $count .= $1;
1251     }
1252
1253     if ($mytype =~ /\*/) {
1254         $fmt = $template{'pointer'};
1255     }
1256     elsif (defined $template{$mytype}) {
1257         $fmt = $template{$mytype};
1258     }
1259     elsif (defined $struct{$mytype}) {
1260         if (!defined $template{&psou($mytype)}) {
1261             &build_template($mytype) unless $mytype eq $name;
1262         }
1263         elsif ($template{&psou($mytype)} !~ /\$$/) {
1264             #warn "incomplete template for $mytype\n";
1265         }
1266         $fmt = $template{&psou($mytype)} || '?';
1267     }
1268     else {
1269         warn "unknown fmt for $mytype\n";
1270         $fmt = '?';
1271     }
1272
1273     $fmt x $count . ' ';
1274 }
1275
1276 sub compute_intrinsics {
1277     $TMPDIR ||= tempdir(CLEANUP => 1);
1278     local($TMP) = "$TMPDIR/c2ph-i.$$.c";
1279     open (TMP, ">$TMP") || die "can't open $TMP: $!";
1280     select(TMP);
1281
1282     print STDERR "computing intrinsic sizes: " if $trace;
1283
1284     undef %intrinsics;
1285
1286     print <<'EOF';
1287 main() {
1288     char *mask = "%d %s\n";
1289 EOF
1290
1291     for $type (@intrinsics) {
1292         next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
1293         print <<"EOF";
1294     printf(mask,sizeof($type), "$type");
1295 EOF
1296     }
1297
1298     print <<'EOF';
1299     printf(mask,sizeof(char *), "pointer");
1300     exit(0);
1301 }
1302 EOF
1303     close TMP;
1304
1305     select(STDOUT);
1306     open(PIPE, "cd $TMPDIR && $CC $TMP && $TMPDIR/a.out|");
1307     while (<PIPE>) {
1308         chop;
1309         split(' ',$_,2);;
1310         print "intrinsic $_[1] is size $_[0]\n" if $debug;
1311         $sizeof{$_[1]} = $_[0];
1312         $intrinsics{$_[1]} = $template{$_[0]};
1313     }
1314     close(PIPE) || die "couldn't read intrinsics!";
1315     unlink($TMP, '$TMPDIR/a.out');
1316     print STDERR "done\n" if $trace;
1317 }
1318
1319 sub scripts2count {
1320     local($_) = @_;
1321
1322     s/^\[//;
1323     s/\]$//;
1324     s/\]\[/*/g;
1325     $_ = eval;
1326     &panic("$_: $@") if $@;
1327     $_;
1328 }
1329
1330 sub system {
1331     print STDERR "@_\n" if $trace;
1332     system @_;
1333 }
1334
1335 sub build_template {
1336     local($name) = @_;
1337
1338     &panic("already got a template for $name") if defined $template{$name};
1339
1340     local($build_templates) = 1;
1341
1342     local($lparen) = '(' x $build_recursed;
1343     local($rparen) = ')' x $build_recursed;
1344
1345     print STDERR "$lparen$name$rparen " if $trace;
1346     $build_recursed++;
1347     &pstruct($name,$name,0);
1348     print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1349     --$build_recursed;
1350 }
1351
1352
1353 sub panic {
1354
1355     select(STDERR);
1356
1357     print "\npanic: @_\n";
1358
1359     exit 1 if $] <= 4.003;  # caller broken
1360
1361     local($i,$_);
1362     local($p,$f,$l,$s,$h,$a,@a,@sub);
1363     for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1364         @a = @DB'args;
1365         for (@a) {
1366             if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1367                 $_ = sprintf("%s",$_);
1368             }
1369             else {
1370                 s/'/\\'/g;
1371                 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1372                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1373                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1374             }
1375         }
1376         $w = $w ? '@ = ' : '$ = ';
1377         $a = $h ? '(' . join(', ', @a) . ')' : '';
1378         push(@sub, "$w&$s$a from file $f line $l\n");
1379         last if $signal;
1380     }
1381     for ($i=0; $i <= $#sub; $i++) {
1382         last if $signal;
1383         print $sub[$i];
1384     }
1385     exit 1;
1386 }
1387
1388 sub squishseq {
1389     local($num);
1390     local($last) = -1e8;
1391     local($string);
1392     local($seq) = '..';
1393
1394     while (defined($num = shift)) {
1395         if ($num == ($last + 1)) {
1396             $string .= $seq unless $inseq++;
1397             $last = $num;
1398             next;
1399         } elsif ($inseq) {
1400             $string .= $last unless $last == -1e8;
1401         }
1402
1403         $string .= ',' if defined $string;
1404         $string .= $num;
1405         $last = $num;
1406         $inseq = 0;
1407     }
1408     $string .= $last if $inseq && $last != -e18;
1409     $string;
1410 }
1411
1412 sub repeat_template {
1413     #  local($template, $scripts) = @_;  have to change caller's values
1414
1415     if ( $_[1] ) {
1416         local($ncount) = &scripts2count($_[1]);
1417         if ($_[0] =~ /^\s*c\s*$/i) {
1418             $_[0] = "A$ncount ";
1419             $_[1] = '';
1420         } else {
1421             $_[0] = $template x $ncount;
1422         }
1423     }
1424 }
1425 !NO!SUBS!
1426
1427 close OUT or die "Can't close $file: $!";
1428 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1429 unlink 'pstruct';
1430 print "Linking c2ph to pstruct.\n";
1431 if (defined $Config{d_link}) {
1432   link 'c2ph', 'pstruct';
1433 } else {
1434   unshift @INC, '../lib';
1435   require File::Copy;
1436   File::Copy::syscopy('c2ph', 'pstruct');
1437 }
1438 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1439 chdir $origdir;