summaryrefslogtreecommitdiff
path: root/support/ltx2x/l2xixxpr.c
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/ltx2x/l2xixxpr.c
Initial commit
Diffstat (limited to 'support/ltx2x/l2xixxpr.c')
-rw-r--r--support/ltx2x/l2xixxpr.c1234
1 files changed, 1234 insertions, 0 deletions
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 <stdio.h>
+#include <math.h>
+#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 */
+/* <sexp> [ <relop> <sexp> ] */
+/* 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 */
+/* [ <unary-op> ] <term> <pmop> <term> { <pmop> <term> } */
+/* 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 <op> ) */
+ 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 <op> <term> */
+
+ exit_debug("exec_simple_expression");
+ return(result_tp);
+} /* end exec_simple_expression */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* exec_term() Execute a term */
+/* <factor> <multop> <factor> { <multop> <factor> } */
+/* 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 <multop> <factor> 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 */
+/* <simple_factor> ** <simple_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 */
+/* <variable> | <number> | NOT <simple_factor> | ( <expression> ) */
+/* 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 */
+/***************************************************************************/
+
+
+
+
+
+