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