(**********************************************************
*
*		CALCULATOR PROGRAM
*
*	I gave this a quick check and it works.  It looks 
*  like it has some extra things that I didn't check out so
*  if someone does and would be so kind to send me a DOC, I
*  will republish it.  Not everyone who Modified this pro-
*  gram left their name but for those who did I left in.
*
*  Donated July, 1980
*
************************************************************)

PROGRAM CALCULATOR;(*WRITTEN BY DALE ANDER JULY 8, 1977
                      MODIFIED JULY 17, 1977*)

LABEL 999; (*PROGRAM EXIT POINT*)
CONST IDLENGTH = 8;{---19/6/80---}
      TABLESIZE = 35;  (*TABLESIZE IS MEMORYSIZE*)
      IDBLANKS = '        '; {---8 blanks---}
      LASTX = 'LASTX   ';

TYPE  TOKENKINDS = (CONSTV, EOFV, FUCIDENV, LINEV, LPARENV, MINUSV, PLUSV,
                     RPARENV, SLASHV, STARV, UNRECIDV, UNRECSYMV, UPARROWV,
                     VARIDENV, EQUALV,  LASTXV);
	idkind = packed array[1..idlength] of char;
(*---IDKIND = PACKED ARRAY[0..IDLENGTH] OF CHAR;---*)

	$STRING0 = STRING 0;
	$STRING255 = STRING 255;
	STRING80   = STRING 80; (*---80 IS THE DEFAULT LENGTH---*)

VAR
  CH		: CHAR;
  J,
  TOTALIDS,
  INDEX		: INTEGER;
  OPERATORS,
  ALPHA,
  NUMERIC	: SET OF CHAR;
  NUM,
  ANSWER	: REAL;
  SOURCE	: STRING80; (*---PASCAL/Z---*)
  TOKENTYPE	: TOKENKINDS;
  NAMETABLE	: ARRAY[0..TABLESIZE] OF
				RECORD
				  NAME: IDKIND;
				  CASE ISVAR: BOOLEAN OF
				    TRUE: (VALUE: REAL)
				END;
  TEMP		: REAL;
  ITSOK,
  GAVEERR	: BOOLEAN;

FUNCTION LENGTH(X: $STRING255): INTEGER; EXTERNAL;
PROCEDURE SETLENGTH(VAR X: $STRING0; Y: INTEGER); EXTERNAL;

PROCEDURE GETCHAR;
BEGIN
  J:=J+1;  (*J IS INDEX INTO SOURCE*)
  IF J<=LENGTH(SOURCE) THEN
    CH:=SOURCE[J]
  ELSE
    CH:='#';  (*EOF SOURCE CHAR*)
  IF (CH>='a') AND (CH<='z') THEN
    CH := CHR(ORD(CH)-32) (*CHANGE TO UPPER CASE*)
END (*OF GETCHAR*);

PROCEDURE SCANNER;
VAR DONTEAT: BOOLEAN;

PROCEDURE GETCONSTANT;
  (*Real number scanner	RJH 9 July 77*)
VAR WHOLEPART:  REAL;
    DODECIMAL:  BOOLEAN;

  FUNCTION NUMBER (FRACTION: BOOLEAN): REAL;
  (*Returns number as whole or fraction*)
  VAR SUM, COUNT: REAL;
  BEGIN
    COUNT:=1;
    SUM:=0;
    REPEAT
      IF SUM < 0.9E37 (*MAXREAL*) THEN
	BEGIN
	  SUM := 10*SUM + ORD(CH) - ORD('0');
	  COUNT:=10*COUNT
	END;
      GETCHAR
    UNTIL NOT (CH IN NUMERIC);
    IF FRACTION THEN
       NUMBER:=SUM/COUNT
    ELSE
       NUMBER:=SUM
  END (*NUMBER*);

