/* l2xixxpr.c LTX2X interpreter expression executor routines */
/* Written by: Peter Wilson, CUA
[email protected] */
/* 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 */
/***************************************************************************/
