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