path: root/support/ltx2x/l2xixstd.c

/* l2xixstd.c  LTX2X interpreter standard procedure/function Executor routines */
/*  Written by: Peter Wilson, CUA  pwilson@cme.nist.gov                */
/*  This code is partly based on algorithms presented by Ronald Mak in */
/*  "Writing Compilers & Interpreters", John Wiley & Sons, 1991        */

#include <stdio.h>
#include <stdlib.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"


#define DEFAULT_NUMERIC_FIELD_WIDTH 10
#define DEFAULT_PRECISION 4
  /* added for ltx2x */
#define MAX_LTX2X_BUFFER 2000

/* EXTERNALS */


extern int level;
extern int exec_line_number;         /* no. of line executed */

extern ICT *code_segmentp;           /* code segment ptr */ /* used? */
extern TOKEN_CODE ctoken;            /* token from code segment */
 
extern STACK_ITEM *stack;                  /* runtime stack */
extern STACK_ITEM_PTR tos;                 /* ptr to top of runtime stack */
extern STACK_ITEM_PTR stack_frame_basep;   /* ptr to stack fame base */
extern STACK_ITEM_PTR stack_display[];     /*  ????????? */


extern BOOLEAN is_value_undef();

extern STRING get_stacked_string();

extern STACK_TYPE form2stack[];            /* map form type to stack type */
extern TYPE_FORM stack2form[];             /* map stack type to form type */

extern STACK_ITEM_PTR create_copy_value();

/* FORWARDS */

TYPE_STRUCT_PTR exec_eof_eoln(), exec_abs_sqr(),
                exec_arctan_cos_exp_ln_sin_sqrt(),
                exec_odd(), exec_round_trunc();
TYPE_STRUCT_PTR exec_atan(), exec_exists_etc(), exec_nvl_etc();
TYPE_STRUCT_PTR exec_rexpr_etc(), exec_hibound_etc(), exec_length_etc();

/* GLOBALS */

BOOLEAN eof_flag = FALSE;
char acbuffer[MAX_LTX2X_BUFFER];        /* added for ltx2x */



/************************************************************************/
/* exec_standard_routine_call(rtn_idp)  Execute a call to a standard    */
/*                                      procedure or function           */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_standard_routine_call(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  entry_debug("exec_standard_routine_call");

  switch (rtn_idp->defn.info.routine.key) {
    case READ:
    case READLN: {
      exec_read_readln(rtn_idp);
      exit_debug("exec_standard_routine_call");
      return(NULL);
    }
    case WRITE: 
    case WRITELN: {
      exec_write_writeln(rtn_idp);
      exit_debug("exec_standard_routine_call");
      return(NULL);
    }
    case EOFF: 
    case EOLN: {
      exit_debug("exec_standard_routine_call");
      return(exec_eof_eoln(rtn_idp));
    }
    case ABS:        /* real or int -> real or int */
              {
      exit_debug("exec_standard_routine_call");
      return(exec_abs_sqr(rtn_idp));
    }
    case COS:        /* real or int -> real */
    case EXP:
    case SIN:
    case SQRT:
    case XACOS:  
    case XASIN:
    case XLOG:
    case XLOG2:
    case XLOG10:
    case XTAN: {
      exit_debug("exec_standard_routine_call");
      return(exec_arctan_cos_exp_ln_sin_sqrt(rtn_idp));
    }
    case XATAN: {             /* extra for EXPRESS */
      exit_debug("exec_standard_routine_call");
      return(exec_atan(rtn_idp));
    }
    case ODD: {      /* int -> boolean */
      exit_debug("exec_standard_routine_call");
      return(exec_odd());
    }
    case ROUND:      /* real -> int */
    case TRUNC: {
      exit_debug("exec_standard_routine_call");
      return(exec_round_trunc(rtn_idp));
    }
    case L2XPRINT: 
    case L2XPRINTLN: {                         /* added for ltx2x */
      exec_print_println(rtn_idp);
      exit_debug("exec_standard_routine_call");
      return(NULL);
    }
    case L2XSYSTEM: {                          /* added for ltx2x */
      exec_system_etc(rtn_idp);
      exit_debug("exec_standard_routine_call");
      return(NULL);
    }
    case L2XREXPR: {                           /* added for ltx2x */
      exit_debug("exec_standard_routine_call");
      return(exec_rexpr_etc(rtn_idp));
    }
    case XHIBOUND:
    case XHIINDEX:
    case XLOBOUND:
    case XLOINDEX:
    case XSIZEOF: {
      exit_debug("exec_standard_routine_call");
      return(exec_hibound_etc(rtn_idp));
    }
    case XLENGTH: {
      exit_debug("exec_standard_routine_call");
      return(exec_length_etc(rtn_idp));
    }
    case XEXISTS: {
      exit_debug("exec_standard_routine_call");
      return(exec_exists_etc(rtn_idp));
    }
    case XNVL: {
      exit_debug("exec_standard_routine_call");
      return(exec_nvl_etc(rtn_idp));
    }
    case XINSERT:
    case XREMOVE: {
      exec_insert_etc(rtn_idp);
      exit_debug("exec_standard_routine_call");
      return(NULL);
    }
    case XBLENGTH:
    case XFORMAT:
    case XROLESOF:
    case XTYPEOF:
    case XUSEDIN:
    case XVALUE:
    case XVALUE_IN:
    case XVALUE_UNIQUE:  {               /* unimplemented EXPRESS stuff */
      runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE);
      exit_debug("exec_standard_routine_call");
      return(NULL);
    }
    default: {
      runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE);
      break;
    }

  } /* end switch */

  exit_debug("exec_standard_routine_call");
  return(NULL);
}                                     /* end exec_standard_routine_call */
/************************************************************************/



