#!/usr/bin/perl
# dc in perl, by Drew Eckhardt
# 
# doesn't do non-base-10 bases yet

# Regexes to match various tokens in the input stream
# Base ten regex, changes

# Note : t_number should be modified to accomodate different bases.

$t_number = '\d+|_\d+';
$t_reg_op = '[slSL<=>].';
$t_no_operand = '[\*\+\-\/%\^dpfqxXvciIokzZ?]';
$t_string = '\[.*\]';
$t_any = "$t_number|$t_reg_op|$t_no_operand|$t_string";

# Table of registers, indexed by a single letter.  scalars are 
# stored as the value, stacks are stored as a nul delimited list
# of the elements since the original DC didn't use NUL.
%registers = ();

$nul = "\000";

# &register_push ($register, @list) - push the items in @list onto 
# the register named by $register.
sub register_push {
    local ($register, @list) = @_;
    foreach $thing (@list) {
	if ($registers{$register} eq undef) {
	    $registers{$register} = $thing;
	} else {
	    $registers{$register} = $registers{$register}.$nul.$thing;
	}
    }
    print STDERR "register stack now has contents \"$registers{$register}\"\n" 
	if ($debug);
}

# $value = &register_top ($register) - return the top item on the stack
# stored in the register named by $register.  For scalar registers,
# the only item is returned. For uninitialized registers, 0 is 
# returned.
sub register_top {
    local ($register) = @_;
    if ($registers{$register} =~ /.*$nul(.*)/) {
	print "register_top($register) : $register is a stack, top is \"$1\"\n"
	    if ($debug);
        return $1;
    } else {
	print "register_top($register) : $register is a scalar \"$registers{$register}\"\n"
	    if ($debug);
	return $registers{$register};
    }
}

# $value = &register_pop ($register) - pop the top item off the stack stored
# in the register named by $register. For scalars, the value is returned and
# the register initialized to uninitialized.  For uninitialized registers,
# 0 is returned.
sub register_pop {
    local ($register) = @_;
    local ($tmp) ;
    if ($registers{$register} =~ /(.*)$nul(.*)/) {
	print "register_pop($register) : $register is stack, top is \"$2\"\n"
	    if ($debug);
	$registers{$register} = $1;
	return $2;
    } elsif ($registers{$register} eq undef) {
	print "register_pop($register) : $register is empty\n"
	    if ($debug);
	return 0;
    } else {
	print "register_pop($register) : $register is a scalar \"$registers{$register}\"\n"
	    if ($debug);
	$tmp = $registers{$register};
	$registers{$register} = undef;
	return $tmp;
    }
}

# Scanner
# @tokens = &tokenize ($expression) - split the input expression $expression
# into it's component tokens.  Note that the caller should handle line 
# continuations and [ ] strings spanning multiple lines since no state is
# preserved between calls.
sub tokenize {
    local ($expression) = @_;
    local (@tokens) = ();
    while (length ($expression) > 0) {
	# Match next token, adding to list of parsed tokens, stripping
	# white space off in the process.
	if ($expression =~ /\s*($t_any)\s*(.*)/) {
	    $expression = $2;
	    push (@tokens, $1);
	# Ignore blank lines
        } elsif ($expression =~ /^\s*$/) {
	    $expression = '';
	# Hack : if an unidentified character is encountered, print
	# its octal value as the real DC does and continue processing
	# the rest of the characters.
	} elsif ($expression =~ /(.)(.*)/) {
	    $expression = $2;
	    printf (STDERR "%o is unimplemented\n", 
		unpack ('C', pack ('a1', $1)));
	} else {
	    printf (STDERR "error parsing expression \"$expression\"\n");
	    exit (1);
	}
    }
    return @tokens;
}

@stack = ();
%registers = ();
$ibase = 10;
$obase = 10;

# Recursive decent parser -
# $exit_recursion_levels = &evaluate ($expression) - evaluate the 
# expression passed in $expression.  Note that the caller should handle
# continuations and [ ] strings spanning multiple lines since no state is
# preserved between calls.  Return the number of recursion levels to
# exit.  

# Minimum stack depth required to complete various operations.
# Operations without an entry in the min_depth table have no 
# minimum depth.
%min_depth = ('+', 2, '-', 2, '/', 2, '*', 2, '%', 2, '^', 2,
		's', 1, 'd', 1, 'p', 1, 'f', 1, 'x', 1, 
		'X', 1, '<', 2, '=', 2, '>', 2, 'v', 1, 
		'i', 1, 'o', 1, 'k', 1, 'Z', 1);

