perl/regen_perly.pl
<<
>>
Prefs
   1#!/usr/bin/perl
   2#
   3# regen_perly.pl, DAPM 12-Feb-04
   4#
   5# Copyright (c) 2004, 2005 Larry Wall
   6#
   7# Given an input file perly.y, run bison on it and produce
   8# the following output files:
   9#
  10# perly.h       standard bison header file with minor doctoring of
  11#               #line directives plus adding a #ifdef PERL_CORE
  12#
  13# perly.tab     the parser table C definitions extracted from the bison output
  14#               plus an extra table generated by this script.
  15#
  16# perly.act     the action case statements extracted from the bison output
  17#
  18# Note that perly.c is *not* regenerated - this is now a static file which
  19# is not dependent on perly.y any more.
  20#
  21# If a filename of the form foo.y is given on the command line, then
  22# this is used instead as the basename for all the files mentioned
  23# above.
  24#
  25# Note that temporary files of the form perlytmp.h and perlytmp.c are
  26# created and then deleted during this process
  27#
  28# Note also that this script is intended to be run on a UNIX system;
  29# it may work elsewhere but no specific attempt has been made to make it
  30# portable.
  31
  32sub usage { die "usage: $0 [ -b bison_executable ] [ file.y ]\n" }
  33
  34use warnings;
  35use strict;
  36
  37my $bison = 'bison';
  38
  39if (@ARGV >= 2 and $ARGV[0] eq '-b') {
  40    shift;
  41    $bison = shift;
  42}
  43
  44my $y_file = shift || 'perly.y';
  45
  46usage unless @ARGV==0 && $y_file =~ /\.y$/;
  47
  48(my $h_file    = $y_file) =~ s/\.y$/.h/;
  49(my $act_file  = $y_file) =~ s/\.y$/.act/;
  50(my $tab_file  = $y_file) =~ s/\.y$/.tab/;
  51(my $tmpc_file = $y_file) =~ s/\.y$/tmp.c/;
  52(my $tmph_file = $y_file) =~ s/\.y$/tmp.h/;
  53
  54# the yytranslate[] table generated by bison is ASCII/EBCDIC sensitive
  55
  56die "$0: must be run on an ASCII system\n" unless ord 'A' == 65;
  57
  58# check for correct version number. The constraints are:
  59#  * must be >= 1.24 to avoid licensing issues.
  60#  * it must generate the yystos[] table. Version 1.28 doesn't generate
  61#    this; 1.35+ does
  62#  * Must produce output which is extractable by the regexes below
  63#  * Must produce the right values.
  64# These last two contstraints  may well be met by earlier versions, but
  65# I simply haven't tested them yet. If it works for you, then modify
  66# the test below to allow that version too. DAPM Feb 04.
  67
  68my $version = `$bison -V`;
  69unless ($version =~ /\b(1\.875[a-z]?|2\.[0134])\b/) { die <<EOF; }
  70
  71You have the wrong version of bison in your path; currently 1.875
  722.0, 2.1, 2.3 or 2.4 is required.  Try installing
  73    http://ftp.gnu.org/gnu/bison/bison-2.4.1.tar.gz
  74or similar.  Your bison identifies itself as:
  75
  76$version
  77EOF
  78
  79# creates $tmpc_file and $tmph_file
  80my_system("$bison -d -o $tmpc_file $y_file");
  81
  82open CTMPFILE, $tmpc_file or die "Can't open $tmpc_file: $!\n";
  83my $clines;
  84{ local $/; $clines = <CTMPFILE>; }
  85die "failed to read $tmpc_file: length mismatch\n"
  86    unless length $clines == -s $tmpc_file;
  87close CTMPFILE;
  88
  89my ($actlines, $tablines) = extract($clines);
  90
  91$tablines .= make_type_tab($y_file, $tablines);
  92
  93chmod 0644, $act_file;
  94open ACTFILE, ">$act_file" or die "can't open $act_file: $!\n";
  95print ACTFILE $actlines;
  96close ACTFILE;
  97chmod 0444, $act_file;
  98
  99chmod 0644, $tab_file;
 100open TABFILE, ">$tab_file" or die "can't open $tab_file: $!\n";
 101print TABFILE $tablines;
 102close TABFILE;
 103chmod 0444, $tab_file;
 104
 105unlink $tmpc_file;
 106
 107# Wrap PERL_CORE round the symbol definitions. Also,  the
 108# C<#line 30 "perly.y"> confuses the Win32 resource compiler and the
 109# C<#line 188 "perlytmp.h"> gets picked up by make depend, so remove them.
 110
 111open TMPH_FILE, $tmph_file or die "Can't open $tmph_file: $!\n";
 112chmod 0644, $h_file;
 113open H_FILE, ">$h_file" or die "Can't open $h_file: $!\n";
 114my $endcore_done = 0;
 115# Token macros need to be generated manually on bison 2.4
 116my $gather_tokens = ($version =~ /\b2\.4\b/ ? undef : 0);
 117my $tokens;
 118while (<TMPH_FILE>) {
 119    print H_FILE "#ifdef PERL_CORE\n" if $. == 1;
 120    if (!$endcore_done and /YYSTYPE_IS_DECLARED/) {
 121        print H_FILE "#endif /* PERL_CORE */\n";
 122        $endcore_done = 1;
 123    }
 124    next if /^#line \d+ ".*"/;
 125    if (not defined $gather_tokens) {
 126        $gather_tokens = 1 if /^\s* enum \s* yytokentype \s* \{/x;
 127    }
 128    elsif ($gather_tokens) {
 129        if (/^\# \s* endif/x) { # The #endif just after the end of the token enum
 130            $gather_tokens = 0;
 131            $_ .= "\n/* Tokens.  */\n$tokens";
 132        }
 133        else {
 134            my ($tok, $val) = /(\w+) \s* = \s* (\d+)/x;
 135            $tokens .= "#define $tok $val\n" if $tok;
 136        }
 137    }
 138    print H_FILE $_;
 139}
 140close TMPH_FILE;
 141close H_FILE;
 142chmod 0444, $h_file;
 143unlink $tmph_file;
 144
 145print "rebuilt:  $h_file $tab_file $act_file\n";
 146
 147exit 0;
 148
 149
 150sub extract {
 151    my $clines = shift;
 152    my $tablines;
 153    my $actlines;
 154
 155    $clines =~ m@
 156        (?:
 157            ^/* YYFINAL[^\n]+\n         #optional comment
 158        )?
 159        \# \s* define \s* YYFINAL       # first #define
 160        .*?                             # other defines + most tables
 161        yystos\[\]\s*=                  # start of last table
 162        .*?
 163        }\s*;                           # end of last table
 164    @xms
 165        or die "Can't extract tables from $tmpc_file\n";
 166    $tablines = $&;
 167
 168
 169    $clines =~ m@
 170        switch \s* \( \s* \w+ \s* \) \s* { \s*
 171        (
 172            case \s* \d+ \s* :
 173            \s*
 174            (?: \s* /\* .*? \*/ \s* )*  # optional C-comments
 175            \s*
 176            \#line [^\n]+"\Q$y_file\E"
 177            .*?
 178        )
 179        }
 180        \s*
 181        (?: \s* /\* .*? \*/ \s* )*      # optional C-comments
 182        \s*
 183        (
 184            \#line[^\n]+\.c"
 185        |
 186            \#line[^\n]+\.simple"
 187        |
 188            YY_SYMBOL_PRINT
 189        )
 190    @xms
 191        or die "Can't extract actions from $tmpc_file\n";
 192    $actlines = $1;
 193
 194    # Remove extraneous comments from bison 2.4
 195    $actlines =~ s!\s* /\* \s* Line \s* \d+ \s* of \s* yacc\.c \s* \*/!!gx;
 196
 197    # C<#line 188 "perlytmp.c"> gets picked up by make depend, so remove them.
 198    $actlines =~ s/^#line \d+ "\Q$tmpc_file\E".*$//gm;
 199
 200    # convert yyvsp[nnn] into ps[nnn].val
 201
 202    $actlines =~ s/yyvsp\[(.*?)\]/ps[$1].val/g
 203        or die "Can't convert value stack name\n";
 204
 205    return $actlines. "\n", $tablines. "\n";
 206}
 207
 208# Generate a table, yy_type_tab[], that specifies for each token, what
 209# type of value it holds.
 210#
 211# Read the .y file and extract a list of all the token names and
 212# non-terminal names; then scan the string $tablines for the table yytname,
 213# which gives the token index of each token/non-terminal; then use this to
 214# create yy_type_tab.
 215#
 216# ie given (in perly.y),
 217#
 218#   %token <opval> A
 219#   %token <ival>  B
 220#   %type  <pval>  C
 221#   %type  <opval> D
 222#
 223# and (in $tablines),
 224#
 225#   yytname[] = { "A" "B", "C", "D", "E" };
 226#
 227# then return
 228#
 229#    typedef enum { toketype_ival, toketype_opval, toketype_pval } toketypes;
 230#
 231#    static const toketypes yy_type_tab[]
 232#          = { toketype_opval, toketype_ival, toketype_pval,
 233#                toketype_opval, toketype_ival }
 234#
 235# where "E" has the default type. The default type is determined
 236# by the __DEFAULT__ comment  next to the appropriate union member in
 237# perly.y
 238
 239sub make_type_tab {
 240    my ($y_file, $tablines) = @_;
 241    my %tokens;
 242    my %types;
 243    my $default_token;
 244    open my $fh, '<', $y_file or die "Can't open $y_file: $!\n";
 245    while (<$fh>) {
 246        if (/(\$\d+)\s*=/) {
 247            warn "$y_file:$.: dangerous assignment to $1: $_";
 248        }
 249
 250        if (/__DEFAULT__/) {
 251            m{(\w+) \s* ; \s* /\* \s* __DEFAULT__}x
 252                or die "$y_file: can't parse __DEFAULT__ line: $_";
 253            die "$y_file: duplicate __DEFAULT__ line: $_"
 254                    if defined $default_token;
 255            $default_token = $1;
 256            next;
 257        }
 258
 259        next unless /^%(token|type)/;
 260        s/^%(token|type)\s+<(\w+)>\s+//
 261            or die "$y_file: unparseable token/type line: $_";
 262        $tokens{$_} = $2 for (split ' ', $_);
 263        $types{$2} = 1;
 264    }
 265    die "$y_file: no __DEFAULT__ token defined\n" unless $default_token;
 266    $types{$default_token} = 1;
 267
 268    $tablines =~ /^\Qstatic const char *const yytname[] =\E\n
 269            {\n
 270            (.*?)
 271            ^};
 272            /xsm
 273        or die "Can't extract yytname[] from table string\n";
 274    my $fields = $1;
 275    $fields =~ s{"([^"]+)"}
 276                { "toketype_" .
 277                    (defined $tokens{$1} ? $tokens{$1} : $default_token)
 278                }ge;
 279    $fields =~ s/, \s* 0 \s* $//x
 280        or die "make_type_tab: couldn't delete trailing ',0'\n";
 281
 282    return 
 283          "\ntypedef enum {\n\t"
 284        . join(", ", map "toketype_$_", sort keys %types)
 285        . "\n} toketypes;\n\n"
 286        . "/* type of each token/terminal */\n"
 287        . "static const toketypes yy_type_tab[] =\n{\n"
 288        . $fields
 289        . "\n};\n";
 290}
 291
 292
 293sub my_system {
 294    system(@_);
 295    if ($? == -1) {
 296        die "failed to execute command '@_': $!\n";
 297    }
 298    elsif ($? & 127) {
 299        die sprintf "command '@_' died with signal %d\n",
 300            ($? & 127);
 301    }
 302    elsif ($? >> 8) {
 303        die sprintf "command '@_' exited with value %d\n", $? >> 8;
 304    }
 305}
 306
lxr.linux.no kindly hosted by Redpill Linpro AS, provider of Linux consulting and operations services since 1995.