Power-Programmierung/CD1.mdf/pascal/library/dos/pibsoft/pibcalc/expressi.pas

Pascal/Delphi Source File | 1986-01-13 | 20.1 KB | 600 lines

(*--------------------------------------------------------------------------*)
(*                Expression -- parse and execute expression                *)
(*--------------------------------------------------------------------------*)

PROCEDURE Expression( VAR formal: formalty;
                      VAR Iline:  AnyStr;
                      VAR Ipos:   INTEGER;
                      VAR v:      valuety);

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  Expression                                               *)
(*                                                                          *)
(*     Purpose:    Parse and execute expression                             *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        Expression( VAR formal: formalty;                                 *)
(*                    VAR Iline:  AnyStr;                                   *)
(*                    VAR Ipos:   INTEGER;                                  *)
(*                    VAR v:      valuety);                                 *)
(*                                                                          *)
(*           formal -- formal parameter block                               *)
(*           Iline  -- input command line                                   *)
(*           Ipos   -- current position in input command line               *)
(*           v      -- value of variable                                    *)
(*                                                                          *)
(*     Calls:     Term                                                      *)
(*                                                                          *)
(*     Called By: DoExp                                                     *)
(*                                                                          *)
(*     Remarks:                                                             *)
(*                                                                          *)
(*        This is the heart of the PibCalc program.  This procedure         *)
(*        controls parsing and execution of an expression in PibCalc        *)
(*        syntax.  The method used is recursive descent.                    *)
(*                                                                          *)
(*        Expression syntax:                                                *)
(*        -----------------                                                 *)
(*                                                                          *)
(*        Expressions are composed of constants, variables, function calls, *)
(*        and the special element '.', using the operators  +, -, *, /, **, *)
(*        MOD, and DIV, acoording to the usual algorithmic programming      *)
(*        language syntax rules.  Parentheses may be used for grouping.     *)
(*        The precise syntax is given below in a modified Backus-Naur form. *)
(*                                                                          *)
(*        Notation used:                                                    *)
(*                                                                          *)
(*           =            is defined to be.                                 *)
(*           .            end of definition.                                *)
(*           '...'        Literal.                                          *)
(*           [...]        Optional.                                         *)
(*           <...>        Repeat 0 or more times.                           *)
(*           |            Or.                                               *)
(*           (...)        Grouping.                                         *)
(*                                                                          *)
(*           EXP     = [SIGN] TERM < ADOP TERM >.                           *)
(*           TERM    = FACTOR < MULOP FACTOR >.                             *)
(*           FACTOR  = ELEMENT < '**' ELEMENT >.                            *)
(*           ELEMENT = CONST | VAR | '(' EXP ')' | '.' | FUNC.              *)
(*           SIGN    = '+' | '-'.                                           *)
(*           ADOP    = '+' | '-'.                                           *)
(*           MULOP   = '*' | '/' | 'MOD' | 'DIV'.                           *)
(*           CONST   = INT | REAL.                                          *)
(*           INT     = DECINT | OCTINT | HEXINT.                            *)
(*           DECINT  = DEC <DEC> ['D'].                                     *)
(*           OCTINT  = OCT <OCT> ['B'|'O'].                                 *)
(*           HEXINT  = HEX <HEX> ['X'].                                     *)
(*           REAL    = DEC <DEC> '.' <DEC> [EXPON] |                        *)
(*                     <DEC> '.' DEC <DEC> [EXPON].                         *)
(*           EXPON   = 'E' [SIGN] DEC <DEC>.                                *)
(*           VAR     = LET.                                                 *)
(*           FUNC    = FNAME [ '(' EXP < ',' EXP > ')' ].                   *)
(*           FNAME   = LET < ALPHNUM >.                                     *)
(*           ALPHNUM = LET | DEC.                                           *)
(*           LET     = 'A' | ... | 'Z'.                                     *)
(*           DEC     = '0' | ... | '9'.                                     *)
(*           OCT     = '0' | ... | '7'.                                     *)
(*           HEX     = '0' | ... | '9' | 'A' | ... | 'F'.                   *)
(*                                                                          *)
(*        The routines here are a quite direct translation of this syntax   *)
(*        into Turbo.  Hence, detailed descriptions of the routines are     *)
(*        not provided.                                                     *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)


