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