source: trunk/third/perl/c2ph.SH @ 9056

Revision 9056, 26.0 KB checked in by ghudson, 28 years ago (diff)
Specify current directory for config.sh; . may not be in our path.
Line 
1case $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    ;;
11esac
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.
14case "$0" in
15*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
16esac
17echo "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.
22rm -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 = '$RCSfile: c2ph.SH,v $$Revision: 1.2 $$Date: 1996-10-05 18:29:15 $';
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;
79delete $intrinsics{'neganull'};
80delete $intrinsics{'bit'};
81delete $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
120require 'getopts.pl';
121
122eval '$'.$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
132if ($opt_w) {
133    ($type_width, $member_width, $offset_width) = (45, 35, 8);
134}
135if ($opt_x) {
136    ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
137}
138
139eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
140
141sub PLUMBER {
142    select(STDERR);
143    print "oops, apperent pager foulup\n";
144    $isatty++;
145    &usage(1);
146}
147
148sub 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
168Options:
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
186Var Name        Default Value    Meaning
187
188EOF
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
220EOF
221    close PIPE;
222    exit 1;
223}
224
225sub defvar {
226    local($var, $msg) = @_;
227    printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;
228}
229
230$recurse = 1;
231
232if (@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
259if ($opt_s) {
260    for (split(/[\s,]+/, $opt_s)) {
261        $interested{$_}++;
262    }
263}
264
265
266$| = 1 if $debug;
267
268main: {
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
278STAB: 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;
347sub ${mname}'typedef {
348    local(\$${mname}'index) = shift;
349    defined \$${mname}'index
350        ? \$${mname}'typedef[\$${mname}'index]
351        : \$${mname}'typedef;
352}
353EOF
354
355            print <<EOF;
356sub ${mname}'sizeof {
357    local(\$${mname}'index) = shift;
358    defined \$${mname}'index
359        ? \$${mname}'sizeof[\$${mname}'index]
360        : \$${mname}'sizeof;
361}
362EOF
363
364            print <<EOF;
365sub ${mname}'offsetof {
366    local(\$${mname}'index) = shift;
367    defined \$${mname}index
368        ? \$${mname}'offsetof[\$${mname}'index]
369        : \$${mname}'sizeof;
370}
371EOF
372
373            print <<EOF;
374sub ${mname}'typeof {
375    local(\$${mname}'index) = shift;
376    defined \$${mname}index
377        ? \$${mname}'typeof[\$${mname}'index]
378        : '$name';
379}
380EOF
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
439sub 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
529sub typeno {  # sun thinks types are (0,27) instead of just 27
530    local($_) = @_;
531    s/\(\d+,(\d+)\)/$1/;
532    $_;
533}
534
535sub 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
668sub psize {
669    local($me) = @_;
670    local($amstruct) = $struct{$me} ?  'struct ' : '';
671
672    print '$sizeof{\'', $amstruct, $me, '\'} = ';
673    printf "%d;\n", $sizeof{$me};
674}
675
676sub 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
702sub 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
770sub 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
778SFIELD:
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
847sub edecl {
848    s/;$//;
849    $enum{$name} = $_;
850    $_ = '';
851}
852
853sub 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}
874sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
875
876sub 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
884sub sou {
885    local($what, $_) = @_;
886    /u/ && $isaunion{$what}++;
887    /s/ && $isastruct{$what}++;
888}
889
890sub 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
901sub 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
920sub 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
931sub 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
965sub 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';
975main() {
976    char *mask = "%d %s\n";
977EOF
978
979    for $type (@intrinsics) {
980        next if $type eq 'void';
981        print <<"EOF";
982    printf(mask,sizeof($type), "$type");
983EOF
984    }
985
986    print <<'EOF';
987    printf(mask,sizeof(char *), "pointer");
988    exit(0);
989}
990EOF
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
1007sub scripts2count {
1008    local($_) = @_;
1009
1010    s/^\[//;
1011    s/\]$//;
1012    s/\]\[/*/g;
1013    $_ = eval;
1014    &panic("$_: $@") if $@;
1015    $_;
1016}
1017
1018sub system {
1019    print STDERR "@_\n" if $trace;
1020    system @_;
1021}
1022
1023sub 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
1041sub 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
1076sub 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
1101rm -f pstruct
1102ln c2ph pstruct
Note: See TracBrowser for help on using the repository browser.