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