projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
This is my patch patch.1n for perl5.001.
[p5sagit/p5-mst-13.2.git] / c2ph.SH
CommitLineData
11aea360 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.
68decaef 22rm -f c2ph
11aea360 23$spitshell >c2ph <<!GROK!THIS!
c2960299 24#!$binexp/perl
11aea360 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
8e07c86e 40$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
11aea360 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+//;
8e07c86e 286 if (s/\\\\"[d,]+$//) {
287 $saveline .= $line;
288 $savebar = $_;
289 next STAB;
290 }
291 if ($saveline) {
292 s/^"//;
293 $_ = $savebar . $_;
294 $line = $saveline;
295 }
11aea360 296 &stab;
8e07c86e 297 $savebar = $saveline = undef;
11aea360 298 }
299 print STDERR "$.\n" if $trace;
300 unlink $TMP if $TMP;
301
302 &compute_intrinsics if $perl && !$opt_i;
303
304 print STDERR "resolving types\n" if $trace;
305
306 &resolve_types;
307 &adjust_start_addrs;
308
309 $sum = 2 + $type_width + $member_width;
310 $pmask1 = "%-${type_width}s %-${member_width}s";
311 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
312
8e07c86e 313
314
11aea360 315 if ($perl) {
316 # resolve template -- should be in stab define order, but even this isn't enough.
317 print STDERR "\nbuilding type templates: " if $trace;
318 for $i (reverse 0..$#type) {
319 next unless defined($name = $type[$i]);
320 next unless defined $struct{$name};
8e07c86e 321 ($iname = $name) =~ s/\..*//;
11aea360 322 $build_recursed = 0;
323 &build_template($name) unless defined $template{&psou($name)} ||
8e07c86e 324 $opt_s && !$interested{$iname};
11aea360 325 }
326 print STDERR "\n\n" if $trace;
327 }
328
329 print STDERR "dumping structs: " if $trace;
330
8e07c86e 331 local($iam);
332
333
11aea360 334
335 foreach $name (sort keys %struct) {
8e07c86e 336 ($iname = $name) =~ s/\..*//;
337 next if $opt_s && !$interested{$iname};
11aea360 338 print STDERR "$name " if $trace;
339
340 undef @sizeof;
341 undef @typedef;
342 undef @offsetof;
343 undef @indices;
344 undef @typeof;
8e07c86e 345 undef @fieldnames;
11aea360 346
347 $mname = &munge($name);
348
349 $fname = &psou($name);
350
351 print "# " if $perl && $verbose;
352 $pcode = '';
353 print "$fname {\n" if !$perl || $verbose;
354 $template{$fname} = &scrunch($template{$fname}) if $perl;
355 &pstruct($name,$name,0);
356 print "# " if $perl && $verbose;
357 print "}\n" if !$perl || $verbose;
358 print "\n" if $perl && $verbose;
359
360 if ($perl) {
361 print "$pcode";
362
363 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
364
365 print <<EOF;
366sub ${mname}'typedef {
367 local(\$${mname}'index) = shift;
368 defined \$${mname}'index
369 ? \$${mname}'typedef[\$${mname}'index]
370 : \$${mname}'typedef;
371}
372EOF
373
374 print <<EOF;
375sub ${mname}'sizeof {
376 local(\$${mname}'index) = shift;
377 defined \$${mname}'index
378 ? \$${mname}'sizeof[\$${mname}'index]
379 : \$${mname}'sizeof;
380}
381EOF
382
383 print <<EOF;
384sub ${mname}'offsetof {
385 local(\$${mname}'index) = shift;
386 defined \$${mname}index
387 ? \$${mname}'offsetof[\$${mname}'index]
388 : \$${mname}'sizeof;
389}
390EOF
391
392 print <<EOF;
393sub ${mname}'typeof {
394 local(\$${mname}'index) = shift;
395 defined \$${mname}index
396 ? \$${mname}'typeof[\$${mname}'index]
397 : '$name';
398}
399EOF
400
8e07c86e 401 print <<EOF;
402sub ${mname}'fieldnames {
403 \@${mname}'fieldnames;
404}
405EOF
406
407 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
408
409 print <<EOF;
410sub ${mname}'isastruct {
411 '$iam';
412}
413EOF
11aea360 414
415 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
416 . "';\n";
417
418 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
419
420
421 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
422
423 print "\n";
424
425 print "\@${mname}'typedef[\@${mname}'indices] = (",
426 join("\n\t", '', @typedef), "\n );\n\n";
427 print "\@${mname}'sizeof[\@${mname}'indices] = (",
428 join("\n\t", '', @sizeof), "\n );\n\n";
429 print "\@${mname}'offsetof[\@${mname}'indices] = (",
430 join("\n\t", '', @offsetof), "\n );\n\n";
431 print "\@${mname}'typeof[\@${mname}'indices] = (",
432 join("\n\t", '', @typeof), "\n );\n\n";
8e07c86e 433 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
434 join("\n\t", '', @fieldnames), "\n );\n\n";
11aea360 435
436 $template_printed{$fname}++;
437 $size_printed{$fname}++;
438 }
439 print "\n";
440 }
441
442 print STDERR "\n" if $trace;
443
444 unless ($perl && $opt_a) {
8e07c86e 445 print "\n1;\n" if $perl;
11aea360 446 exit;
447 }
448
449
450
451 foreach $name (sort bysizevalue keys %intrinsics) {
452 next if $size_printed{$name};
453 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
454 }
455
456 print "\n";
457
458 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
459
460
461 foreach $name (sort keys %intrinsics) {
462 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
463 }
464
8e07c86e 465 print "\n1;\n" if $perl;
11aea360 466
467 exit;
468}
469
470########################################################################################
471
472
473sub stab {
8e07c86e 474 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
11aea360 475 s/"// || next;
476 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
477
478 next if /^\s*$/;
479
480 $size = $3 if $3;
8e07c86e 481 $_ = $continued . $_ if length($continued);
482 if (s/\\\\$//) {
483 # if last 2 chars of string are '\\' then stab is continued
484 # in next stab entry
485 chop;
486 $continued = $_;
487 next;
488 }
489 $continued = '';
11aea360 490
491
492 $line = $_;
493
494 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
495 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
496 &pdecl($pdecl);
497 next;
498 }
499
500
501
502 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
503 local($ident) = $2;
504 push(@intrinsics, $ident);
505 $typeno = &typeno($3);
506 $type[$typeno] = $ident;
507 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
508 next;
509 }
510
511 if (($name, $typeordef, $typeno, $extra, $struct, $_)
512 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
513 {
514 $typeno = &typeno($typeno); # sun foolery
515 }
516 elsif (/^[\$\w]+:/) {
517 next; # variable
518 }
519 else {
520 warn "can't grok stab: <$_> in: $line " if $_;
521 next;
522 }
523
524 #warn "got size $size for $name\n";
525 $sizeof{$name} = $size if $size;
526
527 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
528
529 $typenos{$name} = $typeno;
530
531 unless (defined $type[$typeno]) {
532 &panic("type 0??") unless $typeno;
533 $type[$typeno] = $name unless defined $type[$typeno];
534 printf "new type $typeno is $name" if $debug;
535 if ($extra =~ /\*/ && defined $type[$struct]) {
536 print ", a typedef for a pointer to " , $type[$struct] if $debug;
537 }
538 } else {
539 printf "%s is type %d", $name, $typeno if $debug;
540 print ", a typedef for " , $type[$typeno] if $debug;
541 }
542 print "\n" if $debug;
543 #next unless $extra =~ /[su*]/;
544
545 #$type[$struct] = $name;
546
547 if ($extra =~ /[us*]/) {
548 &sou($name, $extra);
549 $_ = &sdecl($name, $_, 0);
550 }
551 elsif (/^=ar/) {
552 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
553 $_ = "$typeno$_";
554 $scripts = '';
555 $_ = &adecl($_,1);
556
557 }
558 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
559 push(@intrinsics, $2);
560 $typeno = &typeno($3);
561 $type[$typeno] = $2;
562 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
563 }
8e07c86e 564 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
11aea360 565 &edecl;
566 }
567 else {
568 warn "Funny remainder for $name on line $_ left in $line " if $_;
569 }
570}
571
572sub typeno { # sun thinks types are (0,27) instead of just 27
573 local($_) = @_;
574 s/\(\d+,(\d+)\)/$1/;
575 $_;
576}
577
578sub pstruct {
579 local($what,$prefix,$base) = @_;
580 local($field, $fieldname, $typeno, $count, $offset, $entry);
581 local($fieldtype);
582 local($type, $tname);
583 local($mytype, $mycount, $entry2);
584 local($struct_count) = 0;
585 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
586 local($bits,$bytes);
587 local($template);
588
589
590 local($mname) = &munge($name);
591
592 sub munge {
593 local($_) = @_;
594 s/[\s\$\.]/_/g;
595 $_;
596 }
597
598 local($sname) = &psou($what);
599
600 $nesting++;
601
602 for $field (split(/;/, $struct{$what})) {
603 $pad = $prepad = 0;
604 $entry = '';
605 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
606
607 $type = $type[$typeno];
608
609 $type =~ /([^[]*)(\[.*\])?/;
610 $mytype = $1;
611 $count .= $2;
612 $fieldtype = &psou($mytype);
613
614 local($fname) = &psou($name);
615
616 if ($build_templates) {
617
618 $pad = ($offset - ($lastoffset + $lastlength))/8
619 if defined $lastoffset;
620
621 if (! $finished_template{$sname}) {
622 if ($isaunion{$what}) {
623 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
624 } else {
625 $template{$sname} .= 'x' x $pad . ' ' if $pad;
626 }
627 }
628
8e07c86e 629 $template = &fetch_template($type);
630 &repeat_template($template,$count);
11aea360 631
632 if (! $finished_template{$sname}) {
633 $template{$sname} .= $template;
634 }
635
636 $revpad = $length/8 if $isaunion{$what};
637
638 ($lastoffset, $lastlength) = ($offset, $length);
639
640 } else {
641 print '# ' if $perl && $verbose;
642 $entry = sprintf($pmask1,
643 ' ' x ($nesting * $indent) . $fieldtype,
644 "$prefix.$fieldname" . $count);
645
646 $entry =~ s/(\*+)( )/$2$1/;
647
648 printf $pmask2,
649 $entry,
650 ($base+$offset)/8,
651 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
652 $length/8,
653 ($bits = $length % 8) ? ".$bits": ""
654 if !$perl || $verbose;
655
8e07c86e 656 if ($perl) {
657 $template = &fetch_template($type);
658 &repeat_template($template,$count);
659 }
11aea360 660
661 if ($perl && $nesting == 1) {
8e07c86e 662
11aea360 663 push(@sizeof, int($length/8) .",\t# $fieldname");
664 push(@offsetof, int($offset/8) .",\t# $fieldname");
8e07c86e 665 local($little) = &scrunch($template);
666 push(@typedef, "'$little', \t# $fieldname");
11aea360 667 $type =~ s/(struct|union) //;
8e07c86e 668 push(@typeof, "'$mytype" . ($count ? $count : '') .
11aea360 669 "',\t# $fieldname");
8e07c86e 670 push(@fieldnames, "'$fieldname',");
11aea360 671 }
672
673 print ' ', ' ' x $indent x $nesting, $template
674 if $perl && $verbose;
675
676 print "\n" if !$perl || $verbose;
677
678 }
679 if ($perl) {
680 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
681 $mycount *= &scripts2count($count) if $count;
682 if ($nesting==1 && !$build_templates) {
683 $pcode .= sprintf("sub %-32s { %4d; }\n",
684 "${mname}'${fieldname}", $struct_count);
685 push(@indices, $struct_count);
686 }
687 $struct_count += $mycount;
688 }
689
690
691 &pstruct($type, "$prefix.$fieldname", $base+$offset)
692 if $recurse && defined $struct{$type};
693 }
694
695 $countof{$what} = $struct_count unless defined $countof{$whati};
696
697 $template{$sname} .= '$' if $build_templates;
698 $finished_template{$sname}++;
699
700 if ($build_templates && !defined $sizeof{$name}) {
701 local($fmt) = &scrunch($template{$sname});
702 print STDERR "no size for $name, punting with $fmt..." if $debug;
703 eval '$sizeof{$name} = length(pack($fmt, ()))';
704 if ($@) {
705 chop $@;
706 warn "couldn't get size for \$name: $@";
707 } else {
708 print STDERR $sizeof{$name}, "\n" if $debUg;
709 }
710 }
711
712 --$nesting;
713}
714
715
716sub psize {
717 local($me) = @_;
718 local($amstruct) = $struct{$me} ? 'struct ' : '';
719
720 print '$sizeof{\'', $amstruct, $me, '\'} = ';
721 printf "%d;\n", $sizeof{$me};
722}
723
724sub pdecl {
725 local($pdecl) = @_;
726 local(@pdecls);
727 local($tname);
728
729 warn "pdecl: $pdecl\n" if $debug;
730
731 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
732 $pdecl =~ s/\*//g;
733 @pdecls = split(/=/, $pdecl);
734 $typeno = $pdecls[0];
735 $tname = pop @pdecls;
736
737 if ($tname =~ s/^f//) { $tname = "$tname&"; }
738 #else { $tname = "$tname*"; }
739
740 for (reverse @pdecls) {
741 $tname .= s/^f// ? "&" : "*";
742 #$tname =~ s/^f(.*)/$1&/;
743 print "type[$_] is $tname\n" if $debug;
744 $type[$_] = $tname unless defined $type[$_];
745 }
746}
747
748
749
750sub adecl {
751 ($arraytype, $unknown, $lower, $upper) = ();
752 #local($typeno);
753 # global $typeno, @type
754 local($_, $typedef) = @_;
755
8e07c86e 756 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
11aea360 757 ($arraytype, $unknown) = ($2, $3);
8e07c86e 758 $arraytype = &typeno($arraytype);
759 $unknown = &typeno($unknown);
11aea360 760 if (s/^(\d+);(\d+);//) {
761 ($lower, $upper) = ($1, $2);
762 $scripts .= '[' . ($upper+1) . ']';
763 } else {
764 warn "can't find array bounds: $_";
765 }
766 }
8e07c86e 767 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
11aea360 768 ($start, $length) = ($2, $3);
8e07c86e 769 $whatis = $1;
770 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
771 $typeno = &typeno($1);
11aea360 772 &pdecl($whatis);
773 } else {
8e07c86e 774 $typeno = &typeno($whatis);
11aea360 775 }
776 } elsif (s/^(\d+)(=[*suf]\d*)//) {
777 local($whatis) = $2;
778
779 if ($whatis =~ /[f*]/) {
780 &pdecl($whatis);
781 } elsif ($whatis =~ /[su]/) { #
782 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
783 if $debug;
784 #$type[$typeno] = $name unless defined $type[$typeno];
785 ##printf "new type $typeno is $name" if $debug;
786 $typeno = $1;
787 $type[$typeno] = "$prefix.$fieldname";
788 local($name) = $type[$typeno];
789 &sou($name, $whatis);
790 $_ = &sdecl($name, $_, $start+$offset);
791 1;
792 $start = $start{$name};
793 $offset = $sizeof{$name};
794 $length = $offset;
795 } else {
796 warn "what's this? $whatis in $line ";
797 }
798 } elsif (/^\d+$/) {
799 $typeno = $_;
800 } else {
801 warn "bad array stab: $_ in $line ";
802 next STAB;
803 }
804 #local($wasdef) = defined($type[$typeno]) && $debug;
805 #if ($typedef) {
806 #print "redefining $type[$typeno] to " if $wasdef;
807 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
808 #print "$type[$typeno]\n" if $wasdef;
809 #} else {
810 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
811 #}
812 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
813 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
814 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
815 $_;
816}
817
818
819
820sub sdecl {
821 local($prefix, $_, $offset) = @_;
822
823 local($fieldname, $scripts, $type, $arraytype, $unknown,
824 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
825 local($typeno,$sou);
826
827
828SFIELD:
829 while (/^([^;]+);/) {
830 $scripts = '';
831 warn "sdecl $_\n" if $debug;
832 if (s/^([\$\w]+)://) {
833 $fieldname = $1;
834 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
835 $typeno = &typeno($1);
836 $type[$typeno] = "$prefix.$fieldname";
837 local($name) = "$prefix.$fieldname";
838 &sou($name,$2);
839 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
840 $start = $start{$name};
841 $offset += $sizeof{$name};
842 #print "done with anon, start is $start, offset is $offset\n";
843 #next SFIELD;
844 } else {
845 warn "weird field $_ of $line" if $debug;
846 next STAB;
847 #$fieldname = &gensym;
848 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
849 }
850
8e07c86e 851 if (/^(\d+|\(\d+,\d+\))=ar/) {
11aea360 852 $_ = &adecl($_);
853 }
854 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
8e07c86e 855 ($start, $length) = ($2, $3);
856 &panic("no length?") unless $length;
857 $typeno = &typeno($1) if $1;
858 }
859 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
11aea360 860 ($start, $length) = ($2, $3);
861 &panic("no length?") unless $length;
862 $typeno = &typeno($1) if $1;
863 }
864 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
865 ($pdecl, $start, $length) = ($1,$5,$6);
866 &pdecl($pdecl);
867 }
868 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
869 ($typeno, $sou) = ($1, $2);
870 $typeno = &typeno($typeno);
871 if (defined($type[$typeno])) {
872 warn "now how did we get type $1 in $fieldname of $line?";
873 } else {
874 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
875 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
876 };
877 local($name) = "$prefix.$fieldname";
878 &sou($name,$sou);
879 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
880 $type[$typeno] = "$prefix.$fieldname";
881 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
882 $start = $start{$name};
883 $length = $sizeof{$name};
884 }
885 else {
886 warn "can't grok stab for $name ($_) in line $line ";
887 next STAB;
888 }
889
890 &panic("no length for $prefix.$fieldname") unless $length;
891 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
892 }
893 if (s/;\d*,(\d+),(\d+);//) {
894 local($start, $size) = ($1, $2);
895 $sizeof{$prefix} = $size;
896 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
897 $start{$prefix} = $start;
898 }
899 $_;
900}
901
902sub edecl {
903 s/;$//;
904 $enum{$name} = $_;
905 $_ = '';
906}
907
908sub resolve_types {
909 local($sou);
910 for $i (0 .. $#type) {
911 next unless defined $type[$i];
912 $_ = $type[$i];
913 unless (/\d/) {
914 print "type[$i] $type[$i]\n" if $debug;
915 next;
916 }
917 print "type[$i] $_ ==> " if $debug;
918 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
919 s/^(\d+)\&/&type($1)/e;
920 s/^(\d+)/&type($1)/e;
921 s/(\*+)([^*]+)(\*+)/$1$3$2/;
922 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
923 s/^(\d+)([\*\[].*)/&type($1).$2/e;
924 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
925 $type[$i] = $_;
926 print "$_\n" if $debug;
927 }
928}
929sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
930
931sub adjust_start_addrs {
932 for (sort keys %start) {
933 ($basename = $_) =~ s/\.[^.]+$//;
934 $start{$_} += $start{$basename};
935 print "start: $_ @ $start{$_}\n" if $debug;
936 }
937}
938
939sub sou {
940 local($what, $_) = @_;
941 /u/ && $isaunion{$what}++;
942 /s/ && $isastruct{$what}++;
943}
944
945sub psou {
946 local($what) = @_;
947 local($prefix) = '';
948 if ($isaunion{$what}) {
949 $prefix = 'union ';
950 } elsif ($isastruct{$what}) {
951 $prefix = 'struct ';
952 }
953 $prefix . $what;
954}
955
956sub scrunch {
957 local($_) = @_;
958
8e07c86e 959 return '' if $_ eq '';
960
11aea360 961 study;
962
963 s/\$//g;
964 s/ / /g;
965 1 while s/(\w) \1/$1$1/g;
966
967 # i wanna say this, but perl resists my efforts:
968 # s/(\w)(\1+)/$2 . length($1)/ge;
969
970 &quick_scrunch;
971
972 s/ $//;
973
974 $_;
975}
976
977sub buildscrunchlist {
978 $scrunch_code = "sub quick_scrunch {\n";
979 for (values %intrinsics) {
8e07c86e 980 $scrunch_code .= "\ts/($_\{2,})/'$_' . length(\$1)/ge;\n";
11aea360 981 }
982 $scrunch_code .= "}\n";
983 print "$scrunch_code" if $debug;
984 eval $scrunch_code;
985 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
986}
987
988sub fetch_template {
989 local($mytype) = @_;
990 local($fmt);
991 local($count) = 1;
992
993 &panic("why do you care?") unless $perl;
994
995 if ($mytype =~ s/(\[\d+\])+$//) {
996 $count .= $1;
997 }
998
999 if ($mytype =~ /\*/) {
1000 $fmt = $template{'pointer'};
1001 }
1002 elsif (defined $template{$mytype}) {
1003 $fmt = $template{$mytype};
1004 }
1005 elsif (defined $struct{$mytype}) {
1006 if (!defined $template{&psou($mytype)}) {
1007 &build_template($mytype) unless $mytype eq $name;
1008 }
1009 elsif ($template{&psou($mytype)} !~ /\$$/) {
1010 #warn "incomplete template for $mytype\n";
1011 }
1012 $fmt = $template{&psou($mytype)} || '?';
1013 }
1014 else {
1015 warn "unknown fmt for $mytype\n";
1016 $fmt = '?';
1017 }
1018
1019 $fmt x $count . ' ';
1020}
1021
1022sub compute_intrinsics {
1023 local($TMP) = "/tmp/c2ph-i.$$.c";
1024 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1025 select(TMP);
1026
1027 print STDERR "computing intrinsic sizes: " if $trace;
1028
1029 undef %intrinsics;
1030
1031 print <<'EOF';
1032main() {
1033 char *mask = "%d %s\n";
1034EOF
1035
1036 for $type (@intrinsics) {
8e07c86e 1037 next if !type || $type eq 'void' || $type =~ /complex/; # sun stuff
11aea360 1038 print <<"EOF";
1039 printf(mask,sizeof($type), "$type");
1040EOF
1041 }
1042
1043 print <<'EOF';
1044 printf(mask,sizeof(char *), "pointer");
1045 exit(0);
1046}
1047EOF
1048 close TMP;
1049
1050 select(STDOUT);
1051 open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
1052 while (<PIPE>) {
1053 chop;
1054 split(' ',$_,2);;
1055 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1056 $sizeof{$_[1]} = $_[0];
1057 $intrinsics{$_[1]} = $template{$_[0]};
1058 }
1059 close(PIPE) || die "couldn't read intrinsics!";
1060 unlink($TMP, '/tmp/a.out');
1061 print STDERR "done\n" if $trace;
1062}
1063
1064sub scripts2count {
1065 local($_) = @_;
1066
1067 s/^\[//;
1068 s/\]$//;
1069 s/\]\[/*/g;
1070 $_ = eval;
1071 &panic("$_: $@") if $@;
1072 $_;
1073}
1074
1075sub system {
1076 print STDERR "@_\n" if $trace;
1077 system @_;
1078}
1079
1080sub build_template {
1081 local($name) = @_;
1082
1083 &panic("already got a template for $name") if defined $template{$name};
1084
1085 local($build_templates) = 1;
1086
1087 local($lparen) = '(' x $build_recursed;
1088 local($rparen) = ')' x $build_recursed;
1089
1090 print STDERR "$lparen$name$rparen " if $trace;
1091 $build_recursed++;
1092 &pstruct($name,$name,0);
1093 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1094 --$build_recursed;
1095}
1096
1097
1098sub panic {
1099
1100 select(STDERR);
1101
1102 print "\npanic: @_\n";
1103
1104 exit 1 if $] <= 4.003; # caller broken
1105
1106 local($i,$_);
1107 local($p,$f,$l,$s,$h,$a,@a,@sub);
1108 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1109 @a = @DB'args;
1110 for (@a) {
1111 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1112 $_ = sprintf("%s",$_);
1113 }
1114 else {
1115 s/'/\\'/g;
1116 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1117 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1118 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1119 }
1120 }
1121 $w = $w ? '@ = ' : '$ = ';
1122 $a = $h ? '(' . join(', ', @a) . ')' : '';
1123 push(@sub, "$w&$s$a from file $f line $l\n");
1124 last if $signal;
1125 }
1126 for ($i=0; $i <= $#sub; $i++) {
1127 last if $signal;
1128 print $sub[$i];
1129 }
1130 exit 1;
1131}
1132
1133sub squishseq {
1134 local($num);
1135 local($last) = -1e8;
1136 local($string);
1137 local($seq) = '..';
1138
1139 while (defined($num = shift)) {
1140 if ($num == ($last + 1)) {
1141 $string .= $seq unless $inseq++;
1142 $last = $num;
1143 next;
1144 } elsif ($inseq) {
1145 $string .= $last unless $last == -1e8;
1146 }
1147
1148 $string .= ',' if defined $string;
1149 $string .= $num;
1150 $last = $num;
1151 $inseq = 0;
1152 }
1153 $string .= $last if $inseq && $last != -e18;
1154 $string;
1155}
8e07c86e 1156
1157sub repeat_template {
1158 # local($template, $scripts) = @_; have to change caller's values
1159
1160 if ( $_[1] ) {
1161 local($ncount) = &scripts2count($_[1]);
1162 if ($_[0] =~ /^\s*c\s*$/i) {
1163 $_[0] = "A$ncount ";
1164 $_[1] = '';
1165 } else {
1166 $_[0] = $template x $ncount;
1167 }
1168 }
1169}
Unnamed repository; edit this file to name it for gitweb.