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

On Tue, 5 Oct 2004 13:01:28 -0400, Mark Jason Dominus wrote:
> On Oct 5, 2004, at 12:42 PM, Peter Haworth wrote:
> >
> > I'm thinking about allowing user-defined functions, but not being
> > a Forth programmer, I'm not sure how the syntax ought to look.
>
> In PostScript you define a procedure by doing something like:
>
>       { 2 mul } /double def
>
> After processing the '}' operator, the stack contains an anonymous
> function. '/double' pushes the "name object" representing the name
> "double", and then "def" is a binary operator which expects a name
> and a value and associates the two in the current dictionary.

OK, that's nice and clean. Here's a solution which implements that,
plus a "cond" operator, which evaluates one of two anonymous functions
depending on the value of its third argument.


#!/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,@tokens);
%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;
  }],

  # Function definition
  def => [2, sub{
    my($sub,$name)=splice @stack,-2;
    ref($sub) && $name=~/\A[a-zA-Z_]/
      or die "def operator expects an anonymous function and a name as arguments\n";
    $ops{$name}=[0,sub{
      unshift @tokens,@$sub;
    }];
  }],

  # Conditional
  cond => [3,sub{
    my($true,$false,$cond)=splice @stack,-3;
    !$true || ref($true) and !$false || ref($false)
      or die "cond operator expects two anonyous functions and a true/false value\n";
    my $func=$cond ? $true : $false;
    unshift @tokens,@$func if $func;
  }],
);

print '> ';
my @compile;
while(<>){
  @tokens=split;
  while(@tokens){
    my $tok=shift @tokens;
    if(ref $tok){
      push @stack,$tok;
    }elsif($tok eq '{'){
      push @compile,scalar @stack;
    }elsif($tok eq '}'){
      @compile
        or die "No '{' seen before '}'\n";
      my $mark=pop @compile;
      my @code=splice @stack,$mark;
      push @stack,\@code;
    }elsif(@compile){
      push @stack,$tok;
    }elsif($tok=~/\A\/([a-zA-Z_]\w*)\z/){
      push @stack,$1;
    }elsif($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){
    my $val=$stack[$i];
    my $pos=$#stack-$i;
    print "$pos: ";
    if(ref $val){
      print "func\n";
    }elsif($val=~/\A[\d-]/){
      printf "$ofmt\n",$val;
    }else{
      print "word: $val\n";
    }
  }
  print '> ';
}
print "\n";



-- 
	Peter Haworth	[email protected]
"I even make off-by-one errors counting on my fingers.
 No wonder I can't debug my programs :-)"
		-- Nathan Torkington