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