Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TICALC.ZIP/TICALC.PAS

Pascal/Delphi Source File | 1986-01-14 | 5.9 KB | 283 lines

(* This is a Texas Instruments style calculator.  It parses arithmetic
   expressions using the usual precedence rules.
   Written by Jonathan Amsterdam, December 1984.
*)

PROGRAM TICalc;


CONST
  endOfFile = 0;   (* special character signifying end of file *)
  empty     = 127; (* character used to indicate that savedChar is empty *)
  endOfLine = 13;  (* special character signifying end of line *)

TYPE
  nodetype = (binop, unop, number);
  node = ^noderec;
  noderec = RECORD
          CASE tag:nodetype OF
        binop: (operator:CHAR;
            leftOperand, rightOperand:node);
        unop: (uOperator:CHAR;
               operand:node);
        number:(num:INTEGER);
        END;

VAR
  savedChar: CHAR;
  digits: SET OF CHAR;

(* input functions *)

FUNCTION getChar:CHAR;
(* Useful low-level character input.  Returns special characters at
   end of file and end of line. *)
VAR c:CHAR;
BEGIN
  IF savedChar <> chr(empty) THEN BEGIN
    getChar := savedChar;
    savedChar := chr(empty);
  END ELSE IF EOF THEN
    getChar := chr(endOfFile)
  ELSE IF EOLN THEN BEGIN
    getChar := chr(endOfLine);
    readln;
  END ELSE BEGIN
    read(c);
    getChar := c;
  END;
END;


PROCEDURE ungetChar(c:CHAR);
(* Allows one character at a time to be pushed back on the input. *)
BEGIN
  IF savedChar = chr(empty) THEN
    savedChar := c
  ELSE
    writeln('ungetChar: can''t unget more than one character at a time');
END;


FUNCTION nextChar:CHAR;
(* Skips over blanks. *)
VAR c:CHAR;
BEGIN
  REPEAT
    c := getChar
  UNTIL c <> ' ';
  nextChar := c;
END;



FUNCTION charToInt(c:CHAR):INTEGER;
(* Converts a numeric character to an integer. *)
BEGIN
  IF NOT (c IN digits) THEN BEGIN
    writeln('charToInt: ', c, 'is not a digit');
    charToInt := 0;
  END ELSE
    charToInt := ord(c) - ord('0');
END;

FUNCTION getNum(c:CHAR):INTEGER;
(* Reads a number from the input.  The first digit of the number has
   already been read and is passed as an argument. *)
VAR n:INTEGER;
BEGIN
  n := 0;
  REPEAT
    n := 10*n + charToInt(c);
    c := getChar;
  UNTIL NOT (c IN digits);
  ungetChar(c);
  getNum := n;
END;


(* node creation functions *)
(* The following three functions create nodes for the parse tree.  The first
   two each return NIL if their node arguments are NIL. *)

FUNCTION binopNode(opor:CHAR; lopand, ropand:node):node;
VAR n: node;
BEGIN
  IF (lopand = NIL) OR (ropand = NIL) THEN
    binopNode := NIL
  ELSE BEGIN
    new(n, binop);
    WITH n^ DO BEGIN
      tag := binop;
      operator := opor;
      leftOperand := lopand;
      rightOperand := ropand;
    END;
    binopNode := n;
  END;
END;


FUNCTION unopNode(opor:CHAR; opand:node):node;
VAR n:node;
BEGIN
  IF opand = NIL THEN
    unopNode := NIL
  ELSE BEGIN
    new(n, unop);
    WITH n^ DO BEGIN
      tag := unop;
      uOperator := opor;
      operand := opand;
    end;
    unopNode := n;
  END;
END;

FUNCTION numberNode(i:INTEGER):node;
VAR n:node;
BEGIN
  new(n, number);
  WITH n^ DO BEGIN
    tag := number;
    num := i;
  END;
  numberNode := n;
END;


(* tree printing procedures *)

PROCEDURE ptree(n:node; depth:INTEGER);
BEGIN
  WITH n^ DO
    CASE tag OF
      binop: BEGIN
           ptree(leftOperand, depth+2);
           writeln(' ':depth,operator);
           ptree(rightOperand, depth+2);
         END;
      unop: BEGIN
          writeln(' ':depth,uoperator);
          ptree(operand, depth+2);
        END;
      number: writeln(' ':depth,num);
    END;
END;


PROCEDURE printTree(n:node);
BEGIN
  ptree(n, 0);
END;


(* parser *)
(* Each of the three parsing functions returns NIL if an error occurs
   in the parse. *)

FUNCTION term:node; FORWARD;

FUNCTION factor:node; FORWARD;

FUNCTION expr:node;
(* An expression is either a term, or a term +,- an expression. *)
VAR c:CHAR;
    n:node;
BEGIN
  n := term;
  expr := n;
  IF n <> NIL THEN BEGIN
    c := nextChar;
    IF (c = '+') OR (c = '-') THEN
      expr := binopNode(c, n, expr)
    ELSE IF c <> chr(endOfLine) THEN
      ungetChar(c);
  END;
END;


FUNCTION term(*:node*);
(* A term is either a factor, or a factor *,/ a term. *)
VAR c:CHAR;
    n:node;
BEGIN
  n := factor;
  term := n;
  IF n <> NIL THEN BEGIN
    C := nextChar;
    IF (c = '*') OR (c = '/') THEN
      term := binopNode(c, n, term)
    ELSE
      ungetChar(c);
  END;
END;

FUNCTION factor(*:node*);
(* A factor is either a number, or a - followed by a factor, or
   a parenthesized expression. *)
VAR c:CHAR;
BEGIN
  c := nextChar;
  IF c IN digits THEN
    factor := numberNode(getNum(c))
  ELSE IF c = '-' THEN
    factor := unopNode(c, factor)
  ELSE IF c = '(' THEN BEGIN
    factor := expr;
    IF nextChar <> ')' THEN
      writeln('close parenthesis expected');
  END ELSE BEGIN
    writeln('illegal expression');
    factor := NIL;
  END;
END;

FUNCTION eval(n:node):REAL;
(* Evaluates a parse tree. Assumes that the only binary operations are
   +, -, *, and / and that the only unary operation is -. *)
VAR op1, op2:REAL;
BEGIN
  WITH n^ DO
    CASE tag OF
      binop:
    BEGIN
      op1 := eval(leftOperand);
      op2 := eval(rightOperand);
      CASE operator OF
        '+': eval := op1 + op2;
        '-': eval := op1 - op2;
        '*': eval := op1 * op2;
        '/': eval := op1 / op2;
      END;
    END;
      unop: eval := -eval(operand);
      number: eval := num;
    END;
END;

PROCEDURE run;
VAR n:node;
    c:CHAR;
BEGIN
  REPEAT
    write('> ');
    n := expr;
    IF n <> NIL THEN BEGIN
      writeln;
      printTree(n);
      writeln;
      writeln(eval(n):0:2);
    END;
  UNTIL FALSE;
END;


BEGIN  (*** MAIN PROGRAM ***)
  writeln('TI style calculator');
  writeln('Enter an arithmetic expression and hit <RETURN>.');
  writeln('I will print a parse tree and evaluate the expression.');
  digits := ['0'..'9'];
  run;
END.