/************************************************************************/
/* exec_read_readln(rtn_idp)  Execute a call to READ or READLN          */

exec_read_readln(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  SYMTAB_NODE_PTR parm_idp;            /* param id */
  TYPE_STRUCT_PTR parm_tp;             /* param type */
  STACK_ITEM_PTR targetp;              /* ptr to read target */
  XPRSAINT i1;
  XPRSAREAL r1;
  int len;
  char ch;
  char tbuff[MAX_LTX2X_BUFFER];
  STRING lhs;

  entry_debug("exec_read_readln");

  /* params are optional for readln */
  get_ctoken();
  if (ctoken == LPAREN) {           /* id list */
    do {
      get_ctoken();
      parm_idp = get_symtab_cptr();
      parm_tp = base_type(exec_variable(parm_idp, VARPARM_USE));
      targetp = (STACK_ITEM_PTR) get_address(tos);
      pop();             /* pop off address */

      if (parm_tp == integer_typep) {
        scanf("%d", &i1); 
        put_integer(targetp, i1);
      }
      else if (parm_tp == real_typep) {
        scanf("%g", &r1); 
        put_real(targetp, r1);
      }
      else {             /* a string or a logical */
        scanf("%sMAX_LTX2X_BUFFER", tbuff);
        len = strlen(tbuff);
        sprintf(dbuffer, "strlen(str) = %d, str = %s\n", len, tbuff);
        debug_print(dbuffer);
        if (parm_tp == logical_typep) {   /* check which one */
          if (len == 4 && (tbuff[0] == 't' || tbuff[0] == 'T')) { /* TRUE */
            put_true(targetp);
          }
          else if (len == 5 && (tbuff[0] == 'f' || tbuff[0] == 'F')) {  /* FALSE */
            put_false(targetp);
          }
          else if (len == 7 && (tbuff[0] == 'u' || tbuff[0] == 'U')) { /* UNKNOWN */
            put_unknown(targetp);
          }
          else {   /* an error */
            runtime_error(INVALID_FUNCTION_ARGUMENT);
            put_unknown(targetp);
          }
	}
        else {             /* a string */
          free(targetp->value.string);
          lhs = alloc_bytes(len+1);
          sprintf(dbuffer, "lhs = %d", lhs);
          debug_print(dbuffer);
          strcpy(lhs, tbuff);
          sprintf(dbuffer, ", str = %s\n", lhs);
          debug_print(dbuffer);
          put_string(targetp, lhs);
        }
      }

      trace_data_store(parm_idp, parm_idp->typep, targetp, parm_tp);
    } while (ctoken == COMMA); /* end do */
    get_ctoken();           /* token after RPAREN */
  }

  if (rtn_idp->defn.info.routine.key == READLN) {
    do {
      ch = getchar();
    } while(!eof_flag && (ch != '\n'));
  }

  exit_debug("exec_read_readln");
  return;
}                                              /* end exec_read_readln  */
/************************************************************************/



/************************************************************************/
/* exec_write_writeln(rtn_idp)  Execute a call to WRITE or WRITELN      */
/*        Each actual parameter can be: <expr>                          */
/*                                  or  <expr> : <expr>                 */
/*                                  or  <expr> : <expr> : <expr>        */

