arithmetic.pl

这是一个DFA简化和生成LL(1)分析表的程序,自动生成表格及图形

#: parser.pl

package main;

our $RD_TRACE = undef;   # default off
our $RD_VERBOSE = undef; # default off

package X;

our ($str, $pos, $level);

package Parser;

use strict;
use warnings;

sub _rulename {
    my $sub = (caller 2)[3];
    $sub =~ s/^\w+:://g;
    $sub;
}

sub _try {
    return if !$::RD_TRACE;
    my $rule;
    if (@_) {
        $rule = shift;
    } else {
        $rule = _rulename;
    }
    $X::level++;
    my $indent = '  ' x $X::level;
    if ($::RD_VERBOSE or !defined $X::saved_pos or $X::saved_pos != $X::pos) {
        my $next = substr($X::str, $X::pos, 15);
        $next =~ s/\n/\\n/g;
        $next =~ s/\t/\\t/g;
        if (length(substr $X::str, $X::pos) > 15) {
            $next .= '...';
        }
        print "${indent}trying $rule...    [$next]\n";
        $X::saved_pos = $X::pos;
    } else {
        print "${indent}trying $rule...\n";
    }
}

sub _fail {
    return if !$::RD_TRACE;
    my $rule;
    if (@_) {
        $rule = shift;
    } else {
        $rule = _rulename;
    }
    my $indent = '  ' x $X::level;
    print "${indent}FAIL to match $rule...\n";
    $X::level--;
}

sub _success {
    return if !$::RD_TRACE;
    my $rule;
    if (@_) {
        $rule = shift;
    } else {
        $rule = _rulename;
    }
    my $indent = '  ' x $X::level;
    print "${indent}>>MATCH<< $rule...\n";
    $X::level--;
}

sub new {
    my $class = shift;
    $class;
}

sub parse {
    my ($self, $text) = @_;
    $X::str = $text;
    $X::pos = 0;
    $X::level = 0;
    return input();
}

