Syntax10.Scn.Fnt
Syntax10i.Scn.Fnt
Syntax10b.Scn.Fnt
MODULE Calc;	(*CAS 28.9.93*)
	IMPORT
		MathL, Texts, Oberon;
	CONST
		Version = "Calc / cas 28.9.93";
		End = 7;	(*new scanner symbol*)
		Eps = 1.0D-9; Eps0 = 0.5D-9;
	TYPE
		Symbol = POINTER TO SymbolDesc;
		SymbolDesc = RECORD
			name: ARRAY 32 OF CHAR;
			funct: BOOLEAN;
			val: LONGREAL;
			next: Symbol
		END;
		lastTime: LONGINT;
		W: Texts.Writer;
		S: Texts.Scanner;
		syms: Symbol;
	(** expression syntax:
		Expr = Term {AddOp Term}.
		Term = Factor {MulOp Factor}.
		Factor = Atom {PowOp Atom}.
		Atom = Number | Functor Atom | ident | "(" Expr ")".
		PowOp = "^".
		MulOp = "*" | "/" | "%" | "<" | ">".	-- % modulo, < shift left, > shift right
		AddOp = ["+" | "-"].	-- no add op: addition(!)
		Number = (digit {digit}) | (digit {hexDigit} "H") | (digit {hexDigit} "X") | (""" char """).
		Functor = "arccos" | "arcsin" | "arctan" | "cos" | "entier" | "exp" | "ln" | "short" | "sign" | "sin" | "sqrt" | "tan".
	PROCEDURE err;
	BEGIN S.class := Texts.Inval
	END err;
	PROCEDURE sign (n: LONGREAL): LONGREAL;
	BEGIN
		IF n < 0 THEN RETURN -1
		ELSIF n = 0 THEN RETURN 0
		ELSE RETURN 1 END
	END sign;
	PROCEDURE short (n: LONGREAL): REAL;
	BEGIN RETURN SHORT(n + Eps0)
	END short;
	PROCEDURE entier (n: LONGREAL): LONGINT;
	BEGIN RETURN ENTIER(n + Eps0)
	END entier;
	PROCEDURE sin (n: LONGREAL): LONGREAL;
	BEGIN RETURN MathL.sin(n)
	END sin;
	PROCEDURE cos (n: LONGREAL): LONGREAL;
	BEGIN RETURN MathL.cos(n)
	END cos;
	PROCEDURE tan (n: LONGREAL): LONGREAL;
		VAR x: LONGREAL;
	BEGIN x := MathL.cos(n);
		IF x # 0 THEN RETURN MathL.sin(n) / x ELSE err; RETURN 1 END
	END tan;
	PROCEDURE arcsin (n: LONGREAL): LONGREAL;
		VAR x: LONGREAL;
	BEGIN x := MathL.sqrt(1 - n * n);
		IF x # 0 THEN RETURN MathL.arctan(n / x) ELSE err; RETURN 1 END
	END arcsin;
	PROCEDURE arccos (n: LONGREAL): LONGREAL;
	BEGIN RETURN MathL.pi / 2 - arcsin(n)
	END arccos;
	PROCEDURE arctan (n: LONGREAL): LONGREAL;
	BEGIN RETURN MathL.arctan(n)
	END arctan;
	PROCEDURE exp (n: LONGREAL): LONGREAL;
	BEGIN RETURN MathL.exp(n)
	END exp;
	PROCEDURE ln (n: LONGREAL): LONGREAL;
	BEGIN
		IF n > 0 THEN RETURN MathL.ln(n) ELSE err; RETURN 1 END
	END ln;
	PROCEDURE sqrt (n: LONGREAL): LONGREAL;
	BEGIN
		IF n >= 0 THEN RETURN MathL.sqrt(n) ELSE err; RETURN 1 END
	END sqrt;
	PROCEDURE Ch (ch: CHAR);
	BEGIN Texts.Write(W, ch)
	END Ch;
	PROCEDURE Str (s: ARRAY OF CHAR);
	BEGIN Texts.WriteString(W, s)
	END Str;
	PROCEDURE WrHex (n: LONGREAL);
		VAR x, y: LONGINT; i: INTEGER;
			a: ARRAY 10 OF CHAR;
	BEGIN x := entier(n);
		i := 0; Texts.Write(W, " ");
		REPEAT y := x MOD 10H;
			IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
			x := x DIV 10H; INC(i)
		UNTIL i = 8;
		REPEAT DEC(i) UNTIL (i = 0) OR (a[i] # "0");
		IF a[i] >= "A" THEN Texts.Write(W, "0") END;
		WHILE i >= 0 DO Texts.Write(W, a[i]); DEC(i) END;
		Texts.Write(W, "H")
	END WrHex;
	PROCEDURE WrInt (n: LONGREAL);
	BEGIN Texts.Write(W, " "); Texts.WriteInt(W, entier(n), 0)
	END WrInt;
	PROCEDURE WrChar (n: LONGREAL);
		VAR ch: CHAR;
	BEGIN ch := CHR(entier(n));
		IF (" " <= ch) & (ch < 7FX) OR (80X <= ch) & (ch < 0A0X) THEN Ch(" "); Ch(22X); Ch(ch); Ch(22X)
		ELSE WrHex(ORD(ch))
		END
	END WrChar;
	PROCEDURE WrReal (n: LONGREAL);
		VAR x: LONGREAL;
	BEGIN
		IF (MIN(LONGINT) <= n) & (n <= MAX(LONGINT)) THEN x := ABS(n - ENTIER(SHORT(n)));
			IF x < Eps THEN WrInt(n); RETURN END
		END;
		IF (MIN(REAL) <= n) & (n <= MAX(REAL)) THEN x := ABS(n - SHORT(n));
			IF x < Eps THEN
				IF (-10000 < n) & (n < 10000) THEN Texts.WriteRealFix(W, short(n), 0, 6)
				ELSE Texts.WriteReal(W, short(n), 14)
				END;
				RETURN
			END
		END;
		Texts.WriteLongReal(W, n, 23)
	END WrReal;
	PROCEDURE WrValue (n: LONGREAL);
		VAR x: LONGREAL;
	BEGIN
		Str(" ="); WrReal(n);
		IF (MIN(LONGINT) <= n) & (n <= MAX(LONGINT)) THEN x := ABS(n - ENTIER(SHORT(n)));
			IF x < Eps THEN Str(" ="); WrHex(n); Str(" ="); WrInt(n);
				IF (0 <= n) & (n < 256) & (entier(n) = n) THEN Str(" ="); WrChar(n) END
			END
		END
	END WrValue;
	PROCEDURE Ln;
	BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
	END Ln;
	PROCEDURE Scan (VAR S: Texts.Scanner);
		PROCEDURE hex (n: LONGINT): LONGINT;
			VAR x, i: LONGINT; d: ARRAY 8 OF LONGINT;
		BEGIN x := 0; i := 0;
			REPEAT d[i] := n MOD 10; n := n DIV 10; INC(i) UNTIL n = 0;
			WHILE i > 0 DO DEC(i); x := 16*x + d[i] END;
			RETURN x
		END hex;
	BEGIN
		IF S.eot THEN S.class := End
		ELSIF S.nextCh = "/" THEN S.class := Texts.Char; S.c := "/"; Texts.Read(S, S.nextCh)
		ELSE Texts.Scan(S)
		END;
		IF S.line # 0 THEN S.class := End END;
		IF (S.class = Texts.Char) & (S.c = " ") THEN S.c := "-"
		ELSIF (S.class = Texts.String) & (S.len = 2) THEN S.i := ORD(S.s[0]); S.class := Texts.Int
		ELSIF (S.class = Texts.Int) & (S.nextCh = "X") THEN S.i := hex(S.i);
			Texts.Read(S, S.nextCh)
		END
	END Scan;
	PROCEDURE OpenScanner (VAR S: Texts.Scanner);
		VAR text: Texts.Text; beg, end, time: LONGINT;
	BEGIN
		Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Scan(S);
		IF (S.class = Texts.Char) & (S.c = "^") & (S.line = 0) THEN
			Oberon.GetSelection(text, beg, end, time);
			IF time >= lastTime THEN lastTime := time;
				Texts.OpenScanner(S, text, beg); Scan(S)
			END
		END;
		IF S.line # 0 THEN S.class := Texts.Inval END
	END OpenScanner;
	PROCEDURE FindIdent (name: ARRAY OF CHAR; insert: BOOLEAN; VAR val: LONGREAL);
		VAR s: Symbol;
	BEGIN s := syms;
		WHILE (s # NIL) & ((s.name # name) OR s.funct) DO s := s.next END;
		IF insert THEN
			IF s = NIL THEN NEW(s); s.next := syms; syms := s END;
			COPY(name, s.name); s.funct := FALSE; s.val := val
		ELSIF s # NIL THEN val := s.val
		ELSE S.class := Texts.Inval
		END
	END FindIdent;
	PROCEDURE FindFunct (name: ARRAY OF CHAR; insert: BOOLEAN; VAR sym: Symbol);
		VAR s: Symbol;
	BEGIN s := syms;
		WHILE (s # NIL) & ((s.name # name) OR ~s.funct) DO s := s.next END;
		IF insert THEN
			IF s = NIL THEN s := sym; s.next := syms; syms := sym END;
			COPY(name, s.name); s.funct := TRUE; s.val := 0
		ELSIF s # NIL THEN sym := s
		ELSE sym := NIL
		END
	END FindFunct;
	PROCEDURE InitSyms;
		VAR s: Symbol; n: LONGREAL; name: ARRAY 2 OF CHAR;
	BEGIN name[1] := 0X;
		name[0] := "e"; n := MathL.e; FindIdent(name, TRUE, n);
		n := MathL.pi; FindIdent("pi", TRUE, n);
		n := 0;
		NEW(s); FindFunct("arctan", TRUE, s);
		NEW(s); FindFunct("arccos", TRUE, s);
		NEW(s); FindFunct("arcsin", TRUE, s);
		NEW(s); FindFunct("cos", TRUE, s);
		NEW(s); FindFunct("entier", TRUE, s);
		NEW(s); FindFunct("exp", TRUE, s);
		NEW(s); FindFunct("ln", TRUE, s);
		NEW(s); FindFunct("short", TRUE, s);
		NEW(s); FindFunct("sign", TRUE, s);
		NEW(s); FindFunct("sin", TRUE, s);
		NEW(s); FindFunct("sqrt", TRUE, s);
		NEW(s); FindFunct("tan", TRUE, s)
	END InitSyms;
	PROCEDURE^ Expr (VAR n: LONGREAL);
	PROCEDURE Functor (sym: Symbol; VAR n: LONGREAL);
	BEGIN
		IF sym.name = "arcsin" THEN n := arcsin(n)
		ELSIF sym.name = "arccos" THEN n := arccos(n)
		ELSIF sym.name = "arctan" THEN n := arctan(n)
		ELSIF sym.name = "cos" THEN n := cos(n)
		ELSIF sym.name = "exp" THEN n := exp(n)
		ELSIF sym.name = "entier" THEN n := entier(n)
		ELSIF sym.name = "ln" THEN n := ln(n)
		ELSIF sym.name = "short" THEN n := short(n)
		ELSIF sym.name = "sign" THEN n := sign(n)
		ELSIF sym.name = "sin" THEN n := sin(n)
		ELSIF sym.name = "sqrt" THEN n := sqrt(n)
		ELSIF sym.name = "tan" THEN n := tan(n)
		END
	END Functor;
	PROCEDURE Atom (VAR n: LONGREAL);
		VAR sym: Symbol;
	BEGIN
		IF S.class = Texts.Int THEN n := S.i; Scan(S)
		ELSIF S.class = Texts.Real THEN n := S.x; Scan(S)
		ELSIF S.class = Texts.LongReal THEN n := S.y; Scan(S)
		ELSIF S.class = Texts.Name THEN FindFunct(S.s, FALSE, sym);
			IF sym # NIL THEN Scan(S); Atom(n);
				IF S.class # Texts.Inval THEN Functor(sym, n) END
			ELSE FindIdent(S.s, FALSE, n);
				IF S.class # Texts.Inval THEN Scan(S) END
			END
		ELSIF (S.class = Texts.Char) & (S.c = "(") THEN Scan(S);
			Expr(n);
			IF (S.class = Texts.Char) & (S.c = ")") THEN Scan(S)
			ELSE S.class := Texts.Inval
			END
		ELSE S.class := Texts.Inval
		END
	END Atom;
	PROCEDURE Factor (VAR n: LONGREAL);
		VAR x: LONGREAL;
	BEGIN Atom(n);
		WHILE (S.class = Texts.Char) & (S.c = "^") DO
			Scan(S); Factor(x);
			n := sign(n) * MathL.exp(MathL.ln(ABS(n)) * x)
		END
	END Factor;
	PROCEDURE Term (VAR n: LONGREAL);
		VAR x: LONGREAL; op: CHAR;
	BEGIN Factor(n);
		WHILE (S.class = Texts.Char)
		& ((S.c = "*") OR (S.c = "/") OR (S.c = "%") OR (S.c = ">") OR (S.c = "<")) DO
			op := S.c; Scan(S); Factor(x);
			CASE op OF
				"*": n := n * x
			|   "/": IF x # 0 THEN n := n / x ELSE err END
			|   "%": IF x # 0 THEN n := entier(n) MOD entier(x) ELSE err END
			|   "<": n := ASH(entier(n), entier(x))
			|   ">": n := ASH(entier(n), -entier(x))
			END
		END
	END Term;
	PROCEDURE Expr (VAR n: LONGREAL);
		VAR x: LONGREAL; op: CHAR;
	BEGIN Term(n);
		WHILE (S.class = Texts.Char) & ((S.c = "+") OR (S.c = "-")) OR (S.class = Texts.Int) DO
			IF S.class = Texts.Char THEN op := S.c; Scan(S) ELSE op := "+" END;
			Term(x);
			CASE op OF
				"+": n := n + x
			|   "-": n := n - x
			END
		END
	END Expr;
	PROCEDURE Hex*;	(** expr **)
		VAR n: LONGREAL;
	BEGIN Str("Calc.Hex"); OpenScanner(S); Expr(n);
		IF S.class # Texts.Inval THEN WrHex(n) ELSE Str(" failed: bad argument") END;
	END Hex;
	PROCEDURE Dec*;	(** expr **)
		VAR n: LONGREAL;
	BEGIN Str("Calc.Dec"); OpenScanner(S); Expr(n);
		IF S.class # Texts.Inval THEN WrInt(n) ELSE Str(" failed: bad argument") END;
	END Dec;
	PROCEDURE Real*;	(** expr **)
		VAR n: LONGREAL;
	BEGIN Str("Calc.Real"); OpenScanner(S); Expr(n);
		IF S.class # Texts.Inval THEN WrReal(n) ELSE Str(" failed: bad argument") END;
	END Real;
	PROCEDURE Char*;	(** expr **)
		VAR n: LONGREAL;
	BEGIN Str("Calc.Char"); OpenScanner(S); Expr(n);
		IF S.class # Texts.Inval THEN
			IF (0 <= n) & (n < 256) THEN WrChar(n)
			ELSE Str(" failed: not a character code")
			END
		ELSE Str(" failed: bad argument")
		END;
	END Char;
	PROCEDURE Set*;	(** {name ":=" expr} "~" **)
		VAR
			n: LONGREAL;
			name: ARRAY 32 OF CHAR;
	BEGIN Str("Calc.Set"); Ln;
		OpenScanner(S);
		WHILE S.class = Texts.Name DO COPY(S.s, name); Scan(S);
			IF (S.class = Texts.Name) & (S.s = ":") & (S.nextCh = "=") THEN
				Scan(S); Scan(S); Expr(n)
			ELSE S.class := Texts.Inval
			END;
			IF S.class # Texts.Inval THEN FindIdent(name, TRUE, n);
				IF S.class # Texts.Inval THEN Str("  "); Str(name); WrValue(n); Ln END
			END
		END;
		IF S.class = Texts.Inval THEN Str("  failed: bad argument") END
	END Set;
	PROCEDURE List*;
		VAR s: Symbol;
	BEGIN Str("Calc.List"); Ln;
		s := syms;
		WHILE s # NIL DO
			IF s.funct THEN Str("  "); Str(s.name) END;
			s := s.next
		END;
		Ln;
		s := syms;
		WHILE s # NIL DO
			IF ~s.funct THEN Str("  "); Str(s.name); WrValue(s.val); Ln END;
			s := s.next
		END
	END List;
	PROCEDURE Reset*;
	BEGIN Str("Calc.Reset"); Ln; syms := NIL; InitSyms
	END Reset;
BEGIN Texts.OpenWriter(W); Texts.WriteString(W, Version); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
	lastTime := 0; syms := NIL; InitSyms
END Calc.
System.Free Calc ~