{ eval.pas }

PROGRAM evalexpr(input,output);
  { Evaluate an infix expression typed on the command line.  Give no arguments
     to get the help message.  Bruce K. Hillyer.

   This program is written for Microsoft pascal to use the REAL8 type,
     which seems to avoid answers like 0.999999999999999 when the correct
     answer is 1.

   Note that some versions of Microsoft pascal incorrectly decide that your pc
     has an 8087 or 80287 math coprocessor when in fact it doesn't.  To check
     this, try a simple multiplication.  If  eval 2*3   says 2, rather than 6,
     set the enviornment variable   set NO87=X   in your autoexec.bat file.

   This code is derived in part from the spreadsheet that comes with turbo 
     pascal, which contains the following message: 

	    MICROCALC DEMONSTRATION PROGRAM  Version 1.00A

       This program is hereby donated to the public domain
       for non-commercial use only.  Dot commands are  for
       the program lister: LISTT.PAS  (available with  our
       TURBO TUTOR):    .PA, .CP20, etc...
  }

TYPE
  exprStr   = LSTRING(80);

VAR
  cmdTail : ADS OF LSTRING(80);
  Cesxqq [EXTERN] : WORD;

  retnVl : REAL8;
  errLoc : INTEGER;
  i : INTEGER;


{ functions for REAL8 }
FUNCTION Andrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { round }
FUNCTION Aidrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { trunc }
FUNCTION Srdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { sqrt }
FUNCTION Sndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { sin }
FUNCTION Cndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { cos }
FUNCTION Tndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { tan }
FUNCTION Asdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { arcsin }
FUNCTION Acdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { arccos }
FUNCTION Atdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { arctan }
FUNCTION Shdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { sinh }
FUNCTION Chdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { cosh }
FUNCTION Thdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { tanh }
FUNCTION Lndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { ln }
FUNCTION Lddrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { log }
FUNCTION Exdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { exp }
FUNCTION Pidrqq(CONSTS a : REAL8; CONSTS b : INTEGER4) : REAL8; EXTERN;{power}
FUNCTION Prdrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { power }
FUNCTION Mddrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { mod }
FUNCTION Mndrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { min }
FUNCTION Mxdrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { max }

PROCEDURE Endxqq; EXTERN;  { halt }


PROCEDURE strToNum(formula : exprStr; start, len : INTEGER;
		   VAR retVal : REAL8; VAR errPos : INTEGER);
  VAR
    tempStr : LSTRING(80);
    i : INTEGER;
  BEGIN
    FOR i:=1 TO len DO
      tempStr[i] := formula[start+i-1];
    tempStr.Len := Wrd(len);
    WHILE (tempStr.Len > 0) AND (tempStr[1] = ' ') DO
      Delete(tempStr,1,1);
    IF tempStr[1] = '.' THEN Insert('0',tempStr,1);
    IF tempStr[1] = '+' THEN Delete(tempStr,1,1);
    IF NOT Decode(tempStr,retVal) THEN errPos := start
  END; { strToNum }



PROCEDURE printNum(num : REAL8);
  VAR
    pointLoc : INTEGER;
    tempStr : LSTRING(40);
  BEGIN
    IF (num = Andrqq(num)) AND (num <= 1.0e17) THEN { integer }
      BEGIN IF NOT Encode(tempStr,num:1:0) THEN Writeln(output,'output bug ');
      	    tempStr.Len := Wrd(Ord(tempStr.Len) - 1);  { no point }
	    Writeln(output,tempStr)
      END
    ELSE IF Abs(num) > 1.0e6 THEN Writeln(output,num:24)  { big float }
    ELSE BEGIN IF NOT Encode(tempStr,Abs(num):1:16) THEN
    		 Write(output,'output bug  ');
	       { the position of the decimal point is one more than the number
	       	 of digits in the absolute value of the integer part }
	       pointLoc := Positn('.',tempStr,1);
    	       IF pointLoc = 0
	         THEN Writeln(output,num:1:0)
	         ELSE BEGIN IF NOT Encode(tempStr,num:1:(16-pointLoc)) THEN
			      Write(output,'output bug  ');
			    WHILE (Ord(tempStr.Len) > pointLoc) AND
		 		  (tempStr[Ord(tempStr.Len)] = '0') DO
			      tempStr.Len := Wrd(Ord(tempStr.Len) - 1);
			    IF tempStr[Ord(tempStr.Len)] = '.' THEN
			      tempStr.Len := Wrd(Ord(tempStr.Len) - 1);
			    Writeln(output,tempStr)
		      END
    	 END
  END; { printNum }



