path: root/support/ltx2x/l2xixxpr.c

/* 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 */
/***************************************************************************/