BEGIN (*GETCONSTANT*)
  TOKENTYPE:=CONSTV;
  IF CH <> '.' THEN
    BEGIN
      WHOLEPART:=NUMBER(FALSE);
      IF CH='.' THEN GETCHAR;
      DODECIMAL:=(CH IN NUMERIC);
    END
  ELSE
    BEGIN
      WHOLEPART:=0;
      GETCHAR;
      DODECIMAL:=(CH IN NUMERIC);
      IF NOT DODECIMAL THEN TOKENTYPE:=UNRECSYMV
    END;
  IF DODECIMAL THEN
     NUM:=WHOLEPART + NUMBER(TRUE)
  ELSE
     NUM:=WHOLEPART;
  DONTEAT:=CH<>' '; (*DONT EAT NEXT IF CH IS NONBLANK  DA 7/11/77*)
END (*OF GETCONSTANT*);

PROCEDURE GETID;
VAR ID: IDKIND;
    I: INTEGER;

  FUNCTION LOOKUP(IDTEXT: IDKIND):INTEGER;
  VAR I: INTEGER;

  BEGIN
    I:=TOTALIDS;
    NAMETABLE[0].NAME:=IDTEXT;(*DON'T CHANGE--THIS IS USED
                                 INSIDE OF PRIMARY!!*)
    WHILE NAMETABLE[I].NAME<>IDTEXT DO  I:=I-1;
    LOOKUP:=I
  END (*OF LOOKUP*);

