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