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