exec_write_writeln(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;               /* parameter type */
  STACK_TYPE stype;
  XPRSAINT field_width;
  XPRSAINT precision;
  entry_debug("exec_write_writeln");

  /* parameters are optional for writeln */
  get_ctoken();
  if (ctoken == LPAREN) {
    do {
      /* push value */
      get_ctoken();
      parm_tp = base_type(exec_expression());

      /* check if dynamic agg */
      if (is_dynagg(parm_tp)) parm_tp = parm_tp->info.dynagg.elmt_typep;

      field_width = DEFAULT_NUMERIC_FIELD_WIDTH;
      precision = DEFAULT_PRECISION;

      /* optional field width expresion */
      if (ctoken == COLON) {
        get_ctoken();
        exec_expression();
        if (!is_value_undef(tos)) {
          field_width = get_integer(tos);
        }
        pop();                      /* field width */

        /* optional decimal places expresion */
        if (ctoken == COLON) {
          get_ctoken();
          exec_expression();
          if (!is_value_undef(tos)) {
            precision = get_integer(tos);
          }
          pop();                      /* precision */
        }
      }

      if (parm_tp->form == ARRAY_FORM) {  /* array, address on top of stack */
        if (get_stackval_type(tos) == STKADD) {
          copy_value(tos, get_address(tos));
        }
      }

     stype = get_stackval_type(tos);

      /* write value */
      if (is_value_undef(tos)) {
        printf("%*c", field_width, get_undef(tos));
      }
      else if (stype == STKINT) {
        printf("%*d", field_width, get_integer(tos));
      }
      else if (stype == STKREA) {
        printf("%*.*g", field_width, precision, get_real(tos));
      }
      else if (stype == STKLOG) {
        field_width = 0;
        switch (get_logical(tos)) {
          case TRUE_REP: {
            printf("%*s", -field_width, "TRUE");
            break;
	  }
          case FALSE_REP: {
            printf("%*s", -field_width, "FALSE");
            break;
	  }
          case UNKNOWN_REP: {
            printf("%*s", -field_width, "UNKNOWN");
            break;
          }
          default: {
            printf("%*s", -field_width, "??UNKNOWN??");
            break;
	  }
        } /* end switch */
      }
      else if (parm_tp == string_typep || parm_tp->form == STRING_FORM) {
        field_width = 0;
        printf("%*s", -field_width, get_stacked_string(tos) );
      }

      pop();     /* value */
    } while (ctoken == COMMA);  /* end do */

    get_ctoken();      /* token after RPAREN */
  } /* end of if over parameters */

  if (rtn_idp->defn.info.routine.key == WRITELN) putchar('\n');

  exit_debug("exec_write_writeln");
  return;
}                                            /* end exec_write_writeln  */
/************************************************************************/



/************************************************************************/
/* exec_print_println(rtn_idp)  Execute a call to PRINT or PRINTLN      */
/*        Each actual parameter can be: <expr>                          */
/*                                  or  <expr> : <expr>                 */
/*                                  or  <expr> : <expr> : <expr>        */
/*  Identical to exec_write_writeln, except output is to ltx2x myprint  */

exec_print_println(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;               /* parameter type */
  STACK_TYPE stype;
  XPRSAINT field_width;
  XPRSAINT precision;
  entry_debug("exec_print_println");

  /* parameters are optional for println */
  get_ctoken();
  if (ctoken == LPAREN) {
    do {
      /* push value */
      get_ctoken();
      parm_tp = base_type(exec_expression());

      /* check if dynamic agg */
      if (is_dynagg(parm_tp)) {
         parm_tp = parm_tp->info.dynagg.elmt_typep;
       }

      field_width = DEFAULT_NUMERIC_FIELD_WIDTH;
      precision = DEFAULT_PRECISION;


      /* optional field width expresion */
      if (ctoken == COLON) {
        get_ctoken();
        exec_expression();
        if (!is_value_undef(tos)) {
          field_width = get_integer(tos);
        }
        pop();                      /* field width */

        /* optional decimal places expresion */
        if (ctoken == COLON) {
          get_ctoken();
          exec_expression();
          if (!is_value_undef(tos)) {
            precision = get_integer(tos);
          }
          pop();                      /* precision */
        }
      }

      if (parm_tp->form == ARRAY_FORM) {   /* array, address on top of stack */
        if (get_stackval_type(tos) == STKADD) {
          copy_value(tos, get_address(tos));
        }
      }
      
      stype = get_stackval_type(tos);
      /* write value */
      if (is_value_undef(tos)) {
        sprintf(acbuffer, "%*c", field_width, get_undef(tos));
      }
      else if (stype == STKINT) {
        sprintf(acbuffer, "%*d", field_width, get_integer(tos));
      }
      else if (stype == STKREA) {
        sprintf(acbuffer, "%*.*g", field_width, precision, get_real(tos));
      }
      else if (stype == STKLOG) {
        field_width = 0;
        switch (get_logical(tos)) {
          case TRUE_REP: {
            sprintf(acbuffer, "%*s", -field_width, "TRUE");
            break;
	  }
          case FALSE_REP: {
            sprintf(acbuffer, "%*s", -field_width, "FALSE");
            break;
	  }
          case UNKNOWN_REP: {
            sprintf(acbuffer, "%*s", -field_width, "UNKNOWN");
            break;
	  }
          default: {
            sprintf(acbuffer, "%*s", -field_width, "??UNKNOWN??");
            break;
	  }
        } /* end switch */
      }
      else if (parm_tp == string_typep || parm_tp->form == STRING_FORM) {
        field_width = 0;
        sprintf(acbuffer, "%*s", -field_width, get_stacked_string(tos) );
      }
      myprint(acbuffer);
      pop();     /* value */
    } while (ctoken == COMMA);  /* end do */

    get_ctoken();      /* token after RPAREN */
  } /* end of if over parameters */

  if (rtn_idp->defn.info.routine.key == L2XPRINTLN) myprint("\n");

  exit_debug("exec_print_println");
  return;
}                                            /* end exec_print_println  */
/************************************************************************/



