This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Okay, here's your official unofficial closure leak patch
[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.
68decaef 22rm -f c2ph
11aea360
LW		 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
a0d0e21e 40$RCSID = 'c2ph.SH';
11aea360
LW		 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
Unnamed repository; edit this file 'description' to name the repository.