BEGIN (*GETID*)
  ID:=IDBLANKS;
  I:=1;{---start at position #1 NOT position #0---}
  REPEAT
    IF I<=IDLENGTH THEN ID[I]:=CH;
    I:=I+1;
    GETCHAR
  UNTIL NOT(CH IN ['A'..'Z','0'..'9']);
  DONTEAT:=CH<>' '; (*DONT GET NEXT IF CH IS NONBLANK*)
  IF ID=LASTX THEN
    TOKENTYPE:=LASTXV
  ELSE
    BEGIN
      INDEX:=LOOKUP(ID);
      IF INDEX>0 THEN
        IF NAMETABLE[INDEX].ISVAR THEN
	   TOKENTYPE:=VARIDENV
        ELSE
	   TOKENTYPE:=FUCIDENV
      ELSE
	TOKENTYPE:=UNRECIDV
    END
END (*OF GETID*);

BEGIN (*SCANNER*)
  DONTEAT:=FALSE;
  IF CH IN ALPHA THEN GETID
  ELSE
    IF CH IN NUMERIC+['.'] THEN GETCONSTANT
    ELSE
      IF CH IN OPERATORS THEN
        CASE CH OF
	  '+': TOKENTYPE:=PLUSV;
	  '-': TOKENTYPE:=MINUSV;
	  '*': TOKENTYPE:=STARV;
	  '/': TOKENTYPE:=SLASHV;
	  '\': TOKENTYPE:=LINEV;
	  '^': TOKENTYPE:=UPARROWV;
	  '(': TOKENTYPE:=LPARENV;
	  ')': TOKENTYPE:=RPARENV;
	  '=': TOKENTYPE:=EQUALV;
	  '#': BEGIN TOKENTYPE:=EOFV; DONTEAT:=TRUE END
        END
      ELSE TOKENTYPE:=UNRECSYMV;
  IF NOT DONTEAT THEN REPEAT GETCHAR UNTIL CH<>' ' (*GETNONBLANK*)
END (*OF SCANNER*);

FUNCTION EXPRESS(VAR ANS: REAL): BOOLEAN ;
VAR OK, CHANGESIGN: BOOLEAN;
    RSLT1, RSLT2: REAL;
    SAVEOP: TOKENKIND;

FUNCTION TERM(VAR ANS: REAL): BOOLEAN ;
VAR OK: BOOLEAN;
    SAVEOP: TOKENKIND;
    RSLT1, RSLT2: REAL;

FUNCTION FACTOR(VAR ANS: REAL): BOOLEAN ;
VAR OK: BOOLEAN;
    RSLT1, RSLT2: REAL;

FUNCTION PRIMARY(VAR ANS: REAL): BOOLEAN ;
(*REWRITTEN BY RJH 12 JULY 77
   REREWRITTEN BY DA 7/14/77*)
VAR  FUCNUM, SAVEINDEX: INTEGER;
     SAVEID: IDKIND;
     SAVETOK: TOKENKINDS;

FUNCTION PARENEXPRESSION(VAR ANS: REAL): BOOLEAN ;
BEGIN
  PARENEXPRESSION:=FALSE;
  IF TOKENTYPE=LPARENV THEN
    BEGIN
      SCANNER;
      IF EXPRESS(ANS) THEN
        IF TOKENTYPE=RPARENV THEN
	  BEGIN SCANNER; PARENEXPRESSION:=TRUE END
        ELSE
          IF TOKENTYPE<>EOFV THEN
            BEGIN GAVEERR:=TRUE; WRITE ('")"  missing') END
    END
  ELSE
    IF TOKENTYPE IN [UNRECIDV, UNRECSYMV] THEN
      BEGIN GAVEERR:=TRUE; WRITE ('Illegal symbol') END
    ELSE
      IF TOKENTYPE<>EOFV THEN
        BEGIN GAVEERR:=TRUE; WRITE ('"(" missing') END
END (*OF PARENEXPRESSION*);

FUNCTION EVALU8 (VAR ANS: REAL): BOOLEAN;
VAR ARG, TEMP: REAL;
    I: INTEGER;

	Function LOG(x:real):real;
	{ Returns the LOG to base 10 }
	begin
	  LOG := LN(10) / LN(x)
	end;

BEGIN
  EVALU8:=TRUE;
  IF PARENEXPRESSION (ARG) THEN
    CASE FUCNUM OF
      1: ANS:=SIN(ARG);
      2: ANS:=COS(ARG);
      3: IF COS(ARG)=0 THEN
	    BEGIN WRITE('Undefined TAN'); GAVEERR:=TRUE END
	 ELSE
	    ANS:=SIN(ARG)/COS(ARG);
      4: IF ARG<=0 THEN
	    BEGIN WRITE('Undefined LOG'); GAVEERR:=TRUE END
	 ELSE
	    ANS:=LOG(ARG);
      5: IF ARG<=0 THEN
	    BEGIN WRITE('Undefined LN'); GAVEERR:=TRUE END
	 ELSE
	    ANS:=LN(ARG);
      6: ANS:=ABS(ARG);
      7: IF ARG<0 THEN
	    BEGIN WRITE('Undefined SQRT'); GAVEERR:=TRUE END
	 ELSE
	    ANS:=SQRT(ARG);
      10: IF (ROUND(ARG)>33) OR (ROUND(ARG)<0) THEN
            BEGIN
	      WRITE('Cannot calculate factorial GTR 33');
	      GAVEERR:=TRUE
	    END
          ELSE
            BEGIN
              TEMP:=1;
              FOR I:=2 TO ROUND(ARG) DO TEMP:=TEMP*I;
              ANS:=TEMP
            END
    END (*OF CASE*)
  ELSE EVALU8:=FALSE;
  IF GAVEERR THEN EVALU8:=FALSE
END (*OF EVALU8*);

BEGIN (*PRIMARY*)
  PRIMARY:=FALSE;
  IF TOKENTYPE=CONSTV THEN (*CONSTANT*)
    BEGIN
      ANS:=NUM; (*GLOBAL SET BY GETCONSTANT*)
      PRIMARY:=TRUE;
      SCANNER
    END
  ELSE
    IF TOKENTYPE IN [VARIDENV, UNRECIDV] THEN
      BEGIN
        SAVETOK:=TOKENTYPE;
        SAVEID:=NAMETABLE[0].NAME; (*PUT THERE BY LOOKUP IN GETID*)
        SAVEINDEX:=INDEX; (*GLOBAL SET IN GETID*)
        SCANNER;
        IF TOKENTYPE=EQUALV THEN  (*MEMORY ASSIGNMENT*)
          BEGIN
            SCANNER;
	    IF EXPRESS(ANS) THEN
	      BEGIN
		IF SAVETOK=UNRECIDV THEN
		  IF TOTALIDS+1<=TABLESIZE THEN
		    BEGIN
		      TOTALIDS:=TOTALIDS+1;
		      SAVEINDEX:=TOTALIDS;
		      WITH NAMETABLE[SAVEINDEX] DO
			BEGIN ISVAR:=TRUE; NAME:=SAVEID END
  		    END
                  ELSE
                    BEGIN WRITE('Table full. Not done'); GAVEERR:=TRUE END;
		IF SAVEINDEX<>0 THEN
		  BEGIN NAMETABLE[SAVEINDEX].VALUE:=ANS; PRIMARY:=TRUE END
	      END
	  END
	ELSE
          IF SAVETOK=UNRECIDV THEN
            BEGIN WRITE('Unrecognized ID'); GAVEERR:=TRUE END
	  ELSE
            BEGIN PRIMARY:=TRUE; ANS:=NAMETABLE[SAVEINDEX].VALUE END
      END
    ELSE
      IF TOKENTYPE=FUCIDENV THEN (*FUNCTION*)
	BEGIN
	  FUCNUM:=INDEX; (*INDEX SET BY GETIDENT*)
	  SCANNER;
	  PRIMARY:=EVALU8 (ANS)
	END
      ELSE
        IF TOKENTYPE=LASTXV THEN
 	  BEGIN SCANNER; ANS:=ANSWER; PRIMARY:=TRUE END
        ELSE PRIMARY:=PARENEXPRESSION (ANS)
END (*OF PRIMARY*);

BEGIN (*FACTOR*)
  OK:=TRUE;
  IF PRIMARY(RSLT1) THEN
    WHILE OK AND (TOKENTYPE=UPARROWV) DO
      BEGIN
	SCANNER;
	IF PRIMARY(RSLT2) THEN
          IF RSLT1<=0 THEN
            BEGIN
	      WRITE('Cannot calculate power');
	      OK:=FALSE;
	      GAVEERR:=TRUE
	    END
          ELSE
	    RSLT1:=EXP(RSLT2*LN(RSLT1))
	ELSE
	  OK:=FALSE
      END
  ELSE
    OK:=FALSE;
  IF OK THEN ANS:=RSLT1;
  FACTOR:=OK
END (*OF FACTOR*);

BEGIN (*TERM*)
  OK:=TRUE;
  IF FACTOR(RSLT1) THEN
    WHILE OK AND (TOKENTYPE IN [STARV, SLASHV, LINEV]) DO
      BEGIN
        SAVEOP:=TOKENTYPE;
	SCANNER;
	IF FACTOR(RSLT2) THEN
	  CASE SAVEOP OF
	    STARV:	 RSLT1:=RSLT1*RSLT2;
	    SLASHV:	 IF RSLT2=0 THEN
			   BEGIN
			     OK:=FALSE;
			    GAVEERR:=TRUE;
			    WRITE('Division by zero')
			  END
			ELSE RSLT1:=RSLT1/RSLT2;
	    LINEV:	IF ROUND(RSLT2)=0 THEN
			  BEGIN
			    OK:=FALSE;
			    GAVEERR:=TRUE;
			    WRITE('MOD by zero')
			  END
			ELSE
		          RSLT1:=ROUND(RSLT1) MOD ROUND(RSLT2)
	  END (*CASE*)
	ELSE OK:=FALSE
      END
  ELSE OK:=FALSE;
  IF OK THEN ANS:=RSLT1;
  TERM:=OK
END (*TERM*);


BEGIN (*EXPRESS*)
  OK:=TRUE;
  IF TOKENTYPE IN [PLUSV,MINUSV] THEN
    BEGIN CHANGESIGN:=(TOKENTYPE=MINUSV); SCANNER END
  ELSE CHANGESIGN:=FALSE;
  IF TERM(RSLT1) THEN
    BEGIN
      IF CHANGESIGN THEN RSLT1:=-RSLT1;
      WHILE OK AND (TOKENTYPE IN [PLUSV,MINUSV]) DO
        BEGIN
          SAVEOP:=TOKENTYPE;
          SCANNER;
  	  IF TERM(RSLT2) THEN
  	    CASE SAVEOP OF
  	      PLUSV:	RSLT1:=RSLT1+RSLT2;
  	      MINUSV:	RSLT1:=RSLT1-RSLT2
  	    END
  	  ELSE OK:=FALSE
        END
    END
  ELSE OK:=FALSE;
  EXPRESS:=OK;
  IF OK THEN ANS:=RSLT1
END (*OF EXPRESS*);

PROCEDURE INITABLES;
BEGIN
  ALPHA:=['A'..'Z'];
  NUMERIC:=['0'..'9'];
  OPERATORS:=['+','=','*','-','/','\','^','(',')','#'];
  WITH NAMETABLE[1] DO
    BEGIN NAME:='SIN     '; ISVAR:=FALSE END;
  WITH NAMETABLE[2] DO
    BEGIN NAME:='COS     '; ISVAR:=FALSE END;
  WITH NAMETABLE[3] DO
    BEGIN NAME:='TAN     '; ISVAR:=FALSE END;
  WITH NAMETABLE[4] DO
    BEGIN NAME:='LOG     '; ISVAR:=FALSE END;
  WITH NAMETABLE[5] DO
    BEGIN NAME:='LN      '; ISVAR:=FALSE END;
  WITH NAMETABLE[6] DO
    BEGIN NAME:='ABS     '; ISVAR:=FALSE END;
  WITH NAMETABLE[7] DO
    BEGIN NAME:='SQRT    '; ISVAR:=FALSE END;
  WITH NAMETABLE[8] DO
    BEGIN NAME:='E       '; ISVAR:=TRUE; VALUE:=2.718282 END;
  WITH NAMETABLE[9] DO
    BEGIN NAME:='PI      '; ISVAR:=TRUE; VALUE:=3.141593 END;
  WITH NAMETABLE[10] DO
    BEGIN NAME:='FAC     '; ISVAR:=FALSE END;
  TOTALIDS:=10 (*BUILD IN NUMBER OF FUNCS & VARS*)
END (*INITABLES*);

BEGIN (*CALCULATOR*)
  ANSWER:=0;
  INITABLES;
  REPEAT
    SETLENGTH(SOURCE,0);{---PASCAL/Z---}
    GAVEERR:=FALSE;
    J:=0;
    WRITE('->');
    READLN(SOURCE);
    IF LENGTH(SOURCE)=0 THEN{EXIT(PROGRAM)}goto 999;
    REPEAT GETCHAR UNTIL CH<>' '; (*GETNONBLANK*)
    SCANNER;
    ITSOK:=EXPRESS(TEMP) AND (TOKENTYPE=EOFV);
    IF NOT ITSOK THEN
      BEGIN
	IF (TOKENTYPE=EOFV) AND NOT GAVEERR THEN
	  WRITE ('Unexpected end of expression')
        ELSE IF NOT GAVEERR THEN WRITE('Illegal Symbol');
        WRITELN(': Try Again')
      END
    ELSE
      BEGIN WRITELN('    ',TEMP); ANSWER:=TEMP END
  UNTIL FALSE;
999:{EXIT PROGRAM HERE}
END (*EXPRESSION*).

.