/************************************************************************/
/* exec_insert_etc(rtn_idp)  Execute a call to procedure INSERT, etc    */
/*        INSERT(<list>, <item>, <posn>)                                */
/*        REMOVE(<list>, <posn>)                                        */
/*  at entry: ctoken is `proc'                                          */
/*  at exit:  ctoken is the token after the closing )                   */

exec_insert_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;               /* parameter type */
  LBS_PTR list;
  LBS_NODE_PTR nod;
  STACK_ITEM_PTR pitem;
  XPRSAINT pos;
  int code = rtn_idp->defn.info.routine.key;

  entry_debug("exec_insert_etc (l2xixstd.c)");

  /* first parameter */
  get_ctoken();       /* should be ( */
  get_ctoken();       /* should be param 1 */
  parm_tp = base_type(exec_expression());
  if (parm_tp->form != LIST_FORM) {
    runtime_error(INVALID_FUNCTION_ARGUMENT);
  }
  list = (LBS_PTR) get_address_type(tos, STKLST);
  sprintf(dbuffer, "list = %d\n", list);
  debug_print(dbuffer);
  pop();  /* first parm */
  get_ctoken();    /* start of next parameter */

  if (code == XINSERT) {             /* do INSERT second param */
    exec_expression();
    pitem = create_copy_value(tos);
    sprintf(dbuffer, "pitem = %d\n", pitem);
    debug_print(dbuffer);
    get_ctoken();   /* start of next parameter */
  }

     /* final parameter */
  parm_tp = base_type(exec_expression());
  pos = get_integer(tos);
  pop();  /* last parm */
  get_ctoken();     /* token after closing ) */

  switch (code) {
    case XINSERT: {
      nod = lbs_insert(list, (genptr) pitem, pos);
      sprintf(dbuffer, "inserted node = %d, with data = %d, at pos = %d, into list = %d\n", 
                        nod, pitem, pos, list);
      debug_print(dbuffer);
      pop(); /* middle parm */
      break;
    }
    case XREMOVE: {
      nod = lbs_remove(list, pos);
      sprintf(dbuffer, "removed node = %d\n", nod);
      debug_print(dbuffer);
      break;
    }
  } /* end switch */

  exit_debug("exec_insert_etc");
  return;
}                                               /* end EXEC_INSERT_ETC  */
/************************************************************************/



/************************************************************************/
/* exec_eof_eoln(rtn_idp)  Execute a call to EOF or EOLN                */
/*                         No parameters => boolean result              */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_eof_eoln(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  char ch = getchar();
  entry_debug("exec_eof_eoln");
  
  switch (rtn_idp->defn.info.routine.key) {
    case EOFF: {
      if (eof_flag || feof(stdin)) {
        eof_flag = TRUE;
        push_true();
      }
      else {
        push_false();
        ungetc(ch, stdin);
      }
      break;
    }
    case EOLN: {
      if (eof_flag || feof(stdin)) {
        eof_flag = TRUE;
        push_true();
      }
      else {
        push_logical(ch == '\n' ? TRUE_REP : FALSE_REP);
        ungetc(ch, stdin);
      }
      break;
    }
  } /* end switch */

  get_ctoken();             /* token after function name */

  exit_debug("exec_eof_eoln");
  return(logical_typep);
}                                                 /* end exec_eof_eoln  */
/************************************************************************/