PROCEDURE evaluate(formula : exprStr; VAR exprVl: REAL8; VAR errPos: INTEGER);
  { evaluate the formula }

VAR
  pos : INTEGER;    { current position in formula      }
  ch : CHAR;        { Current character being scanned  }

  PROCEDURE nextCh;
    { get the next character into ch, set pos, <cr> indicates eos }
    BEGIN REPEAT pos := pos + 1;
    		 IF pos <= Ord(formula.Len) THEN ch := formula[pos]
		 		            ELSE ch := Chr(0)
	  UNTIL ch <> ' '
    END; { nextCh }


  FUNCTION expression : REAL8;
    VAR
      e : REAL8;

    FUNCTION simpleExpression : REAL8;
      VAR
        s : REAL8;

      FUNCTION term : REAL8;
        VAR
          t,t2 : REAL8;

        FUNCTION signedFactor : REAL8;

          FUNCTION factor : REAL8;
            TYPE
              builtin = (fabs, fround, ftrunc, fsqrt, fsqr, fsin, fcos, ftan,
	      		 farcsin, farccos, farctan, fsinh, fcosh, ftanh,
			 fln, flog, flog2, fexp, ffact);
              builtinList = ARRAY[builtin] OF LSTRING(6);

            CONST
              builtinNames = builtinList
	      	  ('abs', 'round', 'trunc', 'sqrt', 'sqr', 'sin', 'cos','tan',
                   'arcsin', 'arccos', 'arctan', 'sinh', 'cosh', 'tanh',
		   'ln', 'log', 'log2', 'exp', 'fact');
            VAR
              e,l : INTEGER;       { intermediate variables }
              found : BOOLEAN;
              f : REAL8;
              fn : builtin;
              start : INTEGER;

	     FUNCTION thisFn(inp : exprStr; pos : INTEGER; fn : builtin)
 	     		    : BOOLEAN;
	       { see if the input at location pos contains the fn name }
	       VAR
	         i : INTEGER;
	       BEGIN
	         thisFn := TRUE;
		 FOR i:=1 TO Ord(builtinNames[fn].Len) DO
		   IF inp[i+pos-1] <> builtinNames[fn,i] THEN thisFn := FALSE
	       END; { thisFn }


              FUNCTION factorial(arg : REAL8): REAL8;
                BEGIN
		  arg := Andrqq(arg);  { round it to avoid strangeness }
		  IF arg > 170 THEN 
		    BEGIN Writeln(output,'factorial: Too large argument');
		    	  Endxqq
		    END;
		  IF arg < 0 THEN 
		    BEGIN Writeln(output,'factorial: Negative argument');
		    	  Endxqq
		    END;
		  IF arg > 0 THEN factorial := arg * factorial(arg-1)
		  	     ELSE factorial := 1
                END; { factorial }


	      FUNCTION log2(CONSTS a : REAL8) : REAL8;
	        BEGIN
		  log2 := Lndrqq(a) / Lndrqq(2.0)
		END; { log2 }



          BEGIN { factor }
            IF ((ch >= '0') AND (ch <= '9')) OR (ch = '.') THEN
              BEGIN start := pos;
	      	    REPEAT nextCh UNTIL (ch < '0') OR (ch > '9'); 
		    IF ch = '.' THEN
		      REPEAT nextCh UNTIL (ch < '0') OR (ch > '9');
		    IF (ch='E') OR (ch='e') THEN
		      BEGIN nextCh;
		  	    REPEAT nextCh UNTIL (ch < '0') OR (ch > '9')
		      END;
		    strToNum(formula,start,pos-start,f,errPos)
              END
	    ELSE IF ch='(' THEN
              BEGIN nextCh;
	      	    f := expression;
		    IF ch=')' THEN nextCh
		    	      ELSE errPos := pos
              END
	    ELSE
              BEGIN { parse builtin function }
                found := false;
                FOR fn := Lower(fn) TO Upper(fn) DO
                IF NOT found THEN
                BEGIN { check this function name }
                  l := Ord(builtinNames[fn].Len);
		  IF thisFn(formula,pos,fn) THEN
                    BEGIN { call builtin }
                      pos := pos + l - 1;
		      nextCh;
                      f := factor;
                      CASE fn OF
                        fabs:     f:=Abs(f);
			fround:   f:=Andrqq(f);
                        ftrunc:   f:=Aidrqq(f);
			fsqrt:    f:=Srdrqq(f);
                        fsqr:     f:=f*f;
                        fsin:     f:=Sndrqq(f);
                        fcos:     f:=Cndrqq(f);
                        ftan:     f:=Tndrqq(f);
                        farcsin:  f:=Asdrqq(f);
                        farccos:  f:=Acdrqq(f);
                        farctan:  f:=Atdrqq(f);
                        fsinh :   f:=Shdrqq(f);
                        fcosh :   f:=Chdrqq(f);
                        ftanh :   f:=Thdrqq(f);
                        fln :     f:=Lndrqq(f);
                        flog:     f:=Lddrqq(f);
			flog2:    f:=log2(f);
                        fexp:     f:=Exdrqq(f);
                        ffact:    f:=factorial(f);
                      END; { CASE }
                      found := TRUE;
                    END; { call builtin }
                END; { check this function name }
                IF NOT found THEN errPos := pos;
              END; { parse builtin function }
              factor := f
          END; { factor }

        BEGIN { signedFactor }
	  WHILE ch = ' ' DO nextCh;
          IF ch = '-' THEN BEGIN nextCh;
	  			 signedFactor := -factor
			   END
          ELSE IF ch = '+' THEN BEGIN nextCh;
	  			      signedFactor := factor
			   END
	  ELSE signedFactor := factor
        END; { signedFactor }

      BEGIN { term }
        t := signedFactor;
        WHILE (ch = '^') AND (errPos = 0) DO
          BEGIN nextCh;
	  	t2 := signedFactor;
		{ check if t2 is integer by rounding }
		IF t2 = Andrqq(t2) THEN t := Pidrqq(t,Round4(t2))
				   ELSE t := Prdrqq(t,t2)
          END;
        term := t
      END; { term }

    BEGIN { simpleExpression }
      s := term;
      WHILE ((ch = '*') OR (ch = '/') OR (ch = '\') OR (ch = 'm'))
            AND (errPos = 0) DO
        IF ch = '/' THEN BEGIN nextCh;
			       s := s / term
			 END
        ELSE IF ch = '*' THEN BEGIN nextCh;
				    s := s * term
			      END
        ELSE IF ch = '\' THEN BEGIN nextCh;
				    s := Mddrqq(s,(term))
			      END
        ELSE IF ch = 'm' THEN
	  BEGIN nextCh;
		IF ch = 'i'
		  THEN BEGIN nextCh;
		  	     IF ch = 'n' THEN BEGIN nextCh;
			     			    s := Mndrqq(s,(term))
					      END
			     	         ELSE errPos := pos
		       END
		ELSE IF ch = 'a'
		  THEN BEGIN nextCh;
		  	     IF ch = 'x' THEN BEGIN nextCh;
			     			    s := Mxdrqq(s,(term))
					      END
			     	         ELSE errPos := pos
		       END
		ELSE errPos := pos
	  END;
      simpleExpression := s
    END; { simpleExpression }

  BEGIN { expression }
    e := simpleExpression;
    WHILE ((ch = '+') OR (ch = '-')) AND (errPos = 0) DO
      IF ch = '-' THEN BEGIN nextCh;
			     e := e - simpleExpression
		       END
                  ELSE BEGIN nextCh;
			     e := e + simpleExpression
		       END;
    expression := e
  END; { expression }


BEGIN { evaluate }
  { first lower case the string }
  FOR pos:=1 TO Ord(formula.Len) DO
    IF (formula[pos] >= 'A') AND (formula[pos] <= 'Z') THEN
      formula[pos] := Chr(Ord(formula[pos]) + Ord('a') - Ord('A'));

  pos := 0;
  errPos := 0;
  nextCh;
  exprVl := expression;
  IF ch <> Chr(0) THEN errPos := pos
END; { evaluate }



BEGIN { main }
  cmdTail.S := Cesxqq;
  cmdTail.R := 128;
  IF cmdTail^.Len = 0 THEN
    BEGIN Writeln(output,
    	    'Infix expressions using:  +  -  *  /  \  ^  (  )  max  min');
    	  Writeln(output,' unary prefix operators:  +  -  abs  round  trunc',
	  		 '  sqrt  sqr  sin  cos  tan');
	  Writeln(output,'                          arcsin  arccos  arctan',
	  		 '  sinh  cosh  tanh');
	  Writeln(output,'                          ln  log  log2  exp',
	  		 '  fact');
    END
  ELSE IF cmdTail^ = ' who' THEN
    Writeln(output,'adapted from Turbo Pascal spreadsheet, Bruce K. Hillyer')
  ELSE
    BEGIN evaluate(cmdTail^,retnVl,errLoc);
     	  IF errLoc > 0
	    THEN BEGIN Write(output,'      ');  { pass the 'C>eval' }
	      	       FOR i:=1 TO errLoc-1 DO
			 Write(output,' ');
		       Writeln(output,'^----- error')
	      	 END
	    ELSE printNum(retnVl)
    END
END.

.