| 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 | regexp (qr |
| 233 | # Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry |
| 234 | DESTROY DESTROY |