/************************************************************************/
/* exec_system_etc(rtn_idp)    Execute a call to system, etc            */
/*                         fun('string')                                */
/*                         String parameter, no result                  */
/*    at entry, ctoken is `fun'                                         */
/*    at exit, ctoken is token after closing )                          */

exec_system_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                      /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;                    /* actual param type */
  entry_debug("exec_system_etc");

  get_ctoken();             /* should be ( */
  get_ctoken();             /* start of param */
  parm_tp = base_type(exec_expression());
  if (parm_tp->form != STRING_FORM) {
    runtime_error(INVALID_FUNCTION_ARGUMENT);
  }
  else {
    switch (rtn_idp->defn.info.routine.key) {
      case L2XSYSTEM : {
        system(get_stacked_string(tos));
        break;
      }
      default : {
        runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE);
        break; 
      }
    } /* end switch */
  }

  get_ctoken();         /* token after closing ) */
  exit_debug("exec_system_etc");
  return;
}                                                /* end EXEC_SYSTEM_ETC */
/************************************************************************/



/************************************************************************/
/* exec_rexpr_etc(rtn_idp)  Execute a call to REXPR, etc                */
/*           In general, any function fun(p1, p2) that:                 */
/*           p1 and p2 are strings --> boolean result                   */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_rexpr_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm1_tp, parm2_tp;       /* actual param types */
  TYPE_STRUCT_PTR result_tp = logical_typep;
  STRING parm1, parm2;              /* parameters */
  BOOLEAN undef_parm = FALSE;
  int code = rtn_idp->defn.info.routine.key;
  int result;
  entry_debug("exec_rexpr_etc (l2xixstd.c)");

  get_ctoken();    /* LPAREN */
  get_ctoken();    /* start of first parameter */
  parm1_tp = base_type(exec_expression());
  if (is_value_undef(tos)) {
    undef_parm = TRUE;
  }
  else {
    parm1 = get_stacked_string(tos);
  }
/*  get_ctoken();    COMMA */
  get_ctoken();    /* start of second parameter */
  parm2_tp = base_type(exec_expression());
  if (is_value_undef(tos)) {
    undef_parm = TRUE;
  }
  else {
    parm2 = get_stacked_string(tos);
  }
  pop();

  if (code == L2XREXPR) {  /* parm1 = string, parm2 = pattern */
    if (undef_parm) {
      put_undef(tos);
    }
    else { 
      result = rexpr(parm1, parm2);
      if (result < 0) {
        runtime_error(INVALID_REGULAR_EXPRESSION);
        put_undef(tos);
      }
      else if (result == 0) {
        put_false(tos);
      }
      else {
        put_true(tos);
      }
    }
  }

  get_ctoken();   /* token after RPAREN */

  exit_debug("exec_rexpr_etc");
  return(result_tp);
}                                                 /* end EXEC_REXPR_ETC */
/************************************************************************/



