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