[SPOILER] Re: Perl Quiz of the Week #25 (RPN calculator)

This is a pretty simple solution, which holds operator definitions
in a hash. It implements all of the extensions from the original
quiz specification.

I'm thinking about allowing user-defined functions, but not being a
Forth programmer, I'm not sure how the syntax ought to look. Some of
the other submitted solutions which implement this don't look
"reverse" enough to me to fit with the rest of the language.


#!/usr/bin/perl

use strict;
$|=1;

my @stack;

# Helper routines for building the operator hash
sub unary{
  my($op)=@_;
  $op => [1,eval "sub{ \$stack[-1]= $op \$stack[-1]; }"];
}
sub binary{
  my($op)=@_;
  $op => [2,eval "sub{ my \$op2=pop \@stack; \$stack[-1] $op= \$op2; }"];
}

my $ofmt=my $dec_ofmt='%.6g';
my %ops=(
  # Standard ops
  map(binary($_),qw(+ - * / % **)),
  dup   => [1, sub{ push @stack,$stack[-1]; }],
  swap  => [2, sub{ @stack[-1,-2]=@stack[-2,-1]; }],
  drop  => [1, sub{ pop @stack; }],
  clear => [0, sub{ @stack=(); }],

  # additional perl ops
  map(binary($_),qw(& | atan2)),
  map(unary($_),qw(~ abs int cos sin exp log sqrt)),

  # display modes
  dec => [0,sub{ $ofmt=$dec_ofmt; }],
  bin => [0,sub{ $ofmt='0b%b'; }],
  oct => [0,sub{ $ofmt='0%o'; }],
  hex => [0,sub{ $ofmt='0x%x'; }],

  # N roll
  roll  => [1, sub{
    my $n=pop @stack; 
    $n>=0
      or die "roll operator requires a non-negative roll size\n";
    @stack>$n
      or die "roll operator requires a stack depth greater than the roll size\n";
    my $val=splice @stack,-$n-1,1;
    push @stack,$val;
  }],
  # N rolld
  rolld => [1, sub{
    my $n=pop @stack;
    $n>=0
      or die "rolld operator requires a non-negative roll size\n";
    @stack>$n
      or die "rolld operator requires a stack depth graeater than the roll size\n";
    my $val=pop @stack;
    splice @stack,-$n-1,0,$val;
  }],
);

print '> ';
while(<>){
  for my $tok(split){
    if($tok=~/\A0o?(.+)\z/){
      my $oct=$1;
      $oct=~/\A[0-7]+\z/
        or die "Invalid octal number: $tok\n";
      push @stack,oct $oct;
    }elsif($tok=~/\A0x(.+)\z/){
      my $hex=$1;
      $hex=~/\A[0-9a-f]+\z/i
        or die "Invalid hex number: $tok\n";
      push @stack,hex $hex;
    }elsif($tok=~/\A0b(.+)\z/){
      my $bin=$1;
      $bin=~/\A[01]+\z/
        or die "Invalid binary number: $tok\n";
      push @stack,oct $tok;
    }elsif($tok=~/\A-?\d+\z/){ # Only integers ATM
      push @stack,$tok;
    }elsif(my $op=$ops{$tok}){
      my($depth,$sub)=@$op;
      my @args;
      @stack>=$depth
        or die "$tok operator requires a stack depth of at least $depth\n";
      
      $sub->();
    }else{
      die "Unrecognised token: $tok\n";
    }
  }
  for my $i(0..$#stack){
    printf "%d: $ofmt\n",$#stack-$i,$stack[$i];
  }
  print '> ';
}
print "\n";


-- 
	Peter Haworth	[email protected]
"Fortunately, I know nothing about C++."
	-- Sian Leitch