logic.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 root();
}

sub brack_expr {
    _try;
    my ($match, $commit);
    ($match) = &brack_expr_production_1(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    if ($commit) {
        _fail;
        return undef;
    }
    ($match) = &brack_expr_production_2(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    _fail;
    undef;
}

sub and_expr {
    _try;
    my ($match, $commit);
    ($match) = &and_expr_production_1(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    if ($commit) {
        _fail;
        return undef;
    }
    ($match) = &and_expr_production_2(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    _fail;
    undef;
}

sub atom {
    _try;
    my ($match, $commit);
    ($match) = &atom_production_1(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    if ($commit) {
        _fail;
        return undef;
    }
    ($match) = &atom_production_2(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    _fail;
    undef;
}

sub expression {
    _try;
    my ($match, $commit);
    ($match) = &expression_production_1(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    if ($commit) {
        _fail;
        return undef;
    }
    ($match) = &expression_production_2(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    _fail;
    undef;
}

sub not_expr {
    _try;
    my ($match, $commit);
    ($match) = &not_expr_production_1(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    if ($commit) {
        _fail;
        return undef;
    }
    ($match) = &not_expr_production_2(\$commit);
    if (defined $match) {
        _success;
        return $match;
    }
    _fail;
    undef;
}

sub atom_production_1 {
    my $rcommit = shift;
    _try;
    my @item = 'atom_production_1';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = match_str('T');
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { 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 expression_production_1 {
    my $rcommit = shift;
    _try;
    my @item = 'expression_production_1';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = &and_expr();
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = match_str('OR');
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = &expression();
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { $item[1] || $item[3] }; 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 and_expr_production_1 {
    my $rcommit = shift;
    _try;
    my @item = 'and_expr_production_1';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = &not_expr();
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = match_str('AND');
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = &and_expr();
    if (!defined $match) {
        $X::pos = $saved_pos;
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = do { $item[1] && $item[3] }; 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_1 {
    my $rcommit = shift;
    _try;
    my @item = 'not_expr_production_1';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = match_str('NOT');
    if (!defined $match) {
        _fail;
        return undef;
    }
    push @item, $match;
    ($match) = &brack_expr();
    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 root {
    my $rcommit = shift;
    _try;
    my @item = 'root';
    my $text = $X::str;
    pos($text) = $X::pos;
    my $match;
    my $saved_pos = $X::pos;
    ($match) = &expression();
    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] ? 'T' : 'F' }; 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 brack_expr_production_1 {
    my $rcommit = shift;
    _try;
    my @item = 'brack_expr_production_1';