LABEL
   99  (* ERROR EXIT *);

VAR
   negate: BOOLEAN;
   op:     Tokenty;
   w:      valuety;

(*--------------------------------------------------------------------------*)
(*                NextTok -- Get next token                                 *)
(*--------------------------------------------------------------------------*)

PROCEDURE NextTok;

BEGIN (* NextTok *)

   GetTok( Iline , Ipos );

END   (* NextTok *);

(*--------------------------------------------------------------------------*)
(*                VarVal -- Get value of variable                           *)
(*--------------------------------------------------------------------------*)

PROCEDURE VarVal( varnam: varnamty; VAR v: valuety );

VAR
   i:     INTEGER;
   found: BOOLEAN;

BEGIN  (* VarVal *)

   WITH formal DO
      BEGIN

         i     := 0;
         found := FALSE;

         WHILE ( i < nump ) AND ( NOT found ) DO
            BEGIN
               i     := i + 1;
               found := ( varnam = parms[i].name );
            END;

         IF found THEN
            v := parms[i].VAL
         ELSE
            IF NOT VarVals[varnam].def THEN Undef(varnam)
            ELSE v := VarVals[varnam]

      END;

END   (* VarVal *);

(*--------------------------------------------------------------------------*)
(*                StdFunc -- Get value of standard function                 *)
(*--------------------------------------------------------------------------*)

PROCEDURE StdFunc( index:INTEGER; VAR v:valuety );

LABEL
   99  (* Error exit *);

VAR
      a: valuety;
      b: valuety;
      k: INTEGER;

(*--------------------------------------------------------------------------*)
(*                BadArg -- Report error in argument to function            *)
(*--------------------------------------------------------------------------*)

PROCEDURE BadArg;

BEGIN (* BadArg *)

   WRITELN('Bad argument to ',StdFuncs[index].name);
   ErrorFlag := TRUE;

END   (* BadArg *);

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

BEGIN  (* StdFunc *)

   WITH StdFuncs[index],v DO
      BEGIN

         def := TRUE;
         typ := rea;
         i    := 0;

         IF nparms <> 0 THEN
         BEGIN
                                   (* Evaluate 1st function argument *)
            NextTok;

            IF Token <> oparsy THEN
               BEGIN
                  SynErr;
                  GOTO 99;
               END;

            NextTok;

            Expression( formal, Iline, ipos, a );

            IF ErrorFlag THEN GOTO 99;

            IF nparms = 2 THEN     (* Evaluate 2nd function argument *)
            BEGIN

               IF Token <> commasy THEN
                  BEGIN
                     SynErr;
                     GOTO 99;
                  END;

               NextTok;

               Expression( formal, Iline, ipos, b );

               IF ErrorFlag THEN GOTO 99;

            END;

         END;

                                   (* Convert angle in degrees to angle *)
                                   (* in radians                        *)

         IF ( angle = deg ) AND ( func IN [ sinf..cscf ] ) THEN
            a.r := a.r * PI/180.0;

                                   (* Check for valid argument values *)
         CASE func OF
            tanf, secf:
               IF COS(a.r) = 0.0 THEN BadArg;
            cotf, cscf:
               IF SIN(a.r) = 0.0 THEN BadArg;
            asinf, acosf:
               IF abs(a.r) > 1.0 THEN BadArg;
            asecf, acscf:
               IF abs(a.r) < 1.0 THEN BadArg;
            atan2f:
               IF abs(a.r)=0.0 THEN IF abs(b.r)=0.0 THEN BadArg;
            lnf, log10f:
               IF a.r <= 0.0 THEN BadArg;
            logf:
               BEGIN
                  IF a.r <= 0.0 THEN BadArg;
                  IF b.r <= 0.0 THEN BadArg
               END;
            sqrtf:
               IF a.r < 0.0 THEN BadArg;
            ELSE;
         END (* CASE *);

         IF ErrorFlag THEN GOTO 99;

                                   (* Evaluate the function *)
         CASE func OF

            absf:
               BEGIN
                  typ := a.typ;
                  r   := abs( a.r );
                  i   := abs( a.i );
               END;
            minf, Maxf:
               BEGIN
                  typ := a.typ;
                  r   := a.r;
                  i   := a.i;
                  WHILE Token = commasy DO
                     BEGIN
                        NextTok;
                        Expression( formal, Iline, ipos, a );
                        IF ErrorFlag THEN GOTO 99;
                        IF a.typ = rea THEN typ := rea;
                        IF ( ( func = minf ) AND ( a.r < r ) ) OR
                           ( ( func = maxf ) AND ( a.r > r ) ) THEN
                           BEGIN
                              r := a.r;
                              i := a.i
                           END
                     END
               END;

            truncf:
               BEGIN
                  i   := TRUNC( a.r );
                  k   := i;
                  r   := k;
                  typ := INT;
               END;

            roundf:
               BEGIN
                  i   := ROUND( a.r );
                  k   := i;
                  r   := k;
                  typ := INT;
               END;

            sinf:   r := SIN( a.r );
            cosf:   r := COS( a.r );
            tanf:   r := SIN( a.r ) / COS( a.r );
            cotf:   r := COS( a.r ) / SIN( a.r );
            secf:   r := 1.0 / COS( a.r );
            cscf:   r := 1.0 / SIN( a.r );
            asinf:  r := arcsin( a.r );
            acosf:  r := arccos( a.r );
            atanf:  r := ARCTAN( a.r );
            acotf:  r := PI / 2.0 - ARCTAN( a.r );
            asecf:  r := arccos( 1.0 / a.r );
            acscf:  r := arcsin( 1.0 / a.r );
            atan2f: r := arctan2( a.r , b.r );
            expf:   r := EXP( a.r );
            lnf:    r := LN( a.r );
            log10f: r := log10( a.r );
            logf:   r := log( a.r , b.r );
            sqrtf:  r := SQRT( a.r );
            EEf:    r := EE;
            PIf:    r := PI;

         END (* CASE *);

         IF ErrorFlag THEN GOTO 99;

                                   (* Convert angles to degrees if needed *)

         IF ( angle = deg ) AND ( func IN [asinf..atan2f] ) THEN
            r := r * 180.0/PI;
                                   (* Check if any garbage left over *)

         IF (nparms <> 0) AND (Token <> cparsy) THEN SynErr

      END  (* WITH *);

