Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/CALC.ZIP/CALC.PAS

Pascal/Delphi Source File | 1985-12-28 | 11.6 KB | 462 lines

(**********************************************************
*
*        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*).