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