DataMuseum.dk

top - download

    Length: 4352 (0x1100)
    Types: TextFile
    Names: »CALC.PAS«

└─⟦8e533ec5a⟧ Bits:30004189 COMPAS Pascal v3.02 til CR7
    └─ ⟦this⟧ »CALC.PAS« 

TextFile

PROGRAM CALCULATOR; (*$R-*)

(* This program acts like a calculator - You type an expression	*)
(* and the program calculates its value. Each time the calcula-	*)
(* tor is ready to accept an input line, it prints an asterisk.	*)
(* You must then type the expression and end it by pressing the	*)
(* RETURN key, and shortly after, the result is displayed. If	*)
(* the calculator finds an error, it displays a pointer, which	*)
(* points at the error. There are five different operators (^,	*)
(* *, /, +, and -), and seven standard functions (ABS, SQRT,	*)
(* SIN, COS, ARCTAN, LN, and EXP). Parentheses within expres-	*)
(* sions are allowed. A special variable, called X, always	*)
(* holds the value of the last computation. To end the program,	*)
(* type QUIT when the calculator prompts for an input line.	*)

CONST
  STRLEN = 48;
TYPE
  STR = STRINGÆSTRLENÅ;
VAR
  E: INTEGER;
  R: REAL;
  S: STR;

PROCEDURE EVALUATE(VAR EXPR: STR; VAR VALUE: REAL; VAR ERRPOS: INTEGER);
CONST
  ERRCH = '?';
  EOFLINE = @13;
VAR
  POS: INTEGER;
  CH: CHAR;

PROCEDURE NEXTCHAR;
BEGIN
  REPEAT
    POS:=POS+1;
    IF POS<=LEN(EXPR) THEN
    CH:=EXPRÆPOSÅ ELSE
    CH:=EOFLINE;
  UNTIL CH<>' ';
END;

FUNCTION EXPRESSION: REAL;
VAR
  E: REAL;
  OPR: CHAR;

FUNCTION SIMEXPR: REAL;
VAR
  S: REAL;
  OPR: CHAR;

FUNCTION TERM: REAL;
VAR
  T: REAL;

FUNCTION SIGNEDFACTOR: REAL;

FUNCTION FACTOR: REAL;
TYPE
  STDF = (FABS,FSQRT,FSIN,FCOS,FARCTAN,FLN,FEXP);
  STDFLIST = ARRAYÆSTDFÅ OF STRINGÆ6Å;
CONST
  STDFUN: STDFLIST = ('ABS','SQRT','SIN','COS','ARCTAN','LN','EXP');
VAR
  E,EE,L: INTEGER;
  DECPOINT,NEGEXP,FOUND: BOOLEAN;
  F: REAL;
  SF: STDF;
BEGIN
  IF CH IN Æ'0'..'9'Å THEN
  BEGIN
    F:=0.0; E:=0; DECPOINT:=FALSE;
    REPEAT
      F:=F*10.0+(ORD(CH)-48);
      IF DECPOINT THEN E:=E-1;
      NEXTCHAR;
      IF (CH='.') AND NOT DECPOINT THEN
      BEGIN
	DECPOINT:=TRUE; NEXTCHAR;
      END;
    UNTIL NOT(CH IN Æ'0'..'9'Å);
    IF CH='E' THEN
    BEGIN
      EE:=0; NEXTCHAR;
      IF CH IN Æ'+','-'Å THEN
      BEGIN
	NEGEXP:=CH='-'; NEXTCHAR;
      END ELSE
      NEGEXP:=FALSE;
      WHILE CH IN Æ'0'..'9'Å DO
      BEGIN
        EE:=EE*10+ORD(CH)-48;
	NEXTCHAR;
      END;
      IF NEGEXP THEN E:=E-EE ELSE E:=E+EE;
    END;
    F:=F*PWRTEN(E);
  END ELSE
  IF CH='(' THEN
  BEGIN
    NEXTCHAR;
    F:=EXPRESSION;
    IF CH=')' THEN NEXTCHAR ELSE CH:=ERRCH;
  END ELSE
  IF CH='X' THEN
  BEGIN
    NEXTCHAR; F:=VALUE;
  END ELSE
  BEGIN
    FOUND:=FALSE;
    FOR SF:=FABS TO FEXP DO
    IF NOT FOUND THEN
    BEGIN
      L:=LEN(STDFUNÆSFÅ);
      IF COPY(EXPR,POS,L)=STDFUNÆSFÅ THEN
      BEGIN
	POS:=POS+L-1; NEXTCHAR;
	F:=FACTOR;
	CASE SF OF
	  FABS: F:=ABS(F);
	  FSQRT: F:=SQRT(F);
	  FSIN: F:=SIN(F);
	  FCOS: F:=COS(F);
	  FARCTAN: F:=ARCTAN(F);
	  FLN: F:=LN(F);
	  FEXP: F:=EXP(F);
	END;
	FOUND:=TRUE;
      END;
    END;
    IF NOT FOUND THEN CH:=ERRCH;
  END;
  FACTOR:=F;
END (*FACTOR*);

BEGIN (*SIGNEDFACTOR*)
  IF CH='-' THEN
  BEGIN
    NEXTCHAR; SIGNEDFACTOR:=-FACTOR;
  END ELSE
  SIGNEDFACTOR:=FACTOR;
END (*SIGNEDFACTOR*);

BEGIN (*TERM*)
  T:=SIGNEDFACTOR;
  WHILE CH='^' DO
  BEGIN
    NEXTCHAR; T:=EXP(LN(T)*SIGNEDFACTOR);
  END;
  TERM:=T;
END (*TERM*);

BEGIN (*SIMEXPR*)
  S:=TERM;
  WHILE CH IN Æ'*','/'Å DO
  BEGIN
    OPR:=CH; NEXTCHAR;
    CASE OPR OF
      '*': S:=S*TERM;
      '/': S:=S/TERM;
    END;
  END;
  SIMEXPR:=S;
END (*SIMEXPR*);

BEGIN (*EXPRESSION*)
  E:=SIMEXPR;
  WHILE CH IN Æ'+','-'Å DO
  BEGIN
    OPR:=CH; NEXTCHAR;
    CASE OPR OF
      '+': E:=E+SIMEXPR;
      '-': E:=E-SIMEXPR;
    END;
  END;
  EXPRESSION:=E;
END (*EXPRESSION*);

BEGIN (*EVALUATE*)
  POS:=0; NEXTCHAR;
  VALUE:=EXPRESSION;
  IF CH=EOFLINE THEN ERRPOS:=0 ELSE ERRPOS:=POS;
END (*EVALUATE*);

BEGIN (*CALCULATOR*)
  REPEAT
    WRITE('* '); BUFLEN:=STRLEN; READ(S);
    IF (S<>'') AND (S<>'QUIT') THEN
    BEGIN
      EVALUATE(S,R,E);
      IF E=0 THEN
      BEGIN
	WRITE(' =');
	IF R>=0.0 THEN WRITE(R:17) ELSE WRITE(R:18);
      END ELSE
      BEGIN
	WRITELN;
	WRITE('^ ERROR':E+8);
      END;
    END;
    WRITELN;
  UNTIL S='QUIT';
END (*CALCULATOR*).
«eof»