overload.pl

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