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