AUTHORS: better email address
[perl.git] / regen / embed_lib.pl
1 #!/usr/bin/perl -w
2 use strict;
3
4 # read embed.fnc and regen/opcodes, needed by regen/embed.pl and makedef.pl
5
6 require 5.004;  # keep this compatible, an old perl is all we may have before
7                 # we build the new one
8
9 # Records the current pre-processor state:
10 my @state;
11 # Nested structure to group functions by the pre-processor conditions that
12 # control when they are compiled:
13 my %groups;
14
15 sub current_group {
16     my $group = \%groups;
17     # Nested #if blocks are effectively &&ed together
18     # For embed.fnc, ordering within the && isn't relevant, so we can
19     # sort them to try to group more functions together.
20     foreach (sort @state) {
21         $group->{$_} ||= {};
22         $group = $group->{$_};
23     }
24     return $group->{''} ||= [];
25 }
26
27 sub add_level {
28     my ($level, $indent, $wanted) = @_;
29     my $funcs = $level->{''};
30     my @entries;
31     if ($funcs) {
32         if (!defined $wanted) {
33             @entries = @$funcs;
34         } else {
35             foreach (@$funcs) {
36                 if ($_->[0] =~ /A/) {
37                     push @entries, $_ if $wanted eq 'A';
38                 } elsif ($_->[0] =~ /E/) {
39                     push @entries, $_ if $wanted eq 'E';
40                 } else {
41                     push @entries, $_ if $wanted eq '';
42                 }
43             }
44         }
45         @entries = sort {$a->[2] cmp $b->[2]} @entries;
46     }
47     foreach (sort grep {length $_} keys %$level) {
48         my @conditional = add_level($level->{$_}, $indent . '  ', $wanted);
49         push @entries,
50             ["#${indent}if $_"], @conditional, ["#${indent}endif"]
51                 if @conditional;
52     }
53     return @entries;
54 }
55
56 sub setup_embed {
57     my $prefix = shift || '';
58     open IN, $prefix . 'embed.fnc' or die $!;
59
60     my @embed;
61
62     while (<IN>) {
63         chomp;
64         next if /^:/;
65         next if /^$/;
66         while (s|\\$||) {
67             $_ .= <IN>;
68             chomp;
69         }
70         s/\s+$//;
71         my @args;
72         if (/^\s*(#|$)/) {
73             @args = $_;
74         }
75         else {
76             @args = split /\s*\|\s*/, $_;
77         }
78         if (@args == 1 && $args[0] !~ /^#\s*(?:if|ifdef|ifndef|else|endif)/) {
79             die "Illegal line $. '$args[0]' in embed.fnc";
80         }
81         push @embed, \@args;
82     }
83
84     close IN or die "Problem reading embed.fnc: $!";
85
86     open IN, $prefix . 'regen/opcodes' or die $!;
87     {
88         my %syms;
89
90         while (<IN>) {
91             chomp;
92             next unless $_;
93             next if /^#/;
94             my $check = (split /\t+/, $_)[2];
95             next if $syms{$check}++;
96
97             # These are all indirectly referenced by globals.c.
98             push @embed, ['pR', 'OP *', $check, 'NN OP *o'];
99         }
100     }
101     close IN or die "Problem reading regen/opcodes: $!";
102
103     # Cluster entries in embed.fnc that have the same #ifdef guards.
104     # Also, split out at the top level the three classes of functions.
105     # Output structure is actually the same as input structure - an
106     # (ordered) list of array references, where the elements in the
107     # reference determine what it is - a reference to a 1-element array is a
108     # pre-processor directive, a reference to 2+ element array is a function.
109
110     my $current = current_group();
111
112     foreach (@embed) {
113         if (@$_ > 1) {
114             push @$current, $_;
115             next;
116         }
117         $_->[0] =~ s/^#\s+/#/;
118         $_->[0] =~ /^\S*/;
119         $_->[0] =~ s/^#ifdef\s+(\S+)/#if defined($1)/;
120         $_->[0] =~ s/^#ifndef\s+(\S+)/#if !defined($1)/;
121         if ($_->[0] =~ /^#if\s*(.*)/) {
122             push @state, $1;
123         } elsif ($_->[0] =~ /^#else\s*$/) {
124             die "Unmatched #else in embed.fnc" unless @state;
125             $state[-1] = "!($state[-1])";
126         } elsif ($_->[0] =~ m!^#endif\s*(?:/\*.*\*/)?$!) {
127             die "Unmatched #endif in embed.fnc" unless @state;
128             pop @state;
129         } else {
130             die "Unhandled pre-processor directive '$_->[0]' in embed.fnc";
131         }
132         $current = current_group();
133     }
134
135     return ([add_level(\%groups, '')],
136             [add_level(\%groups, '', '')],    # core
137             [add_level(\%groups, '', 'E')],   # ext
138             [add_level(\%groups, '', 'A')]);  # api
139 }
140
141 1;