summaryrefslogtreecommitdiff
path: root/support/ltx2x/l2xixstd.c
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/ltx2x/l2xixstd.c
Initial commit
Diffstat (limited to 'support/ltx2x/l2xixstd.c')
-rw-r--r--support/ltx2x/l2xixstd.c1233
1 files changed, 1233 insertions, 0 deletions
diff --git a/support/ltx2x/l2xixstd.c b/support/ltx2x/l2xixstd.c
new file mode 100644
index 0000000000..43f513e889
--- /dev/null
+++ b/support/ltx2x/l2xixstd.c
@@ -0,0 +1,1233 @@
+/* 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 */
+/************************************************************************/
+
+
+
+
+