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