logic.pl

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

    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) = &expression();
    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 atom_production_2 {
    my $rcommit = shift;
    _try;
    my @item = 'atom_production_2';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = match_str('F');
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { 0 }; 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 not_expr_production_2 {
    _try;
    my @item = 'not_expr_production_2';
    my $text = $X::str;
    pos($text) = $X::pos;
    my ($match) = &brack_expr();
    if (defined $match) {
        _success;
        push @item, $match;
        return $match;
    } else {
        _fail;
        return undef;
    }
}

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

sub expression_production_2 {
    _try;
    my @item = 'expression_production_2';
    my $text = $X::str;
    pos($text) = $X::pos;
    my ($match) = &and_expr();
    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 and_expr_production_2 {
    _try;
    my @item = 'and_expr_production_2';
    my $text = $X::str;
    pos($text) = $X::pos;
    my ($match) = &not_expr();
    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";
    }
}