Move Compress::Raw::Zlib from ext/ to cpan/
[perl.git] / 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_lib.pl';
20 }
21
22 use strict;
23
24 use File::Spec::Functions qw(catdir catfile);;
25
26 my (@enums, @names);
27 while (<DATA>) {
28   next if /^#/;
29   next if /^$/;
30   my ($enum, $name) = /^(\S+)\s+(\S+)/ or die "Can't parse $_";
31   push @enums, $enum;
32   push @names, $name;
33 }
34
35 safer_unlink (catfile(qw(lib overload numbers.pm)));
36 my $c = safer_open("overload.c-new");
37 my $h = safer_open("overload.h-new");
38 mkdir("lib/overload") unless -d catdir(qw(lib overload));
39 my $p = safer_open(catfile(qw(lib overload numbers.pm)));
40
41
42 select $p;
43
44 {
45 local $" = "\n    ";
46 print <<"EOF";
47 # -*- buffer-read-only: t -*-
48 #
49 #   lib/overload/numbers.pm
50 #
51 #   Copyright (C) 2008 by Larry Wall and others
52 #
53 #   You may distribute under the terms of either the GNU General Public
54 #   License or the Artistic License, as specified in the README file.
55 #
56 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
57 # This file is built by overload.pl
58 #
59
60 package overload::numbers;
61
62 our \@names = qw#
63     @names
64 #;
65
66 our \@enums = qw#
67     @enums
68 #;
69
70 { my \$i = 0; our %names = map { \$_ => \$i++ } \@names }
71
72 { my \$i = 0; our %enums = map { \$_ => \$i++ } \@enums }
73
74 EOF
75 }
76
77
78 sub print_header {
79   my $file = shift;
80   print <<"EOF";
81 /* -*- buffer-read-only: t -*-
82  *
83  *    $file
84  *
85  *    Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007 by Larry Wall
86  *    and others
87  *
88  *    You may distribute under the terms of either the GNU General Public
89  *    License or the Artistic License, as specified in the README file.
90  *
91  *  !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
92  *  This file is built by overload.pl
93  */
94 EOF
95 }
96
97 select $c;
98 print_header('overload.c');
99
100 select $h;
101 print_header('overload.h');
102 print <<'EOF';
103
104 enum {
105 EOF
106
107 print "    ${_}_amg,\n", foreach @enums;
108
109 print <<'EOF';
110     max_amg_code
111     /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
112 };
113
114 #define NofAMmeth max_amg_code
115
116 EOF
117
118 print $c <<'EOF';
119
120 #define AMG_id2name(id) (PL_AMG_names[id]+1)
121 #define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
122
123 static const U8 PL_AMG_namelens[NofAMmeth] = {
124 EOF
125
126 my $last = pop @names;
127
128 print $c "    $_,\n" foreach map { length $_ } @names;
129
130 my $lastlen = length $last;
131 print $c <<"EOT";
132     $lastlen
133 };
134
135 static const char * const PL_AMG_names[NofAMmeth] = {
136   /* Names kept in the symbol table.  fallback => "()", the rest has
137      "(" prepended.  The only other place in perl which knows about
138      this convention is AMG_id2name (used for debugging output and
139      'nomethod' only), the only other place which has it hardwired is
140      overload.pm.  */
141 EOT
142
143 print $c "    \"$_\",\n" foreach map { s/(["\\"])/\\$1/g; $_ } @names;
144
145 print $c <<"EOT";
146     "$last"
147 };
148 EOT
149
150 safer_close($h);
151 safer_close($c);
152 safer_close($p);
153 rename_if_different("overload.c-new", "overload.c");
154 rename_if_different("overload.h-new","overload.h");
155
156 __DATA__
157 # Fallback should be the first
158 fallback        ()
159
160 # These 5 are the most common in the fallback switch statement in amagic_call
161 to_sv           (${}
162 to_av           (@{}
163 to_hv           (%{}
164 to_gv           (*{}
165 to_cv           (&{}
166
167 # These have non-default cases in that switch statement
168 inc             (++
169 dec             (--
170 bool_           (bool
171 numer           (0+
172 string          (""
173 not             (!
174 copy            (=
175 abs             (abs
176 neg             (neg
177 iter            (<>
178 int             (int
179
180 # These 12 feature in the next switch statement
181 lt              (<
182 le              (<=
183 gt              (>
184 ge              (>=
185 eq              (==
186 ne              (!=
187 slt             (lt
188 sle             (le
189 sgt             (gt
190 sge             (ge
191 seq             (eq
192 sne             (ne
193
194 nomethod        (nomethod
195 add             (+
196 add_ass         (+=
197 subtr           (-
198 subtr_ass       (-=
199 mult            (*
200 mult_ass        (*=
201 div             (/
202 div_ass         (/=
203 modulo          (%
204 modulo_ass      (%=
205 pow             (**
206 pow_ass         (**=
207 lshift          (<<
208 lshift_ass      (<<=
209 rshift          (>>
210 rshift_ass      (>>=
211 band            (&
212 band_ass        (&=
213 bor             (|
214 bor_ass         (|=
215 bxor            (^
216 bxor_ass        (^=
217 ncmp            (<=>
218 scmp            (cmp
219 compl           (~
220 atan2           (atan2
221 cos             (cos
222 sin             (sin
223 exp             (exp
224 log             (log
225 sqrt            (sqrt
226 repeat          (x
227 repeat_ass      (x=
228 concat          (.
229 concat_ass      (.=
230 smart           (~~
231 ftest           (-X
232 # Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
233 DESTROY         DESTROY