El siguiente programa calculator.pl
recibe como entrada una expresión en infijo.
La ejecución consta de dos bucles. En la primera parte se inyecta a la jerarquía de clases de los AST generados para las expresiones en infijo una semántica que permite evaluar la expresión:
58 require EvalCalc;
59
60 test_calc(
61 'Evaluating infix arithmetic expressions (CTRL-D to end in unix) ',
62 sub { print &Data::Dumper::Dumper(shift()) },
63 );
En esta primera parte mostraremos además el AST
construido para la expresión infija de entrada.
pl@nereida:~/Lregexpgrammars/demo$ ./calculator.pl Evaluating infix arithmetic expressions (CTRL-D to end in unix) 8-4-2 $VAR1 = bless( { 'operands' => [ bless( { 'operands' => [ bless( { 'operands' => [ bless( { 'operands' => [ bless( { 'operands' => [ bless( { '' => '8', 'val' => '8' }, 'factor' ) ], '' => '8' }, 'factorial' ) ], '' => '8' }, 'power' ) ], '' => '8' }, 'uneg' ) ], '' => '8' }, 'term' ), bless( { 'operands' => [ bless( { 'operands' => [ bless( { 'operands' => [ bless( { 'operands' => [ bless( { '' => '4', 'val' => '4' }, 'factor' ) ], '' => '4' }, 'factorial' ) ], '' => '4' }, 'power' ) ], '' => '4' }, 'uneg' ) ], '' => '4' }, 'term' ), bless( { 'operands' => [ bless( { 'operands' => [ bless( { 'operands' => [ bless( { 'operands' => [ bless( { '' => '2', 'val' => '2' }, 'factor' ) ], '' => '2' }, 'factorial' ) ], '' => '2' }, 'power' ) ], '' => '2' }, 'uneg' ) ], '' => '2' }, 'term' ) ], '' => '8-4-2', 'operators' => [ '-', '-' ] }, 'expr' ); 2Observamos que la asociatividad es la correcta. El
2 final es el resultado de la evaluación de
8-4-2.
La estructura del árbol se corresponde con la de la gramática:
8 my $rbb = do {
9 use Regexp::Grammars;
10
11 qr{
12 \A<expr>\z
13
14 <objrule: expr> <[operands=term]> ** <[operators=addop]>
15
16 <objrule: term> <[operands=uneg]> ** <[operators=mulop]>
17
18 <objrule: uneg> <[operators=minus]>* <[operands=power]>
19
20 <objrule: power> <[operands=factorial]> ** <[operators=powerop]>
21
22 <objrule: factorial> <[operands=factor]> <[operators=(!)]>*
23
24 <objrule: factor> <val=([+-]?\d+(?:\.\d*)?)>
25 | \( <MATCH=expr> \)
26
27 <token: addop> [+-]
28
29 <token: mulop> [*/]
30
31 <token: powerop> \*\*|\^
32
33 <token: minus> - <MATCH=(?{ 'NEG' })>
34
35 }x;
36 };
Ahora, en una segunda parte sobreescribimos los métodos
sem que describen la semántica para producir una traducción
de infijo a postfijo:
66 require PostfixCalc;
67 test_calc('Translating expressions to postfix (CTRL-D to end in unix) ');
Ahora al proporcionar la entrada 6--3! obtenemos:
Translating expressions to postfix (CTRL-D to end in unix) 6--3! 6 3 ! ~ -Aquí
~ es el operador de negación unaria y ! es el operador
factorial.
Estos son los ficheros que integran la aplicación:
pl@nereida:~/Lregexpgrammars/demo/calculator$ tree . |-- EvalCalc.pm # Soporte para la evaluación de la expresión: sem |-- Operator.pm # Soporte a las clases nodo: recorridos |-- PostfixCalc.pm # Soporte para la traducción a postfijo: sem `-- calculator.pl # programa principal
En el programa principal definimos la gramática
y escribimos una subrutina test_calc
que realiza el parsing.
pl@nereida:~/Lregexpgrammars/demo/calculator$ cat -n calculator.pl 1 #!/usr/bin/env perl5.10.1 2 use strict; 3 use warnings; 4 use 5.010; 5 use Data::Dumper; 6 $Data::Dumper::Indent = 1; 7 8 my $rbb = do { 9 use Regexp::Grammars; 10 11 qr{ 12 \A<expr>\z 13 14 <objrule: expr> <[operands=term]> ** <[operators=addop]> 15 16 <objrule: term> <[operands=uneg]> ** <[operators=mulop]> 17 18 <objrule: uneg> <[operators=minus]>* <[operands=power]> 19 20 <objrule: power> <[operands=factorial]> ** <[operators=powerop]> 21 22 <objrule: factorial> <[operands=factor]> <[operators=(!)]>* 23 24 <objrule: factor> <val=([+-]?\d+(?:\.\d*)?)> 25 | \( <MATCH=expr> \) 26 27 <token: addop> [+-] 28 29 <token: mulop> [*/] 30 31 <token: powerop> \*\*|^ 32 33 <token: minus> - <MATCH=(?{ 'NEG' })> 34 35 }x; 36 }; 37 38 sub test_calc { 39 my $prompt = shift; 40 my $handler = shift; 41 42 say $prompt; 43 while (my $input = <>) { 44 chomp($input); 45 if ($input =~ m{$rbb}) { 46 my $tree = $/{expr}; 47 $handler->($tree) if $handler; 48 49 say $tree->ceval; 50 51 } 52 else { 53 say("does not match"); 54 } 55 } 56 } 57 58 require EvalCalc; 59 60 test_calc( 61 'Evaluating infix arithmetic expressions (CTRL-D to end in unix) ', 62 sub { print &Data::Dumper::Dumper(shift()) }, 63 ); 64 65 66 require PostfixCalc; 67 test_calc('Translating expressions to postfix (CTRL-D to end in unix) ');
Los nodos del AST poseen un método ceval que se encarga de
realizar la traducción del nodo.
pl@nereida:~/Lregexpgrammars/demo/calculator$ cat -n Operator.pm
1 # Class hierarchy diagram:
2 # $ vgg -t 'Operator(LeftBinaryOp(expr,term),RightBinaryOp(power),PreUnaryOp(uneg),PostUnaryOp(factorial))'
3 # +--------+
4 # |Operator|
5 # +--------+
6 # .---------------.----^--------.-------------.
7 # +------------+ +-------------+ +----------+ +-----------+
8 # |LeftBinaryOp| |RightBinaryOp| |PreUnaryOp| |PostUnaryOp|
9 # +------------+ +-------------+ +----------+ +-----------+
10 # .---^--. | | |
11 # +----+ +----+ +-----+ +----+ +---------+
12 # |expr| |term| |power| |uneg| |factorial|
13 # +----+ +----+ +-----+ +----+ +---------+
14 #
15 #
16 # NOTE: package "factor" actually implements numbers and is
17 # outside this hierarchy
18 #
19 package Operator;
20 use strict;
21 use Carp;
22
23 sub Operands {
24 my $self = shift;
25
26 return () unless exists $self->{operands};
27 return @{$self->{operands}};
28 }
29
30 sub Operators {
31 my $self = shift;
32
33 return () unless exists $self->{operators};
34 return @{$self->{operators}};
35 }
36
37 sub sem {
38 confess "not defined sem";
39 }
40
41 sub make_sem {
42 my $class = shift;
43 my %semdesc = @_;
44
45 for my $class (keys %semdesc) {
46 my %sem = %{$semdesc{$class}};
47
48 # Install 'sem' method in $class
49 no strict 'refs';
50 no warnings 'redefine';
51 *{$class."::sem"} = sub {
52 my ($self, $op) = @_;
53 $sem{$op}
54 };
55 }
56 }
57
58 package LeftBinaryOp;
59 use base qw{Operator};
60
61 sub ceval {
62 my $self = shift;
63
64 # recursively evaluate the children first
65 my @operands = map { $_->ceval } $self->Operands;
66
67 # then combine them
68 my $s = shift @operands;
69 for ($self->Operators) {
70 $s = $self->sem($_)->($s, shift @operands);
71 }
72 return $s;
73 }
74
75 package RightBinaryOp;
76 use base qw{Operator};
77
78 sub ceval {
79 my $self = shift;
80
81 # recursively evaluate the children first
82 my @operands = map { $_->ceval } $self->Operands;
83
84 # then combine them
85 my $s = pop @operands;
86 for (reverse $self->Operators) {
87 $s = $self->sem($_)->(pop @operands, $s);
88 }
89 return $s;
90 }
91
92 package PreUnaryOp;
93 use base qw{Operator};
94
95 sub ceval {
96 my $self = shift;
97
98 # recursively evaluate the children first
99 my @operands = map { $_->ceval } $self->Operands;
100
101 # then combine them
102 my $s = shift @operands;
103 for (reverse $self->Operators) {
104 $s = $self->sem($_)->($s);
105 }
106 return $s;
107 }
108
109 package PostUnaryOp;
110 use base qw{Operator};
111
112 sub ceval {
113 my $self = shift;
114
115 # recursively evaluate the children first
116 my @operands = map { $_->ceval } $self->Operands;
117
118 # then combine them
119 my $s = shift @operands;
120 for ($self->Operators) {
121 $s = $self->sem($_)->($s);
122 }
123 return $s;
124 }
125
126 package term;
127 use base qw{LeftBinaryOp};
128
129 package expr;
130 use base qw{LeftBinaryOp};
131
132 package power;
133 use base qw{RightBinaryOp};
134
135 package uneg;
136 use base qw{PreUnaryOp};
137
138 package factorial;
139 use base qw{PostUnaryOp};
140
141 package factor;
142
143 sub ceval {
144 my $self = shift;
145
146 return $self->{val};
147 }
148
149 1;
pl@nereida:~/Lregexpgrammars/demo/calculator$ cat -n EvalCalc.pm
1 package EvalCalc;
2 use strict;
3 use Carp;
4
5 use Operator;
6
7 ####
8 sub f {
9 $_[0]>1?$_[0]*f($_[0]-1):1;
10 }
11
12 sub fac {
13 my $n = shift;
14
15 confess "Not valid number" unless $n =~ /^\d+$/;
16 f($n);
17 };
18
19 my $s = sub { shift() ** shift() };
20
21 Operator->make_sem(
22 expr => {
23 '+' => sub { shift() + shift() },
24 '-' => sub { shift() - shift() },
25 },
26 term => {
27 '*' => sub { shift() * shift() },
28 '/' => sub { shift() / shift() },
29 },
30 power => {
31 '^' => $s,
32 '**' => $s,
33 },
34 uneg => {
35 'NEG' => sub { -shift() },
36 },
37 factorial => {
38 '!' => \&fac,
39 },
40 );
41
42 1;
pl@nereida:~/Lregexpgrammars/demo/calculator$ cat -n PostfixCalc.pm
1 package PostfixCalc;
2 use strict;
3
4 use Operator;
5
6 # Modify semantics: now translate to postfix
7 my $powers = sub { shift().' '.shift().' **' };
8
9 Operator->make_sem(
10 expr => {
11 '+' => sub { shift().' '.shift().' +' },
12 '-' => sub { shift().' '.shift().' -' },
13 },
14 term => {
15 '*' => sub { shift().' '.shift().' *' },
16 '/' => sub { shift().' '.shift().' /' },
17 },
18 power => {
19 '^' => $powers,
20 '**' => $powers,
21 },
22 uneg => {
23 # use ~ for unary minus
24 'NEG' => sub { shift().' ~' },
25 },
26 factorial => {
27 '!' => sub { shift().' !'},
28 },
29 );
30
31 1;
pl@nereida:~/Lregexpgrammars/demo$ cat -n calculator.pl 1 #!/usr/bin/env perl5.10.1
$handler en test_calc:
42 sub test_calc {
43 my $prompt = shift;
44 my $handler = shift;
45
46 say $prompt;
47 while (my $input = <>) {
48 chomp($input);
49 if ($input =~ m{$rbb}) {
50 my $tree = $/{expr};
51 $handler->($tree) if $handler;
52
53 say $tree->ceval;
54
55 }
56 else {
57 say("does not match");
58 }
59 }
60 }
make_sem, fac y las llamadas a make_sem
en un módulo Calculator::Semantics aparte.
2*3+4 se traducirá como + * 2 3 4