sub convert {
    local ($value, $ibase, $obase) = @_;
    if ($ibase = $10) {
    } elsif ($obase = $10) {
    } else {
	return &convert (&convert ($value, $ibase, 10), 10, $obase);
    }
}
sub evaluate {
    local ($expression) = @_;
    local (@tokens)= &tokenize ($expression);
    local ($value, $token);

    foreach $token (@tokens) {
	$token =~ /^(.)/;
	if ($min_depth{$1} && (($#stack + 1) < $min_depth{$1})) {
	    print STDERR "stack empty\n";
	    next;
	}

	if ($token =~ /^$t_number/) {
	    push (@stack, ($ibase == 10) ? $token : 
		&convert ($token, 10, $ibase));
	    print STDERR "(number) pushed $stack[$#stack]\n" if ($debug);
	} elsif ($token =~ /^[\-\+\*\/%\^]/) {
	    $token =~ s/\^/\*\*/;
	    $right_op = pop(@stack);
	    $left_op = pop (@stack);
	    push (@stack, eval "$left_op $token $right_op");
	    print STDERR "(expression) $left_op $token $right_op pushed $stack[$#stack]\n" if ($debug);
	} elsif ($token =~ /^s(.)/) {
	    print STDERR "(store) $1 = $stack[$#stack]\n" if ($debug);
	    $registers{$1} = pop(@stack);
	} elsif ($token =~ /^S(.)/) {
	    print STDERR "(store) stack $1 = $stack[$#stack]\n" if ($debug);
	    &register_push ($1, pop(@stack));
	} elsif ($token =~ /^l(.)/) {
	    push (@stack, &register_top ($1));
    	    print STDERR "(load) $1 pushed $stack[$#stack]\n" if ($debug);
	} elsif ($token =~ /^L(.)/) {
	    push (@stack, &register_pop ($1));
	    print STDERR "(load) stack $1 pushed $stack[$#stack]\n" if ($debug);
	} elsif ($token eq 'd') {
	    push (@stack, $stack[$#stack]);
    	    print STDERR "(duplicate) pushed $stack[$#stack]\n" if ($debug);
	} elsif ($token eq 'p') {
	    print "$stack[$#stack]\n";
	} elsif ($token eq 'f') {
	    foreach $value (reverse @stack) {
		print "$value\n";
	    }
	} elsif ($token eq 'q') {
	    print STDERR "quit - exiting two recursion levels\n" if ($debug);
	    return 2;
	} elsif ($token eq 'Q') {
	    return pop (@stack) - 1;
	} elsif ($token eq 'x') {
	    print STDERR "(execute) recursing into expression \"$stack[$#stack]\"\n" if
		($debug);
	    $tmp = &evaluate ($stack[$#stack]);
	    print STDERR "back\n" if ($debug);
	    return ($tmp - 1) if ($tmp > 0);
	} elsif ($token =~ /^\[(.*)\]/) {
	    push (@stack, $1);
	    print STDERR "(string) pushed $1\n" if ($debug);
	} elsif ($token =~ /^([<=>])(.)/) {
	    $left_op = pop(@stack);
	    $right_op = pop(@stack);
	    print "(conditional) evaluating $left_op $1 $right_op\n" if ($debug);
	    if (eval "$left_op $1 $right_op") {
		$tmp = &evaluate (&register_top($2));
		return ($tmp - 1) if ($tmp > 0);
	    }
	} elsif ($token eq 'c') {
	    @stack = ();
	} elsif ($token eq 'i') {
	    $ibase = pop (@stack);
	} elsif ($token eq 'I') {
	    push (@stack, $ibase);
	} elsif ($token eq 'o') {
	    $obase = pop (@stack);
	} elsif ($token eq 'O') {
	    push (@stack, $obase);
	} elsif ($token eq 'z') {
	    push (@stack, $#stack + 1);
	}
    }
}

# Default state is starting a new line
$continue = undef;
while (<>) {
    # If we are performing a line continuation, prepend the contents of
    # all previously contionued lines onto this one.
    if ($continue ne undef) {
	$_ = $continue.$_;
	$continue = undef;
    }

    # A line containing a left paren but not a right paren requires
    # a line continuation.
    # 
    # XXX - bug : nested []'s will break this.
    if (/\[/ && !/\]/) {
	$continue = $_;
    } else {
	# Break when we exit the final recursion level.
	if (&evaluate ($_) > 0) {
	    last;
	}
    }
}

print STDERR "unterminated [\n" if ($continue ne undef);