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