utils/c2ph.PL

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