/************************************************************************/
/* exec_hibound_etc(rtn_idp)  Execute a call to HIBOUND, etc            */
/*                   agg type -> integer                                */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_hibound_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;                       /* actual param type */
  TYPE_STRUCT_PTR result_tp = integer_typep;           /* result type */
  XPRSAINT result = 0;
  STACK_TYPE stype;
  TYPE_FORM ftype;
  int code = rtn_idp->defn.info.routine.key;
  entry_debug("exec_hibound_etc");

  get_ctoken();     /* LPAREN */
  get_ctoken();
  parm_tp = base_type(exec_expression());
  if (is_value_undef(tos)) {
    put_undef(tos);
    get_ctoken();   /* token after RPAREN */
    exit_debug("exec_hibound_etc");
    return(result_tp);
  }
  ftype = parm_tp->form;
  if ((ftype != ARRAY_FORM) &&
      (ftype != BAG_FORM) &&
      (ftype != LIST_FORM) &&
      (ftype != SET_FORM) ) {
    runtime_error(INVALID_FUNCTION_ARGUMENT);
    put_undef(tos);
    get_ctoken();   /* token after RPAREN */
    exit_debug("exec_hibound_etc");
    return(result_tp);
  }

  stype = get_stackval_type(tos);
  if (stype != form2stack[ftype] &&
      stype != STKADD) {
    stack_warning(form2stack[ftype], stype);
  }

  switch (code) {
    case XHIBOUND: {                         /* declared upper bound */
      if (parm_tp->form == ARRAY_FORM) {
        result = parm_tp->info.array.max_index;
      }
      else {
        result = parm_tp->info.dynagg.max_index;
      }
      break;
    }
    case XHIINDEX: {           /* declared array upper bound, or # of elements */
      if (parm_tp->form == ARRAY_FORM) {
        result = parm_tp->info.array.max_index;
      }
      else {
        result = NELS((LBS_PTR) get_address_type(tos, stype));
      }
      break;
    }
    case XLOBOUND: {                         /* declared lower bound */
      if (parm_tp->form == ARRAY_FORM) {
        result = parm_tp->info.array.min_index;
      }
      else {
        result = parm_tp->info.dynagg.min_index;
      }
      break;
    }
    case XLOINDEX: {                       /* declared array lower bound, or 1 */
      if (parm_tp->form == ARRAY_FORM) {
        result = parm_tp->info.array.min_index;
      }
      else {
        result = 1;
      }
      break;
    }
    case XSIZEOF: {                         /* # of actual elements */
      if (parm_tp->form == ARRAY_FORM) {
        result = parm_tp->info.array.max_index - parm_tp->info.array.min_index + 1;
      }
      else {
        result = NELS((LBS_PTR) get_address_type(tos, stype));
      }
      break;
    }
   
    default: {           /* should not be here */
      runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE);
      get_ctoken();
      put_undef(tos);
      exit_debug("exec_hibound_etc");
      return(result_tp);
    }
  } /* end switch */

  get_ctoken();   /* token after RPAREN */

  put_integer(tos, result);
  exit_debug("exec_hibound_etc");
  return(result_tp);
}                                               /* end EXEC_HIBOUND_ETC */
/************************************************************************/



/************************************************************************/
/* exec_length_etc(rtn_idp)    Execute a call to LENGTH, etc            */
/*                         fun('string')                                */
/*                         String parameter, integer result             */
/*    at entry, ctoken is `fun'                                         */
/*    at exit, ctoken is token after closing )                          */

TYPE_STRUCT_PTR exec_length_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                      /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;                    /* actual param type */
  TYPE_STRUCT_PTR result_tp;                  /* returned type */
  XPRSAINT result = 0;
  entry_debug("exec_length_etc (l2xixstd.c)");

  get_ctoken();             /* should be ( */
  get_ctoken();             /* start of param */
  parm_tp = base_type(exec_expression());
  if (parm_tp->form != STRING_FORM) {
    runtime_error(INVALID_FUNCTION_ARGUMENT);
  }
  else {
    switch (rtn_idp->defn.info.routine.key) {
      case XLENGTH : {                             /* # of chars in a string */
        result = (XPRSAINT) strlen(get_stacked_string(tos));
        break;
      }
      default : {
        runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE);
        break; 
      }
    } /* end switch */
  }

  get_ctoken();         /* token after closing ) */
  put_integer(tos, result);
  exit_debug("exec_length_etc");
  return(result_tp);
}                                                /* end EXEC_LENGTH_ETC */
/************************************************************************/



/************************************************************************/
/* exec_exists_etc(rtn_idp)  Execute a call to EXISTS, etc              */
/*                   any type -> boolean                                */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_exists_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;             /* actual param type */
  TYPE_STRUCT_PTR result_tp;           /* result type */
  int code = rtn_idp->defn.info.routine.key;
  entry_debug("exec_exists_etc");

  get_ctoken();     /* LPAREN */
  get_ctoken();
  parm_tp = base_type(exec_expression());

  if (code == XEXISTS) {
    if (is_value_undef(tos)) {
      put_true(tos);
    }
    else {
      put_false(tos);
    }
  }

  get_ctoken();   /* token after RPAREN */

  exit_debug("exec_exists_etc");
  return(logical_typep);
}                                                /* end EXEC_EXISTS_ETC */
/************************************************************************/