sub factor {
    _try;
    my ($match, $commit);
    ($match) = &factor_production_1(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    if ($commit) {
        _fail;
        return undef;
    }
    ($match) = &factor_production_2(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    _fail;
    undef;
}

sub factor_production_2 {
    my $rcommit = shift;
    _try;
    my @item = 'factor_production_2';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = match_str('(');
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = &expr();
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = match_str(')');
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { $item[2] }; if (defined $match and pos($text)>$X::pos) { $X::pos=pos($text); };
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    _success;
    $item[-1];
}

sub expr {
    my $rcommit = shift;
    _try;
    my @item = 'expr';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = match_leftop( \&term, q/([-+])/, \&term );
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { eval join(' ', @{$item[1]}); }; if (defined $match and pos($text)>$X::pos) { $X::pos=pos($text); };
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    _success;
    $item[-1];
}

sub input {
    my $rcommit = shift;
    _try;
    my @item = 'input';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = &expr();
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = &eof();
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { $item[1] }; if (defined $match and pos($text)>$X::pos) { $X::pos=pos($text); };
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    _success;
    $item[-1];
}

sub factor_production_1 {
    my $rcommit = shift;
    _try;
    my @item = 'factor_production_1';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = repeat_0_1( sub { &neg } );
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = &number();
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { my $neg = $item[1]->[0] || ''; $neg . $item[2] }; if (defined $match and pos($text)>$X::pos) { $X::pos=pos($text); };
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    _success;
    $item[-1];
}

sub term {
    my $rcommit = shift;
    _try;
    my @item = 'term';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = match_leftop( \&factor, q/([*\/])/, \&factor );
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { eval join(' ', @{$item[1]}); }; if (defined $match and pos($text)>$X::pos) { $X::pos=pos($text); };
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    _success;
    $item[-1];
}

sub number {
    _try;
    my @item = 'number';
    my $text = $X::str;
    pos($text) = $X::pos;
    my ($match) = match_re(q/[1-9]\d*/);
    if (defined $match) {
        _success;
        push @item, $match;
        return $match;
    } else {
        _fail;
        return undef;
    }
}

sub eof {
    _try;
    my @item = 'eof';
    my $text = $X::str;
    pos($text) = $X::pos;
    my ($match) = match_re(q/^\Z/);
    if (defined $match) {
        _success;
        push @item, $match;
        return $match;
    } else {
        _fail;
        return undef;
    }
}

sub neg {
    _try;
    my @item = 'neg';
    my $text = $X::str;
    pos($text) = $X::pos;
    my ($match) = match_str('-');
    if (defined $match) {
        _success;
        push @item, $match;
        return $match;
    } else {
        _fail;
        return undef;
    }
}

sub match_str {
    my $target = shift;
    _try("'$target'");
    my $text = $X::str;
    pos($text) = $X::pos;
    if ($text =~ m/\G\s+/gc) {
        $X::pos += length($&);
    }
    #warn substr($text, $X::pos), "\n";
    my $len = length($target);
    my $equal = (substr($text, $X::pos, $len) eq $target);
    if (!$equal) {
        _fail("'$target'");
        return undef;
    }
    $X::pos += $len;
    _success("'$target'");
    return $target;
}

sub match_re {
    my $re = shift;
    _try("/$re/");
    my $text = $X::str;
    pos($text) = $X::pos;
    if ($text =~ m/\G\s+/gc) {
        $X::pos += length($&);
    }
    if ($re eq "^\\Z") {
        #warn "Matching end of file";
        if ($X::pos == length($X::str)) {
            _success("/$re/");
            return 1;
        }
        _fail("/$re/");
        return undef;
    }
    if ($text !~ /\G(?:$re)/) {
        _fail("/$re/");
        return undef;
    }
    my $match = $&;
    $X::grouping = $1;
    $X::pos += length($&);
    _success("/$re/");
    return $match;
}

sub repeat_1_n_sep {
    my ($coderef, $sep) = @_;
    my @retval;
    my $match = $coderef->();
    if (!defined $match) {
        return undef;
    }
    push @retval, $match;
    while (1) {
        my $saved_pos = $X::pos;
        my $match = match_re($sep);
        last if !defined $match;
        my $sep_match;
        if (defined $X::grouping) {
            $sep_match = $match;
        }
        $match = $coderef->();
        if (!defined $match) {
            $X::pos = $saved_pos;
            last;
        }
        last if $X::pos == $saved_pos;
        push @retval, $sep_match if defined $sep_match;
        push @retval, $match;
    }
    \@retval;
}

sub repeat_1_n {
    my ($coderef) = @_;
    my $match = $coderef->();
    if (!defined $match) {
        return undef;
    }
    my @retval;
    push @retval, $match;
    while (1) {
        my $saved_pos = $X::pos;
        my $match = $coderef->();
        last if !defined $match;
        last if $X::pos == $saved_pos;
        push @retval, $match;
    }
    \@retval;
}

sub repeat_0_n_sep {
    my ($coderef, $sep) = @_;
    my @retval;
    my $match = $coderef->();
    if (!defined $match) {
        return [];
    }
    push @retval, $match;
    while (1) {
        my $saved_pos = $X::pos;
        my $match = match_re($sep);
        last if !defined $match;
        my $sep_match;
        if (defined $X::grouping) {
            $sep_match = $match;
        }
        $match = $coderef->();
        if (!defined $match) {
            $X::pos = $saved_pos;
            last;
        }
        last if $X::pos == $saved_pos;
        push @retval, $sep_match if defined $sep_match;
        push @retval, $match;
    }
    \@retval;
}

sub repeat_0_n {
    my $coderef = $_[0];
    my @retval;
    my $match = $coderef->();
    if (!defined $match) {
        return [];
    }
    push @retval, $match;
    while (1) {
        my $saved_pos = $X::pos;
        my $match = $coderef->();
        last if $X::pos == $saved_pos;
        if (defined $match) {
            push @retval, $match;
        } else {
            last;
        }
    }
    \@retval;
}

sub repeat_0_1 {
    my $coderef = $_[0];
    my $match = $coderef->();
    if (!defined $match) {
        [];
    } else {
        [$match];
    }
}

sub match_leftop {
    my ($sub1, $sep, $sub2) = @_;
    my @retval;
    my $match = $sub1->();
    return undef if !defined $match;
    push @retval, $match;
    while (1) {
        my $saved_pos = $X::pos;
        my $match = match_re($sep);
        last if !defined $match;
        my $sep_match;
        if (defined $X::grouping) {
            $sep_match = $match;
        }
        $match = $sub2->();
        if (!defined $match) {
            $X::pos = $saved_pos;
            last;
        }
        last if $X::pos == $saved_pos;
        push @retval, $sep_match if defined $sep_match;
        push @retval, $match;
    }
    \@retval;
}

sub error {
    my $verbose = shift;
    if ($verbose) {
        #warn "Syntax error.\n";
    }
    undef;
}

package main;

use strict;
use warnings;
use Data::Dumper;
use Getopt::Std;

my %opts;
getopts('d', \%opts);

local $/;
my $src = <>;
die "No input source code.\n" if !defined $src;

my $parser = Parser->new;
my $ast;
if ($opts{d}) {
    $::RD_TRACE = 1;
    $ast = $parser->parse($src);
    print "\n", defined($ast) ? 'success' : 'fail', "\n";
} else {
    $::Data::Dumper::Indent = 1;
    $ast = $parser->parse($src);
    if (!defined $ast) {
        warn "Syntax error.\n";
        exit(1);
    } elsif (ref $ast) {
        print Data::Dumper->Dump([$ast], ['AST']);
    } else {
        print $ast, "\n";
    }
}