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