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