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, '.PL');
17 $file .= '.com' if $^O eq 'VMS';
19 open OUT,">$file" or die "Can't create $file: $!";
21 print "Extracting $file (with variable substitutions)\n";
23 # In this section, perl variables will be expanded during extraction.
24 # You can use $Config{...} to use Configure variables.
26 print OUT <<"!GROK!THIS!";
28 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
29 if \$running_under_some_shell;
32 # In the following, perl variables are not expanded during extraction.
34 print OUT <<'!NO!SUBS!';
38 # Tom Christiansen, <tchrist@convex.com>
40 # As pstruct, dump C structures as generated from 'cc -g -S' stabs.
41 # As c2ph, do this PLUS generate perl code for getting at the structures.
43 # See the usage message for more. If this isn't enough, read the code.
48 c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
52 c2ph [-dpnP] [var=val] [files ...]
58 -w wide; short for: type_width=45 member_width=35 offset_width=8
59 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
61 -n do not generate perl code (default when invoked as pstruct)
62 -p generate perl code (default when invoked as c2ph)
63 -v generate perl code, with C decls as comments
65 -i do NOT recompute sizes for intrinsic datatypes
66 -a dump information on intrinsics also
69 -d spew reams of debugging output
71 -slist give comma-separated list a structures to dump
75 The following is the old c2ph.doc documentation by Tom Christiansen
77 Date: 25 Jul 91 08:10:21 GMT
79 Once upon a time, I wrote a program called pstruct. It was a perl
80 program that tried to parse out C structures and display their member
81 offsets for you. This was especially useful for people looking at
82 binary dumps or poking around the kernel.
84 Pstruct was not a pretty program. Neither was it particularly robust.
85 The problem, you see, was that the C compiler was much better at parsing
86 C than I could ever hope to be.
88 So I got smart: I decided to be lazy and let the C compiler parse the C,
89 which would spit out debugger stabs for me to read. These were much
90 easier to parse. It's still not a pretty program, but at least it's more
93 Pstruct takes any .c or .h files, or preferably .s ones, since that's
94 the format it is going to massage them into anyway, and spits out
98 int tty.t_locker 000 4
99 int tty.t_mutex_index 004 4
100 struct tty * tty.t_tp_virt 008 4
101 struct clist tty.t_rawq 00c 20
102 int tty.t_rawq.c_cc 00c 4
103 int tty.t_rawq.c_cmax 010 4
104 int tty.t_rawq.c_cfx 014 4
105 int tty.t_rawq.c_clx 018 4
106 struct tty * tty.t_rawq.c_tp_cpu 01c 4
107 struct tty * tty.t_rawq.c_tp_iop 020 4
108 unsigned char * tty.t_rawq.c_buf_cpu 024 4
109 unsigned char * tty.t_rawq.c_buf_iop 028 4
110 struct clist tty.t_canq 02c 20
111 int tty.t_canq.c_cc 02c 4
112 int tty.t_canq.c_cmax 030 4
113 int tty.t_canq.c_cfx 034 4
114 int tty.t_canq.c_clx 038 4
115 struct tty * tty.t_canq.c_tp_cpu 03c 4
116 struct tty * tty.t_canq.c_tp_iop 040 4
117 unsigned char * tty.t_canq.c_buf_cpu 044 4
118 unsigned char * tty.t_canq.c_buf_iop 048 4
119 struct clist tty.t_outq 04c 20
120 int tty.t_outq.c_cc 04c 4
121 int tty.t_outq.c_cmax 050 4
122 int tty.t_outq.c_cfx 054 4
123 int tty.t_outq.c_clx 058 4
124 struct tty * tty.t_outq.c_tp_cpu 05c 4
125 struct tty * tty.t_outq.c_tp_iop 060 4
126 unsigned char * tty.t_outq.c_buf_cpu 064 4
127 unsigned char * tty.t_outq.c_buf_iop 068 4
128 (*int)() tty.t_oproc_cpu 06c 4
129 (*int)() tty.t_oproc_iop 070 4
130 (*int)() tty.t_stopproc_cpu 074 4
131 (*int)() tty.t_stopproc_iop 078 4
132 struct thread * tty.t_rsel 07c 4
137 Actually, this was generated by a particular set of options. You can control
138 the formatting of each column, whether you prefer wide or fat, hex or decimal,
139 leading zeroes or whatever.
141 All you need to be able to use this is a C compiler than generates
142 BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
143 should get this for you.
145 To learn more, just type a bogus option, like B<-\?>, and a long usage message
146 will be provided. There are a fair number of possibilities.
148 If you're only a C programmer, than this is the end of the message for you.
149 You can quit right now, and if you care to, save off the source and run it
150 when you feel like it. Or not.
154 But if you're a perl programmer, then for you I have something much more
155 wondrous than just a structure offset printer.
157 You see, if you call pstruct by its other incybernation, c2ph, you have a code
158 generator that translates C code into perl code! Well, structure and union
159 declarations at least, but that's quite a bit.
161 Prior to this point, anyone programming in perl who wanted to interact
162 with C programs, like the kernel, was forced to guess the layouts of
163 the C strutures, and then hardwire these into his program. Of course,
164 when you took your wonderfully crafted program to a system where the
165 sgtty structure was laid out differently, you program broke. Which is
168 We've had Larry's h2ph translator, which helped, but that only works on
169 cpp symbols, not real C, which was also very much needed. What I offer
170 you is a symbolic way of getting at all the C structures. I've couched
171 them in terms of packages and functions. Consider the following program:
173 #!/usr/local/bin/perl
175 require 'syscall.ph';
176 require 'sys/time.ph';
177 require 'sys/resource.ph';
179 $ru = "\0" x &rusage'sizeof();
181 syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
183 @ru = unpack($t = &rusage'typedef(), $ru);
185 $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
186 + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
188 $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
189 + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
191 printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
194 As you see, the name of the package is the name of the structure. Regular
195 fields are just their own names. Plus the following accessor functions are
196 provided for your convenience:
198 struct This takes no arguments, and is merely the number of first-level
199 elements in the structure. You would use this for indexing
200 into arrays of structures, perhaps like this
203 $usec = $u[ &user'u_utimer
204 + (&ITIMER_VIRTUAL * &itimerval'struct)
205 + &itimerval'it_value
209 sizeof Returns the bytes in the structure, or the member if
210 you pass it an argument, such as
212 &rusage'sizeof(&rusage'ru_utime)
214 typedef This is the perl format definition for passing to pack and
215 unpack. If you ask for the typedef of a nothing, you get
216 the whole structure, otherwise you get that of the member
217 you ask for. Padding is taken care of, as is the magic to
218 guarantee that a union is unpacked into all its aliases.
219 Bitfields are not quite yet supported however.
221 offsetof This function is the byte offset into the array of that
222 member. You may wish to use this for indexing directly
223 into the packed structure with vec() if you're too lazy
226 typeof Not to be confused with the typedef accessor function, this
227 one returns the C type of that field. This would allow
228 you to print out a nice structured pretty print of some
229 structure without knoning anything about it beforehand.
230 No args to this one is a noop. Someday I'll post such
231 a thing to dump out your u structure for you.
234 The way I see this being used is like basically this:
236 % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
237 % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
240 It's a little tricker with c2ph because you have to get the includes right.
241 I can't know this for your system, but it's not usually too terribly difficult.
243 The code isn't pretty as I mentioned -- I never thought it would be a 1000-
244 line program when I started, or I might not have begun. :-) But I would have
245 been less cavalier in how the parts of the program communicated with each
246 other, etc. It might also have helped if I didn't have to divine the makeup
247 of the stabs on the fly, and then account for micro differences between my
250 Anyway, here it is. Should run on perl v4 or greater. Maybe less.
257 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
260 ######################################################################
262 # some handy data definitions. many of these can be reset later.
264 $bitorder = 'b'; # ascending; set to B for descending bit fields
269 'unsigned char', 'C',
272 'unsigned short', 'S',
273 'unsigned short int', 'S',
274 'short unsigned int', 'S',
279 'unsigned long', 'L',
280 'unsigned long', 'L',
281 'long unsigned int', 'L',
282 'unsigned long int', 'L',
284 'long long int', 'q',
285 'unsigned long long', 'Q',
286 'unsigned long long int', 'Q',
296 delete $intrinsics{'neganull'};
297 delete $intrinsics{'bit'};
298 delete $intrinsics{'null'};
300 # use -s to recompute sizes
303 'unsigned char', '1',
306 'unsigned short', '2',
307 'unsigned short int', '2',
308 'short unsigned int', '2',
313 'unsigned long', '4',
314 'unsigned long int', '4',
315 'long unsigned int', '4',
317 'long long int', '8',
318 'unsigned long long', '8',
319 'unsigned long long int', '8',
325 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
327 ($offset_fmt, $size_fmt) = ('d', 'd');
335 $perl++ if $0 =~ m#/?c2ph$#;
337 require 'getopts.pl';
339 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
341 &Getopts('aixdpvtnws:') || &usage(0);
346 $opt_v && $verbose++;
347 $opt_n && ($perl = 0);
350 ($type_width, $member_width, $offset_width) = (45, 35, 8);
353 ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
356 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
360 print "oops, apperent pager foulup\n";
372 print "hit <RETURN> for further explanation: ";
374 open (PIPE, "|". ($ENV{PAGER} || 'more'));
375 $SIG{PIPE} = PLUMBER;
379 print "usage: $0 [-dpnP] [var=val] [files ...]\n";
387 -w wide; short for: type_width=45 member_width=35 offset_width=8
388 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
390 -n do not generate perl code (default when invoked as pstruct)
391 -p generate perl code (default when invoked as c2ph)
392 -v generate perl code, with C decls as comments
394 -i do NOT recompute sizes for intrinsic datatypes
395 -a dump information on intrinsics also
398 -d spew reams of debugging output
400 -slist give comma-separated list a structures to dump
403 Var Name Default Value Meaning
407 &defvar('CC', 'which_compiler to call');
408 &defvar('CFLAGS', 'how to generate *.s files with stabs');
409 &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
413 &defvar('type_width', 'width of type field (column 1)');
414 &defvar('member_width', 'width of member field (column 2)');
415 &defvar('offset_width', 'width of offset field (column 3)');
416 &defvar('size_width', 'width of size field (column 4)');
420 &defvar('offset_fmt', 'sprintf format type for offset');
421 &defvar('size_fmt', 'sprintf format type for size');
425 &defvar('indent', 'how far to indent each nesting level');
429 If any *.[ch] files are given, these will be catted together into
430 a temporary *.c file and sent through:
432 and the resulting *.s groped for stab information. If no files are
433 supplied, then stdin is read directly with the assumption that it
434 contains stab information. All other liens will be ignored. At
435 most one *.s file should be supplied.
443 local($var, $msg) = @_;
444 printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
450 if (grep(!/\.[csh]$/,@ARGV)) {
451 warn "Only *.[csh] files expected!\n";
454 elsif (grep(/\.s$/,@ARGV)) {
456 warn "Only one *.s file allowed!\n";
460 elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
461 local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
462 $chdir = "cd $dir; " if $dir;
463 &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
464 $ARGV[0] =~ s/\.c$/.s/;
467 $TMP = "/tmp/c2ph.$$.c";
468 &system("cat @ARGV > $TMP") && exit 1;
469 &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
477 for (split(/[\s,]+/, $opt_s)) {
489 print STDERR "reading from your keyboard: ";
491 print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
496 if ($trace && !($. % 10)) {
498 print STDERR $lineno, "\b" x length($lineno);
500 next unless /^\s*\.stabs\s+/;
503 if (s/\\\\"[d,]+$//) {
514 $savebar = $saveline = undef;
516 print STDERR "$.\n" if $trace;
519 &compute_intrinsics if $perl && !$opt_i;
521 print STDERR "resolving types\n" if $trace;
526 $sum = 2 + $type_width + $member_width;
527 $pmask1 = "%-${type_width}s %-${member_width}s";
528 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
533 # resolve template -- should be in stab define order, but even this isn't enough.
534 print STDERR "\nbuilding type templates: " if $trace;
535 for $i (reverse 0..$#type) {
536 next unless defined($name = $type[$i]);
537 next unless defined $struct{$name};
538 ($iname = $name) =~ s/\..*//;
540 &build_template($name) unless defined $template{&psou($name)} ||
541 $opt_s && !$interested{$iname};
543 print STDERR "\n\n" if $trace;
546 print STDERR "dumping structs: " if $trace;
552 foreach $name (sort keys %struct) {
553 ($iname = $name) =~ s/\..*//;
554 next if $opt_s && !$interested{$iname};
555 print STDERR "$name " if $trace;
564 $mname = &munge($name);
566 $fname = &psou($name);
568 print "# " if $perl && $verbose;
570 print "$fname {\n" if !$perl || $verbose;
571 $template{$fname} = &scrunch($template{$fname}) if $perl;
572 &pstruct($name,$name,0);
573 print "# " if $perl && $verbose;
574 print "}\n" if !$perl || $verbose;
575 print "\n" if $perl && $verbose;
580 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
583 sub ${mname}'typedef {
584 local(\$${mname}'index) = shift;
585 defined \$${mname}'index
586 ? \$${mname}'typedef[\$${mname}'index]
587 : \$${mname}'typedef;
592 sub ${mname}'sizeof {
593 local(\$${mname}'index) = shift;
594 defined \$${mname}'index
595 ? \$${mname}'sizeof[\$${mname}'index]
601 sub ${mname}'offsetof {
602 local(\$${mname}'index) = shift;
603 defined \$${mname}index
604 ? \$${mname}'offsetof[\$${mname}'index]
610 sub ${mname}'typeof {
611 local(\$${mname}'index) = shift;
612 defined \$${mname}index
613 ? \$${mname}'typeof[\$${mname}'index]
619 sub ${mname}'fieldnames {
620 \@${mname}'fieldnames;
624 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
627 sub ${mname}'isastruct {
632 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
635 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
638 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
642 print "\@${mname}'typedef[\@${mname}'indices] = (",
643 join("\n\t", '', @typedef), "\n );\n\n";
644 print "\@${mname}'sizeof[\@${mname}'indices] = (",
645 join("\n\t", '', @sizeof), "\n );\n\n";
646 print "\@${mname}'offsetof[\@${mname}'indices] = (",
647 join("\n\t", '', @offsetof), "\n );\n\n";
648 print "\@${mname}'typeof[\@${mname}'indices] = (",
649 join("\n\t", '', @typeof), "\n );\n\n";
650 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
651 join("\n\t", '', @fieldnames), "\n );\n\n";
653 $template_printed{$fname}++;
654 $size_printed{$fname}++;
659 print STDERR "\n" if $trace;
661 unless ($perl && $opt_a) {
662 print "\n1;\n" if $perl;
668 foreach $name (sort bysizevalue keys %intrinsics) {
669 next if $size_printed{$name};
670 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
675 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
678 foreach $name (sort keys %intrinsics) {
679 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
682 print "\n1;\n" if $perl;
687 ########################################################################################
691 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
693 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
698 $_ = $continued . $_ if length($continued);
700 # if last 2 chars of string are '\\' then stab is continued
711 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
712 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
719 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
721 push(@intrinsics, $ident);
722 $typeno = &typeno($3);
723 $type[$typeno] = $ident;
724 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
728 if (($name, $typeordef, $typeno, $extra, $struct, $_)
729 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
731 $typeno = &typeno($typeno); # sun foolery
733 elsif (/^[\$\w]+:/) {
737 warn "can't grok stab: <$_> in: $line " if $_;
741 #warn "got size $size for $name\n";
742 $sizeof{$name} = $size if $size;
744 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
746 $typenos{$name} = $typeno;
748 unless (defined $type[$typeno]) {
749 &panic("type 0??") unless $typeno;
750 $type[$typeno] = $name unless defined $type[$typeno];
751 printf "new type $typeno is $name" if $debug;
752 if ($extra =~ /\*/ && defined $type[$struct]) {
753 print ", a typedef for a pointer to " , $type[$struct] if $debug;
756 printf "%s is type %d", $name, $typeno if $debug;
757 print ", a typedef for " , $type[$typeno] if $debug;
759 print "\n" if $debug;
760 #next unless $extra =~ /[su*]/;
762 #$type[$struct] = $name;
764 if ($extra =~ /[us*]/) {
766 $_ = &sdecl($name, $_, 0);
769 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
775 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
776 push(@intrinsics, $2);
777 $typeno = &typeno($3);
779 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
781 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
785 warn "Funny remainder for $name on line $_ left in $line " if $_;
789 sub typeno { # sun thinks types are (0,27) instead of just 27
796 local($what,$prefix,$base) = @_;
797 local($field, $fieldname, $typeno, $count, $offset, $entry);
799 local($type, $tname);
800 local($mytype, $mycount, $entry2);
801 local($struct_count) = 0;
802 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
807 local($mname) = &munge($name);
815 local($sname) = &psou($what);
819 for $field (split(/;/, $struct{$what})) {
822 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
824 $type = $type[$typeno];
826 $type =~ /([^[]*)(\[.*\])?/;
829 $fieldtype = &psou($mytype);
831 local($fname) = &psou($name);
833 if ($build_templates) {
835 $pad = ($offset - ($lastoffset + $lastlength))/8
836 if defined $lastoffset;
838 if (! $finished_template{$sname}) {
839 if ($isaunion{$what}) {
840 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
842 $template{$sname} .= 'x' x $pad . ' ' if $pad;
846 $template = &fetch_template($type);
847 &repeat_template($template,$count);
849 if (! $finished_template{$sname}) {
850 $template{$sname} .= $template;
853 $revpad = $length/8 if $isaunion{$what};
855 ($lastoffset, $lastlength) = ($offset, $length);
858 print '# ' if $perl && $verbose;
859 $entry = sprintf($pmask1,
860 ' ' x ($nesting * $indent) . $fieldtype,
861 "$prefix.$fieldname" . $count);
863 $entry =~ s/(\*+)( )/$2$1/;
868 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
870 ($bits = $length % 8) ? ".$bits": ""
871 if !$perl || $verbose;
874 $template = &fetch_template($type);
875 &repeat_template($template,$count);
878 if ($perl && $nesting == 1) {
880 push(@sizeof, int($length/8) .",\t# $fieldname");
881 push(@offsetof, int($offset/8) .",\t# $fieldname");
882 local($little) = &scrunch($template);
883 push(@typedef, "'$little', \t# $fieldname");
884 $type =~ s/(struct|union) //;
885 push(@typeof, "'$mytype" . ($count ? $count : '') .
887 push(@fieldnames, "'$fieldname',");
890 print ' ', ' ' x $indent x $nesting, $template
891 if $perl && $verbose;
893 print "\n" if !$perl || $verbose;
897 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
898 $mycount *= &scripts2count($count) if $count;
899 if ($nesting==1 && !$build_templates) {
900 $pcode .= sprintf("sub %-32s { %4d; }\n",
901 "${mname}'${fieldname}", $struct_count);
902 push(@indices, $struct_count);
904 $struct_count += $mycount;
908 &pstruct($type, "$prefix.$fieldname", $base+$offset)
909 if $recurse && defined $struct{$type};
912 $countof{$what} = $struct_count unless defined $countof{$whati};
914 $template{$sname} .= '$' if $build_templates;
915 $finished_template{$sname}++;
917 if ($build_templates && !defined $sizeof{$name}) {
918 local($fmt) = &scrunch($template{$sname});
919 print STDERR "no size for $name, punting with $fmt..." if $debug;
920 eval '$sizeof{$name} = length(pack($fmt, ()))';
923 warn "couldn't get size for \$name: $@";
925 print STDERR $sizeof{$name}, "\n" if $debUg;
935 local($amstruct) = $struct{$me} ? 'struct ' : '';
937 print '$sizeof{\'', $amstruct, $me, '\'} = ';
938 printf "%d;\n", $sizeof{$me};
946 warn "pdecl: $pdecl\n" if $debug;
948 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
950 @pdecls = split(/=/, $pdecl);
951 $typeno = $pdecls[0];
952 $tname = pop @pdecls;
954 if ($tname =~ s/^f//) { $tname = "$tname&"; }
955 #else { $tname = "$tname*"; }
957 for (reverse @pdecls) {
958 $tname .= s/^f// ? "&" : "*";
959 #$tname =~ s/^f(.*)/$1&/;
960 print "type[$_] is $tname\n" if $debug;
961 $type[$_] = $tname unless defined $type[$_];
968 ($arraytype, $unknown, $lower, $upper) = ();
970 # global $typeno, @type
971 local($_, $typedef) = @_;
973 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
974 ($arraytype, $unknown) = ($2, $3);
975 $arraytype = &typeno($arraytype);
976 $unknown = &typeno($unknown);
977 if (s/^(\d+);(\d+);//) {
978 ($lower, $upper) = ($1, $2);
979 $scripts .= '[' . ($upper+1) . ']';
981 warn "can't find array bounds: $_";
984 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
985 ($start, $length) = ($2, $3);
987 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
988 $typeno = &typeno($1);
991 $typeno = &typeno($whatis);
993 } elsif (s/^(\d+)(=[*suf]\d*)//) {
996 if ($whatis =~ /[f*]/) {
998 } elsif ($whatis =~ /[su]/) { #
999 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
1001 #$type[$typeno] = $name unless defined $type[$typeno];
1002 ##printf "new type $typeno is $name" if $debug;
1004 $type[$typeno] = "$prefix.$fieldname";
1005 local($name) = $type[$typeno];
1006 &sou($name, $whatis);
1007 $_ = &sdecl($name, $_, $start+$offset);
1009 $start = $start{$name};
1010 $offset = $sizeof{$name};
1013 warn "what's this? $whatis in $line ";
1018 warn "bad array stab: $_ in $line ";
1021 #local($wasdef) = defined($type[$typeno]) && $debug;
1023 #print "redefining $type[$typeno] to " if $wasdef;
1024 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1025 #print "$type[$typeno]\n" if $wasdef;
1027 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1029 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1030 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1031 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1038 local($prefix, $_, $offset) = @_;
1040 local($fieldname, $scripts, $type, $arraytype, $unknown,
1041 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1042 local($typeno,$sou);
1046 while (/^([^;]+);/) {
1048 warn "sdecl $_\n" if $debug;
1049 if (s/^([\$\w]+)://) {
1051 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
1052 $typeno = &typeno($1);
1053 $type[$typeno] = "$prefix.$fieldname";
1054 local($name) = "$prefix.$fieldname";
1056 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1057 $start = $start{$name};
1058 $offset += $sizeof{$name};
1059 #print "done with anon, start is $start, offset is $offset\n";
1062 warn "weird field $_ of $line" if $debug;
1064 #$fieldname = &gensym;
1065 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1068 if (/^(\d+|\(\d+,\d+\))=ar/) {
1071 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
1072 ($start, $length) = ($2, $3);
1073 &panic("no length?") unless $length;
1074 $typeno = &typeno($1) if $1;
1076 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
1077 ($start, $length) = ($2, $3);
1078 &panic("no length?") unless $length;
1079 $typeno = &typeno($1) if $1;
1081 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
1082 ($pdecl, $start, $length) = ($1,$5,$6);
1085 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1086 ($typeno, $sou) = ($1, $2);
1087 $typeno = &typeno($typeno);
1088 if (defined($type[$typeno])) {
1089 warn "now how did we get type $1 in $fieldname of $line?";
1091 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1092 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1094 local($name) = "$prefix.$fieldname";
1096 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1097 $type[$typeno] = "$prefix.$fieldname";
1098 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1099 $start = $start{$name};
1100 $length = $sizeof{$name};
1103 warn "can't grok stab for $name ($_) in line $line ";
1107 &panic("no length for $prefix.$fieldname") unless $length;
1108 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1110 if (s/;\d*,(\d+),(\d+);//) {
1111 local($start, $size) = ($1, $2);
1112 $sizeof{$prefix} = $size;
1113 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1114 $start{$prefix} = $start;
1127 for $i (0 .. $#type) {
1128 next unless defined $type[$i];
1131 print "type[$i] $type[$i]\n" if $debug;
1134 print "type[$i] $_ ==> " if $debug;
1135 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
1136 s/^(\d+)\&/&type($1)/e;
1137 s/^(\d+)/&type($1)/e;
1138 s/(\*+)([^*]+)(\*+)/$1$3$2/;
1139 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1140 s/^(\d+)([\*\[].*)/&type($1).$2/e;
1141 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1143 print "$_\n" if $debug;
1146 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
1148 sub adjust_start_addrs {
1149 for (sort keys %start) {
1150 ($basename = $_) =~ s/\.[^.]+$//;
1151 $start{$_} += $start{$basename};
1152 print "start: $_ @ $start{$_}\n" if $debug;
1157 local($what, $_) = @_;
1158 /u/ && $isaunion{$what}++;
1159 /s/ && $isastruct{$what}++;
1164 local($prefix) = '';
1165 if ($isaunion{$what}) {
1167 } elsif ($isastruct{$what}) {
1168 $prefix = 'struct ';
1176 return '' if $_ eq '';
1182 1 while s/(\w) \1/$1$1/g;
1184 # i wanna say this, but perl resists my efforts:
1185 # s/(\w)(\1+)/$2 . length($1)/ge;
1194 sub buildscrunchlist {
1195 $scrunch_code = "sub quick_scrunch {\n";
1196 for (values %intrinsics) {
1197 $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
1199 $scrunch_code .= "}\n";
1200 print "$scrunch_code" if $debug;
1202 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1205 sub fetch_template {
1206 local($mytype) = @_;
1210 &panic("why do you care?") unless $perl;
1212 if ($mytype =~ s/(\[\d+\])+$//) {
1216 if ($mytype =~ /\*/) {
1217 $fmt = $template{'pointer'};
1219 elsif (defined $template{$mytype}) {
1220 $fmt = $template{$mytype};
1222 elsif (defined $struct{$mytype}) {
1223 if (!defined $template{&psou($mytype)}) {
1224 &build_template($mytype) unless $mytype eq $name;
1226 elsif ($template{&psou($mytype)} !~ /\$$/) {
1227 #warn "incomplete template for $mytype\n";
1229 $fmt = $template{&psou($mytype)} || '?';
1232 warn "unknown fmt for $mytype\n";
1236 $fmt x $count . ' ';
1239 sub compute_intrinsics {
1240 local($TMP) = "/tmp/c2ph-i.$$.c";
1241 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1244 print STDERR "computing intrinsic sizes: " if $trace;
1250 char *mask = "%d %s\n";
1253 for $type (@intrinsics) {
1254 next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
1256 printf(mask,sizeof($type), "$type");
1261 printf(mask,sizeof(char *), "pointer");
1268 open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
1272 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1273 $sizeof{$_[1]} = $_[0];
1274 $intrinsics{$_[1]} = $template{$_[0]};
1276 close(PIPE) || die "couldn't read intrinsics!";
1277 unlink($TMP, '/tmp/a.out');
1278 print STDERR "done\n" if $trace;
1288 &panic("$_: $@") if $@;
1293 print STDERR "@_\n" if $trace;
1297 sub build_template {
1300 &panic("already got a template for $name") if defined $template{$name};
1302 local($build_templates) = 1;
1304 local($lparen) = '(' x $build_recursed;
1305 local($rparen) = ')' x $build_recursed;
1307 print STDERR "$lparen$name$rparen " if $trace;
1309 &pstruct($name,$name,0);
1310 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1319 print "\npanic: @_\n";
1321 exit 1 if $] <= 4.003; # caller broken
1324 local($p,$f,$l,$s,$h,$a,@a,@sub);
1325 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1328 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1329 $_ = sprintf("%s",$_);
1333 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1334 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1335 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1338 $w = $w ? '@ = ' : '$ = ';
1339 $a = $h ? '(' . join(', ', @a) . ')' : '';
1340 push(@sub, "$w&$s$a from file $f line $l\n");
1343 for ($i=0; $i <= $#sub; $i++) {
1352 local($last) = -1e8;
1356 while (defined($num = shift)) {
1357 if ($num == ($last + 1)) {
1358 $string .= $seq unless $inseq++;
1362 $string .= $last unless $last == -1e8;
1365 $string .= ',' if defined $string;
1370 $string .= $last if $inseq && $last != -e18;
1374 sub repeat_template {
1375 # local($template, $scripts) = @_; have to change caller's values
1378 local($ncount) = &scripts2count($_[1]);
1379 if ($_[0] =~ /^\s*c\s*$/i) {
1380 $_[0] = "A$ncount ";
1383 $_[0] = $template x $ncount;
1389 close OUT or die "Can't close $file: $!";
1390 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1392 print "Linking c2ph to pstruct.\n";
1393 if (defined $Config{d_link}) {
1394 link 'c2ph', 'pstruct';
1396 unshift @INC, '../lib';
1398 File::Copy::syscopy('c2ph', 'pstruct');
1400 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';