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