(*--------------------------------------------------------------------------
  :Program.    function.mod
  :Contents.   Funktionsparser
  :Author.     Frank Lömker
  :Copyright.  FreeWare, siehe Dok-File für TRechner
  :Language.   Modula-2
  :Translator. M2Amiga V4.1d
  :History.    V1.0, [Frank Lömker] 01-Mar-93
  :Bugs.       keine bekannt
--------------------------------------------------------------------------*)

IMPLEMENTATION MODULE function;
(*$ DEFINE FFP:=TRUE DEFINE LONG:=FALSE *)

(*$ StackParms:=FALSE StackChk:=FALSE RangeChk:=FALSE OverflowChk:=FALSE
    CaseChk:=FALSE ReturnChk:=FALSE EntryClear:=FALSE LargeVars:=FALSE
    Volatile:=FALSE *)

FROM SYSTEM IMPORT ADR,ADDRESS;
FROM String IMPORT Length,Occurs,CapString;
FROM Conversions IMPORT StrToVal;
FROM (*$ IF FFP *)     MathTrans
     (*$ ELSIF LONG *) MathIEEEDoubTrans
     (*$ ELSE *)       MathIEEESingTrans (*$ ENDIF *)
     IMPORT Sin,Cos,Tan,Sqrt,Log,Pow,Exp,Atan,Asin,Acos,Tanh,Sinh,Cosh,Log10;
FROM (*$ IF FFP *)     FFPConversions
     (*$ ELSIF LONG *) LongRealConversions
     (*$ ELSE *)       RealConversions    (*$ ENDIF *) IMPORT StrToReal;

(*$ IF FFP *)
  CONST factMax=20.0;  (* FFP *)
        winMax=102900.0;
        expMax=43.66;
(*$ ELSIF LONG *)
  CONST factMax=170.0;  (* LONGREAL *)
        winMax=10000000000000.0;
        expMax=709.78;
(*$ ELSE *)
  CONST factMax=34.0;  (* REAL *)
        winMax=10000000000000.0;
        expMax=88.72;
(*$ ENDIF *)

PROCEDURE calcex (ex:ARRAY OF CHAR;x:REAL;VAR y:REAL;VAR error:SHORTINT);

PROCEDURE summand():REAL; FORWARD;
PROCEDURE faktor():REAL; FORWARD;
PROCEDURE potenz():REAL; FORWARD;

