4 use File::Basename qw(&basename &dirname);
6 # List explicitly here the variables you want Configure to
7 # generate. Metaconfig only looks for shell variables, so you
8 # have to mention them as if they were shell variables, not
9 # %Config entries. Thus you write
11 # to ensure Configure will look for $Config{startperl}.
13 # This forces PL files to create target in same directory as PL file.
14 # This is so that make depend always knows where to find PL derivatives.
16 ($file = basename($0)) =~ s/\.PL$//;
18 if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
20 open OUT,">$file" or die "Can't create $file: $!";
22 print "Extracting $file (with variable substitutions)\n";
24 # In this section, perl variables will be expanded during extraction.
25 # You can use $Config{...} to use Configure variables.
27 print OUT <<"!GROK!THIS!";
29 eval 'exec perl -S \$0 "\$@"'
33 # In the following, perl variables are not expanded during extraction.
35 print OUT <<'!NO!SUBS!';
39 # Tom Christiansen, <tchrist@convex.com>
41 # As pstruct, dump C structures as generated from 'cc -g -S' stabs.
42 # As c2ph, do this PLUS generate perl code for getting at the structures.
44 # See the usage message for more. If this isn't enough, read the code.
49 c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
53 c2ph [-dpnP] [var=val] [files ...]
59 -w wide; short for: type_width=45 member_width=35 offset_width=8
60 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
62 -n do not generate perl code (default when invoked as pstruct)
63 -p generate perl code (default when invoked as c2ph)
64 -v generate perl code, with C decls as comments
66 -i do NOT recompute sizes for intrinsic datatypes
67 -a dump information on intrinsics also
70 -d spew reams of debugging output
72 -slist give comma-separated list a structures to dump
76 The following is the old c2ph.doc documentation by Tom Christiansen
78 Date: 25 Jul 91 08:10:21 GMT
80 Once upon a time, I wrote a program called pstruct. It was a perl
81 program that tried to parse out C structures and display their member
82 offsets for you. This was especially useful for people looking at
83 binary dumps or poking around the kernel.
85 Pstruct was not a pretty program. Neither was it particularly robust.
86 The problem, you see, was that the C compiler was much better at parsing
87 C than I could ever hope to be.
89 So I got smart: I decided to be lazy and let the C compiler parse the C,
90 which would spit out debugger stabs for me to read. These were much
91 easier to parse. It's still not a pretty program, but at least it's more
94 Pstruct takes any .c or .h files, or preferably .s ones, since that's
95 the format it is going to massage them into anyway, and spits out
99 int tty.t_locker 000 4
100 int tty.t_mutex_index 004 4
101 struct tty * tty.t_tp_virt 008 4
102 struct clist tty.t_rawq 00c 20
103 int tty.t_rawq.c_cc 00c 4
104 int tty.t_rawq.c_cmax 010 4
105 int tty.t_rawq.c_cfx 014 4
106 int tty.t_rawq.c_clx 018 4
107 struct tty * tty.t_rawq.c_tp_cpu 01c 4
108 struct tty * tty.t_rawq.c_tp_iop 020 4
109 unsigned char * tty.t_rawq.c_buf_cpu 024 4
110 unsigned char * tty.t_rawq.c_buf_iop 028 4
111 struct clist tty.t_canq 02c 20
112 int tty.t_canq.c_cc 02c 4
113 int tty.t_canq.c_cmax 030 4
114 int tty.t_canq.c_cfx 034 4
115 int tty.t_canq.c_clx 038 4
116 struct tty * tty.t_canq.c_tp_cpu 03c 4
117 struct tty * tty.t_canq.c_tp_iop 040 4
118 unsigned char * tty.t_canq.c_buf_cpu 044 4
119 unsigned char * tty.t_canq.c_buf_iop 048 4
120 struct clist tty.t_outq 04c 20
121 int tty.t_outq.c_cc 04c 4
122 int tty.t_outq.c_cmax 050 4
123 int tty.t_outq.c_cfx 054 4
124 int tty.t_outq.c_clx 058 4
125 struct tty * tty.t_outq.c_tp_cpu 05c 4
126 struct tty * tty.t_outq.c_tp_iop 060 4
127 unsigned char * tty.t_outq.c_buf_cpu 064 4
128 unsigned char * tty.t_outq.c_buf_iop 068 4
129 (*int)() tty.t_oproc_cpu 06c 4
130 (*int)() tty.t_oproc_iop 070 4
131 (*int)() tty.t_stopproc_cpu 074 4
132 (*int)() tty.t_stopproc_iop 078 4
133 struct thread * tty.t_rsel 07c 4
138 Actually, this was generated by a particular set of options. You can control
139 the formatting of each column, whether you prefer wide or fat, hex or decimal,
140 leading zeroes or whatever.
142 All you need to be able to use this is a C compiler than generates
143 BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
144 should get this for you.
146 To learn more, just type a bogus option, like B<-\?>, and a long usage message
147 will be provided. There are a fair number of possibilities.
149 If you're only a C programmer, than this is the end of the message for you.
150 You can quit right now, and if you care to, save off the source and run it
151 when you feel like it. Or not.
155 But if you're a perl programmer, then for you I have something much more
156 wondrous than just a structure offset printer.
158 You see, if you call pstruct by its other incybernation, c2ph, you have a code
159 generator that translates C code into perl code! Well, structure and union
160 declarations at least, but that's quite a bit.
162 Prior to this point, anyone programming in perl who wanted to interact
163 with C programs, like the kernel, was forced to guess the layouts of
164 the C strutures, and then hardwire these into his program. Of course,
165 when you took your wonderfully crafted program to a system where the
166 sgtty structure was laid out differently, you program broke. Which is
169 We've had Larry's h2ph translator, which helped, but that only works on
170 cpp symbols, not real C, which was also very much needed. What I offer
171 you is a symbolic way of getting at all the C structures. I've couched
172 them in terms of packages and functions. Consider the following program:
174 #!/usr/local/bin/perl
176 require 'syscall.ph';
177 require 'sys/time.ph';
178 require 'sys/resource.ph';
180 $ru = "\0" x &rusage'sizeof();
182 syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
184 @ru = unpack($t = &rusage'typedef(), $ru);
186 $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
187 + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
189 $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
190 + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
192 printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
195 As you see, the name of the package is the name of the structure. Regular
196 fields are just their own names. Plus the following accessor functions are
197 provided for your convenience:
199 struct This takes no arguments, and is merely the number of first-level
200 elements in the structure. You would use this for indexing
201 into arrays of structures, perhaps like this
204 $usec = $u[ &user'u_utimer
205 + (&ITIMER_VIRTUAL * &itimerval'struct)
206 + &itimerval'it_value
210 sizeof Returns the bytes in the structure, or the member if
211 you pass it an argument, such as
213 &rusage'sizeof(&rusage'ru_utime)
215 typedef This is the perl format definition for passing to pack and
216 unpack. If you ask for the typedef of a nothing, you get
217 the whole structure, otherwise you get that of the member
218 you ask for. Padding is taken care of, as is the magic to
219 guarantee that a union is unpacked into all its aliases.
220 Bitfields are not quite yet supported however.
222 offsetof This function is the byte offset into the array of that
223 member. You may wish to use this for indexing directly
224 into the packed structure with vec() if you're too lazy
227 typeof Not to be confused with the typedef accessor function, this
228 one returns the C type of that field. This would allow
229 you to print out a nice structured pretty print of some
230 structure without knoning anything about it beforehand.
231 No args to this one is a noop. Someday I'll post such
232 a thing to dump out your u structure for you.
235 The way I see this being used is like basically this:
237 % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
238 % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
241 It's a little tricker with c2ph because you have to get the includes right.
242 I can't know this for your system, but it's not usually too terribly difficult.
244 The code isn't pretty as I mentioned -- I never thought it would be a 1000-
245 line program when I started, or I might not have begun. :-) But I would have
246 been less cavalier in how the parts of the program communicated with each
247 other, etc. It might also have helped if I didn't have to divine the makeup
248 of the stabs on the fly, and then account for micro differences between my
251 Anyway, here it is. Should run on perl v4 or greater. Maybe less.
258 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
261 ######################################################################
263 # some handy data definitions. many of these can be reset later.
265 $bitorder = 'b'; # ascending; set to B for descending bit fields
270 'unsigned char', 'C',
273 'unsigned short', 'S',
274 'unsigned short int', 'S',
275 'short unsigned int', 'S',
280 'unsigned long', 'L',
281 'unsigned long', 'L',
282 'long unsigned int', 'L',
283 'unsigned long int', 'L',
285 'long long int', 'q',
286 'unsigned long long', 'Q',
287 'unsigned long long int', 'Q',
297 delete $intrinsics{'neganull'};
298 delete $intrinsics{'bit'};
299 delete $intrinsics{'null'};
301 # use -s to recompute sizes
304 'unsigned char', '1',
307 'unsigned short', '2',
308 'unsigned short int', '2',
309 'short unsigned int', '2',
314 'unsigned long', '4',
315 'unsigned long int', '4',
316 'long unsigned int', '4',
318 'long long int', '8',
319 'unsigned long long', '8',
320 'unsigned long long int', '8',
326 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
328 ($offset_fmt, $size_fmt) = ('d', 'd');
336 $perl++ if $0 =~ m#/?c2ph$#;
338 require 'getopts.pl';
340 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
342 &Getopts('aixdpvtnws:') || &usage(0);
347 $opt_v && $verbose++;
348 $opt_n && ($perl = 0);
351 ($type_width, $member_width, $offset_width) = (45, 35, 8);
354 ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
357 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
361 print "oops, apperent pager foulup\n";
373 print "hit <RETURN> for further explanation: ";
375 open (PIPE, "|". ($ENV{PAGER} || 'more'));
376 $SIG{PIPE} = PLUMBER;
380 print "usage: $0 [-dpnP] [var=val] [files ...]\n";
388 -w wide; short for: type_width=45 member_width=35 offset_width=8
389 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
391 -n do not generate perl code (default when invoked as pstruct)
392 -p generate perl code (default when invoked as c2ph)
393 -v generate perl code, with C decls as comments
395 -i do NOT recompute sizes for intrinsic datatypes
396 -a dump information on intrinsics also
399 -d spew reams of debugging output
401 -slist give comma-separated list a structures to dump
404 Var Name Default Value Meaning
408 &defvar('CC', 'which_compiler to call');
409 &defvar('CFLAGS', 'how to generate *.s files with stabs');
410 &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
414 &defvar('type_width', 'width of type field (column 1)');
415 &defvar('member_width', 'width of member field (column 2)');
416 &defvar('offset_width', 'width of offset field (column 3)');
417 &defvar('size_width', 'width of size field (column 4)');
421 &defvar('offset_fmt', 'sprintf format type for offset');
422 &defvar('size_fmt', 'sprintf format type for size');
426 &defvar('indent', 'how far to indent each nesting level');
430 If any *.[ch] files are given, these will be catted together into
431 a temporary *.c file and sent through:
433 and the resulting *.s groped for stab information. If no files are
434 supplied, then stdin is read directly with the assumption that it
435 contains stab information. All other liens will be ignored. At
436 most one *.s file should be supplied.
444 local($var, $msg) = @_;
445 printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
451 if (grep(!/\.[csh]$/,@ARGV)) {
452 warn "Only *.[csh] files expected!\n";
455 elsif (grep(/\.s$/,@ARGV)) {
457 warn "Only one *.s file allowed!\n";
461 elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
462 local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
463 $chdir = "cd $dir; " if $dir;
464 &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
465 $ARGV[0] =~ s/\.c$/.s/;
468 $TMP = "/tmp/c2ph.$$.c";
469 &system("cat @ARGV > $TMP") && exit 1;
470 &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
478 for (split(/[\s,]+/, $opt_s)) {
490 print STDERR "reading from your keyboard: ";
492 print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
497 if ($trace && !($. % 10)) {
499 print STDERR $lineno, "\b" x length($lineno);
501 next unless /^\s*\.stabs\s+/;
504 if (s/\\\\"[d,]+$//) {
515 $savebar = $saveline = undef;
517 print STDERR "$.\n" if $trace;
520 &compute_intrinsics if $perl && !$opt_i;
522 print STDERR "resolving types\n" if $trace;
527 $sum = 2 + $type_width + $member_width;
528 $pmask1 = "%-${type_width}s %-${member_width}s";
529 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
534 # resolve template -- should be in stab define order, but even this isn't enough.
535 print STDERR "\nbuilding type templates: " if $trace;
536 for $i (reverse 0..$#type) {
537 next unless defined($name = $type[$i]);
538 next unless defined $struct{$name};
539 ($iname = $name) =~ s/\..*//;
541 &build_template($name) unless defined $template{&psou($name)} ||
542 $opt_s && !$interested{$iname};
544 print STDERR "\n\n" if $trace;
547 print STDERR "dumping structs: " if $trace;
553 foreach $name (sort keys %struct) {
554 ($iname = $name) =~ s/\..*//;
555 next if $opt_s && !$interested{$iname};
556 print STDERR "$name " if $trace;
565 $mname = &munge($name);
567 $fname = &psou($name);
569 print "# " if $perl && $verbose;
571 print "$fname {\n" if !$perl || $verbose;
572 $template{$fname} = &scrunch($template{$fname}) if $perl;
573 &pstruct($name,$name,0);
574 print "# " if $perl && $verbose;
575 print "}\n" if !$perl || $verbose;
576 print "\n" if $perl && $verbose;
581 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
584 sub ${mname}'typedef {
585 local(\$${mname}'index) = shift;
586 defined \$${mname}'index
587 ? \$${mname}'typedef[\$${mname}'index]
588 : \$${mname}'typedef;
593 sub ${mname}'sizeof {
594 local(\$${mname}'index) = shift;
595 defined \$${mname}'index
596 ? \$${mname}'sizeof[\$${mname}'index]
602 sub ${mname}'offsetof {
603 local(\$${mname}'index) = shift;
604 defined \$${mname}index
605 ? \$${mname}'offsetof[\$${mname}'index]
611 sub ${mname}'typeof {
612 local(\$${mname}'index) = shift;
613 defined \$${mname}index
614 ? \$${mname}'typeof[\$${mname}'index]
620 sub ${mname}'fieldnames {
621 \@${mname}'fieldnames;
625 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
628 sub ${mname}'isastruct {
633 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
636 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
639 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
643 print "\@${mname}'typedef[\@${mname}'indices] = (",
644 join("\n\t", '', @typedef), "\n );\n\n";
645 print "\@${mname}'sizeof[\@${mname}'indices] = (",
646 join("\n\t", '', @sizeof), "\n );\n\n";
647 print "\@${mname}'offsetof[\@${mname}'indices] = (",
648 join("\n\t", '', @offsetof), "\n );\n\n";
649 print "\@${mname}'typeof[\@${mname}'indices] = (",
650 join("\n\t", '', @typeof), "\n );\n\n";
651 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
652 join("\n\t", '', @fieldnames), "\n );\n\n";
654 $template_printed{$fname}++;
655 $size_printed{$fname}++;
660 print STDERR "\n" if $trace;
662 unless ($perl && $opt_a) {
663 print "\n1;\n" if $perl;
669 foreach $name (sort bysizevalue keys %intrinsics) {
670 next if $size_printed{$name};
671 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
676 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
679 foreach $name (sort keys %intrinsics) {
680 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
683 print "\n1;\n" if $perl;
688 ########################################################################################
692 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
694 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
699 $_ = $continued . $_ if length($continued);
701 # if last 2 chars of string are '\\' then stab is continued
712 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
713 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
720 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
722 push(@intrinsics, $ident);
723 $typeno = &typeno($3);
724 $type[$typeno] = $ident;
725 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
729 if (($name, $typeordef, $typeno, $extra, $struct, $_)
730 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
732 $typeno = &typeno($typeno); # sun foolery
734 elsif (/^[\$\w]+:/) {
738 warn "can't grok stab: <$_> in: $line " if $_;
742 #warn "got size $size for $name\n";
743 $sizeof{$name} = $size if $size;
745 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
747 $typenos{$name} = $typeno;
749 unless (defined $type[$typeno]) {
750 &panic("type 0??") unless $typeno;
751 $type[$typeno] = $name unless defined $type[$typeno];
752 printf "new type $typeno is $name" if $debug;
753 if ($extra =~ /\*/ && defined $type[$struct]) {
754 print ", a typedef for a pointer to " , $type[$struct] if $debug;
757 printf "%s is type %d", $name, $typeno if $debug;
758 print ", a typedef for " , $type[$typeno] if $debug;
760 print "\n" if $debug;
761 #next unless $extra =~ /[su*]/;
763 #$type[$struct] = $name;
765 if ($extra =~ /[us*]/) {
767 $_ = &sdecl($name, $_, 0);
770 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
776 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
777 push(@intrinsics, $2);
778 $typeno = &typeno($3);
780 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
782 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
786 warn "Funny remainder for $name on line $_ left in $line " if $_;
790 sub typeno { # sun thinks types are (0,27) instead of just 27
797 local($what,$prefix,$base) = @_;
798 local($field, $fieldname, $typeno, $count, $offset, $entry);
800 local($type, $tname);
801 local($mytype, $mycount, $entry2);
802 local($struct_count) = 0;
803 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
808 local($mname) = &munge($name);
816 local($sname) = &psou($what);
820 for $field (split(/;/, $struct{$what})) {
823 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
825 $type = $type[$typeno];
827 $type =~ /([^[]*)(\[.*\])?/;
830 $fieldtype = &psou($mytype);
832 local($fname) = &psou($name);
834 if ($build_templates) {
836 $pad = ($offset - ($lastoffset + $lastlength))/8
837 if defined $lastoffset;
839 if (! $finished_template{$sname}) {
840 if ($isaunion{$what}) {
841 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
843 $template{$sname} .= 'x' x $pad . ' ' if $pad;
847 $template = &fetch_template($type);
848 &repeat_template($template,$count);
850 if (! $finished_template{$sname}) {
851 $template{$sname} .= $template;
854 $revpad = $length/8 if $isaunion{$what};
856 ($lastoffset, $lastlength) = ($offset, $length);
859 print '# ' if $perl && $verbose;
860 $entry = sprintf($pmask1,
861 ' ' x ($nesting * $indent) . $fieldtype,
862 "$prefix.$fieldname" . $count);
864 $entry =~ s/(\*+)( )/$2$1/;
869 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
871 ($bits = $length % 8) ? ".$bits": ""
872 if !$perl || $verbose;
875 $template = &fetch_template($type);
876 &repeat_template($template,$count);
879 if ($perl && $nesting == 1) {
881 push(@sizeof, int($length/8) .",\t# $fieldname");
882 push(@offsetof, int($offset/8) .",\t# $fieldname");
883 local($little) = &scrunch($template);
884 push(@typedef, "'$little', \t# $fieldname");
885 $type =~ s/(struct|union) //;
886 push(@typeof, "'$mytype" . ($count ? $count : '') .
888 push(@fieldnames, "'$fieldname',");
891 print ' ', ' ' x $indent x $nesting, $template
892 if $perl && $verbose;
894 print "\n" if !$perl || $verbose;
898 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
899 $mycount *= &scripts2count($count) if $count;
900 if ($nesting==1 && !$build_templates) {
901 $pcode .= sprintf("sub %-32s { %4d; }\n",
902 "${mname}'${fieldname}", $struct_count);
903 push(@indices, $struct_count);
905 $struct_count += $mycount;
909 &pstruct($type, "$prefix.$fieldname", $base+$offset)
910 if $recurse && defined $struct{$type};
913 $countof{$what} = $struct_count unless defined $countof{$whati};
915 $template{$sname} .= '$' if $build_templates;
916 $finished_template{$sname}++;
918 if ($build_templates && !defined $sizeof{$name}) {
919 local($fmt) = &scrunch($template{$sname});
920 print STDERR "no size for $name, punting with $fmt..." if $debug;
921 eval '$sizeof{$name} = length(pack($fmt, ()))';
924 warn "couldn't get size for \$name: $@";
926 print STDERR $sizeof{$name}, "\n" if $debUg;
936 local($amstruct) = $struct{$me} ? 'struct ' : '';
938 print '$sizeof{\'', $amstruct, $me, '\'} = ';
939 printf "%d;\n", $sizeof{$me};
947 warn "pdecl: $pdecl\n" if $debug;
949 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
951 @pdecls = split(/=/, $pdecl);
952 $typeno = $pdecls[0];
953 $tname = pop @pdecls;
955 if ($tname =~ s/^f//) { $tname = "$tname&"; }
956 #else { $tname = "$tname*"; }
958 for (reverse @pdecls) {
959 $tname .= s/^f// ? "&" : "*";
960 #$tname =~ s/^f(.*)/$1&/;
961 print "type[$_] is $tname\n" if $debug;
962 $type[$_] = $tname unless defined $type[$_];
969 ($arraytype, $unknown, $lower, $upper) = ();
971 # global $typeno, @type
972 local($_, $typedef) = @_;
974 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
975 ($arraytype, $unknown) = ($2, $3);
976 $arraytype = &typeno($arraytype);
977 $unknown = &typeno($unknown);
978 if (s/^(\d+);(\d+);//) {
979 ($lower, $upper) = ($1, $2);
980 $scripts .= '[' . ($upper+1) . ']';
982 warn "can't find array bounds: $_";
985 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
986 ($start, $length) = ($2, $3);
988 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
989 $typeno = &typeno($1);
992 $typeno = &typeno($whatis);
994 } elsif (s/^(\d+)(=[*suf]\d*)//) {
997 if ($whatis =~ /[f*]/) {
999 } elsif ($whatis =~ /[su]/) { #
1000 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
1002 #$type[$typeno] = $name unless defined $type[$typeno];
1003 ##printf "new type $typeno is $name" if $debug;
1005 $type[$typeno] = "$prefix.$fieldname";
1006 local($name) = $type[$typeno];
1007 &sou($name, $whatis);
1008 $_ = &sdecl($name, $_, $start+$offset);
1010 $start = $start{$name};
1011 $offset = $sizeof{$name};
1014 warn "what's this? $whatis in $line ";
1019 warn "bad array stab: $_ in $line ";
1022 #local($wasdef) = defined($type[$typeno]) && $debug;
1024 #print "redefining $type[$typeno] to " if $wasdef;
1025 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1026 #print "$type[$typeno]\n" if $wasdef;
1028 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1030 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1031 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1032 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1039 local($prefix, $_, $offset) = @_;
1041 local($fieldname, $scripts, $type, $arraytype, $unknown,
1042 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1043 local($typeno,$sou);
1047 while (/^([^;]+);/) {
1049 warn "sdecl $_\n" if $debug;
1050 if (s/^([\$\w]+)://) {
1052 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
1053 $typeno = &typeno($1);
1054 $type[$typeno] = "$prefix.$fieldname";
1055 local($name) = "$prefix.$fieldname";
1057 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1058 $start = $start{$name};
1059 $offset += $sizeof{$name};
1060 #print "done with anon, start is $start, offset is $offset\n";
1063 warn "weird field $_ of $line" if $debug;
1065 #$fieldname = &gensym;
1066 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1069 if (/^(\d+|\(\d+,\d+\))=ar/) {
1072 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
1073 ($start, $length) = ($2, $3);
1074 &panic("no length?") unless $length;
1075 $typeno = &typeno($1) if $1;
1077 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
1078 ($start, $length) = ($2, $3);
1079 &panic("no length?") unless $length;
1080 $typeno = &typeno($1) if $1;
1082 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
1083 ($pdecl, $start, $length) = ($1,$5,$6);
1086 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1087 ($typeno, $sou) = ($1, $2);
1088 $typeno = &typeno($typeno);
1089 if (defined($type[$typeno])) {
1090 warn "now how did we get type $1 in $fieldname of $line?";
1092 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1093 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1095 local($name) = "$prefix.$fieldname";
1097 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1098 $type[$typeno] = "$prefix.$fieldname";
1099 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1100 $start = $start{$name};
1101 $length = $sizeof{$name};
1104 warn "can't grok stab for $name ($_) in line $line ";
1108 &panic("no length for $prefix.$fieldname") unless $length;
1109 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1111 if (s/;\d*,(\d+),(\d+);//) {
1112 local($start, $size) = ($1, $2);
1113 $sizeof{$prefix} = $size;
1114 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1115 $start{$prefix} = $start;
1128 for $i (0 .. $#type) {
1129 next unless defined $type[$i];
1132 print "type[$i] $type[$i]\n" if $debug;
1135 print "type[$i] $_ ==> " if $debug;
1136 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
1137 s/^(\d+)\&/&type($1)/e;
1138 s/^(\d+)/&type($1)/e;
1139 s/(\*+)([^*]+)(\*+)/$1$3$2/;
1140 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1141 s/^(\d+)([\*\[].*)/&type($1).$2/e;
1142 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1144 print "$_\n" if $debug;
1147 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
1149 sub adjust_start_addrs {
1150 for (sort keys %start) {
1151 ($basename = $_) =~ s/\.[^.]+$//;
1152 $start{$_} += $start{$basename};
1153 print "start: $_ @ $start{$_}\n" if $debug;
1158 local($what, $_) = @_;
1159 /u/ && $isaunion{$what}++;
1160 /s/ && $isastruct{$what}++;
1165 local($prefix) = '';
1166 if ($isaunion{$what}) {
1168 } elsif ($isastruct{$what}) {
1169 $prefix = 'struct ';
1177 return '' if $_ eq '';
1183 1 while s/(\w) \1/$1$1/g;
1185 # i wanna say this, but perl resists my efforts:
1186 # s/(\w)(\1+)/$2 . length($1)/ge;
1195 sub buildscrunchlist {
1196 $scrunch_code = "sub quick_scrunch {\n";
1197 for (values %intrinsics) {
1198 $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
1200 $scrunch_code .= "}\n";
1201 print "$scrunch_code" if $debug;
1203 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1206 sub fetch_template {
1207 local($mytype) = @_;
1211 &panic("why do you care?") unless $perl;
1213 if ($mytype =~ s/(\[\d+\])+$//) {
1217 if ($mytype =~ /\*/) {
1218 $fmt = $template{'pointer'};
1220 elsif (defined $template{$mytype}) {
1221 $fmt = $template{$mytype};
1223 elsif (defined $struct{$mytype}) {
1224 if (!defined $template{&psou($mytype)}) {
1225 &build_template($mytype) unless $mytype eq $name;
1227 elsif ($template{&psou($mytype)} !~ /\$$/) {
1228 #warn "incomplete template for $mytype\n";
1230 $fmt = $template{&psou($mytype)} || '?';
1233 warn "unknown fmt for $mytype\n";
1237 $fmt x $count . ' ';
1240 sub compute_intrinsics {
1241 local($TMP) = "/tmp/c2ph-i.$$.c";
1242 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1245 print STDERR "computing intrinsic sizes: " if $trace;
1251 char *mask = "%d %s\n";
1254 for $type (@intrinsics) {
1255 next if !type || $type eq 'void' || $type =~ /complex/; # sun stuff
1257 printf(mask,sizeof($type), "$type");
1262 printf(mask,sizeof(char *), "pointer");
1269 open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
1273 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1274 $sizeof{$_[1]} = $_[0];
1275 $intrinsics{$_[1]} = $template{$_[0]};
1277 close(PIPE) || die "couldn't read intrinsics!";
1278 unlink($TMP, '/tmp/a.out');
1279 print STDERR "done\n" if $trace;
1289 &panic("$_: $@") if $@;
1294 print STDERR "@_\n" if $trace;
1298 sub build_template {
1301 &panic("already got a template for $name") if defined $template{$name};
1303 local($build_templates) = 1;
1305 local($lparen) = '(' x $build_recursed;
1306 local($rparen) = ')' x $build_recursed;
1308 print STDERR "$lparen$name$rparen " if $trace;
1310 &pstruct($name,$name,0);
1311 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1320 print "\npanic: @_\n";
1322 exit 1 if $] <= 4.003; # caller broken
1325 local($p,$f,$l,$s,$h,$a,@a,@sub);
1326 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1329 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1330 $_ = sprintf("%s",$_);
1334 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1335 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1336 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1339 $w = $w ? '@ = ' : '$ = ';
1340 $a = $h ? '(' . join(', ', @a) . ')' : '';
1341 push(@sub, "$w&$s$a from file $f line $l\n");
1344 for ($i=0; $i <= $#sub; $i++) {
1353 local($last) = -1e8;
1357 while (defined($num = shift)) {
1358 if ($num == ($last + 1)) {
1359 $string .= $seq unless $inseq++;
1363 $string .= $last unless $last == -1e8;
1366 $string .= ',' if defined $string;
1371 $string .= $last if $inseq && $last != -e18;
1375 sub repeat_template {
1376 # local($template, $scripts) = @_; have to change caller's values
1379 local($ncount) = &scripts2count($_[1]);
1380 if ($_[0] =~ /^\s*c\s*$/i) {
1381 $_[0] = "A$ncount ";
1384 $_[0] = $template x $ncount;
1390 close OUT or die "Can't close $file: $!";
1391 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1393 print "Linking c2ph to pstruct.\n";
1394 if (defined $Config{d_link}) {
1395 link 'c2ph', 'pstruct';
1397 unshift @INC, '../lib';
1399 File::Copy::syscopy('c2ph', 'pstruct');
1401 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';