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/l2xixxpr.c | 1234 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1234 insertions(+) create mode 100644 support/ltx2x/l2xixxpr.c (limited to 'support/ltx2x/l2xixxpr.c') diff --git a/support/ltx2x/l2xixxpr.c b/support/ltx2x/l2xixxpr.c new file mode 100644 index 0000000000..7a97bae889 --- /dev/null +++ b/support/ltx2x/l2xixxpr.c @@ -0,0 +1,1234 @@ +/* l2xixxpr.c LTX2X interpreter expression 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 "l2xicmon.h" +#include "l2xierr.h" +#include "l2xiscan.h" +#include "l2xisymt.h" +#include "l2xiprse.h" +#include "l2xiidbg.h" +#include "l2xiexec.h" + +#include "listsetc.h" + +/* EXTERNALS */ + +extern int level; + +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 BOOLEAN is_value_undef(); +extern STRING get_stacked_string(); + +extern STACK_TYPE form2stack[]; /* map form type to stack type */ + +/* FORWARDS */ + +TYPE_STRUCT_PTR exec_expression(), exec_simple_expression(), + exec_term(), exec_factor(), + exec_constant(), exec_variable(), + exec_subscripts(); +TYPE_STRUCT_PTR exec_simple_factor(), exec_attribute(); + +STRING concat_strings(); + +/* MACROS */ + +/* undef_types(tp1, tp2) TRUE if either type is undef, else FALSE */ +#define undef_types(tp1, tp2) ((tp1 == any_typep) || (tp2 == any_typep)) + +/* undef_values(sp1, sp2) TRUE if either stack value is undef */ +#define undef_values(sp1, sp2) (is_value_undef(sp1) || is_value_undef(sp2)) + +/* set_undef(tp1) Sets tp1 to undef type */ +#define set_undef(tp1) (tp1 = any_typep) + +/* is_undef(tp1) TRUE if tp1 is undef type, else FALSE */ +#define is_undef(tp1) (tp1 == any_typep) + +/* string_operands(tp1, tp2) TRUE iff tp1 and tp2 are string types */ +#define string_operands(tp1, tp2) ((tp1)->form == STRING_FORM && (tp2)->form == STRING_FORM) + +/***************************************************************************/ +/* exec_expression() Execute an expression */ +/* [ ] */ +/* return a pointer to the type structure. */ + +TYPE_STRUCT_PTR exec_expression() +{ + STACK_ITEM_PTR operandp1, operandp2; /* ptrs to operands */ + TYPE_STRUCT_PTR result_tp, tp1, tp2; /* ptrs to types */ + TOKEN_CODE op; /* operator token */ + BOOLEAN result; + LOGICAL_REP log; + entry_debug("exec_expression"); + + tp1 = exec_simple_expression(); /* first simple expression */ + result_tp = tp1; + + /* process relop sexp, if any */ + if ((ctoken == EQUAL) || (ctoken == LT) || (ctoken == GT) || + (ctoken == NE) || (ctoken == LE) || (ctoken == GE) || + (ctoken == COLONEQUALCOLON) || (ctoken == COLONNEQCOLON) || + (ctoken == IN) || (ctoken == XLIKE) ) { + op = ctoken; + tp1 = base_type(tp1); + result_tp = logical_typep; + + get_ctoken(); + tp2 = base_type(exec_simple_expression()); /* second simple expression */ + /* get operands */ + operandp1 = tos - 1; + operandp2 = tos; + + if (undef_types(tp1, tp2) || undef_values(operandp1, operandp2)) { + put_unknown(operandp1); + pop(); + expression_type_debug(result_tp); + exit_debug("exec_expression"); + return(result_tp); + } + + log = do_relop(operandp1, tp1, op, operandp2, tp2); + /* replace the two operands on the stack by the result */ + put_logical(operandp1, log); + pop(); + } /* end if on relop */ + + + expression_type_debug(result_tp); + exit_debug("exec_expression"); + return(result_tp); +} /* end exec_expression */ +/***************************************************************************/ + + +/***************************************************************************/ +/* do_relop() execute a relop expression */ + +LOGICAL_REP do_relop(operandp1, tp1, op, operandp2, tp2) +STACK_ITEM_PTR operandp1, operandp2; /* the operands */ +TYPE_STRUCT_PTR tp1, tp2; /* their types */ +TOKEN_CODE op; /* the relop */ +{ + int result; + LOGICAL_REP log; + + entry_debug("do_relop (l2xixxpr.c)"); + + if (((tp1 == integer_typep) && (tp2 == integer_typep)) || + (tp1->form == ENUM_FORM)) { + /* both operands are integer, bool or enum */ + switch (op) { + case EQUAL: + case COLONEQUALCOLON: { + result = get_integer(operandp1) == get_integer(operandp2); + break; + } + case LT: { + result = get_integer(operandp1) < get_integer(operandp2); + break; + } + case GT: { + result = get_integer(operandp1) > get_integer(operandp2); + break; + } + case NE: + case COLONNEQCOLON: { + result = get_integer(operandp1) != get_integer(operandp2); + break; + } + case LE: { + result = get_integer(operandp1) <= get_integer(operandp2); + break; + } + case GE: { + result = get_integer(operandp1) >= get_integer(operandp2); + break; + } + } /* end switch on op */ + } + + else if ((tp1 == real_typep) || (tp2 == real_typep)) { + /* One operand real, t'other real or integer */ + promote_operands_to_real(operandp1, tp1, operandp2, tp2); + + switch (op) { + case EQUAL: + case COLONEQUALCOLON: { + result = get_real(operandp1) == get_real(operandp2); + break; + } + case LT: { + result = get_real(operandp1) < get_real(operandp2); + break; + } + case GT: { + result = get_real(operandp1) > get_real(operandp2); + break; + } + case NE: + case COLONNEQCOLON: { + result = get_real(operandp1) != get_real(operandp2); + break; + } + case LE: { + result = get_real(operandp1) <= get_real(operandp2); + break; + } + case GE: { + result = get_real(operandp1) >= get_real(operandp2); + break; + } + } /* end switch */ + } + + else if (string_operands(tp1, tp2)) { /* strings */ + if (op == XLIKE) { + result = like_expr(get_stacked_string(operandp1), + get_stacked_string(operandp2)); + if (result < 0) { /* invalid pattern */ + runtime_error(INVALID_REGULAR_EXPRESSION); + log = UNKNOWN_REP; + } + else if (result == 0) { + log = FALSE_REP; + } + else { + log = TRUE_REP; + } + exit_debug("do_relop (at LIKE)"); + return(log); + } + else { /* general relational operator */ + int cmp = strncmp(get_stacked_string(operandp1), + get_stacked_string(operandp2)); + + result = (((cmp < 0) && + ((op == NE) || (op == COLONNEQCOLON) || (op == LE) || (op == LT))) + || ((cmp == 0) && + ((op == EQUAL) || (op == COLONEQUALCOLON) || (op == LE) || (op == GE))) + || ((cmp > 0) && + ((op == NE) || (op == COLONNEQCOLON) || (op == GE) || (op == GT)))); + } + } + + else if (is_dynagg(tp1) || is_dynagg(tp2)) { /* dynamic agg */ + log = exec_dynagg_relop(tp1, operandp1, op, tp2, operandp2); + exit_debug("do_relop (at dynagg)"); + return(log); + } + + exit_debug("do_relop"); + if (result == TRUE) return(TRUE_REP); + else return(FALSE_REP); + +} /* end DO_RELOP */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_simple_expression() Execute a simple expression */ +/* [ ] { } */ +/* return a pointer to the type structure. */ + +TYPE_STRUCT_PTR exec_simple_expression() +{ + STACK_ITEM_PTR operandp1, operandp2; /* ptrs to operands */ + TYPE_STRUCT_PTR result_tp, tp2; /* ptrs to types */ + TOKEN_CODE op; /* operator token */ + TOKEN_CODE unary_op = PLUS; /* unary op token */ + XPRSAINT i1; + LOGICAL_REP b1, b2, br; + XPRSAREAL r1; + STRING str; + entry_debug("exec_simple_expression"); + + /* remember unary op */ + if ((ctoken == PLUS) || (ctoken == MINUS)) { + unary_op = ctoken; + get_ctoken(); + } + + result_tp = exec_term(); /* first term */ + + /* if there was a unary MINUS, negate the top of the stack */ + if (unary_op == MINUS) { + if (!is_value_undef(tos)) { + if (result_tp == integer_typep) put_integer(tos, -get_integer(tos)); + else put_real(tos, -get_real(tos)); + } + } + + /* loop to process following terms (seperated by ) */ + while ((ctoken == PLUS) || (ctoken == MINUS) || + (ctoken == OR) || (ctoken == XXOR) ) { + op = ctoken; /* operator */ + result_tp = base_type(result_tp); + + get_ctoken(); + tp2 = base_type(exec_term()); /* term */ + + operandp1 = tos - 1; + operandp2 = tos; + + if (undef_values(operandp1, operandp2)) { + put_undef(operandp1); + } + + else if ((op == OR) || (op == XXOR)) { + b1 = get_logical(operandp1); + b2 = get_logical(operandp2); + br = FALSE_REP; + if (op == OR) { /* term OR term */ + if (b1 == FALSE_REP && b2 == FALSE_REP) { + br = FALSE_REP; + } + else if (b1 == UNKNOWN_REP && + (b2 == UNKNOWN_REP || b2 == FALSE_REP)) { + br = UNKNOWN_REP; + } + else if (b1 == FALSE_REP && b2 == UNKNOWN_REP) { + br = UNKNOWN_REP; + } + else { + br = TRUE_REP; + } + } + else { /* term XOR term */ + if (b1 == TRUE_REP && b2 == TRUE_REP) { + br = FALSE_REP; + } + else if (b1 == TRUE_REP && b2 == FALSE_REP) { + br = TRUE_REP; + } + else if (b1 == FALSE_REP && b2 == TRUE_REP) { + br = TRUE_REP; + } + else if (b1 == FALSE_REP && b2 == FALSE_REP) { + br = FALSE_REP; + } + else { + br = UNKNOWN_REP; + } + } + put_logical(operandp1, br); + result_tp = logical_typep; + } + + /* op is + or - */ + else if ((result_tp == integer_typep) && + (tp2 == integer_typep)) { + /* both operands are integer */ + i1 = (op == PLUS) + ? get_integer(operandp1) + get_integer(operandp2) + : get_integer(operandp1) - get_integer(operandp2); + put_integer(operandp1, i1); + result_tp = integer_typep; + } + else if ((result_tp == string_typep || result_tp->form == STRING_FORM) && + (tp2 == string_typep || tp2->form == STRING_FORM)) { + /* two strings, plus is only operator */ + if (op == PLUS) { + str = concat_strings(operandp1, operandp2); + free(get_stacked_string(operandp1)); + put_string(operandp1, str); + result_tp = string_typep; + result_tp->form == STRING_FORM; + } + } + else { + /* mix of real and integer */ + promote_operands_to_real(operandp1, result_tp, operandp2, tp2); + r1 = (op == PLUS) + ? get_real(operandp1) + get_real(operandp2) + : get_real(operandp1) - get_real(operandp2); + put_real(operandp1, r1); + result_tp = real_typep; + } + + /* pop off the second operand */ + pop(); + } /* end while over */ + + exit_debug("exec_simple_expression"); + return(result_tp); +} /* end exec_simple_expression */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_term() Execute a term */ +/* { } */ +/* return a pointer to the type structure. */ + +TYPE_STRUCT_PTR exec_term() +{ + STACK_ITEM_PTR operandp1, operandp2; /* ptrs to operands */ + TYPE_STRUCT_PTR result_tp, tp2; /* ptrs to types */ + TOKEN_CODE op; /* operator token */ + XPRSAINT i1; + XPRSAREAL r1; + LOGICAL_REP b1, b2, br; + entry_debug("exec_term"); + + result_tp = exec_factor(); /* first factor */ + + /* loop to process following pairs */ + while ((ctoken == STAR) || (ctoken == SLASH) || (ctoken == DIV) || + (ctoken == MOD) || (ctoken == AND) || (ctoken == BARBAR)) { + op = ctoken; + result_tp = base_type(result_tp); + + get_ctoken(); + tp2 = exec_factor(); /* next factor */ + + operandp1 = tos - 1; + operandp2 = tos; + + if (undef_values(operandp1, operandp2)) { + put_undef(operandp1); + } + + else if (op == AND) { + b1 = get_logical(operandp1); + b2 = get_logical(operandp2); + if (b1 == TRUE_REP && b2 == TRUE_REP) { + br = TRUE_REP; + } + else if (b1 == TRUE_REP && b2 == UNKNOWN_REP) { + br = UNKNOWN_REP; + } + else if (b1 == UNKNOWN_REP && b2 == TRUE_REP) { + br = UNKNOWN_REP; + } + else if (b1 == UNKNOWN_REP && b2 == UNKNOWN_REP) { + br = UNKNOWN_REP; + } + else { + br = FALSE_REP; + } + put_logical(operandp1, br); + result_tp = logical_typep; + } + + else if (op == BARBAR) { + runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE); +/* result_tp = &dummy_typep; */ + } + + else { + /* *, /, DIV or MOD */ + switch (op) { + case STAR: { + if ((result_tp == integer_typep) && (tp2 == integer_typep)) { + /* integer operands */ + i1 = get_integer(operandp1) * get_integer(operandp2); + put_integer(operandp1, i1); + result_tp = integer_typep; + } + else { + /* at least one real */ + promote_operands_to_real(operandp1, result_tp, operandp2, tp2); + r1 = get_real(operandp1) * get_real(operandp2); + put_real(operandp1, r1); + result_tp = real_typep; + } + break; + } + case SLASH: { + promote_operands_to_real(operandp1, result_tp, operandp2, tp2); + if (get_real(operandp2) == 0.0) { + runtime_error(DIVISION_BY_ZERO); + } + else { + r1 = get_real(operandp1) / get_real(operandp2); + put_real(operandp1, r1); + } + result_tp = real_typep; + break; + } + case DIV: + case MOD: { + /* both operands integer */ + if (get_integer(operandp2) == 0) { + runtime_error(DIVISION_BY_ZERO); + } + else { + i1 = (op == DIV) + ? get_integer(operandp1) / get_integer(operandp2) + : get_integer(operandp1) % get_integer(operandp2); + put_integer(operandp1, i1); + } + result_tp = integer_typep; + break; + } + } /* end switch */ + } + + /* pop off the second operand */ + pop(); + + } /* end while over op/factor pairs */ + + exit_debug("exec_term"); + return(result_tp); +} /* end exec_term */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_factor() Execute an EXPRESS factor */ +/* ** */ +/* return a pointer to the type structure */ + +TYPE_STRUCT_PTR exec_factor() +{ + TYPE_STRUCT_PTR result_tp; /* ptr to type */ + STACK_ITEM_PTR operand1, operand2; /* ptrs to operands */ + TYPE_STRUCT_PTR tp2; + XPRSAINT i1, i2, i; + XPRSAREAL r1, r2, r; + entry_debug("exec_factor"); + + result_tp = exec_simple_factor(); /* first operand */ + + if (ctoken == STARSTAR) { /* have an operator */ + result_tp = base_type(result_tp); + + get_ctoken(); + tp2 = base_type(exec_simple_factor()); + + operand1 = tos - 1; + operand2 = tos; + + if (undef_values(operand1, operand2)) { + put_undef(operand1); + } + + else if ((result_tp == integer_typep) && (tp2 == integer_typep)) { + /* integer operands */ + i1 = get_integer(operand1); + i2 = get_integer(operand2); + if ((i1 == 0) && (i2 <= 0) ) { + runtime_error(INVALID_FUNCTION_ARGUMENT); + } + else { + i = (XPRSAINT) pow((double) i1, (double) i2); + sprintf(dbuffer, "i1= %d, i2= %d, pow(i1, i2)= %d\n", i1, i2, i); + debug_print(dbuffer); + put_integer(operand1, i); + result_tp = integer_typep; + } + } + else { + /* at least one real */ + if ((tp2 == integer_typep)) { /* first real, second int */ + r1 = get_real(operand1); + i2 = get_integer(operand2); + if ((r1 == 0.0) && (i2 <= 0)) { + runtime_error(INVALID_FUNCTION_ARGUMENT); + } + else { + r = (XPRSAREAL) pow((double) r1, (double) i2); + put_real(operand1, r); + result_tp = real_typep; + } + } + else if ((result_tp == real_typep) && (tp2 == real_typep)) { + r1 = get_real(operand1); + r2 = get_real(operand2); + if (((r1 == 0.0) && (r2 <= 0.0)) || (r1 < 0.0)) { + runtime_error(INVALID_FUNCTION_ARGUMENT); + } + else { + r = (XPRSAREAL) pow((double) r1, (double) r2); + put_real(operand1, r); + result_tp = real_typep; + } + } + else { /* first int, second real */ + i1 = get_integer(operand1); + r2 = get_real(operand2); + if ((i1 == 0) && (r2 <= 0.0)) { + runtime_error(INVALID_FUNCTION_ARGUMENT); + } + else { + r = (XPRSAREAL) pow((double) i1, (double) r2); + put_real(operand1, r); + result_tp = real_typep; + } + } + } + + pop(); /* pop off the second operand */ + } + + exit_debug("exec_factor"); + return(result_tp); +} /* end EXEC_FACTOR */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_simple_factor() Execute a simple factor */ +/* | | NOT | ( ) */ +/* or an interval expression = {expr op expr op expr} */ +/* return a pointer to the type structure. */ + +TYPE_STRUCT_PTR exec_simple_factor() +{ + TYPE_STRUCT_PTR result_tp; /* ptr to type */ + TYPE_STRUCT_PTR tp1, tp2, tp3; + LOGICAL_REP b1, br; + TOKEN_CODE op1, op2; + STACK_ITEM_PTR operandp1, operandp2, operandp3; + STACK_TYPE t1, t2, t3; + entry_debug("exec_simple_factor"); + + switch (ctoken) { + case IDENTIFIER: { + SYMTAB_NODE_PTR idp = get_symtab_cptr(); + + if (idp->defn.key == FUNC_DEFN) { + result_tp = exec_routine_call(idp); + } + else if (idp->defn.key == CONST_DEFN) { + result_tp = exec_constant(idp); + } + else { + result_tp = exec_variable(idp, EXPR_USE); + } + break; + } + case NUMBER_LITERAL: { + SYMTAB_NODE_PTR np = get_symtab_cptr(); + + /* get the number from the symbol table and push it on the stack */ + if (np->typep == integer_typep) { + push_integer(np->defn.info.constant.value.integer); + result_tp = integer_typep; + } + else { + push_real(np->defn.info.constant.value.real); + result_tp = real_typep; + } + + get_ctoken(); + break; + } + + case STRING_LITERAL: { + SYMTAB_NODE_PTR np = get_symtab_cptr(); + int length = strlen(np->name); + push_string((STRING) np->info); + result_tp = np->typep; + get_ctoken(); + break; + } + + case NOT: { + get_ctoken(); + result_tp = exec_simple_factor(); + if (is_undef(result_tp) || is_value_undef(tos)) { + put_undef(tos); + } + else { + b1 = get_logical(tos); + if (b1 == TRUE_REP) { + br = FALSE_REP; + } + else if (b1 == FALSE_REP) { + br = TRUE_REP; + } + else { + br = UNKNOWN_REP; + } + put_logical(tos, br); /* TRUE -> FALSE, FALSE -> TRUE */ + } + break; + } + + case LPAREN: { + get_ctoken(); + result_tp = exec_expression(); + get_ctoken(); /* the token after the ) */ + break; + } + + case LBRACE: { /* interval expression */ + result_tp = logical_typep; + get_ctoken(); + tp1 = exec_simple_expression(); + op1 = ctoken; + get_ctoken(); + tp2 = exec_simple_expression(); + op2 = ctoken; + get_ctoken(); + tp3 = exec_simple_expression(); + get_ctoken(); /* the token after the } */ + operandp1 = tos - 2; + operandp2 = tos - 1; + operandp3 = tos; + pop(); + pop(); + /* check if anything is indeterminate */ + t1 = get_stackval_type(operandp1); + if (t1 == STKUDF) { + put_unknown(operandp1); + break; + } + t2 = get_stackval_type(operandp2); + if (t2 == STKUDF) { + put_unknown(operandp1); + break; + } + t3 = get_stackval_type(operandp3); + if (t3 == STKUDF) { + put_unknown(operandp1); + break; + } + /* check first condition */ + b1 = do_relop(operandp1, tp1, op1, operandp2, tp2); + if (b1 == FALSE_REP) { + put_false(operandp1); + break; + } + /* and the second */ + br = do_relop(operandp2, tp2, op2, operandp3, tp3); + if (br == FALSE_REP) { + put_false(operandp1); + break; + } + if (b1 == TRUE_REP && br == TRUE_REP) { + put_true(operandp1); + } + else { + put_unknown(operandp1); + } + break; + } + + } /* end switch */ + + expression_type_debug(result_tp); + exit_debug("exec_simple_factor"); + return(result_tp); +} /* end exec_simple_factor */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_constant(idp) Push the value of a non-string constant id, */ +/* or the address of a string constant id onto the stack */ +/* return a pointer to the type structure. */ + +TYPE_STRUCT_PTR exec_constant(idp) +SYMTAB_NODE_PTR idp; /* constant id */ +{ + TYPE_STRUCT_PTR tp = idp->typep; /* ptrs to types */ + entry_debug("exec_constant"); + + if (base_type(tp) == logical_typep) { + push_logical(idp->defn.info.constant.value.integer); + } + else if ((base_type(tp) == integer_typep) || (tp->form == ENUM_FORM)) { + push_integer(idp->defn.info.constant.value.integer); + } + else if (tp == real_typep) { + push_real(idp->defn.info.constant.value.real); + } + else if (tp->form == ARRAY_FORM) { + push_address((ADDRESS) idp->defn.info.constant.value.stringp); + } + else if (tp->form == STRING_FORM) { + push_string((STRING) idp->defn.info.constant.value.stringp); + } + else if (is_undef(tp)) { + push_undef(); + } + + trace_data_fetch(idp, tp, tos); + get_ctoken(); + + exit_debug("exec_constant"); + return(tp); +} /* end exec_constant */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_variable(idp, use) Push either the variable's address or its */ +/* value onto the stack */ +/* return a pointer to the type structure. */ + +TYPE_STRUCT_PTR exec_variable(idp, use) +SYMTAB_NODE_PTR idp; /* variable id */ +USE use; /* how variable is used */ +{ + int delta; /* difference in levels */ + TYPE_STRUCT_PTR tp = idp->typep; /* ptrs to types */ + TYPE_STRUCT_PTR base_tp; /* ptrs to types */ + STACK_ITEM_PTR datap; /* ptr to data area */ + STACK_ITEM_PTR hp; + STACK_TYPE stype; + entry_debug("exec_variable (l2xixxpr.c)"); + + /* point to the variable's stack item. If the variable's level */ + /* is less than the current level, follow the static links to the */ + /* appropriate stack frame base */ + hp = (STACK_ITEM_PTR) stack_frame_basep; + delta = level - idp->level; + while (delta-- > 0) { + hp = (STACK_ITEM_PTR) get_static_link(hp); + } + datap = hp + idp->defn.info.data.offset; + + /* If a scalar or enumeration VAR parm, that item points to the */ + /* actual item */ + if ((idp->defn.key == VARPARM_DEFN) && + (tp->form != ARRAY_FORM) && + (tp->form != ENTITY_FORM) && + (tp->form != BAG_FORM) && + (tp->form != LIST_FORM) && + (tp->form != SET_FORM)) { + datap = (STACK_ITEM_PTR) get_address(datap); + } + + /* push the address of the variables data area */ + if ((tp->form == BAG_FORM) || + (tp->form == LIST_FORM) || + (tp->form == SET_FORM)) { + stype = form2stack[tp->form]; + push_address_type(get_address_type(datap, stype), stype); + } + else if ((tp->form == ARRAY_FORM) || + (tp->form == ENTITY_FORM)) { + push_address((ADDRESS) get_address(datap)); + } + else { + push_address((ADDRESS) datap); + } + + get_ctoken(); + + /* for a string, may be dealing with a substring only */ + if (tp->form == STRING_FORM) { + if (ctoken == LBRACKET) { + exec_substring(use); + if (use != TARGET_USE && use != VARPARM_USE) { + exit_debug("exec_variable"); + return(tp); + } + } + } + else { + /* if there are any subscripts or attribute designators, */ + /* modify the address to point to the array element record field */ + while ((ctoken == LBRACKET) || (ctoken == PERIOD)) { + if (ctoken == LBRACKET) tp = exec_subscripts(tp); + else if (ctoken == PERIOD) tp = exec_attribute(); + } + } + + base_tp = base_type(tp); + + /* leave the modified address on top of the stack if it: */ + /* is an assignment target */ + /* represents a parameter passed by reference */ + /* is the address of an array or entity */ + /* Otherwise, replace the address with the value it points to */ + + if ((use != TARGET_USE) && (use != VARPARM_USE) && + (tp->form != ARRAY_FORM) && + (tp->form != ENTITY_FORM) && + (tp->form != BAG_FORM) && + (tp->form != LIST_FORM) && + (tp->form != SET_FORM)) { + if (is_value_undef(get_address(tos))) { + put_undef(tos); + } + else if (base_tp == logical_typep) { + put_logical(tos, get_logical(get_address(tos))); + } + else if ((base_tp == integer_typep) || (tp->form == ENUM_FORM)) { + put_integer(tos, get_integer(get_address(tos))); + } + else if (tp->form == STRING_FORM) { + put_string(tos, get_stacked_string(get_address(tos))); + } + else if (tp->form == BAG_FORM || + tp->form == LIST_FORM || + tp->form == SET_FORM) { + stype = get_stackval_type(tos); + put_address_type(tos, get_address_type(tos, stype), stype); + } + else { + put_real(tos, get_real(get_address(tos))); + } + } + + if ((use != TARGET_USE) && (use != VARPARM_USE)) { + stype = get_stackval_type(tos); + if ((tp->form == ARRAY_FORM) || + (tp->form == ENTITY_FORM) || + (tp->form == BAG_FORM) || + (tp->form == LIST_FORM) || + (tp->form == SET_FORM)) { + trace_data_fetch(idp, tp, get_address_type(tos, stype)); + } + else { + trace_data_fetch(idp, tp, tos); + } + } + + expression_type_debug(tp); + exit_debug("exec_variable"); + return(tp); +} /* end exec_variable */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_substring() Execute subscripts to modify the string on top */ +/* of the stack */ +/* at entry: ctoken is the opening [ */ +/* at exit: ctoken is after the closing ] */ + +exec_substring(usage) +USE usage; /* how the var is used */ +{ + XPRSAINT subscript1_value, subscript2_value; + STRING strorig; + STRING strnew; + int num, i, j; + entry_debug("exec_substring (l2xixxpr.c)"); + + /* save the current string */ + strorig = get_stacked_string(get_address(tos)); + + /* do first expression */ + get_ctoken(); + exec_expression(); + subscript1_value = get_integer(tos); + pop(); + /* check value in range */ + if ((subscript1_value < 1) || + (subscript1_value > MAX_EXPRESS_STRING)) { + runtime_error(VALUE_OUT_OF_RANGE); + } + subscript2_value = subscript1_value; + + if (ctoken == COLON) { /* do next expression */ + get_ctoken(); + exec_expression(); + subscript2_value = get_integer(tos); + pop(); + /* check value in range */ + if ((subscript2_value < subscript1_value) || + (subscript2_value > MAX_EXPRESS_STRING)) { + runtime_error(VALUE_OUT_OF_RANGE); + } + } + + get_ctoken(); /* token after closing ] */ + + /* now do the substring stuff */ + num = (subscript2_value - subscript1_value + 1); /* no of chars */ + strnew = alloc_bytes(num+1); + j = 0; + for (i = subscript1_value - 1; i < subscript2_value; i++) { + strnew[j] = strorig[i]; + j++; + } + strnew[j] = '\0'; + /* replace strorig in the stack with strnew, unless a lhs */ + if (usage != TARGET_USE && usage != VARPARM_USE) { + put_string(tos, strnew); + } + + exit_debug("exec_substring"); + return; +} /* end EXEC_SUBSTRING */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_subscripts(tp) Execute subscripts to modify the array data area */ +/* address on the top of the stack */ +/* return a pointer to the type of the array element */ + +TYPE_STRUCT_PTR exec_subscripts(tp) +TYPE_STRUCT_PTR tp; /* ptr to type structure */ +{ + XPRSAINT subscript_value; + STACK_ITEM_PTR adr, dat; + STACK_TYPE stype; + LBS_PTR lbs; + LBS_NODE_PTR node; + entry_debug("exec_subscripts"); + + /* loop to execute bracketed subscripts */ + if (tp->form == ARRAY_FORM) { + while (ctoken == LBRACKET) { + /* loop to execute a subscript list */ + do { + get_ctoken(); + exec_expression(); + + subscript_value = get_integer(tos); + pop(); + + /* range check */ + if ((subscript_value < tp->info.array.min_index) || + (subscript_value > tp->info.array.max_index)) { + runtime_error(VALUE_OUT_OF_RANGE); + } + + /* modify the data area address */ + adr = (STACK_ITEM_PTR) get_address(tos); + adr = adr + + ((subscript_value - tp->info.array.min_index) * + (tp->info.array.elmt_typep->size))/sizeof(STACK_ITEM); + put_address(tos, adr); + + if (ctoken == COMMA) tp = tp->info.array.elmt_typep; + } while (ctoken == COMMA); /* end do */ + + get_ctoken(); + if (ctoken == LBRACKET) tp = tp->info.array.elmt_typep; + } /* end while */ + } /* end of array processing */ + + else if (tp->form == BAG_FORM || + tp->form == LIST_FORM || + tp->form == SET_FORM) { /* dynamic aggregate */ + stype = form2stack[tp->form]; + while (ctoken == LBRACKET) { + get_ctoken(); + exec_expression(); + + subscript_value = get_integer(tos); + pop(); + + /* range check */ + if ((subscript_value < tp->info.dynagg.min_index) || + (subscript_value > tp->info.dynagg.max_index)) { + runtime_error(VALUE_OUT_OF_RANGE); + } + + /* get the element from the aggregate */ + lbs = (LBS_PTR) get_address_type(tos, stype); + /* outside element count? */ + sprintf(dbuffer, "lbs = %d, el count = %d, subscript = %d\n", + lbs, NELS(lbs), subscript_value); + debug_print(dbuffer); + if (subscript_value > NELS(lbs)) runtime_error(VALUE_OUT_OF_RANGE); + node = lbs_get_nth(lbs, subscript_value); + sprintf(dbuffer, "node = %d\n", node); + debug_print(dbuffer); + /* put the element data on top of the stack */ + dat = (STACK_ITEM_PTR) DATA(node); + sprintf(dbuffer, "data = %d\n", dat); + debug_print(dbuffer); + copy_value(tos, dat); + + get_ctoken(); + if (ctoken == LBRACKET) tp = tp->info.dynagg.elmt_typep; + } /* end while */ + } /* end of dynamic aggregate processing */ + + exit_debug("exec_subscripts"); + return(tp); +} /* end exec_subscripts */ +/***************************************************************************/ + + + + +/***************************************************************************/ +/* exec_attribute() Execute an attribute designator to modify the */ +/* entity data */ +/* address area on the top of the stack */ +/* return a pointer to the type of the attribute */ + +TYPE_STRUCT_PTR exec_attribute() +{ + SYMTAB_NODE_PTR attr_idp; + ADDRESS adr; + entry_debug("exec_attribute (l2xixxpr.c)"); + + get_ctoken(); + attr_idp = get_symtab_cptr(); + + adr = get_address(tos); + adr += attr_idp->defn.info.data.offset; + put_address(tos, adr); + + get_ctoken(); + + exit_debug("exec_attribute"); + return(attr_idp->typep); +} /* end EXEC_ATTRIBUTE */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* promote_operands_to_real(operandp1, tp1, operandp2, tp2) If either */ +/* operand is integer, convert it to real */ + +promote_operands_to_real(operandp1, tp1, operandp2, tp2) +STACK_ITEM_PTR operandp1, operandp2; /* ptrs to operands */ +TYPE_STRUCT_PTR tp1, tp2; /* ptrs to types */ +{ + XPRSAINT i1; + entry_debug("promote_operands_to_real"); + + if (tp1 == integer_typep) { + if (!is_value_undef(operandp1)) { + i1 = get_integer(operandp1); + put_real(operandp1, (XPRSAREAL) i1); + } + } + if (tp2 == integer_typep) { + if (!is_value_undef(operandp2)) { + i1 = get_integer(operandp2); + put_real(operandp2, (XPRSAREAL) i1); + } + } + + + exit_debug("promote_operands_to_real"); + return; +} /* end promote_operands_to_real */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* concat_strings() Concatenate two strings */ + +STRING concat_strings(op1, op2) +STACK_ITEM_PTR op1; /* pos of first string in the stack */ +STACK_ITEM_PTR op2; /* pos of second string in the stack */ +{ + int n1 = strlen(get_stacked_string(op1)); + int n2 = strlen(get_stacked_string(op2)); + int tot, i, j; + STRING str = NULL; + STRING two; + entry_debug("concat_strings (l2xixxpr.c)"); + + tot = n1 + n2; + if (tot <= MAX_EXPRESS_STRING) { + str = alloc_bytes(n1 + n2 + 1); + strcpy(str, get_stacked_string(op1)); + strcat(str, get_stacked_string(op2)); + } + else { + runtime_error(RUNTIME_STRING_TOO_LONG); + tot = MAX_EXPRESS_STRING; + str = alloc_bytes(tot + 1); + strcpy(str, get_stacked_string(op1)); + two = get_stacked_string(op2); + j = n1; + for (i = 0; j <= tot; i++) { + str[j++] = two[i]; + } + str[j] = '\0'; + } + + exit_debug("concat_strings"); + return(str); +} /* end CONCAT_STRINGS */ +/***************************************************************************/ + + + +/***************************************************************************/ +/* exec_dynagg_relop(t1, p1, op, t2, p2) Execute a relop on dynamic */ +/* aggregates */ +/* p1 op p2 */ +/* returns a logical result */ + +LOGICAL_REP exec_dynagg_relop(t1, p1, op, t2, p2) +TYPE_STRUCT_PTR t1; /* type of p1 */ +STACK_ITEM_PTR p1; /* value of p1 */ +TOKEN_CODE op; /* the operator */ +TYPE_STRUCT_PTR t2; /* type of p2 */ +STACK_ITEM_PTR p2; /* value of p2 */ +{ + LOGICAL_REP result; + STACK_ITEM_PTR agg; + LBS_NODE_PTR nod, nextnod; + STACK_TYPE agtp = get_stackval_type(p2); + LBS_PTR head; + + entry_debug("exec_dynagg_relop (l2xixxpr.c)"); + + sprintf(dbuffer, "t1 = %d, p1 = %d, t2 = %d, p2 = %d\n", t1, p1, t2, p2); + debug_print(dbuffer); + + if (op == IN) { /* element IN agg */ + if (t1 != t2->info.dynagg.elmt_typep) { /* not an element */ + exit_debug("exec_dynagg_relop"); + return(FALSE_REP); + } + /* get first node */ + head = (LBS_PTR) get_address_type(p2, agtp); + debug_print("Getting first node\n"); + nod = lbs_get_next_el(head, NULL); + sprintf(dbuffer, "nod = %d\n", nod); + debug_print(dbuffer); + + while (nod != NULL) { /* loop over all nodes */ + debug_print("Testing for value equality\n"); + sprintf(dbuffer, "data = %d\n", DATA(nod)); + debug_print(dbuffer); + result = stack_value_equal(p1, DATA(nod)); + if (result == UNKNOWN_REP || result == TRUE_REP) { + exit_debug("exec_dynagg_relop (p1 IN p2 not FALSE)"); + return(result); + } + debug_print("Getting next node\n"); + nod = lbs_get_next_el(head, nod); + sprintf(dbuffer, "nod = %d\n", nod); + debug_print(dbuffer); + } + exit_debug("exec_dynagg_relop (p1 IN p2 is FALSE"); + return(FALSE_REP); + } + + else { + runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE); + exit_debug("exec_dynagg_relop"); + return(UNKNOWN_REP); + } + + +} /* end EXEC_DYNAGG_RELOP */ +/***************************************************************************/ + + + + + + -- cgit v1.2.3