4 use File::Basename qw(&basename &dirname);
8 sub link { # This is a cut-down version of installperl:link().
13 CORE::link($from, $to)
15 : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
16 ? die "AFS" # okay inside eval {}
17 : die "Couldn't link $from to $to: $!\n";
22 File::Copy::copy($from, $to)
24 : warn "Couldn't copy $from to $to: $!\n";
29 # List explicitly here the variables you want Configure to
30 # generate. Metaconfig only looks for shell variables, so you
31 # have to mention them as if they were shell variables, not
32 # %Config entries. Thus you write
34 # to ensure Configure will look for $Config{startperl}.
36 # This forces PL files to create target in same directory as PL file.
37 # This is so that make depend always knows where to find PL derivatives.
40 $file = basename($0, '.PL');
41 $file .= '.com' if $^O eq 'VMS';
43 open OUT,">$file" or die "Can't create $file: $!";
45 print "Extracting $file (with variable substitutions)\n";
47 # In this section, perl variables will be expanded during extraction.
48 # You can use $Config{...} to use Configure variables.
50 print OUT <<"!GROK!THIS!";
52 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
53 if \$running_under_some_shell;
56 # In the following, perl variables are not expanded during extraction.
58 print OUT <<'!NO!SUBS!';
62 # Tom Christiansen, <tchrist@convex.com>
64 # As pstruct, dump C structures as generated from 'cc -g -S' stabs.
65 # As c2ph, do this PLUS generate perl code for getting at the structures.
67 # See the usage message for more. If this isn't enough, read the code.
72 c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
76 c2ph [-dpnP] [var=val] [files ...]
82 -w wide; short for: type_width=45 member_width=35 offset_width=8
83 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
85 -n do not generate perl code (default when invoked as pstruct)
86 -p generate perl code (default when invoked as c2ph)
87 -v generate perl code, with C decls as comments
89 -i do NOT recompute sizes for intrinsic datatypes
90 -a dump information on intrinsics also
93 -d spew reams of debugging output
95 -slist give comma-separated list a structures to dump
99 The following is the old c2ph.doc documentation by Tom Christiansen
101 Date: 25 Jul 91 08:10:21 GMT
103 Once upon a time, I wrote a program called pstruct. It was a perl
104 program that tried to parse out C structures and display their member
105 offsets for you. This was especially useful for people looking at
106 binary dumps or poking around the kernel.
108 Pstruct was not a pretty program. Neither was it particularly robust.
109 The problem, you see, was that the C compiler was much better at parsing
110 C than I could ever hope to be.
112 So I got smart: I decided to be lazy and let the C compiler parse the C,
113 which would spit out debugger stabs for me to read. These were much
114 easier to parse. It's still not a pretty program, but at least it's more
117 Pstruct takes any .c or .h files, or preferably .s ones, since that's
118 the format it is going to massage them into anyway, and spits out
122 int tty.t_locker 000 4
123 int tty.t_mutex_index 004 4
124 struct tty * tty.t_tp_virt 008 4
125 struct clist tty.t_rawq 00c 20
126 int tty.t_rawq.c_cc 00c 4
127 int tty.t_rawq.c_cmax 010 4
128 int tty.t_rawq.c_cfx 014 4
129 int tty.t_rawq.c_clx 018 4
130 struct tty * tty.t_rawq.c_tp_cpu 01c 4
131 struct tty * tty.t_rawq.c_tp_iop 020 4
132 unsigned char * tty.t_rawq.c_buf_cpu 024 4
133 unsigned char * tty.t_rawq.c_buf_iop 028 4
134 struct clist tty.t_canq 02c 20
135 int tty.t_canq.c_cc 02c 4
136 int tty.t_canq.c_cmax 030 4
137 int tty.t_canq.c_cfx 034 4
138 int tty.t_canq.c_clx 038 4
139 struct tty * tty.t_canq.c_tp_cpu 03c 4
140 struct tty * tty.t_canq.c_tp_iop 040 4
141 unsigned char * tty.t_canq.c_buf_cpu 044 4
142 unsigned char * tty.t_canq.c_buf_iop 048 4
143 struct clist tty.t_outq 04c 20
144 int tty.t_outq.c_cc 04c 4
145 int tty.t_outq.c_cmax 050 4
146 int tty.t_outq.c_cfx 054 4
147 int tty.t_outq.c_clx 058 4
148 struct tty * tty.t_outq.c_tp_cpu 05c 4
149 struct tty * tty.t_outq.c_tp_iop 060 4
150 unsigned char * tty.t_outq.c_buf_cpu 064 4
151 unsigned char * tty.t_outq.c_buf_iop 068 4
152 (*int)() tty.t_oproc_cpu 06c 4
153 (*int)() tty.t_oproc_iop 070 4
154 (*int)() tty.t_stopproc_cpu 074 4
155 (*int)() tty.t_stopproc_iop 078 4
156 struct thread * tty.t_rsel 07c 4
161 Actually, this was generated by a particular set of options. You can control
162 the formatting of each column, whether you prefer wide or fat, hex or decimal,
163 leading zeroes or whatever.
165 All you need to be able to use this is a C compiler than generates
166 BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
167 should get this for you.
169 To learn more, just type a bogus option, like B<-\?>, and a long usage message
170 will be provided. There are a fair number of possibilities.
172 If you're only a C programmer, than this is the end of the message for you.
173 You can quit right now, and if you care to, save off the source and run it
174 when you feel like it. Or not.
178 But if you're a perl programmer, then for you I have something much more
179 wondrous than just a structure offset printer.
181 You see, if you call pstruct by its other incybernation, c2ph, you have a code
182 generator that translates C code into perl code! Well, structure and union
183 declarations at least, but that's quite a bit.
185 Prior to this point, anyone programming in perl who wanted to interact
186 with C programs, like the kernel, was forced to guess the layouts of
187 the C structures, and then hardwire these into his program. Of course,
188 when you took your wonderfully crafted program to a system where the
189 sgtty structure was laid out differently, your program broke. Which is
192 We've had Larry's h2ph translator, which helped, but that only works on
193 cpp symbols, not real C, which was also very much needed. What I offer
194 you is a symbolic way of getting at all the C structures. I've couched
195 them in terms of packages and functions. Consider the following program:
197 #!/usr/local/bin/perl
199 require 'syscall.ph';
200 require 'sys/time.ph';
201 require 'sys/resource.ph';
203 $ru = "\0" x &rusage'sizeof();
205 syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
207 @ru = unpack($t = &rusage'typedef(), $ru);
209 $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
210 + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
212 $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
213 + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
215 printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
218 As you see, the name of the package is the name of the structure. Regular
219 fields are just their own names. Plus the following accessor functions are
220 provided for your convenience:
222 struct This takes no arguments, and is merely the number of first-level
223 elements in the structure. You would use this for indexing
224 into arrays of structures, perhaps like this
227 $usec = $u[ &user'u_utimer
228 + (&ITIMER_VIRTUAL * &itimerval'struct)
229 + &itimerval'it_value
233 sizeof Returns the bytes in the structure, or the member if
234 you pass it an argument, such as
236 &rusage'sizeof(&rusage'ru_utime)
238 typedef This is the perl format definition for passing to pack and
239 unpack. If you ask for the typedef of a nothing, you get
240 the whole structure, otherwise you get that of the member
241 you ask for. Padding is taken care of, as is the magic to
242 guarantee that a union is unpacked into all its aliases.
243 Bitfields are not quite yet supported however.
245 offsetof This function is the byte offset into the array of that
246 member. You may wish to use this for indexing directly
247 into the packed structure with vec() if you're too lazy
250 typeof Not to be confused with the typedef accessor function, this
251 one returns the C type of that field. This would allow
252 you to print out a nice structured pretty print of some
253 structure without knoning anything about it beforehand.
254 No args to this one is a noop. Someday I'll post such
255 a thing to dump out your u structure for you.
258 The way I see this being used is like basically this:
260 % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
261 % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
264 It's a little tricker with c2ph because you have to get the includes right.
265 I can't know this for your system, but it's not usually too terribly difficult.
267 The code isn't pretty as I mentioned -- I never thought it would be a 1000-
268 line program when I started, or I might not have begun. :-) But I would have
269 been less cavalier in how the parts of the program communicated with each
270 other, etc. It might also have helped if I didn't have to divine the makeup
271 of the stabs on the fly, and then account for micro differences between my
274 Anyway, here it is. Should run on perl v4 or greater. Maybe less.
281 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
285 ######################################################################
287 # some handy data definitions. many of these can be reset later.
289 $bitorder = 'b'; # ascending; set to B for descending bit fields
294 'unsigned char', 'C',
297 'unsigned short', 'S',
298 'unsigned short int', 'S',
299 'short unsigned int', 'S',
304 'unsigned long', 'L',
305 'unsigned long', 'L',
306 'long unsigned int', 'L',
307 'unsigned long int', 'L',
309 'long long int', 'q',
310 'unsigned long long', 'Q',
311 'unsigned long long int', 'Q',
321 delete $intrinsics{'neganull'};
322 delete $intrinsics{'bit'};
323 delete $intrinsics{'null'};
325 # use -s to recompute sizes
328 'unsigned char', '1',
331 'unsigned short', '2',
332 'unsigned short int', '2',
333 'short unsigned int', '2',
338 'unsigned long', '4',
339 'unsigned long int', '4',
340 'long unsigned int', '4',
342 'long long int', '8',
343 'unsigned long long', '8',
344 'unsigned long long int', '8',
350 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
352 ($offset_fmt, $size_fmt) = ('d', 'd');
359 if (($Config{gccversion} || '') =~ /^(\d+)\.(\d+)/
360 and ($1 > 3 or ($1 == 3 and $2 >= 2))) {
361 print OUT q/$CFLAGS = '-gstabs -S';/;
363 print OUT q/$CFLAGS = '-g -S';/;
366 print OUT <<'!NO!SUBS!';
370 $perl++ if $0 =~ m#/?c2ph$#;
372 require 'getopts.pl';
374 use File::Temp 'tempdir';
376 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
378 &Getopts('aixdpvtnws:') || &usage(0);
383 $opt_v && $verbose++;
384 $opt_n && ($perl = 0);
387 ($type_width, $member_width, $offset_width) = (45, 35, 8);
390 ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
393 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
397 print "oops, apperent pager foulup\n";
409 print "hit <RETURN> for further explanation: ";
411 open (PIPE, "|". ($ENV{PAGER} || 'more'));
412 $SIG{PIPE} = PLUMBER;
416 print "usage: $0 [-dpnP] [var=val] [files ...]\n";
424 -w wide; short for: type_width=45 member_width=35 offset_width=8
425 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
427 -n do not generate perl code (default when invoked as pstruct)
428 -p generate perl code (default when invoked as c2ph)
429 -v generate perl code, with C decls as comments
431 -i do NOT recompute sizes for intrinsic datatypes
432 -a dump information on intrinsics also
435 -d spew reams of debugging output
437 -slist give comma-separated list a structures to dump
440 Var Name Default Value Meaning
444 &defvar('CC', 'which_compiler to call');
445 &defvar('CFLAGS', 'how to generate *.s files with stabs');
446 &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
450 &defvar('type_width', 'width of type field (column 1)');
451 &defvar('member_width', 'width of member field (column 2)');
452 &defvar('offset_width', 'width of offset field (column 3)');
453 &defvar('size_width', 'width of size field (column 4)');
457 &defvar('offset_fmt', 'sprintf format type for offset');
458 &defvar('size_fmt', 'sprintf format type for size');
462 &defvar('indent', 'how far to indent each nesting level');
466 If any *.[ch] files are given, these will be catted together into
467 a temporary *.c file and sent through:
469 and the resulting *.s groped for stab information. If no files are
470 supplied, then stdin is read directly with the assumption that it
471 contains stab information. All other lines will be ignored. At
472 most one *.s file should be supplied.
480 local($var, $msg) = @_;
481 printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
485 $SAFEDIR = File::Temp::tempdir("c2ph.XXXXXX", TMPDIR => 1, CLEANUP => 1)
486 unless (defined($SAFEDIR));
494 if (grep(!/\.[csh]$/,@ARGV)) {
495 warn "Only *.[csh] files expected!\n";
498 elsif (grep(/\.s$/,@ARGV)) {
500 warn "Only one *.s file allowed!\n";
504 elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
505 local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
506 $chdir = "cd $dir && " if $dir;
507 &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
508 $ARGV[0] =~ s/\.c$/.s/;
512 $TMP = "$SAFEDIR/c2ph.$$.c";
513 &system("cat @ARGV > $TMP") && exit 1;
514 &system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1;
522 for (split(/[\s,]+/, $opt_s)) {
534 print STDERR "reading from your keyboard: ";
536 print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
541 if ($trace && !($. % 10)) {
543 print STDERR $lineno, "\b" x length($lineno);
545 next unless /^\s*\.stabs\s+/;
548 if (s/\\\\"[d,]+$//) {
559 $savebar = $saveline = undef;
561 print STDERR "$.\n" if $trace;
564 &compute_intrinsics if $perl && !$opt_i;
566 print STDERR "resolving types\n" if $trace;
571 $sum = 2 + $type_width + $member_width;
572 $pmask1 = "%-${type_width}s %-${member_width}s";
573 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
578 # resolve template -- should be in stab define order, but even this isn't enough.
579 print STDERR "\nbuilding type templates: " if $trace;
580 for $i (reverse 0..$#type) {
581 next unless defined($name = $type[$i]);
582 next unless defined $struct{$name};
583 ($iname = $name) =~ s/\..*//;
585 &build_template($name) unless defined $template{&psou($name)} ||
586 $opt_s && !$interested{$iname};
588 print STDERR "\n\n" if $trace;
591 print STDERR "dumping structs: " if $trace;
597 foreach $name (sort keys %struct) {
598 ($iname = $name) =~ s/\..*//;
599 next if $opt_s && !$interested{$iname};
600 print STDERR "$name " if $trace;
609 $mname = &munge($name);
611 $fname = &psou($name);
613 print "# " if $perl && $verbose;
615 print "$fname {\n" if !$perl || $verbose;
616 $template{$fname} = &scrunch($template{$fname}) if $perl;
617 &pstruct($name,$name,0);
618 print "# " if $perl && $verbose;
619 print "}\n" if !$perl || $verbose;
620 print "\n" if $perl && $verbose;
625 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
628 sub ${mname}'typedef {
629 local(\$${mname}'index) = shift;
630 defined \$${mname}'index
631 ? \$${mname}'typedef[\$${mname}'index]
632 : \$${mname}'typedef;
637 sub ${mname}'sizeof {
638 local(\$${mname}'index) = shift;
639 defined \$${mname}'index
640 ? \$${mname}'sizeof[\$${mname}'index]
646 sub ${mname}'offsetof {
647 local(\$${mname}'index) = shift;
648 defined \$${mname}index
649 ? \$${mname}'offsetof[\$${mname}'index]
655 sub ${mname}'typeof {
656 local(\$${mname}'index) = shift;
657 defined \$${mname}index
658 ? \$${mname}'typeof[\$${mname}'index]
664 sub ${mname}'fieldnames {
665 \@${mname}'fieldnames;
669 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
672 sub ${mname}'isastruct {
677 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
680 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
683 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
687 print "\@${mname}'typedef[\@${mname}'indices] = (",
688 join("\n\t", '', @typedef), "\n );\n\n";
689 print "\@${mname}'sizeof[\@${mname}'indices] = (",
690 join("\n\t", '', @sizeof), "\n );\n\n";
691 print "\@${mname}'offsetof[\@${mname}'indices] = (",
692 join("\n\t", '', @offsetof), "\n );\n\n";
693 print "\@${mname}'typeof[\@${mname}'indices] = (",
694 join("\n\t", '', @typeof), "\n );\n\n";
695 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
696 join("\n\t", '', @fieldnames), "\n );\n\n";
698 $template_printed{$fname}++;
699 $size_printed{$fname}++;
704 print STDERR "\n" if $trace;
706 unless ($perl && $opt_a) {
707 print "\n1;\n" if $perl;
713 foreach $name (sort bysizevalue keys %intrinsics) {
714 next if $size_printed{$name};
715 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
720 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
723 foreach $name (sort keys %intrinsics) {
724 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
727 print "\n1;\n" if $perl;
732 ########################################################################################
736 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
738 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
743 $_ = $continued . $_ if length($continued);
745 # if last 2 chars of string are '\\' then stab is continued
756 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
757 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
764 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
766 push(@intrinsics, $ident);
767 $typeno = &typeno($3);
768 $type[$typeno] = $ident;
769 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
773 if (($name, $typeordef, $typeno, $extra, $struct, $_)
774 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
776 $typeno = &typeno($typeno); # sun foolery
778 elsif (/^[\$\w]+:/) {
782 warn "can't grok stab: <$_> in: $line " if $_;
786 #warn "got size $size for $name\n";
787 $sizeof{$name} = $size if $size;
789 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
791 $typenos{$name} = $typeno;
793 unless (defined $type[$typeno]) {
794 &panic("type 0??") unless $typeno;
795 $type[$typeno] = $name unless defined $type[$typeno];
796 printf "new type $typeno is $name" if $debug;
797 if ($extra =~ /\*/ && defined $type[$struct]) {
798 print ", a typedef for a pointer to " , $type[$struct] if $debug;
801 printf "%s is type %d", $name, $typeno if $debug;
802 print ", a typedef for " , $type[$typeno] if $debug;
804 print "\n" if $debug;
805 #next unless $extra =~ /[su*]/;
807 #$type[$struct] = $name;
809 if ($extra =~ /[us*]/) {
811 $_ = &sdecl($name, $_, 0);
814 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
820 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
821 push(@intrinsics, $2);
822 $typeno = &typeno($3);
824 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
826 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
830 warn "Funny remainder for $name on line $_ left in $line " if $_;
834 sub typeno { # sun thinks types are (0,27) instead of just 27
841 local($what,$prefix,$base) = @_;
842 local($field, $fieldname, $typeno, $count, $offset, $entry);
844 local($type, $tname);
845 local($mytype, $mycount, $entry2);
846 local($struct_count) = 0;
847 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
852 local($mname) = &munge($name);
860 local($sname) = &psou($what);
864 for $field (split(/;/, $struct{$what})) {
867 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
869 $type = $type[$typeno];
871 $type =~ /([^[]*)(\[.*\])?/;
874 $fieldtype = &psou($mytype);
876 local($fname) = &psou($name);
878 if ($build_templates) {
880 $pad = ($offset - ($lastoffset + $lastlength))/8
881 if defined $lastoffset;
883 if (! $finished_template{$sname}) {
884 if ($isaunion{$what}) {
885 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
887 $template{$sname} .= 'x' x $pad . ' ' if $pad;
891 $template = &fetch_template($type);
892 &repeat_template($template,$count);
894 if (! $finished_template{$sname}) {
895 $template{$sname} .= $template;
898 $revpad = $length/8 if $isaunion{$what};
900 ($lastoffset, $lastlength) = ($offset, $length);
903 print '# ' if $perl && $verbose;
904 $entry = sprintf($pmask1,
905 ' ' x ($nesting * $indent) . $fieldtype,
906 "$prefix.$fieldname" . $count);
908 $entry =~ s/(\*+)( )/$2$1/;
913 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
915 ($bits = $length % 8) ? ".$bits": ""
916 if !$perl || $verbose;
919 $template = &fetch_template($type);
920 &repeat_template($template,$count);
923 if ($perl && $nesting == 1) {
925 push(@sizeof, int($length/8) .",\t# $fieldname");
926 push(@offsetof, int($offset/8) .",\t# $fieldname");
927 local($little) = &scrunch($template);
928 push(@typedef, "'$little', \t# $fieldname");
929 $type =~ s/(struct|union) //;
930 push(@typeof, "'$mytype" . ($count ? $count : '') .
932 push(@fieldnames, "'$fieldname',");
935 print ' ', ' ' x $indent x $nesting, $template
936 if $perl && $verbose;
938 print "\n" if !$perl || $verbose;
942 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
943 $mycount *= &scripts2count($count) if $count;
944 if ($nesting==1 && !$build_templates) {
945 $pcode .= sprintf("sub %-32s { %4d; }\n",
946 "${mname}'${fieldname}", $struct_count);
947 push(@indices, $struct_count);
949 $struct_count += $mycount;
953 &pstruct($type, "$prefix.$fieldname", $base+$offset)
954 if $recurse && defined $struct{$type};
957 $countof{$what} = $struct_count unless defined $countof{$whati};
959 $template{$sname} .= '$' if $build_templates;
960 $finished_template{$sname}++;
962 if ($build_templates && !defined $sizeof{$name}) {
963 local($fmt) = &scrunch($template{$sname});
964 print STDERR "no size for $name, punting with $fmt..." if $debug;
965 eval '$sizeof{$name} = length(pack($fmt, ()))';
968 warn "couldn't get size for \$name: $@";
970 print STDERR $sizeof{$name}, "\n" if $debUg;
980 local($amstruct) = $struct{$me} ? 'struct ' : '';
982 print '$sizeof{\'', $amstruct, $me, '\'} = ';
983 printf "%d;\n", $sizeof{$me};
991 warn "pdecl: $pdecl\n" if $debug;
993 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
995 @pdecls = split(/=/, $pdecl);
996 $typeno = $pdecls[0];
997 $tname = pop @pdecls;
999 if ($tname =~ s/^f//) { $tname = "$tname&"; }
1000 #else { $tname = "$tname*"; }
1002 for (reverse @pdecls) {
1003 $tname .= s/^f// ? "&" : "*";
1004 #$tname =~ s/^f(.*)/$1&/;
1005 print "type[$_] is $tname\n" if $debug;
1006 $type[$_] = $tname unless defined $type[$_];
1013 ($arraytype, $unknown, $lower, $upper) = ();
1015 # global $typeno, @type
1016 local($_, $typedef) = @_;
1018 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
1019 ($arraytype, $unknown) = ($2, $3);
1020 $arraytype = &typeno($arraytype);
1021 $unknown = &typeno($unknown);
1022 if (s/^(\d+);(\d+);//) {
1023 ($lower, $upper) = ($1, $2);
1024 $scripts .= '[' . ($upper+1) . ']';
1026 warn "can't find array bounds: $_";
1029 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
1030 ($start, $length) = ($2, $3);
1032 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
1033 $typeno = &typeno($1);
1036 $typeno = &typeno($whatis);
1038 } elsif (s/^(\d+)(=[*suf]\d*)//) {
1039 local($whatis) = $2;
1041 if ($whatis =~ /[f*]/) {
1043 } elsif ($whatis =~ /[su]/) { #
1044 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
1046 #$type[$typeno] = $name unless defined $type[$typeno];
1047 ##printf "new type $typeno is $name" if $debug;
1049 $type[$typeno] = "$prefix.$fieldname";
1050 local($name) = $type[$typeno];
1051 &sou($name, $whatis);
1052 $_ = &sdecl($name, $_, $start+$offset);
1054 $start = $start{$name};
1055 $offset = $sizeof{$name};
1058 warn "what's this? $whatis in $line ";
1063 warn "bad array stab: $_ in $line ";
1066 #local($wasdef) = defined($type[$typeno]) && $debug;
1068 #print "redefining $type[$typeno] to " if $wasdef;
1069 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1070 #print "$type[$typeno]\n" if $wasdef;
1072 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1074 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1075 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1076 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1083 local($prefix, $_, $offset) = @_;
1085 local($fieldname, $scripts, $type, $arraytype, $unknown,
1086 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1087 local($typeno,$sou);
1091 while (/^([^;]+);/) {
1093 warn "sdecl $_\n" if $debug;
1094 if (s/^([\$\w]+)://) {
1096 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
1097 $typeno = &typeno($1);
1098 $type[$typeno] = "$prefix.$fieldname";
1099 local($name) = "$prefix.$fieldname";
1101 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1102 $start = $start{$name};
1103 $offset += $sizeof{$name};
1104 #print "done with anon, start is $start, offset is $offset\n";
1107 warn "weird field $_ of $line" if $debug;
1109 #$fieldname = &gensym;
1110 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1113 if (/^(\d+|\(\d+,\d+\))=ar/) {
1116 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
1117 ($start, $length) = ($2, $3);
1118 &panic("no length?") unless $length;
1119 $typeno = &typeno($1) if $1;
1121 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
1122 ($start, $length) = ($2, $3);
1123 &panic("no length?") unless $length;
1124 $typeno = &typeno($1) if $1;
1126 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
1127 ($pdecl, $start, $length) = ($1,$5,$6);
1130 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1131 ($typeno, $sou) = ($1, $2);
1132 $typeno = &typeno($typeno);
1133 if (defined($type[$typeno])) {
1134 warn "now how did we get type $1 in $fieldname of $line?";
1136 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1137 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1139 local($name) = "$prefix.$fieldname";
1141 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1142 $type[$typeno] = "$prefix.$fieldname";
1143 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1144 $start = $start{$name};
1145 $length = $sizeof{$name};
1148 warn "can't grok stab for $name ($_) in line $line ";
1152 &panic("no length for $prefix.$fieldname") unless $length;
1153 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1155 if (s/;\d*,(\d+),(\d+);//) {
1156 local($start, $size) = ($1, $2);
1157 $sizeof{$prefix} = $size;
1158 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1159 $start{$prefix} = $start;
1172 for $i (0 .. $#type) {
1173 next unless defined $type[$i];
1176 print "type[$i] $type[$i]\n" if $debug;
1179 print "type[$i] $_ ==> " if $debug;
1180 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
1181 s/^(\d+)\&/&type($1)/e;
1182 s/^(\d+)/&type($1)/e;
1183 s/(\*+)([^*]+)(\*+)/$1$3$2/;
1184 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1185 s/^(\d+)([\*\[].*)/&type($1).$2/e;
1186 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1188 print "$_\n" if $debug;
1191 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
1193 sub adjust_start_addrs {
1194 for (sort keys %start) {
1195 ($basename = $_) =~ s/\.[^.]+$//;
1196 $start{$_} += $start{$basename};
1197 print "start: $_ @ $start{$_}\n" if $debug;
1202 local($what, $_) = @_;
1203 /u/ && $isaunion{$what}++;
1204 /s/ && $isastruct{$what}++;
1209 local($prefix) = '';
1210 if ($isaunion{$what}) {
1212 } elsif ($isastruct{$what}) {
1213 $prefix = 'struct ';
1221 return '' if $_ eq '';
1227 1 while s/(\w) \1/$1$1/g;
1229 # i wanna say this, but perl resists my efforts:
1230 # s/(\w)(\1+)/$2 . length($1)/ge;
1239 sub buildscrunchlist {
1240 $scrunch_code = "sub quick_scrunch {\n";
1241 for (values %intrinsics) {
1242 $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
1244 $scrunch_code .= "}\n";
1245 print "$scrunch_code" if $debug;
1247 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1250 sub fetch_template {
1251 local($mytype) = @_;
1255 &panic("why do you care?") unless $perl;
1257 if ($mytype =~ s/(\[\d+\])+$//) {
1261 if ($mytype =~ /\*/) {
1262 $fmt = $template{'pointer'};
1264 elsif (defined $template{$mytype}) {
1265 $fmt = $template{$mytype};
1267 elsif (defined $struct{$mytype}) {
1268 if (!defined $template{&psou($mytype)}) {
1269 &build_template($mytype) unless $mytype eq $name;
1271 elsif ($template{&psou($mytype)} !~ /\$$/) {
1272 #warn "incomplete template for $mytype\n";
1274 $fmt = $template{&psou($mytype)} || '?';
1277 warn "unknown fmt for $mytype\n";
1281 $fmt x $count . ' ';
1284 sub compute_intrinsics {
1286 local($TMP) = "$SAFEDIR/c2ph-i.$$.c";
1287 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1290 print STDERR "computing intrinsic sizes: " if $trace;
1296 char *mask = "%d %s\n";
1299 for $type (@intrinsics) {
1300 next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
1302 printf(mask,sizeof($type), "$type");
1307 printf(mask,sizeof(char *), "pointer");
1314 open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|");
1318 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1319 $sizeof{$_[1]} = $_[0];
1320 $intrinsics{$_[1]} = $template{$_[0]};
1322 close(PIPE) || die "couldn't read intrinsics!";
1323 unlink($TMP, "$SAFEDIR/a.out");
1324 print STDERR "done\n" if $trace;
1334 &panic("$_: $@") if $@;
1339 print STDERR "@_\n" if $trace;
1343 sub build_template {
1346 &panic("already got a template for $name") if defined $template{$name};
1348 local($build_templates) = 1;
1350 local($lparen) = '(' x $build_recursed;
1351 local($rparen) = ')' x $build_recursed;
1353 print STDERR "$lparen$name$rparen " if $trace;
1355 &pstruct($name,$name,0);
1356 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1365 print "\npanic: @_\n";
1367 exit 1 if $] <= 4.003; # caller broken
1370 local($p,$f,$l,$s,$h,$a,@a,@sub);
1371 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1374 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1375 $_ = sprintf("%s",$_);
1379 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1380 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1381 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1384 $w = $w ? '@ = ' : '$ = ';
1385 $a = $h ? '(' . join(', ', @a) . ')' : '';
1386 push(@sub, "$w&$s$a from file $f line $l\n");
1389 for ($i=0; $i <= $#sub; $i++) {
1398 local($last) = -1e8;
1402 while (defined($num = shift)) {
1403 if ($num == ($last + 1)) {
1404 $string .= $seq unless $inseq++;
1408 $string .= $last unless $last == -1e8;
1411 $string .= ',' if defined $string;
1416 $string .= $last if $inseq && $last != -e18;
1420 sub repeat_template {
1421 # local($template, $scripts) = @_; have to change caller's values
1424 local($ncount) = &scripts2count($_[1]);
1425 if ($_[0] =~ /^\s*c\s*$/i) {
1426 $_[0] = "A$ncount ";
1429 $_[0] = $template x $ncount;
1435 close OUT or die "Can't close $file: $!";
1436 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1438 print "Linking $file to pstruct.\n";
1439 if (defined $Config{d_link}) {
1440 link $file, 'pstruct';
1442 unshift @INC, '../lib';
1444 File::Copy::syscopy('c2ph', 'pstruct');
1446 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';