#!/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";
# ®ister_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 = ®ister_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 = ®ister_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);
®ister_push ($1, pop(@stack));
} elsif ($token =~ /^l(.)/) {
push (@stack, ®ister_top ($1));
print STDERR "(load) $1 pushed $stack[$#stack]\n" if ($debug);
} elsif ($token =~ /^L(.)/) {
push (@stack, ®ister_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 (®ister_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);