Arithmetic evaluation/Pascal

Works with: GNU Pascal version 20060325, based on gcc-3.4.4

Note: This code is completely standard pascal, checked with gpc --classic-pascal. It uses certain features of standard Pascal which are not implemented in all Pascal compilers (e.g. the code will not compile with Turbo/Borland Pascal or Free Pascal).

<lang pascal>program calculator(input, output);

type

NodeType = (binop, number, error);

pAstNode = ^tAstNode;
tAstNode = record
            case typ: NodeType of
             binop:
             (
               operation: char;
               first, second: pAstNode;
             );
             number:
              (value: integer);
             error:
              ();
           end;

function newBinOp(op: char; left: pAstNode): pAstNode;

var
 node: pAstNode;
begin
 new(node, binop);
 node^.operation := op;
 node^.first := left;
 node^.second := nil;
 newBinOp := node;
end;

procedure disposeTree(tree: pAstNode);

begin
 if tree^.typ = binop
  then
   begin
    if (tree^.first <> nil)
     then
      disposeTree(tree^.first);
    if (tree^.second <> nil)
     then
      disposeTree(tree^.second)
   end;
 dispose(tree);
end;

procedure skipWhitespace(var f: text);

var
 ch:char;
function isWhite: boolean;
 begin
  isWhite := false;
  if not eoln(f)
   then
    if f^ = ' '
     then
      isWhite := true
 end;
begin
 while isWhite do
  read(f, ch)
end;

function parseAddSub(var f: text): pAstNode; forward; function parseMulDiv(var f: text): pAstNode; forward; function parseValue(var f: text): pAstNode; forward;

function parseAddSub;

var
 node1, node2: pAstNode;
 continue: boolean;
begin
 node1 := parseMulDiv(f);
 if node1^.typ <> error
  then
   begin
    continue := true;
    while continue and not eoln(f) do
     begin
      skipWhitespace(f);
      if f^ in ['+', '-']
       then
        begin
         node1 := newBinop(f^, node1);
         get(f);
         node2 := parseMulDiv(f);
         if (node2^.typ = error)
          then
           begin
            disposeTree(node1);
            node1 := node2;
            continue := false
           end
          else
           node1^.second := node2
        end
       else
        continue := false
     end;
   end;
 parseAddSub := node1;
end;

function parseMulDiv;

var
 node1, node2: pAstNode;
 continue: boolean;
begin
 node1 := parseValue(f);
 if node1^.typ <> error
  then
   begin
    continue := true;
    while continue and not eoln(f) do
     begin
      skipWhitespace(f);
      if f^ in ['*', '/']
       then
        begin
         node1 := newBinop(f^, node1);
         get(f);
         node2 := parseValue(f);
         if (node2^.typ = error)
          then
           begin
            disposeTree(node1);
            node1 := node2;
            continue := false
           end
          else
           node1^.second := node2
        end
       else
        continue := false
     end;
   end;
 parseMulDiv := node1;
end;

function parseValue;

var
 node:  pAstNode;
 value: integer;
 neg:   boolean;
begin
 node := nil;
 skipWhitespace(f);
 if f^ = '('
  then
   begin
    get(f);
    node := parseAddSub(f);
    if node^.typ <> error
     then
      begin
       skipWhitespace(f);
       if f^ = ')'
        then
         get(f)
        else
         begin
          disposeTree(node);
          new(node, error)
         end
      end
   end
  else if f^ in ['0' .. '9', '+', '-']
   then
    begin
     neg := f^ = '-';
     if f^ in ['+', '-']
      then
       get(f);
     value := 0;
     if f^ in ['0' .. '9']
      then
       begin
        while f^ in ['0' .. '9'] do
         begin
          value := 10 * value + (ord(f^) - ord('0'));
          get(f)
         end;
        new(node, number);
        if (neg)
         then
          node^.value := -value
         else
          node^.value := value
       end
    end;
 if node = nil
  then
   new(node, error);
 parseValue := node
end;

function eval(ast: pAstNode): integer;

begin
 with ast^ do
  case typ of
   number: eval := value;
   binop:
    case operation of
     '+': eval := eval(first) + eval(second);
     '-': eval := eval(first) - eval(second);
     '*': eval := eval(first) * eval(second);
     '/': eval := eval(first) div eval(second);
    end;
   error:
    writeln('Oops! Program is buggy!')
  end
end;

procedure ReadEvalPrintLoop;

var
 ast: pAstNode;
begin
 while not eof do
  begin
   ast := parseAddSub(input);
   if (ast^.typ = error) or not eoln
    then
     writeln('Error in expression.')
    else
     writeln('Result: ', eval(ast));
   readln;
   disposeTree(ast)
  end
end;

begin

ReadEvalPrintLoop

end.</lang>