99:
   END;

(*--------------------------------------------------------------------------*)
(*               UserFunc -- Evaluate user-defined function                 *)
(*--------------------------------------------------------------------------*)

PROCEDURE UserFunc (index: INTEGER; VAR v: valuety);

LABEL
   99 (* ERROR EXIT *);

VAR
   lformal: formalty;
   i:       INTEGER;
   dpos:    INTEGER;

BEGIN  (* UserFunc *)

   WITH UserFuncs[index],lformal DO

      BEGIN
                                   (* Pick up no. of params to function *)
         nump := nparms;

         IF nparms > 0 THEN        (* If params, need to evaluate each one *)
            BEGIN

               NextTok;            (* Look for open paren of arg list *)

               IF Token <> oparsy THEN
                  BEGIN
                     SynErr;
                     GOTO 99;
                  END;
                                    (* Loop over each param *)

               FOR i := 1 TO nparms DO
                  BEGIN
                                    (* Pick up formal param name *)

                     parms[i].name := pnames[i];

                     NextTok;
                                    (* Evaluate its actual value *)

                     Expression( formal, Iline, ipos, parms[i].VAL );

                     IF ErrorFlag THEN GOTO 99;

                                    (* Look for comma *)

                     IF i < nparms THEN
                        IF Token <> commasy THEN
                           BEGIN
                              SynErr;
                              GOTO 99;
                           END;

                  END;
                                   (* Look for closing right paren *)
                                   (* of argument list             *)

            IF Token <> cparsy THEN
               BEGIN
                  SynErr;
                  GOTO 99;
               END;

         END;
                                   (* Now scan definition of function, *)
                                   (* inserting actual values in place *)
                                   (* of formal parameters, and hence  *)
                                   (* evaluating function.             *)

                                   (* dpos = current position in       *)
                                   (* definition of function.          *)
         dpos := 1;

         GetTok( defn , dpos );

         Expression( lformal, defn, dpos, v );

         IF ErrorFlag THEN GOTO 99;

                                   (* Ensure all of function definition *)
                                   (* used up.                          *)

         IF Token <> eolsy THEN
            BEGIN
               SynErr;
               GOTO 99;
            END;

      END;

