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