home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
jËzyki_programowania
/
oberon
/
system
/
calc.mod
(
.txt
)
< prev
next >
Wrap
Oberon Text
|
1977-12-31
|
12KB
|
349 lines
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 ~