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