This is my patch patch.1i for perl5.001.
[perl.git] / c2ph.SH
1 case $CONFIG in
2 '')
3     if test ! -f config.sh; then
4         ln ../config.sh . || \
5         ln ../../config.sh . || \
6         ln ../../../config.sh . || \
7         (echo "Can't find config.sh."; exit 1)
8     fi
9     . config.sh
10     ;;
11 esac
12 : This forces SH files to create target in same directory as SH file.
13 : This is so that make depend always knows where to find SH derivatives.
14 case "$0" in
15 */*) cd `expr X$0 : 'X\(.*\)/'` ;;
16 esac
17 echo "Extracting c2ph (with variable substitutions)"
18 : This section of the file will have variable substitutions done on it.
19 : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
20 : Protect any dollar signs and backticks that you do not want interpreted
21 : by putting a backslash in front.  You may delete these comments.
22 rm -f c2ph
23 $spitshell >c2ph <<!GROK!THIS!
24 #!$bin/perl
25 #
26 !GROK!THIS!
27
28 : In the following dollars and backticks do not need the extra backslash.
29 $spitshell >>c2ph <<'!NO!SUBS!'
30 #
31 #   c2ph (aka pstruct)
32 #   Tom Christiansen, <tchrist@convex.com>
33 #   
34 #   As pstruct, dump C structures as generated from 'cc -g -S' stabs.
35 #   As c2ph, do this PLUS generate perl code for getting at the structures.
36 #
37 #   See the usage message for more.  If this isn't enough, read the code.
38 #
39
40 $RCSID = 'c2ph.SH';
41
42
43 ######################################################################
44
45 # some handy data definitions.   many of these can be reset later.
46
47 $bitorder = 'b';  # ascending; set to B for descending bit fields
48
49 %intrinsics = 
50 %template = (
51     'char',                     'c',
52     'unsigned char',            'C',
53     'short',                    's',
54     'short int',                's',
55     'unsigned short',           'S',
56     'unsigned short int',       'S',
57     'short unsigned int',       'S',
58     'int',                      'i',
59     'unsigned int',             'I',
60     'long',                     'l',
61     'long int',                 'l',
62     'unsigned long',            'L',
63     'unsigned long',            'L',
64     'long unsigned int',        'L',
65     'unsigned long int',        'L',
66     'long long',                'q',
67     'long long int',            'q',
68     'unsigned long long',       'Q',
69     'unsigned long long int',   'Q',
70     'float',                    'f',
71     'double',                   'd',
72     'pointer',                  'p',
73     'null',                     'x',
74     'neganull',                 'X',
75     'bit',                      $bitorder,
76 ); 
77
78 &buildscrunchlist;
79 delete $intrinsics{'neganull'};
80 delete $intrinsics{'bit'};
81 delete $intrinsics{'null'};
82
83 # use -s to recompute sizes
84 %sizeof = (
85     'char',                     '1',
86     'unsigned char',            '1',
87     'short',                    '2',
88     'short int',                '2',
89     'unsigned short',           '2',
90     'unsigned short int',       '2',
91     'short unsigned int',       '2',
92     'int',                      '4',
93     'unsigned int',             '4',
94     'long',                     '4',
95     'long int',                 '4',
96     'unsigned long',            '4',
97     'unsigned long int',        '4',
98     'long unsigned int',        '4',
99     'long long',                '8',
100     'long long int',            '8',
101     'unsigned long long',       '8',
102     'unsigned long long int',   '8',
103     'float',                    '4',
104     'double',                   '8',
105     'pointer',                  '4',
106 );
107
108 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
109
110 ($offset_fmt, $size_fmt) = ('d', 'd');
111
112 $indent = 2;
113
114 $CC = 'cc';
115 $CFLAGS = '-g -S';
116 $DEFINES = '';
117
118 $perl++ if $0 =~ m#/?c2ph$#;
119
120 require 'getopts.pl';
121
122 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
123
124 &Getopts('aixdpvtnws:') || &usage(0);
125
126 $opt_d && $debug++;
127 $opt_t && $trace++;
128 $opt_p && $perl++;
129 $opt_v && $verbose++;
130 $opt_n && ($perl = 0);
131
132 if ($opt_w) {
133     ($type_width, $member_width, $offset_width) = (45, 35, 8);
134
135 if ($opt_x) {
136     ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
137 }
138
139 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
140
141 sub PLUMBER {
142     select(STDERR);
143     print "oops, apperent pager foulup\n";
144     $isatty++;
145     &usage(1);
146
147
148 sub usage {
149     local($oops) = @_;
150     unless (-t STDOUT) {
151         select(STDERR);
152     } elsif (!$oops) {
153         $isatty++;
154         $| = 1;
155         print "hit <RETURN> for further explanation: ";
156         <STDIN>;
157         open (PIPE, "|". ($ENV{PAGER} || 'more'));
158         $SIG{PIPE} = PLUMBER;
159         select(PIPE);
160     } 
161
162     print "usage: $0 [-dpnP] [var=val] [files ...]\n";
163
164     exit unless $isatty;
165
166     print <<EOF;
167
168 Options:
169
170 -w      wide; short for: type_width=45 member_width=35 offset_width=8
171 -x      hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
172
173 -n      do not generate perl code  (default when invoked as pstruct)
174 -p      generate perl code         (default when invoked as c2ph)
175 -v      generate perl code, with C decls as comments
176
177 -i      do NOT recompute sizes for intrinsic datatypes
178 -a      dump information on intrinsics also
179
180 -t      trace execution
181 -d      spew reams of debugging output
182
183 -slist  give comma-separated list a structures to dump
184
185
186 Var Name        Default Value    Meaning
187
188 EOF
189
190     &defvar('CC', 'which_compiler to call');
191     &defvar('CFLAGS', 'how to generate *.s files with stabs');
192     &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
193
194     print "\n";
195
196     &defvar('type_width', 'width of type field   (column 1)');
197     &defvar('member_width', 'width of member field (column 2)');
198     &defvar('offset_width', 'width of offset field (column 3)');
199     &defvar('size_width', 'width of size field   (column 4)');
200
201     print "\n";
202
203     &defvar('offset_fmt', 'sprintf format type for offset');
204     &defvar('size_fmt', 'sprintf format type for size');
205
206     print "\n";
207
208     &defvar('indent', 'how far to indent each nesting level');
209
210    print <<'EOF';
211
212     If any *.[ch] files are given, these will be catted together into
213     a temporary *.c file and sent through:
214             $CC $CFLAGS $DEFINES 
215     and the resulting *.s groped for stab information.  If no files are
216     supplied, then stdin is read directly with the assumption that it
217     contains stab information.  All other liens will be ignored.  At
218     most one *.s file should be supplied.
219
220 EOF
221     close PIPE;
222     exit 1;
223
224
225 sub defvar {
226     local($var, $msg) = @_;
227     printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;
228
229
230 $recurse = 1;
231
232 if (@ARGV) {
233     if (grep(!/\.[csh]$/,@ARGV)) {
234         warn "Only *.[csh] files expected!\n";
235         &usage;
236     } 
237     elsif (grep(/\.s$/,@ARGV)) {
238         if (@ARGV > 1) { 
239             warn "Only one *.s file allowed!\n";
240             &usage;
241         }
242     } 
243     elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
244         local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
245         $chdir = "cd $dir; " if $dir;
246         &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
247         $ARGV[0] =~ s/\.c$/.s/;
248     } 
249     else {
250         $TMP = "/tmp/c2ph.$$.c";
251         &system("cat @ARGV > $TMP") && exit 1;
252         &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
253         unlink $TMP;
254         $TMP =~ s/\.c$/.s/;
255         @ARGV = ($TMP);
256     } 
257 }
258
259 if ($opt_s) {
260     for (split(/[\s,]+/, $opt_s)) {
261         $interested{$_}++;
262     } 
263
264
265
266 $| = 1 if $debug;
267
268 main: {
269
270     if ($trace) {
271         if (-t && !@ARGV) { 
272             print STDERR "reading from your keyboard: ";
273         } else {
274             print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
275         }
276     }
277
278 STAB: while (<>) {
279         if ($trace && !($. % 10)) {
280             $lineno = $..'';
281             print STDERR $lineno, "\b" x length($lineno);
282         } 
283         next unless /^\s*\.stabs\s+/;
284         $line = $_;
285         s/^\s*\.stabs\s+//; 
286         &stab; 
287     }
288     print STDERR "$.\n" if $trace;
289     unlink $TMP if $TMP;
290
291     &compute_intrinsics if $perl && !$opt_i;
292
293     print STDERR "resolving types\n" if $trace;
294
295     &resolve_types;
296     &adjust_start_addrs;
297
298     $sum = 2 + $type_width + $member_width;
299     $pmask1 = "%-${type_width}s %-${member_width}s"; 
300     $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
301
302     if ($perl) {
303         # resolve template -- should be in stab define order, but even this isn't enough.
304         print STDERR "\nbuilding type templates: " if $trace;
305         for $i (reverse 0..$#type) {
306             next unless defined($name = $type[$i]);
307             next unless defined $struct{$name};
308             $build_recursed = 0;
309             &build_template($name) unless defined $template{&psou($name)} ||
310                                         $opt_s && !$interested{$name};
311         } 
312         print STDERR "\n\n" if $trace;
313     }
314
315     print STDERR "dumping structs: " if $trace;
316
317
318     foreach $name (sort keys %struct) {
319         next if $opt_s && !$interested{$name};
320         print STDERR "$name " if $trace;
321
322         undef @sizeof;
323         undef @typedef;
324         undef @offsetof;
325         undef @indices;
326         undef @typeof;
327
328         $mname = &munge($name);
329
330         $fname = &psou($name);
331
332         print "# " if $perl && $verbose;
333         $pcode = '';
334         print "$fname {\n" if !$perl || $verbose; 
335         $template{$fname} = &scrunch($template{$fname}) if $perl;
336         &pstruct($name,$name,0); 
337         print "# " if $perl && $verbose;
338         print "}\n" if !$perl || $verbose; 
339         print "\n" if $perl && $verbose;
340
341         if ($perl) {
342             print "$pcode";
343
344             printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
345
346             print <<EOF;
347 sub ${mname}'typedef { 
348     local(\$${mname}'index) = shift;
349     defined \$${mname}'index 
350         ? \$${mname}'typedef[\$${mname}'index] 
351         : \$${mname}'typedef;
352 }
353 EOF
354
355             print <<EOF;
356 sub ${mname}'sizeof { 
357     local(\$${mname}'index) = shift;
358     defined \$${mname}'index 
359         ? \$${mname}'sizeof[\$${mname}'index] 
360         : \$${mname}'sizeof;
361 }
362 EOF
363
364             print <<EOF;
365 sub ${mname}'offsetof { 
366     local(\$${mname}'index) = shift;
367     defined \$${mname}index 
368         ? \$${mname}'offsetof[\$${mname}'index] 
369         : \$${mname}'sizeof;
370 }
371 EOF
372
373             print <<EOF;
374 sub ${mname}'typeof { 
375     local(\$${mname}'index) = shift;
376     defined \$${mname}index 
377         ? \$${mname}'typeof[\$${mname}'index] 
378         : '$name';
379 }
380 EOF
381     
382
383             print "\$${mname}'typedef = '" . &scrunch($template{$fname}) 
384                 . "';\n";
385
386             print "\$${mname}'sizeof = $sizeof{$name};\n\n";
387
388
389             print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
390
391             print "\n";
392
393             print "\@${mname}'typedef[\@${mname}'indices] = (",
394                         join("\n\t", '', @typedef), "\n    );\n\n";
395             print "\@${mname}'sizeof[\@${mname}'indices] = (",
396                         join("\n\t", '', @sizeof), "\n    );\n\n";
397             print "\@${mname}'offsetof[\@${mname}'indices] = (",
398                         join("\n\t", '', @offsetof), "\n    );\n\n";
399             print "\@${mname}'typeof[\@${mname}'indices] = (",
400                         join("\n\t", '', @typeof), "\n    );\n\n";
401
402             $template_printed{$fname}++;
403             $size_printed{$fname}++;
404         } 
405         print "\n";
406     }
407
408     print STDERR "\n" if $trace;
409
410     unless ($perl && $opt_a) { 
411         print "\n1;\n";
412         exit;
413     }
414
415
416
417     foreach $name (sort bysizevalue keys %intrinsics) {
418         next if $size_printed{$name};
419         print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
420     }
421
422     print "\n";
423
424     sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
425
426
427     foreach $name (sort keys %intrinsics) {
428         print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
429     }
430
431     print "\n1;\n";
432         
433     exit;
434 }
435
436 ########################################################################################
437
438
439 sub stab {
440     next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/;  # (\d+,\d+) is for sun
441     s/"//                                               || next;
442     s/",([x\d]+),([x\d]+),([x\d]+),.*//                 || next;
443
444     next if /^\s*$/;
445
446     $size = $3 if $3;
447
448
449     $line = $_;
450
451     if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
452         print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
453         &pdecl($pdecl);
454         next;
455     }
456
457
458
459     if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {  
460         local($ident) = $2;
461         push(@intrinsics, $ident);
462         $typeno = &typeno($3);
463         $type[$typeno] = $ident;
464         print STDERR "intrinsic $ident in new type $typeno\n" if $debug; 
465         next;
466     }
467
468     if (($name, $typeordef, $typeno, $extra, $struct, $_) 
469         = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) 
470     {
471         $typeno = &typeno($typeno);  # sun foolery
472     } 
473     elsif (/^[\$\w]+:/) {
474         next; # variable
475     }
476     else { 
477         warn "can't grok stab: <$_> in: $line " if $_;
478         next;
479     } 
480
481     #warn "got size $size for $name\n";
482     $sizeof{$name} = $size if $size;
483
484     s/;[-\d]*;[-\d]*;$//;  # we don't care about ranges
485
486     $typenos{$name} = $typeno;
487
488     unless (defined $type[$typeno]) {
489         &panic("type 0??") unless $typeno;
490         $type[$typeno] = $name unless defined $type[$typeno];
491         printf "new type $typeno is $name" if $debug;
492         if ($extra =~ /\*/ && defined $type[$struct]) {
493             print ", a typedef for a pointer to " , $type[$struct] if $debug;
494         }
495     } else {
496         printf "%s is type %d", $name, $typeno if $debug;
497         print ", a typedef for " , $type[$typeno] if $debug;
498     } 
499     print "\n" if $debug;
500     #next unless $extra =~ /[su*]/;
501
502     #$type[$struct] = $name;
503
504     if ($extra =~ /[us*]/) {
505         &sou($name, $extra);
506         $_ = &sdecl($name, $_, 0);
507     }
508     elsif (/^=ar/) {
509         print "it's a bare array typedef -- that's pretty sick\n" if $debug;
510         $_ = "$typeno$_";
511         $scripts = '';
512         $_ = &adecl($_,1);
513
514     }
515     elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) {  # the ?'s are for gcc
516         push(@intrinsics, $2);
517         $typeno = &typeno($3);
518         $type[$typeno] = $2;
519         print STDERR "intrinsic $2 in new type $typeno\n" if $debug; 
520     }
521     elsif (s/^=e//) { # blessed by thy compiler; mine won't do this
522         &edecl;
523     } 
524     else {
525         warn "Funny remainder for $name on line $_ left in $line " if $_;
526     } 
527 }
528
529 sub typeno {  # sun thinks types are (0,27) instead of just 27
530     local($_) = @_;
531     s/\(\d+,(\d+)\)/$1/;
532     $_;
533
534
535 sub pstruct {
536     local($what,$prefix,$base) = @_; 
537     local($field, $fieldname, $typeno, $count, $offset, $entry); 
538     local($fieldtype);
539     local($type, $tname); 
540     local($mytype, $mycount, $entry2);
541     local($struct_count) = 0;
542     local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
543     local($bits,$bytes);
544     local($template);
545
546
547     local($mname) = &munge($name);
548
549     sub munge { 
550         local($_) = @_;
551         s/[\s\$\.]/_/g;
552         $_;
553     }
554
555     local($sname) = &psou($what);
556
557     $nesting++;
558
559     for $field (split(/;/, $struct{$what})) {
560         $pad = $prepad = 0;
561         $entry = ''; 
562         ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); 
563
564         $type = $type[$typeno];
565
566         $type =~ /([^[]*)(\[.*\])?/;
567         $mytype = $1;
568         $count .= $2;
569         $fieldtype = &psou($mytype);
570
571         local($fname) = &psou($name);
572
573         if ($build_templates) {
574
575             $pad = ($offset - ($lastoffset + $lastlength))/8 
576                 if defined $lastoffset;
577
578             if (! $finished_template{$sname}) {
579                 if ($isaunion{$what}) {
580                     $template{$sname} .= 'X' x $revpad . ' '    if $revpad;
581                 } else {
582                     $template{$sname} .= 'x' x $pad    . ' '    if $pad;
583                 }
584             }
585
586             $template = &fetch_template($type) x 
587                             ($count ? &scripts2count($count) : 1);
588
589             if (! $finished_template{$sname}) {
590                 $template{$sname} .= $template;
591             }
592
593             $revpad = $length/8 if $isaunion{$what};
594
595             ($lastoffset, $lastlength) = ($offset, $length);
596
597         } else { 
598             print '# ' if $perl && $verbose;
599             $entry = sprintf($pmask1,
600                         ' ' x ($nesting * $indent) . $fieldtype,
601                         "$prefix.$fieldname" . $count); 
602
603             $entry =~ s/(\*+)( )/$2$1/; 
604
605             printf $pmask2,
606                     $entry,
607                     ($base+$offset)/8,
608                     ($bits = ($base+$offset)%8) ? ".$bits" : "  ",
609                     $length/8,
610                     ($bits = $length % 8) ? ".$bits": ""
611                         if !$perl || $verbose;
612
613
614             if ($perl && $nesting == 1) {
615                 $template = &scrunch(&fetch_template($type) x 
616                                 ($count ? &scripts2count($count) : 1));
617                 push(@sizeof, int($length/8) .",\t# $fieldname");
618                 push(@offsetof, int($offset/8) .",\t# $fieldname");
619                 push(@typedef, "'$template', \t# $fieldname");
620                 $type =~ s/(struct|union) //;
621                 push(@typeof, "'$type" . ($count ? $count : '') .
622                     "',\t# $fieldname");
623             }
624
625             print '  ', ' ' x $indent x $nesting, $template
626                                 if $perl && $verbose;
627
628             print "\n" if !$perl || $verbose;
629
630         }    
631         if ($perl) {
632             local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
633             $mycount *= &scripts2count($count) if $count;
634             if ($nesting==1 && !$build_templates) {
635                 $pcode .= sprintf("sub %-32s { %4d; }\n", 
636                         "${mname}'${fieldname}", $struct_count);
637                 push(@indices, $struct_count);
638             }
639             $struct_count += $mycount;
640         } 
641
642
643         &pstruct($type, "$prefix.$fieldname", $base+$offset) 
644                 if $recurse && defined $struct{$type}; 
645     }
646
647     $countof{$what} = $struct_count unless defined $countof{$whati};
648
649     $template{$sname} .= '$' if $build_templates;
650     $finished_template{$sname}++;
651
652     if ($build_templates && !defined $sizeof{$name}) {
653         local($fmt) = &scrunch($template{$sname});
654         print STDERR "no size for $name, punting with $fmt..." if $debug;
655         eval '$sizeof{$name} = length(pack($fmt, ()))';
656         if ($@) {
657             chop $@;
658             warn "couldn't get size for \$name: $@";
659         } else {
660             print STDERR $sizeof{$name}, "\n" if $debUg;
661         }
662     } 
663
664     --$nesting;
665 }
666
667
668 sub psize {
669     local($me) = @_; 
670     local($amstruct) = $struct{$me} ?  'struct ' : '';
671
672     print '$sizeof{\'', $amstruct, $me, '\'} = '; 
673     printf "%d;\n", $sizeof{$me}; 
674 }
675
676 sub pdecl {
677     local($pdecl) = @_;
678     local(@pdecls);
679     local($tname);
680
681     warn "pdecl: $pdecl\n" if $debug;
682
683     $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
684     $pdecl =~ s/\*//g; 
685     @pdecls = split(/=/, $pdecl); 
686     $typeno = $pdecls[0];
687     $tname = pop @pdecls;
688
689     if ($tname =~ s/^f//) { $tname = "$tname&"; } 
690     #else { $tname = "$tname*"; } 
691
692     for (reverse @pdecls) {
693         $tname  .= s/^f// ? "&" : "*"; 
694         #$tname =~ s/^f(.*)/$1&/;
695         print "type[$_] is $tname\n" if $debug;
696         $type[$_] = $tname unless defined $type[$_];
697     } 
698 }
699
700
701
702 sub adecl {
703     ($arraytype, $unknown, $lower, $upper) = ();
704     #local($typeno);
705     # global $typeno, @type
706     local($_, $typedef) = @_;
707
708     while (s/^((\d+)=)?ar(\d+);//) {
709         ($arraytype, $unknown) = ($2, $3); 
710         if (s/^(\d+);(\d+);//) {
711             ($lower, $upper) = ($1, $2); 
712             $scripts .= '[' .  ($upper+1) . ']'; 
713         } else {
714             warn "can't find array bounds: $_"; 
715         } 
716     }
717     if (s/^([\d*f=]*),(\d+),(\d+);//) {
718         ($start, $length) = ($2, $3); 
719         local($whatis) = $1;
720         if ($whatis =~ /^(\d+)=/) {
721             $typeno = $1;
722             &pdecl($whatis);
723         } else {
724             $typeno = $whatis;
725         }
726     } elsif (s/^(\d+)(=[*suf]\d*)//) {
727         local($whatis) = $2; 
728
729         if ($whatis =~ /[f*]/) {
730             &pdecl($whatis); 
731         } elsif ($whatis =~ /[su]/) {  # 
732             print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" 
733                 if $debug;
734             #$type[$typeno] = $name unless defined $type[$typeno];
735             ##printf "new type $typeno is $name" if $debug;
736             $typeno = $1;
737             $type[$typeno] = "$prefix.$fieldname";
738             local($name) = $type[$typeno];
739             &sou($name, $whatis);
740             $_ = &sdecl($name, $_, $start+$offset);
741             1;
742             $start = $start{$name};
743             $offset = $sizeof{$name};
744             $length = $offset;
745         } else {
746             warn "what's this? $whatis in $line ";
747         } 
748     } elsif (/^\d+$/) {
749         $typeno = $_;
750     } else {
751         warn "bad array stab: $_ in $line ";
752         next STAB;
753     } 
754     #local($wasdef) = defined($type[$typeno]) && $debug;
755     #if ($typedef) { 
756         #print "redefining $type[$typeno] to " if $wasdef;
757         #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
758         #print "$type[$typeno]\n" if $wasdef;
759     #} else {
760         #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
761     #}
762     $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
763     print "type[$arraytype] is $type[$arraytype]\n" if $debug;
764     print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
765     $_;
766 }
767
768
769
770 sub sdecl {
771     local($prefix, $_, $offset) = @_;
772
773     local($fieldname, $scripts, $type, $arraytype, $unknown,
774     $whatis, $pdecl, $upper,$lower, $start,$length) = ();
775     local($typeno,$sou);
776
777
778 SFIELD:
779     while (/^([^;]+);/) {
780         $scripts = '';
781         warn "sdecl $_\n" if $debug;
782         if (s/^([\$\w]+)://) { 
783             $fieldname = $1;
784         } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # 
785             $typeno = &typeno($1);
786             $type[$typeno] = "$prefix.$fieldname";
787             local($name) = "$prefix.$fieldname";
788             &sou($name,$2);
789             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
790             $start = $start{$name};
791             $offset += $sizeof{$name};
792             #print "done with anon, start is $start, offset is $offset\n";
793             #next SFIELD;
794         } else  {
795             warn "weird field $_ of $line" if $debug;
796             next STAB;
797             #$fieldname = &gensym;
798             #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
799         }
800
801         if (/^\d+=ar/) {
802             $_ = &adecl($_);
803         }
804         elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
805             ($start, $length) =  ($2, $3); 
806             &panic("no length?") unless $length;
807             $typeno = &typeno($1) if $1;
808         }
809         elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
810             ($pdecl, $start, $length) =  ($1,$5,$6); 
811             &pdecl($pdecl); 
812         }
813         elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
814             ($typeno, $sou) = ($1, $2);
815             $typeno = &typeno($typeno);
816             if (defined($type[$typeno])) {
817                 warn "now how did we get type $1 in $fieldname of $line?";
818             } else {
819                 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
820                 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
821             };
822             local($name) = "$prefix.$fieldname";
823             &sou($name,$sou);
824             print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
825             $type[$typeno] = "$prefix.$fieldname";
826             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); 
827             $start = $start{$name};
828             $length = $sizeof{$name};
829         }
830         else {
831             warn "can't grok stab for $name ($_) in line $line "; 
832             next STAB; 
833         }
834
835         &panic("no length for $prefix.$fieldname") unless $length;
836         $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
837     }
838     if (s/;\d*,(\d+),(\d+);//) {
839         local($start, $size) = ($1, $2); 
840         $sizeof{$prefix} = $size;
841         print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; 
842         $start{$prefix} = $start; 
843     } 
844     $_;
845 }
846
847 sub edecl {
848     s/;$//;
849     $enum{$name} = $_;
850     $_ = '';
851
852
853 sub resolve_types {
854     local($sou);
855     for $i (0 .. $#type) {
856         next unless defined $type[$i];
857         $_ = $type[$i];
858         unless (/\d/) {
859             print "type[$i] $type[$i]\n" if $debug;
860             next;
861         }
862         print "type[$i] $_ ==> " if $debug;
863         s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
864         s/^(\d+)\&/&type($1)/e; 
865         s/^(\d+)/&type($1)/e; 
866         s/(\*+)([^*]+)(\*+)/$1$3$2/;
867         s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
868         s/^(\d+)([\*\[].*)/&type($1).$2/e;
869         #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
870         $type[$i] = $_;
871         print "$_\n" if $debug;
872     }
873 }
874 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); } 
875
876 sub adjust_start_addrs {
877     for (sort keys %start) {
878         ($basename = $_) =~ s/\.[^.]+$//;
879         $start{$_} += $start{$basename};
880         print "start: $_ @ $start{$_}\n" if $debug;
881     }
882 }
883
884 sub sou {
885     local($what, $_) = @_;
886     /u/ && $isaunion{$what}++;
887     /s/ && $isastruct{$what}++;
888 }
889
890 sub psou {
891     local($what) = @_;
892     local($prefix) = '';
893     if ($isaunion{$what})  {
894         $prefix = 'union ';
895     } elsif ($isastruct{$what})  {
896         $prefix = 'struct ';
897     }
898     $prefix . $what;
899 }
900
901 sub scrunch {
902     local($_) = @_;
903
904     study;
905
906     s/\$//g;
907     s/  / /g;
908     1 while s/(\w) \1/$1$1/g;
909
910     # i wanna say this, but perl resists my efforts:
911     #      s/(\w)(\1+)/$2 . length($1)/ge;
912
913     &quick_scrunch;
914
915     s/ $//;
916
917     $_;
918 }
919
920 sub buildscrunchlist {
921     $scrunch_code = "sub quick_scrunch {\n";
922     for (values %intrinsics) {
923         $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n";
924     } 
925     $scrunch_code .= "}\n";
926     print "$scrunch_code" if $debug;
927     eval $scrunch_code;
928     &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
929
930
931 sub fetch_template {
932     local($mytype) = @_;
933     local($fmt);
934     local($count) = 1;
935
936     &panic("why do you care?") unless $perl;
937
938     if ($mytype =~ s/(\[\d+\])+$//) {
939         $count .= $1;
940     } 
941
942     if ($mytype =~ /\*/) {
943         $fmt = $template{'pointer'};
944     } 
945     elsif (defined $template{$mytype}) {
946         $fmt = $template{$mytype};
947     } 
948     elsif (defined $struct{$mytype}) {
949         if (!defined $template{&psou($mytype)}) {
950             &build_template($mytype) unless $mytype eq $name;
951         } 
952         elsif ($template{&psou($mytype)} !~ /\$$/) {
953             #warn "incomplete template for $mytype\n";
954         } 
955         $fmt = $template{&psou($mytype)} || '?';
956     } 
957     else {
958         warn "unknown fmt for $mytype\n";
959         $fmt = '?';
960     } 
961
962     $fmt x $count . ' ';
963 }
964
965 sub compute_intrinsics {
966     local($TMP) = "/tmp/c2ph-i.$$.c";
967     open (TMP, ">$TMP") || die "can't open $TMP: $!";
968     select(TMP);
969
970     print STDERR "computing intrinsic sizes: " if $trace;
971
972     undef %intrinsics;
973
974     print <<'EOF';
975 main() {
976     char *mask = "%d %s\n";
977 EOF
978
979     for $type (@intrinsics) {
980         next if $type eq 'void';
981         print <<"EOF";
982     printf(mask,sizeof($type), "$type");
983 EOF
984     } 
985
986     print <<'EOF';
987     printf(mask,sizeof(char *), "pointer");
988     exit(0);
989 }
990 EOF
991     close TMP;
992
993     select(STDOUT);
994     open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
995     while (<PIPE>) {
996         chop;
997         split(' ',$_,2);;
998         print "intrinsic $_[1] is size $_[0]\n" if $debug;
999         $sizeof{$_[1]} = $_[0];
1000         $intrinsics{$_[1]} = $template{$_[0]};
1001     } 
1002     close(PIPE) || die "couldn't read intrinsics!";
1003     unlink($TMP, '/tmp/a.out');
1004     print STDERR "done\n" if $trace;
1005
1006
1007 sub scripts2count {
1008     local($_) = @_;
1009
1010     s/^\[//;
1011     s/\]$//;
1012     s/\]\[/*/g;
1013     $_ = eval;
1014     &panic("$_: $@") if $@;
1015     $_;
1016 }
1017
1018 sub system {
1019     print STDERR "@_\n" if $trace;
1020     system @_;
1021
1022
1023 sub build_template { 
1024     local($name) = @_;
1025
1026     &panic("already got a template for $name") if defined $template{$name};
1027
1028     local($build_templates) = 1;
1029
1030     local($lparen) = '(' x $build_recursed;
1031     local($rparen) = ')' x $build_recursed;
1032
1033     print STDERR "$lparen$name$rparen " if $trace;
1034     $build_recursed++;
1035     &pstruct($name,$name,0);
1036     print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1037     --$build_recursed;
1038 }
1039
1040
1041 sub panic {
1042
1043     select(STDERR);
1044
1045     print "\npanic: @_\n";
1046
1047     exit 1 if $] <= 4.003;  # caller broken
1048
1049     local($i,$_);
1050     local($p,$f,$l,$s,$h,$a,@a,@sub);
1051     for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1052         @a = @DB'args;
1053         for (@a) {
1054             if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1055                 $_ = sprintf("%s",$_);
1056             }
1057             else {
1058                 s/'/\\'/g;
1059                 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1060                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1061                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1062             }
1063         }
1064         $w = $w ? '@ = ' : '$ = ';
1065         $a = $h ? '(' . join(', ', @a) . ')' : '';
1066         push(@sub, "$w&$s$a from file $f line $l\n");
1067         last if $signal;
1068     }
1069     for ($i=0; $i <= $#sub; $i++) {
1070         last if $signal;
1071         print $sub[$i];
1072     }
1073     exit 1;
1074
1075
1076 sub squishseq {
1077     local($num);
1078     local($last) = -1e8;
1079     local($string);
1080     local($seq) = '..';
1081
1082     while (defined($num = shift)) {
1083         if ($num == ($last + 1)) {
1084             $string .= $seq unless $inseq++;
1085             $last = $num;
1086             next;
1087         } elsif ($inseq) {
1088             $string .= $last unless $last == -1e8;
1089         }
1090
1091         $string .= ',' if defined $string;
1092         $string .= $num;
1093         $last = $num;
1094         $inseq = 0;
1095     }
1096     $string .= $last if $inseq && $last != -e18;
1097     $string;
1098 }
1099 !NO!SUBS!
1100 $eunicefix c2ph
1101 rm -f pstruct
1102 ln c2ph pstruct