{$M+} {$E+} PROGRAM Mock; {$I i:\opus.i} {$I i:\gctv.inc} {$I d:\pascal\opus\xbios.def} PROCEDURE STRIP_NUM ( VAR num_str : LorFstr; VAR str : LorFstr; VAR str_pos, len : INTEGER ); EXTERNAL; FUNCTION TRANSLATE_CELL ( VAR str : LorFstr; { cell_str or formula } VAR str_pos : INTEGER; { position; 1 for cell } len : INTEGER; { length of string } VAR row,col : INTEGER; VAR row_rel, { relative reference? } col_rel : BOOLEAN ) : StatusType; EXTERNAL; PROCEDURE ALL_LISTS ( action : INTEGER; ptr : CellPtr; row,col : INTEGER ); EXTERNAL; FUNCTION VALID_NUMBER ( VAR num_str : LorFstr ) : StatusType; EXTERNAL; FUNCTION STRING_TO_REAL ( VAR string_real : STR30 ) : REAL; EXTERNAL; FUNCTION REQUEST_MEMORY ( what : ReqType ) : BOOLEAN; EXTERNAL; FUNCTION LOCATE_CELL ( row,col : INTEGER ) : CellPtr; EXTERNAL; FUNCTION NEW_CELL ( row,col : INTEGER ) : CellPtr; EXTERNAL; PROCEDURE DELETE_CELL ( r,c : INTEGER; free_dep : BOOLEAN ); EXTERNAL; PROCEDURE FIND_SCREEN_POS ( row,col : INTEGER; VAR l_scr_row,l_scr_col : INTEGER ); EXTERNAL; PROCEDURE CELL_ON_SCREEN ( draw_or_toggle,row,col : INTEGER; force : BOOLEAN ); EXTERNAL; FUNCTION ASSIGNED ( row,col : INTEGER; VAR ptr : CellPtr ) : AssignedStatus; EXTERNAL; PROCEDURE Set_Mouse ( a : Mouse_Type ); EXTERNAL; PROCEDURE ERROR_MESSAGE ( VAR str : LorFstr; error : StatusType; str_pos,len : INTEGER ); EXTERNAL; { following are EXP & LN functions to use instead of library, since lib is only accurate to 6-9 digits. These are reasonably quick and accurate to 10+ digits. Use range reduction to get a number favorable for power-series calculations, then laws of exponents/logarithms for final result. } FUNCTION MY_EXP ( x : REAL ) : REAL; VAR n,whole_num,i : INTEGER; sum,prod,frac,term : REAL; neg : BOOLEAN; BEGIN i := 1; { index into e_table } prod := 1; whole_num := TRUNC(x); { got the integer part } neg := whole_num < 0; frac := x-whole_num; { keeps sign of x } whole_num := ABS(whole_num); WHILE whole_num <> 0 DO BEGIN IF whole_num & 1 <> 0 THEN { LSB set? } IF neg THEN prod := prod/e_table[i] ELSE prod := prod*e_table[i]; whole_num := ShR(whole_num,1); { prepare to test next bit } i := i+1 END; { so now, e^(x - x MOD 1) has been calculated. ( MOD being a REAL mod ) Next calculate e^(x MOD 1), which will satisfy |x| < 1, using the MacLaurin series } n := 0 ; sum := 1; term := 1; REPEAT n := n+1; term := term*frac/n; sum := sum+term UNTIL ABS(term/sum) < 5E-12; { and finally combine prod & sum } my_exp := prod*sum END; { MY_EXP } FUNCTION MY_LN ( x : REAL ) : REAL; VAR j,c2,c10,sign : INTEGER; sum,term,power : REAL; BEGIN { First, normalize the number so that 0.5 < x < 1.0, so we can use the series described below. } IF x = 1 THEN my_ln := 0 ELSE BEGIN c10 := 0; WHILE x > 1 DO BEGIN x := x/10; c10 := c10+1 { have to 'multiply' later so positive c10 } END; WHILE x < 0.1 DO BEGIN x := x*10; c10 := c10-1 { have to 'divide' later so negative c10 } END; c2 := 0; WHILE x < 0.5 DO BEGIN x := x*2; c2 := c2-1; END; sum := 0; IF x < 1 THEN BEGIN { since we're between 0.5 and 1.0, we must subtract one from x so we in fact calculate ln(x), using the series which GIVES ln(1+x) } x := x-1; { Now calculate the Taylor series ln(1+X) = X-(1/2X^2)+(1/3X^3)-(1/4X^4)..., valid in the interval -1 < X <= -1, where incr = a term in the series, until ABS(incr/sum) < 5E-12, since a maximum of ten digits are available in the fractional part of the mantissa. Caveat: since the series include terms that alternate in sign, significant cancellation error can occur with numbers like 1.00001. The lib provides 5 digits. The worst case for this one is about 7 digit precision. The real problem is that the lib mult/div routines apparently work with a number format identical to the one "visible" TO us, 6 bytes. It SHOULD work with an expanded prec number and round the final result } j := 1; sign := 1; power := x; REPEAT term := 1/j*power; sum := sum+term; sign := -sign; j := (abs(j)+1)*sign; power := power*x UNTIL ABS(term/sum) < 5E-12 END; my_ln := sum+c10*Ln10+c2*Ln2 { combine } END END; { MY_LN } PROCEDURE EVALUATE_FORMULA ( row,col : INTEGER; force, new_form : BOOLEAN; cell : CellPtr ); LABEL 1,2; VAR str_pos,len : INTEGER; result,old_num : REAL; dep : DepPtr; stat,old_status : StatusType; ptr : CellPtr; (*************************************************************************) (* EVALUATE_FORMULA is the parent proc; see body of it for details *) (*************************************************************************) PROCEDURE FULL_EXPR ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL ); FORWARD; FUNCTION CHECK_BOOLOP ( VAR str : LorFstr; VAR bool_op : BoolOps; VAR stat : StatusType ) : BOOLEAN; FORWARD; FUNCTION EVAL_BOOLOP ( VAR bool_op : BoolOps; VAR arg_1, arg_2 : REAL ) : BOOLEAN; FORWARD; PROCEDURE VAL_EXPR ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL ); FORWARD; PROCEDURE TERM ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL ); FORWARD; PROCEDURE FACTOR ( VAR str : LorFstr; do_it, get_neg : BOOLEAN; VAR result : REAL ); FORWARD; PROCEDURE EXPONENTIATION_EXPR ( VAR str : LorFstr; do_it, get_neg : BOOLEAN; VAR result : REAL ); FORWARD; PROCEDURE EVAL_FUNCTION ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); FORWARD; PROCEDURE DO_SINGLE ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); FORWARD; PROCEDURE DO_MULTIPLE ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); FORWARD; PROCEDURE DO_DOUBLE ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); FORWARD; PROCEDURE DO_AGGREGATE ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); FORWARD; PROCEDURE DO_FINANCIAL ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); FORWARD; PROCEDURE DO_LOOKUP ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); FORWARD; PROCEDURE IF_EXPR ( VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL ); FORWARD; PROCEDURE ITS_PENDING; BEGIN cell^.format := cell^.format & no_recalc_mask & not_pending_mask; GOTO 2 END; PROCEDURE DO_ERROR ( VAR str : LorFstr ); { only invoke error-dialog if a new formula is being parsed } BEGIN IF new_form THEN BEGIN Set_Mouse(M_Arrow); error_message(str,stat,str_pos,len); Set_Mouse(M_Bee) END; GOTO 1 END; { DO_ERROR } FUNCTION FIND_FUNCTION ( VAR str : STR10; VAR func_code : AllFunctions ) : BOOLEAN; { binary search for function name in array functions } VAR low,mid,high : INTEGER; BEGIN find_function := FALSE; low := 1; high := n_functions; WHILE low <= high DO BEGIN mid := ( low+high ) DIV 2; IF str < functions[mid].func_name THEN high := mid-1 ELSE IF str > functions[mid].func_name THEN low := mid+1 ELSE BEGIN find_function := TRUE; func_code := functions[mid].func_type; low := high+1; { break } END END END; { FIND_FUNCTION } PROCEDURE GET_RANGE ( VAR str : LorFstr; do_it : BOOLEAN; VAR s_r,s_c,e_r,e_c : INTEGER ); { ::= : } VAR i,j : INTEGER; dummy,quit : BOOLEAN; ptr : CellPtr; BEGIN IF str_pos < len THEN IF str[str_pos] IN up_case+['$'] THEN BEGIN stat := translate_cell(str,str_pos,len,s_r,s_c,dummy,dummy); IF stat = OK THEN IF str_pos < len THEN IF str[str_pos] <> ':' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; stat := translate_cell(str,str_pos,len,e_r,e_c, dummy,dummy); IF stat = OK THEN IF (s_r > e_r) OR (s_c > e_c) THEN stat := BadRef ELSE IF do_it THEN IF natural THEN FOR i := s_r TO e_r DO BEGIN ptr := data[i]; quit := FALSE; WHILE (ptr <> NIL) AND (NOT quit) DO BEGIN IF (ptr^.c >= s_c) AND (ptr^.c <= e_c) THEN IF ptr^.class = Expr THEN IF ptr^.format & pending_mask <> 0 THEN its_pending ELSE IF ptr^.format & recalc_mask = 0 THEN BEGIN evaluate_formula(i,ptr^.c, force,FALSE, ptr); IF ptr^.format & recalc_mask = 0 THEN its_pending END ELSE ELSE ELSE IF ptr^.c > e_c THEN quit := TRUE; ptr := ptr^.next END END ELSE ELSE ELSE END ELSE stat := SyntaxErr ELSE END ELSE stat := SyntaxErr ELSE stat := SyntaxErr; IF stat <> OK THEN do_error(str) END; { GET_RANGE } FUNCTION ADD_OP ( a_char : CHAR; VAR op : CHAR ) : BOOLEAN; BEGIN op := a_char; add_op := (a_char = '+') OR (a_char = '-') END; { ADD_OP } FUNCTION MUL_OP ( a_char : CHAR; VAR op : CHAR ) : BOOLEAN; BEGIN op := a_char; mul_op := (a_char = '*') OR (a_char = '/') END; { ADD_OP } { some general crash-proofing routines; NOT exhaustive } FUNCTION CHECK_EXP ( what : REAL ) : BOOLEAN; BEGIN IF ABS(what) < 85 THEN check_exp := TRUE ELSE check_exp := FALSE END; { CHECK_EXP } FUNCTION CHECK_SQUARE ( what : REAL ) : BOOLEAN; BEGIN IF (ABS(what) > MaxSquare) OR ( (ABS(what) < MinSquare) AND (what <> 0) ) THEN check_square := FALSE ELSE check_square := TRUE END; { CHECK_SQUARE } FUNCTION FRACTION ( what : REAL; VAR str : LorFstr ) : REAL; BEGIN what := ABS(what); IF what > Long_Maxint THEN BEGIN stat := Overflow; do_error(str) END ELSE fraction := what-LONG_TRUNC(what) END; { FRACTION } FUNCTION ODD_REAL ( what : REAL; VAR str : LorFstr ) : BOOLEAN; BEGIN IF fraction(what/2.0,str) > 0.25 THEN odd_real := TRUE { really should be = 0.5, but } ELSE { best to account for rounding } odd_real := FALSE { errors! } END; { ODD_REAL } { in general, status is checked at the end of all routines that can modify it, and if it isn't = OK, a jump is made to do_error, and evaluation is stopped at that point. Thus, when one routine calls another, if the "callee" returns, status is guaranteed to be OK and no checking of this by the "caller" is neccessary. Also, this ensures that the error returned is the "first" one encountered, which may not be the case if handled less rigorously. } PROCEDURE FULL_EXPR; { ::= | expr, val_expr, term, & factor are set up so that all arithmetic operations and functions preceding and following a boolop are executed before the conditional is tested, so that in effect, the boolop has lowest precedence of all, and 1+2+3<1+2*5 means 6 < 11. Note that expr like 1<2<3 won't be flagged as an error unless str_pos < len is checked upon return to evaluate_formula, since this routine can't look for this because it may be called by factor, and we wouldn't want to prematurely end with an error! } VAR result_1 : REAL; bool_op : BoolOps; BEGIN val_expr(str,do_it,result); IF str_pos < len THEN IF check_boolop(str,bool_op,stat) THEN BEGIN val_expr(str,do_it,result_1); IF do_it THEN IF eval_boolop(bool_op,result,result_1) THEN result := 1.0 ELSE result := 0.0 END; IF stat <> OK THEN do_error(str) END; { FULL_EXPR } FUNCTION CHECK_BOOLOP; { called by full_expr; at least 2 chars in str } BEGIN check_boolop := TRUE; IF str[str_pos] = '=' THEN BEGIN bool_op := Equal; str_pos := str_pos+1 END ELSE IF str[str_pos] = '>' THEN IF str[str_pos+1] = '=' THEN BEGIN bool_op := GreaterOrEqual; str_pos := str_pos+2 END ELSE BEGIN bool_op := Greater; str_pos := str_pos+1 END ELSE IF str[str_pos] = '<' THEN IF str[str_pos+1] = '=' THEN BEGIN bool_op := LesserOrEqual; str_pos := str_pos+2 END ELSE IF str[str_pos+1] = '>' THEN BEGIN bool_op := NotEqual; str_pos := str_pos+2 END ELSE BEGIN bool_op := Lesser; str_pos := str_pos+1 END ELSE check_boolop := FALSE END; { CHECK_BOOLOP } FUNCTION EVAL_BOOLOP; BEGIN CASE bool_op OF Equal : eval_boolop := arg_1 = arg_2; NotEqual : eval_boolop := arg_1 <> arg_2; Lesser : eval_boolop := arg_1 < arg_2; LesserOrEqual : eval_boolop := arg_1 <= arg_2; Greater : eval_boolop := arg_1 > arg_2; GreaterOrEqual : eval_boolop := arg_1 >= arg_2 END END; { EVAL_BOOLOP } PROCEDURE VAL_EXPR; (* ::= { } *) VAR result_1 : REAL; continue : BOOLEAN; op : CHAR; BEGIN term(str,do_it,result); continue := TRUE; WHILE (str_pos < len) AND (continue) DO IF add_op(str[str_pos],op) THEN BEGIN str_pos := str_pos+1; term(str,do_it,result_1); IF do_it THEN IF op = '+' THEN result := result+result_1 ELSE result := result-result_1 END ELSE continue := FALSE; { break } IF stat <> OK THEN do_error(str) END; { VAL_EXPR } PROCEDURE TERM; (* ::= { } *) VAR result_1 : REAL; continue : BOOLEAN; op : CHAR; BEGIN factor(str,do_it,FALSE,result); continue := TRUE; WHILE (str_pos < len) AND (continue) DO IF mul_op(str[str_pos],op) THEN BEGIN str_pos := str_pos+1; factor(str,do_it,FALSE,result_1); IF do_it THEN IF op = '*' THEN result := result*result_1 ELSE IF result_1 = 0.0 THEN stat := DivBy0 ELSE result := result/result_1 END ELSE continue := FALSE; { break } IF stat <> OK THEN do_error(str) END; { TERM } PROCEDURE FACTOR; { ::= real | | | () | | - ::= <^> } VAR old_pos,row,col,temp_len : INTEGER; dummy,a_cell : BOOLEAN; func_code : AllFunctions; ptr : CellPtr; BEGIN { the things which come under the initial IF's scope all look for character patterns that indicate the start of a factor, a factor representing the fundamental data "chunk-size" the evaluator handles. And as can be seen from the grammar, all the operands indeed reduce to a factor, in one of its forms. In sum, a factor is an entity that is meant to be taken as a single number; in 1+2*3, 1,2,3 are factors, but 1+2 & 2*3 are NOT, while in 1*(2+3), 1,2,3 are factors but so is (2+3). Hence precedence is maintained. However, the exponentiation operator has highest precedence, so can't look for it in val_expr or term. And since the two operands joined by this op are meant to be taken as single numbers, it makes sense to define this type of expr as above, and check for the exp. op whenever a factor is retrieved. This is done at the end of this proc. Note that expressions such as 3^4^5 are perfectly legal and are evaluated right-to-left, so that 3 is raised to the 5th power of 4, NOT the the power 20, as is the case for (3^4)^5. Last point(!). If a^b is a factor, what happens if -a^b? Well, - expects a factor, and since a factor = a^b, we erroneously get negation AFTER the exponentiation. So, include a boolean to be passed to exponentiation_expr to indicate whether factor was called from the unary minus operator, and if so, DON'T look for ^. Rather, upon return to unary minus code, the factor is negated, and THEN we look for ^. } IF str_pos > len THEN stat := SyntaxErr ELSE IF str[str_pos] IN digits+['.'] THEN BEGIN strip_num(num_str,str,str_pos,len); IF (new_form) OR (cell^.status < Full) THEN stat := valid_number(num_str); IF (stat = OK) AND (do_it) THEN BEGIN result := string_to_real(num_str); IF num_str = 'OVERFLOW' THEN stat := Overflow ELSE IF str_pos <= len THEN IF str[str_pos] = '%' THEN BEGIN result := result/100; str_pos := str_pos+1 END END ELSE IF NOT do_it THEN IF str_pos <= len THEN IF str[str_pos] = '%' THEN str_pos := str_pos+1 ELSE ELSE ELSE END ELSE IF str_pos < len THEN IF str[str_pos] IN up_case+['$'] THEN BEGIN a_cell := FALSE; IF (str[str_pos] = '$') OR (str[str_pos+1] IN digits+['$']) THEN a_cell := TRUE ELSE IF str_pos+1 < len THEN IF (str[str_pos+1] IN up_case) AND (str[str_pos+2] IN digits+['$']) THEN a_cell := TRUE; IF a_cell THEN BEGIN stat := translate_cell(str,str_pos,len,row,col,dummy,dummy); IF (stat = OK) AND (do_it) THEN BEGIN ptr := locate_cell(row,col); IF ptr <> NIL THEN WITH ptr^ DO IF class <> Labl THEN BEGIN IF (class = Expr) AND (natural) THEN IF format & pending_mask <> 0 THEN its_pending ELSE IF format & recalc_mask = 0 THEN BEGIN evaluate_formula(row,col,force,FALSE,ptr); IF format & recalc_mask = 0 THEN its_pending END; IF status = Full THEN result := num ELSE IF status = Empty THEN result := 0 ELSE stat := status END ELSE result := 0 ELSE result := 0 END ELSE END ELSE BEGIN { function name? } old_pos := str_pos; WHILE (str[str_pos] IN up_case) AND (str_pos < len) DO str_pos := str_pos+1; { when done, str_pos = pos following "name" } temp_len := str_pos-old_pos; IF (temp_len > 7) OR (temp_len < 2) OR (str_pos = len) THEN stat := SyntaxErr ELSE BEGIN temp := COPY(str,old_pos,temp_len); IF find_function(temp,func_code) THEN eval_function(str,do_it,result,func_code ) ELSE stat := SyntaxErr END END END ELSE BEGIN str_pos := str_pos+1; CASE str[str_pos-1] OF '(' : BEGIN { something in parentheses can be a 'full' expression, so we can have things like (1+COS(2*A1))/2 and A1>(A2+A3)*5 } full_expr(str,do_it,result); IF str_pos <= len THEN IF str[str_pos] <> ')' THEN stat := SyntaxErr ELSE str_pos := str_pos+1 ELSE stat := SyntaxErr END; '-' : BEGIN { use factor because negation such as -5+3 would result in evaluation as if it were written -(5+3), possible if full_expr was used, giving an addop higher precedence than the negation op. Note that 3^-3 is handled correctly. } factor(str,do_it,TRUE,result); IF do_it THEN result := -result END; OTHERWISE : stat := SyntaxErr END { CASE } END ELSE { str_pos did = len; a number was the only valid possibility } stat := SyntaxErr; { and it has already been looked for } IF stat <> OK THEN do_error(str) ELSE exponentiation_expr(str,do_it,get_neg,result) END; { FACTOR } PROCEDURE EXPONENTIATION_EXPR; { ::= ^ } { stat guaranteed to be OK; only one call to this, in FACTOR } VAR sign : INTEGER; result_1,work_real : REAL; BEGIN IF NOT get_neg THEN IF str_pos < len THEN IF str[str_pos] = '^' THEN BEGIN str_pos := str_pos+1; factor(str,do_it,FALSE,result_1); IF do_it THEN IF result = 0.0 THEN { check for crash } stat := Undefined ELSE IF result < 0.0 THEN BEGIN IF fraction(result_1,str) <> 0.0 THEN stat := Undefined { can't do -2^8.5; what would } ELSE BEGIN { the sign be? } IF odd_real(result_1,str) THEN sign := -1 ELSE sign := 1; IF check_exp(result_1*my_ln(ABS(result))) THEN result := sign*my_exp(result_1*my_ln(ABS(result))) ELSE stat := Overflow END END ELSE IF check_exp(result_1*my_ln(result)) THEN result := my_exp(result_1*my_ln(result)) ELSE stat := Overflow END; IF stat <> OK THEN do_error(str) END; { EXPONENTIATION_EXPR } PROCEDURE EVAL_FUNCTION; BEGIN IF str_pos > len THEN stat := SyntaxErr ELSE IF str[str_pos] <> '(' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; IF func_code IN Single THEN do_single(str,do_it,result,func_code) ELSE IF func_code IN Double THEN do_double(str,do_it,result,func_code) ELSE IF func_code IN Multiple THEN do_multiple(str,do_it,result,func_code) ELSE IF func_code IN Aggregate THEN do_aggregate(str,do_it,result,func_code) ELSE IF func_code IN Financial THEN do_financial(str,do_it,result,func_code) ELSE IF func_code IN LookUp THEN do_lookup(str,do_it,result,func_code) ELSE IF func_code = IfOp THEN if_expr(str,do_it,result); IF str_pos > len THEN stat := SyntaxErr ELSE IF str[str_pos] <> ')' THEN stat := SyntaxErr ELSE str_pos := str_pos+1 END; IF stat <> OK THEN do_error(str) END; { EVAL_FUNCTION } (**************************************************************************) (* Single/No Argument Functions: Transcendental, Conversion, Factorial... *) (**************************************************************************) PROCEDURE DO_SINGLE; { simple_function ::= | } VAR i,limit : INTEGER; mag_num,temp : REAL; BEGIN (*********************************************) (* functions with no arguments; result = f() *) (*********************************************) IF func_code = PiOp THEN IF do_it THEN result := pi ELSE (*************************************************) (* functions with single argument; result = f(x) *) (*************************************************) ELSE BEGIN full_expr(str,do_it,result); IF do_it THEN BEGIN mag_num := ABS(result); CASE func_code OF (***************************) (* transfer-like functions *) (***************************) AbsOp : result := mag_num; DegOp : result := result*DegPerRad; RadOp : result := result/DegPerRad; (******************) (* trig functions *) (******************) SinOp : result := SIN(result); CosOp : result := COS(result); TanOp : IF COS(result) <> 0 THEN { best to use Pascal rather } { than magnum<>halfpi; avoid } result := SIN(result)/COS(result) { roundoff error } ELSE stat := Undefined; AsinOp : IF (mag_num > 1) OR ((result <> 0) AND (mag_num < MinSquare)) THEN stat := Undefined ELSE IF mag_num = 1 THEN result := HalfPi*result ELSE result := ArcTan(result/SQRT(1-result*result)); ACosOp : IF (mag_num > 1) OR ((result <> 0) AND (mag_num < MinSquare)) THEN stat := Undefined ELSE IF mag_num = 1 THEN result := 0 ELSE result := -ArcTan(result/SQRT(1-result*result))+ HalfPi; AtanOp : result := ArcTan(result); (*******************) (* power functions *) (*******************) LogOp : IF result > 0 THEN result := my_ln(result)/ln10 ELSE stat := Undefined; LnOp : IF result > 0 THEN result := my_ln(result) ELSE stat := Undefined; ExpOp : IF check_exp(result) THEN result := my_exp(result) ELSE stat := Overflow; SqrOp : IF NOT check_square(mag_num) THEN stat := Overflow ELSE result := SQR(result); SqrtOp : IF result >= 0 THEN result := SQRT(result) ELSE stat := Undefined; (*****************) (* miscellaneous *) (*****************) FacOp : IF result > 33 THEN stat := Overflow ELSE IF result < 0 THEN stat := Undefined ELSE IF result <> ROUND(result) THEN stat := Undefined { we don't do gamma functions } ELSE BEGIN limit := ROUND(result); temp := 1; FOR i := 2 TO limit DO temp := temp*i; result := temp END; NotOp : IF result = 0 THEN result := 1 ELSE result := 0 END { CASE } END { IF do_it } END; { ELSE; func_code <> pi } END; { DO_SINGLE } (***********************************************) (* Functions with 2 arguments *) (* ::= funcname(,) *) (***********************************************) PROCEDURE DO_DOUBLE; VAR rmag2 : INTEGER; temp,arg1,arg2,mag1,mag2 : REAL; BEGIN full_expr(str,do_it,arg1); IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; full_expr(str,do_it,arg2); IF do_it THEN BEGIN mag1 := ABS(arg1); mag2 := ABS(arg2); CASE func_code OF DivOp : { integer division } IF arg2 = 0 THEN stat := DivBy0 ELSE IF (mag1 > Long_Maxint) OR (mag2 > Long_Maxint) THEN stat := Overflow ELSE result := LONG_TRUNC(arg1) DIV LONG_TRUNC(arg2); ModOp : { REAL modulo function } IF arg2 = 0 THEN stat := DivBy0 ELSE IF mag1/mag2 > Long_Maxint THEN stat := Overflow ELSE result := arg1-LONG_TRUNC(arg1/arg2)*arg2; RoundOp,TruncOp : IF mag2 > 10 THEN stat := Overflow ELSE BEGIN rmag2 := ROUND(mag2); IF arg2 > 0 THEN temp := arg1*PwrOfTen(rmag2) ELSE temp := arg1/PwrOfTen(rmag2); IF ABS(temp) > Long_Maxint THEN stat := Overflow ELSE IF arg2 > 0 THEN IF func_code = RoundOp THEN result := LONG_ROUND(temp)/PwrOfTen(rmag2) ELSE result := LONG_TRUNC(temp)/PwrOfTen(rmag2) ELSE IF func_code = RoundOp THEN result := LONG_ROUND(temp)*PwrOfTen(rmag2) ELSE result := LONG_TRUNC(temp)*PwrOfTen(rmag2) END; RandOp : BEGIN result := ABS(Random_Number/16777215.0); IF ABS(result*(arg2-arg1+1)) > Long_Maxint THEN stat := Overflow ELSE result := arg1+result*(arg2-arg1); END END { CASE } END { IF do_it } END { ELSE } ELSE stat := SyntaxErr; IF stat <> OK THEN do_error(str) END; { DO_DOUBLE } PROCEDURE DO_MULTIPLE; VAR count,i : INTEGER; quit : BOOLEAN; args : ARRAY [1..20] OF REAL; BEGIN quit := FALSE; count := 1; full_expr(str,do_it,args[count]); IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN WHILE (str_pos < len) AND (NOT quit) AND (stat = OK) DO IF str[str_pos] = ',' THEN BEGIN str_pos := str_pos+1; count := count+1; full_expr(str,do_it,args[count]) END ELSE IF str_pos > len THEN stat := SyntaxErr ELSE quit := TRUE; IF (stat = OK) AND (do_it) THEN IF func_code = AndOp THEN BEGIN result := 1; FOR i := 1 TO count DO IF args[i] = 0 THEN result := 0 ELSE END ELSE IF func_code = OrOp THEN BEGIN result := 0; FOR i := 1 TO count DO IF args[i] <> 0 THEN result := 1 ELSE END END ELSE stat := SyntaxErr; IF stat <> OK THEN do_error(str) END; { DO_MULTIPLE } (*************************************************************) (* Aggregate/Statistical Functions; main routine is DO_STATS *) (*************************************************************) PROCEDURE DO_MAX_MIN ( s_r,s_c,e_r,e_c : INTEGER; VAR str : LorFstr; VAR result : REAL; func_code : AllFunctions ); VAR i,j : INTEGER; found,quit : BOOLEAN; a : AssignedStatus; ptr,dummy : CellPtr; BEGIN found := FALSE; i := s_r; { first get a value within the range } WHILE (i <= e_r) AND (NOT found) DO BEGIN ptr := data[i]; WHILE (ptr <> NIL) AND (NOT found) DO BEGIN IF (ptr^.c >= s_c) AND (ptr^.c <= e_c) THEN BEGIN a := assigned(i,ptr^.c,dummy); IF a = Value THEN BEGIN result := ptr^.num; found := TRUE END END; ptr := ptr^.next END; i := i+1; END; IF NOT found THEN { no value in range } stat := GenError ELSE FOR i := s_r TO e_r DO BEGIN quit := FALSE; ptr := data[i]; WHILE (ptr <> NIL) AND (NOT (quit)) DO BEGIN IF (ptr^.c >= s_c) AND (ptr^.c <= e_c) THEN BEGIN a := assigned(i,ptr^.c,dummy); IF a = Value THEN IF func_code = MaxOp THEN IF ptr^.num > result THEN result := ptr^.num ELSE ELSE { MinOp } IF ptr^.num < result THEN result := ptr^.num END ELSE IF ptr^.c > e_c THEN quit := TRUE; ptr := ptr^.next END END; IF stat <> OK THEN do_error(str) END; { DO_MAX_MIN } PROCEDURE DO_SUM_AND_MULT ( s_r,s_c,e_r,e_c : INTEGER; VAR str : LorFstr; VAR result : REAL; VAR count : INTEGER; action : SumSqrProd ); { returns the _____ of cells with AssignedStatus = Value within a range: 1. SUM (Sum) , 2. SUM of SQUARES (SumSquares), 3. PRODUCT (Product). } VAR i : INTEGER; quit : BOOLEAN; a : AssignedStatus; ptr,dummy : CellPtr; BEGIN IF action = Product THEN result := 1 ELSE result := 0; count := 0; i := s_r; WHILE (i <= e_r) AND (stat = OK) DO BEGIN quit := FALSE; ptr := data[i]; WHILE (ptr <> NIL) AND (NOT quit) DO BEGIN IF (ptr^.c >= s_c) AND (ptr^.c <= e_c) THEN BEGIN a := assigned(i,ptr^.c,dummy); IF a = Value THEN BEGIN count := count+1; IF action = Product THEN result := result*ptr^.num ELSE IF action = Sum THEN result := result+ptr^.num ELSE IF check_square(ptr^.num) THEN result := result+SQR(ptr^.num) ELSE stat := Overflow END ELSE IF a = Error THEN stat := ptr^.status END ELSE IF ptr^.c > e_c THEN quit := TRUE; ptr := ptr^.next END; i := i+1 END; IF stat <> OK THEN do_error(str) END; { DO_SUM_AND_MULT } PROCEDURE DO_REGRESSION ( ys_r,ys_c,ye_r,ye_c : INTEGER; VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); { Note: the arrays needn't be adjacent, oriented in the same direction, or even linear in shape; however, they must both contain the same number of Value = AssignedStatus, and its the users duty to ensure that the correspondence between items is what he wants. Sums are done in ROW-MAJOR order, so for arrays spanning > 1 column: A B | C D 1 1 5 | 10 14 2 2 6 | 11 15 3 3 7 | 12 16 4 4 8 | 13 17 A1 relates to C1, B2 relates to D2, etc. if called as func(A1:B4,C1:D4). Thus have to use an iterative method to traverse range, rather than a simple list traversal, to make the routine reasonable } VAR i,j,xs_r,xs_c,xe_r,xe_c,y_n,x_n,n : INTEGER; y_sum,y_sumsqr,x_sum,x_sumsqr,xy_sum, denom,slope,y_int,predict_arg : REAL; ptr : CellPtr; PROCEDURE DO_XYSUM ( VAR xy_sum : REAL ); { guaranteed to be = # values in y and x arrays; use both y_done & x_done even though they both must be out of data at the same time, in order to clarify things. So, user can have arrays where there isn't explicit 1-1 coorespondence between items; matching of items is on a column-major basis } VAR y_r,y_c,x_r,x_c,y_row,y_col,x_row,x_col : INTEGER; y_done,x_done,y_found,x_found : BOOLEAN; ptrx,ptry : CellPtr; BEGIN xy_sum := 0; y_done := FALSE; x_done := FALSE; y_r := ys_r; y_c := ys_c; x_r := xs_r; x_c := xs_c; REPEAT y_found := FALSE; x_found := FALSE; { get a y-value } WHILE (NOT y_found) AND (NOT y_done) DO BEGIN IF assigned(y_r,y_c,ptry) = Value THEN BEGIN y_found := TRUE; y_row := y_r; y_col := y_c; END; IF y_r = ye_r THEN BEGIN { last row? } y_r := ys_r; { make it first row } IF y_c = ye_c THEN { last col? } y_done := TRUE { we're through } ELSE y_c := y_c+1 { no we're not! } END ELSE y_r := y_r+1 { down a row } END; { go for x-value } WHILE (NOT x_found) AND (NOT x_done) DO BEGIN IF assigned(x_r,x_c,ptrx) = Value THEN BEGIN x_found := TRUE; x_row := x_r; x_col := x_c; END; IF x_r = xe_r THEN BEGIN x_r := xs_r; IF x_c = xe_c THEN x_done := TRUE ELSE x_c := x_c+1 END ELSE x_r := x_r+1 END; IF (y_found) AND (x_found) THEN xy_sum := xy_sum+ptry^.num*ptrx^.num UNTIL (y_done) AND (x_done) END; { DO_XYSUM } BEGIN { DO_REGRESSION } IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; get_range(str,do_it,xs_r,xs_c,xe_r,xe_c); IF func_code = PredVOp THEN IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; full_expr(str,do_it,predict_arg); END ELSE stat := SyntaxErr; IF stat = OK THEN BEGIN do_sum_and_mult(ys_r,ys_c,ye_r,ye_c,str,y_sum,y_n,Sum); do_sum_and_mult(xs_r,xs_c,xe_r,xe_c,str,x_sum,x_n,Sum); IF NOT check_square(x_sum) THEN stat := Overflow ELSE IF (y_n <> x_n) OR (y_n < 2) THEN stat := Undefined ELSE BEGIN n := y_n; do_sum_and_mult(ys_r,ys_c,ye_r,ye_c,str, y_sumsqr,n,SumSquares); do_sum_and_mult(xs_r,xs_c,xe_r,xe_c,str, x_sumsqr,n,SumSquares); do_xysum(xy_sum); IF (func_code = LinROp) OR (func_code = PredVOp) THEN BEGIN denom := n*x_sumsqr-SQR(x_sum); IF denom = 0 THEN stat := DivBy0 ELSE BEGIN slope := (n*xy_sum-x_sum*y_sum)/denom; y_int := (y_sum*x_sumsqr-x_sum*xy_sum)/denom; IF func_code = PredVOp THEN result := slope*predict_arg+y_int { y = mx+b } ELSE BEGIN result := slope; IF col < n_cols THEN BEGIN delete_cell(row,col+1,FALSE); ptr := new_cell(row,col+1); ptr^.num := y_int; ptr^.status := Full; cell_on_screen(1,row,col+1,TRUE) END END END END ELSE IF NOT check_square(y_sum) THEN stat := Overflow ELSE BEGIN { CorrOp } denom := (x_sumsqr-n*SQR(x_sum/n)) * (y_sumsqr-n*SQR(y_sum/n)); IF denom = 0 THEN stat := DivBy0 ELSE IF denom < 0 THEN stat := Undefined ELSE BEGIN denom := SQRT(denom); result := (xy_sum-n*x_sum/n*y_sum/n)/denom END END END END END ELSE stat := SyntaxErr; IF stat <> OK THEN do_error(str) END; { DO_REGRESSION } PROCEDURE DO_STATS ( s_r,s_c,e_r,e_c : INTEGER; VAR str : LorFstr; do_it : BOOLEAN; VAR result : REAL; func_code : AllFunctions ); VAR i,j,count : INTEGER; result_1 : REAL; BEGIN CASE func_code OF (**************************************) (* Arithmetic aggregate functions *) (* ::= funcname() *) (**************************************) SumOp,MeanOp : BEGIN do_sum_and_mult(s_r,s_c,e_r,e_c,str,result,count,Sum); IF func_code = MeanOp THEN IF count = 0 THEN stat := DivBy0 ELSE result := result/count END; ProdOp : BEGIN do_sum_and_mult(s_r,s_c,e_r,e_c,str,result,count,Product); IF count = 0 THEN result := 0 END; (****************************************) (* Sample Statistics ( NOT population ) *) (* ::= funcname() *) (****************************************) VarOp,SdevOp,SerrOp : BEGIN do_sum_and_mult(s_r,s_c,e_r,e_c,str,result,count,Sum); IF count < 2 THEN stat := Undefined ELSE IF NOT check_square(result) THEN stat := Overflow ELSE BEGIN do_sum_and_mult(s_r,s_c,e_r,e_c,str,result_1,count,SumSquares); IF count*result_1-SQR(result) < 0 THEN stat := Undefined ELSE BEGIN result := SQRT( (count*result_1-SQR(result)) / (count*(count-1)) ); IF func_code = VarOp THEN IF check_square(result) THEN result := SQR(result) ELSE stat := Overflow ELSE IF func_code = SerrOp THEN result := result/SQRT(count) END END END; (****************************************************************) (* Linear Regression functions *) (* & ::= funcname(,) *) (* ::= funcname(,,) *) (****************************************************************) LinROp,PredVOp,CorrOp : do_regression(s_r,s_c,e_r,e_c,str,do_it,result,func_code); END; { CASE } IF stat <> OK THEN do_error(str) END; { DO_STATS } PROCEDURE DO_AGGREGATE; VAR s_r,s_c,e_r,e_c,i,j : INTEGER; quit : BOOLEAN; ptr,dummy : CellPtr; BEGIN { checks for str_pos > len } get_range(str,do_it,s_r,s_c,e_r,e_c); { if returns, stat = ok } IF do_it THEN CASE func_code OF CountOp : BEGIN result := 0; FOR i := s_r TO e_r DO BEGIN quit := FALSE; ptr := data[i]; WHILE (ptr <> NIL) AND (NOT quit) DO BEGIN IF (ptr^.c >= s_c) AND (ptr^.c <= e_c) THEN IF assigned(i,ptr^.c,dummy) = Value THEN result := result+1 ELSE ELSE IF ptr^.c > e_c THEN quit := TRUE; ptr := ptr^.next END; END END; MaxOp, MinOp : do_max_min(s_r,s_c,e_r,e_c,str,result,func_code); SumOp, MeanOp, ProdOp, VarOp, SdevOp, SerrOp, LinROp, CorrOp, PredVOp : do_stats(s_r,s_c,e_r,e_c,str,do_it,result,func_code) END { CASE } ELSE IF func_code IN [LinROp..PredVOp] THEN { additional args } IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; get_range(str,do_it,s_r,s_c,e_r,e_c); IF func_code = PredVOp THEN IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; full_expr(str,do_it,result) END ELSE stat := SyntaxErr END ELSE stat := SyntaxErr; IF stat <> OK THEN do_error(str) END; { DO_AGGREGATE } PROCEDURE DO_FINANCIAL; TYPE Parms = RECORD parm : REAL; present : BOOLEAN END; ArgArray = ARRAY [1..6] OF Parms; VAR i : INTEGER; cont : BOOLEAN; arg : ArgArray; FUNCTION POWER ( a,y : REAL ) : REAL; { efficiently and more accurately then e^xlny calc an integer power; used by the Financial functions PV, FV, PMT, NPER } VAR n : LONG_INTEGER; b,c : REAL; BEGIN IF ABS(y) >= Long_MaxInt THEN stat := Overflow ELSE BEGIN n := ABS(LONG_ROUND(y)); b := 1; c := a; WHILE n <> 0 DO BEGIN IF n & 1 <> 0 THEN b := b*c; IF check_square(c) THEN c := SQR(c) ELSE BEGIN stat := Overflow; do_error(str) END; n := ShR(n,1) END; IF y >= 0 THEN power := b ELSE power := 1/b END; IF stat <> OK THEN do_error(str) END; { POWER } PROCEDURE EVAL; VAR temp,rate : REAL; BEGIN rate := 1+arg[1].parm; CASE func_code OF PvOp : { ( rate , nper , rent , fv , type ) } IF (NOT arg[1].present) OR (NOT arg[2].present) THEN stat := SyntaxErr ELSE IF arg[1].parm <= 0 THEN stat := Undefined ELSE IF arg[3].present THEN { annuity } IF arg[4].present THEN stat := SyntaxErr ELSE BEGIN { ordinary annuity by default } result := arg[3].parm*(1-power(rate, -arg[2].parm))/arg[1].parm; IF arg[5].present THEN IF arg[5].parm < 1 THEN { annuity due } result := arg[3].parm*((1-power(rate, 1-arg[2].parm))/arg[1].parm+1) END ELSE IF arg[4].present THEN { compound interest } IF arg[5].present THEN { type is meaningless } stat := SyntaxErr ELSE result := arg[4].parm/power(rate,arg[2].parm) ELSE stat := SyntaxErr; { end of PvOp } FvOp : { ( rate , nper , rent , fv , type ) } IF (NOT arg[1].present) OR (NOT arg[2].present) THEN stat := SyntaxErr ELSE IF arg[1].parm <= 0 THEN stat := Undefined ELSE IF arg[3].present THEN { annuity } IF arg[4].present THEN stat := SyntaxErr ELSE BEGIN { ordinary annuity by default } result := arg[3].parm* (power(rate,arg[2].parm)-1)/arg[1].parm; IF arg[5].present THEN IF arg[5].parm < 1 THEN { annuity due } result := arg[3].parm*((power(rate, arg[2].parm+1)-1)/arg[1].parm-1) END ELSE IF arg[4].present THEN { compound interest } IF arg[5].present THEN { type is meaningless } stat := SyntaxErr ELSE result := arg[4].parm*power(rate,arg[2].parm) ELSE stat := SyntaxErr; { end of FvOp } NperOp : BEGIN { ( rate , pmt , pv , fv , type ) } IF (NOT arg[1].present) OR ((NOT arg[2].present) AND (arg[5].present)) THEN stat := SyntaxErr ELSE IF (arg[1].parm <= 0) OR ((arg[2].present) AND (arg[2].parm = 0)) THEN stat := Undefined ELSE IF (arg[3].present) AND (arg[4].present) THEN { nper to get from pv to fv, i.e. compound interest } IF (arg[2].present) OR (arg[5].present) THEN stat := SyntaxErr ELSE IF arg[3].parm = 0 THEN stat := Undefined ELSE IF arg[4].parm/arg[3].parm <= 0 THEN stat := Undefined ELSE result := my_ln(arg[4].parm/arg[3].parm)/my_ln(rate) ELSE IF arg[2].present THEN { annuity } IF arg[3].present THEN { present value } IF (NOT arg[5].present) OR { default is ordinary } ((arg[5].present) AND (arg[5].parm > 0)) THEN BEGIN temp := arg[3].parm*arg[1].parm/arg[2].parm; IF temp >= 1 THEN stat := Undefined ELSE result := -my_ln(1-temp)/my_ln(rate) END ELSE BEGIN { annuity due } temp := arg[1].parm*(arg[3].parm/arg[2].parm-1); IF temp >= 1 THEN stat := SyntaxErr ELSE result := 1-my_ln(1-temp)/my_ln(rate) END ELSE IF arg[4].present THEN { future value } { ordinary by default } IF (NOT arg[5].present) OR ((arg[5].present) AND (arg[5].parm > 0)) THEN BEGIN temp := arg[4].parm*arg[1].parm/arg[2].parm; IF temp <= -1 THEN stat := Undefined ELSE result := my_ln(temp+1)/my_ln(rate) END ELSE BEGIN { annuity due } temp := arg[1].parm*(arg[4].parm/arg[2].parm+1); IF temp <= -1 THEN stat := Undefined ELSE result := my_ln(temp+1)/my_ln(rate)-1 END ELSE stat := SyntaxErr ELSE stat := SyntaxErr; IF stat = OK THEN IF ABS(result) <= Long_MaxInt THEN result := LONG_ROUND(result) END;{ CASE NperOp } PmtOp : { ( rate , nper , pv , fv , type ) } IF (NOT arg[1].present) OR (NOT arg[2].present) OR ((arg[3].present) AND (arg[4].present)) THEN stat := SyntaxErr ELSE IF arg[1].parm <= 0 THEN stat := Undefined ELSE IF arg[3].present THEN { ordinary annuity by default } IF (NOT arg[5].present) OR ((arg[5].present) AND (arg[5].parm > 0)) THEN BEGIN temp := power(rate,-arg[2].parm); IF temp = 1 THEN stat := Undefined ELSE result := arg[3].parm/((1-temp)/arg[1].parm) END ELSE BEGIN { annuity due } temp := power(rate,1-arg[2].parm); IF temp = 1 THEN stat := Undefined ELSE result := arg[3].parm/((1-temp)/arg[1].parm+1) END ELSE IF arg[4].present THEN { future value } { ordinary by default } IF (NOT arg[5].present) OR ((arg[5].present) AND (arg[5].parm > 0)) THEN BEGIN temp := power(rate,arg[2].parm); IF temp = 1 THEN stat := Undefined ELSE result := arg[4].parm/((temp-1)/arg[1].parm) END ELSE BEGIN { annuity due } temp := power(rate,arg[2].parm+1); IF temp = 1 THEN stat := Undefined ELSE result := arg[4].parm/((temp-1)/arg[1].parm-1) END ELSE stat := SyntaxErr END { CASE } END; { EVAL } BEGIN { DO_FINANCIAL } FOR i := 1 TO 5 DO arg[i].present := FALSE; i := 1; cont := TRUE; WHILE (cont) AND (i <= 5) DO BEGIN IF str_pos > len THEN stat := SyntaxErr ELSE CASE str[str_pos] OF ',' : BEGIN str_pos := str_pos+1; IF str_pos <= len THEN IF str[str_pos] = ')' THEN stat := SyntaxErr END; ')' : cont := FALSE; OTHERWISE : BEGIN full_expr(str,do_it,arg[i].parm); arg[i].present := TRUE; IF str_pos < len THEN IF str[str_pos] = ',' THEN str_pos := str_pos+1 ELSE IF str[str_pos] <> ')' THEN stat := SyntaxErr END END; { CASE } IF stat <> OK THEN do_error(str); i := i+1 END; IF do_it THEN eval; IF stat <> OK THEN do_error(str) END; { DO_FINANCIAL } PROCEDURE DO_LOOKUP; VAR index,s_r,s_c,e_r,e_c,i,row,col : INTEGER; tag,temp : REAL; found,equal : BOOLEAN; a : AssignedStatus; ptr : CellPtr; BEGIN full_expr(str,do_it,tag); IF func_code = IndexOp THEN IF (tag < -MaxInt) OR (tag > MaxInt) THEN stat := OutOfRange; IF (str_pos < len) AND (stat = OK) THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; full_expr(str,do_it,temp); IF (temp < -MaxInt) OR (temp > MaxInt) THEN stat := OutOfRange ELSE IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; index := ROUND(temp); IF index < 1 THEN stat := OutOfRange ELSE BEGIN get_range(str,do_it,s_r,s_c,e_r,e_c); IF func_code = VLookUpOp THEN IF s_c+index-1 > e_c THEN stat := OutOfRange ELSE ELSE IF func_code = HLookUpOp THEN IF s_r+index-1 > e_r THEN stat := OutOfRange ELSE ELSE BEGIN { IndexOp } row := ROUND(tag); col := index; IF (row < 1) OR (col < 1) OR (row > e_r-s_r+1) OR (col > e_c-s_c+1) THEN stat := OutOfRange END; IF (do_it) AND (stat = OK) THEN IF func_code = VLookUpOp THEN BEGIN found := FALSE; equal := FALSE; i := s_r; WHILE (NOT found) AND (i <= e_r) DO BEGIN a := assigned(i,s_c,ptr); IF a = Value THEN IF ptr^.num >= tag THEN BEGIN found := TRUE; IF ptr^.num = tag THEN equal := TRUE END; i := i+1 END; IF (equal) OR (NOT found) THEN i := i-1 ELSE i := i-2; found := FALSE; WHILE (NOT found) AND (i >= s_r) DO BEGIN a := assigned(i,s_c,ptr); IF a = Value THEN BEGIN found := TRUE; a := assigned(i,s_c+index-1,ptr); IF a = Value THEN result := ptr^.num ELSE IF a = Error THEN stat := ptr^.status ELSE result := 0 END; i := i-1 END; IF NOT found THEN stat := OutOfRange END ELSE IF func_code = HLookUpOp THEN BEGIN found := FALSE; equal := FALSE; i := s_c; WHILE (NOT found) AND (i <= e_c) DO BEGIN a := assigned(s_r,i,ptr); IF a = Value THEN IF ptr^.num > tag THEN BEGIN found := TRUE; IF ptr^.num = tag THEN equal := TRUE END; i := i+1 END; IF (equal) OR (NOT found) THEN i := i-1 ELSE i := i-2; found := FALSE; WHILE (NOT found) AND (i >= s_c) DO BEGIN a := assigned(s_r,i,ptr); IF a = Value THEN BEGIN found := TRUE; a := assigned(s_r+index-1,i,ptr); IF a = Value THEN result := ptr^.num ELSE IF a = Error THEN stat := ptr^.status ELSE result := 0 END; i := i-1 END; IF NOT found THEN stat := OutOfRange END ELSE BEGIN { IndexOp } a := assigned(s_r+row-1,s_c+col-1,ptr); IF a = Value THEN result := ptr^.num ELSE IF a = Error THEN stat := ptr^.status ELSE result := 0 END END END ELSE stat := SyntaxErr END; IF stat <> OK THEN do_error(str) END; { DO_LOOKUP } PROCEDURE IF_EXPR; { ::= IF(,,) } VAR T_result,F_result : REAL; BEGIN IF str_pos < len THEN BEGIN full_expr(str,do_it,result); IF str_pos < len THEN IF str[str_pos] <> ',' THEN stat := SyntaxErr ELSE BEGIN str_pos := str_pos+1; { first action; must "pseudo-evaluate" if the boolean expr was FALSE in order to get str_pos to the correct pos. } full_expr(str,result<>0,T_result); IF str_pos < len THEN IF (str[str_pos] <> ',') THEN stat := SyntaxErr ELSE BEGIN { alternate action; ditto as for 1st } str_pos := str_pos+1; full_expr(str,result=0,F_result); IF do_it THEN IF result <> 0 THEN result := T_result ELSE result := F_result END ELSE stat := SyntaxErr END ELSE { can't call this an error } END ELSE { str_pos did = len } stat := SyntaxErr; IF stat <> OK THEN do_error(str) END; { IF_EXPR } (**************************************************************************) (* EVALUATE_FORMULA, the parent, begins here. Had to make the other *) (* routines local to this one so that if an error is encountered, can *) (* abort to a label in this routine. *) (**************************************************************************) { class of cell passed here should be Expr, but NIL str and recalc flag are checked to be certain } BEGIN { EVALUATE_FORMULA } IF cell^.str <> NIL THEN BEGIN cell^.format := cell^.format | pending_mask; str_pos := 1; stat := OK; result := 0; WITH cell^ DO BEGIN len := LENGTH(str^); full_expr(str^,TRUE,result); 1: cell^.format := (cell^.format | recalc_mask) & not_pending_mask; old_num := num; old_status := status; IF (str_pos <= len) AND (stat = OK) THEN BEGIN stat := SyntaxErr; IF new_form THEN BEGIN Set_Mouse(M_Arrow); error_message(str^,stat,str_pos,len); Set_Mouse(M_Bee) END END; { Catch things like 1 < A1 < 2, } { as FULL_EXPR only looks for the } IF stat = OK THEN { 1st clause. Can't check there } status := Full { because some valid expr may be } ELSE { left, following the boolean... } status := stat; { NOTE: all cells dependent on this } num := result; { will assume its status if an error } IF format & perc_mask <> 0 THEN num := num/100; IF (auto_recalc) AND ((old_num <> num) OR (old_status <> status)) THEN BEGIN dep := sub; WHILE dep <> NIL DO BEGIN ptr := locate_cell(dep^.r,dep^.c); IF ptr <> NIL THEN IF (ptr^.class = Expr) AND (ptr^.format & recalc_mask = 0) AND (ptr^.format & pending_mask = 0) THEN evaluate_formula(dep^.r,dep^.c,force,FALSE,ptr); dep := dep^.next END; END { IF } END; { WITH } IF (row <> data_row) OR (col <> data_col) THEN IF (old_num <> cell^.num) OR (old_status <> cell^.status) THEN cell_on_screen(1,row,col,TRUE) END ELSE { str did = NIL } cell^.format := cell^.format | recalc_mask; 2: END; { EVALUATE_FORMULA } BEGIN END.