This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In regen scripts, print to explicit file handles instead of using select.
[perl5.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 print $p read_only_top(lang => 'Perl', by => 'regen/overload.pl',
39                        file => 'lib/overload/numbers.pm', copyright => [2008]);
40
41 {
42 local $" = "\n    ";
43 print $p <<"EOF";
44 package overload::numbers;
45
46 our \@names = qw#
47     @names
48 #;
49
50 our \@enums = qw#
51     @enums
52 #;
53
54 { my \$i = 0; our %names = map { \$_ => \$i++ } \@names }
55
56 { my \$i = 0; our %enums = map { \$_ => \$i++ } \@enums }
57 EOF
58 }
59
60 for ([$c, 'overload.c'], [$h, 'overload.h']) {
61     my ($handle, $file) = @$_;
62     print $handle read_only_top(lang => 'C', by => 'regen/overload.pl',
63                                 file => $file, style => '*',
64                                 copyright => [1997, 1998, 2000, 2001,
65                                              2005 .. 2007, 2011]);
66 }
67
68 print $h "enum {\n";
69
70 for (0..$#enums) {
71     my $op = $names[$_];
72     $op = 'fallback' if $op eq '()';
73     $op =~ s/^\(//;
74     die if $op =~ m{\*/};
75     my $l =   3 - int((length($enums[$_]) + 9) / 8);
76     $l = 1 if $l < 1;
77     printf $h "    %s_amg,%s/* 0x%02x %-8s */\n", $enums[$_],
78         ("\t" x $l), $_, $op;
79 }
80
81 print $h <<'EOF';
82     max_amg_code
83     /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
84 };
85
86 #define NofAMmeth max_amg_code
87 EOF
88
89 print $c <<'EOF';
90 #define AMG_id2name(id) (PL_AMG_names[id]+1)
91 #define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
92
93 static const U8 PL_AMG_namelens[NofAMmeth] = {
94 EOF
95
96 my $last = pop @names;
97
98 print $c map { "    " . (length $_) . ",\n" } @names;
99
100 my $lastlen = length $last;
101 print $c <<"EOT";
102     $lastlen
103 };
104
105 static const char * const PL_AMG_names[NofAMmeth] = {
106   /* Names kept in the symbol table.  fallback => "()", the rest has
107      "(" prepended.  The only other place in perl which knows about
108      this convention is AMG_id2name (used for debugging output and
109      'nomethod' only), the only other place which has it hardwired is
110      overload.pm.  */
111 EOT
112
113 for (0..$#names) {
114     my $n = $names[$_];
115     $n =~ s/(["\\])/\\$1/g;
116     my $l =   3 - int((length($n) + 7) / 8);
117     $l = 1 if $l < 1;
118     printf $c "    \"%s\",%s/* %-10s */\n", $n, ("\t" x $l), $enums[$_];
119 }
120
121 print $c <<"EOT";
122     "$last"
123 };
124 EOT
125
126 foreach ($h, $c, $p) {
127     read_only_bottom_close_and_rename($_);
128 }
129 __DATA__
130 # Fallback should be the first
131 fallback        ()
132
133 # These 5 are the most common in the fallback switch statement in amagic_call
134 to_sv           (${}
135 to_av           (@{}
136 to_hv           (%{}
137 to_gv           (*{}
138 to_cv           (&{}
139
140 # These have non-default cases in that switch statement
141 inc             (++
142 dec             (--
143 bool_           (bool
144 numer           (0+
145 string          (""
146 not             (!
147 copy            (=
148 abs             (abs
149 neg             (neg
150 iter            (<>
151 int             (int
152
153 # These 12 feature in the next switch statement
154 lt              (<
155 le              (<=
156 gt              (>
157 ge              (>=
158 eq              (==
159 ne              (!=
160 slt             (lt
161 sle             (le
162 sgt             (gt
163 sge             (ge
164 seq             (eq
165 sne             (ne
166
167 nomethod        (nomethod
168 add             (+
169 add_ass         (+=
170 subtr           (-
171 subtr_ass       (-=
172 mult            (*
173 mult_ass        (*=
174 div             (/
175 div_ass         (/=
176 modulo          (%
177 modulo_ass      (%=
178 pow             (**
179 pow_ass         (**=
180 lshift          (<<
181 lshift_ass      (<<=
182 rshift          (>>
183 rshift_ass      (>>=
184 band            (&
185 band_ass        (&=
186 bor             (|
187 bor_ass         (|=
188 bxor            (^
189 bxor_ass        (^=
190 ncmp            (<=>
191 scmp            (cmp
192 compl           (~
193 atan2           (atan2
194 cos             (cos
195 sin             (sin
196 exp             (exp
197 log             (log
198 sqrt            (sqrt
199 repeat          (x
200 repeat_ass      (x=
201 concat          (.
202 concat_ass      (.=
203 smart           (~~
204 ftest           (-X
205 regexp          (qr
206 # Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
207 DESTROY         DESTROY