/************************************************************************/
/* exec_nvl_etc(rtn_idp)  Execute a call to NVL, etc                    */
/*           In general, any function fun(p1, p2) that:                 */
/*           any compatible params --> compatible result                */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_nvl_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm1_tp, parm2_tp;       /* actual param types */
  TYPE_STRUCT_PTR result_tp;
  STACK_ITEM_PTR parm1, parm2;              /* parameters */
  int code = rtn_idp->defn.info.routine.key;
  entry_debug("exec_nvl_etc");

  get_ctoken();    /* LPAREN */
  get_ctoken();    /* start of first parameter */
  parm1_tp = base_type(exec_expression());
  parm1 = tos;
  get_ctoken();    /* COMMA */
  get_ctoken();    /* start of second parameter */
  parm2_tp = base_type(exec_expression());
  parm2 = tos;


  if (code == XNVL) {
    if (is_value_undef(parm1)) {
      copy_value(parm1, parm2);
      result_tp = parm2_tp;
    }
    else {
      result_tp = parm1_tp;
    }
  }

  get_ctoken();   /* token after RPAREN */

  exit_debug("exec_nvl_etc");
  return(result_tp);
}                                                   /* end EXEC_NVL_ETC */
/************************************************************************/



/************************************************************************/
/* exec_abs_sqr(rtn_idp)  Execute a call to ABS or SQR                  */
/*                         Integer --> integer result                   */
/*                         real --> real result                         */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_abs_sqr(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;             /* actual param type */
  TYPE_STRUCT_PTR result_tp;           /* result type */
  XPRSAINT i1;
  XPRSAREAL r1;
  int code = rtn_idp->defn.info.routine.key;
  entry_debug("exec_abs_sqr");

  get_ctoken();     /* LPAREN */
  get_ctoken();
  parm_tp = base_type(exec_expression());

  if (is_value_undef(tos)) {
    ;
  }
  if (code == ABS) {
    if (parm_tp == integer_typep) {
       i1 = get_integer(tos);
       if (i1 >= 0) {
         put_integer(tos, i1);
       }
       else {
         put_integer(tos, -i1);
       }
    }
    else {
      r1 = (XPRSAREAL) fabs((double) get_real(tos));
      put_real(tos, r1);
    }
  }

  get_ctoken();   /* token after RPAREN */

  exit_debug("exec_abs_sqr");
  return(parm_tp);
}                                                  /* end exec_abs_sqr  */
/************************************************************************/



/************************************************************************/
/* exec_arctan_cos_exp_ln_sin_sqrt(rtn_idp)  Execute a call to ARCTAN,  */
/*                  COS, EXP, LN, SIN or SQRT                           */
/*           In general, any function fun(p1) that:                     */
/*           integer or real param --> real result                      */
/* return a pointer to the type stucture of the call                    */
/* NOTE calling C library routines acos() and asin() give wierd interp error */

