The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!/usr/bin/perl -w
use strict;
#use Test::More qw(no_plan);
use Test::More tests => 5;

#use Test::Exception;
our $test_exception_installed;
BEGIN { 
$test_exception_installed = 1;
eval { require Test::Exception };
$test_exception_installed = 0 if $@;
}

use_ok qw(Parse::Eyapp) or exit;
use Data::Dumper;
use_ok qw( Parse::Eyapp::Treeregexp) or exit;

my $translationscheme = q{
%{
# head code is available at tree construction time 
use Data::Dumper;

our %sym; # symbol table
our %Op = ( PLUS => '+', MINUS => '-', 'TIMES' => '*', DIV => '/');
%}

%defaultaction { $lhs->{n} = eval " $left->{n} $Op{$lhs->type} $right->{n} " }

%metatree

%left   '='
%left   '-' '+'
%left   '*' '/'

%%
line:       %name EXP  
              exp <+ ';'> /* Expressions separated by semicolons */ 
	        { $lhs->{n} = $_[1]->Last_child->{n} }
;

exp:    
            %name PLUS  
              exp.left '+' exp.right 
        |   %name MINUS
	      exp.left '-' exp.right    
        |   %name TIMES 
              exp.left '*' exp.right  
        |   %name DIV 
              exp.left '/' exp.right  
        |   %name NUM   $NUM          
	        { $lhs->{n} = $NUM->{attr} }
        |   '(' $exp ')'  %begin { $exp }       
        |   %name VAR
	      $VAR                 
	        { $lhs->{n} = $sym{$VAR->{attr}}->{n} }
        |   %name ASSIGN
	      $VAR '=' $exp         
	        { $lhs->{n} = $sym{$VAR->{attr}}->{n} = $exp->{n} }

;

%%
# tail code is available at tree construction time 
sub _Error {
  die "Syntax error.\n";
}

sub _Lexer {
    my($parser)=shift;

    for ($parser->YYData->{INPUT}) {
        defined($_) or  return('',undef);

        s/^\s*//;
        s/^([0-9]+(?:\.[0-9]+)?)// and return('NUM',$1);
        s/^([A-Za-z][A-Za-z0-9_]*)// and return('VAR',$1);
        s/^(.)// and return($1,$1);
        s/^\s*//;
    }
}

sub Run {
    my($self)=shift;
    return $self->YYParse( yylex => \&_Lexer, yyerror => \&_Error );
}
}; # end translation scheme

$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
$Data::Dumper::Deepcopy  = 1;


SKIP: {
  skip "Test::Exception not installed", 1 unless $test_exception_installed;
  Test::Exception::lives_ok { Parse::Eyapp->new_grammar(
      input=>$translationscheme,
      classname=>'main',
      firstline => 6,
      #outputfile => 'main.pm'
  ) } 'No errors in input translation scheme';
}

unless ($test_exception_installed) {
  Parse::Eyapp->new_grammar(
      input=>$translationscheme,
      classname=>'main',
      firstline => 6,
      #outputfile => 'main.pm'
  ) 
}
my $parser = main->new();
#print "Write a sequence of arithmetic expressions: " if is_interactive();
$parser->YYData->{INPUT} = 'a=2*3; b= 1+a; a*b'; # <>;
my $t = $parser->Run() or die "Syntax Error analyzing input";

$t->translation_scheme;
my $treestring = Dumper($t);
our %sym;
my $symboltable = Dumper(\%sym);
my $expectedsym = { 'a' => { 'n' => 6 }, 'b' => { 'n' => 7 } };
is_deeply(\%sym, $expectedsym, "symbol tables");

my $expected_result = 42;
is($t->{n}, $expected_result, "a=2*3; b= 1+a; a*b == 42");

# print <<"EOR";
# ***********Tree*************
# $treestring
# ******Symbol table**********
# $symboltable
# ************Result**********
# $t->{n}
# 
# EOR