This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c2ph.PL fix
[perl5.git] / utils / c2ph.PL
1 #!/usr/local/bin/perl
2
3 use Config;
4 use 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.
15 chdir dirname($0);
16 $file = basename($0, '.PL');
17 $file .= '.com' if $^O eq 'VMS';
18
19 open OUT,">$file" or die "Can't create $file: $!";
20
21 print "Extracting $file (with variable substitutions)\n";
22
23 # In this section, perl variables will be expanded during extraction.
24 # You can use $Config{...} to use Configure variables.
25
26 print OUT <<"!GROK!THIS!";
27 $Config{startperl}
28     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
29         if \$running_under_some_shell;
30 !GROK!THIS!
31
32 # In the following, perl variables are not expanded during extraction.
33
34 print OUT <<'!NO!SUBS!';
35 #
36 #
37 #   c2ph (aka pstruct)
38 #   Tom Christiansen, <tchrist@convex.com>
39 #
40 #   As pstruct, dump C structures as generated from 'cc -g -S' stabs.
41 #   As c2ph, do this PLUS generate perl code for getting at the structures.
42 #
43 #   See the usage message for more.  If this isn't enough, read the code.
44 #
45
46 =head1 NAME
47
48 c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
49
50 =head1 SYNOPSIS
51
52     c2ph [-dpnP] [var=val] [files ...]
53
54 =head2 OPTIONS
55
56     Options:
57
58     -w  wide; short for: type_width=45 member_width=35 offset_width=8
59     -x  hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
60
61     -n  do not generate perl code  (default when invoked as pstruct)
62     -p  generate perl code         (default when invoked as c2ph)
63     -v  generate perl code, with C decls as comments
64
65     -i  do NOT recompute sizes for intrinsic datatypes
66     -a  dump information on intrinsics also
67
68     -t  trace execution
69     -d  spew reams of debugging output
70
71     -slist  give comma-separated list a structures to dump
72
73 =head1 DESCRIPTION
74
75 The following is the old c2ph.doc documentation by Tom Christiansen
76 <tchrist@perl.com>
77 Date: 25 Jul 91 08:10:21 GMT
78
79 Once upon a time, I wrote a program called pstruct.  It was a perl
80 program that tried to parse out C structures and display their member
81 offsets for you.  This was especially useful for people looking at
82 binary dumps or poking around the kernel.
83
84 Pstruct was not a pretty program.  Neither was it particularly robust.
85 The problem, you see, was that the C compiler was much better at parsing
86 C than I could ever hope to be.
87
88 So I got smart:  I decided to be lazy and let the C compiler parse the C,
89 which would spit out debugger stabs for me to read.  These were much
90 easier to parse.  It's still not a pretty program, but at least it's more
91 robust.
92
93 Pstruct takes any .c or .h files, or preferably .s ones, since that's
94 the format it is going to massage them into anyway, and spits out
95 listings like this:
96
97  struct tty {
98    int                          tty.t_locker                         000      4
99    int                          tty.t_mutex_index                    004      4
100    struct tty *                 tty.t_tp_virt                        008      4
101    struct clist                 tty.t_rawq                           00c     20
102      int                        tty.t_rawq.c_cc                      00c      4
103      int                        tty.t_rawq.c_cmax                    010      4
104      int                        tty.t_rawq.c_cfx                     014      4
105      int                        tty.t_rawq.c_clx                     018      4
106      struct tty *               tty.t_rawq.c_tp_cpu                  01c      4
107      struct tty *               tty.t_rawq.c_tp_iop                  020      4
108      unsigned char *            tty.t_rawq.c_buf_cpu                 024      4
109      unsigned char *            tty.t_rawq.c_buf_iop                 028      4
110    struct clist                 tty.t_canq                           02c     20
111      int                        tty.t_canq.c_cc                      02c      4
112      int                        tty.t_canq.c_cmax                    030      4
113      int                        tty.t_canq.c_cfx                     034      4
114      int                        tty.t_canq.c_clx                     038      4
115      struct tty *               tty.t_canq.c_tp_cpu                  03c      4
116      struct tty *               tty.t_canq.c_tp_iop                  040      4
117      unsigned char *            tty.t_canq.c_buf_cpu                 044      4
118      unsigned char *            tty.t_canq.c_buf_iop                 048      4
119    struct clist                 tty.t_outq                           04c     20
120      int                        tty.t_outq.c_cc                      04c      4
121      int                        tty.t_outq.c_cmax                    050      4
122      int                        tty.t_outq.c_cfx                     054      4
123      int                        tty.t_outq.c_clx                     058      4
124      struct tty *               tty.t_outq.c_tp_cpu                  05c      4
125      struct tty *               tty.t_outq.c_tp_iop                  060      4
126      unsigned char *            tty.t_outq.c_buf_cpu                 064      4
127      unsigned char *            tty.t_outq.c_buf_iop                 068      4
128    (*int)()                     tty.t_oproc_cpu                      06c      4
129    (*int)()                     tty.t_oproc_iop                      070      4
130    (*int)()                     tty.t_stopproc_cpu                   074      4
131    (*int)()                     tty.t_stopproc_iop                   078      4
132    struct thread *              tty.t_rsel                           07c      4
133
134 etc.
135
136
137 Actually, this was generated by a particular set of options.  You can control
138 the formatting of each column, whether you prefer wide or fat, hex or decimal,
139 leading zeroes or whatever.
140
141 All you need to be able to use this is a C compiler than generates
142 BSD/GCC-style stabs.  The B<-g> option on native BSD compilers and GCC
143 should get this for you.
144
145 To learn more, just type a bogus option, like B<-\?>, and a long usage message
146 will be provided.  There are a fair number of possibilities.
147
148 If you're only a C programmer, than this is the end of the message for you.
149 You can quit right now, and if you care to, save off the source and run it
150 when you feel like it.  Or not.
151
152
153
154 But if you're a perl programmer, then for you I have something much more
155 wondrous than just a structure offset printer.
156
157 You see, if you call pstruct by its other incybernation, c2ph, you have a code
158 generator that translates C code into perl code!  Well, structure and union
159 declarations at least, but that's quite a bit.
160
161 Prior to this point, anyone programming in perl who wanted to interact
162 with C programs, like the kernel, was forced to guess the layouts of
163 the C strutures, and then hardwire these into his program.  Of course,
164 when you took your wonderfully crafted program to a system where the
165 sgtty structure was laid out differently, you program broke.  Which is
166 a shame.
167
168 We've had Larry's h2ph translator, which helped, but that only works on
169 cpp symbols, not real C, which was also very much needed.  What I offer
170 you is a symbolic way of getting at all the C structures.  I've couched
171 them in terms of packages and functions.  Consider the following program:
172
173     #!/usr/local/bin/perl
174
175     require 'syscall.ph';
176     require 'sys/time.ph';
177     require 'sys/resource.ph';
178
179     $ru = "\0" x &rusage'sizeof();
180
181     syscall(&SYS_getrusage, &RUSAGE_SELF, $ru)      && die "getrusage: $!";
182
183     @ru = unpack($t = &rusage'typedef(), $ru);
184
185     $utime =  $ru[ &rusage'ru_utime + &timeval'tv_sec  ]
186            + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
187
188     $stime =  $ru[ &rusage'ru_stime + &timeval'tv_sec  ]
189            + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
190
191     printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
192
193
194 As you see, the name of the package is the name of the structure.  Regular
195 fields are just their own names.  Plus the following accessor functions are
196 provided for your convenience:
197
198     struct      This takes no arguments, and is merely the number of first-level
199                 elements in the structure.  You would use this for indexing
200                 into arrays of structures, perhaps like this
201
202
203                     $usec = $u[ &user'u_utimer
204                                 + (&ITIMER_VIRTUAL * &itimerval'struct)
205                                 + &itimerval'it_value
206                                 + &timeval'tv_usec
207                               ];
208
209     sizeof      Returns the bytes in the structure, or the member if
210                 you pass it an argument, such as
211
212                         &rusage'sizeof(&rusage'ru_utime)
213
214     typedef     This is the perl format definition for passing to pack and
215                 unpack.  If you ask for the typedef of a nothing, you get
216                 the whole structure, otherwise you get that of the member
217                 you ask for.  Padding is taken care of, as is the magic to
218                 guarantee that a union is unpacked into all its aliases.
219                 Bitfields are not quite yet supported however.
220
221     offsetof    This function is the byte offset into the array of that
222                 member.  You may wish to use this for indexing directly
223                 into the packed structure with vec() if you're too lazy
224                 to unpack it.
225
226     typeof      Not to be confused with the typedef accessor function, this
227                 one returns the C type of that field.  This would allow
228                 you to print out a nice structured pretty print of some
229                 structure without knoning anything about it beforehand.
230                 No args to this one is a noop.  Someday I'll post such
231                 a thing to dump out your u structure for you.
232
233
234 The way I see this being used is like basically this:
235
236         % h2ph <some_include_file.h  >  /usr/lib/perl/tmp.ph
237         % c2ph  some_include_file.h  >> /usr/lib/perl/tmp.ph
238         % install
239
240 It's a little tricker with c2ph because you have to get the includes right.
241 I can't know this for your system, but it's not usually too terribly difficult.
242
243 The code isn't pretty as I mentioned  -- I never thought it would be a 1000-
244 line program when I started, or I might not have begun. :-)  But I would have
245 been less cavalier in how the parts of the program communicated with each
246 other, etc.  It might also have helped if I didn't have to divine the makeup
247 of the stabs on the fly, and then account for micro differences between my
248 compiler and gcc.
249
250 Anyway, here it is.  Should run on perl v4 or greater.  Maybe less.
251
252
253  --tom
254
255 =cut
256
257 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
258
259
260 ######################################################################
261
262 # some handy data definitions.   many of these can be reset later.
263
264 $bitorder = 'b';  # ascending; set to B for descending bit fields
265
266 %intrinsics =
267 %template = (
268     'char',                     'c',
269     'unsigned char',            'C',
270     'short',                    's',
271     'short int',                's',
272     'unsigned short',           'S',
273     'unsigned short int',       'S',
274     'short unsigned int',       'S',
275     'int',                      'i',
276     'unsigned int',             'I',
277     'long',                     'l',
278     'long int',                 'l',
279     'unsigned long',            'L',
280     'unsigned long',            'L',
281     'long unsigned int',        'L',
282     'unsigned long int',        'L',
283     'long long',                'q',
284     'long long int',            'q',
285     'unsigned long long',       'Q',
286     'unsigned long long int',   'Q',
287     'float',                    'f',
288     'double',                   'd',
289     'pointer',                  'p',
290     'null',                     'x',
291     'neganull',                 'X',
292     'bit',                      $bitorder,
293 );
294
295 &buildscrunchlist;
296 delete $intrinsics{'neganull'};
297 delete $intrinsics{'bit'};
298 delete $intrinsics{'null'};
299
300 # use -s to recompute sizes
301 %sizeof = (
302     'char',                     '1',
303     'unsigned char',            '1',
304     'short',                    '2',
305     'short int',                '2',
306     'unsigned short',           '2',
307     'unsigned short int',       '2',
308     'short unsigned int',       '2',
309     'int',                      '4',
310     'unsigned int',             '4',
311     'long',                     '4',
312     'long int',                 '4',
313     'unsigned long',            '4',
314     'unsigned long int',        '4',
315     'long unsigned int',        '4',
316     'long long',                '8',
317     'long long int',            '8',
318     'unsigned long long',       '8',
319     'unsigned long long int',   '8',
320     'float',                    '4',
321     'double',                   '8',
322     'pointer',                  '4',
323 );
324
325 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
326
327 ($offset_fmt, $size_fmt) = ('d', 'd');
328
329 $indent = 2;
330
331 $CC = 'cc';
332 $CFLAGS = '-g -S';
333 $DEFINES = '';
334
335 $perl++ if $0 =~ m#/?c2ph$#;
336
337 require 'getopts.pl';
338
339 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
340
341 &Getopts('aixdpvtnws:') || &usage(0);
342
343 $opt_d && $debug++;
344 $opt_t && $trace++;
345 $opt_p && $perl++;
346 $opt_v && $verbose++;
347 $opt_n && ($perl = 0);
348
349 if ($opt_w) {
350     ($type_width, $member_width, $offset_width) = (45, 35, 8);
351 }
352 if ($opt_x) {
353     ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
354 }
355
356 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
357
358 sub PLUMBER {
359     select(STDERR);
360     print "oops, apperent pager foulup\n";
361     $isatty++;
362     &usage(1);
363 }
364
365 sub usage {
366     local($oops) = @_;
367     unless (-t STDOUT) {
368         select(STDERR);
369     } elsif (!$oops) {
370         $isatty++;
371         $| = 1;
372         print "hit <RETURN> for further explanation: ";
373         <STDIN>;
374         open (PIPE, "|". ($ENV{PAGER} || 'more'));
375         $SIG{PIPE} = PLUMBER;
376         select(PIPE);
377     }
378
379     print "usage: $0 [-dpnP] [var=val] [files ...]\n";
380
381     exit unless $isatty;
382
383     print <<EOF;
384
385 Options:
386
387 -w      wide; short for: type_width=45 member_width=35 offset_width=8
388 -x      hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
389
390 -n      do not generate perl code  (default when invoked as pstruct)
391 -p      generate perl code         (default when invoked as c2ph)
392 -v      generate perl code, with C decls as comments
393
394 -i      do NOT recompute sizes for intrinsic datatypes
395 -a      dump information on intrinsics also
396
397 -t      trace execution
398 -d      spew reams of debugging output
399
400 -slist  give comma-separated list a structures to dump
401
402
403 Var Name        Default Value    Meaning
404
405 EOF
406
407     &defvar('CC', 'which_compiler to call');
408     &defvar('CFLAGS', 'how to generate *.s files with stabs');
409     &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
410
411     print "\n";
412
413     &defvar('type_width', 'width of type field   (column 1)');
414     &defvar('member_width', 'width of member field (column 2)');
415     &defvar('offset_width', 'width of offset field (column 3)');
416     &defvar('size_width', 'width of size field   (column 4)');
417
418     print "\n";
419
420     &defvar('offset_fmt', 'sprintf format type for offset');
421     &defvar('size_fmt', 'sprintf format type for size');
422
423     print "\n";
424
425     &defvar('indent', 'how far to indent each nesting level');
426
427    print <<'EOF';
428
429     If any *.[ch] files are given, these will be catted together into
430     a temporary *.c file and sent through:
431             $CC $CFLAGS $DEFINES
432     and the resulting *.s groped for stab information.  If no files are
433     supplied, then stdin is read directly with the assumption that it
434     contains stab information.  All other liens will be ignored.  At
435     most one *.s file should be supplied.
436
437 EOF
438     close PIPE;
439     exit 1;
440 }
441
442 sub defvar {
443     local($var, $msg) = @_;
444     printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;
445 }
446
447 $recurse = 1;
448
449 if (@ARGV) {
450     if (grep(!/\.[csh]$/,@ARGV)) {
451         warn "Only *.[csh] files expected!\n";
452         &usage;
453     }
454     elsif (grep(/\.s$/,@ARGV)) {
455         if (@ARGV > 1) {
456             warn "Only one *.s file allowed!\n";
457             &usage;
458         }
459     }
460     elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
461         local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
462         $chdir = "cd $dir; " if $dir;
463         &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
464         $ARGV[0] =~ s/\.c$/.s/;
465     }
466     else {
467         $TMP = "/tmp/c2ph.$$.c";
468         &system("cat @ARGV > $TMP") && exit 1;
469         &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
470         unlink $TMP;
471         $TMP =~ s/\.c$/.s/;
472         @ARGV = ($TMP);
473     }
474 }
475
476 if ($opt_s) {
477     for (split(/[\s,]+/, $opt_s)) {
478         $interested{$_}++;
479     }
480 }
481
482
483 $| = 1 if $debug;
484
485 main: {
486
487     if ($trace) {
488         if (-t && !@ARGV) {
489             print STDERR "reading from your keyboard: ";
490         } else {
491             print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
492         }
493     }
494
495 STAB: while (<>) {
496         if ($trace && !($. % 10)) {
497             $lineno = $..'';
498             print STDERR $lineno, "\b" x length($lineno);
499         }
500         next unless /^\s*\.stabs\s+/;
501         $line = $_;
502         s/^\s*\.stabs\s+//;
503         if (s/\\\\"[d,]+$//) {
504             $saveline .= $line;
505             $savebar  = $_;
506             next STAB;
507         }
508         if ($saveline) {
509             s/^"//;
510             $_ = $savebar . $_;
511             $line = $saveline;
512         }
513         &stab;
514         $savebar = $saveline = undef;
515     }
516     print STDERR "$.\n" if $trace;
517     unlink $TMP if $TMP;
518
519     &compute_intrinsics if $perl && !$opt_i;
520
521     print STDERR "resolving types\n" if $trace;
522
523     &resolve_types;
524     &adjust_start_addrs;
525
526     $sum = 2 + $type_width + $member_width;
527     $pmask1 = "%-${type_width}s %-${member_width}s";
528     $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
529
530
531
532     if ($perl) {
533         # resolve template -- should be in stab define order, but even this isn't enough.
534         print STDERR "\nbuilding type templates: " if $trace;
535         for $i (reverse 0..$#type) {
536             next unless defined($name = $type[$i]);
537             next unless defined $struct{$name};
538             ($iname = $name) =~ s/\..*//;
539             $build_recursed = 0;
540             &build_template($name) unless defined $template{&psou($name)} ||
541                                         $opt_s && !$interested{$iname};
542         }
543         print STDERR "\n\n" if $trace;
544     }
545
546     print STDERR "dumping structs: " if $trace;
547
548     local($iam);
549
550
551
552     foreach $name (sort keys %struct) {
553         ($iname = $name) =~ s/\..*//;
554         next if $opt_s && !$interested{$iname};
555         print STDERR "$name " if $trace;
556
557         undef @sizeof;
558         undef @typedef;
559         undef @offsetof;
560         undef @indices;
561         undef @typeof;
562         undef @fieldnames;
563
564         $mname = &munge($name);
565
566         $fname = &psou($name);
567
568         print "# " if $perl && $verbose;
569         $pcode = '';
570         print "$fname {\n" if !$perl || $verbose;
571         $template{$fname} = &scrunch($template{$fname}) if $perl;
572         &pstruct($name,$name,0);
573         print "# " if $perl && $verbose;
574         print "}\n" if !$perl || $verbose;
575         print "\n" if $perl && $verbose;
576
577         if ($perl) {
578             print "$pcode";
579
580             printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
581
582             print <<EOF;
583 sub ${mname}'typedef {
584     local(\$${mname}'index) = shift;
585     defined \$${mname}'index
586         ? \$${mname}'typedef[\$${mname}'index]
587         : \$${mname}'typedef;
588 }
589 EOF
590
591             print <<EOF;
592 sub ${mname}'sizeof {
593     local(\$${mname}'index) = shift;
594     defined \$${mname}'index
595         ? \$${mname}'sizeof[\$${mname}'index]
596         : \$${mname}'sizeof;
597 }
598 EOF
599
600             print <<EOF;
601 sub ${mname}'offsetof {
602     local(\$${mname}'index) = shift;
603     defined \$${mname}index
604         ? \$${mname}'offsetof[\$${mname}'index]
605         : \$${mname}'sizeof;
606 }
607 EOF
608
609             print <<EOF;
610 sub ${mname}'typeof {
611     local(\$${mname}'index) = shift;
612     defined \$${mname}index
613         ? \$${mname}'typeof[\$${mname}'index]
614         : '$name';
615 }
616 EOF
617
618             print <<EOF;
619 sub ${mname}'fieldnames {
620     \@${mname}'fieldnames;
621 }
622 EOF
623
624         $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
625
626             print <<EOF;
627 sub ${mname}'isastruct {
628     '$iam';
629 }
630 EOF
631
632             print "\$${mname}'typedef = '" . &scrunch($template{$fname})
633                 . "';\n";
634
635             print "\$${mname}'sizeof = $sizeof{$name};\n\n";
636
637
638             print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
639
640             print "\n";
641
642             print "\@${mname}'typedef[\@${mname}'indices] = (",
643                         join("\n\t", '', @typedef), "\n    );\n\n";
644             print "\@${mname}'sizeof[\@${mname}'indices] = (",
645                         join("\n\t", '', @sizeof), "\n    );\n\n";
646             print "\@${mname}'offsetof[\@${mname}'indices] = (",
647                         join("\n\t", '', @offsetof), "\n    );\n\n";
648             print "\@${mname}'typeof[\@${mname}'indices] = (",
649                         join("\n\t", '', @typeof), "\n    );\n\n";
650             print "\@${mname}'fieldnames[\@${mname}'indices] = (",
651                         join("\n\t", '', @fieldnames), "\n    );\n\n";
652
653             $template_printed{$fname}++;
654             $size_printed{$fname}++;
655         }
656         print "\n";
657     }
658
659     print STDERR "\n" if $trace;
660
661     unless ($perl && $opt_a) {
662         print "\n1;\n" if $perl;
663         exit;
664     }
665
666
667
668     foreach $name (sort bysizevalue keys %intrinsics) {
669         next if $size_printed{$name};
670         print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
671     }
672
673     print "\n";
674
675     sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
676
677
678     foreach $name (sort keys %intrinsics) {
679         print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
680     }
681
682     print "\n1;\n" if $perl;
683
684     exit;
685 }
686
687 ########################################################################################
688
689
690 sub stab {
691     next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/;  # (\d+,\d+) is for sun
692     s/"//                                               || next;
693     s/",([x\d]+),([x\d]+),([x\d]+),.*//                 || next;
694
695     next if /^\s*$/;
696
697     $size = $3 if $3;
698     $_ = $continued . $_ if length($continued);
699     if (s/\\\\$//) {
700       # if last 2 chars of string are '\\' then stab is continued
701       # in next stab entry
702       chop;
703       $continued = $_;
704       next;
705     }
706     $continued = '';
707
708
709     $line = $_;
710
711     if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
712         print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
713         &pdecl($pdecl);
714         next;
715     }
716
717
718
719     if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
720         local($ident) = $2;
721         push(@intrinsics, $ident);
722         $typeno = &typeno($3);
723         $type[$typeno] = $ident;
724         print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
725         next;
726     }
727
728     if (($name, $typeordef, $typeno, $extra, $struct, $_)
729         = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
730     {
731         $typeno = &typeno($typeno);  # sun foolery
732     }
733     elsif (/^[\$\w]+:/) {
734         next; # variable
735     }
736     else {
737         warn "can't grok stab: <$_> in: $line " if $_;
738         next;
739     }
740
741     #warn "got size $size for $name\n";
742     $sizeof{$name} = $size if $size;
743
744     s/;[-\d]*;[-\d]*;$//;  # we don't care about ranges
745
746     $typenos{$name} = $typeno;
747
748     unless (defined $type[$typeno]) {
749         &panic("type 0??") unless $typeno;
750         $type[$typeno] = $name unless defined $type[$typeno];
751         printf "new type $typeno is $name" if $debug;
752         if ($extra =~ /\*/ && defined $type[$struct]) {
753             print ", a typedef for a pointer to " , $type[$struct] if $debug;
754         }
755     } else {
756         printf "%s is type %d", $name, $typeno if $debug;
757         print ", a typedef for " , $type[$typeno] if $debug;
758     }
759     print "\n" if $debug;
760     #next unless $extra =~ /[su*]/;
761
762     #$type[$struct] = $name;
763
764     if ($extra =~ /[us*]/) {
765         &sou($name, $extra);
766         $_ = &sdecl($name, $_, 0);
767     }
768     elsif (/^=ar/) {
769         print "it's a bare array typedef -- that's pretty sick\n" if $debug;
770         $_ = "$typeno$_";
771         $scripts = '';
772         $_ = &adecl($_,1);
773
774     }
775     elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) {  # the ?'s are for gcc
776         push(@intrinsics, $2);
777         $typeno = &typeno($3);
778         $type[$typeno] = $2;
779         print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
780     }
781     elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
782         &edecl;
783     }
784     else {
785         warn "Funny remainder for $name on line $_ left in $line " if $_;
786     }
787 }
788
789 sub typeno {  # sun thinks types are (0,27) instead of just 27
790     local($_) = @_;
791     s/\(\d+,(\d+)\)/$1/;
792     $_;
793 }
794
795 sub pstruct {
796     local($what,$prefix,$base) = @_;
797     local($field, $fieldname, $typeno, $count, $offset, $entry);
798     local($fieldtype);
799     local($type, $tname);
800     local($mytype, $mycount, $entry2);
801     local($struct_count) = 0;
802     local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
803     local($bits,$bytes);
804     local($template);
805
806
807     local($mname) = &munge($name);
808
809     sub munge {
810         local($_) = @_;
811         s/[\s\$\.]/_/g;
812         $_;
813     }
814
815     local($sname) = &psou($what);
816
817     $nesting++;
818
819     for $field (split(/;/, $struct{$what})) {
820         $pad = $prepad = 0;
821         $entry = '';
822         ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
823
824         $type = $type[$typeno];
825
826         $type =~ /([^[]*)(\[.*\])?/;
827         $mytype = $1;
828         $count .= $2;
829         $fieldtype = &psou($mytype);
830
831         local($fname) = &psou($name);
832
833         if ($build_templates) {
834
835             $pad = ($offset - ($lastoffset + $lastlength))/8
836                 if defined $lastoffset;
837
838             if (! $finished_template{$sname}) {
839                 if ($isaunion{$what}) {
840                     $template{$sname} .= 'X' x $revpad . ' '    if $revpad;
841                 } else {
842                     $template{$sname} .= 'x' x $pad    . ' '    if $pad;
843                 }
844             }
845
846             $template = &fetch_template($type);
847             &repeat_template($template,$count);
848
849             if (! $finished_template{$sname}) {
850                 $template{$sname} .= $template;
851             }
852
853             $revpad = $length/8 if $isaunion{$what};
854
855             ($lastoffset, $lastlength) = ($offset, $length);
856
857         } else {
858             print '# ' if $perl && $verbose;
859             $entry = sprintf($pmask1,
860                         ' ' x ($nesting * $indent) . $fieldtype,
861                         "$prefix.$fieldname" . $count);
862
863             $entry =~ s/(\*+)( )/$2$1/;
864
865             printf $pmask2,
866                     $entry,
867                     ($base+$offset)/8,
868                     ($bits = ($base+$offset)%8) ? ".$bits" : "  ",
869                     $length/8,
870                     ($bits = $length % 8) ? ".$bits": ""
871                         if !$perl || $verbose;
872
873             if ($perl) {
874                 $template = &fetch_template($type);
875                 &repeat_template($template,$count);
876             }
877
878             if ($perl && $nesting == 1) {
879
880                 push(@sizeof, int($length/8) .",\t# $fieldname");
881                 push(@offsetof, int($offset/8) .",\t# $fieldname");
882                 local($little) = &scrunch($template);
883                 push(@typedef, "'$little', \t# $fieldname");
884                 $type =~ s/(struct|union) //;
885                 push(@typeof, "'$mytype" . ($count ? $count : '') .
886                     "',\t# $fieldname");
887                 push(@fieldnames, "'$fieldname',");
888             }
889
890             print '  ', ' ' x $indent x $nesting, $template
891                                 if $perl && $verbose;
892
893             print "\n" if !$perl || $verbose;
894
895         }
896         if ($perl) {
897             local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
898             $mycount *= &scripts2count($count) if $count;
899             if ($nesting==1 && !$build_templates) {
900                 $pcode .= sprintf("sub %-32s { %4d; }\n",
901                         "${mname}'${fieldname}", $struct_count);
902                 push(@indices, $struct_count);
903             }
904             $struct_count += $mycount;
905         }
906
907
908         &pstruct($type, "$prefix.$fieldname", $base+$offset)
909                 if $recurse && defined $struct{$type};
910     }
911
912     $countof{$what} = $struct_count unless defined $countof{$whati};
913
914     $template{$sname} .= '$' if $build_templates;
915     $finished_template{$sname}++;
916
917     if ($build_templates && !defined $sizeof{$name}) {
918         local($fmt) = &scrunch($template{$sname});
919         print STDERR "no size for $name, punting with $fmt..." if $debug;
920         eval '$sizeof{$name} = length(pack($fmt, ()))';
921         if ($@) {
922             chop $@;
923             warn "couldn't get size for \$name: $@";
924         } else {
925             print STDERR $sizeof{$name}, "\n" if $debUg;
926         }
927     }
928
929     --$nesting;
930 }
931
932
933 sub psize {
934     local($me) = @_;
935     local($amstruct) = $struct{$me} ?  'struct ' : '';
936
937     print '$sizeof{\'', $amstruct, $me, '\'} = ';
938     printf "%d;\n", $sizeof{$me};
939 }
940
941 sub pdecl {
942     local($pdecl) = @_;
943     local(@pdecls);
944     local($tname);
945
946     warn "pdecl: $pdecl\n" if $debug;
947
948     $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
949     $pdecl =~ s/\*//g;
950     @pdecls = split(/=/, $pdecl);
951     $typeno = $pdecls[0];
952     $tname = pop @pdecls;
953
954     if ($tname =~ s/^f//) { $tname = "$tname&"; }
955     #else { $tname = "$tname*"; }
956
957     for (reverse @pdecls) {
958         $tname  .= s/^f// ? "&" : "*";
959         #$tname =~ s/^f(.*)/$1&/;
960         print "type[$_] is $tname\n" if $debug;
961         $type[$_] = $tname unless defined $type[$_];
962     }
963 }
964
965
966
967 sub adecl {
968     ($arraytype, $unknown, $lower, $upper) = ();
969     #local($typeno);
970     # global $typeno, @type
971     local($_, $typedef) = @_;
972
973     while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
974         ($arraytype, $unknown) = ($2, $3);
975         $arraytype = &typeno($arraytype);
976         $unknown = &typeno($unknown);
977         if (s/^(\d+);(\d+);//) {
978             ($lower, $upper) = ($1, $2);
979             $scripts .= '[' .  ($upper+1) . ']';
980         } else {
981             warn "can't find array bounds: $_";
982         }
983     }
984     if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
985         ($start, $length) = ($2, $3);
986         $whatis = $1;
987         if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
988             $typeno = &typeno($1);
989             &pdecl($whatis);
990         } else {
991             $typeno = &typeno($whatis);
992         }
993     } elsif (s/^(\d+)(=[*suf]\d*)//) {
994         local($whatis) = $2;
995
996         if ($whatis =~ /[f*]/) {
997             &pdecl($whatis);
998         } elsif ($whatis =~ /[su]/) {  #
999             print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
1000                 if $debug;
1001             #$type[$typeno] = $name unless defined $type[$typeno];
1002             ##printf "new type $typeno is $name" if $debug;
1003             $typeno = $1;
1004             $type[$typeno] = "$prefix.$fieldname";
1005             local($name) = $type[$typeno];
1006             &sou($name, $whatis);
1007             $_ = &sdecl($name, $_, $start+$offset);
1008             1;
1009             $start = $start{$name};
1010             $offset = $sizeof{$name};
1011             $length = $offset;
1012         } else {
1013             warn "what's this? $whatis in $line ";
1014         }
1015     } elsif (/^\d+$/) {
1016         $typeno = $_;
1017     } else {
1018         warn "bad array stab: $_ in $line ";
1019         next STAB;
1020     }
1021     #local($wasdef) = defined($type[$typeno]) && $debug;
1022     #if ($typedef) {
1023         #print "redefining $type[$typeno] to " if $wasdef;
1024         #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1025         #print "$type[$typeno]\n" if $wasdef;
1026     #} else {
1027         #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1028     #}
1029     $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1030     print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1031     print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1032     $_;
1033 }
1034
1035
1036
1037 sub sdecl {
1038     local($prefix, $_, $offset) = @_;
1039
1040     local($fieldname, $scripts, $type, $arraytype, $unknown,
1041     $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1042     local($typeno,$sou);
1043
1044
1045 SFIELD:
1046     while (/^([^;]+);/) {
1047         $scripts = '';
1048         warn "sdecl $_\n" if $debug;
1049         if (s/^([\$\w]+)://) {
1050             $fieldname = $1;
1051         } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
1052             $typeno = &typeno($1);
1053             $type[$typeno] = "$prefix.$fieldname";
1054             local($name) = "$prefix.$fieldname";
1055             &sou($name,$2);
1056             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1057             $start = $start{$name};
1058             $offset += $sizeof{$name};
1059             #print "done with anon, start is $start, offset is $offset\n";
1060             #next SFIELD;
1061         } else  {
1062             warn "weird field $_ of $line" if $debug;
1063             next STAB;
1064             #$fieldname = &gensym;
1065             #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1066         }
1067
1068         if (/^(\d+|\(\d+,\d+\))=ar/) {
1069             $_ = &adecl($_);
1070         }
1071         elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
1072           ($start, $length) =  ($2, $3);
1073           &panic("no length?") unless $length;
1074           $typeno = &typeno($1) if $1;
1075         }
1076         elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
1077             ($start, $length) =  ($2, $3);
1078             &panic("no length?") unless $length;
1079             $typeno = &typeno($1) if $1;
1080         }
1081         elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
1082             ($pdecl, $start, $length) =  ($1,$5,$6);
1083             &pdecl($pdecl);
1084         }
1085         elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1086             ($typeno, $sou) = ($1, $2);
1087             $typeno = &typeno($typeno);
1088             if (defined($type[$typeno])) {
1089                 warn "now how did we get type $1 in $fieldname of $line?";
1090             } else {
1091                 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1092                 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1093             };
1094             local($name) = "$prefix.$fieldname";
1095             &sou($name,$sou);
1096             print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1097             $type[$typeno] = "$prefix.$fieldname";
1098             $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1099             $start = $start{$name};
1100             $length = $sizeof{$name};
1101         }
1102         else {
1103             warn "can't grok stab for $name ($_) in line $line ";
1104             next STAB;
1105         }
1106
1107         &panic("no length for $prefix.$fieldname") unless $length;
1108         $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1109     }
1110     if (s/;\d*,(\d+),(\d+);//) {
1111         local($start, $size) = ($1, $2);
1112         $sizeof{$prefix} = $size;
1113         print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1114         $start{$prefix} = $start;
1115     }
1116     $_;
1117 }
1118
1119 sub edecl {
1120     s/;$//;
1121     $enum{$name} = $_;
1122     $_ = '';
1123 }
1124
1125 sub resolve_types {
1126     local($sou);
1127     for $i (0 .. $#type) {
1128         next unless defined $type[$i];
1129         $_ = $type[$i];
1130         unless (/\d/) {
1131             print "type[$i] $type[$i]\n" if $debug;
1132             next;
1133         }
1134         print "type[$i] $_ ==> " if $debug;
1135         s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
1136         s/^(\d+)\&/&type($1)/e;
1137         s/^(\d+)/&type($1)/e;
1138         s/(\*+)([^*]+)(\*+)/$1$3$2/;
1139         s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1140         s/^(\d+)([\*\[].*)/&type($1).$2/e;
1141         #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1142         $type[$i] = $_;
1143         print "$_\n" if $debug;
1144     }
1145 }
1146 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
1147
1148 sub adjust_start_addrs {
1149     for (sort keys %start) {
1150         ($basename = $_) =~ s/\.[^.]+$//;
1151         $start{$_} += $start{$basename};
1152         print "start: $_ @ $start{$_}\n" if $debug;
1153     }
1154 }
1155
1156 sub sou {
1157     local($what, $_) = @_;
1158     /u/ && $isaunion{$what}++;
1159     /s/ && $isastruct{$what}++;
1160 }
1161
1162 sub psou {
1163     local($what) = @_;
1164     local($prefix) = '';
1165     if ($isaunion{$what})  {
1166         $prefix = 'union ';
1167     } elsif ($isastruct{$what})  {
1168         $prefix = 'struct ';
1169     }
1170     $prefix . $what;
1171 }
1172
1173 sub scrunch {
1174     local($_) = @_;
1175
1176     return '' if $_ eq '';
1177
1178     study;
1179
1180     s/\$//g;
1181     s/  / /g;
1182     1 while s/(\w) \1/$1$1/g;
1183
1184     # i wanna say this, but perl resists my efforts:
1185     #      s/(\w)(\1+)/$2 . length($1)/ge;
1186
1187     &quick_scrunch;
1188
1189     s/ $//;
1190
1191     $_;
1192 }
1193
1194 sub buildscrunchlist {
1195     $scrunch_code = "sub quick_scrunch {\n";
1196     for (values %intrinsics) {
1197         $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
1198     }
1199     $scrunch_code .= "}\n";
1200     print "$scrunch_code" if $debug;
1201     eval $scrunch_code;
1202     &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1203 }
1204
1205 sub fetch_template {
1206     local($mytype) = @_;
1207     local($fmt);
1208     local($count) = 1;
1209
1210     &panic("why do you care?") unless $perl;
1211
1212     if ($mytype =~ s/(\[\d+\])+$//) {
1213         $count .= $1;
1214     }
1215
1216     if ($mytype =~ /\*/) {
1217         $fmt = $template{'pointer'};
1218     }
1219     elsif (defined $template{$mytype}) {
1220         $fmt = $template{$mytype};
1221     }
1222     elsif (defined $struct{$mytype}) {
1223         if (!defined $template{&psou($mytype)}) {
1224             &build_template($mytype) unless $mytype eq $name;
1225         }
1226         elsif ($template{&psou($mytype)} !~ /\$$/) {
1227             #warn "incomplete template for $mytype\n";
1228         }
1229         $fmt = $template{&psou($mytype)} || '?';
1230     }
1231     else {
1232         warn "unknown fmt for $mytype\n";
1233         $fmt = '?';
1234     }
1235
1236     $fmt x $count . ' ';
1237 }
1238
1239 sub compute_intrinsics {
1240     local($TMP) = "/tmp/c2ph-i.$$.c";
1241     open (TMP, ">$TMP") || die "can't open $TMP: $!";
1242     select(TMP);
1243
1244     print STDERR "computing intrinsic sizes: " if $trace;
1245
1246     undef %intrinsics;
1247
1248     print <<'EOF';
1249 main() {
1250     char *mask = "%d %s\n";
1251 EOF
1252
1253     for $type (@intrinsics) {
1254         next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
1255         print <<"EOF";
1256     printf(mask,sizeof($type), "$type");
1257 EOF
1258     }
1259
1260     print <<'EOF';
1261     printf(mask,sizeof(char *), "pointer");
1262     exit(0);
1263 }
1264 EOF
1265     close TMP;
1266
1267     select(STDOUT);
1268     open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
1269     while (<PIPE>) {
1270         chop;
1271         split(' ',$_,2);;
1272         print "intrinsic $_[1] is size $_[0]\n" if $debug;
1273         $sizeof{$_[1]} = $_[0];
1274         $intrinsics{$_[1]} = $template{$_[0]};
1275     }
1276     close(PIPE) || die "couldn't read intrinsics!";
1277     unlink($TMP, '/tmp/a.out');
1278     print STDERR "done\n" if $trace;
1279 }
1280
1281 sub scripts2count {
1282     local($_) = @_;
1283
1284     s/^\[//;
1285     s/\]$//;
1286     s/\]\[/*/g;
1287     $_ = eval;
1288     &panic("$_: $@") if $@;
1289     $_;
1290 }
1291
1292 sub system {
1293     print STDERR "@_\n" if $trace;
1294     system @_;
1295 }
1296
1297 sub build_template {
1298     local($name) = @_;
1299
1300     &panic("already got a template for $name") if defined $template{$name};
1301
1302     local($build_templates) = 1;
1303
1304     local($lparen) = '(' x $build_recursed;
1305     local($rparen) = ')' x $build_recursed;
1306
1307     print STDERR "$lparen$name$rparen " if $trace;
1308     $build_recursed++;
1309     &pstruct($name,$name,0);
1310     print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1311     --$build_recursed;
1312 }
1313
1314
1315 sub panic {
1316
1317     select(STDERR);
1318
1319     print "\npanic: @_\n";
1320
1321     exit 1 if $] <= 4.003;  # caller broken
1322
1323     local($i,$_);
1324     local($p,$f,$l,$s,$h,$a,@a,@sub);
1325     for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1326         @a = @DB'args;
1327         for (@a) {
1328             if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1329                 $_ = sprintf("%s",$_);
1330             }
1331             else {
1332                 s/'/\\'/g;
1333                 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1334                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1335                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1336             }
1337         }
1338         $w = $w ? '@ = ' : '$ = ';
1339         $a = $h ? '(' . join(', ', @a) . ')' : '';
1340         push(@sub, "$w&$s$a from file $f line $l\n");
1341         last if $signal;
1342     }
1343     for ($i=0; $i <= $#sub; $i++) {
1344         last if $signal;
1345         print $sub[$i];
1346     }
1347     exit 1;
1348 }
1349
1350 sub squishseq {
1351     local($num);
1352     local($last) = -1e8;
1353     local($string);
1354     local($seq) = '..';
1355
1356     while (defined($num = shift)) {
1357         if ($num == ($last + 1)) {
1358             $string .= $seq unless $inseq++;
1359             $last = $num;
1360             next;
1361         } elsif ($inseq) {
1362             $string .= $last unless $last == -1e8;
1363         }
1364
1365         $string .= ',' if defined $string;
1366         $string .= $num;
1367         $last = $num;
1368         $inseq = 0;
1369     }
1370     $string .= $last if $inseq && $last != -e18;
1371     $string;
1372 }
1373
1374 sub repeat_template {
1375     #  local($template, $scripts) = @_;  have to change caller's values
1376
1377     if ( $_[1] ) {
1378         local($ncount) = &scripts2count($_[1]);
1379         if ($_[0] =~ /^\s*c\s*$/i) {
1380             $_[0] = "A$ncount ";
1381             $_[1] = '';
1382         } else {
1383             $_[0] = $template x $ncount;
1384         }
1385     }
1386 }
1387 !NO!SUBS!
1388
1389 close OUT or die "Can't close $file: $!";
1390 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1391 unlink 'pstruct';
1392 print "Linking c2ph to pstruct.\n";
1393 if (defined $Config{d_link}) {
1394   link 'c2ph', 'pstruct';
1395 } else {
1396   unshift @INC, '../lib';
1397   require File::Copy;
1398   File::Copy::syscopy('c2ph', 'pstruct');
1399 }
1400 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';