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