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