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