Installer: Early check whether the installation directory is writable
[msysgit.git] / bin / c2ph
blobda97d759a328cc09c2040d5e91be386d6708b269
1 #!/usr/bin/perl
2 eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
3 if $running_under_some_shell;
6 # c2ph (aka pstruct)
7 # Tom Christiansen, <tchrist@convex.com>
9 # As pstruct, dump C structures as generated from 'cc -g -S' stabs.
10 # As c2ph, do this PLUS generate perl code for getting at the structures.
12 # See the usage message for more. If this isn't enough, read the code.
15 =head1 NAME
17 c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
19 =head1 SYNOPSIS
21 c2ph [-dpnP] [var=val] [files ...]
23 =head2 OPTIONS
25 Options:
27 -w wide; short for: type_width=45 member_width=35 offset_width=8
28 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
30 -n do not generate perl code (default when invoked as pstruct)
31 -p generate perl code (default when invoked as c2ph)
32 -v generate perl code, with C decls as comments
34 -i do NOT recompute sizes for intrinsic datatypes
35 -a dump information on intrinsics also
37 -t trace execution
38 -d spew reams of debugging output
40 -slist give comma-separated list a structures to dump
42 =head1 DESCRIPTION
44 The following is the old c2ph.doc documentation by Tom Christiansen
45 <tchrist@perl.com>
46 Date: 25 Jul 91 08:10:21 GMT
48 Once upon a time, I wrote a program called pstruct. It was a perl
49 program that tried to parse out C structures and display their member
50 offsets for you. This was especially useful for people looking at
51 binary dumps or poking around the kernel.
53 Pstruct was not a pretty program. Neither was it particularly robust.
54 The problem, you see, was that the C compiler was much better at parsing
55 C than I could ever hope to be.
57 So I got smart: I decided to be lazy and let the C compiler parse the C,
58 which would spit out debugger stabs for me to read. These were much
59 easier to parse. It's still not a pretty program, but at least it's more
60 robust.
62 Pstruct takes any .c or .h files, or preferably .s ones, since that's
63 the format it is going to massage them into anyway, and spits out
64 listings like this:
66 struct tty {
67 int tty.t_locker 000 4
68 int tty.t_mutex_index 004 4
69 struct tty * tty.t_tp_virt 008 4
70 struct clist tty.t_rawq 00c 20
71 int tty.t_rawq.c_cc 00c 4
72 int tty.t_rawq.c_cmax 010 4
73 int tty.t_rawq.c_cfx 014 4
74 int tty.t_rawq.c_clx 018 4
75 struct tty * tty.t_rawq.c_tp_cpu 01c 4
76 struct tty * tty.t_rawq.c_tp_iop 020 4
77 unsigned char * tty.t_rawq.c_buf_cpu 024 4
78 unsigned char * tty.t_rawq.c_buf_iop 028 4
79 struct clist tty.t_canq 02c 20
80 int tty.t_canq.c_cc 02c 4
81 int tty.t_canq.c_cmax 030 4
82 int tty.t_canq.c_cfx 034 4
83 int tty.t_canq.c_clx 038 4
84 struct tty * tty.t_canq.c_tp_cpu 03c 4
85 struct tty * tty.t_canq.c_tp_iop 040 4
86 unsigned char * tty.t_canq.c_buf_cpu 044 4
87 unsigned char * tty.t_canq.c_buf_iop 048 4
88 struct clist tty.t_outq 04c 20
89 int tty.t_outq.c_cc 04c 4
90 int tty.t_outq.c_cmax 050 4
91 int tty.t_outq.c_cfx 054 4
92 int tty.t_outq.c_clx 058 4
93 struct tty * tty.t_outq.c_tp_cpu 05c 4
94 struct tty * tty.t_outq.c_tp_iop 060 4
95 unsigned char * tty.t_outq.c_buf_cpu 064 4
96 unsigned char * tty.t_outq.c_buf_iop 068 4
97 (*int)() tty.t_oproc_cpu 06c 4
98 (*int)() tty.t_oproc_iop 070 4
99 (*int)() tty.t_stopproc_cpu 074 4
100 (*int)() tty.t_stopproc_iop 078 4
101 struct thread * tty.t_rsel 07c 4
103 etc.
106 Actually, this was generated by a particular set of options. You can control
107 the formatting of each column, whether you prefer wide or fat, hex or decimal,
108 leading zeroes or whatever.
110 All you need to be able to use this is a C compiler than generates
111 BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
112 should get this for you.
114 To learn more, just type a bogus option, like B<-\?>, and a long usage message
115 will be provided. There are a fair number of possibilities.
117 If you're only a C programmer, than this is the end of the message for you.
118 You can quit right now, and if you care to, save off the source and run it
119 when you feel like it. Or not.
123 But if you're a perl programmer, then for you I have something much more
124 wondrous than just a structure offset printer.
126 You see, if you call pstruct by its other incybernation, c2ph, you have a code
127 generator that translates C code into perl code! Well, structure and union
128 declarations at least, but that's quite a bit.
130 Prior to this point, anyone programming in perl who wanted to interact
131 with C programs, like the kernel, was forced to guess the layouts of
132 the C structures, and then hardwire these into his program. Of course,
133 when you took your wonderfully crafted program to a system where the
134 sgtty structure was laid out differently, your program broke. Which is
135 a shame.
137 We've had Larry's h2ph translator, which helped, but that only works on
138 cpp symbols, not real C, which was also very much needed. What I offer
139 you is a symbolic way of getting at all the C structures. I've couched
140 them in terms of packages and functions. Consider the following program:
142 #!/usr/local/bin/perl
144 require 'syscall.ph';
145 require 'sys/time.ph';
146 require 'sys/resource.ph';
148 $ru = "\0" x &rusage'sizeof();
150 syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
152 @ru = unpack($t = &rusage'typedef(), $ru);
154 $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
155 + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
157 $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
158 + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
160 printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
163 As you see, the name of the package is the name of the structure. Regular
164 fields are just their own names. Plus the following accessor functions are
165 provided for your convenience:
167 struct This takes no arguments, and is merely the number of first-level
168 elements in the structure. You would use this for indexing
169 into arrays of structures, perhaps like this
172 $usec = $u[ &user'u_utimer
173 + (&ITIMER_VIRTUAL * &itimerval'struct)
174 + &itimerval'it_value
175 + &timeval'tv_usec
178 sizeof Returns the bytes in the structure, or the member if
179 you pass it an argument, such as
181 &rusage'sizeof(&rusage'ru_utime)
183 typedef This is the perl format definition for passing to pack and
184 unpack. If you ask for the typedef of a nothing, you get
185 the whole structure, otherwise you get that of the member
186 you ask for. Padding is taken care of, as is the magic to
187 guarantee that a union is unpacked into all its aliases.
188 Bitfields are not quite yet supported however.
190 offsetof This function is the byte offset into the array of that
191 member. You may wish to use this for indexing directly
192 into the packed structure with vec() if you're too lazy
193 to unpack it.
195 typeof Not to be confused with the typedef accessor function, this
196 one returns the C type of that field. This would allow
197 you to print out a nice structured pretty print of some
198 structure without knoning anything about it beforehand.
199 No args to this one is a noop. Someday I'll post such
200 a thing to dump out your u structure for you.
203 The way I see this being used is like basically this:
205 % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
206 % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
207 % install
209 It's a little tricker with c2ph because you have to get the includes right.
210 I can't know this for your system, but it's not usually too terribly difficult.
212 The code isn't pretty as I mentioned -- I never thought it would be a 1000-
213 line program when I started, or I might not have begun. :-) But I would have
214 been less cavalier in how the parts of the program communicated with each
215 other, etc. It might also have helped if I didn't have to divine the makeup
216 of the stabs on the fly, and then account for micro differences between my
217 compiler and gcc.
219 Anyway, here it is. Should run on perl v4 or greater. Maybe less.
222 --tom
224 =cut
226 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
228 use File::Temp;
230 ######################################################################
232 # some handy data definitions. many of these can be reset later.
234 $bitorder = 'b'; # ascending; set to B for descending bit fields
236 %intrinsics =
237 %template = (
238 'char', 'c',
239 'unsigned char', 'C',
240 'short', 's',
241 'short int', 's',
242 'unsigned short', 'S',
243 'unsigned short int', 'S',
244 'short unsigned int', 'S',
245 'int', 'i',
246 'unsigned int', 'I',
247 'long', 'l',
248 'long int', 'l',
249 'unsigned long', 'L',
250 'unsigned long', 'L',
251 'long unsigned int', 'L',
252 'unsigned long int', 'L',
253 'long long', 'q',
254 'long long int', 'q',
255 'unsigned long long', 'Q',
256 'unsigned long long int', 'Q',
257 'float', 'f',
258 'double', 'd',
259 'pointer', 'p',
260 'null', 'x',
261 'neganull', 'X',
262 'bit', $bitorder,
265 &buildscrunchlist;
266 delete $intrinsics{'neganull'};
267 delete $intrinsics{'bit'};
268 delete $intrinsics{'null'};
270 # use -s to recompute sizes
271 %sizeof = (
272 'char', '1',
273 'unsigned char', '1',
274 'short', '2',
275 'short int', '2',
276 'unsigned short', '2',
277 'unsigned short int', '2',
278 'short unsigned int', '2',
279 'int', '4',
280 'unsigned int', '4',
281 'long', '4',
282 'long int', '4',
283 'unsigned long', '4',
284 'unsigned long int', '4',
285 'long unsigned int', '4',
286 'long long', '8',
287 'long long int', '8',
288 'unsigned long long', '8',
289 'unsigned long long int', '8',
290 'float', '4',
291 'double', '8',
292 'pointer', '4',
295 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
297 ($offset_fmt, $size_fmt) = ('d', 'd');
299 $indent = 2;
301 $CC = 'cc';
302 $CFLAGS = '-g -S';
303 $DEFINES = '';
305 $perl++ if $0 =~ m#/?c2ph$#;
307 require 'getopts.pl';
309 use File::Temp 'tempdir';
311 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
313 &Getopts('aixdpvtnws:') || &usage(0);
315 $opt_d && $debug++;
316 $opt_t && $trace++;
317 $opt_p && $perl++;
318 $opt_v && $verbose++;
319 $opt_n && ($perl = 0);
321 if ($opt_w) {
322 ($type_width, $member_width, $offset_width) = (45, 35, 8);
324 if ($opt_x) {
325 ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
328 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
330 sub PLUMBER {
331 select(STDERR);
332 print "oops, apperent pager foulup\n";
333 $isatty++;
334 &usage(1);
337 sub usage {
338 local($oops) = @_;
339 unless (-t STDOUT) {
340 select(STDERR);
341 } elsif (!$oops) {
342 $isatty++;
343 $| = 1;
344 print "hit <RETURN> for further explanation: ";
345 <STDIN>;
346 open (PIPE, "|". ($ENV{PAGER} || 'more'));
347 $SIG{PIPE} = PLUMBER;
348 select(PIPE);
351 print "usage: $0 [-dpnP] [var=val] [files ...]\n";
353 exit unless $isatty;
355 print <<EOF;
357 Options:
359 -w wide; short for: type_width=45 member_width=35 offset_width=8
360 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
362 -n do not generate perl code (default when invoked as pstruct)
363 -p generate perl code (default when invoked as c2ph)
364 -v generate perl code, with C decls as comments
366 -i do NOT recompute sizes for intrinsic datatypes
367 -a dump information on intrinsics also
369 -t trace execution
370 -d spew reams of debugging output
372 -slist give comma-separated list a structures to dump
375 Var Name Default Value Meaning
379 &defvar('CC', 'which_compiler to call');
380 &defvar('CFLAGS', 'how to generate *.s files with stabs');
381 &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
383 print "\n";
385 &defvar('type_width', 'width of type field (column 1)');
386 &defvar('member_width', 'width of member field (column 2)');
387 &defvar('offset_width', 'width of offset field (column 3)');
388 &defvar('size_width', 'width of size field (column 4)');
390 print "\n";
392 &defvar('offset_fmt', 'sprintf format type for offset');
393 &defvar('size_fmt', 'sprintf format type for size');
395 print "\n";
397 &defvar('indent', 'how far to indent each nesting level');
399 print <<'EOF';
401 If any *.[ch] files are given, these will be catted together into
402 a temporary *.c file and sent through:
403 $CC $CFLAGS $DEFINES
404 and the resulting *.s groped for stab information. If no files are
405 supplied, then stdin is read directly with the assumption that it
406 contains stab information. All other lines will be ignored. At
407 most one *.s file should be supplied.
410 close PIPE;
411 exit 1;
414 sub defvar {
415 local($var, $msg) = @_;
416 printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
419 sub safedir {
420 $SAFEDIR = File::Temp::tempdir("c2ph.XXXXXX", TMPDIR => 1, CLEANUP => 1)
421 unless (defined($SAFEDIR));
424 undef $SAFEDIR;
426 $recurse = 1;
428 if (@ARGV) {
429 if (grep(!/\.[csh]$/,@ARGV)) {
430 warn "Only *.[csh] files expected!\n";
431 &usage;
433 elsif (grep(/\.s$/,@ARGV)) {
434 if (@ARGV > 1) {
435 warn "Only one *.s file allowed!\n";
436 &usage;
439 elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
440 local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
441 $chdir = "cd $dir && " if $dir;
442 &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
443 $ARGV[0] =~ s/\.c$/.s/;
445 else {
446 &safedir;
447 $TMP = "$SAFEDIR/c2ph.$$.c";
448 &system("cat @ARGV > $TMP") && exit 1;
449 &system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1;
450 unlink $TMP;
451 $TMP =~ s/\.c$/.s/;
452 @ARGV = ($TMP);
456 if ($opt_s) {
457 for (split(/[\s,]+/, $opt_s)) {
458 $interested{$_}++;
463 $| = 1 if $debug;
465 main: {
467 if ($trace) {
468 if (-t && !@ARGV) {
469 print STDERR "reading from your keyboard: ";
470 } else {
471 print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
475 STAB: while (<>) {
476 if ($trace && !($. % 10)) {
477 $lineno = $..'';
478 print STDERR $lineno, "\b" x length($lineno);
480 next unless /^\s*\.stabs\s+/;
481 $line = $_;
482 s/^\s*\.stabs\s+//;
483 if (s/\\\\"[d,]+$//) {
484 $saveline .= $line;
485 $savebar = $_;
486 next STAB;
488 if ($saveline) {
489 s/^"//;
490 $_ = $savebar . $_;
491 $line = $saveline;
493 &stab;
494 $savebar = $saveline = undef;
496 print STDERR "$.\n" if $trace;
497 unlink $TMP if $TMP;
499 &compute_intrinsics if $perl && !$opt_i;
501 print STDERR "resolving types\n" if $trace;
503 &resolve_types;
504 &adjust_start_addrs;
506 $sum = 2 + $type_width + $member_width;
507 $pmask1 = "%-${type_width}s %-${member_width}s";
508 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
512 if ($perl) {
513 # resolve template -- should be in stab define order, but even this isn't enough.
514 print STDERR "\nbuilding type templates: " if $trace;
515 for $i (reverse 0..$#type) {
516 next unless defined($name = $type[$i]);
517 next unless defined $struct{$name};
518 ($iname = $name) =~ s/\..*//;
519 $build_recursed = 0;
520 &build_template($name) unless defined $template{&psou($name)} ||
521 $opt_s && !$interested{$iname};
523 print STDERR "\n\n" if $trace;
526 print STDERR "dumping structs: " if $trace;
528 local($iam);
532 foreach $name (sort keys %struct) {
533 ($iname = $name) =~ s/\..*//;
534 next if $opt_s && !$interested{$iname};
535 print STDERR "$name " if $trace;
537 undef @sizeof;
538 undef @typedef;
539 undef @offsetof;
540 undef @indices;
541 undef @typeof;
542 undef @fieldnames;
544 $mname = &munge($name);
546 $fname = &psou($name);
548 print "# " if $perl && $verbose;
549 $pcode = '';
550 print "$fname {\n" if !$perl || $verbose;
551 $template{$fname} = &scrunch($template{$fname}) if $perl;
552 &pstruct($name,$name,0);
553 print "# " if $perl && $verbose;
554 print "}\n" if !$perl || $verbose;
555 print "\n" if $perl && $verbose;
557 if ($perl) {
558 print "$pcode";
560 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
562 print <<EOF;
563 sub ${mname}'typedef {
564 local(\$${mname}'index) = shift;
565 defined \$${mname}'index
566 ? \$${mname}'typedef[\$${mname}'index]
567 : \$${mname}'typedef;
571 print <<EOF;
572 sub ${mname}'sizeof {
573 local(\$${mname}'index) = shift;
574 defined \$${mname}'index
575 ? \$${mname}'sizeof[\$${mname}'index]
576 : \$${mname}'sizeof;
580 print <<EOF;
581 sub ${mname}'offsetof {
582 local(\$${mname}'index) = shift;
583 defined \$${mname}index
584 ? \$${mname}'offsetof[\$${mname}'index]
585 : \$${mname}'sizeof;
589 print <<EOF;
590 sub ${mname}'typeof {
591 local(\$${mname}'index) = shift;
592 defined \$${mname}index
593 ? \$${mname}'typeof[\$${mname}'index]
594 : '$name';
598 print <<EOF;
599 sub ${mname}'fieldnames {
600 \@${mname}'fieldnames;
604 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
606 print <<EOF;
607 sub ${mname}'isastruct {
608 '$iam';
612 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
613 . "';\n";
615 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
618 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
620 print "\n";
622 print "\@${mname}'typedef[\@${mname}'indices] = (",
623 join("\n\t", '', @typedef), "\n );\n\n";
624 print "\@${mname}'sizeof[\@${mname}'indices] = (",
625 join("\n\t", '', @sizeof), "\n );\n\n";
626 print "\@${mname}'offsetof[\@${mname}'indices] = (",
627 join("\n\t", '', @offsetof), "\n );\n\n";
628 print "\@${mname}'typeof[\@${mname}'indices] = (",
629 join("\n\t", '', @typeof), "\n );\n\n";
630 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
631 join("\n\t", '', @fieldnames), "\n );\n\n";
633 $template_printed{$fname}++;
634 $size_printed{$fname}++;
636 print "\n";
639 print STDERR "\n" if $trace;
641 unless ($perl && $opt_a) {
642 print "\n1;\n" if $perl;
643 exit;
648 foreach $name (sort bysizevalue keys %intrinsics) {
649 next if $size_printed{$name};
650 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
653 print "\n";
655 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
658 foreach $name (sort keys %intrinsics) {
659 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
662 print "\n1;\n" if $perl;
664 exit;
667 ########################################################################################
670 sub stab {
671 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
672 s/"// || next;
673 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
675 next if /^\s*$/;
677 $size = $3 if $3;
678 $_ = $continued . $_ if length($continued);
679 if (s/\\\\$//) {
680 # if last 2 chars of string are '\\' then stab is continued
681 # in next stab entry
682 chop;
683 $continued = $_;
684 next;
686 $continued = '';
689 $line = $_;
691 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
692 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
693 &pdecl($pdecl);
694 next;
699 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
700 local($ident) = $2;
701 push(@intrinsics, $ident);
702 $typeno = &typeno($3);
703 $type[$typeno] = $ident;
704 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
705 next;
708 if (($name, $typeordef, $typeno, $extra, $struct, $_)
709 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
711 $typeno = &typeno($typeno); # sun foolery
713 elsif (/^[\$\w]+:/) {
714 next; # variable
716 else {
717 warn "can't grok stab: <$_> in: $line " if $_;
718 next;
721 #warn "got size $size for $name\n";
722 $sizeof{$name} = $size if $size;
724 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
726 $typenos{$name} = $typeno;
728 unless (defined $type[$typeno]) {
729 &panic("type 0??") unless $typeno;
730 $type[$typeno] = $name unless defined $type[$typeno];
731 printf "new type $typeno is $name" if $debug;
732 if ($extra =~ /\*/ && defined $type[$struct]) {
733 print ", a typedef for a pointer to " , $type[$struct] if $debug;
735 } else {
736 printf "%s is type %d", $name, $typeno if $debug;
737 print ", a typedef for " , $type[$typeno] if $debug;
739 print "\n" if $debug;
740 #next unless $extra =~ /[su*]/;
742 #$type[$struct] = $name;
744 if ($extra =~ /[us*]/) {
745 &sou($name, $extra);
746 $_ = &sdecl($name, $_, 0);
748 elsif (/^=ar/) {
749 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
750 $_ = "$typeno$_";
751 $scripts = '';
752 $_ = &adecl($_,1);
755 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
756 push(@intrinsics, $2);
757 $typeno = &typeno($3);
758 $type[$typeno] = $2;
759 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
761 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
762 &edecl;
764 else {
765 warn "Funny remainder for $name on line $_ left in $line " if $_;
769 sub typeno { # sun thinks types are (0,27) instead of just 27
770 local($_) = @_;
771 s/\(\d+,(\d+)\)/$1/;
775 sub pstruct {
776 local($what,$prefix,$base) = @_;
777 local($field, $fieldname, $typeno, $count, $offset, $entry);
778 local($fieldtype);
779 local($type, $tname);
780 local($mytype, $mycount, $entry2);
781 local($struct_count) = 0;
782 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
783 local($bits,$bytes);
784 local($template);
787 local($mname) = &munge($name);
789 sub munge {
790 local($_) = @_;
791 s/[\s\$\.]/_/g;
795 local($sname) = &psou($what);
797 $nesting++;
799 for $field (split(/;/, $struct{$what})) {
800 $pad = $prepad = 0;
801 $entry = '';
802 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
804 $type = $type[$typeno];
806 $type =~ /([^[]*)(\[.*\])?/;
807 $mytype = $1;
808 $count .= $2;
809 $fieldtype = &psou($mytype);
811 local($fname) = &psou($name);
813 if ($build_templates) {
815 $pad = ($offset - ($lastoffset + $lastlength))/8
816 if defined $lastoffset;
818 if (! $finished_template{$sname}) {
819 if ($isaunion{$what}) {
820 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
821 } else {
822 $template{$sname} .= 'x' x $pad . ' ' if $pad;
826 $template = &fetch_template($type);
827 &repeat_template($template,$count);
829 if (! $finished_template{$sname}) {
830 $template{$sname} .= $template;
833 $revpad = $length/8 if $isaunion{$what};
835 ($lastoffset, $lastlength) = ($offset, $length);
837 } else {
838 print '# ' if $perl && $verbose;
839 $entry = sprintf($pmask1,
840 ' ' x ($nesting * $indent) . $fieldtype,
841 "$prefix.$fieldname" . $count);
843 $entry =~ s/(\*+)( )/$2$1/;
845 printf $pmask2,
846 $entry,
847 ($base+$offset)/8,
848 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
849 $length/8,
850 ($bits = $length % 8) ? ".$bits": ""
851 if !$perl || $verbose;
853 if ($perl) {
854 $template = &fetch_template($type);
855 &repeat_template($template,$count);
858 if ($perl && $nesting == 1) {
860 push(@sizeof, int($length/8) .",\t# $fieldname");
861 push(@offsetof, int($offset/8) .",\t# $fieldname");
862 local($little) = &scrunch($template);
863 push(@typedef, "'$little', \t# $fieldname");
864 $type =~ s/(struct|union) //;
865 push(@typeof, "'$mytype" . ($count ? $count : '') .
866 "',\t# $fieldname");
867 push(@fieldnames, "'$fieldname',");
870 print ' ', ' ' x $indent x $nesting, $template
871 if $perl && $verbose;
873 print "\n" if !$perl || $verbose;
876 if ($perl) {
877 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
878 $mycount *= &scripts2count($count) if $count;
879 if ($nesting==1 && !$build_templates) {
880 $pcode .= sprintf("sub %-32s { %4d; }\n",
881 "${mname}'${fieldname}", $struct_count);
882 push(@indices, $struct_count);
884 $struct_count += $mycount;
888 &pstruct($type, "$prefix.$fieldname", $base+$offset)
889 if $recurse && defined $struct{$type};
892 $countof{$what} = $struct_count unless defined $countof{$whati};
894 $template{$sname} .= '$' if $build_templates;
895 $finished_template{$sname}++;
897 if ($build_templates && !defined $sizeof{$name}) {
898 local($fmt) = &scrunch($template{$sname});
899 print STDERR "no size for $name, punting with $fmt..." if $debug;
900 eval '$sizeof{$name} = length(pack($fmt, ()))';
901 if ($@) {
902 chop $@;
903 warn "couldn't get size for \$name: $@";
904 } else {
905 print STDERR $sizeof{$name}, "\n" if $debUg;
909 --$nesting;
913 sub psize {
914 local($me) = @_;
915 local($amstruct) = $struct{$me} ? 'struct ' : '';
917 print '$sizeof{\'', $amstruct, $me, '\'} = ';
918 printf "%d;\n", $sizeof{$me};
921 sub pdecl {
922 local($pdecl) = @_;
923 local(@pdecls);
924 local($tname);
926 warn "pdecl: $pdecl\n" if $debug;
928 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
929 $pdecl =~ s/\*//g;
930 @pdecls = split(/=/, $pdecl);
931 $typeno = $pdecls[0];
932 $tname = pop @pdecls;
934 if ($tname =~ s/^f//) { $tname = "$tname&"; }
935 #else { $tname = "$tname*"; }
937 for (reverse @pdecls) {
938 $tname .= s/^f// ? "&" : "*";
939 #$tname =~ s/^f(.*)/$1&/;
940 print "type[$_] is $tname\n" if $debug;
941 $type[$_] = $tname unless defined $type[$_];
947 sub adecl {
948 ($arraytype, $unknown, $lower, $upper) = ();
949 #local($typeno);
950 # global $typeno, @type
951 local($_, $typedef) = @_;
953 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
954 ($arraytype, $unknown) = ($2, $3);
955 $arraytype = &typeno($arraytype);
956 $unknown = &typeno($unknown);
957 if (s/^(\d+);(\d+);//) {
958 ($lower, $upper) = ($1, $2);
959 $scripts .= '[' . ($upper+1) . ']';
960 } else {
961 warn "can't find array bounds: $_";
964 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
965 ($start, $length) = ($2, $3);
966 $whatis = $1;
967 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
968 $typeno = &typeno($1);
969 &pdecl($whatis);
970 } else {
971 $typeno = &typeno($whatis);
973 } elsif (s/^(\d+)(=[*suf]\d*)//) {
974 local($whatis) = $2;
976 if ($whatis =~ /[f*]/) {
977 &pdecl($whatis);
978 } elsif ($whatis =~ /[su]/) { #
979 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
980 if $debug;
981 #$type[$typeno] = $name unless defined $type[$typeno];
982 ##printf "new type $typeno is $name" if $debug;
983 $typeno = $1;
984 $type[$typeno] = "$prefix.$fieldname";
985 local($name) = $type[$typeno];
986 &sou($name, $whatis);
987 $_ = &sdecl($name, $_, $start+$offset);
989 $start = $start{$name};
990 $offset = $sizeof{$name};
991 $length = $offset;
992 } else {
993 warn "what's this? $whatis in $line ";
995 } elsif (/^\d+$/) {
996 $typeno = $_;
997 } else {
998 warn "bad array stab: $_ in $line ";
999 next STAB;
1001 #local($wasdef) = defined($type[$typeno]) && $debug;
1002 #if ($typedef) {
1003 #print "redefining $type[$typeno] to " if $wasdef;
1004 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1005 #print "$type[$typeno]\n" if $wasdef;
1006 #} else {
1007 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1009 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1010 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1011 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1017 sub sdecl {
1018 local($prefix, $_, $offset) = @_;
1020 local($fieldname, $scripts, $type, $arraytype, $unknown,
1021 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1022 local($typeno,$sou);
1025 SFIELD:
1026 while (/^([^;]+);/) {
1027 $scripts = '';
1028 warn "sdecl $_\n" if $debug;
1029 if (s/^([\$\w]+)://) {
1030 $fieldname = $1;
1031 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
1032 $typeno = &typeno($1);
1033 $type[$typeno] = "$prefix.$fieldname";
1034 local($name) = "$prefix.$fieldname";
1035 &sou($name,$2);
1036 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1037 $start = $start{$name};
1038 $offset += $sizeof{$name};
1039 #print "done with anon, start is $start, offset is $offset\n";
1040 #next SFIELD;
1041 } else {
1042 warn "weird field $_ of $line" if $debug;
1043 next STAB;
1044 #$fieldname = &gensym;
1045 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1048 if (/^(\d+|\(\d+,\d+\))=ar/) {
1049 $_ = &adecl($_);
1051 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
1052 ($start, $length) = ($2, $3);
1053 &panic("no length?") unless $length;
1054 $typeno = &typeno($1) if $1;
1056 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
1057 ($start, $length) = ($2, $3);
1058 &panic("no length?") unless $length;
1059 $typeno = &typeno($1) if $1;
1061 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
1062 ($pdecl, $start, $length) = ($1,$5,$6);
1063 &pdecl($pdecl);
1065 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1066 ($typeno, $sou) = ($1, $2);
1067 $typeno = &typeno($typeno);
1068 if (defined($type[$typeno])) {
1069 warn "now how did we get type $1 in $fieldname of $line?";
1070 } else {
1071 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1072 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1074 local($name) = "$prefix.$fieldname";
1075 &sou($name,$sou);
1076 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1077 $type[$typeno] = "$prefix.$fieldname";
1078 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1079 $start = $start{$name};
1080 $length = $sizeof{$name};
1082 else {
1083 warn "can't grok stab for $name ($_) in line $line ";
1084 next STAB;
1087 &panic("no length for $prefix.$fieldname") unless $length;
1088 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1090 if (s/;\d*,(\d+),(\d+);//) {
1091 local($start, $size) = ($1, $2);
1092 $sizeof{$prefix} = $size;
1093 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1094 $start{$prefix} = $start;
1099 sub edecl {
1100 s/;$//;
1101 $enum{$name} = $_;
1102 $_ = '';
1105 sub resolve_types {
1106 local($sou);
1107 for $i (0 .. $#type) {
1108 next unless defined $type[$i];
1109 $_ = $type[$i];
1110 unless (/\d/) {
1111 print "type[$i] $type[$i]\n" if $debug;
1112 next;
1114 print "type[$i] $_ ==> " if $debug;
1115 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
1116 s/^(\d+)\&/&type($1)/e;
1117 s/^(\d+)/&type($1)/e;
1118 s/(\*+)([^*]+)(\*+)/$1$3$2/;
1119 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1120 s/^(\d+)([\*\[].*)/&type($1).$2/e;
1121 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1122 $type[$i] = $_;
1123 print "$_\n" if $debug;
1126 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
1128 sub adjust_start_addrs {
1129 for (sort keys %start) {
1130 ($basename = $_) =~ s/\.[^.]+$//;
1131 $start{$_} += $start{$basename};
1132 print "start: $_ @ $start{$_}\n" if $debug;
1136 sub sou {
1137 local($what, $_) = @_;
1138 /u/ && $isaunion{$what}++;
1139 /s/ && $isastruct{$what}++;
1142 sub psou {
1143 local($what) = @_;
1144 local($prefix) = '';
1145 if ($isaunion{$what}) {
1146 $prefix = 'union ';
1147 } elsif ($isastruct{$what}) {
1148 $prefix = 'struct ';
1150 $prefix . $what;
1153 sub scrunch {
1154 local($_) = @_;
1156 return '' if $_ eq '';
1158 study;
1160 s/\$//g;
1161 s/ / /g;
1162 1 while s/(\w) \1/$1$1/g;
1164 # i wanna say this, but perl resists my efforts:
1165 # s/(\w)(\1+)/$2 . length($1)/ge;
1167 &quick_scrunch;
1169 s/ $//;
1174 sub buildscrunchlist {
1175 $scrunch_code = "sub quick_scrunch {\n";
1176 for (values %intrinsics) {
1177 $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
1179 $scrunch_code .= "}\n";
1180 print "$scrunch_code" if $debug;
1181 eval $scrunch_code;
1182 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1185 sub fetch_template {
1186 local($mytype) = @_;
1187 local($fmt);
1188 local($count) = 1;
1190 &panic("why do you care?") unless $perl;
1192 if ($mytype =~ s/(\[\d+\])+$//) {
1193 $count .= $1;
1196 if ($mytype =~ /\*/) {
1197 $fmt = $template{'pointer'};
1199 elsif (defined $template{$mytype}) {
1200 $fmt = $template{$mytype};
1202 elsif (defined $struct{$mytype}) {
1203 if (!defined $template{&psou($mytype)}) {
1204 &build_template($mytype) unless $mytype eq $name;
1206 elsif ($template{&psou($mytype)} !~ /\$$/) {
1207 #warn "incomplete template for $mytype\n";
1209 $fmt = $template{&psou($mytype)} || '?';
1211 else {
1212 warn "unknown fmt for $mytype\n";
1213 $fmt = '?';
1216 $fmt x $count . ' ';
1219 sub compute_intrinsics {
1220 &safedir;
1221 local($TMP) = "$SAFEDIR/c2ph-i.$$.c";
1222 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1223 select(TMP);
1225 print STDERR "computing intrinsic sizes: " if $trace;
1227 undef %intrinsics;
1229 print <<'EOF';
1230 main() {
1231 char *mask = "%d %s\n";
1234 for $type (@intrinsics) {
1235 next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
1236 print <<"EOF";
1237 printf(mask,sizeof($type), "$type");
1241 print <<'EOF';
1242 printf(mask,sizeof(char *), "pointer");
1243 exit(0);
1246 close TMP;
1248 select(STDOUT);
1249 open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|");
1250 while (<PIPE>) {
1251 chop;
1252 split(' ',$_,2);;
1253 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1254 $sizeof{$_[1]} = $_[0];
1255 $intrinsics{$_[1]} = $template{$_[0]};
1257 close(PIPE) || die "couldn't read intrinsics!";
1258 unlink($TMP, '$SAFEDIR/a.out');
1259 print STDERR "done\n" if $trace;
1262 sub scripts2count {
1263 local($_) = @_;
1265 s/^\[//;
1266 s/\]$//;
1267 s/\]\[/*/g;
1268 $_ = eval;
1269 &panic("$_: $@") if $@;
1273 sub system {
1274 print STDERR "@_\n" if $trace;
1275 system @_;
1278 sub build_template {
1279 local($name) = @_;
1281 &panic("already got a template for $name") if defined $template{$name};
1283 local($build_templates) = 1;
1285 local($lparen) = '(' x $build_recursed;
1286 local($rparen) = ')' x $build_recursed;
1288 print STDERR "$lparen$name$rparen " if $trace;
1289 $build_recursed++;
1290 &pstruct($name,$name,0);
1291 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1292 --$build_recursed;
1296 sub panic {
1298 select(STDERR);
1300 print "\npanic: @_\n";
1302 exit 1 if $] <= 4.003; # caller broken
1304 local($i,$_);
1305 local($p,$f,$l,$s,$h,$a,@a,@sub);
1306 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1307 @a = @DB'args;
1308 for (@a) {
1309 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1310 $_ = sprintf("%s",$_);
1312 else {
1313 s/'/\\'/g;
1314 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1315 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1316 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1319 $w = $w ? '@ = ' : '$ = ';
1320 $a = $h ? '(' . join(', ', @a) . ')' : '';
1321 push(@sub, "$w&$s$a from file $f line $l\n");
1322 last if $signal;
1324 for ($i=0; $i <= $#sub; $i++) {
1325 last if $signal;
1326 print $sub[$i];
1328 exit 1;
1331 sub squishseq {
1332 local($num);
1333 local($last) = -1e8;
1334 local($string);
1335 local($seq) = '..';
1337 while (defined($num = shift)) {
1338 if ($num == ($last + 1)) {
1339 $string .= $seq unless $inseq++;
1340 $last = $num;
1341 next;
1342 } elsif ($inseq) {
1343 $string .= $last unless $last == -1e8;
1346 $string .= ',' if defined $string;
1347 $string .= $num;
1348 $last = $num;
1349 $inseq = 0;
1351 $string .= $last if $inseq && $last != -e18;
1352 $string;
1355 sub repeat_template {
1356 # local($template, $scripts) = @_; have to change caller's values
1358 if ( $_[1] ) {
1359 local($ncount) = &scripts2count($_[1]);
1360 if ($_[0] =~ /^\s*c\s*$/i) {
1361 $_[0] = "A$ncount ";
1362 $_[1] = '';
1363 } else {
1364 $_[0] = $template x $ncount;