PROGRAM calc(INPUT,OUTPUT); { This program uses recursive descent to evaluate expressions written in infix notation. The operations addition (+), subtraction (-), multiplication (*), and division (/) are supported, as are the functions ABS, ARCTAN, COS, EXP, LN, SQR, and SQRT. PI returns the value for pi. Results exceeding 1.0E37 are reported as overflows. Results less than 1.0E-37 are set to zero. Written by James L. Dean 406 40th Street New Orleans, LA 70124 February 25, 1985 } TYPE argument_record_ptr = ^argument_record; argument_record = RECORD value : REAL; next_ptr : argument_record_ptr END; string_1 = STRING[1]; string_255 = STRING[255]; VAR error_detected : BOOLEAN; error_msg : string_255; expression : string_255; expression_index : INTEGER; expression_length : INTEGER; result : REAL; PROCEDURE set_error(msg : string_255); BEGIN error_detected:=TRUE; error_msg :='Error: '+msg+'.' END; PROCEDURE eat_leading_spaces; VAR non_blank_found : BOOLEAN; BEGIN non_blank_found:=FALSE; WHILE((expression_index <= expression_length) AND (NOT non_blank_found)) DO IF expression[expression_index] = ' ' THEN expression_index:=expression_index+1 ELSE non_blank_found:=TRUE END; FUNCTION unsigned_integer : REAL; VAR non_digit_found : BOOLEAN; overflow : BOOLEAN; result : REAL; tem_char : CHAR; tem_real : REAL; BEGIN non_digit_found:=FALSE; result:=0.0; overflow:=FALSE; REPEAT tem_char:=expression[expression_index]; IF ((tem_char >= '0') AND (tem_char <= '9')) THEN BEGIN tem_real:=ORD(tem_char)-ORD('0'); IF result > 1.0E36 THEN overflow:=TRUE ELSE BEGIN result:=10.0*result+tem_real; expression_index:=expression_index+1; IF expression_index > expression_length THEN non_digit_found:=TRUE END END ELSE non_digit_found:=TRUE UNTIL ((non_digit_found) OR (overflow)); IF overflow THEN set_error('constant is too big'); unsigned_integer:=result END; FUNCTION unsigned_number : REAL; VAR exponent_value : REAL; exponent_sign : CHAR; factor : REAL; non_digit_found : BOOLEAN; result : REAL; tem_char : CHAR; tem_real_1 : REAL; tem_real_2 : REAL; BEGIN result:=unsigned_integer; IF (NOT error_detected) THEN BEGIN IF expression_index <= expression_length THEN BEGIN tem_char:=expression[expression_index]; IF tem_char = '.' THEN BEGIN tem_real_1:=result; expression_index:=expression_index+1; IF expression_index > expression_length THEN set_error( 'end of expression encountered where decimal part expected') ELSE BEGIN tem_char:=expression[expression_index]; IF ((tem_char >= '0') AND (tem_char <= '9')) THEN BEGIN factor:=1.0; non_digit_found:=FALSE; WHILE (NOT non_digit_found) DO BEGIN factor:=factor/10.0; tem_real_2:=ORD(tem_char)-ORD('0'); tem_real_1:=tem_real_1+factor*tem_real_2; expression_index:=expression_index+1; IF expression_index > expression_length THEN non_digit_found:=TRUE ELSE BEGIN tem_char :=expression[expression_index]; IF ((tem_char < '0') OR (tem_char > '9')) THEN non_digit_found:=TRUE END END; result:=tem_real_1 END ELSE set_error( 'decimal part of real number is missing') END END; IF (NOT error_detected) THEN BEGIN IF expression_index <= expression_length THEN BEGIN IF ((tem_char = 'e') OR (tem_char = 'E')) THEN BEGIN expression_index:=expression_index+1; IF expression_index > expression_length THEN set_error( 'end of expression encountered where exponent expected') ELSE BEGIN tem_char :=expression[expression_index]; IF ((tem_char = '+') OR (tem_char = '-')) THEN BEGIN exponent_sign:=tem_char; expression_index:=expression_index+1 END ELSE exponent_sign:=' '; IF expression_index > expression_length THEN set_error( 'end of expression encountered where exponent magnitude expected') ELSE BEGIN tem_char:=expression[expression_index]; IF ((tem_char >= '0') AND (tem_char <= '9')) THEN BEGIN exponent_value :=unsigned_integer; IF (NOT error_detected) THEN BEGIN IF exponent_value > 37.0 THEN set_error( 'magnitude of exponent is too large') ELSE BEGIN tem_real_1:=1.0; WHILE (exponent_value > 0.0) DO BEGIN exponent_value :=exponent_value-1.0; tem_real_1:=10.0*tem_real_1 END; IF exponent_sign = '-' THEN tem_real_1 :=1.0/tem_real_1; IF result <> 0.0 THEN BEGIN tem_real_2 :=(LN(tem_real_1) +LN(ABS(result))) /LN(10.0); IF tem_real_2 < -37.0 THEN result:=0.0 ELSE IF tem_real_2 > 37.0 THEN set_error( 'constant is too big') ELSE result:=result*tem_real_1 END END END END ELSE set_error( 'nonnumeric exponent encountered') END END END END END END END; unsigned_number:=result END; FUNCTION pop_argument(VAR argument_stack_head : argument_record_ptr) : REAL; VAR argument_stack_ptr : argument_record_ptr; result : REAL; BEGIN result :=argument_stack_head^.value; argument_stack_ptr :=argument_stack_head^.next_ptr; DISPOSE(argument_stack_head); argument_stack_head:=argument_stack_ptr; pop_argument:=result END; FUNCTION abs_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN IF argument >= 0.0 THEN result:=argument ELSE result:=-argument ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; abs_function:=result END; FUNCTION arctan_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN result:=ARCTAN(argument) ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; arctan_function:=result END; FUNCTION cos_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN result:=COS(argument) ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; cos_function:=result END; FUNCTION exp_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; tem_real : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN BEGIN tem_real:=argument/LN(10.0); IF tem_real < -37.0 THEN result:=0.0 ELSE IF tem_real > 37.0 THEN set_error( 'overflow detected while calculating "'+ function_name+'"') ELSE result:=EXP(argument) END ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; exp_function:=result END; FUNCTION ln_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN IF argument <= 0.0 THEN set_error( 'argument to "'+function_name+ '" is other than positive') ELSE result:=LN(argument) ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; ln_function:=result END; FUNCTION pi_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN result:=4.0*ARCTAN(1.0) ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"'); pi_function:=result END; FUNCTION sin_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN result:=SIN(argument) ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; sin_function:=result END; FUNCTION sqr_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; tem_real : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN IF argument = 0.0 THEN result:=0.0 ELSE BEGIN tem_real:=2.0*LN(ABS(argument))/LN(10.0); IF tem_real < -37.0 THEN result:=0.0 ELSE IF tem_real > 37.0 THEN set_error( 'overflow detected during calculation of "'+ function_name+'"') ELSE result:=argument*argument END ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; sqr_function:=result END; FUNCTION sqrt_function(VAR argument_stack_head : argument_record_ptr; VAR function_name : string_255) : REAL; VAR argument : REAL; result : REAL; BEGIN result:=0.0; IF argument_stack_head = NIL THEN set_error( 'argument to "'+function_name+'" is missing') ELSE BEGIN argument:=pop_argument(argument_stack_head); IF argument_stack_head = NIL THEN IF argument < 0.0 THEN set_error( 'argument to "'+function_name+ '" is negative') ELSE result:=SQRT(argument) ELSE set_error( 'extraneous argument supplied to function "'+ function_name+'"') END; sqrt_function:=result END; FUNCTION simple_expression : REAL; FORWARD; FUNCTION funct : REAL; VAR argument : REAL; argument_stack_head : argument_record_ptr; argument_stack_ptr : argument_record_ptr; arguments_okay : BOOLEAN; function_name : string_255; non_alphanumeric_found : BOOLEAN; result : REAL; right_parenthesis_found : BOOLEAN; tem_char : CHAR; BEGIN result:=0.0; non_alphanumeric_found:=FALSE; function_name:=''; WHILE((expression_index <= expression_length) AND (NOT non_alphanumeric_found)) DO BEGIN tem_char:=expression[expression_index]; tem_char:=UPCASE(tem_char); IF ((tem_char >= 'A') AND (tem_char <= 'Z')) THEN BEGIN function_name:=function_name+tem_char; expression_index:=expression_index+1 END ELSE non_alphanumeric_found:=TRUE END; argument_stack_head:=NIL; arguments_okay:=TRUE; eat_leading_spaces; IF expression_index <= expression_length THEN BEGIN tem_char:=expression[expression_index]; IF tem_char = '(' THEN BEGIN expression_index:=expression_index+1; right_parenthesis_found:=FALSE; WHILE ((NOT right_parenthesis_found) AND (arguments_okay) AND (expression_index <= expression_length)) DO BEGIN argument:=simple_expression; IF error_detected THEN arguments_okay:=FALSE ELSE BEGIN IF argument_stack_head = NIL THEN BEGIN NEW(argument_stack_head); argument_stack_head^.value:=argument; argument_stack_head^.next_ptr:=NIL END ELSE BEGIN NEW(argument_stack_ptr); argument_stack_ptr^.value:=argument; argument_stack_ptr^.next_ptr :=argument_stack_head; argument_stack_head:=argument_stack_ptr END; eat_leading_spaces; IF expression_index <= expression_length THEN BEGIN tem_char:=expression[expression_index]; IF tem_char = ')' THEN BEGIN right_parenthesis_found:=TRUE; expression_index:=expression_index+1 END ELSE IF tem_char = ',' THEN expression_index:=expression_index+1 ELSE BEGIN arguments_okay:=FALSE; set_error( 'comma missing from function arguments') END END END END; IF arguments_okay THEN BEGIN IF (NOT right_parenthesis_found) THEN BEGIN arguments_okay:=FALSE; set_error( '")" to terminate function arguments is missing') END END END END; IF arguments_okay THEN BEGIN IF function_name = 'ABS' THEN result :=abs_function(argument_stack_head,function_name) ELSE IF function_name = 'ARCTAN' THEN result :=arctan_function(argument_stack_head,function_name) ELSE IF function_name = 'COS' THEN result :=cos_function(argument_stack_head,function_name) ELSE IF function_name = 'EXP' THEN result :=exp_function(argument_stack_head,function_name) ELSE IF function_name = 'LN' THEN result :=ln_function(argument_stack_head,function_name) ELSE IF function_name = 'PI' THEN result :=pi_function(argument_stack_head,function_name) ELSE IF function_name = 'SIN' THEN result :=sin_function(argument_stack_head,function_name) ELSE IF function_name = 'SQR' THEN result :=sqr_function(argument_stack_head,function_name) ELSE IF function_name = 'SQRT' THEN result :=sqrt_function(argument_stack_head,function_name) ELSE set_error('the function "'+ function_name+'" is unrecognized') END; WHILE (argument_stack_head <> NIL) DO BEGIN argument_stack_ptr:=argument_stack_head^.next_ptr; DISPOSE(argument_stack_head); argument_stack_head:=argument_stack_ptr END; funct:=result END; FUNCTION factor : REAL; VAR result : REAL; tem_char : CHAR; BEGIN result:=0.0; eat_leading_spaces; IF expression_index > expression_length THEN set_error( 'end of expression encountered where factor expected') ELSE BEGIN tem_char:=expression[expression_index]; BEGIN IF tem_char = '(' THEN BEGIN expression_index:=expression_index+1; result:=simple_expression; IF (NOT error_detected) THEN BEGIN eat_leading_spaces; IF expression_index > expression_length THEN set_error( 'end of expression encountered '+ 'where ")" was expected') ELSE IF expression[expression_index] = ')' THEN expression_index:=expression_index+1 ELSE set_error('expression not followed by ")"') END END ELSE IF ((tem_char >= '0') AND (tem_char <= '9')) THEN result:=unsigned_number ELSE IF (((tem_char >= 'a') AND (tem_char <= 'z')) OR ((tem_char >= 'A') AND (tem_char <= 'Z'))) THEN result:=funct ELSE set_error( 'function, unsigned number, or "(" expected') END END; factor:=result END; FUNCTION quotient_of_factors(VAR left_value,right_value : REAL) : REAL; VAR result : REAL; tem_real : REAL; BEGIN result:=0.0; IF right_value = 0.0 THEN set_error('division by zero attempted') ELSE BEGIN IF left_value = 0.0 THEN result:=0.0 ELSE BEGIN tem_real:=(LN(ABS(left_value))-LN(ABS(right_value)))/LN(10.0); IF tem_real < -37.0 THEN result:=0.0 ELSE IF tem_real > 37.0 THEN set_error( 'overflow detected during division') ELSE result:=left_value/right_value END END; quotient_of_factors:=result END; FUNCTION product_of_factors(VAR left_value,right_value : REAL) : REAL; VAR result : REAL; tem_real : REAL; BEGIN result:=0.0; IF ((left_value <> 0.0) AND (right_value <> 0.0)) THEN BEGIN tem_real:=(LN(ABS(left_value))+LN(ABS(right_value)))/LN(10.0); IF tem_real < -37.0 THEN result:=0.0 ELSE IF tem_real > 37.0 THEN set_error( 'overflow detected during multiplication') ELSE result:=left_value*right_value END; product_of_factors:=result END; FUNCTION factor_operator : string_1; VAR result : string_1; BEGIN eat_leading_spaces; IF expression_index <= expression_length THEN BEGIN result:=expression[expression_index]; IF ((result = '*') OR (result = '/')) THEN expression_index:=expression_index+1 END ELSE result:=''; factor_operator:=result END; FUNCTION term : REAL; VAR operator : string_1; operator_found : BOOLEAN; result : REAL; right_value : REAL; BEGIN result:=0; eat_leading_spaces; IF expression_index > expression_length THEN set_error( 'end of expression encountered where term was expected') ELSE BEGIN result:=factor; operator_found:=TRUE; WHILE((NOT error_detected) AND (operator_found)) DO BEGIN operator:=factor_operator; IF LENGTH(operator) = 0 THEN operator_found:=FALSE ELSE IF ((operator <> '*') AND (operator <> '/')) THEN operator_found:=FALSE ELSE BEGIN right_value:=factor; IF (NOT error_detected) THEN BEGIN IF operator = '*' THEN result:=product_of_factors( result,right_value) ELSE result:=quotient_of_factors( result,right_value) END END END END; term:=result END; FUNCTION sum_of_terms(VAR left_value,right_value : REAL) : REAL; VAR result : REAL; BEGIN result:=0.0; IF ((left_value > 0.0) AND (right_value > 0.0)) THEN IF left_value > (1.0E37 - right_value) THEN set_error('overflow detected during addition') ELSE result:=left_value+right_value ELSE IF ((left_value < 0.0) AND (right_value < 0.0)) THEN IF left_value < (-1.0E37 - right_value) THEN set_error('overflow detected during addition') ELSE result:=left_value+right_value ELSE result:=left_value+right_value; sum_of_terms:=result END; FUNCTION difference_of_terms(VAR left_value,right_value : REAL) : REAL; VAR result : REAL; BEGIN IF ((left_value < 0.0) AND (right_value > 0.0)) THEN IF left_value < (right_value - 1.0E37) THEN set_error('overflow detected during subtraction') ELSE result:=left_value-right_value ELSE IF ((left_value > 0.0) AND (right_value < 0.0)) THEN IF left_value > (right_value + 1.0E37) THEN set_error('overflow detected during subtraction') ELSE result:=left_value-right_value ELSE result:=left_value-right_value; difference_of_terms:=result END; FUNCTION term_operator : string_1; VAR result : string_1; BEGIN eat_leading_spaces; IF expression_index <= expression_length THEN BEGIN result:=expression[expression_index]; IF ((result = '+') OR (result = '-')) THEN expression_index:=expression_index+1 END ELSE result:=''; term_operator:=result END; FUNCTION simple_expression; VAR leading_sign : CHAR; operator : string_1; operator_found : BOOLEAN; result : REAL; right_value : REAL; tem_char : CHAR; BEGIN result:=0.0; eat_leading_spaces; IF expression_index > expression_length THEN set_error( 'end of expression encountered where simple expression expected') ELSE BEGIN leading_sign:=' '; tem_char:=expression[expression_index]; IF ((tem_char = '+') OR (tem_char = '-')) THEN BEGIN leading_sign:=tem_char; expression_index:=expression_index+1 END; result:=term; IF (NOT error_detected) THEN BEGIN IF leading_sign <> ' ' THEN BEGIN IF leading_sign = '-' THEN result:=-result END; operator_found:=TRUE; WHILE((NOT error_detected) AND (operator_found)) DO BEGIN operator:=term_operator; IF LENGTH(operator) = 0 THEN operator_found:=FALSE ELSE IF ((operator <> '+') AND (operator <> '-')) THEN operator_found:=FALSE ELSE BEGIN right_value:=term; IF (NOT error_detected) THEN BEGIN IF operator = '+' THEN result:=sum_of_terms( result,right_value) ELSE result:=difference_of_terms( result,right_value) END END END END END; simple_expression:=result END; PROCEDURE output_value(VAR result : REAL); VAR digits_in_integer_part : INTEGER; magnitude_of_result : REAL; BEGIN WRITE(OUTPUT,'Value: '); IF result >= 0.0 THEN magnitude_of_result:=result ELSE magnitude_of_result:=-result; IF magnitude_of_result >= 5.0E-3 THEN BEGIN digits_in_integer_part:=0; WHILE ((digits_in_integer_part <= 8) AND (magnitude_of_result >= 1.0)) DO BEGIN magnitude_of_result:=magnitude_of_result/10.0; digits_in_integer_part:=digits_in_integer_part+1 END; IF digits_in_integer_part > 8 THEN WRITELN(OUTPUT,result:13) ELSE WRITELN(OUTPUT,result:10:8-digits_in_integer_part) END ELSE WRITELN(OUTPUT,result:13) END; PROCEDURE output_error( error_msg : string_255; VAR expression : string_255; VAR expression_index : INTEGER); VAR error_index : INTEGER; BEGIN WRITELN(OUTPUT,error_msg); WRITELN(OUTPUT,expression); error_index:=1; WHILE (error_index < expression_index) DO BEGIN WRITE(OUTPUT,' '); error_index:=error_index+1 END; WRITELN(OUTPUT,'*') END; BEGIN REPEAT WRITELN(OUTPUT,' '); WRITE(OUTPUT,'Expression (RETURN to exit)? '); READLN(INPUT,expression); expression_length:=LENGTH(expression); IF expression_length > 0 THEN BEGIN error_detected:=FALSE; expression_index:=1; result:=simple_expression; IF error_detected THEN output_error(error_msg,expression,expression_index) ELSE BEGIN eat_leading_spaces; IF expression_index <= expression_length THEN output_error( 'Error: expression followed by garbage', expression,expression_index) ELSE output_value(result) END END UNTIL (expression_length = 0) END.