TYPE_STRUCT_PTR exec_arctan_cos_exp_ln_sin_sqrt(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm_tp;       /* actual param type */
  int code = rtn_idp->defn.info.routine.key;
  XPRSAREAL r1, r2;
  entry_debug("exec_arctan_cos_exp_ln_sin_sqrt");

  get_ctoken();    /* LPAREN */
  get_ctoken();
  parm_tp = base_type(exec_expression());

  if (is_value_undef(tos)) {
    get_ctoken();   /* token after RPAREN */
    exit_debug("exec_arctan_cos_exp_ln_sin_sqrt");
    return(real_typep);
  }
  
  if (parm_tp == integer_typep) {
    put_real(tos, (XPRSAREAL) get_integer(tos));
  }

  r1 = (double) get_real(tos);

         /* check input value */
  if (((code == SQRT) && (r1 < 0.0)) ||
      ((code == XACOS) && (r1 < -1.0 || r1 > 1.0)) ||
      ((code == XASIN) && (r1 < -1.0 || r1 > 1.0)) ||
      ((code == XLOG) && (r1 <= 0.0)) ||
      ((code == XLOG2) && (r1 <= 0.0)) ||
      ((code == XLOG10) && (r1 <= 0.0)) ) {
    runtime_error(INVALID_FUNCTION_ARGUMENT);
    exit_debug("exec_arctan_cos_exp_ln_sin_sqrt");
  }
  else {
    switch (rtn_idp->defn.info.routine.key) {
      case COS: {
        put_real(tos, (XPRSAREAL) cos(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (COS)");
        break;
      }
      case EXP: {
        put_real(tos, (XPRSAREAL) exp(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (EXP)");
        break;
      }
      case SIN: {
        put_real(tos, (XPRSAREAL) sin(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (SIN)");
        break;
      }
      case SQRT: {
        put_real(tos, (XPRSAREAL) sqrt(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (SQRT)");
        break;
      }
      case XACOS: {           
        put_real(tos, (XPRSAREAL) acos(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (ACOS)");
        break;
      }
      case XASIN: {
        put_real(tos, (XPRSAREAL) asin(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (ASIN)");
        break;
      }
      case XLOG: {
        put_real(tos, (XPRSAREAL) log(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (LOG)");
        break;
      }
      case XLOG2: {    /* log_a(x) = ln(x)/ln(a) : ln(2) = 0.6931 47180 55994 */
        put_real(tos, (1.442695 * ((XPRSAREAL) log(r1))));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (LOG2)");
        break;
      }
      case XLOG10: {
        put_real(tos, (XPRSAREAL) log10(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (LOG10)");
        break;
      }
      case XTAN: {
        put_real(tos, (XPRSAREAL) tan(r1));
  exit_debug("exec_arctan_cos_exp_ln_sin_sqrt (TAN)");
        break;
      }
    } /* end switch */
  }

  get_ctoken();   /* token after RPAREN */

  return(real_typep);
}                               /* end exec_arctan_cos_exp_ln_sin_sqrt  */
/************************************************************************/



/************************************************************************/
/* exec_atan(rtn_idp)  Execute a call to ATAN,                          */
/*           In general, any function fun(p1, p2) that:                 */
/*           integer or real param --> real result                      */
/* return a pointer to the type stucture of the call                    */
/*   NOTE: Calling C library function atan2() gives wierd interp. error */

TYPE_STRUCT_PTR exec_atan(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  TYPE_STRUCT_PTR parm1_tp, parm2_tp;       /* actual param type */
  TYPE_STRUCT_PTR result_tp;
  STACK_ITEM_PTR parm1, parm2;
  int code = rtn_idp->defn.info.routine.key;
  XPRSAREAL r1;
  XPRSAREAL r2;
  entry_debug("exec_atan");

  get_ctoken();    /* LPAREN */
  get_ctoken();    /* start of first parameter */
  parm1_tp = base_type(exec_expression());
  parm1 = tos;

  get_ctoken();    /* COMMA */
  get_ctoken();    /* start of second parameter */
  parm2_tp = base_type(exec_expression());
  parm2 = tos;

  if (code == XATAN) {
    if (is_value_undef(parm1) || is_value_undef(parm2)) {
      put_undef(parm1);
    }
    else {
      if (parm1_tp == integer_typep) {
        put_real(parm1, (XPRSAREAL) get_integer(parm1));
      }
      r1 = get_real(parm1);
      if (parm2_tp == integer_typep) {
        put_real(parm2, (XPRSAREAL) get_integer(parm2));
      }
      r2 = get_real(parm2);
      if (r1 == 0.0 && r2 == 0.0) {
        runtime_error(INVALID_FUNCTION_ARGUMENT);
      }
      else {
        r1 = (double) r1;
        r2 = (double) r2;
        put_real(parm1, (XPRSAREAL) atan2(r1, r2));
      }
    }
  }

  pop();
  get_ctoken();   /* token after RPAREN */

  exit_debug("exec_atan");
  return(real_typep);
}                                                     /* end EXEC_ATAN  */
/************************************************************************/



/************************************************************************/
/* exec_odd()  Execute a call to ODD                                    */
/*                    integer param --> boolean result                  */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_odd()
{
  XPRSAINT i1;
  entry_debug("exec_odd");
  get_ctoken();  /* LPAREN */
  get_ctoken();
  exec_expression();

  if (!is_value_undef(tos)) {
    i1 = get_integer(tos);
    i1 &= 1;
    if (i1 == 0) {
      put_false(tos);
    }
    else {
      put_true(tos);
    }
  }

  get_ctoken();  /* after RPAREN */

  exit_debug("exec_odd");
  return(logical_typep);
}                                                      /* end exec_odd  */
/************************************************************************/



/************************************************************************/
/* exec_round_trunc(rtn_idp)  Execute a call to ROUND or TRUNC          */
/*                            real param --> integer result             */
/* return a pointer to the type stucture of the call                    */

TYPE_STRUCT_PTR exec_round_trunc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                  /* routine id */
{
  XPRSAREAL r1;
  XPRSAINT i1;

  entry_debug("exec_round_trunc");
  get_ctoken();  /* LPAREN */
  get_ctoken();
  exec_expression();

  if (!is_value_undef(tos)) {
    r1 = get_real(tos);
    if (rtn_idp->defn.info.routine.key == ROUND) {
      i1 = r1 > 0.0
                   ? (XPRSAINT) (r1 + 0.5)
	           : (XPRSAINT) (r1 - 0.5);
    }
    else {
      i1 = (XPRSAINT) r1;
    }
    put_integer(tos, i1);
  }

  get_ctoken();  /* after RPAREN */

  exit_debug("exec_round_trunc");
  return(integer_typep);
}                                              /* end exec_round_trunc  */
/************************************************************************/