From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- support/ltx2x/l2xixstd.c | 1233 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1233 insertions(+) create mode 100644 support/ltx2x/l2xixstd.c (limited to 'support/ltx2x/l2xixstd.c') diff --git a/support/ltx2x/l2xixstd.c b/support/ltx2x/l2xixstd.c new file mode 100644 index 0000000000..43f513e889 --- /dev/null +++ b/support/ltx2x/l2xixstd.c @@ -0,0 +1,1233 @@ +/* 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 */ +/************************************************************************/ + + + + + -- cgit v1.2.3