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
CommitLineData
bab3dc31 1#!/usr/bin/perl -w
bab3dc31 2#
8bc7f08e 3# Regenerate (overwriting only if changed):
6294c161
DM
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#
8c798f87 11# This allows the order of overloading constants to be changed.
6294c161
DM
12#
13# Accepts the standard regen_lib -q and -v args.
14#
15# This script is normally invoked from regen.pl.
bab3dc31
NC
16
17BEGIN {
18 # Get function prototypes
af001346 19 require 'regen/regen_lib.pl';
bab3dc31
NC
20}
21
22use strict;
23
24my (@enums, @names);
25while (<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
f038801a
NC
33my $c = safer_open('overload.c-new', 'overload.c');
34my $h = safer_open('overload.h-new', 'overload.h');
916e4025 35mkdir("lib/overload", 0777) unless -d 'lib/overload';
f038801a 36my $p = safer_open('lib/overload/numbers.pm-new', 'lib/overload/numbers.pm');
e46c382e 37
2d6469fe
NC
38print $p read_only_top(lang => 'Perl', by => 'regen/overload.pl',
39 file => 'lib/overload/numbers.pm', copyright => [2008]);
78102347 40
e46c382e
YK
41{
42local $" = "\n ";
2d6469fe 43print $p <<"EOF";
e46c382e
YK
44package overload::numbers;
45
46our \@names = qw#
47 @names
48#;
49
50our \@enums = qw#
51 @enums
52#;
53
d87d3eed 54{ my \$i = 0; our %names = map { \$_ => \$i++ } \@names }
e46c382e 55
d87d3eed 56{ my \$i = 0; our %enums = map { \$_ => \$i++ } \@enums }
e46c382e
YK
57EOF
58}
59
78102347
NC
60for ([$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]);
8261f8eb
NC
66}
67
2d6469fe 68print $h "enum {\n";
bab3dc31 69
c4ac9b44
DM
70for (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;
2d6469fe 77 printf $h " %s_amg,%s/* 0x%02x %-8s */\n", $enums[$_],
218eba0d 78 ("\t" x $l), $_, $op;
c4ac9b44 79}
bab3dc31 80
2d6469fe 81print $h <<'EOF';
bab3dc31
NC
82 max_amg_code
83 /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
84};
85
bab3dc31 86#define NofAMmeth max_amg_code
8261f8eb
NC
87EOF
88
08858ed2 89print $c <<'EOF';
bab3dc31 90#define AMG_id2name(id) (PL_AMG_names[id]+1)
82af6593 91#define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
bab3dc31 92
2e1c5ef0 93static const U8 PL_AMG_namelens[NofAMmeth] = {
d279ab82
NC
94EOF
95
96my $last = pop @names;
97
916e4025 98print $c map { " " . (length $_) . ",\n" } @names;
d279ab82
NC
99
100my $lastlen = length $last;
08858ed2 101print $c <<"EOT";
d279ab82
NC
102 $lastlen
103};
104
2e1c5ef0 105static const char * const PL_AMG_names[NofAMmeth] = {
bab3dc31
NC
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. */
d279ab82 111EOT
bab3dc31 112
c4ac9b44
DM
113for (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}
bab3dc31 120
08858ed2 121print $c <<"EOT";
bab3dc31
NC
122 "$last"
123};
bab3dc31
NC
124EOT
125
ce716c52
NC
126foreach ($h, $c, $p) {
127 read_only_bottom_close_and_rename($_);
128}
bab3dc31
NC
129__DATA__
130# Fallback should be the first
131fallback ()
132
133# These 5 are the most common in the fallback switch statement in amagic_call
134to_sv (${}
135to_av (@{}
136to_hv (%{}
137to_gv (*{}
138to_cv (&{}
139
140# These have non-default cases in that switch statement
141inc (++
142dec (--
143bool_ (bool
144numer (0+
145string (""
146not (!
147copy (=
148abs (abs
149neg (neg
150iter (<>
151int (int
152
153# These 12 feature in the next switch statement
154lt (<
155le (<=
156gt (>
157ge (>=
158eq (==
159ne (!=
160slt (lt
161sle (le
162sgt (gt
163sge (ge
164seq (eq
165sne (ne
166
167nomethod (nomethod
168add (+
169add_ass (+=
170subtr (-
171subtr_ass (-=
172mult (*
173mult_ass (*=
174div (/
175div_ass (/=
176modulo (%
177modulo_ass (%=
178pow (**
179pow_ass (**=
180lshift (<<
181lshift_ass (<<=
182rshift (>>
183rshift_ass (>>=
184band (&
185band_ass (&=
186bor (|
187bor_ass (|=
188bxor (^
189bxor_ass (^=
190ncmp (<=>
191scmp (cmp
192compl (~
193atan2 (atan2
194cos (cos
195sin (sin
196exp (exp
197log (log
198sqrt (sqrt
199repeat (x
200repeat_ass (x=
201concat (.
202concat_ass (.=
203smart (~~
8c8d0d99 204ftest (-X
d9151963 205regexp (qr
bab3dc31
NC
206# Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
207DESTROY DESTROY