#!/usr/local/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__