home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / calculat / calc224.lbr / CALC_P.IZC / CALC_P.INC
Text File  |  1987-07-19  |  4KB  |  162 lines
  1. function conv_post(expr : str; var post_expr : str) : boolean;
  2. type
  3.    op_ptr = ^op_rec;
  4.    op_rec = record
  5.                 op   : str;
  6.                 next : op_ptr;
  7.              end;
  8. var
  9.    i        : integer;
  10.    valid    : boolean;
  11.    token    : str;
  12.    last_tok : str;
  13.    top_tok  : str;
  14.    op_stack : op_ptr;
  15.    is_prec  : boolean;
  16.  
  17.  
  18. function empty(op_stack : op_ptr) : boolean;
  19. begin { function empty }
  20.    empty := op_stack = nil;
  21. end; { function empty }
  22.  
  23. function pop(var op_stack : op_ptr) : str;
  24. var
  25.    prev : op_ptr;
  26. begin { function pop }
  27.    if empty(op_stack) then
  28.       begin
  29.       pop := '';
  30.       writeln('Stack empty.');
  31.       end
  32.    else
  33.       begin
  34.       pop      := op_stack^.op;
  35.       prev     := op_stack;
  36.       op_stack := op_stack^.next;
  37.       dispose(prev);
  38.       end;
  39. end; { function pop }
  40.  
  41. procedure push(var op_stack : op_ptr; op : str);
  42. var
  43.    new_op : op_ptr;
  44. begin { procedure push }
  45.    new(new_op);
  46.    new_op^.op   := op;
  47.    new_op^.next := op_stack;
  48.    op_stack     := new_op;
  49. end; { procdure push }
  50.  
  51. function top(op_stack : op_ptr) : str;
  52. begin { function top }
  53.    if empty(op_stack) then
  54.       begin
  55.       top := '';
  56.       writeln('Stack empty.');
  57.       end
  58.    else
  59.       top := op_stack^.op;
  60. end; { function top }
  61.  
  62. function op_prec(op1, op2 : str) : boolean;
  63. var
  64.    val_op1, val_op2 : number;
  65.  
  66. function op_val(op : str) : integer;
  67. begin { function op_val }
  68.    if (op = '|') or (op = '^') then
  69.       op_val := 1
  70.    else if (op = '&') then
  71.       op_val := 2
  72.    else if (op = '+') or (op = '-') then
  73.       op_val := 3
  74.    else if (op = '*') or (op = '/') or (op = '%') then
  75.       op_val := 5
  76.    else if (op = '**') then
  77.       op_val := 7
  78.    else if (op = '~') then
  79.       op_val := 8
  80.    else if (op = '!') then
  81.       op_val := 9
  82.    else
  83.       op_val := 0;
  84. end; { function op_val }
  85.  
  86. begin { function op_prec }
  87.    if (op1 = '(') and (op2 = ')') then
  88.       op_prec := false
  89.    else if op2 = ')' then
  90.       op_prec := true
  91.    else if op2 = '(' then
  92.       op_prec := false
  93.    else if (op1 = '~') and (op2 = '~') then
  94.       op_prec := false
  95.    else
  96.       op_prec := op_val(op1) >= op_val(op2);
  97. end; { function op_prec }
  98.  
  99. procedure put_stack(stack : op_ptr);
  100. begin { procedure put_stack }
  101.    writeln('stack:');
  102.    while stack <> nil do
  103.       begin
  104.       writeln('  ', stack^.op);
  105.       stack  := stack^.next;
  106.       end;
  107.    writeln;
  108. end;{ procedure put_stack }
  109.  
  110. begin { functioon conv_post }
  111.    valid     := true;
  112.    op_stack  := nil;
  113.    post_expr := '';
  114.    top_tok   := '';
  115.    last_tok  := '(';
  116.    while get_token(expr, token) and valid do
  117.       begin
  118.       if is_num(token) then
  119.          post_expr := post_expr + token + ' '
  120.       else if is_op(token) then
  121.          begin
  122.          if (token = '-') and (is_op(last_tok)
  123.                           and not (last_tok[1] in [')', '!'])) then
  124.             token := '~';
  125.          is_prec := true;
  126.          while not empty(op_stack) and is_prec do
  127.             begin
  128.             top_tok := top(op_stack);
  129.             is_prec := op_prec(top_tok, token);
  130.             if is_prec and (top_tok <> '(') then
  131.                post_expr := post_expr + pop(op_stack) + ' '
  132.             else if (top_tok = '(') and (token = ')')then
  133.                voids := pop(op_stack)
  134.             end;
  135.          if token <> ')' then
  136.             push(op_stack, token)
  137.          else if top_tok <> '(' then
  138.             begin
  139.             writeln('Missing open parenthesis.');
  140.             valid := false;
  141.             end;
  142.          end
  143.       else
  144.          begin
  145.          writeln('Invalid token ''', token, '''.');
  146.          valid := false;
  147.          end;
  148.       last_tok := token;
  149.       end;
  150.    while valid and not empty(op_stack) do
  151.       if (top(op_stack) <> '(') then
  152.          post_expr := post_expr + pop(op_stack) + ' '
  153.       else
  154.          begin
  155.          writeln('Missing close parenthesis.');
  156.          valid := false;
  157.          end;
  158.    conv_post := valid;
  159. end; { procedure conv_post }
  160.  
  161. = true
  162.    else i