VAR sym,pos:INTEGER;
    ch:CHAR;
    wert:REAL;
    einfach:ARRAY [0..20] OF CHAR;
    mehrfach:ARRAY [0..100] OF CHAR;

  PROCEDURE getch;
  BEGIN
    REPEAT
      IF pos<=Length(ex) THEN
        ch:=ex[pos];
        INC(pos);
      ELSE
        ch:=0C;
      END;
    UNTIL ch#" ";
  END getch;

  PROCEDURE getsym;
  VAR anz,stelle:INTEGER;
      wert2:LONGINT;
      mehr:ARRAY [0..20] OF CHAR;
      err,signed:BOOLEAN;
      altch:CHAR;
  BEGIN
    altch:=ch;
    wert:=0.0; mehr:="";
    anz:=0;
    WHILE (einfach[anz]#ch) AND (anz<=9) DO
      INC(anz); END;
    IF (anz<=9) AND ( (ex[pos]<"A") OR (ex[pos]>"Z") OR (anz<8) ) THEN
      sym:=anz; getch;
    ELSIF ch>="A" THEN    (* Funktion (mehrfach) ? *)
      stelle:=0;
      WHILE (ch>="A") AND (ch<="Z") AND (stelle<20) DO
        mehr[stelle]:=ch;
        INC (stelle);
        getch;
      END;
      mehr[stelle]:=0C;
      sym:=Occurs(mehrfach,0,mehr,FALSE);
      IF (sym=-1) OR (stelle<2) THEN sym:=-1;     (* Fehler *)
              ELSE
                stelle:=sym+Length(mehr);
                IF (mehrfach[sym-1]=" ") AND (mehrfach[stelle]=" ") THEN
                  sym:=sym DIV 5+11;
                ELSE sym:=-1; END;    (* Fehler *)
              END;
    ELSE    (* Zahl ? *)
      stelle:=0; anz:=10;  (* = Basis *)
      IF ch="$" THEN
        anz:=16; getch;
      ELSIF ch="%" THEN
        anz:=2; getch;
      END;
      WHILE ((ch=".") OR ((ch>="0") AND (ch<="9")) OR
                         ((ch>="A") AND (ch<="F")) ) AND (stelle<20) DO
        mehr[stelle]:=ch;
        INC(stelle);
        getch;
      END;
      mehr[stelle]:=0C;
      IF stelle=0 THEN sym:=-1;     (* Fehler *)
      ELSE
        sym:=10;
        IF anz=10 THEN
          StrToReal (mehr,wert,err);
        ELSE
          StrToVal (mehr,wert2,signed,anz,err);
          IF wert2<0 THEN sym:=-1;
                     ELSE wert:=REAL(wert2); END;
        END;
        IF err THEN sym:=-1; END;
      END;
    END;
    IF (sym=-1) AND (altch#0C) THEN error:=wrongSym; END;
  END getsym;

  PROCEDURE expression():REAL;
  VAR neuwert,geswert:REAL;
      osym:INTEGER;
  BEGIN
    CASE sym OF
       3: getsym; geswert:=summand();  (* + *)
      |4: getsym; geswert:=-summand(); (* - *)
      ELSE geswert:=summand();
    END;
    WHILE (sym=3) OR (sym=4) DO  (* +,- *)
      osym:=sym; getsym;
      neuwert:=summand();
      IF osym=3 THEN geswert:=geswert+neuwert;
                ELSE geswert:=geswert-neuwert; END;
    END;
    RETURN geswert;
  END expression;

  PROCEDURE summand():REAL;
  VAR neuwert,geswert:REAL;
      osym:INTEGER;
  BEGIN
    geswert:=potenz();
    WHILE (sym=5) OR (sym=6) DO  (* *,/ *)
      osym:=sym; getsym;
      neuwert:=potenz();
      IF osym=5 THEN geswert:=geswert*neuwert;
                ELSE
                  IF neuwert=0.0 THEN error:=Fehler
                                 ELSE geswert:=geswert/neuwert; END;
                END;
    END;
    RETURN geswert;
  END summand;

  PROCEDURE potenz():REAL;
  VAR neuwert,geswert:REAL;
      osym:INTEGER;
  BEGIN
    geswert:=faktor();
    WHILE sym=7 DO               (* ^ *)
      getsym;
      neuwert:=faktor();
      IF (geswert=0.0) AND (neuwert<=0.0) THEN        (* 0^(-ZAHL) *)
        error:=Fehler
      ELSE
        IF (geswert<0.0) THEN                      (* -ZAHL^ZAHL *)
          IF (neuwert=REAL(INTEGER(neuwert))) THEN (* -ZAHL^n *)
            IF (ODD(INTEGER(neuwert))) THEN        (* -ZAHL^(n ungrade) *)
              geswert:=-(Pow(geswert,neuwert))
            ELSE
              geswert:=Pow(geswert,neuwert);
            END;
          ELSE
            error:=Fehler;
          END;
        ELSE
          geswert:=Pow(geswert,neuwert);
        END;
      END;  (* IF (geswert=0.0) *)
    END;  (* WHILE *)
    RETURN geswert;
  END potenz;

  PROCEDURE Fact (x:REAL):REAL;
  VAR anz:INTEGER;
  BEGIN
    IF (x>factMax) OR (x<0.0) OR (x#REAL(LONGINT(x))) THEN
      error:=Fehler; RETURN x;
    END;
    anz:=INTEGER(x);
    IF anz<2 THEN RETURN 1.0; END;
    x:=1.0;
    REPEAT
      x:=x*REAL(anz);
      DEC (anz);
    UNTIL anz<2;
    RETURN x;
  END Fact;

  PROCEDURE faktor():REAL;
  VAR neuwert:REAL;
      osym:INTEGER;
  BEGIN
    CASE sym OF
        0: neuwert:=x;           (* x *)
           getsym;
      | 1: getsym;               (* ( *)
           neuwert:=expression();
           IF sym=2 THEN getsym;
           ELSIF error=noFehler THEN error:=Klammerzu; END;
      | 8: neuwert:=e;
           getsym;
      | 9: neuwert:=pi;
           getsym;
      |10: neuwert:=wert;        (* Zahl *)
           getsym;
      |11..29: osym:=sym;         (* Funkionen *)
           getsym;
           IF sym=1 THEN       (* ( *)
             getsym;
             neuwert:=expression();
             IF sym=2 THEN getsym;
             ELSIF error=noFehler THEN error:=Klammerzu; END;
             IF error=noFehler THEN
               CASE osym OF
                  11: IF neuwert>winMax THEN error:=Fehler;      (* sin *)
                                        ELSE neuwert:=Sin(neuwert); END;
                 |12: IF neuwert>winMax THEN error:=Fehler;      (* cos *)
                                        ELSE neuwert:=Cos(neuwert); END;
                 |13: IF neuwert>winMax THEN error:=Fehler;      (* tan *)
                                        ELSE neuwert:=Tan(neuwert); END;
                 |14: IF neuwert<=0.0 THEN error:=Fehler;        (* LN *)
                                      ELSE neuwert:=Log(neuwert); END;
                 |15: IF neuwert<0.0 THEN error:=Fehler;         (* sqrt *)
                                     ELSE neuwert:=Sqrt(neuwert); END;
                 |16: neuwert:=ABS(neuwert);                     (* ABS *)
                 |17: IF neuwert>expMax THEN error:=Fehler;      (* exp *)
                                        ELSE neuwert:=Exp(neuwert); END;
                 |18: neuwert:=Atan(neuwert);                    (* ArcTan *)
                 |19: IF (neuwert<-1.0) OR (neuwert>1.0) THEN error:=Fehler;
                          ELSE neuwert:=Asin(neuwert); END;      (* ArcSin *)
                 |20: IF (neuwert<-1.0) OR (neuwert>1.0) THEN error:=Fehler;
                          ELSE neuwert:=Acos(neuwert); END;      (* ArcCos *)
                 |21: neuwert:=Tanh(neuwert);                    (* TanH *)
                 |22: neuwert:=Sinh(neuwert);                    (* SinH *)
                 |23: neuwert:=Cosh(neuwert);                    (* CosH *)
                 |24: neuwert:=(neuwert/pi*180.0);               (* RToD *)
                 |25: neuwert:=(neuwert/180.0*pi);               (* DToR *)
                 |26: IF neuwert<0.0 THEN neuwert:=-1.0;         (* SGN *)
                      ELSIF neuwert>0.0 THEN neuwert:=1.0
                      ELSE neuwert:=0.0; END;
                 |27: neuwert:=Fact(neuwert);                    (* Fact *)
                 |28: IF neuwert<=0.0 THEN error:=Fehler;        (* Log *)
                                      ELSE neuwert:=Log10(neuwert); END;
                 |29: IF neuwert>2147000000.0 THEN error:=Fehler;
                      ELSE neuwert:=REAL(LONGINT(neuwert)); END; (* INT *)
               END;  (* CASE osym *)
             END;  (* IF error:=noFehler *)
           ELSE
             error:=Klammerauf;
           END;
    ELSE
      error:=wrongSym;
    END;  (* CASE sym *)
    RETURN neuwert;
  END faktor;

BEGIN
  y:=0.0;
  einfach:="X()+-*/^EP";
          (* ,1234,1234,1234,1234,1234,1234,1234,1234,1234,1234,1234,1234 *)
  mehrfach:=" SIN  COS  TAN  LN   SQRT ABS  EXP  ATAN ASIN ACOS TANH SINH"+
            " COSH RTOD DTOR SGN  FACT LOG  INT  ";
  CapString (ex);
  pos:=Length(ex);
  WHILE ex[pos]=" " DO
    ex[pos]:=0C; DEC (pos);
  END;
  pos:=0;
  error:=noFehler; sym:=-1;
  getch;  (* ex,pos,ch *)
  IF ch#0C THEN
    getsym; (* ex,pos,ch,sym,wert *)
    y:=expression();
  END;
  IF error=noFehler THEN
    IF sym=2 THEN error:=Klammerauf;
    ELSIF (ch#0C) OR (sym#-1) THEN
      error:=Fehler;
    END;
  END;
END calcex;

END function.