Turbo Toolbox/Turbo_Toolbox.iso/spezial/04/quellen/calc.pas

Pascal/Delphi Source File | 1979-12-31 | 18.8 KB | 436 lines

(***************************************************************************)
(*                                                                         *)
(*                            CALC.PAS                                     *)
(*    Berechnung von arithmetischen Ausdruecken in Pascal zur Laufzeit     *)
(*                                                                         *)
(***************************************************************************)

(* ----------------------------------------------------------------------- *)
(*            Uebersetzen eines Ausdrucks von AOS nach UPN:                *)
(* 'Expr' enthaelt den zu uebersetzenden Ausdruck                          *)
(* 'VarTable' ist ein Zeiger auf die fuer den zu uebersetzenden Ausdruck   *)
(* zu verwendente Variablen-Tabelle. Ist dieser '= nil', wird von 'Calc-   *)
(* Expression implizit eine solche Tabelle erzeugt und fuer den Ausdruck   *)
(* verwendet. Man beachte in diesem Zusammenhang auch 'CalcDecMod'!        *)
(* 'ExprPtr' gibt den Zeiger auf die von 'CompileExpression' erzeugte UPN- *)
(* Queue zurueck. Dieser ist '= nil', wenn ein fehlerhafter Ausdruck vor-  *)
(* liegt (kein Calc-Prog. erzeugt!).                                       *)
(* 'CalcResult' ist TRUE, wenn kein Problem auftrat - sonst FALSE!         *)
(* ----------------------------------------------------------------------- *)

PROCEDURE CompileExpression (Expr: Calc_String;
                             VAR VarTable: Calc_VarTab;
                             VAR ExprPtr : Calc_Prog);

VAR VarTabFlag,
    ParsError,
    EndOfExpr  : BOOLEAN;
    ch         : STRING[1];                (* akt. Zeichen aus String      *)
    LastPos,
    StrPos     : INTEGER;                  (* zaehlt String-Position mit   *)
    TempIdent,
    Ident      : Calc_String;              (* enth. aktuellen Bezeichner   *)
    Symbol,                                (* akt. Symbol des Bezeichners  *)
    LastSymbol : Calc_Symbols;             (* vorheriges Symbol            *)
    Number     : Calc_Operand;             (* akt. Zahl/Index aus String   *)
    ProgPtr    : Calc_Prog;

   (* -------------------------------------------------------------------- *)
   (* Fehlerbehandlung! Die Anweisungen des IF-Zweiges koennen nach        *)
   (* eigenen Beduerfnissen (z.B. der Programm-Umgebung) angepasst werden. *)

   PROCEDURE Error (ErrPos: INTEGER; ErrMsg: Calc_String);

   BEGIN
      IF NOT ParsError THEN
      BEGIN
         WriteLn; Write('*** Fehler in CompileExpression:');
         ClrEol; WriteLn;
         Write (' ',Expr);ClrEol; Writeln;
         Write (' ':ErrPos, '^'); ClrEol; Writeln;
         Write (ErrMsg, '!'); Clreol; Writeln; ClrEol;
         WriteLn; ClrEol
      END;
      ParsError := TRUE;  Symbol := Calc_Err
   END;

   (* -------------------------------------------------------------------- *)
   (*           naechsten Befehl an die UPN-Queue anhaengen:               *)
   (* Dabei wird mittels 'HeapAvail' der noch freie Heap geprueft. Wegen   *)
   (* des eventuellen Aufrufs der Error-Prozedur wird nicht nur Platz fuer *)
   (* ein Queue-Element benoetigt - deshalb ein paar Bytes mehr, um eine   *)
   (* Heap-Stack-Kollision zu vermeiden !                                  *)

   PROCEDURE Add_To_Queue (op: Calc_Symbols; x: Calc_Operand);

   VAR UPN_Entry: Calc_Prog;

   BEGIN
      IF HeapAvail > 160.0 THEN     (* hier: noch 160 Bytes im Heap frei ? *)
         BEGIN
            New (UPN_Entry);
            WITH UPN_Entry^ DO
            BEGIN
               NextInst := NIL;
               Instruct := op;
               CASE op OF
                  Calc_Var  : VarIndex := Trunc(x);
                  Calc_Const: Operand  := x
               END
            END;
            ProgPtr^.NextInst := UPN_Entry;
            ProgPtr           := ProgPtr^.NextInst
         END
      ELSE Error(1, 'nicht genuegend freier Speicher fuer den Ausdruck')
   END;

   (* -------------------------------------------------------------------- *)
   (*           naechstes Symbol aus der Zeichenkette holen:               *)

   PROCEDURE GetSymbol;

      (* ----------------------------------------------------------------- *)
      (*           holt naechstes Zeichen aus der Zeichenkette:            *)

      PROCEDURE GetChar;

      BEGIN
         ch := ' ';  StrPos := Succ(StrPos);
         EndOfExpr := (StrPos > Length(Expr));
         IF NOT EndOfExpr THEN ch := UpCase (Expr[StrPos])
      END;

      (* ----------------------------------------------------------------- *)
      (*        holt und wandelt Ziffernfolge aus der Zeichenkette:        *)
      (* die Val-Prozedur von Turbo Pascal moechte in der Zeichenkette nur *)
      (* gueltige Zeichen einer Real-Zahl haben, NumberEnd zeigt auf das   *)
      (* erste ungueltige Zeichen! Deshalb folgendes:                      *)

      PROCEDURE GetNumber;

      VAR NumberStr: Calc_String;
          NumberEnd,posi: INTEGER;

      BEGIN
         NumberStr := Copy (Expr, StrPos, 255); (* nimm alles ab 1. Ziffer *)
         NumberStr := NumberStr + '     ';
         posi := 1;
         while (not (numberstr[posi] in ['e','E']))
           and (posi < length(numberstr))
         do posi := succ(posi);
         if numberstr[posi] in ['e','E'] THEN
         BEGIN
           if numberstr[posi+1] in ['+','-'] THEN posi := succ(posi);
           if not (numberstr[posi+1] in ['0'..'9'])
             THEN error(StrPos+posi,'unvollstaendiger Ausdruck')
             else if
              ((numberstr[posi+1] = '3') and (numberstr[posi+2] in ['7'..'9']))
           or ((numberstr[posi+1] > '3') and (numberstr[posi+2] in ['0'..'9']))
                THEN error(StrPos+posi,'ausserhalb des Real-Bereichs');
         END;
         Val (NumberStr, Number, NumberEnd);
         IF NumberEnd > 0 THEN        (* ungueltiges Zeichen in NumberStr! *)
            BEGIN                     (* Zahl nicht am Ende von Expr.      *)
               StrPos := StrPos + NumberEnd - 2;
               NumberStr := Copy (NumberStr, 1, Pred(NumberEnd));
               Val (NumberStr, Number, NumberEnd)
            END
         ELSE                     (* hat geklappt, weil am Ende von Expr ! *)
            StrPos := Length(Expr)
      END;

      (* ----------------------------------------------------------------- *)
      (*           Symbolbezeichner in der Symbol-Tabelle suchen:          *)

PROCEDURE searchsymtab;

VAR symok: BOOLEAN;

BEGIN
  symok := FALSE;
  symbol := calc_err;
  WHILE (symbol < calc_end) AND NOT symok DO
    BEGIN
      symbol := Succ(symbol);
      symok := (ident = calc_ids[symbol]);
    END;
  IF NOT symok
    THEN
      symbol := calc_err
END;


      (* ----------------------------------------------------------------- *)

   BEGIN  (* GetSymbol *)
      LastPos := StrPos;  LastSymbol := Symbol;  Ident := '';
      WHILE (ch = ' ') AND NOT EndOfExpr DO GetChar;
      CASE ch[1] OF
         'A'..'Z': REPEAT      (* Bezeichner f. Operator, Funktion o. Var. *)
                      Ident := Concat (Ident, ch);  GetChar
                   UNTIL NOT (ch[1] IN ['A'..'Z', '0'..'9']);
         '0'..'9','.': BEGIN  GetNumber;  Ident := 'CONST';  GetChar  END
         ELSE      BEGIN  Ident := ch;  GetChar  END       (* + - * / usw. *)
      END;
      SearchSymtab;
      IF Symbol = Calc_Err THEN      (* Zeichenfolge nicht identifiziert ! *)
         IF Ident[1] IN ['A'..'Z'] THEN    (* nehmen wir sie als Variable! *)
            Symbol := Calc_Var
         ELSE IF Ident <> ' ' THEN Error(LastPos, 'unbekanntes Symbol');
      IF Symbol = Calc_Var THEN
         IF LastSymbol <> Calc_Var THEN
            BEGIN
               Number := SearchVarTab(VarTable, Ident);
               (* entspr. 'CalcDecMod' eine nicht identifizierte Zeichen-
                  folge abweisen oder als neue Variable interpretierten.   *)
               IF CalcDecMod AND (Number = 0.0) THEN
                  Error(LastPos, 'unbekanntes Symbol')
               ELSE IF Number = 0.0 THEN
               BEGIN
                  Number := AddToVarTab(VarTable, Ident);
                  IF Number < 0.0 THEN
                     Error(LastPos, 'Zu viel Variable im Ausdruck')
               END
            END
         ELSE IF NOT EndOfExpr THEN Error(LastPos, 'Operator erwartet')
   END;

   (* -------------------------------------------------------------------- *)
   (* Ausdruck kann aus mehreren mit + u. - verknuepften Termen bestehen.  *)
   (* Das ist die Aufgabe von:                                             *)

{$A-}     (* rekursiven Code unter CP/M erzeugen ! *)

   PROCEDURE Expression;

   VAR ExprOp: Calc_Symbols;

      (* ----------------------------------------------------------------- *)
      (* Term kann aus mehreren mit den entspr. Operatoren verknuepften    *)
      (* Faktoren bestehen (z.B. Faktor*Faktor). Also:                     *)

      PROCEDURE Term;

      VAR TermOp: Calc_Symbols;

         (* -------------------------------------------------------------- *)
         (* Faktor kann eine Variable, eine Konstante, eine Funktion oder  *)
         (* wieder ein geklammerter Ausdruck sein, die alle noch           *)
         (* potenziert werden koennen! Der Parameter 'fparen' gibt an, ob  *)
         (* es sich bei einer Klammerung um Ausdrucks- oder Funktions-     *)
         (* klammern handelt. Bei letzterem muss vor der Potenzierung noch *)
         (* die Funktion ausgewertet werden! Deshalb:                      *)

         PROCEDURE Factor (fparen: BOOLEAN);

         VAR FacOp: Calc_Symbols;

         BEGIN
            IF Symbol <> Calc_Err THEN
            BEGIN
               CASE Symbol OF
                  Calc_Var: BEGIN
                               Add_To_Queue (Calc_Var, Number);  GetSymbol
                            END;
                Calc_Const: BEGIN
                               Add_To_Queue (Calc_Const, Number);  GetSymbol
                            END;
                   Calc_Pi: BEGIN
                               Add_To_Queue (Calc_Const, Pi);  GetSymbol
                            END;
                    Calc_E: BEGIN
                               Add_To_Queue (Calc_Const, E);  GetSymbol
                            END;
                   Calc_lp: BEGIN                 (* geklammerter Ausdruck *)
                               GetSymbol;
                               Expression;
                               IF (Symbol <> Calc_rp) THEN
                                  Error (StrPos - Ord(ch[1] > ' '),
                                         Concat(Calc_Ids[Calc_rp],
                                                ' erwartet'));
                               GetSymbol
                            END;
                  Calc_Pow: ;      (* Potenzieren, wird spaeter erledigt ! *)
                Calc_Sqr..
                  Calc_Fak: BEGIN                            (* Funktionen *)
                               FacOp := Symbol;
                               GetSymbol;
                               IF (Symbol = Calc_lp) THEN
                                  Factor(TRUE)
                               ELSE
                                  Error (LastPos, Concat(Calc_Ids[Calc_lp],
                                                         ' erwartet'));
                               Add_To_Queue (FacOp, 0)
                            END
                  ELSE              (* Symbol an dieser Stelle unerwartet! *)
                     Error(LastPos, 'hier unerwartet')
               END; (* CASE *)
               IF NOT fparen THEN          (* keine Funktionsklammer, also *)
                  IF Symbol = Calc_Pow THEN               (* potenzieren ! *)
                     IF LastSymbol IN [Calc_Const,Calc_Var,Calc_rp,
                                       Calc_PI,Calc_e] THEN
                     BEGIN  (* wenn LastSym. ok, Potenzausdruck auswerten: *)
                        GetSymbol;   Factor(FALSE);
                        Add_To_Queue (Calc_Pow, 0);
                     END
                  ELSE                 (* Potenzierung hier nicht moeglich *)
                     Error (Pred(StrPos), 'hier unerwartet');
            END (* IF Symbol <> Calc_Err *)
            ELSE
               Error(StrPos-Ord(EndOfExpr), 'unvollstaendiger Ausdruck');
         END; (* Faktor *)

      (* ----------------------------------------------------------------- *)

      BEGIN  (* Term *)
         Factor(FALSE);
         IF Symbol IN [Calc_Mul..Calc_kgV] THEN
         BEGIN                      (* mehrere Faktoren im Term enthalten! *)
            TermOp := Symbol;  GetSymbol;
            Term;  Add_To_Queue (TermOp,0)
         END;
      END; (* Term *)

   (* -------------------------------------------------------------------- *)

   BEGIN  (* Expression *)
      IF Symbol IN [Calc_Add..Calc_Sub] THEN
         BEGIN                              (* Ausdruck beginnt mit + o. - *)
            ExprOp := Symbol;  GetSymbol;  Term;
            IF ExprOp = Calc_Sub THEN             (* 1. Symbol war -, also *)
               Add_To_Queue (Calc_Neg, 0);        (* alles negieren !      *)
         END
      ELSE
         Term;
      WHILE (Symbol IN [Calc_Add..Calc_Sub]) DO
      BEGIN                                   (* es folgen weitere Terme ! *)
         ExprOp := Symbol;  GetSymbol;  Term;
         Add_To_Queue (ExprOp, 0);
      END;
   END; (* Expression *)
{$a+}   (* ab hier wieder absoluten Code unter CP/M erzeugen *)

   (* -------------------------------------------------------------------- *)

BEGIN  (* CompileExpression *)
   Symbol := Calc_Err;   ParsError := FALSE;  EndOfExpr := FALSE;
   StrPos := 0;          ch := ' ';           VarTabFlag := (VarTable = NIL);
   IF VarTabFlag THEN VarTable := NewVarTab;
   New (ExprPtr);   ExprPtr^.NextInst := NIL;  ProgPtr := ExprPtr;
   GetSymbol;       Expression;
   IF Symbol <> Calc_EOE THEN Error(LastPos, '";" erwartet');
   CalcResult := NOT ParsError;
   IF ParsError THEN
   BEGIN
      KillExpression(ExprPtr);
      IF VarTabFlag THEN KillVarTab(VarTable)
   END;
END;

(* ----------------------------------------------------------------------- *)
(*             Auswertung des in UPN uebersetzten Ausdrucks                *)
(* ----------------------------------------------------------------------- *)

FUNCTION CalcExpression (ExprPtr : Calc_Prog;
                         VarTable: Calc_VarTab): Calc_Operand;

CONST StackSize = 50;

VAR x       : Calc_Operand;
    StackPtr: INTEGER;
    Stack   : ARRAY[1..StackSize] OF Calc_Operand;         (* Rechenstapel *)


   PROCEDURE Push;                        (* schiebt Zahl auf Rechenstapel *)

   BEGIN
      Stack[StackPtr] := x;  StackPtr := Succ(StackPtr)
   END;


   FUNCTION Pop: Calc_Operand;               (* holt Zahl vom Rechenstapel *)

   BEGIN
      StackPtr := Pred(StackPtr);  Pop := Stack[StackPtr]
   END;


BEGIN  (* CalcExpression *)
   CalcResult := TRUE;
   IF (ExprPtr <> NIL) AND (VarTable <> NIL) THEN
   BEGIN
      ExprPtr := ExprPtr^.NextInst;     (* 1. Eintrag der Queue ist leer ! *)
      StackPtr := 1;  x := 0.0;                (* Laufzeit-Stapel ist leer *)
      WHILE ExprPtr <> NIL DO
      BEGIN
         WITH ExprPtr^ DO
            CASE Instruct OF
               Calc_Const: BEGIN Push;  x := Operand  END;
               Calc_Var  : BEGIN
                              Push;  x := VarTable^[VarIndex].Value
                           END;
            ELSE
               BEGIN
                  CASE Instruct OF
                     Calc_Neg    : x := -x;
                     Calc_Add    : x := Pop+x;
                     Calc_Sub    : x := Pop-x;
                     Calc_Mul    : x := Pop*x;
                     Calc_Dvd    : IF x <> 0.0 THEN x := Pop/x
                                   ELSE CalcError(2, '');
                     Calc_Div    : IF Trunc(x) <> 0 THEN
                                     x := Trunc(Pop) DIV Trunc(x)
                                   ELSE CalcError(2, '');
                     Calc_Mod    : IF Trunc(x) <> 0 THEN
                                     x := Trunc(Pop) MOD Trunc(x)
                                   ELSE CalcError(2, '');
                     Calc_ggT    : x := ggT(Trunc(Pop),Trunc(x));
                     Calc_kgV    : x := kgV(Trunc(Pop),Trunc(x));
                     Calc_Pow    : x := x_hoch_y(Pop,x);
                     Calc_Sqr    : x := Sqr(x);
                     Calc_Sqrt   : IF x >= 0.0 THEN x := Sqrt(x)
                                   ELSE CalcError(3, 'Sqrt(x): x <= 0');
                     Calc_Exp    : x := Exp(x);
                     Calc_Ln     : IF x > 0.0 THEN x := Ln(x)
                                   ELSE CalcError(3, 'ln(x): x <= 0');
                     Calc_Lg     : x := lg(x);
                     Calc_Ld     : x := ld(x);
                     Calc_Sin    : x := Sin(x);
                     Calc_Cos    : x := Cos(x);
                     Calc_Tan    : x := tan(x);
                     Calc_Cot    : x := cot(x);
                     Calc_ArcSin : x := arcsin(x);
                     Calc_ArcCos : x := arccos(x);
                     Calc_ArcTan : x := ArcTan(x);
                     Calc_ArcCot : x := arccot(x);
                     Calc_Sinh   : x := sinh(x);
                     Calc_Cosh   : x := cosh(x);
                     Calc_Tanh   : x := tanh(x);
                     Calc_Coth   : x := coth(x);
                     Calc_ArcSinh: x := arsinh(x);
                     Calc_ArcCosh: x := arcosh(x);
                     Calc_ArcTanh: x := artanh(x);
                     Calc_ArcCoth: x := arcoth(x);
                     Calc_Abs    : x := abs(x);
                     Calc_Deg    : x := altgrad(x);
                     Calc_Rad    : x := radiant(x);
                     Calc_Rez    : x := kehrwert(x);
                     Calc_Fak    : x := fakultaet(Round(x));
                     Calc_Int    : x := Int(x);
                     Calc_Sig    : x := Sign(x);
                     ELSE CalcError(0, 'Funktion nicht verfuegbar')
                  END (* CASE *)
               END (* ELSE *)
            END (* CASE *);
         ExprPtr := ExprPtr^.NextInst;
         IF StackPtr > StackSize THEN CalcError(0, 'Stackueberlauf');
         IF NOT CalcResult THEN ExprPtr := NIL
      END; (* WHILE *)
      CalcExpression := x
   END (* THEN *)
   ELSE CalcError(0, 'ungueltiger Ausdruck')
 END;

(* ----------------------------------------------------------------------- *)
(*                         Ende von CALC.PAS                               *)