#!/usr/bin/perl
# 
# dc
# Copyright 1998/1999 Julian E. C. Squires (tek@wiw.org)
# This program comes with ABSOLUTELY NO WARRANTY.
#
# Version Alpha Zero
#
# $Id: pdc,v 1.3 1999/08/05 01:11:13 tek Exp $
#
# Missing:
#   Variable radix
#   Variable precision
#   Comparison
#
# Bugs:
#   "." should become "0" on the stack, not remain "."
#
# Notes for next version:
#   Fix Sn and Ln
#   Number::Format must be fixed to handle other radixes
#   Use Number::Format for all number handling
#   Rewrite with hash table of references fu
#

use strict;

#use Number::Format;
use Math::BigFloat;

my @stack = new Math::BigFloat('0');
my @registers = new Math::BigFloat('0');
my @registerstack = new Math::BigFloat('0');
my $insargsmsg = "dc: stack empty.\n";
my $checkstack=sub{if(@{$_[0]}<$_[1]){print $insargsmsg;return -1}};

my %dc_commands;
# Printing Commands
$dc_commands{'p'} = sub {
    if(&$checkstack(\@stack, 1) != -1) { print $stack[@stack-1] . "\n" }
    shift @_; };

$dc_commands{'n'} = sub {
    if(&$checkstack(\@stack, 1) != -1) { print pop(@stack) }
    shift @_; };

# FIXME: Read the manual page again
$dc_commands{'P'} = sub {
    if(&$checkstack(\@stack, 1) != -1) { pop(@stack) }
    shift @_; };

$dc_commands{'f'} = sub {
# FIXME: Use reverse instead?
    for(my $i = @stack-1; $i >= 0; $i--) {
      print "$stack[$i]\n";
    } shift @_; };

# Arithmetic
$dc_commands{'+'} = sub {
    if(&$checkstack(\@stack, 2) != -1)
    { push(@stack, pop(@stack)+pop(@stack)) }
    shift @_; };

$dc_commands{'-'} = sub {
      if(&$checkstack(\@stack, 2) != -1)
      { my $a = pop(@stack); my $b = pop(@stack);
        push(@stack, $b-$a); }
      shift @_; };

$dc_commands{'*'} = sub {
      if(&$checkstack(\@stack, 2) != -1)
      { push(@stack, pop(@stack)*pop(@stack)) }
      shift @_; };

$dc_commands{'/'} = sub {
      if(&$checkstack(\@stack, 2) != -1)
      { my $a = pop(@stack); my $b = pop(@stack);
        push(@stack, $b/$a); }
      shift @_; };

$dc_commands{'%'} = sub {
      if(&$checkstack(\@stack, 2) != -1)
      { push(@stack, pop(@stack)%pop(@stack)) }
      shift @_; };

$dc_commands{'~'} = sub {
      if(&$checkstack(\@stack, 2) != -1) {
      my $foo = pop(@stack); my $bar = pop(@stack);
      push(@stack, $foo/$bar); push(@stack, $foo%$bar); }
      shift @_; };

$dc_commands{'^'} = sub {
      if(&$checkstack(\@stack, 2) != -1) { 
	my $foo = pop(@stack);
	my $bar = pop(@stack);
	push(@stack, $bar**$foo);
      }
      shift @_; };

$dc_commands{'|'} = sub {
      if(&$checkstack(\@stack, 2) != -1) {
 	my $foo = pop(@stack);
	my $bar = pop(@stack);
	push(@stack, ($bar**$foo)%pop(@stack));
      }
      shift @_; };

$dc_commands{'v'} = sub {
      if(&$checkstack(\@stack, 1) != -1)
      { push(@stack, sqrt(pop(@stack))) }
      shift @_; };

# Stack Control
$dc_commands{'c'} = sub { @stack = ();  shift @_; };

$dc_commands{'d'} = sub {
      if(&$checkstack(\@stack, 1) != -1)
      { push(@stack, $stack[@stack-1]) }
      shift @_; };

$dc_commands{'r'} = sub {
      if(&$checkstack(\@stack, 2) != -1) {
	my $foo = pop(@stack);
	my $bar = pop(@stack);
	push(@stack, $foo);
	push(@stack, $bar); }
      shift @_; };

