142 lines
4.2 KiB
Plaintext
142 lines
4.2 KiB
Plaintext
INT base=10;
|
|
MODE FIXED = LONG REAL; # numbers in the format 9,999.999 #
|
|
|
|
# set the error handler to the default error handler #
|
|
PROC eval error := ( STRING message )VOID: (print(("****",message,newline)); stop);
|
|
# sets the eval error handler #
|
|
PROC on eval error = ( PROC(STRING)VOID handler )VOID: eval error := handler;
|
|
|
|
MODE AST = UNION(NODE, FIXED);
|
|
MODE NUM = REF AST;
|
|
MODE NODE = STRUCT(NUM a, PROC (FIXED,FIXED)FIXED op, NUM b);
|
|
|
|
OP EVAL = (NUM ast)FIXED:(
|
|
CASE ast IN
|
|
(FIXED num): num,
|
|
(NODE tree): (op OF tree)(EVAL(a OF tree), EVAL (b OF tree))
|
|
ESAC
|
|
);
|
|
|
|
OP + = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED x,y)FIXED:x+y, b) );
|
|
OP - = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED x,y)FIXED:x-y, b) );
|
|
OP * = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED x,y)FIXED:x*y, b) );
|
|
OP / = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED x,y)FIXED:x/y, b) );
|
|
OP **= (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED x,y)FIXED:x**y, b) );
|
|
|
|
AST error value := FIXED(-1);
|
|
|
|
MODE LEX = PROC (TOK)NUM;
|
|
MODE MONADIC = PROC (NUM)NUM;
|
|
MODE DIADIC = PROC (NUM,NUM)NUM;
|
|
|
|
MODE TOK = CHAR;
|
|
MODE ACTION = UNION(STACKACTION, LEX, MONADIC, DIADIC);
|
|
MODE OPVAL = STRUCT(INT prio, ACTION action);
|
|
MODE OPITEM = STRUCT(TOK token, OPVAL opval);
|
|
|
|
[256]STACKITEM stack;
|
|
MODE STACKITEM = STRUCT(NUM value, OPVAL op);
|
|
MODE STACKACTION = PROC (REF STACKITEM)VOID;
|
|
|
|
PROC begin = (REF STACKITEM top)VOID: prio OF op OF top -:= +10;
|
|
PROC end = (REF STACKITEM top)VOID: prio OF op OF top -:= -10;
|
|
|
|
[8]OPITEM op list :=(
|
|
# OP PRIO ACTION #
|
|
("^", (8, (NUM a,b)NUM: a**b)),
|
|
("*", (7, (NUM a,b)NUM: a*b)),
|
|
("/", (7, (NUM a,b)NUM: a/b)),
|
|
("+", (6, (NUM a,b)NUM: a+b)),
|
|
("-", (6, (NUM a,b)NUM: a-b)),
|
|
("(",(+10, begin)),
|
|
(")",(-10, end)),
|
|
("?", (9, LEX:SKIP))
|
|
);
|
|
|
|
PROC op dict = (TOK op)REF OPVAL:(
|
|
# This can be unrolled to increase performance #
|
|
REF OPITEM candidate;
|
|
FOR i TO UPB op list WHILE
|
|
candidate := op list[i];
|
|
# WHILE # op /= token OF candidate DO
|
|
SKIP
|
|
OD;
|
|
opval OF candidate
|
|
);
|
|
|
|
PROC build ast = (STRING expr)NUM:(
|
|
|
|
INT top:=0;
|
|
|
|
PROC compress ast stack = (INT prio, NUM in value)NUM:(
|
|
NUM out value := in value;
|
|
FOR loc FROM top BY -1 TO 1 WHILE
|
|
REF STACKITEM stack top := stack[loc];
|
|
# WHILE # ( top >= LWB stack | prio <= prio OF op OF stack top | FALSE ) DO
|
|
top := loc - 1;
|
|
out value :=
|
|
CASE action OF op OF stack top IN
|
|
(MONADIC op): op(value OF stack top), # not implemented #
|
|
(DIADIC op): op(value OF stack top,out value)
|
|
ESAC
|
|
OD;
|
|
out value
|
|
);
|
|
|
|
NUM value := NIL;
|
|
FIXED num value;
|
|
INT decimal places;
|
|
|
|
FOR i TO UPB expr DO
|
|
TOK token = expr[i];
|
|
REF OPVAL this op := op dict(token);
|
|
CASE action OF this op IN
|
|
(STACKACTION action):(
|
|
IF prio OF thisop = -10 THEN
|
|
value := compress ast stack(0, value)
|
|
FI;
|
|
IF top >= LWB stack THEN
|
|
action(stack[top])
|
|
FI
|
|
),
|
|
(LEX):( # a crude lexer #
|
|
SHORT INT digit = ABS token - ABS "0";
|
|
IF 0<= digit AND digit < base THEN
|
|
IF NUM(value) IS NIL THEN # first digit #
|
|
decimal places := 0;
|
|
value := HEAP AST := num value := digit
|
|
ELSE
|
|
NUM(value) := num value := IF decimal places = 0
|
|
THEN
|
|
num value * base + digit
|
|
ELSE
|
|
decimal places *:= base;
|
|
num value + digit / decimal places
|
|
FI
|
|
FI
|
|
ELIF token = "." THEN
|
|
decimal places := 1
|
|
ELSE
|
|
SKIP # and ignore spaces and any unrecognised characters #
|
|
FI
|
|
),
|
|
(MONADIC): SKIP, # not implemented #
|
|
(DIADIC):(
|
|
value := compress ast stack(prio OF this op, value);
|
|
IF top=UPB stack THEN eval error("Stack overflow");GOTO index error FI;
|
|
stack[top+:=1]:=STACKITEM(value, this op);
|
|
value:=NIL
|
|
)
|
|
ESAC
|
|
OD;
|
|
compress ast stack(-max int, value)
|
|
EXIT index error: error value
|
|
);
|
|
|
|
#test#(
|
|
on eval error( (STRING m)VOID: ( print(("EVAL error: ",m,newline));stop ) );
|
|
FIXED eval result
|
|
= EVAL build ast("1+1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+1/15)/14)/13)/12)/11)/10)/9)/8)/7)/6)/5)/4)/3)/2");
|
|
print((" euler's number is about: ", fixed(eval result,-long real width,long real width-2), newline))
|
|
)
|