Data commit

Task/Arithmetic-evaluation/ALGOL-68/arithmetic-evaluation.alg

@@ -0,0 +1,142 @@
+INT base=10;
+MODE FIXED = LONG REAL; # numbers in the format 9,999.999 #
+
+#IF build abstract syntax tree and then EVAL tree #
+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 fork): (op OF fork)(EVAL( a OF fork), EVAL (b OF fork))
+  ESAC
+);
+
+OP + = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED a,b)FIXED:a+b, b) );
+OP - = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED a,b)FIXED:a-b, b) );
+OP * = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED a,b)FIXED:a*b, b) );
+OP / = (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED a,b)FIXED:a/b, b) );
+OP **= (NUM a,b)NUM: ( HEAP AST := NODE(a, (FIXED a,b)FIXED:a**b, b) );
+
+#ELSE simply use REAL arithmetic with no abstract syntax tree at all # CO
+MODE NUM = FIXED, AST = FIXED;
+OP EVAL = (FIXED num)FIXED: num;
+#FI# END CO
+
+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;
+
+OP ** = (COMPL a,b)COMPL: complex exp(complex ln(a)*b);
+
+[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 index error FI;
+        stack[top+:=1]:=STACKITEM(value, this op);
+        value:=NIL
+      )
+    ESAC
+  OD;
+  compress ast stack(-max int, value)
+);
+
+test:(
+   printf(($" euler's number is about: "g(-long real width,long real width-2)l$,
+     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")));
+  SKIP EXIT
+  index error:
+    printf(("Stack over flow"))
+)