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 ($Config{'osname'} eq 'VMS' or
19 $Config{'osname'} eq 'OS2'); # "case-forgiving"
21 open OUT,">$file" or die "Can't create $file: $!";
23 print "Extracting $file (with variable substitutions)\n";
25 # In this section, perl variables will be expanded during extraction.
26 # You can use $Config{...} to use Configure variables.
28 print OUT <<"!GROK!THIS!";
30 eval 'exec perl -S \$0 "\$@"'
34 # In the following, perl variables are not expanded during extraction.
36 print OUT <<'!NO!SUBS!';
40 # Tom Christiansen, <tchrist@convex.com>
42 # As pstruct, dump C structures as generated from 'cc -g -S' stabs.
43 # As c2ph, do this PLUS generate perl code for getting at the structures.
45 # See the usage message for more. If this isn't enough, read the code.
48 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
51 ######################################################################
53 # some handy data definitions. many of these can be reset later.
55 $bitorder = 'b'; # ascending; set to B for descending bit fields
63 'unsigned short', 'S',
64 'unsigned short int', 'S',
65 'short unsigned int', 'S',
72 'long unsigned int', 'L',
73 'unsigned long int', 'L',
76 'unsigned long long', 'Q',
77 'unsigned long long int', 'Q',
87 delete $intrinsics{'neganull'};
88 delete $intrinsics{'bit'};
89 delete $intrinsics{'null'};
91 # use -s to recompute sizes
97 'unsigned short', '2',
98 'unsigned short int', '2',
99 'short unsigned int', '2',
104 'unsigned long', '4',
105 'unsigned long int', '4',
106 'long unsigned int', '4',
108 'long long int', '8',
109 'unsigned long long', '8',
110 'unsigned long long int', '8',
116 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
118 ($offset_fmt, $size_fmt) = ('d', 'd');
126 $perl++ if $0 =~ m#/?c2ph$#;
128 require 'getopts.pl';
130 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
132 &Getopts('aixdpvtnws:') || &usage(0);
137 $opt_v && $verbose++;
138 $opt_n && ($perl = 0);
141 ($type_width, $member_width, $offset_width) = (45, 35, 8);
144 ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
147 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
151 print "oops, apperent pager foulup\n";
163 print "hit <RETURN> for further explanation: ";
165 open (PIPE, "|". ($ENV{PAGER} || 'more'));
166 $SIG{PIPE} = PLUMBER;
170 print "usage: $0 [-dpnP] [var=val] [files ...]\n";
178 -w wide; short for: type_width=45 member_width=35 offset_width=8
179 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
181 -n do not generate perl code (default when invoked as pstruct)
182 -p generate perl code (default when invoked as c2ph)
183 -v generate perl code, with C decls as comments
185 -i do NOT recompute sizes for intrinsic datatypes
186 -a dump information on intrinsics also
189 -d spew reams of debugging output
191 -slist give comma-separated list a structures to dump
194 Var Name Default Value Meaning
198 &defvar('CC', 'which_compiler to call');
199 &defvar('CFLAGS', 'how to generate *.s files with stabs');
200 &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
204 &defvar('type_width', 'width of type field (column 1)');
205 &defvar('member_width', 'width of member field (column 2)');
206 &defvar('offset_width', 'width of offset field (column 3)');
207 &defvar('size_width', 'width of size field (column 4)');
211 &defvar('offset_fmt', 'sprintf format type for offset');
212 &defvar('size_fmt', 'sprintf format type for size');
216 &defvar('indent', 'how far to indent each nesting level');
220 If any *.[ch] files are given, these will be catted together into
221 a temporary *.c file and sent through:
223 and the resulting *.s groped for stab information. If no files are
224 supplied, then stdin is read directly with the assumption that it
225 contains stab information. All other liens will be ignored. At
226 most one *.s file should be supplied.
234 local($var, $msg) = @_;
235 printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
241 if (grep(!/\.[csh]$/,@ARGV)) {
242 warn "Only *.[csh] files expected!\n";
245 elsif (grep(/\.s$/,@ARGV)) {
247 warn "Only one *.s file allowed!\n";
251 elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
252 local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
253 $chdir = "cd $dir; " if $dir;
254 &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
255 $ARGV[0] =~ s/\.c$/.s/;
258 $TMP = "/tmp/c2ph.$$.c";
259 &system("cat @ARGV > $TMP") && exit 1;
260 &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
268 for (split(/[\s,]+/, $opt_s)) {
280 print STDERR "reading from your keyboard: ";
282 print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
287 if ($trace && !($. % 10)) {
289 print STDERR $lineno, "\b" x length($lineno);
291 next unless /^\s*\.stabs\s+/;
294 if (s/\\\\"[d,]+$//) {
305 $savebar = $saveline = undef;
307 print STDERR "$.\n" if $trace;
310 &compute_intrinsics if $perl && !$opt_i;
312 print STDERR "resolving types\n" if $trace;
317 $sum = 2 + $type_width + $member_width;
318 $pmask1 = "%-${type_width}s %-${member_width}s";
319 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
324 # resolve template -- should be in stab define order, but even this isn't enough.
325 print STDERR "\nbuilding type templates: " if $trace;
326 for $i (reverse 0..$#type) {
327 next unless defined($name = $type[$i]);
328 next unless defined $struct{$name};
329 ($iname = $name) =~ s/\..*//;
331 &build_template($name) unless defined $template{&psou($name)} ||
332 $opt_s && !$interested{$iname};
334 print STDERR "\n\n" if $trace;
337 print STDERR "dumping structs: " if $trace;
343 foreach $name (sort keys %struct) {
344 ($iname = $name) =~ s/\..*//;
345 next if $opt_s && !$interested{$iname};
346 print STDERR "$name " if $trace;
355 $mname = &munge($name);
357 $fname = &psou($name);
359 print "# " if $perl && $verbose;
361 print "$fname {\n" if !$perl || $verbose;
362 $template{$fname} = &scrunch($template{$fname}) if $perl;
363 &pstruct($name,$name,0);
364 print "# " if $perl && $verbose;
365 print "}\n" if !$perl || $verbose;
366 print "\n" if $perl && $verbose;
371 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
374 sub ${mname}'typedef {
375 local(\$${mname}'index) = shift;
376 defined \$${mname}'index
377 ? \$${mname}'typedef[\$${mname}'index]
378 : \$${mname}'typedef;
383 sub ${mname}'sizeof {
384 local(\$${mname}'index) = shift;
385 defined \$${mname}'index
386 ? \$${mname}'sizeof[\$${mname}'index]
392 sub ${mname}'offsetof {
393 local(\$${mname}'index) = shift;
394 defined \$${mname}index
395 ? \$${mname}'offsetof[\$${mname}'index]
401 sub ${mname}'typeof {
402 local(\$${mname}'index) = shift;
403 defined \$${mname}index
404 ? \$${mname}'typeof[\$${mname}'index]
410 sub ${mname}'fieldnames {
411 \@${mname}'fieldnames;
415 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
418 sub ${mname}'isastruct {
423 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
426 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
429 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
433 print "\@${mname}'typedef[\@${mname}'indices] = (",
434 join("\n\t", '', @typedef), "\n );\n\n";
435 print "\@${mname}'sizeof[\@${mname}'indices] = (",
436 join("\n\t", '', @sizeof), "\n );\n\n";
437 print "\@${mname}'offsetof[\@${mname}'indices] = (",
438 join("\n\t", '', @offsetof), "\n );\n\n";
439 print "\@${mname}'typeof[\@${mname}'indices] = (",
440 join("\n\t", '', @typeof), "\n );\n\n";
441 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
442 join("\n\t", '', @fieldnames), "\n );\n\n";
444 $template_printed{$fname}++;
445 $size_printed{$fname}++;
450 print STDERR "\n" if $trace;
452 unless ($perl && $opt_a) {
453 print "\n1;\n" if $perl;
459 foreach $name (sort bysizevalue keys %intrinsics) {
460 next if $size_printed{$name};
461 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
466 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
469 foreach $name (sort keys %intrinsics) {
470 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
473 print "\n1;\n" if $perl;
478 ########################################################################################
482 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
484 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
489 $_ = $continued . $_ if length($continued);
491 # if last 2 chars of string are '\\' then stab is continued
502 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
503 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
510 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
512 push(@intrinsics, $ident);
513 $typeno = &typeno($3);
514 $type[$typeno] = $ident;
515 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
519 if (($name, $typeordef, $typeno, $extra, $struct, $_)
520 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
522 $typeno = &typeno($typeno); # sun foolery
524 elsif (/^[\$\w]+:/) {
528 warn "can't grok stab: <$_> in: $line " if $_;
532 #warn "got size $size for $name\n";
533 $sizeof{$name} = $size if $size;
535 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
537 $typenos{$name} = $typeno;
539 unless (defined $type[$typeno]) {
540 &panic("type 0??") unless $typeno;
541 $type[$typeno] = $name unless defined $type[$typeno];
542 printf "new type $typeno is $name" if $debug;
543 if ($extra =~ /\*/ && defined $type[$struct]) {
544 print ", a typedef for a pointer to " , $type[$struct] if $debug;
547 printf "%s is type %d", $name, $typeno if $debug;
548 print ", a typedef for " , $type[$typeno] if $debug;
550 print "\n" if $debug;
551 #next unless $extra =~ /[su*]/;
553 #$type[$struct] = $name;
555 if ($extra =~ /[us*]/) {
557 $_ = &sdecl($name, $_, 0);
560 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
566 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
567 push(@intrinsics, $2);
568 $typeno = &typeno($3);
570 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
572 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
576 warn "Funny remainder for $name on line $_ left in $line " if $_;
580 sub typeno { # sun thinks types are (0,27) instead of just 27
587 local($what,$prefix,$base) = @_;
588 local($field, $fieldname, $typeno, $count, $offset, $entry);
590 local($type, $tname);
591 local($mytype, $mycount, $entry2);
592 local($struct_count) = 0;
593 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
598 local($mname) = &munge($name);
606 local($sname) = &psou($what);
610 for $field (split(/;/, $struct{$what})) {
613 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
615 $type = $type[$typeno];
617 $type =~ /([^[]*)(\[.*\])?/;
620 $fieldtype = &psou($mytype);
622 local($fname) = &psou($name);
624 if ($build_templates) {
626 $pad = ($offset - ($lastoffset + $lastlength))/8
627 if defined $lastoffset;
629 if (! $finished_template{$sname}) {
630 if ($isaunion{$what}) {
631 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
633 $template{$sname} .= 'x' x $pad . ' ' if $pad;
637 $template = &fetch_template($type);
638 &repeat_template($template,$count);
640 if (! $finished_template{$sname}) {
641 $template{$sname} .= $template;
644 $revpad = $length/8 if $isaunion{$what};
646 ($lastoffset, $lastlength) = ($offset, $length);
649 print '# ' if $perl && $verbose;
650 $entry = sprintf($pmask1,
651 ' ' x ($nesting * $indent) . $fieldtype,
652 "$prefix.$fieldname" . $count);
654 $entry =~ s/(\*+)( )/$2$1/;
659 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
661 ($bits = $length % 8) ? ".$bits": ""
662 if !$perl || $verbose;
665 $template = &fetch_template($type);
666 &repeat_template($template,$count);
669 if ($perl && $nesting == 1) {
671 push(@sizeof, int($length/8) .",\t# $fieldname");
672 push(@offsetof, int($offset/8) .",\t# $fieldname");
673 local($little) = &scrunch($template);
674 push(@typedef, "'$little', \t# $fieldname");
675 $type =~ s/(struct|union) //;
676 push(@typeof, "'$mytype" . ($count ? $count : '') .
678 push(@fieldnames, "'$fieldname',");
681 print ' ', ' ' x $indent x $nesting, $template
682 if $perl && $verbose;
684 print "\n" if !$perl || $verbose;
688 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
689 $mycount *= &scripts2count($count) if $count;
690 if ($nesting==1 && !$build_templates) {
691 $pcode .= sprintf("sub %-32s { %4d; }\n",
692 "${mname}'${fieldname}", $struct_count);
693 push(@indices, $struct_count);
695 $struct_count += $mycount;
699 &pstruct($type, "$prefix.$fieldname", $base+$offset)
700 if $recurse && defined $struct{$type};
703 $countof{$what} = $struct_count unless defined $countof{$whati};
705 $template{$sname} .= '$' if $build_templates;
706 $finished_template{$sname}++;
708 if ($build_templates && !defined $sizeof{$name}) {
709 local($fmt) = &scrunch($template{$sname});
710 print STDERR "no size for $name, punting with $fmt..." if $debug;
711 eval '$sizeof{$name} = length(pack($fmt, ()))';
714 warn "couldn't get size for \$name: $@";
716 print STDERR $sizeof{$name}, "\n" if $debUg;
726 local($amstruct) = $struct{$me} ? 'struct ' : '';
728 print '$sizeof{\'', $amstruct, $me, '\'} = ';
729 printf "%d;\n", $sizeof{$me};
737 warn "pdecl: $pdecl\n" if $debug;
739 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
741 @pdecls = split(/=/, $pdecl);
742 $typeno = $pdecls[0];
743 $tname = pop @pdecls;
745 if ($tname =~ s/^f//) { $tname = "$tname&"; }
746 #else { $tname = "$tname*"; }
748 for (reverse @pdecls) {
749 $tname .= s/^f// ? "&" : "*";
750 #$tname =~ s/^f(.*)/$1&/;
751 print "type[$_] is $tname\n" if $debug;
752 $type[$_] = $tname unless defined $type[$_];
759 ($arraytype, $unknown, $lower, $upper) = ();
761 # global $typeno, @type
762 local($_, $typedef) = @_;
764 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
765 ($arraytype, $unknown) = ($2, $3);
766 $arraytype = &typeno($arraytype);
767 $unknown = &typeno($unknown);
768 if (s/^(\d+);(\d+);//) {
769 ($lower, $upper) = ($1, $2);
770 $scripts .= '[' . ($upper+1) . ']';
772 warn "can't find array bounds: $_";
775 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
776 ($start, $length) = ($2, $3);
778 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
779 $typeno = &typeno($1);
782 $typeno = &typeno($whatis);
784 } elsif (s/^(\d+)(=[*suf]\d*)//) {
787 if ($whatis =~ /[f*]/) {
789 } elsif ($whatis =~ /[su]/) { #
790 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
792 #$type[$typeno] = $name unless defined $type[$typeno];
793 ##printf "new type $typeno is $name" if $debug;
795 $type[$typeno] = "$prefix.$fieldname";
796 local($name) = $type[$typeno];
797 &sou($name, $whatis);
798 $_ = &sdecl($name, $_, $start+$offset);
800 $start = $start{$name};
801 $offset = $sizeof{$name};
804 warn "what's this? $whatis in $line ";
809 warn "bad array stab: $_ in $line ";
812 #local($wasdef) = defined($type[$typeno]) && $debug;
814 #print "redefining $type[$typeno] to " if $wasdef;
815 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
816 #print "$type[$typeno]\n" if $wasdef;
818 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
820 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
821 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
822 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
829 local($prefix, $_, $offset) = @_;
831 local($fieldname, $scripts, $type, $arraytype, $unknown,
832 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
837 while (/^([^;]+);/) {
839 warn "sdecl $_\n" if $debug;
840 if (s/^([\$\w]+)://) {
842 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
843 $typeno = &typeno($1);
844 $type[$typeno] = "$prefix.$fieldname";
845 local($name) = "$prefix.$fieldname";
847 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
848 $start = $start{$name};
849 $offset += $sizeof{$name};
850 #print "done with anon, start is $start, offset is $offset\n";
853 warn "weird field $_ of $line" if $debug;
855 #$fieldname = &gensym;
856 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
859 if (/^(\d+|\(\d+,\d+\))=ar/) {
862 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
863 ($start, $length) = ($2, $3);
864 &panic("no length?") unless $length;
865 $typeno = &typeno($1) if $1;
867 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
868 ($start, $length) = ($2, $3);
869 &panic("no length?") unless $length;
870 $typeno = &typeno($1) if $1;
872 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
873 ($pdecl, $start, $length) = ($1,$5,$6);
876 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
877 ($typeno, $sou) = ($1, $2);
878 $typeno = &typeno($typeno);
879 if (defined($type[$typeno])) {
880 warn "now how did we get type $1 in $fieldname of $line?";
882 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
883 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
885 local($name) = "$prefix.$fieldname";
887 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
888 $type[$typeno] = "$prefix.$fieldname";
889 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
890 $start = $start{$name};
891 $length = $sizeof{$name};
894 warn "can't grok stab for $name ($_) in line $line ";
898 &panic("no length for $prefix.$fieldname") unless $length;
899 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
901 if (s/;\d*,(\d+),(\d+);//) {
902 local($start, $size) = ($1, $2);
903 $sizeof{$prefix} = $size;
904 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
905 $start{$prefix} = $start;
918 for $i (0 .. $#type) {
919 next unless defined $type[$i];
922 print "type[$i] $type[$i]\n" if $debug;
925 print "type[$i] $_ ==> " if $debug;
926 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
927 s/^(\d+)\&/&type($1)/e;
928 s/^(\d+)/&type($1)/e;
929 s/(\*+)([^*]+)(\*+)/$1$3$2/;
930 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
931 s/^(\d+)([\*\[].*)/&type($1).$2/e;
932 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
934 print "$_\n" if $debug;
937 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
939 sub adjust_start_addrs {
940 for (sort keys %start) {
941 ($basename = $_) =~ s/\.[^.]+$//;
942 $start{$_} += $start{$basename};
943 print "start: $_ @ $start{$_}\n" if $debug;
948 local($what, $_) = @_;
949 /u/ && $isaunion{$what}++;
950 /s/ && $isastruct{$what}++;
956 if ($isaunion{$what}) {
958 } elsif ($isastruct{$what}) {
967 return '' if $_ eq '';
973 1 while s/(\w) \1/$1$1/g;
975 # i wanna say this, but perl resists my efforts:
976 # s/(\w)(\1+)/$2 . length($1)/ge;
985 sub buildscrunchlist {
986 $scrunch_code = "sub quick_scrunch {\n";
987 for (values %intrinsics) {
988 $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
990 $scrunch_code .= "}\n";
991 print "$scrunch_code" if $debug;
993 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1001 &panic("why do you care?") unless $perl;
1003 if ($mytype =~ s/(\[\d+\])+$//) {
1007 if ($mytype =~ /\*/) {
1008 $fmt = $template{'pointer'};
1010 elsif (defined $template{$mytype}) {
1011 $fmt = $template{$mytype};
1013 elsif (defined $struct{$mytype}) {
1014 if (!defined $template{&psou($mytype)}) {
1015 &build_template($mytype) unless $mytype eq $name;
1017 elsif ($template{&psou($mytype)} !~ /\$$/) {
1018 #warn "incomplete template for $mytype\n";
1020 $fmt = $template{&psou($mytype)} || '?';
1023 warn "unknown fmt for $mytype\n";
1027 $fmt x $count . ' ';
1030 sub compute_intrinsics {
1031 local($TMP) = "/tmp/c2ph-i.$$.c";
1032 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1035 print STDERR "computing intrinsic sizes: " if $trace;
1041 char *mask = "%d %s\n";
1044 for $type (@intrinsics) {
1045 next if !type || $type eq 'void' || $type =~ /complex/; # sun stuff
1047 printf(mask,sizeof($type), "$type");
1052 printf(mask,sizeof(char *), "pointer");
1059 open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
1063 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1064 $sizeof{$_[1]} = $_[0];
1065 $intrinsics{$_[1]} = $template{$_[0]};
1067 close(PIPE) || die "couldn't read intrinsics!";
1068 unlink($TMP, '/tmp/a.out');
1069 print STDERR "done\n" if $trace;
1079 &panic("$_: $@") if $@;
1084 print STDERR "@_\n" if $trace;
1088 sub build_template {
1091 &panic("already got a template for $name") if defined $template{$name};
1093 local($build_templates) = 1;
1095 local($lparen) = '(' x $build_recursed;
1096 local($rparen) = ')' x $build_recursed;
1098 print STDERR "$lparen$name$rparen " if $trace;
1100 &pstruct($name,$name,0);
1101 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1110 print "\npanic: @_\n";
1112 exit 1 if $] <= 4.003; # caller broken
1115 local($p,$f,$l,$s,$h,$a,@a,@sub);
1116 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1119 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1120 $_ = sprintf("%s",$_);
1124 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1125 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1126 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1129 $w = $w ? '@ = ' : '$ = ';
1130 $a = $h ? '(' . join(', ', @a) . ')' : '';
1131 push(@sub, "$w&$s$a from file $f line $l\n");
1134 for ($i=0; $i <= $#sub; $i++) {
1143 local($last) = -1e8;
1147 while (defined($num = shift)) {
1148 if ($num == ($last + 1)) {
1149 $string .= $seq unless $inseq++;
1153 $string .= $last unless $last == -1e8;
1156 $string .= ',' if defined $string;
1161 $string .= $last if $inseq && $last != -e18;
1165 sub repeat_template {
1166 # local($template, $scripts) = @_; have to change caller's values
1169 local($ncount) = &scripts2count($_[1]);
1170 if ($_[0] =~ /^\s*c\s*$/i) {
1171 $_[0] = "A$ncount ";
1174 $_[0] = $template x $ncount;
1180 close OUT or die "Can't close $file: $!";
1181 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1184 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';