home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS 1992 September
/
Simtel20_Sept92.cdr
/
msdos
/
calcultr
/
calculat.arc
/
CALCULAT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1986-02-27
|
35KB
|
943 lines
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.
