7ff3f124ae6315e08d681f0bdf6e3e5297d4229c
[perl.git] / regen / overload.pl
1 #!/usr/bin/perl -w
2 #
3 # Regenerate (overwriting only if changed):
4 #
5 #    overload.h
6 #    overload.c
7 #    lib/overload/numbers.pm
8 #
9 # from information stored in the DATA section of this file.
10 #
11 # This allows the order of overloading constants to be changed.
12 #
13 # Accepts the standard regen_lib -q and -v args.
14 #
15 # This script is normally invoked from regen.pl.
16
17 BEGIN {
18     # Get function prototypes
19     require 'regen/regen_lib.pl';
20 }
21
22 use strict;
23
24 my (@enums, @names);
25 while (<DATA>) {
26   next if /^#/;
27   next if /^$/;
28   my ($enum, $name) = /^(\S+)\s+(\S+)/ or die "Can't parse $_";
29   push @enums, $enum;
30   push @names, $name;
31 }
32
33 my $c = safer_open('overload.c-new', 'overload.c');
34 my $h = safer_open('overload.h-new', 'overload.h');
35 mkdir("lib/overload", 0777) unless -d 'lib/overload';
36 my $p = safer_open('lib/overload/numbers.pm-new', 'lib/overload/numbers.pm');
37
38
39 select $p;
40
41 print read_only_top(lang => 'Perl', by => 'regen/overload.pl',
42                     file => 'lib/overload/numbers.pm', copyright => [2008]);
43
44 {
45 local $" = "\n    ";
46 print <<"EOF";
47 package overload::numbers;
48
49 our \@names = qw#
50     @names
51 #;
52
53 our \@enums = qw#
54     @enums
55 #;
56
57 { my \$i = 0; our %names = map { \$_ => \$i++ } \@names }
58
59 { my \$i = 0; our %enums = map { \$_ => \$i++ } \@enums }
60
61 EOF
62 }
63
64 for ([$c, 'overload.c'], [$h, 'overload.h']) {
65     my ($handle, $file) = @$_;
66     print $handle read_only_top(lang => 'C', by => 'regen/overload.pl',
67                                 file => $file, style => '*',
68                                 copyright => [1997, 1998, 2000, 2001,
69                                              2005 .. 2007, 2011]);
70 }
71
72 select $h;
73 print "enum {\n";
74
75 for (0..$#enums) {
76     my $op = $names[$_];
77     $op = 'fallback' if $op eq '()';
78     $op =~ s/^\(//;
79     die if $op =~ m{\*/};
80     my $l =   3 - int((length($enums[$_]) + 9) / 8);
81     $l = 1 if $l < 1;
82     printf "    %s_amg,%s/* 0x%02x %-8s */\n", $enums[$_],
83         ("\t" x $l), $_, $op;
84 }
85
86 print <<'EOF';
87     max_amg_code
88     /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
89 };
90
91 #define NofAMmeth max_amg_code
92
93 EOF
94
95 print $c <<'EOF';
96 #define AMG_id2name(id) (PL_AMG_names[id]+1)
97 #define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
98
99 static const U8 PL_AMG_namelens[NofAMmeth] = {
100 EOF
101
102 my $last = pop @names;
103
104 print $c map { "    " . (length $_) . ",\n" } @names;
105
106 my $lastlen = length $last;
107 print $c <<"EOT";
108     $lastlen
109 };
110
111 static const char * const PL_AMG_names[NofAMmeth] = {
112   /* Names kept in the symbol table.  fallback => "()", the rest has
113      "(" prepended.  The only other place in perl which knows about
114      this convention is AMG_id2name (used for debugging output and
115      'nomethod' only), the only other place which has it hardwired is
116      overload.pm.  */
117 EOT
118
119 for (0..$#names) {
120     my $n = $names[$_];
121     $n =~ s/(["\\])/\\$1/g;
122     my $l =   3 - int((length($n) + 7) / 8);
123     $l = 1 if $l < 1;
124     printf $c "    \"%s\",%s/* %-10s */\n", $n, ("\t" x $l), $enums[$_];
125 }
126
127 print $c <<"EOT";
128     "$last"
129 };
130 EOT
131
132 close_and_rename($h);
133 close_and_rename($c);
134 close_and_rename($p);
135
136 __DATA__
137 # Fallback should be the first
138 fallback        ()
139
140 # These 5 are the most common in the fallback switch statement in amagic_call
141 to_sv           (${}
142 to_av           (@{}
143 to_hv           (%{}
144 to_gv           (*{}
145 to_cv           (&{}
146
147 # These have non-default cases in that switch statement
148 inc             (++
149 dec             (--
150 bool_           (bool
151 numer           (0+
152 string          (""
153 not             (!
154 copy            (=
155 abs             (abs
156 neg             (neg
157 iter            (<>
158 int             (int
159
160 # These 12 feature in the next switch statement
161 lt              (<
162 le              (<=
163 gt              (>
164 ge              (>=
165 eq              (==
166 ne              (!=
167 slt             (lt
168 sle             (le
169 sgt             (gt
170 sge             (ge
171 seq             (eq
172 sne             (ne
173
174 nomethod        (nomethod
175 add             (+
176 add_ass         (+=
177 subtr           (-
178 subtr_ass       (-=
179 mult            (*
180 mult_ass        (*=
181 div             (/
182 div_ass         (/=
183 modulo          (%
184 modulo_ass      (%=
185 pow             (**
186 pow_ass         (**=
187 lshift          (<<
188 lshift_ass      (<<=
189 rshift          (>>
190 rshift_ass      (>>=
191 band            (&
192 band_ass        (&=
193 bor             (|
194 bor_ass         (|=
195 bxor            (^
196 bxor_ass        (^=
197 ncmp            (<=>
198 scmp            (cmp
199 compl           (~
200 atan2           (atan2
201 cos             (cos
202 sin             (sin
203 exp             (exp
204 log             (log
205 sqrt            (sqrt
206 repeat          (x
207 repeat_ass      (x=
208 concat          (.
209 concat_ass      (.=
210 smart           (~~
211 ftest           (-X
212 regexp          (qr
213 # Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
214 DESTROY         DESTROY