regen/overload.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Regenerate (overwriting only if changed):
   4 #
   5 #    overload.h
   6 #    overload.inc
   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 my ($c, $h) = map {
  34     open_new($_, '>',
  35              { by => 'regen/overload.pl', file => $_, style => '*',
  36                copyright => [1997, 1998, 2000, 2001, 2005 .. 2007, 2011] });
  37 } 'overload.inc', 'overload.h';
  38
  39 mkdir("lib/overload", 0777) unless -d 'lib/overload';
  40 my $p = open_new('lib/overload/numbers.pm', '>',
  41                  { by => 'regen/overload.pl',
  42                    file => 'lib/overload/numbers.pm', copyright => [2008] });
  43
  44 {
  45 local $" = "\n    ";
  46 print $p <<"EOF";
  47 package overload::numbers;
  48
  49 our \@names = qw#
  50     @names
  51 #;
  52
  53 our \@enums = qw#
  54     @enums
  55 #;
  56
  57 { my \$i = 0; our %names = map { \$_ => \$i++ } \@names }
  58
  59 { my \$i = 0; our %enums = map { \$_ => \$i++ } \@enums }
  60 EOF
  61 }
  62
  63 print $h "enum {\n";
  64
  65 for (0..$#enums) {
  66     my $op = $names[$_];
  67     $op = 'fallback' if $op eq '()';
  68     $op =~ s/^\(//;
  69     die if $op =~ m{\*/};
  70     my $l =   3 - int((length($enums[$_]) + 9) / 8);
  71     $l = 1 if $l < 1;
  72     printf $h "    %s_amg,%s/* 0x%02x %-8s */\n", $enums[$_],
  73         ("\t" x $l), $_, $op;
  74 }
  75
  76 print $h <<'EOF';
  77     max_amg_code
  78     /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
  79 };
  80
  81 #define NofAMmeth max_amg_code
  82 EOF
  83
  84 print $c <<'EOF';
  85 #define AMG_id2name(id) (PL_AMG_names[id]+1)
  86 #define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
  87
  88 static const U8 PL_AMG_namelens[NofAMmeth] = {
  89 EOF
  90
  91 my $last = pop @names;
  92
  93 print $c map { "    " . (length $_) . ",\n" } @names;
  94
  95 my $lastlen = length $last;
  96 print $c <<"EOT";
  97     $lastlen
  98 };
  99
 100 static const char * const PL_AMG_names[NofAMmeth] = {
 101   /* Names kept in the symbol table.  fallback => "()", the rest has
 102      "(" prepended.  The only other place in perl which knows about
 103      this convention is AMG_id2name (used for debugging output and
 104      'nomethod' only), the only other place which has it hardwired is
 105      overload.pm.  */
 106 EOT
 107
 108 for (0..$#names) {
 109     my $n = $names[$_];
 110     $n =~ s/(["\\])/\\$1/g;
 111     my $l =   3 - int((length($n) + 7) / 8);
 112     $l = 1 if $l < 1;
 113     printf $c "    \"%s\",%s/* %-10s */\n", $n, ("\t" x $l), $enums[$_];
 114 }
 115
 116 print $c <<"EOT";
 117     "$last"
 118 };
 119 EOT
 120
 121 foreach ($h, $c, $p) {
 122     read_only_bottom_close_and_rename($_);
 123 }
 124 __DATA__
 125 # Fallback should be the first
 126 fallback        ()
 127
 128 # These 5 are the most common in the fallback switch statement in amagic_call
 129 to_sv           (${}
 130 to_av           (@{}
 131 to_hv           (%{}
 132 to_gv           (*{}
 133 to_cv           (&{}
 134
 135 # These have non-default cases in that switch statement
 136 inc             (++
 137 dec             (--
 138 bool_           (bool
 139 numer           (0+
 140 string          (""
 141 not             (!
 142 copy            (=
 143 abs             (abs
 144 neg             (neg
 145 iter            (<>
 146 int             (int
 147
 148 # These 12 feature in the next switch statement
 149 lt              (<
 150 le              (<=
 151 gt              (>
 152 ge              (>=
 153 eq              (==
 154 ne              (!=
 155 slt             (lt
 156 sle             (le
 157 sgt             (gt
 158 sge             (ge
 159 seq             (eq
 160 sne             (ne
 161
 162 nomethod        (nomethod
 163 add             (+
 164 add_ass         (+=
 165 subtr           (-
 166 subtr_ass       (-=
 167 mult            (*
 168 mult_ass        (*=
 169 div             (/
 170 div_ass         (/=
 171 modulo          (%
 172 modulo_ass      (%=
 173 pow             (**
 174 pow_ass         (**=
 175 lshift          (<<
 176 lshift_ass      (<<=
 177 rshift          (>>
 178 rshift_ass      (>>=
 179 band            (&
 180 band_ass        (&=
 181 sband           (&.
 182 sband_ass       (&.=
 183 bor             (|
 184 bor_ass         (|=
 185 sbor            (|.
 186 sbor_ass        (|.=
 187 bxor            (^
 188 bxor_ass        (^=
 189 sbxor           (^.
 190 sbxor_ass       (^.=
 191 ncmp            (<=>
 192 scmp            (cmp
 193 compl           (~
 194 scompl          (~.
 195 atan2           (atan2
 196 cos             (cos
 197 sin             (sin
 198 exp             (exp
 199 log             (log
 200 sqrt            (sqrt
 201 repeat          (x
 202 repeat_ass      (x=
 203 concat          (.
 204 concat_ass      (.=
 205 smart           (~~
 206 ftest           (-X
 207 regexp          (qr