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