#!/usr/bin/perl -w require 5.004; use strict; BEGIN { unshift @INC, "../lib"; } package Parse::SExpressions; use Parse::Lex; @Parse::SExpressions::ISA = qw(Parse::Lex); sub upto { my $self = shift; my $upto = shift; my $token; my @list = (); my $current = $self->getToken; # save the current token while (($token = $self->next)->type ne $upto) { push @list, $token->text; } $self->setToken($current); @list; } my %apply = ( '+' => sub { my $r = shift; foreach (@_) { $r += $_ } $r; }, '-' => sub { my $r = shift; foreach (@_) { $r -= $_ } $r; }, '*' => sub { my $r = shift; foreach (@_) { $_ or return 0; $r *= $_ } $r; }, '/' => sub { my $r = shift; foreach (@_) { $_ or die "illegal division by 0"; $r /= $_; } $r; }, ); Parse::Lex->exclusive('OPERATOR'); my $lexer; Parse::Lex->trace; $lexer = Parse::SExpressions->new( 'LEFTP' => '[\(]' => sub { $lexer->start('OPERATOR'); my($operator, @operands) = $lexer->upto('RIGHTP'); &{$apply{$operator}}(@operands); }, 'RIGHTP' => '[\)]', 'OPERATOR:OPERATOR' => '[-+/*]' => sub { $lexer->end('OPERATOR'); $_[1] }, 'NUMBER' => '\d+', 'ALL:ERROR' => '.*' => sub { if ($lexer->state('OPERATOR')) { die qq!can\'t analyze: "$_[1]"\nOperator expected\n!; } else { die qq!can\'t analyze: "$_[1]"\n!; } } ); my $sexp = '(* 2 (+ 3 3))'; $lexer->from($sexp); print "result of $sexp: ", $lexer->next->text, "\n"; __END__