Re: [SPOILER] Solution for QotW #25 (RPN calculator)

Several modifications related to error-checking:


#!/usr/bin/perl 

=pod

For my implemenation of the RPN calculator, I use a dispatch table %functions
that maps the operators to their operations.  This allows me to point all the
binary operators to  the subroutine "binary", which simply reads in the
operator, pops the top two stack elements, and pushes 'eval "$elem1 $op
$elem2"' back onto the stack.  Likewise, most of the unary operators
(the ones with perl implementations!) were pointned to the "unary" sub.

To distinguish between operators and numbers, I match each input item
on /^$RE{num}{real}$/ (from Regexp::Common).  Numbers are pushed onto the
stack, and items that aren't operators or numbers are directed to the 'error'
function in the dispatch table.

By processing the @ARGV array, this implementation allows an additional
command-line usage of this form:
    kester@duck 96: rpn 3 4 - 2 3 '*' +
    0: 5
    >
    kester@duck 97:
(A bit clunky with the stack number '0:' and the null '>' prompt, but
you don't have to type 'q' to exit).


=cut

use warnings;
use strict;
use Regexp::Common;

our @stack;
our %functions = (
    clear => \&{ sub{@stack=()}  },
    drop  => \&{ sub{pop @stack} },
    swap  => \&{ sub{my $x=pop @stack;my $y=pop @stack;push_def($x,$y) } },
    dup   => \&{ sub{my $x=pop @stack;push_def($x,$x)}   },
    roll  => \&{ sub{unshift_def(pop @stack)} },
    show  => \&print_stack,

    abs   => \&unary,
    sqrt  => \&unary,
    cos   => \&unary,
    sin   => \&unary,

    '+'   => \&binary,
    '-'   => \&binary,
    '*'   => \&binary,
    '/'   => \&binary,
    '%'   => \&binary,
    '**'  => \&binary,

    'q'   => \&{ sub{exit} },
    error => \&{ sub {warn "@_ is not a valid entry\n"} },
);

{
    do {process ( @ARGV ); print "\n"; exit} if @ARGV;
    print "Welcome to RPN\n> ";
    process ( $_ ) while <>;
}

sub unshift_def { unshift @stack, get_defs ( @_ ) }
sub push_def    {    push @stack, get_defs ( @_ ) }
sub get_defs {
    my ( @defs, @undefs );
    (defined $_ ? push @defs, $_ : push @undefs, $_) foreach @_;
    print ("Undefined values rejected (div by zero?)\n") if @undefs;
    return @defs;
}

sub print_stack {
    do { print "<empty stack>\n"; return } if not @stack;
    print scalar @stack-$_-1, ": $stack[$_]\n" foreach 0..scalar @stack - 1;
}

sub process {
    foreach ( map {chomp;$_} map {split} @_ ) {
          /^$RE{num}{real}$/     ?  push ( @stack, $_ )
        : exists $functions{$_}  ? $functions{$_}->($_)
        : $functions{error}->($_);
    }
    print_stack ();
    print '> ';
}

sub binary {
    my ($op,$x,$y) = ( shift, pop @stack, pop @stack );
    return underflow($op) if not defined $x;
    push_def($x) and return underflow($op) if not defined $y;
    push_def ( eval "$y $op $x" || undef ); # y then x for div and %
}

sub unary {
    my ($op,$x) = ( shift, pop @stack );
    do {warn "underflow, skipping $op"; return} if !defined $x;
    push_def ( eval "$op $x" );
}

sub underflow {
    warn "underflow, skipping $_[0]\n";
}