home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 January / Chip_1999-01_cd.bin / zkuste / delphi / D1 / COOLCALC.ZIP / INFIX.PAS < prev    next >
Pascal/Delphi Source File  |  1995-08-23  |  48KB  |  1,417 lines
  1. Unit Infix;
  2.  
  3. { ------------------------------------------------------------------------
  4.   INFIX.PAS
  5.   ------------------------------------------------------------------------
  6.  
  7.     This unit uses recursive descent to evaluate expressions
  8.     written in infix notation.  The operations addition (+),
  9.     subtraction (-), multiplication (*), and division (/) are supported,
  10.     as are the functions ABS, ARCTAN, COS, EXP, LN, SQR, and SQRT.
  11.     PI returns the value for pi.  Results exceeding 1.0E37 are reported
  12.     as overflows.  Results less than 1.0E-37 are set to zero.
  13.  
  14.          Written by:
  15.  
  16.          James L. Dean
  17.          406 40th Street
  18.          New Orleans, LA 70124
  19.          February 25, 1985
  20.  
  21.          Modified by:
  22.  
  23.          David J. Firth
  24.          5665-A2 Parkville St.
  25.          Columbus, OH 43229
  26.          December 26, 1991
  27.  
  28.      This code was originally written as a stand-alone program using
  29.      standard Pascal.  In that form the program wasn't very useful.
  30.      I have taken the code and reorganized it for use with Turbo Pascal
  31.      versions 5.x or 6.0.  In addition, I have reworked it to support
  32.      variables by adding a preprocessor.  The variables are preceded and
  33.      followed by a @ symbol, are case sensitive, and must be less than
  34.      20 characters long (including the 2 @s). For example, the
  35.      following would all be valid variables:
  36.  
  37.      @VARIABLE1@      @Pressure3@      @AngleOfAttack@
  38.  
  39.      Variable identifiers are passed around as strings.
  40.  
  41.      Calculation results may either be stored in variables or returned
  42.      raw to the caller.  Raw calculations may not contain variables,
  43.      since the raw procedure calls are sent directly to the original
  44.      code.
  45.  
  46.      As a final note, the original code is virtually unreadable due
  47.      to the original author's lack of any comments.  I have attempted
  48.      to provide a front end to this code that is useful and understandable.
  49.  
  50.      Your comments are welcome (and desired!). My E-Mail addresses
  51.      are:
  52.  
  53.      GEnie:     D.FIRTH
  54.      CIS:       76467,1734
  55. }
  56.  
  57. Interface
  58.  
  59. type
  60.     real = extended;     { dfn 8/22/95: Typing Real as Extended is a quick and dirty
  61.                            way of increasing the precision which this evaluation engine 
  62.                      calculates the results of expressions. Real which is
  63.                      less precise than Extended may have been the only type
  64.                      available when the program was originally written in 1985,
  65.                      I can't say that for sure as my experience doesn't go back 
  66.                      quite that far. }
  67.  
  68.   Str20 = string[20];                 {store variable IDs this way to conserve}
  69.  
  70.   VariablePtr = ^VariableType;        {for dynamic allocation of records }
  71.  
  72.   VariableType = record
  73.     ID    : Str20;                    {the id of the variable, with @s   }
  74.     Value : real;                     {the current value of the variable }
  75.     Next  : VariablePtr;              {hook to next record in linked list}
  76.   end; {VariableType}
  77.  
  78. var
  79.  
  80.   HPtr,                               {head of variable list       }
  81.   TPtr,                               {tail of variable list       }
  82.   SPtr  : VariablePtr;                {used to search variable list}
  83.  
  84.   CalcError : integer;                {the position of the error   }
  85.  
  86. procedure StoreVariable(VariableID:str20;MyValue:real);
  87. procedure ReadVariable(VariableID:str20;var MyValue:real;var MyError:boolean);
  88. procedure DestroyList;
  89.  
  90. procedure RawCalculate(MyFormula:string;var MyResult:real;var MyError:byte);
  91. procedure Calculate(MyFormula:string;var MyResult:real;var MyError:byte);
  92. procedure CalcAndStore(MyFormula:string;StoreID:str20;var MyError:byte);
  93.  
  94. Implementation
  95.  
  96. { ------------------------------------------------------------------------ }
  97.  
  98.   TYPE
  99.  
  100.     argument_record_ptr = ^argument_record;
  101.  
  102.     argument_record = RECORD
  103.                         value : REAL;
  104.                         next_ptr : argument_record_ptr
  105.                       END;
  106.  
  107.     string_1 = STRING[1];
  108.  
  109.     string_255 = STRING[255];
  110.  
  111.   VAR
  112.  
  113.     error_detected              : BOOLEAN;
  114.     error_msg                   : string_255;
  115.     expression                  : string_255; 
  116.     expression_index            : INTEGER;
  117.     expression_length           : INTEGER;
  118.     xresult                     : REAL;    { 8/11/95 dfn: result -> xresult }
  119.  
  120. { ------------------------------------------------------------------------ }
  121.  
  122.   PROCEDURE set_error(msg : string_255);
  123.     BEGIN
  124.       error_detected:=TRUE;
  125.       error_msg
  126.        :='Error:  '+msg+'.'
  127.     END;
  128.  
  129. { ------------------------------------------------------------------------ }
  130.  
  131.   PROCEDURE eat_leading_spaces;
  132.     VAR
  133.       non_blank_found           : BOOLEAN;
  134.     BEGIN
  135.       non_blank_found:=FALSE;
  136.       WHILE((expression_index <= expression_length)
  137.       AND   (NOT non_blank_found)) DO
  138.         IF expression[expression_index] = ' ' THEN
  139.           expression_index:=expression_index+1
  140.         ELSE
  141.           non_blank_found:=TRUE
  142.     END;
  143.  
  144. { ------------------------------------------------------------------------ }
  145.  
  146.   FUNCTION unsigned_integer : REAL;
  147.     VAR
  148.       non_digit_found           : BOOLEAN;
  149.       overflow                  : BOOLEAN;
  150.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  151.       tem_char                  : CHAR;
  152.       tem_real                  : REAL;
  153.     BEGIN
  154.       non_digit_found:=FALSE;
  155.       xresult:=0.0;
  156.       overflow:=FALSE;
  157.       REPEAT
  158.         tem_char:=expression[expression_index];
  159.         IF ((tem_char >= '0') AND (tem_char <= '9')) THEN
  160.           BEGIN
  161.             tem_real:=ORD(tem_char)-ORD('0');
  162.             IF xresult > 1.0E36 THEN
  163.               overflow:=TRUE
  164.             ELSE
  165.               BEGIN
  166.                 xresult:=10.0*xresult+tem_real;
  167.                 expression_index:=expression_index+1;
  168.                 IF expression_index > expression_length THEN
  169.                   non_digit_found:=TRUE
  170.               END
  171.           END
  172.         ELSE
  173.           non_digit_found:=TRUE
  174.       UNTIL ((non_digit_found) OR (overflow));
  175.       IF overflow THEN
  176.         set_error('constant is too big');
  177.       unsigned_integer:=xresult
  178.     END;
  179.  
  180. { ------------------------------------------------------------------------ }
  181.  
  182.   FUNCTION unsigned_number : REAL;
  183.     VAR
  184.       exponent_value            : REAL;
  185.       exponent_sign             : CHAR;
  186.       factor                    : REAL;
  187.       non_digit_found           : BOOLEAN;
  188.       xresult                   : REAL; { 8/11/95 dfn: result -> xresult }
  189.       tem_char                  : CHAR;
  190.       tem_real_1                : REAL;
  191.       tem_real_2                : REAL;
  192.     BEGIN
  193.       xresult:=unsigned_integer;
  194.       IF (NOT error_detected) THEN
  195.         BEGIN
  196.           IF expression_index <= expression_length THEN
  197.             BEGIN
  198.               tem_char:=expression[expression_index];
  199.               IF tem_char = '.' THEN
  200.                 BEGIN
  201.                   tem_real_1:=xresult;
  202.                   expression_index:=expression_index+1;
  203.                   IF expression_index > expression_length THEN
  204.                     set_error(
  205.             'end of expression encountered where decimal part expected')
  206.                   ELSE
  207.                     BEGIN
  208.                       tem_char:=expression[expression_index];
  209.                       IF ((tem_char >= '0') AND (tem_char <= '9')) THEN
  210.                         BEGIN
  211.                           factor:=1.0;
  212.                           non_digit_found:=FALSE;
  213.                           WHILE (NOT non_digit_found) DO
  214.                             BEGIN
  215.                               factor:=factor/10.0;
  216.                               tem_real_2:=ORD(tem_char)-ORD('0');
  217.                               tem_real_1:=tem_real_1+factor*tem_real_2;
  218.                               expression_index:=expression_index+1;
  219.                               IF expression_index > expression_length THEN
  220.                                non_digit_found:=TRUE
  221.                               ELSE
  222.                                 BEGIN
  223.                                   tem_char
  224.                                    :=expression[expression_index];
  225.                                   IF ((tem_char < '0')
  226.                                   OR  (tem_char > '9')) THEN
  227.                                     non_digit_found:=TRUE
  228.                                 END
  229.                             END;
  230.                           xresult:=tem_real_1
  231.                         END
  232.                       ELSE
  233.                         set_error(
  234.                          'decimal part of real number is missing')
  235.                     END
  236.                 END;
  237.               IF (NOT error_detected) THEN
  238.                 BEGIN
  239.                   IF expression_index <= expression_length THEN
  240.                     BEGIN
  241.                       IF ((tem_char = 'e') OR (tem_char = 'E')) THEN
  242.                         BEGIN
  243.                           expression_index:=expression_index+1;
  244.                           IF expression_index > expression_length THEN
  245.                             set_error(
  246.                'end of expression encountered where exponent expected')
  247.                          ELSE
  248.                             BEGIN
  249.                               tem_char
  250.                                :=expression[expression_index];
  251.                               IF ((tem_char = '+')
  252.                               OR  (tem_char = '-')) THEN
  253.                                 BEGIN
  254.                                   exponent_sign:=tem_char;
  255.                                   expression_index:=expression_index+1
  256.                                 END
  257.                               ELSE
  258.                                 exponent_sign:=' ';
  259.                               IF expression_index > expression_length
  260.                                THEN
  261.                                 set_error(
  262.      'end of expression encountered where exponent magnitude expected')
  263.                               ELSE
  264.                                 BEGIN
  265.                                   tem_char:=expression[expression_index];
  266.                                  IF ((tem_char >= '0')
  267.                                   AND (tem_char <= '9')) THEN
  268.                                     BEGIN
  269.                                       exponent_value
  270.                                        :=unsigned_integer;
  271.                                       IF (NOT error_detected) THEN
  272.                                         BEGIN
  273.                                           IF exponent_value > 37.0 THEN
  274.                                             set_error(
  275.                                    'magnitude of exponent is too large')
  276.                                           ELSE
  277.                                             BEGIN
  278.                                               tem_real_1:=1.0;
  279.                                               WHILE (exponent_value > 0.0) DO
  280.                                                 BEGIN
  281.                                                   exponent_value
  282.                                                    :=exponent_value-1.0;
  283.                                                   tem_real_1:=10.0*tem_real_1
  284.                                                 END;
  285.                                               IF exponent_sign = '-' THEN
  286.                                                tem_real_1
  287.                                                 :=1.0/tem_real_1;
  288.                                               IF xresult <> 0.0 THEN
  289.                                                 BEGIN
  290.                                                   tem_real_2
  291.                                                    :=(LN(tem_real_1)
  292.                                                    +LN(ABS(xresult)))
  293.                                                    /LN(10.0);
  294.                                                   IF tem_real_2 < -37.0 THEN
  295.                                                     xresult:=0.0
  296.                                                   ELSE
  297.                                                     IF tem_real_2 > 37.0 THEN
  298.                                                       set_error(
  299.                                                        'constant is too big')
  300.                                                     ELSE
  301.                                                       xresult:=xresult*tem_real_1
  302.                                                 END
  303.                                             END
  304.                                         END
  305.                                     END
  306.                                   ELSE
  307.                                     set_error(
  308.                                      'nonnumeric exponent encountered')
  309.                                 END
  310.                             END
  311.                         END
  312.                     END
  313.                 END
  314.             END
  315.         END;
  316.       unsigned_number:=xresult
  317.     END;
  318.  
  319. { ------------------------------------------------------------------------ }
  320.  
  321.   FUNCTION pop_argument(VAR argument_stack_head : argument_record_ptr) : REAL;
  322.     VAR
  323.       argument_stack_ptr        : argument_record_ptr;
  324.       xresult                   : REAL;  { 8/11/95 dfn: result -> xresult }
  325.     BEGIN
  326.       xresult:=argument_stack_head^.value;
  327.       argument_stack_ptr:=argument_stack_head^.next_ptr;
  328.       DISPOSE(argument_stack_head);
  329.       argument_stack_head:=argument_stack_ptr;
  330.       pop_argument:=xresult
  331.     END;
  332.  
  333. { ------------------------------------------------------------------------ }
  334.  
  335.   FUNCTION abs_function(VAR argument_stack_head : argument_record_ptr;
  336.    VAR function_name : string_255) : REAL;
  337.     VAR
  338.       argument                  : REAL;
  339.       xresult                   : REAL;   { 8/11/95 dfn: result -> xresult }
  340.     BEGIN
  341.       xresult:=0.0;
  342.       IF argument_stack_head = NIL THEN
  343.         set_error('argument to "'+function_name+'" is missing')
  344.       ELSE
  345.         BEGIN
  346.           argument:=pop_argument(argument_stack_head);
  347.           IF argument_stack_head = NIL THEN
  348.             IF argument >= 0.0 THEN
  349.               xresult:=argument
  350.             ELSE
  351.               xresult:=-argument
  352.           ELSE
  353.             set_error(
  354.              'extraneous argument supplied to function "'+
  355.              function_name+'"')
  356.         END;
  357.       abs_function:=xresult
  358.     END;
  359.  
  360. { ------------------------------------------------------------------------ }
  361.  
  362.   FUNCTION arctan_function(VAR argument_stack_head : argument_record_ptr;
  363.    VAR function_name : string_255) : REAL;
  364.     VAR
  365.       argument                  : REAL;
  366.       xresult                   : REAL; { 8/11/95 dfn: result -> xresult }
  367.     BEGIN
  368.       xresult:=0.0;
  369.       IF argument_stack_head = NIL THEN
  370.        set_error(
  371.         'argument to "'+function_name+'" is missing')
  372.       ELSE
  373.         BEGIN
  374.           argument:=pop_argument(argument_stack_head);
  375.           IF argument_stack_head = NIL THEN
  376.             xresult:=ARCTAN(argument)
  377.           ELSE
  378.             set_error(
  379.              'extraneous argument supplied to function "'+
  380.              function_name+'"')
  381.         END;
  382.       arctan_function:=xresult
  383.     END;
  384.  
  385. { ------------------------------------------------------------------------ }
  386.  
  387.   FUNCTION cos_function(VAR argument_stack_head : argument_record_ptr;
  388.    VAR function_name : string_255) : REAL;
  389.     VAR
  390.       argument                  : REAL;
  391.       xresult                   : REAL;  { 8/11/95 dfn: result -> xresult }
  392.     BEGIN
  393.       xresult:=0.0;
  394.       IF argument_stack_head = NIL THEN
  395.         set_error('argument to "'+function_name+'" is missing')
  396.       ELSE
  397.         BEGIN
  398.           argument:=pop_argument(argument_stack_head);
  399.           IF argument_stack_head = NIL THEN
  400.             xresult:=COS(argument)
  401.           ELSE
  402.             set_error(
  403.              'extraneous argument supplied to function "'+
  404.              function_name+'"')
  405.         END;
  406.       cos_function:=xresult
  407.     END;
  408.  
  409. { ------------------------------------------------------------------------ }
  410.  
  411.   FUNCTION exp_function(VAR argument_stack_head : argument_record_ptr;
  412.    VAR function_name : string_255) : REAL;
  413.     VAR
  414.       argument                  : REAL;
  415.       xresult                   : REAL; { 8/11/95 dfn: result -> xresult }
  416.       tem_real                  : REAL;
  417.     BEGIN
  418.       xresult:=0.0;
  419.       IF argument_stack_head = NIL THEN
  420.         set_error('argument to "'+function_name+'" is missing')
  421.       ELSE
  422.         BEGIN
  423.           argument:=pop_argument(argument_stack_head);
  424.           IF argument_stack_head = NIL THEN
  425.             BEGIN
  426.               tem_real:=argument/LN(10.0);
  427.               IF tem_real < -37.0 THEN
  428.                 xresult:=0.0
  429.               ELSE
  430.                 IF tem_real > 37.0 THEN
  431.                   set_error(
  432.                    'overflow detected while calculating "'+
  433.                    function_name+'"')
  434.                 ELSE
  435.                   xresult:=EXP(argument)
  436.             END
  437.           ELSE
  438.             set_error(
  439.              'extraneous argument supplied to function "'+
  440.              function_name+'"')
  441.         END;
  442.       exp_function:=xresult
  443.     END;
  444.  
  445. { ------------------------------------------------------------------------ }
  446.  
  447.   FUNCTION ln_function(VAR argument_stack_head : argument_record_ptr;
  448.    VAR function_name : string_255) : REAL;
  449.     VAR
  450.       argument                  : REAL;
  451.       xresult                   : REAL; { 8/11/95 dfn: result -> xresult }
  452.     BEGIN
  453.       xresult:=0.0;
  454.       IF argument_stack_head = NIL THEN
  455.         set_error(
  456.          'argument to "'+function_name+'" is missing')
  457.       ELSE
  458.         BEGIN
  459.           argument:=pop_argument(argument_stack_head);
  460.           IF argument_stack_head = NIL THEN
  461.             IF argument <= 0.0 THEN
  462.               set_error(
  463.                'argument to "'+function_name+
  464.                '" is other than positive')
  465.             ELSE
  466.               xresult:=LN(argument)
  467.           ELSE
  468.             set_error(
  469.              'extraneous argument supplied to function "'+
  470.              function_name+'"')
  471.         END;
  472.       ln_function:=xresult
  473.     END;
  474.  
  475. { ------------------------------------------------------------------------ }
  476.  
  477.   FUNCTION pi_function(VAR argument_stack_head : argument_record_ptr;
  478.    VAR function_name : string_255) : REAL;
  479.     VAR
  480.       argument                  : REAL;
  481.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  482.     BEGIN
  483.       xresult:=0.0;
  484.       IF argument_stack_head = NIL THEN
  485.         xresult:=4.0*ARCTAN(1.0)
  486.       ELSE
  487.         set_error(
  488.          'extraneous argument supplied to function "'+
  489.          function_name+'"');
  490.       pi_function:=xresult
  491.     END;
  492.  
  493. { ------------------------------------------------------------------------ }
  494.  
  495.   FUNCTION sin_function(VAR argument_stack_head : argument_record_ptr;
  496.    VAR function_name : string_255) : REAL;
  497.     VAR
  498.       argument                  : REAL;
  499.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  500.     BEGIN
  501.       xresult:=0.0;
  502.       IF argument_stack_head = NIL THEN
  503.         set_error(
  504.          'argument to "'+function_name+'" is missing')
  505.       ELSE
  506.         BEGIN
  507.           argument:=pop_argument(argument_stack_head);
  508.           IF argument_stack_head = NIL THEN
  509.             xresult:=SIN(argument)
  510.           ELSE
  511.             set_error(
  512.              'extraneous argument supplied to function "'+
  513.              function_name+'"')
  514.         END;
  515.       sin_function:=xresult
  516.     END;
  517.  
  518. { ------------------------------------------------------------------------ }
  519.  
  520.   FUNCTION sqr_function(VAR argument_stack_head : argument_record_ptr;
  521.    VAR function_name : string_255) : REAL;
  522.     VAR
  523.       argument                  : REAL;
  524.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  525.       tem_real                  : REAL;
  526.     BEGIN
  527.       xresult:=0.0;
  528.       IF argument_stack_head = NIL THEN
  529.         set_error(
  530.          'argument to "'+function_name+'" is missing')
  531.       ELSE
  532.         BEGIN
  533.           argument:=pop_argument(argument_stack_head);
  534.           IF argument_stack_head = NIL THEN
  535.             IF argument = 0.0 THEN
  536.               xresult:=0.0
  537.             ELSE
  538.               BEGIN
  539.                 tem_real:=2.0*LN(ABS(argument))/LN(10.0);
  540.                 IF tem_real < -37.0 THEN
  541.                   xresult:=0.0
  542.                 ELSE
  543.                   IF tem_real > 37.0 THEN
  544.                     set_error(
  545.                      'overflow detected during calculation of "'+
  546.                      function_name+'"')
  547.                   ELSE
  548.                     xresult:=argument*argument
  549.               END
  550.           ELSE
  551.             set_error(
  552.              'extraneous argument supplied to function "'+
  553.              function_name+'"')
  554.         END;
  555.       sqr_function:=xresult
  556.     END;
  557.  
  558. { ------------------------------------------------------------------------ }
  559.  
  560.   FUNCTION sqrt_function(VAR argument_stack_head : argument_record_ptr;
  561.    VAR function_name : string_255) : REAL;
  562.     VAR
  563.       argument                  : REAL;
  564.       xresult                   : REAL;  { 8/11/95 dfn: result -> xresult }
  565.     BEGIN
  566.       xresult:=0.0;
  567.       IF argument_stack_head = NIL THEN
  568.         set_error(
  569.          'argument to "'+function_name+'" is missing')
  570.       ELSE
  571.         BEGIN
  572.           argument:=pop_argument(argument_stack_head);
  573.           IF argument_stack_head = NIL THEN
  574.             IF argument < 0.0 THEN
  575.               set_error(
  576.                'argument to "'+function_name+
  577.                '" is negative')
  578.             ELSE
  579.               xresult:=SQRT(argument)
  580.           ELSE
  581.             set_error(
  582.              'extraneous argument supplied to function "'+
  583.              function_name+'"')
  584.         END;
  585.       sqrt_function:=xresult
  586.     END;
  587.  
  588. { ------------------------------------------------------------------------ }
  589.  
  590.   FUNCTION simple_expression : REAL; FORWARD;
  591.  
  592. { ------------------------------------------------------------------------ }
  593.  
  594.   FUNCTION funct : REAL;
  595.     VAR
  596.       argument                  : REAL;
  597.       argument_stack_head       : argument_record_ptr;
  598.       argument_stack_ptr        : argument_record_ptr;
  599.       arguments_okay            : BOOLEAN;
  600.       function_name             : string_255;
  601.       non_alphanumeric_found    : BOOLEAN;
  602.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  603.       right_parenthesis_found   : BOOLEAN;
  604.       tem_char                  : CHAR;
  605.     BEGIN    
  606.       xresult:=0.0;
  607.       non_alphanumeric_found:=FALSE;
  608.       function_name:='';
  609.       WHILE((expression_index <= expression_length)
  610.       AND   (NOT non_alphanumeric_found)) DO
  611.         BEGIN
  612.           tem_char:=expression[expression_index];
  613.           tem_char:=UPCASE(tem_char);
  614.           IF ((tem_char >= 'A') AND (tem_char <= 'Z')) THEN
  615.             BEGIN
  616.               function_name:=function_name+tem_char;
  617.               expression_index:=expression_index+1
  618.             END
  619.           ELSE
  620.             non_alphanumeric_found:=TRUE
  621.         END;
  622.       argument_stack_head:=NIL;
  623.       arguments_okay:=TRUE;
  624.       eat_leading_spaces;
  625.       IF expression_index <= expression_length THEN
  626.         BEGIN
  627.           tem_char:=expression[expression_index];
  628.           IF tem_char = '(' THEN
  629.             BEGIN
  630.               expression_index:=expression_index+1;
  631.               right_parenthesis_found:=FALSE;
  632.               WHILE ((NOT right_parenthesis_found)
  633.               AND    (arguments_okay)
  634.               AND    (expression_index <= expression_length)) DO
  635.                 BEGIN
  636.                   argument:=simple_expression;
  637.                   IF error_detected THEN
  638.                     arguments_okay:=FALSE
  639.                   ELSE
  640.                     BEGIN
  641.                       IF argument_stack_head = NIL THEN
  642.                         BEGIN
  643.                           NEW(argument_stack_head);
  644.                           argument_stack_head^.value:=argument;
  645.                           argument_stack_head^.next_ptr:=NIL
  646.                         END
  647.                       ELSE
  648.                         BEGIN
  649.                           NEW(argument_stack_ptr);
  650.                           argument_stack_ptr^.value:=argument;
  651.                           argument_stack_ptr^.next_ptr
  652.                            :=argument_stack_head;
  653.                           argument_stack_head:=argument_stack_ptr
  654.                         END;
  655.                       eat_leading_spaces;
  656.                       IF expression_index <= expression_length THEN
  657.                         BEGIN
  658.                           tem_char:=expression[expression_index];
  659.                           IF tem_char = ')' THEN
  660.                             BEGIN
  661.                               right_parenthesis_found:=TRUE;
  662.                               expression_index:=expression_index+1
  663.                             END
  664.                           ELSE
  665.                             IF tem_char = ',' THEN
  666.                               expression_index:=expression_index+1
  667.                             ELSE
  668.                               BEGIN
  669.                                 arguments_okay:=FALSE;
  670.                                 set_error(
  671.                             'comma missing from function arguments')
  672.                               END
  673.                         END
  674.                     END
  675.                 END;
  676.               IF arguments_okay THEN
  677.                 BEGIN
  678.                   IF (NOT right_parenthesis_found) THEN
  679.                     BEGIN
  680.                       arguments_okay:=FALSE;
  681.                       set_error(
  682.                    '")" to terminate function arguments is missing')
  683.                     END
  684.                 END
  685.             END
  686.         END;
  687.       IF arguments_okay THEN
  688.         BEGIN
  689.           IF function_name = 'ABS' THEN
  690.             xresult
  691.              :=abs_function(argument_stack_head,function_name) 
  692.           ELSE
  693.             IF function_name = 'ARCTAN' THEN
  694.               xresult
  695.                :=arctan_function(argument_stack_head,function_name)
  696.             ELSE
  697.               IF function_name = 'COS' THEN
  698.                 xresult
  699.                  :=cos_function(argument_stack_head,function_name)
  700.               ELSE
  701.                 IF function_name = 'EXP' THEN
  702.                   xresult
  703.                    :=exp_function(argument_stack_head,function_name)
  704.                 ELSE
  705.                   IF function_name = 'LN' THEN
  706.                     xresult
  707.                      :=ln_function(argument_stack_head,function_name)
  708.                   ELSE
  709.                     IF function_name = 'PI' THEN
  710.                       xresult
  711.                        :=pi_function(argument_stack_head,function_name)
  712.                     ELSE
  713.                       IF function_name = 'SIN' THEN
  714.                         xresult
  715.                          :=sin_function(argument_stack_head,function_name)
  716.                       ELSE
  717.                         IF function_name = 'SQR' THEN
  718.                           xresult
  719.                            :=sqr_function(argument_stack_head,function_name)
  720.                         ELSE
  721.                           IF function_name = 'SQRT' THEN
  722.                             xresult
  723.                              :=sqrt_function(argument_stack_head,function_name)
  724.                           ELSE
  725.                             set_error('the function "'+
  726.                              function_name+'" is unrecognized')
  727.         END;
  728.       WHILE (argument_stack_head <> NIL) DO
  729.         BEGIN
  730.           argument_stack_ptr:=argument_stack_head^.next_ptr;
  731.           DISPOSE(argument_stack_head);
  732.           argument_stack_head:=argument_stack_ptr
  733.         END;
  734.       funct:=result
  735.     END;
  736.  
  737. { ------------------------------------------------------------------------ }
  738.  
  739.   FUNCTION factor : REAL;
  740.     VAR
  741.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  742.       tem_char                  : CHAR;
  743.     BEGIN
  744.       xresult:=0.0;
  745.       eat_leading_spaces;
  746.       IF expression_index > expression_length THEN
  747.         set_error(
  748.          'end of expression encountered where factor expected')
  749.       ELSE
  750.         BEGIN
  751.           tem_char:=expression[expression_index];
  752.           BEGIN
  753.             IF tem_char = '(' THEN
  754.               BEGIN
  755.                 expression_index:=expression_index+1;
  756.                 xresult:=simple_expression;
  757.                 IF (NOT error_detected) THEN
  758.                   BEGIN
  759.                     eat_leading_spaces;
  760.                     IF expression_index > expression_length THEN
  761.                       set_error(
  762.                        'end of expression encountered '+
  763.                        'where ")" was expected')
  764.                     ELSE
  765.                       IF expression[expression_index] = ')' THEN
  766.                         expression_index:=expression_index+1
  767.                       ELSE
  768.                         set_error('expression not followed by ")"')
  769.                   END
  770.               END
  771.             ELSE
  772.               IF ((tem_char >= '0') AND (tem_char <= '9')) THEN
  773.                 xresult:=unsigned_number
  774.               ELSE
  775.                 IF (((tem_char >= 'a') AND (tem_char <= 'z'))
  776.                 OR  ((tem_char >= 'A') AND (tem_char <= 'Z'))) THEN
  777.                   xresult:=funct
  778.                 ELSE
  779.                   set_error(
  780.                    'function, unsigned number, or "(" expected')
  781.           END
  782.         END;
  783.       factor:=xresult
  784.     END;
  785.  
  786. { ------------------------------------------------------------------------ }
  787.  
  788.   FUNCTION quotient_of_factors(VAR left_value,right_value : REAL) : REAL;
  789.     VAR
  790.       xresult                   : REAL; { 8/11/95 dfn: result -> xresult }
  791.       tem_real                  : REAL;
  792.     BEGIN
  793.       xresult:=0.0;
  794.       IF right_value = 0.0 THEN
  795.         set_error('division by zero attempted')
  796.       ELSE
  797.         BEGIN
  798.           IF left_value = 0.0 THEN
  799.             xresult:=0.0
  800.           ELSE
  801.             BEGIN
  802.               tem_real:=(LN(ABS(left_value))-LN(ABS(right_value)))/LN(10.0);
  803.               IF tem_real < -37.0 THEN 
  804.                 xresult:=0.0
  805.               ELSE
  806.                 IF tem_real > 37.0 THEN
  807.                   set_error(
  808.                    'overflow detected during division')
  809.                 ELSE
  810.                   xresult:=left_value/right_value
  811.             END
  812.         END;
  813.       quotient_of_factors:=xresult
  814.     END;
  815.  
  816. { ------------------------------------------------------------------------ }
  817.  
  818.   FUNCTION product_of_factors(VAR left_value,right_value : REAL) : REAL;
  819.     VAR
  820.       xresult                   : REAL; { 8/11/95 dfn: result -> xresult }
  821.       tem_real                  : REAL;
  822.     BEGIN
  823.       xresult:=0.0;
  824.       IF ((left_value <> 0.0) AND (right_value <> 0.0)) THEN
  825.         BEGIN
  826.           tem_real:=(LN(ABS(left_value))+LN(ABS(right_value)))/LN(10.0); 
  827.           IF tem_real < -37.0 THEN
  828.             xresult:=0.0
  829.           ELSE
  830.             IF tem_real > 37.0 THEN
  831.               set_error(
  832.                'overflow detected during multiplication')
  833.             ELSE
  834.               xresult:=left_value*right_value
  835.         END;
  836.       product_of_factors:=xresult
  837.     END;
  838.  
  839. { ------------------------------------------------------------------------ }
  840.  
  841.   FUNCTION factor_operator : string_1;
  842.     VAR
  843.       xresult                   : string_1; { 8/11/95 dfn: result -> xresult }
  844.     BEGIN
  845.       eat_leading_spaces;
  846.       IF expression_index <= expression_length THEN
  847.         BEGIN
  848.           xresult:=expression[expression_index];
  849.           IF ((xresult = '*')
  850.           OR  (xresult = '/')) THEN
  851.             expression_index:=expression_index+1
  852.         END
  853.       ELSE
  854.         xresult:='';
  855.       factor_operator:=xresult
  856.     END;
  857.  
  858. { ------------------------------------------------------------------------ }
  859.  
  860.   FUNCTION term : REAL;
  861.     VAR
  862.       operator                  : string_1;
  863.       operator_found            : BOOLEAN;
  864.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  865.       right_value               : REAL;
  866.     BEGIN
  867.       xresult:=0;
  868.       eat_leading_spaces;
  869.       IF expression_index > expression_length THEN
  870.         set_error(
  871.          'end of expression encountered where term was expected')
  872.       ELSE
  873.         BEGIN
  874.           xresult:=factor;
  875.           operator_found:=TRUE;
  876.           WHILE((NOT error_detected)
  877.           AND   (operator_found)) DO
  878.             BEGIN
  879.               operator:=factor_operator;
  880.               IF LENGTH(operator) = 0 THEN
  881.                 operator_found:=FALSE
  882.               ELSE
  883.                 IF ((operator <> '*')
  884.                 AND (operator <> '/')) THEN
  885.                   operator_found:=FALSE
  886.                 ELSE
  887.                   BEGIN
  888.                     right_value:=factor;
  889.                     IF (NOT error_detected) THEN
  890.                       BEGIN
  891.                         IF operator = '*' THEN
  892.                             xresult:=product_of_factors(
  893.                              xresult,right_value)
  894.                         ELSE
  895.                             xresult:=quotient_of_factors(
  896.                              xresult,right_value)
  897.                       END
  898.                   END
  899.             END
  900.         END;
  901.       term:=xresult
  902.     END;
  903.  
  904. { ------------------------------------------------------------------------ }
  905.  
  906.   FUNCTION sum_of_terms(VAR left_value,right_value : REAL) : REAL;
  907.     VAR
  908.       xresult                    : REAL;    { 8/11/95 dfn: result -> xresult }
  909.     BEGIN
  910.       xresult:=0.0;
  911.       IF ((left_value > 0.0) AND (right_value > 0.0)) THEN
  912.         IF left_value > (1.0E37 - right_value) THEN
  913.           set_error('overflow detected during addition')
  914.         ELSE
  915.           xresult:=left_value+right_value
  916.       ELSE
  917.         IF ((left_value < 0.0) AND (right_value < 0.0)) THEN
  918.           IF left_value < (-1.0E37 - right_value) THEN
  919.             set_error('overflow detected during addition')
  920.           ELSE
  921.             xresult:=left_value+right_value
  922.         ELSE
  923.           xresult:=left_value+right_value;
  924.       sum_of_terms:=xresult
  925.     END;
  926.  
  927. { ------------------------------------------------------------------------ }
  928.  
  929.   FUNCTION difference_of_terms(VAR left_value,right_value : REAL) : REAL;
  930.     VAR
  931.       xresult                    : REAL;    { 8/11/95 dfn: result -> xresult }
  932.     BEGIN
  933.       IF ((left_value < 0.0) AND (right_value > 0.0)) THEN
  934.         IF left_value < (right_value - 1.0E37) THEN
  935.           set_error('overflow detected during subtraction')
  936.         ELSE
  937.           xresult:=left_value-right_value
  938.       ELSE
  939.         IF ((left_value > 0.0) AND (right_value < 0.0)) THEN
  940.           IF left_value > (right_value + 1.0E37) THEN
  941.             set_error('overflow detected during subtraction')
  942.           ELSE
  943.             xresult:=left_value-right_value
  944.         ELSE
  945.           xresult:=left_value-right_value;
  946.       difference_of_terms:=xresult
  947.     END;
  948.  
  949. { ------------------------------------------------------------------------ }
  950.  
  951.   FUNCTION term_operator : string_1;
  952.     VAR
  953.       xresult                    : string_1;    { 8/11/95 dfn: result -> xresult }
  954.     BEGIN
  955.       eat_leading_spaces;
  956.       IF expression_index <= expression_length THEN
  957.         BEGIN
  958.           xresult:=expression[expression_index];
  959.           IF ((xresult = '+')
  960.           OR  (xresult = '-')) THEN
  961.             expression_index:=expression_index+1
  962.         END
  963.       ELSE
  964.         xresult:='';
  965.       term_operator:=xresult
  966.     END;
  967.  
  968. { ------------------------------------------------------------------------ }
  969.  
  970.   FUNCTION simple_expression;
  971.     VAR
  972.       leading_sign              : CHAR;
  973.       operator                  : string_1;
  974.       operator_found            : BOOLEAN;
  975.       xresult                   : REAL;    { 8/11/95 dfn: result -> xresult }
  976.       right_value               : REAL;
  977.       tem_char                  : CHAR;
  978.     BEGIN
  979.       xresult:=0.0;
  980.       eat_leading_spaces;
  981.       IF expression_index > expression_length THEN
  982.         set_error(
  983.        'end of expression encountered where simple expression expected')
  984.       ELSE
  985.         BEGIN
  986.           leading_sign:=' ';
  987.           tem_char:=expression[expression_index];
  988.           IF ((tem_char = '+') OR (tem_char = '-')) THEN
  989.             BEGIN
  990.               leading_sign:=tem_char;
  991.               expression_index:=expression_index+1
  992.             END;
  993.           xresult:=term;
  994.           IF (NOT error_detected) THEN
  995.             BEGIN
  996.               IF leading_sign <> ' ' THEN
  997.                 BEGIN
  998.                   IF leading_sign = '-' THEN
  999.                     xresult:=-xresult
  1000.                 END;
  1001.               operator_found:=TRUE;
  1002.               WHILE((NOT error_detected)
  1003.               AND   (operator_found)) DO
  1004.                 BEGIN
  1005.                   operator:=term_operator;
  1006.                   IF LENGTH(operator) = 0 THEN
  1007.                     operator_found:=FALSE
  1008.                   ELSE
  1009.                     IF ((operator <> '+')
  1010.                     AND (operator <> '-')) THEN
  1011.                       operator_found:=FALSE
  1012.                     ELSE
  1013.                       BEGIN
  1014.                         right_value:=term;
  1015.                         IF (NOT error_detected) THEN
  1016.                           BEGIN
  1017.                             IF operator = '+' THEN
  1018.                               xresult:=sum_of_terms(
  1019.                                xresult,right_value)
  1020.                             ELSE
  1021.                               xresult:=difference_of_terms(
  1022.                                xresult,right_value)
  1023.                           END
  1024.                       END
  1025.                 END
  1026.             END
  1027.         END;
  1028.       simple_expression:=xresult
  1029.     END;
  1030.  
  1031. { ------------------------------------------------------------------------ }
  1032.  
  1033.   PROCEDURE output_value(VAR xresult : REAL);
  1034.  
  1035.   { this procedure used to send text directly to the display.
  1036.     I reworked it to condition the value only and then return. }
  1037.  
  1038.     VAR
  1039.       digits_in_integer_part       : INTEGER;
  1040.       magnitude_of_xresult          : REAL;
  1041.  
  1042.     BEGIN
  1043.  
  1044.       IF xresult >= 0.0 THEN
  1045.         magnitude_of_xresult:=xresult
  1046.       ELSE
  1047.         magnitude_of_xresult:=-xresult;
  1048.       IF magnitude_of_xresult >= 5.0E-3 THEN
  1049.         BEGIN
  1050.           digits_in_integer_part:=0;
  1051.           WHILE ((digits_in_integer_part <= 8)
  1052.           AND    (magnitude_of_xresult >= 1.0)) DO
  1053.             BEGIN
  1054.               magnitude_of_xresult:=magnitude_of_xresult/10.0;
  1055.               digits_in_integer_part:=digits_in_integer_part+1
  1056.             END;
  1057. (*
  1058.           IF digits_in_integer_part > 8 THEN
  1059.             WRITELN(OUTPUT,xresult:13)
  1060.           ELSE
  1061.             WRITELN(OUTPUT,xresult:10:8-digits_in_integer_part)
  1062. *)
  1063.         END;
  1064. (*
  1065.       ELSE
  1066.         WRITELN(OUTPUT,xresult:13)
  1067. *)
  1068.     END;
  1069.  
  1070. { ------------------------------------------------------------------------ }
  1071.  
  1072.   PROCEDURE output_error(error_msg : string_255;
  1073.                          VAR expression : string_255;
  1074.                          VAR expression_index : INTEGER);
  1075.  
  1076.     { this routine used to write the expression, the position of
  1077.       the error, and an error message to the screen. it has been
  1078.       reworked to keep the position of the error only. if more
  1079.       information is required, add the code here. the original
  1080.       calling convention has been preserved.
  1081.     }
  1082.  
  1083.     BEGIN
  1084.  
  1085.       {trap the error here to see in Turbo Debugger}
  1086.  
  1087.       CalcError := expression_index;
  1088.  
  1089.     END;
  1090.  
  1091. { ------------------------------------------------------------------------ }
  1092.  
  1093. procedure RawCalculate(MyFormula:string;var MyResult:real;var MyError:byte);
  1094.  
  1095. { this procedure will evaluate an expression without variables.
  1096.   it is called by the Calculate procedure once variable values
  1097.   have been inserted into the expression.
  1098.  
  1099.   MyError will be 0 for a successful evaluation.
  1100. }
  1101.  
  1102. begin
  1103.  
  1104.   expression := MyFormula;
  1105.   MyResult := 0;
  1106.   CalcError := 0;
  1107.   expression_length := length(MyFormula);
  1108.  
  1109.   { ---- Original code starts here ---- }
  1110.  
  1111.   error_detected:=FALSE;
  1112.   expression_index:=1;
  1113.   xresult:=simple_expression;
  1114.  
  1115.   IF error_detected THEN
  1116.     output_error(error_msg,expression,expression_index)
  1117.   ELSE
  1118.     BEGIN
  1119.       eat_leading_spaces;
  1120.       IF expression_index <= expression_length THEN
  1121.         output_error('Error:  expression followed by garbage',
  1122.                      expression,expression_index)
  1123.       ELSE
  1124.         output_value(xresult);
  1125.     END;
  1126.  
  1127.   { ---- Original code ends here ---- }
  1128.  
  1129.   MyResult := xresult;
  1130.   MyError := CalcError;
  1131.  
  1132. end; {RawCalc}
  1133.  
  1134. { ------------------------------------------------------------------------ }
  1135.  
  1136. procedure GetPointerTo(VariableID:str20;var MPtr:VariablePtr);
  1137.  
  1138. var
  1139.  
  1140.   Done : boolean;
  1141.   XPtr : VariablePtr;
  1142.  
  1143. begin
  1144.  
  1145.   MPtr := nil;
  1146.   XPtr := HPtr;
  1147.  
  1148.   Done := false;
  1149.   while (not Done) do begin
  1150.  
  1151.     if XPtr^.ID=VariableID then
  1152.       MPtr := XPtr;
  1153.  
  1154.     if XPtr^.Next=nil then
  1155.       Done := true
  1156.     else
  1157.       XPtr := XPtr^.Next;
  1158.  
  1159.   end; {while}
  1160.  
  1161. end; {GetPointerTo}
  1162.  
  1163. { ------------------------------------------------------------------------ }
  1164.  
  1165. procedure ReadVariable(VariableID:str20;var MyValue:real;var MyError:boolean);
  1166.  
  1167. var
  1168.  
  1169.   MPtr : VariablePtr;
  1170.  
  1171. begin
  1172.  
  1173.   MyError := false;
  1174.   MyValue := 0;
  1175.  
  1176.   GetPointerTo(VariableID,MPtr);
  1177.  
  1178.   if MPtr<>nil then begin
  1179.     MyValue := MPtr^.Value
  1180.   end
  1181.   else begin
  1182.     MyError := true;
  1183.   end;
  1184.  
  1185. end; {ReadVariable}
  1186.  
  1187. { ------------------------------------------------------------------------ }
  1188.  
  1189. procedure StoreVariable(VariableID:str20;MyValue:real);
  1190.  
  1191. var
  1192.  
  1193.   WorkingRec : VariableType;
  1194.  
  1195. begin
  1196.  
  1197.   fillchar(WorkingRec,sizeof(WorkingRec),0);
  1198.   WorkingRec.ID := VariableID;
  1199.   WorkingRec.Value := MyValue;
  1200.  
  1201.   If HPtr = nil then begin
  1202.  
  1203.     {this is the first record added to the list}
  1204.  
  1205.     New(HPtr);                                {allocate 1st record in LL }
  1206.     TPtr := HPtr;                             {init tail (= head)        }
  1207.     TPtr^ := WorkingRec;                      {add new record as head    }
  1208.     TPtr^.Next := nil;                        {set the next link for tail}
  1209.  
  1210.   end
  1211.   else begin
  1212.  
  1213.     GetPointerTo(VariableID,SPtr);
  1214.  
  1215.     if SPtr <> nil then begin
  1216.  
  1217.       {the list exists and so does the variable -- modify value}
  1218.  
  1219.       SPtr^.Value := MyValue;
  1220.  
  1221.     end
  1222.     else begin
  1223.  
  1224.       {the list exists, but the variable doesn't -- add it}
  1225.  
  1226.       New(SPtr);                          {allocate new record for LL }
  1227.       SPtr^ := WorkingRec;                {put info in new LL record  }
  1228.       TPtr^.Next := SPtr;                 {add new record as tail     }
  1229.       SPtr^.Next := nil;                  {set the new link for tail  }
  1230.       TPtr := SPtr;                       {point tail to new record   }
  1231.  
  1232.     end; {if-else}
  1233.  
  1234.   end;
  1235.  
  1236. end; {StoreVariable}
  1237.  
  1238. { ------------------------------------------------------------------------- }
  1239.  
  1240. Procedure DestroyFieldList(TempPtr:VariablePtr);
  1241.  
  1242. { This procedure recursively destroys a linked list }
  1243.  
  1244. Begin
  1245.  
  1246.   If TempPtr^.Next <> nil then
  1247.     DestroyFieldList(TempPtr^.Next);
  1248.  
  1249.   Dispose(TempPtr);
  1250.  
  1251. End;
  1252.  
  1253. { ------------------------------------------------------------------------ }
  1254.  
  1255. procedure DestroyList;
  1256.  
  1257. begin
  1258.  
  1259.   if HPtr <> Nil then
  1260.     DestroyFieldList(HPtr);
  1261.  
  1262.   HPtr := nil;
  1263.   TPtr := nil;
  1264.   SPtr := nil;
  1265.  
  1266. end; {DestroyList}
  1267.  
  1268. { ------------------------------------------------------------------------ }
  1269.  
  1270. procedure Calculate(MyFormula:string;var MyResult:real;var MyError:byte);
  1271.  
  1272. { this procedure will evaluate an expression containing variables.
  1273.   this routine will scan the expression for variables, removing
  1274.   the variable IDs and substituting the value into the expression.
  1275.   once all variable IDs have been removed, this procedure calls
  1276.   RawCalculate for expression evaluation.
  1277.  
  1278.   MyError will be 0 for a successful evaluation.
  1279. }
  1280.  
  1281. var
  1282.  
  1283.   VarStr,
  1284.   DestStr : string;
  1285.   Index   : byte;
  1286.   MyReal  : real;
  1287.   MyErr   : boolean;
  1288.  
  1289. begin
  1290.  
  1291.   {the first part of this routine is the preprocessor for variables.
  1292.    the formula string will be copied to another string. as the string
  1293.    is copied, values for any variables will be inserted where the
  1294.    variable ID was in the original string.}
  1295.  
  1296.   MyError := 0;
  1297.   DestStr := '';
  1298.   Index := 1;
  1299.  
  1300.   while Index <= length(MyFormula) do begin
  1301.  
  1302.     if MyFormula[Index]='@' then begin
  1303.  
  1304.       VarStr := '@';
  1305.       inc(Index);
  1306.       while (MyFormula[Index]<>'@') AND (Index<=length(MyFormula)) do begin
  1307.         VarStr := VarStr + MyFormula[Index];
  1308.         inc(Index);
  1309.       end; {while}
  1310.       VarStr := VarStr + '@';
  1311.  
  1312.       if VarStr[length(VarStr)]='@' then begin
  1313.         {read variable}
  1314.         ReadVariable(VarStr,MyReal,MyErr);
  1315.         if not MyErr then begin
  1316.           {substitute value for variable}
  1317.           str(MyReal,VarStr);
  1318.           DestStr := DestStr + VarStr;
  1319.         end
  1320.         else
  1321.           {didn't find variable}
  1322.           MyError := Index - length(VarStr);
  1323.       end
  1324.       else begin
  1325.         {ran out of formula!}
  1326.         MyError := Index - length(VarStr);
  1327.       end; {if-else}
  1328.  
  1329.     end
  1330.     else
  1331.       DestStr := DestStr + MyFormula[Index];
  1332.  
  1333.     inc(Index);
  1334.  
  1335.   end; {while}
  1336.  
  1337.   if MyError=0 then begin
  1338.     MyFormula := DestStr;
  1339.     {call RawCalculate to evaluate expression}
  1340.     RawCalculate(MyFormula,MyResult,MyError);
  1341.   end;
  1342.  
  1343. end; {Calc}
  1344.  
  1345. { ------------------------------------------------------------------------ }
  1346.  
  1347. procedure CalcAndStore(MyFormula:string;StoreID:str20;var MyError:byte);
  1348.  
  1349. { this routine will evaluate an expression containing variables
  1350.   and will store the xresult in the variable with the ID, StoreID.
  1351.   this routine calls Calculate to evaluate the expression.
  1352.  
  1353.   MyError will be 0 for a successful evaluation.
  1354. }
  1355.  
  1356. var
  1357.  
  1358.   MyResult : real;
  1359.  
  1360. begin
  1361.  
  1362.   {call Calculate to evaluate expression}
  1363.   Calculate(MyFormula,MyResult,MyError);
  1364.  
  1365.   if MyError=0 then
  1366.     StoreVariable(StoreID,MyResult);
  1367.  
  1368. end; {CalcAndStore}
  1369.  
  1370. { ------------------------------------------------------------------------ }
  1371.  
  1372. (* This is the original main program block, now unused. --- DJF
  1373.  
  1374. BEGIN
  1375.     REPEAT
  1376.       WRITELN(OUTPUT,' ');
  1377.       WRITE(OUTPUT,'Expression (RETURN to exit)?  ');
  1378.       READLN(INPUT,expression);
  1379.       expression_length:=LENGTH(expression);
  1380.       IF expression_length > 0 THEN
  1381.         BEGIN
  1382.           error_detected:=FALSE;
  1383.           expression_index:=1;
  1384.           xresult:=simple_expression;
  1385.           IF error_detected THEN
  1386.             output_error(error_msg,expression,expression_index)
  1387.           ELSE
  1388.             BEGIN
  1389.               eat_leading_spaces;
  1390.               IF expression_index <= expression_length THEN
  1391.                 output_error(
  1392.                  'Error:  expression followed by garbage',
  1393.                  expression,expression_index)
  1394.               ELSE
  1395.                 output_value(xresult)
  1396.             END
  1397.         END
  1398.     UNTIL (expression_length = 0)
  1399.   END.
  1400.  
  1401.   *)
  1402.  
  1403. { ------------------------------------------------------------------------ }
  1404.  
  1405. Begin  {init code}
  1406.  
  1407.   {set up linked list to empty state}
  1408.  
  1409.   HPtr := nil;
  1410.   TPtr := nil;
  1411.   SPtr := nil;
  1412.  
  1413.   CalcError := 0;
  1414.  
  1415. End.   {init code}
  1416.  
  1417.