utils/c2ph.PL

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