# Registers
$dc_commands{'s'} = sub {
      shift @_;
      if(&$checkstack(\@stack, 1) != -1) {
	my $foo = $_[0];
        $registers[ord($foo)] = $stack[@stack-1];
     } };

$dc_commands{'l'} = sub {
      shift @_;
      my $foo = $_[0];

      push(@stack, $registers[ord($foo)]);
      };

$dc_commands{'S'} = sub {
      shift @_;
      if(&$checkstack(\@stack, 1) != -1) {
	my $foo = $_[0];

	push(@{$registers[ord($foo)]}, $stack[@stack-1]);
     } };

$dc_commands{'L'} = sub {
      shift @_;
      my $foo = $_[0];

      if(!@{$registers[ord($foo)]})
      { printf("dc: Stack register \'%c\' (%04o) is empty.\n",
	     ord($foo), ord($foo));  last; }

     push(@stack, pop(@{$registers[ord($foo)]})); };

# Parameters
$dc_commands{i} = sub { };

$dc_commands{o} = sub { };

$dc_commands{k} = sub { };

$dc_commands{I} = sub { };

$dc_commands{O} = sub { };

$dc_commands{K} = sub { };

# Strings
# FIXME: This doesn't allow for multiline strings

$dc_commands{'['} = sub {
      shift @_;
      my $foo = "";
      while(@_ && !($_[0] eq "]")) {
 	$foo .= $_[0];  shift @_;
      }
      if($_[0] eq "]") { push(@stack, $foo) }
      else {
# FIXME: Should do something, like inspiring the parser to continue the string
      }
      shift @_; };

$dc_commands{'a'} = sub {
      shift @_;
      if(&$checkstack(\@stack, 1) != -1) {
  	my $foo = pop(@stack);
	if($foo =~ /[^\d\.]/) {
          push(@stack, chr(ord($foo)));
	} else {
          push(@stack, chr($foo&0xFF));
	}
      } };

$dc_commands{'x'} = sub {
      shift @_;
      if(&$checkstack(\@stack, 1) != -1) {
	my $foo = pop(@stack);
	$foo .= "\n";
	$_ = $foo;
	parseline($foo);
      } };

$dc_commands{'!'} = sub { };
  
$dc_commands{'>'} = sub { };

$dc_commands{'<'} = sub { };

$dc_commands{'='} = sub { };

$dc_commands{'?'} = sub { };

# FIXME: This isn't quite right
$dc_commands{'q'} = sub { exit 0 };

$dc_commands{'Q'} = sub { };

# Status inquiry
$dc_commands{'Z'} = sub {
      if(&$checkstack(\@stack, 1) != -1)
      { push(@stack, length(pop(@stack))) }
      shift @_; };

# FIXME: doesn't always work...
$dc_commands{'X'} = sub {
      if(&$checkstack(\@stack, 1) != -1) {
        my $foo = pop(@stack);

        if($foo =~ /[^\d]/ || $foo !~ /[\.]/) { $foo = 0; }
        else { $foo =~ s/^\d*\.//; $foo = length($foo) }
        push(@stack, $foo);
      }
      shift @_; };

$dc_commands{'z'} = sub {
      push(@stack, sprintf("%d", @stack));
      shift @_; };

$dc_commands{':'} = sub { };

$dc_commands{';'} = sub { };


# This is due to Math::BigInt not doing what we want
pop(@stack);
pop(@registers);
pop(@registerstack);

while(<STDIN>) {
    if(parseline($_) == -1) {
	exit 0;
    }
}

sub parseline($) {
    @_ = split //;

    while(@_) {
	if($_[0] =~ /[\d\.]/) {
	    my $foo = $_[0];
	    shift @_;
	    while(@_ && $_[0] =~ /[\d\.]/) {
		$foo .= $_[0];  shift @_;
	    }
	    push(@stack, $foo);

# Ignore whitespace
	} elsif($_[0] =~ /\s/) {
	    shift @_;

# Comments
	} elsif($_[0] eq "#") {
	    @_ = ();  last;

        } elsif(exists($dc_commands{$_[0]})) {
	  &{$dc_commands{$_[0]}};

	} else {
	    printf("dc: \'%c\' (%04o) unimplemented\n", ord($_[0]),
		   ord($_[0]));
	    shift @_;
	}
    }
    return;
}

# EOF dc