99:
END   (* UserFunc *);

(*--------------------------------------------------------------------------*)
(*               Element -- pick up 'element' in expression                 *)
(*--------------------------------------------------------------------------*)

PROCEDURE Element( VAR v: valuety );

LABEL
   99 (* ERROR EXIT *);

BEGIN (* Element *)

         (*---------------------------------------------------*)
         (* ELEMENT = CONST | VAR | '(' EXP ')' | '.' | FUNC. *)
         (*---------------------------------------------------*)

   CASE Token OF
      constsy   :   v := constval;
      varsy     :   VarVal( varnam , v );
      oparsy    :   BEGIN
                       NextTok;
                       Expression( formal, Iline, ipos, v );
                       IF ErrorFlag THEN GOTO 99;
                       IF Token <> cparsy THEN SynErr;
                    END;
      periodsy  : v := curval;
      StdFuncsy : StdFunc( iStdFunc , v );
      UserFuncsy: UserFunc( iUserFunc , v );
      ELSE
         SynErr;
   END (* Case *);

   IF ( NOT ErrorFlag ) THEN NextTok;

99:
END (* Element *);

(*--------------------------------------------------------------------------*)
(*               Factor -- pick up 'factor' in expression                   *)
(*--------------------------------------------------------------------------*)

PROCEDURE Factor( VAR v: valuety );

VAR
   w: valuety;

LABEL 99;

BEGIN (* Factor *)

         (*-------------------------------------*)
         (* FACTOR  = ELEMENT < '**' ELEMENT >. *)
         (*-------------------------------------*)

   Element( v );

   IF ErrorFlag THEN GOTO 99;

   WHILE Token = exponsy DO
      BEGIN

         NextTok;

         Element( w );

         IF ErrorFlag THEN GOTO 99;

         Powvals( v , w );

      END;

99:
END  (* Factor *);

(*--------------------------------------------------------------------------*)
(*               Term -- pick up 'term' in expression                       *)
(*--------------------------------------------------------------------------*)

PROCEDURE Term( VAR v: valuety );

VAR
   op: Tokenty;
   w:  valuety;

LABEL 99;

BEGIN  (* Term *)

         (*---------------------------------*)
         (* TERM = FACTOR < MULOP FACTOR >. *)
         (*---------------------------------*)

   Factor( v );

   IF ErrorFlag THEN GOTO 99;

   WHILE Token IN [starsy,slashsy,modsy,divsy] DO
      BEGIN

         op := Token;

         NextTok;

         Factor( w );

         IF ErrorFlag THEN GOTO 99;

         CASE op OF
            starsy:  MulVals ( v , w );
            slashsy: RdivVals( v , w );
            divsy:   IdivVals( v , w );
            modsy:   ModVals ( v , w );
         END;

      END;

99:
END  (* Term *);

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

BEGIN (* Expression *)

                                    (* Any errors before getting here? *)
                                    (* If so, do nothing.              *)
   IF ErrorFlag THEN GOTO 99;

         (*-----------------------------------*)
         (* EXP = [SIGN] TERM < ADOP TERM >.  *)
         (*-----------------------------------*)

                                    (* Check for and remember leading *)
                                    (* sign                           *)
   negate := FALSE;

   IF Token IN [plussy,minussy] THEN
   BEGIN
      negate := ( Token = minussy );
      NextTok;
   END;
                                   (* Pick up leading expression value *)
   Term( v );
   IF ErrorFlag THEN GOTO 99;

                                   (* Apply negative sign if leading '-' *)
   IF negate THEN
      WITH v DO
         BEGIN
            r := -r;
            IF typ = INT THEN i := -i;
         END;

                                   (* Continue through rest of expression *)

   WHILE Token IN [plussy,minussy] DO
      BEGIN

         op := Token;

         NextTok;

         Term( w );

         IF ErrorFlag THEN GOTO 99;

         CASE op OF
            plussy:  addvals( v , w );
            minussy: subvals( v , w );
         END;

      END;

99:
END  (* EXPRESSION *);