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