/* l2xixstd.c LTX2X interpreter standard procedure/function Executor routines */ /* Written by: Peter Wilson, CUA pwilson@cme.nist.gov */ /* This code is partly based on algorithms presented by Ronald Mak in */ /* "Writing Compilers & Interpreters", John Wiley & Sons, 1991 */ #include #include #include #include "l2xicmon.h" #include "l2xierr.h" #include "l2xiscan.h" #include "l2xisymt.h" #include "l2xiprse.h" #include "l2xiidbg.h" #include "l2xiexec.h" #include "listsetc.h" #define DEFAULT_NUMERIC_FIELD_WIDTH 10 #define DEFAULT_PRECISION 4 /* added for ltx2x */ #define MAX_LTX2X_BUFFER 2000 /* EXTERNALS */ extern int level; extern int exec_line_number; /* no. of line executed */ extern ICT *code_segmentp; /* code segment ptr */ /* used? */ extern TOKEN_CODE ctoken; /* token from code segment */ extern STACK_ITEM *stack; /* runtime stack */ extern STACK_ITEM_PTR tos; /* ptr to top of runtime stack */ extern STACK_ITEM_PTR stack_frame_basep; /* ptr to stack fame base */ extern STACK_ITEM_PTR stack_display[]; /* ????????? */ extern BOOLEAN is_value_undef(); extern STRING get_stacked_string(); extern STACK_TYPE form2stack[]; /* map form type to stack type */ extern TYPE_FORM stack2form[]; /* map stack type to form type */ extern STACK_ITEM_PTR create_copy_value(); /* FORWARDS */ TYPE_STRUCT_PTR exec_eof_eoln(), exec_abs_sqr(), exec_arctan_cos_exp_ln_sin_sqrt(), exec_odd(), exec_round_trunc(); TYPE_STRUCT_PTR exec_atan(), exec_exists_etc(), exec_nvl_etc(); TYPE_STRUCT_PTR exec_rexpr_etc(), exec_hibound_etc(), exec_length_etc(); /* GLOBALS */ BOOLEAN eof_flag = FALSE; char acbuffer[MAX_LTX2X_BUFFER]; /* added for ltx2x */ /************************************************************************/ /* exec_standard_routine_call(rtn_idp) Execute a call to a standard */ /* procedure or function */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_standard_routine_call(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { entry_debug("exec_standard_routine_call"); switch (rtn_idp->defn.info.routine.key) { case READ: case READLN: { exec_read_readln(rtn_idp); exit_debug("exec_standard_routine_call"); return(NULL); } case WRITE: case WRITELN: { exec_write_writeln(rtn_idp); exit_debug("exec_standard_routine_call"); return(NULL); } case EOFF: case EOLN: { exit_debug("exec_standard_routine_call"); return(exec_eof_eoln(rtn_idp)); } case ABS: /* real or int -> real or int */ { exit_debug("exec_standard_routine_call"); return(exec_abs_sqr(rtn_idp)); } case COS: /* real or int -> real */ case EXP: case SIN: case SQRT: case XACOS: case XASIN: case XLOG: case XLOG2: case XLOG10: case XTAN: { exit_debug("exec_standard_routine_call"); return(exec_arctan_cos_exp_ln_sin_sqrt(rtn_idp)); } case XATAN: { /* extra for EXPRESS */ exit_debug("exec_standard_routine_call"); return(exec_atan(rtn_idp)); } case ODD: { /* int -> boolean */ exit_debug("exec_standard_routine_call"); return(exec_odd()); } case ROUND: /* real -> int */ case TRUNC: { exit_debug("exec_standard_routine_call"); return(exec_round_trunc(rtn_idp)); } case L2XPRINT: case L2XPRINTLN: { /* added for ltx2x */ exec_print_println(rtn_idp); exit_debug("exec_standard_routine_call"); return(NULL); } case L2XSYSTEM: { /* added for ltx2x */ exec_system_etc(rtn_idp); exit_debug("exec_standard_routine_call"); return(NULL); } case L2XREXPR: { /* added for ltx2x */ exit_debug("exec_standard_routine_call"); return(exec_rexpr_etc(rtn_idp)); } case XHIBOUND: case XHIINDEX: case XLOBOUND: case XLOINDEX: case XSIZEOF: { exit_debug("exec_standard_routine_call"); return(exec_hibound_etc(rtn_idp)); } case XLENGTH: { exit_debug("exec_standard_routine_call"); return(exec_length_etc(rtn_idp)); } case XEXISTS: { exit_debug("exec_standard_routine_call"); return(exec_exists_etc(rtn_idp)); } case XNVL: { exit_debug("exec_standard_routine_call"); return(exec_nvl_etc(rtn_idp)); } case XINSERT: case XREMOVE: { exec_insert_etc(rtn_idp); exit_debug("exec_standard_routine_call"); return(NULL); } case XBLENGTH: case XFORMAT: case XROLESOF: case XTYPEOF: case XUSEDIN: case XVALUE: case XVALUE_IN: case XVALUE_UNIQUE: { /* unimplemented EXPRESS stuff */ runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE); exit_debug("exec_standard_routine_call"); return(NULL); } default: { runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE); break; } } /* end switch */ exit_debug("exec_standard_routine_call"); return(NULL); } /* end exec_standard_routine_call */ /************************************************************************/ /************************************************************************/ /* exec_read_readln(rtn_idp) Execute a call to READ or READLN */ exec_read_readln(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { SYMTAB_NODE_PTR parm_idp; /* param id */ TYPE_STRUCT_PTR parm_tp; /* param type */ STACK_ITEM_PTR targetp; /* ptr to read target */ XPRSAINT i1; XPRSAREAL r1; int len; char ch; char tbuff[MAX_LTX2X_BUFFER]; STRING lhs; entry_debug("exec_read_readln"); /* params are optional for readln */ get_ctoken(); if (ctoken == LPAREN) { /* id list */ do { get_ctoken(); parm_idp = get_symtab_cptr(); parm_tp = base_type(exec_variable(parm_idp, VARPARM_USE)); targetp = (STACK_ITEM_PTR) get_address(tos); pop(); /* pop off address */ if (parm_tp == integer_typep) { scanf("%d", &i1); put_integer(targetp, i1); } else if (parm_tp == real_typep) { scanf("%g", &r1); put_real(targetp, r1); } else { /* a string or a logical */ scanf("%sMAX_LTX2X_BUFFER", tbuff); len = strlen(tbuff); sprintf(dbuffer, "strlen(str) = %d, str = %s\n", len, tbuff); debug_print(dbuffer); if (parm_tp == logical_typep) { /* check which one */ if (len == 4 && (tbuff[0] == 't' || tbuff[0] == 'T')) { /* TRUE */ put_true(targetp); } else if (len == 5 && (tbuff[0] == 'f' || tbuff[0] == 'F')) { /* FALSE */ put_false(targetp); } else if (len == 7 && (tbuff[0] == 'u' || tbuff[0] == 'U')) { /* UNKNOWN */ put_unknown(targetp); } else { /* an error */ runtime_error(INVALID_FUNCTION_ARGUMENT); put_unknown(targetp); } } else { /* a string */ free(targetp->value.string); lhs = alloc_bytes(len+1); sprintf(dbuffer, "lhs = %d", lhs); debug_print(dbuffer); strcpy(lhs, tbuff); sprintf(dbuffer, ", str = %s\n", lhs); debug_print(dbuffer); put_string(targetp, lhs); } } trace_data_store(parm_idp, parm_idp->typep, targetp, parm_tp); } while (ctoken == COMMA); /* end do */ get_ctoken(); /* token after RPAREN */ } if (rtn_idp->defn.info.routine.key == READLN) { do { ch = getchar(); } while(!eof_flag && (ch != '\n')); } exit_debug("exec_read_readln"); return; } /* end exec_read_readln */ /************************************************************************/ /************************************************************************/ /* exec_write_writeln(rtn_idp) Execute a call to WRITE or WRITELN */ /* Each actual parameter can be: */ /* or : */ /* or : : */ exec_write_writeln(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* parameter type */ STACK_TYPE stype; XPRSAINT field_width; XPRSAINT precision; entry_debug("exec_write_writeln"); /* parameters are optional for writeln */ get_ctoken(); if (ctoken == LPAREN) { do { /* push value */ get_ctoken(); parm_tp = base_type(exec_expression()); /* check if dynamic agg */ if (is_dynagg(parm_tp)) parm_tp = parm_tp->info.dynagg.elmt_typep; field_width = DEFAULT_NUMERIC_FIELD_WIDTH; precision = DEFAULT_PRECISION; /* optional field width expresion */ if (ctoken == COLON) { get_ctoken(); exec_expression(); if (!is_value_undef(tos)) { field_width = get_integer(tos); } pop(); /* field width */ /* optional decimal places expresion */ if (ctoken == COLON) { get_ctoken(); exec_expression(); if (!is_value_undef(tos)) { precision = get_integer(tos); } pop(); /* precision */ } } if (parm_tp->form == ARRAY_FORM) { /* array, address on top of stack */ if (get_stackval_type(tos) == STKADD) { copy_value(tos, get_address(tos)); } } stype = get_stackval_type(tos); /* write value */ if (is_value_undef(tos)) { printf("%*c", field_width, get_undef(tos)); } else if (stype == STKINT) { printf("%*d", field_width, get_integer(tos)); } else if (stype == STKREA) { printf("%*.*g", field_width, precision, get_real(tos)); } else if (stype == STKLOG) { field_width = 0; switch (get_logical(tos)) { case TRUE_REP: { printf("%*s", -field_width, "TRUE"); break; } case FALSE_REP: { printf("%*s", -field_width, "FALSE"); break; } case UNKNOWN_REP: { printf("%*s", -field_width, "UNKNOWN"); break; } default: { printf("%*s", -field_width, "??UNKNOWN??"); break; } } /* end switch */ } else if (parm_tp == string_typep || parm_tp->form == STRING_FORM) { field_width = 0; printf("%*s", -field_width, get_stacked_string(tos) ); } pop(); /* value */ } while (ctoken == COMMA); /* end do */ get_ctoken(); /* token after RPAREN */ } /* end of if over parameters */ if (rtn_idp->defn.info.routine.key == WRITELN) putchar('\n'); exit_debug("exec_write_writeln"); return; } /* end exec_write_writeln */ /************************************************************************/ /************************************************************************/ /* exec_print_println(rtn_idp) Execute a call to PRINT or PRINTLN */ /* Each actual parameter can be: */ /* or : */ /* or : : */ /* Identical to exec_write_writeln, except output is to ltx2x myprint */ exec_print_println(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* parameter type */ STACK_TYPE stype; XPRSAINT field_width; XPRSAINT precision; entry_debug("exec_print_println"); /* parameters are optional for println */ get_ctoken(); if (ctoken == LPAREN) { do { /* push value */ get_ctoken(); parm_tp = base_type(exec_expression()); /* check if dynamic agg */ if (is_dynagg(parm_tp)) { parm_tp = parm_tp->info.dynagg.elmt_typep; } field_width = DEFAULT_NUMERIC_FIELD_WIDTH; precision = DEFAULT_PRECISION; /* optional field width expresion */ if (ctoken == COLON) { get_ctoken(); exec_expression(); if (!is_value_undef(tos)) { field_width = get_integer(tos); } pop(); /* field width */ /* optional decimal places expresion */ if (ctoken == COLON) { get_ctoken(); exec_expression(); if (!is_value_undef(tos)) { precision = get_integer(tos); } pop(); /* precision */ } } if (parm_tp->form == ARRAY_FORM) { /* array, address on top of stack */ if (get_stackval_type(tos) == STKADD) { copy_value(tos, get_address(tos)); } } stype = get_stackval_type(tos); /* write value */ if (is_value_undef(tos)) { sprintf(acbuffer, "%*c", field_width, get_undef(tos)); } else if (stype == STKINT) { sprintf(acbuffer, "%*d", field_width, get_integer(tos)); } else if (stype == STKREA) { sprintf(acbuffer, "%*.*g", field_width, precision, get_real(tos)); } else if (stype == STKLOG) { field_width = 0; switch (get_logical(tos)) { case TRUE_REP: { sprintf(acbuffer, "%*s", -field_width, "TRUE"); break; } case FALSE_REP: { sprintf(acbuffer, "%*s", -field_width, "FALSE"); break; } case UNKNOWN_REP: { sprintf(acbuffer, "%*s", -field_width, "UNKNOWN"); break; } default: { sprintf(acbuffer, "%*s", -field_width, "??UNKNOWN??"); break; } } /* end switch */ } else if (parm_tp == string_typep || parm_tp->form == STRING_FORM) { field_width = 0; sprintf(acbuffer, "%*s", -field_width, get_stacked_string(tos) ); } myprint(acbuffer); pop(); /* value */ } while (ctoken == COMMA); /* end do */ get_ctoken(); /* token after RPAREN */ } /* end of if over parameters */ if (rtn_idp->defn.info.routine.key == L2XPRINTLN) myprint("\n"); exit_debug("exec_print_println"); return; } /* end exec_print_println */ /************************************************************************/ /************************************************************************/ /* exec_insert_etc(rtn_idp) Execute a call to procedure INSERT, etc */ /* INSERT(, , ) */ /* REMOVE(, ) */ /* at entry: ctoken is `proc' */ /* at exit: ctoken is the token after the closing ) */ exec_insert_etc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* parameter type */ LBS_PTR list; LBS_NODE_PTR nod; STACK_ITEM_PTR pitem; XPRSAINT pos; int code = rtn_idp->defn.info.routine.key; entry_debug("exec_insert_etc (l2xixstd.c)"); /* first parameter */ get_ctoken(); /* should be ( */ get_ctoken(); /* should be param 1 */ parm_tp = base_type(exec_expression()); if (parm_tp->form != LIST_FORM) { runtime_error(INVALID_FUNCTION_ARGUMENT); } list = (LBS_PTR) get_address_type(tos, STKLST); sprintf(dbuffer, "list = %d\n", list); debug_print(dbuffer); pop(); /* first parm */ get_ctoken(); /* start of next parameter */ if (code == XINSERT) { /* do INSERT second param */ exec_expression(); pitem = create_copy_value(tos); sprintf(dbuffer, "pitem = %d\n", pitem); debug_print(dbuffer); get_ctoken(); /* start of next parameter */ } /* final parameter */ parm_tp = base_type(exec_expression()); pos = get_integer(tos); pop(); /* last parm */ get_ctoken(); /* token after closing ) */ switch (code) { case XINSERT: { nod = lbs_insert(list, (genptr) pitem, pos); sprintf(dbuffer, "inserted node = %d, with data = %d, at pos = %d, into list = %d\n", nod, pitem, pos, list); debug_print(dbuffer); pop(); /* middle parm */ break; } case XREMOVE: { nod = lbs_remove(list, pos); sprintf(dbuffer, "removed node = %d\n", nod); debug_print(dbuffer); break; } } /* end switch */ exit_debug("exec_insert_etc"); return; } /* end EXEC_INSERT_ETC */ /************************************************************************/ /************************************************************************/ /* exec_eof_eoln(rtn_idp) Execute a call to EOF or EOLN */ /* No parameters => boolean result */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_eof_eoln(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { char ch = getchar(); entry_debug("exec_eof_eoln"); switch (rtn_idp->defn.info.routine.key) { case EOFF: { if (eof_flag || feof(stdin)) { eof_flag = TRUE; push_true(); } else { push_false(); ungetc(ch, stdin); } break; } case EOLN: { if (eof_flag || feof(stdin)) { eof_flag = TRUE; push_true(); } else { push_logical(ch == '\n' ? TRUE_REP : FALSE_REP); ungetc(ch, stdin); } break; } } /* end switch */ get_ctoken(); /* token after function name */ exit_debug("exec_eof_eoln"); return(logical_typep); } /* end exec_eof_eoln */ /************************************************************************/ /************************************************************************/ /* exec_system_etc(rtn_idp) Execute a call to system, etc */ /* fun('string') */ /* String parameter, no result */ /* at entry, ctoken is `fun' */ /* at exit, ctoken is token after closing ) */ exec_system_etc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* actual param type */ entry_debug("exec_system_etc"); get_ctoken(); /* should be ( */ get_ctoken(); /* start of param */ parm_tp = base_type(exec_expression()); if (parm_tp->form != STRING_FORM) { runtime_error(INVALID_FUNCTION_ARGUMENT); } else { switch (rtn_idp->defn.info.routine.key) { case L2XSYSTEM : { system(get_stacked_string(tos)); break; } default : { runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE); break; } } /* end switch */ } get_ctoken(); /* token after closing ) */ exit_debug("exec_system_etc"); return; } /* end EXEC_SYSTEM_ETC */ /************************************************************************/ /************************************************************************/ /* exec_rexpr_etc(rtn_idp) Execute a call to REXPR, etc */ /* In general, any function fun(p1, p2) that: */ /* p1 and p2 are strings --> boolean result */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_rexpr_etc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm1_tp, parm2_tp; /* actual param types */ TYPE_STRUCT_PTR result_tp = logical_typep; STRING parm1, parm2; /* parameters */ BOOLEAN undef_parm = FALSE; int code = rtn_idp->defn.info.routine.key; int result; entry_debug("exec_rexpr_etc (l2xixstd.c)"); get_ctoken(); /* LPAREN */ get_ctoken(); /* start of first parameter */ parm1_tp = base_type(exec_expression()); if (is_value_undef(tos)) { undef_parm = TRUE; } else { parm1 = get_stacked_string(tos); } /* get_ctoken(); COMMA */ get_ctoken(); /* start of second parameter */ parm2_tp = base_type(exec_expression()); if (is_value_undef(tos)) { undef_parm = TRUE; } else { parm2 = get_stacked_string(tos); } pop(); if (code == L2XREXPR) { /* parm1 = string, parm2 = pattern */ if (undef_parm) { put_undef(tos); } else { result = rexpr(parm1, parm2); if (result < 0) { runtime_error(INVALID_REGULAR_EXPRESSION); put_undef(tos); } else if (result == 0) { put_false(tos); } else { put_true(tos); } } } get_ctoken(); /* token after RPAREN */ exit_debug("exec_rexpr_etc"); return(result_tp); } /* end EXEC_REXPR_ETC */ /************************************************************************/ /************************************************************************/ /* exec_hibound_etc(rtn_idp) Execute a call to HIBOUND, etc */ /* agg type -> integer */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_hibound_etc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* actual param type */ TYPE_STRUCT_PTR result_tp = integer_typep; /* result type */ XPRSAINT result = 0; STACK_TYPE stype; TYPE_FORM ftype; int code = rtn_idp->defn.info.routine.key; entry_debug("exec_hibound_etc"); get_ctoken(); /* LPAREN */ get_ctoken(); parm_tp = base_type(exec_expression()); if (is_value_undef(tos)) { put_undef(tos); get_ctoken(); /* token after RPAREN */ exit_debug("exec_hibound_etc"); return(result_tp); } ftype = parm_tp->form; if ((ftype != ARRAY_FORM) && (ftype != BAG_FORM) && (ftype != LIST_FORM) && (ftype != SET_FORM) ) { runtime_error(INVALID_FUNCTION_ARGUMENT); put_undef(tos); get_ctoken(); /* token after RPAREN */ exit_debug("exec_hibound_etc"); return(result_tp); } stype = get_stackval_type(tos); if (stype != form2stack[ftype] && stype != STKADD) { stack_warning(form2stack[ftype], stype); } switch (code) { case XHIBOUND: { /* declared upper bound */ if (parm_tp->form == ARRAY_FORM) { result = parm_tp->info.array.max_index; } else { result = parm_tp->info.dynagg.max_index; } break; } case XHIINDEX: { /* declared array upper bound, or # of elements */ if (parm_tp->form == ARRAY_FORM) { result = parm_tp->info.array.max_index; } else { result = NELS((LBS_PTR) get_address_type(tos, stype)); } break; } case XLOBOUND: { /* declared lower bound */ if (parm_tp->form == ARRAY_FORM) { result = parm_tp->info.array.min_index; } else { result = parm_tp->info.dynagg.min_index; } break; } case XLOINDEX: { /* declared array lower bound, or 1 */ if (parm_tp->form == ARRAY_FORM) { result = parm_tp->info.array.min_index; } else { result = 1; } break; } case XSIZEOF: { /* # of actual elements */ if (parm_tp->form == ARRAY_FORM) { result = parm_tp->info.array.max_index - parm_tp->info.array.min_index + 1; } else { result = NELS((LBS_PTR) get_address_type(tos, stype)); } break; } default: { /* should not be here */ runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE); get_ctoken(); put_undef(tos); exit_debug("exec_hibound_etc"); return(result_tp); } } /* end switch */ get_ctoken(); /* token after RPAREN */ put_integer(tos, result); exit_debug("exec_hibound_etc"); return(result_tp); } /* end EXEC_HIBOUND_ETC */ /************************************************************************/ /************************************************************************/ /* exec_length_etc(rtn_idp) Execute a call to LENGTH, etc */ /* fun('string') */ /* String parameter, integer result */ /* at entry, ctoken is `fun' */ /* at exit, ctoken is token after closing ) */ TYPE_STRUCT_PTR exec_length_etc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* actual param type */ TYPE_STRUCT_PTR result_tp; /* returned type */ XPRSAINT result = 0; entry_debug("exec_length_etc (l2xixstd.c)"); get_ctoken(); /* should be ( */ get_ctoken(); /* start of param */ parm_tp = base_type(exec_expression()); if (parm_tp->form != STRING_FORM) { runtime_error(INVALID_FUNCTION_ARGUMENT); } else { switch (rtn_idp->defn.info.routine.key) { case XLENGTH : { /* # of chars in a string */ result = (XPRSAINT) strlen(get_stacked_string(tos)); break; } default : { runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE); break; } } /* end switch */ } get_ctoken(); /* token after closing ) */ put_integer(tos, result); exit_debug("exec_length_etc"); return(result_tp); } /* end EXEC_LENGTH_ETC */ /************************************************************************/ /************************************************************************/ /* exec_exists_etc(rtn_idp) Execute a call to EXISTS, etc */ /* any type -> boolean */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_exists_etc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* actual param type */ TYPE_STRUCT_PTR result_tp; /* result type */ int code = rtn_idp->defn.info.routine.key; entry_debug("exec_exists_etc"); get_ctoken(); /* LPAREN */ get_ctoken(); parm_tp = base_type(exec_expression()); if (code == XEXISTS) { if (is_value_undef(tos)) { put_true(tos); } else { put_false(tos); } } get_ctoken(); /* token after RPAREN */ exit_debug("exec_exists_etc"); return(logical_typep); } /* end EXEC_EXISTS_ETC */ /************************************************************************/ /************************************************************************/ /* exec_nvl_etc(rtn_idp) Execute a call to NVL, etc */ /* In general, any function fun(p1, p2) that: */ /* any compatible params --> compatible result */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_nvl_etc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm1_tp, parm2_tp; /* actual param types */ TYPE_STRUCT_PTR result_tp; STACK_ITEM_PTR parm1, parm2; /* parameters */ int code = rtn_idp->defn.info.routine.key; entry_debug("exec_nvl_etc"); get_ctoken(); /* LPAREN */ get_ctoken(); /* start of first parameter */ parm1_tp = base_type(exec_expression()); parm1 = tos; get_ctoken(); /* COMMA */ get_ctoken(); /* start of second parameter */ parm2_tp = base_type(exec_expression()); parm2 = tos; if (code == XNVL) { if (is_value_undef(parm1)) { copy_value(parm1, parm2); result_tp = parm2_tp; } else { result_tp = parm1_tp; } } get_ctoken(); /* token after RPAREN */ exit_debug("exec_nvl_etc"); return(result_tp); } /* end EXEC_NVL_ETC */ /************************************************************************/ /************************************************************************/ /* exec_abs_sqr(rtn_idp) Execute a call to ABS or SQR */ /* Integer --> integer result */ /* real --> real result */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_abs_sqr(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* actual param type */ TYPE_STRUCT_PTR result_tp; /* result type */ XPRSAINT i1; XPRSAREAL r1; int code = rtn_idp->defn.info.routine.key; entry_debug("exec_abs_sqr"); get_ctoken(); /* LPAREN */ get_ctoken(); parm_tp = base_type(exec_expression()); if (is_value_undef(tos)) { ; } if (code == ABS) { if (parm_tp == integer_typep) { i1 = get_integer(tos); if (i1 >= 0) { put_integer(tos, i1); } else { put_integer(tos, -i1); } } else { r1 = (XPRSAREAL) fabs((double) get_real(tos)); put_real(tos, r1); } } get_ctoken(); /* token after RPAREN */ exit_debug("exec_abs_sqr"); return(parm_tp); } /* end exec_abs_sqr */ /************************************************************************/ /************************************************************************/ /* exec_arctan_cos_exp_ln_sin_sqrt(rtn_idp) Execute a call to ARCTAN, */ /* COS, EXP, LN, SIN or SQRT */ /* In general, any function fun(p1) that: */ /* integer or real param --> real result */ /* return a pointer to the type stucture of the call */ /* NOTE calling C library routines acos() and asin() give wierd interp error */ TYPE_STRUCT_PTR exec_arctan_cos_exp_ln_sin_sqrt(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm_tp; /* actual param type */ int code = rtn_idp->defn.info.routine.key; XPRSAREAL r1, r2; entry_debug("exec_arctan_cos_exp_ln_sin_sqrt"); get_ctoken(); /* LPAREN */ get_ctoken(); parm_tp = base_type(exec_expression()); if (is_value_undef(tos)) { get_ctoken(); /* token after RPAREN */ exit_debug("exec_arctan_cos_exp_ln_sin_sqrt"); return(real_typep); } if (parm_tp == integer_typep) { put_real(tos, (XPRSAREAL) get_integer(tos)); } r1 = (double) get_real(tos); /* check input value */ if (((code == SQRT) && (r1 < 0.0)) || ((code == XACOS) && (r1 < -1.0 || r1 > 1.0)) || ((code == XASIN) && (r1 < -1.0 || r1 > 1.0)) || ((code == XLOG) && (r1 <= 0.0)) || ((code == XLOG2) && (r1 <= 0.0)) || ((code == XLOG10) && (r1 <= 0.0)) ) { runtime_error(INVALID_FUNCTION_ARGUMENT); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt"); } else { switch (rtn_idp->defn.info.routine.key) { case COS: { put_real(tos, (XPRSAREAL) cos(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (COS)"); break; } case EXP: { put_real(tos, (XPRSAREAL) exp(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (EXP)"); break; } case SIN: { put_real(tos, (XPRSAREAL) sin(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (SIN)"); break; } case SQRT: { put_real(tos, (XPRSAREAL) sqrt(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (SQRT)"); break; } case XACOS: { put_real(tos, (XPRSAREAL) acos(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (ACOS)"); break; } case XASIN: { put_real(tos, (XPRSAREAL) asin(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (ASIN)"); break; } case XLOG: { put_real(tos, (XPRSAREAL) log(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (LOG)"); break; } case XLOG2: { /* log_a(x) = ln(x)/ln(a) : ln(2) = 0.6931 47180 55994 */ put_real(tos, (1.442695 * ((XPRSAREAL) log(r1)))); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (LOG2)"); break; } case XLOG10: { put_real(tos, (XPRSAREAL) log10(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (LOG10)"); break; } case XTAN: { put_real(tos, (XPRSAREAL) tan(r1)); exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (TAN)"); break; } } /* end switch */ } get_ctoken(); /* token after RPAREN */ return(real_typep); } /* end exec_arctan_cos_exp_ln_sin_sqrt */ /************************************************************************/ /************************************************************************/ /* exec_atan(rtn_idp) Execute a call to ATAN, */ /* In general, any function fun(p1, p2) that: */ /* integer or real param --> real result */ /* return a pointer to the type stucture of the call */ /* NOTE: Calling C library function atan2() gives wierd interp. error */ TYPE_STRUCT_PTR exec_atan(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { TYPE_STRUCT_PTR parm1_tp, parm2_tp; /* actual param type */ TYPE_STRUCT_PTR result_tp; STACK_ITEM_PTR parm1, parm2; int code = rtn_idp->defn.info.routine.key; XPRSAREAL r1; XPRSAREAL r2; entry_debug("exec_atan"); get_ctoken(); /* LPAREN */ get_ctoken(); /* start of first parameter */ parm1_tp = base_type(exec_expression()); parm1 = tos; get_ctoken(); /* COMMA */ get_ctoken(); /* start of second parameter */ parm2_tp = base_type(exec_expression()); parm2 = tos; if (code == XATAN) { if (is_value_undef(parm1) || is_value_undef(parm2)) { put_undef(parm1); } else { if (parm1_tp == integer_typep) { put_real(parm1, (XPRSAREAL) get_integer(parm1)); } r1 = get_real(parm1); if (parm2_tp == integer_typep) { put_real(parm2, (XPRSAREAL) get_integer(parm2)); } r2 = get_real(parm2); if (r1 == 0.0 && r2 == 0.0) { runtime_error(INVALID_FUNCTION_ARGUMENT); } else { r1 = (double) r1; r2 = (double) r2; put_real(parm1, (XPRSAREAL) atan2(r1, r2)); } } } pop(); get_ctoken(); /* token after RPAREN */ exit_debug("exec_atan"); return(real_typep); } /* end EXEC_ATAN */ /************************************************************************/ /************************************************************************/ /* exec_odd() Execute a call to ODD */ /* integer param --> boolean result */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_odd() { XPRSAINT i1; entry_debug("exec_odd"); get_ctoken(); /* LPAREN */ get_ctoken(); exec_expression(); if (!is_value_undef(tos)) { i1 = get_integer(tos); i1 &= 1; if (i1 == 0) { put_false(tos); } else { put_true(tos); } } get_ctoken(); /* after RPAREN */ exit_debug("exec_odd"); return(logical_typep); } /* end exec_odd */ /************************************************************************/ /************************************************************************/ /* exec_round_trunc(rtn_idp) Execute a call to ROUND or TRUNC */ /* real param --> integer result */ /* return a pointer to the type stucture of the call */ TYPE_STRUCT_PTR exec_round_trunc(rtn_idp) SYMTAB_NODE_PTR rtn_idp; /* routine id */ { XPRSAREAL r1; XPRSAINT i1; entry_debug("exec_round_trunc"); get_ctoken(); /* LPAREN */ get_ctoken(); exec_expression(); if (!is_value_undef(tos)) { r1 = get_real(tos); if (rtn_idp->defn.info.routine.key == ROUND) { i1 = r1 > 0.0 ? (XPRSAINT) (r1 + 0.5) : (XPRSAINT) (r1 - 0.5); } else { i1 = (XPRSAINT) r1; } put_integer(tos, i1); } get_ctoken(); /* after RPAREN */ exit_debug("exec_round_trunc"); return(integer_typep); } /* end exec_round_trunc */ /************************************************************************/