summaryrefslogtreecommitdiff
path: root/support/ltx2x/l2xixutl.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/l2xixutl.c
Initial commit
Diffstat (limited to 'support/ltx2x/l2xixutl.c')
-rw-r--r--support/ltx2x/l2xixutl.c1866
1 files changed, 1866 insertions, 0 deletions
diff --git a/support/ltx2x/l2xixutl.c b/support/ltx2x/l2xixutl.c
new file mode 100644
index 0000000000..47b0d5f2a7
--- /dev/null
+++ b/support/ltx2x/l2xixutl.c
@@ -0,0 +1,1866 @@
+/* l2xixutl.c LTX2X Executor utility 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 "l2xicmon.h"
+#include "l2xierr.h"
+#include "l2xiscan.h"
+#include "l2xisymt.h"
+#include "l2xiidbg.h"
+#include "l2xiexec.h"
+
+#include "listsetc.h"
+
+/* EXTERNALS */
+
+extern TOKEN_CODE token;
+extern int line_number;;
+extern int level;
+
+extern BOOLEAN executed_return; /* TRUE iff return statement executed */
+
+/* GLOBALS */
+
+ICT *code_buffer; /* code buffer */
+ICT *code_bufferp; /* code buffer ptr */
+ICT *code_segmentp; /* code segment ptr */
+ICT *code_segment_limit; /* end of code segment */
+
+ICT *statement_startp; /* ptr to start of statement */
+TOKEN_CODE ctoken; /* token from code segment */
+int exec_line_number; /* no. of line executed */
+long exec_stmt_count = 0; /* count of executed statements */
+
+STACK_ITEM *stack; /* runtime stack */
+STACK_ITEM_PTR tos; /* ptr to top of runtime stack */
+STACK_ITEM_PTR stack_frame_basep; /* ptr to stack fame base */
+STACK_ITEM_PTR maxtos; /* current max top of runtime stack */
+
+/* map from form type to stack type */
+STACK_TYPE form2stack[] = {
+#define fotc(a, b, c, d) a,
+#define sotc(a, b, c, d)
+#define sftc(a, b, c, d) a,
+#include "l2xisftc.h"
+#undef fotc
+#undef sotc
+#undef sftc
+};
+
+/* map from stack type to form type */
+TYPE_FORM stack2form[] = {
+#define fotc(a, b, c, d)
+#define sotc(a, b, c, d) c,
+#define sftc(a, b, c, d) c,
+#include "l2xisftc.h"
+#undef fotc
+#undef sotc
+#undef sftc
+};
+
+/* FORWARDS */
+
+ADDRESS get_static_link();
+ADDRESS get_dynamic_link();
+ADDRESS get_return_address();
+STACK_TYPE get_stackval_type();
+
+/* CODE SEGMENT ROUTINES */
+
+
+/***************************************************************************/
+/* create_code_segment() Create a code segment and copy in the contents */
+/* of the code buffer. Reset the code buffer pointer */
+/* return a pointer to the segment */
+
+ICT *create_code_segment()
+{
+ ICT *code_segment = alloc_array(ICT, (code_bufferp - code_buffer));
+ entry_debug("create_code_segment");
+
+ code_segment_limit = code_segment + (code_bufferp - code_buffer);
+ code_bufferp = code_buffer;
+ code_segmentp = code_segment;
+
+ /* copy in the contents of the code buffer */
+ while (code_segmentp != code_segment_limit) {
+ *code_segmentp++ = *code_bufferp++;
+ }
+ /* reset the code buffer pointer */
+ code_bufferp = code_buffer;
+
+ code_segment_debug(code_segment, code_segment_limit);
+
+ exit_debug("create_code_segment");
+ return(code_segment);
+
+} /* end create_code_segment */
+/***************************************************************************/
+
+
+
+
+/***************************************************************************/
+/* crunch_token() Append the token code to the code buffer. */
+/* Called by the scanner routine only while parsing a block */
+
+
+crunch_token()
+{
+ int token_code = token; /* integer sized token code */
+ entry_debug("crunch_token");
+
+ if ((code_bufferp - code_buffer) >= MAX_CODE_BUFFER_SIZE - sizeof(token_code)) {
+ error(CODE_SEGMENT_OVERFLOW);
+ exit(-CODE_SEGMENT_OVERFLOW);
+ }
+
+ *code_bufferp++ = (ICT) token_code;
+
+ exit_debug("crunch_token");
+ return;
+} /* end crunch_token */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* crunch_extra_token() Append the token code to the code buffer. */
+
+crunch_extra_token(tok)
+TOKEN_CODE tok;
+{
+ entry_debug("crunch_extra_token (l2xixutl.c)");
+
+ if ((code_bufferp - code_buffer) >= MAX_CODE_BUFFER_SIZE - sizeof(tok)) {
+ error(CODE_SEGMENT_OVERFLOW);
+ exit(-CODE_SEGMENT_OVERFLOW);
+ }
+
+ *code_bufferp++ = (ICT) tok;
+
+ exit_debug("crunch_extra_token");
+ return;
+} /* end CRUNCH_EXTRA_TOKEN */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* get_ctoken() Gets next crunched token */
+
+TOKEN_CODE get_ctoken()
+{
+ entry_debug("get_ctoken (l2xixutl.c)");
+
+ code_segment_entry_debug(code_segmentp);
+ ctoken = *code_segmentp++;
+
+ exit_debug("get_ctoken");
+ return(ctoken);
+} /* end GET_CTOKEN */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* change_crunched_token(newtok) Replace the last token in the code */
+/* segment by newtok */
+
+change_crunched_token(newtok)
+int newtok; /* integer sized new token code */
+{
+ ICT *bp;
+ entry_debug("change_crunched_token");
+
+ bp = code_bufferp;
+ bp--;
+
+ *bp = (ICT) newtok;
+
+ exit_debug("change_crunched_token");
+ return;
+} /* end CHANGE_CRUNCHED_TOKEN */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* backup_crunched() prepare to write over last code entry */
+/* */
+
+backup_crunched()
+{
+ entry_debug("backup_crunched");
+
+ code_bufferp--;
+
+ exit_debug("backup_crunched");
+ return;
+} /* end BACKUP_CRUNCHED */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* crunch_symtab_node_ptr(np) Append a symbol table node pointer to the */
+/* code buffer */
+
+crunch_symtab_node_ptr(np)
+SYMTAB_NODE_PTR np; /* pointer to append */
+{
+/* SYMTAB_NODE_PTR *npp = (SYMTAB_NODE_PTR *) code_bufferp; */
+ ICT *npp = code_bufferp;
+
+ entry_debug("crunch_symtab_node_ptr");
+
+ if ((code_bufferp - code_buffer) >=
+ (MAX_CODE_BUFFER_SIZE - sizeof(SYMTAB_NODE_PTR))) {
+ error(CODE_SEGMENT_OVERFLOW);
+ exit(-CODE_SEGMENT_OVERFLOW);
+ }
+ else {
+ *npp = (ICT) np;
+ code_bufferp++;
+ }
+
+ exit_debug("crunch_symtab_node_ptr");
+ return;
+} /* end crunch_symtab_node_ptr */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* get_symtab_cptr() Extract a symbol table node pointer from the current */
+/* code segment */
+/* return the symbol table node pointer */
+
+SYMTAB_NODE_PTR get_symtab_cptr()
+{
+ SYMTAB_NODE_PTR np;
+ ICT *npp = code_segmentp;
+
+ np = (SYMTAB_NODE_PTR) *npp;
+/* code_segmentp += sizeof(SYMTAB_NODE_PTR); */
+ code_segmentp++;
+
+ return(np);
+} /* end get_symtab_cptr */
+/***************************************************************************/
+
+
+
+
+/***************************************************************************/
+/* crunch_statement_marker() Append a statement marker to the code buffer */
+/* */
+
+crunch_statement_marker()
+{
+ entry_debug("crunch_statement_marker");
+
+ if ((code_bufferp - code_buffer) >= MAX_CODE_BUFFER_SIZE) {
+ error(CODE_SEGMENT_OVERFLOW);
+ exit(-CODE_SEGMENT_OVERFLOW);
+ }
+ else {
+ ICT save_code = *(--code_bufferp);
+
+ *code_bufferp++ = STATEMENT_MARKER;
+ *((int *) code_bufferp) = line_number;
+ code_bufferp++;
+ *code_bufferp++ = save_code;
+ }
+
+ exit_debug("crunch_statement_marker");
+ return;
+} /* end crunch_statement_marker */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* get_statement_cmarker() Extract a statement marker from the current */
+/* code segment. */
+/* return its line number. */
+
+
+int get_statement_cmarker()
+{
+ int line_num;
+ entry_debug("get_statement_cmarker");
+
+
+ if (ctoken == STATEMENT_MARKER) {
+ line_num = *((int *) code_segmentp);
+ code_segmentp++;
+ }
+
+ exit_debug("get_statement_cmarker");
+ return(line_num);
+} /* end get_statement_cmarker */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* crunch_address_marker(address) Append a code address to the code */
+/* buffer */
+/* return the address of the address */
+
+ICT *crunch_address_marker(address)
+ADDRESS address;
+{
+
+ ICT *save_code_bufferp;
+
+ if ((code_bufferp - code_buffer) >= MAX_CODE_BUFFER_SIZE - sizeof(ADDRESS)) {
+ error(CODE_SEGMENT_OVERFLOW);
+ exit(-CODE_SEGMENT_OVERFLOW);
+ }
+ else {
+ ICT save_code = *(--code_bufferp);
+
+ *code_bufferp++ = (ICT) ADDRESS_MARKER;
+ save_code_bufferp = code_bufferp;
+ *((ADDRESS *) code_bufferp) = address;
+ code_bufferp++;
+ *code_bufferp++ = save_code;
+ }
+
+ return(save_code_bufferp);
+} /* end crunch_address_marker */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* get_address_cmarker Extract an address marker from current code */
+/* segment. Add its offset value to the code segment */
+/* address. */
+/* return new address */
+
+ADDRESS get_address_cmarker()
+{
+ ADDRESS address; /* address to be returned */
+
+ if (ctoken == ADDRESS_MARKER) {
+ address = *((int *) code_segmentp) + code_segmentp - 1;
+ code_segmentp++;
+ }
+
+ return(address);
+
+} /* end get_address_cmarker */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* fixup_address_marker(address) Fix up an address marker with the offset */
+/* from the address marker to the current */
+/* code buffer address. */
+/* return the old value of the address marker */
+
+ADDRESS fixup_address_marker(address)
+ADDRESS address; /* address of marker to be fixed up */
+{
+
+/* ADDRESS old_address = address; */
+/* int *old_address = *((ADDRESS *) address); */
+ ADDRESS old_address = *((ADDRESS *) address);
+
+ *((int *) address) = code_bufferp - address;
+ return(old_address);
+
+} /* end fixup_address_marker */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* crunch_integer(value) Append an integer value to the code buffer */
+
+crunch_integer(value)
+XPRSAINT value;
+{
+
+ if ((code_bufferp - code_buffer) >= MAX_CODE_BUFFER_SIZE - sizeof(XPRSAINT)) {
+ error(CODE_SEGMENT_OVERFLOW);
+ exit(-CODE_SEGMENT_OVERFLOW);
+ }
+ else {
+ *code_bufferp++ = (ICT) value;
+ }
+
+} /* end crunch_integer */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* get_cinteger Extract an integer from the current code segment */
+/* return the value */
+
+XPRSAINT get_cinteger()
+{
+ XPRSAINT value;
+
+ value = (XPRSAINT) *code_segmentp++;
+
+ return(value);
+
+} /* end get_cinteger */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* crunch_offset(address) Append an integer value to the code that */
+/* represents the offset from the given address */
+/* to the current code buffer address */
+
+crunch_offset(address)
+ADDRESS address;
+{
+ ICT *temp;
+
+ if ((code_bufferp - code_buffer) >= MAX_CODE_BUFFER_SIZE - sizeof(int)) {
+ error(CODE_SEGMENT_OVERFLOW);
+ exit(-CODE_SEGMENT_OVERFLOW);
+ }
+ else {
+ temp = code_bufferp;
+ *code_bufferp++ = address - temp;
+ }
+
+} /* end crunch_offset */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* get_caddress() Extract an offset from the current code segment and */
+/* add it to the code segment address. */
+/* return the new address */
+
+ADDRESS get_caddress()
+{
+ ADDRESS address;
+
+ address = *((int *) code_segmentp) + code_segmentp - 1;
+ code_segmentp++;
+
+ return(address);
+
+} /* end get_caddress */
+/***************************************************************************/
+
+
+/* EXECUTOR UTILITIES */
+
+
+/***************************************************************************/
+/* get_element_type(tp) Given an aggregate type, return the element type */
+
+TYPE_STRUCT_PTR get_element_type(agg_tp)
+TYPE_STRUCT_PTR agg_tp; /* the aggregate type */
+{
+ TYPE_STRUCT_PTR et;
+
+ if (is_array(agg_tp)) return(agg_tp->info.array.elmt_typep);
+ else if (is_dynagg(agg_tp)) return(agg_tp->info.dynagg.elmt_typep);
+ else return(agg_tp);
+
+} /* end GET_ELEMENT_TYPE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_integer(item_value) Push an integer onto the runtime stack */
+
+push_integer(item_value)
+XPRSAINT item_value;
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_integer");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKINT;
+ itemp->value.integer = item_value;
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_integer");
+ return;
+} /* end push_integer */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_integer(sptr, item_value) Put an integer into the runtime stack */
+
+put_integer(sptr, item_value)
+STACK_ITEM_PTR sptr;
+XPRSAINT item_value;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_integer");
+
+ itemp->type = STKINT;
+ itemp->value.integer = item_value;
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_integer");
+ return;
+} /* end put_integer */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* int get_integer(sptr) Get an integer from the runtime stack */
+
+XPRSAINT get_integer(sptr)
+STACK_ITEM_PTR sptr;
+{
+ int item_value = 0;
+ XPRSAREAL r1;
+ STACK_ITEM_PTR itemp = sptr;
+ STACK_TYPE stype;
+ entry_debug("get_integer");
+ stack_access_debug("Got", itemp);
+
+ if (itemp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ return(item_value);
+ }
+
+ stype = itemp->type;
+ if (stype == STKINT) {
+ item_value = itemp->value.integer;
+ }
+ else if (stype == STKREA) { /* real value, return nearest integer */
+ r1 = itemp->value.real;
+ item_value = r1 > 0.0 ? (XPRSAINT) (r1 + 0.5)
+ : (XPRSAINT) (r1 - 0.5);
+ }
+ else {
+ stack_warning(STKINT, stype);
+ }
+
+ exit_debug("get_integer");
+ return(item_value);
+} /* end get_integer */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_real(item_value) Push a real onto the runtime stack */
+
+push_real(item_value)
+XPRSAREAL item_value;
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_real");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKREA;
+ itemp->value.real = item_value;
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_real");
+ return;
+} /* end push_real */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_real(sptr, item_value) Put a real into the runtime stack */
+
+put_real(sptr, item_value)
+STACK_ITEM_PTR sptr;
+XPRSAREAL item_value;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_real");
+
+
+ itemp->type = STKREA;
+ itemp->value.real = item_value;
+
+ stack_access_debug("Put",itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_real");
+ return;
+} /* end put_real */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* float get_real(sptr) Get a real from the runtime stack */
+
+XPRSAREAL get_real(sptr)
+STACK_ITEM_PTR sptr;
+{
+ XPRSAREAL item_value = 0.0;
+ STACK_ITEM_PTR itemp = sptr;
+ STACK_TYPE stype;
+ entry_debug("get_real");
+ stack_access_debug("Got", itemp);
+
+ if (itemp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ return(item_value);
+ }
+
+ stype = itemp->type;
+ if (stype == STKREA) {
+ item_value = itemp->value.real;
+ }
+ else if (stype == STKINT) { /* convert integer to float */
+ item_value = (XPRSAREAL) itemp->value.integer;
+ }
+ else {
+ stack_warning(STKREA, stype);
+ }
+
+ exit_debug("get_real");
+ return(item_value);
+} /* end get_real */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_address(item_value) Push an address onto the runtime stack */
+
+push_address(address)
+ADDRESS address;
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_address");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKADD;
+ itemp->value.address = address;
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_address");
+ return;
+} /* end push_address */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_address(sptr, item_value) Put an address into the runtime stack */
+
+put_address(sptr, address)
+STACK_ITEM_PTR sptr;
+ADDRESS address;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_address");
+
+
+ itemp->type = STKADD;
+ itemp->value.address = address;
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_address");
+ return;
+} /* end put_address */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* ADDRESS get_address(sptr) Get an address from the runtime stack */
+
+ADDRESS get_address(sptr)
+STACK_ITEM_PTR sptr;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ ADDRESS address = NULL;
+ STACK_TYPE stype;
+ entry_debug("get_address");
+ stack_access_debug("Got", itemp);
+
+ if (itemp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ return(address);
+ }
+
+ stype = get_stackval_type(itemp);
+ if (stype == STKINT ||
+ stype == STKREA ||
+ stype == STKLOG ||
+ stype == STKSTR ||
+ stype == STKBAG ||
+ stype == STKLST ||
+ stype == STKSET ||
+ stype == STKUDF) {
+ stack_warning(STKADD, stype);
+ }
+ else {
+ address = itemp->value.address;
+ }
+
+ exit_debug("get_address");
+ return(address);
+} /* end get_address */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_address_type(item_value, type) Push an address onto the runtime */
+/* stack */
+
+push_address_type(address, type)
+ADDRESS address;
+STACK_TYPE type;
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_address_type (l2xixutl.c)");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ switch (type) {
+ case STKBAG:
+ case STKLST:
+ case STKSET: {
+ itemp->type = type;
+ itemp->value.head = (LBS_PTR) address;
+ break;
+ }
+ case STKSTR: {
+ itemp->type = type;
+ itemp->value.string = (STRING) address;
+ break;
+ }
+ default : {
+ itemp->type = type;
+ itemp->value.address = address;
+ break;
+ }
+ }
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_address_type");
+ return;
+} /* end push_address_type */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_address_type(sptr, item_value, type) Put an address into the runtime stack */
+
+put_address_type(sptr, address, type)
+STACK_ITEM_PTR sptr;
+ADDRESS address;
+STACK_TYPE type;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_address_type (l2xixutl.c)");
+
+ switch (type) {
+ case STKBAG:
+ case STKLST:
+ case STKSET: {
+ itemp->type = type;
+ itemp->value.head = (LBS_PTR) address;
+ break;
+ }
+ case STKSTR: {
+ itemp->type = type;
+ itemp->value.string = (STRING) address;
+ break;
+ }
+ default : {
+ itemp->type = type;
+ itemp->value.address = address;
+ break;
+ }
+ }
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_address_type");
+ return;
+} /* end put_address_type */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* ADDRESS get_address_type(sptr, type) Get an address from the runtime stack */
+
+ADDRESS get_address_type(sptr, type)
+STACK_ITEM_PTR sptr;
+STACK_TYPE type;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ ADDRESS address = NULL;
+ STACK_TYPE ftype;
+ entry_debug("get_address_type (l2xixutl.c)");
+ stack_access_debug("Got", itemp);
+
+ if (itemp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ return(NULL);
+ }
+
+ ftype = get_stackval_type(itemp);
+ if (type != ftype) stack_warning(type, ftype);
+
+ switch (ftype) {
+ case STKBAG:
+ case STKLST:
+ case STKSET: {
+ address = (ADDRESS) itemp->value.head;
+ break;
+ }
+ case STKSTR: {
+ address = (ADDRESS) itemp->value.string;
+ break;
+ }
+ case STKADD:
+ case STKARY:
+ case STKENT: {
+ address = itemp->value.address;
+ break;
+ }
+ }
+
+ exit_debug("get_address_type");
+ return(address);
+} /* end get_address_type */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* get_stackval_type(sptr) Returns the type of value in the stack */
+
+STACK_TYPE get_stackval_type(sptr)
+STACK_ITEM_PTR sptr;
+{
+ entry_debug("get_stackval_type (l2xixutl.c)");
+
+ if (sptr == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+
+ exit_debug("get_stackval_type");
+ return(sptr->type);
+} /* end GET_STACKVAL_TYPE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_false() Push false onto runtime stack */
+
+push_false()
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_false");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKLOG;
+ itemp->value.integer = FALSE_REP;
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_false");
+ return;
+} /* end PUSH_FALSE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_unknown() Push unknown onto runtime stack */
+
+push_unknown()
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_unknown");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKLOG;
+ itemp->value.integer = UNKNOWN_REP;
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_unknown");
+ return;
+} /* end PUSH_UNKNOWN */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_true() Push true onto runtime stack */
+
+push_true()
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_true");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKLOG;
+ itemp->value.integer = TRUE_REP;
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_true");
+ return;
+} /* end PUSH_TRUE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_false() Put false onto runtime stack */
+
+put_false(sptr)
+STACK_ITEM_PTR sptr;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_false");
+
+ itemp->type = STKLOG;
+ itemp->value.integer = FALSE_REP;
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_false");
+ return;
+} /* end PUT_FALSE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_unknown() Put unknown onto runtime stack */
+
+put_unknown(sptr)
+STACK_ITEM_PTR sptr;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_unknown");
+
+ itemp->type = STKLOG;
+ itemp->value.integer = UNKNOWN_REP;
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_unknown");
+ return;
+} /* end PUT_UNKNOWN */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_true() Put true onto runtime stack */
+
+put_true(sptr)
+STACK_ITEM_PTR sptr;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_true");
+
+ itemp->type = STKLOG;
+ itemp->value.integer = TRUE_REP;
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_true");
+ return;
+} /* end PUT_TRUE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_logical() Push logical value onto runtime stack */
+
+push_logical(item_value)
+LOGICAL_REP item_value;
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_logical");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKLOG;
+ itemp->value.integer = item_value;
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_logical");
+ return;
+} /* end PUSH_LOGICAL */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_logical() Put logical value onto runtime stack */
+
+put_logical(sptr, item_value)
+STACK_ITEM_PTR sptr;
+LOGICAL_REP item_value;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_logical");
+
+ itemp->type = STKLOG;
+ itemp->value.integer = item_value;
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_logical");
+ return;
+} /* end PUT_LOGICAL */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* get_logical(sptr) Get a boolean/logical from the runtime stack */
+
+LOGICAL_REP get_logical(sptr)
+STACK_ITEM_PTR sptr;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ LOGICAL_REP item_value = UNKNOWN_REP;
+ entry_debug("get_logical");
+ stack_access_debug("Got", itemp);
+
+ if (itemp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+
+ if (itemp->type != STKLOG) {
+ stack_warning(STKLOG, itemp->type);
+ }
+ else {
+ item_value = itemp->value.integer;
+ }
+
+ exit_debug("get_logical");
+ return(item_value);
+} /* end GET_LOGICAL */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_string(item_value) Push a string onto the stack */
+
+STRING push_string(item_value)
+STRING item_value;
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_string");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKSTR;
+ itemp->value.string = item_value;
+
+ stack_access_debug("Pushed", tos);
+
+ exit_debug("push_string");
+ return;
+} /* end PUSH_STRING */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_string(sptr, item_value) Put a string into the stack */
+
+STRING put_string(sptr, item_value)
+STACK_ITEM_PTR sptr;
+STRING item_value;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_string");
+
+ itemp->type = STKSTR;
+ itemp->value.string = item_value;
+
+ stack_access_debug("Put", itemp);
+
+ if (itemp > tos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+
+ exit_debug("put_string");
+ return;
+} /* end PUT_STRING */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* get_stacked_string(sptr) Get a string from the stack */
+
+STRING get_stacked_string(sptr)
+STACK_ITEM_PTR sptr;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ STRING item_value = "";
+ entry_debug("get_stacked_string");
+ stack_access_debug("Got", itemp);
+
+ if (itemp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+
+ if (itemp->type != STKSTR) {
+ stack_warning(STKSTR, itemp->type);
+ }
+ else {
+ item_value = itemp->value.string;
+ }
+
+ exit_debug("get_stacked_string");
+ return(item_value);
+} /* end GET_STACKED_STRING */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* push_undef() Push undefined `?' onto runtime stack */
+
+push_undef()
+{
+ STACK_ITEM_PTR itemp = ++tos;
+ entry_debug("push_undef");
+
+ maxtos = tos > maxtos ? tos : maxtos;
+
+ if (itemp >= &stack[MAX_STACK_SIZE]) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ }
+
+ itemp->type = STKUDF;
+ itemp->value.integer = '\?';
+
+ stack_access_debug("Pushed", tos);
+ exit_debug("push_undef");
+ return;
+} /* end PUSH_UNDEF */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* put_undef(sptr) Put undefined `?' into runtime stack */
+
+put_undef(sptr)
+STACK_ITEM_PTR sptr;
+{
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("put_undef");
+
+
+ itemp->type = STKUDF;
+ itemp->value.integer = '\?';
+
+ stack_access_debug("Put", itemp);
+ if (itemp > maxtos) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ exit_debug("put_undef");
+ return;
+} /* end PUT_UNDEF */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* get_undef() Get undefined `?' from runtime stack */
+
+char get_undef(sptr)
+STACK_ITEM_PTR sptr;
+{
+ char item_value = ' ';
+ STACK_ITEM_PTR itemp = sptr;
+ entry_debug("get_undef");
+ stack_access_debug("Got", itemp);
+
+ if (itemp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+
+ if (itemp->type != STKUDF) {
+ item_value = ' ';
+ runtime_warning(STKUDF, itemp->type);
+ }
+ else {
+ item_value = itemp->value.integer;
+ }
+
+ exit_debug("get_undef");
+ return(item_value);
+} /* end GET_UNDEF */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* is_value_undef(sptr) TRUE iff value on stack at sptr is undef */
+
+BOOLEAN is_value_undef(sptr)
+STACK_ITEM_PTR sptr;
+{
+ BOOLEAN result = FALSE;
+
+ if (sptr == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ }
+ else {
+ result = (sptr->type == STKUDF);
+ }
+ return(result);
+} /* end IS_VALUE_UNDEF */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* copy_value(to, from) Copies stack value */
+
+copy_value(top, fromp)
+STACK_ITEM_PTR top;
+STACK_ITEM_PTR fromp;
+{
+ STACK_TYPE type;
+ entry_debug("copy_value (l2xixutl.c)");
+
+ if (top == NULL || fromp == NULL) {
+ runtime_warning(INVALID_STACK_ACCESS);
+ exit_debug("copy_value");
+ return;
+ }
+
+ stack_access_debug("Copy -- replacing: ", top);
+ stack_access_debug(" with: ", fromp);
+ type = fromp->type;
+ switch (type) {
+ case STKINT: {
+ top->type = type;
+ top->value.integer = fromp->value.integer;
+ break;
+ }
+ case STKREA: {
+ top->type = type;
+ top->value.real = fromp->value.real;
+ break;
+ }
+ case STKADD:
+ case STKARY:
+ case STKBAG:
+ case STKLST:
+ case STKSET:
+ case STKENT: {
+ top->type = type;
+ top->value.address = fromp->value.address;
+ break;
+ }
+ case STKUDF: {
+ put_undef(top);
+ break;
+ }
+ default: {
+ break;
+ }
+ } /* end switch */
+
+ exit_debug("copy_value");
+ return;
+} /* end COPY_VALUE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* create_copy_value(fromp) Copies a stack value to a new value */
+/* returns pointer to the new copied value */
+
+STACK_ITEM_PTR create_copy_value(fromp)
+STACK_ITEM_PTR fromp;
+{
+ STACK_TYPE type;
+ STACK_ITEM_PTR top;
+ entry_debug("create_copy_value (l2xixutl.c)");
+
+ /* get the memory required */
+ top = alloc_struct(STACK_ITEM);
+ if (top == NULL) {
+ runtime_error(RUNTIME_STACK_OVERFLOW);
+ exit_debug("create_copy_value");
+ return(NULL);
+ }
+
+ type = fromp->type;
+ switch (type) {
+ case STKINT: {
+ top->type = type;
+ top->value.integer = fromp->value.integer;
+ break;
+ }
+ case STKREA: {
+ top->type = type;
+ top->value.real = fromp->value.real;
+ break;
+ }
+ case STKADD:
+ case STKARY:
+ case STKBAG:
+ case STKLST:
+ case STKSET:
+ case STKENT: {
+ top->type = type;
+ top->value.address = fromp->value.address;
+ break;
+ }
+ case STKUDF: {
+ put_undef(top);
+ break;
+ }
+ default: {
+ break;
+ }
+ } /* end switch */
+ stack_access_debug("Created copy of: ", fromp);
+ stack_access_debug(" as: ", top);
+
+ exit_debug("create_copy_value");
+ return(top);
+} /* end CREATE_COPY_VALUE */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* execute(rtn_idp) Execute a routine's code segment */
+/* */
+
+execute(rtn_idp)
+SYMTAB_NODE_PTR rtn_idp;
+{
+ entry_debug("execute");
+
+ routine_entry(rtn_idp);
+
+ get_ctoken();
+ exec_statement();
+
+ routine_exit(rtn_idp);
+
+ exit_debug("execute");
+ return;
+} /* end execute */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* routine_entry(rtn_idp) Point to the new routine's code segment */
+/* and allocate its locals */
+
+routine_entry(rtn_idp)
+SYMTAB_NODE_PTR rtn_idp; /* new routine's id */
+{
+ SYMTAB_NODE_PTR var_idp; /* local variable id */
+ entry_debug("routine_entry");
+ stack_debug();
+
+ trace_routine_entry(rtn_idp);
+
+ /* switch to new code segment */
+ code_segmentp = rtn_idp->defn.info.routine.code_segment;
+
+ /* allocate local variables */
+ for (var_idp = rtn_idp->defn.info.routine.locals;
+ var_idp != NULL;
+ var_idp = var_idp->next) {
+ alloc_local(var_idp->typep);
+ }
+
+ stack_debug();
+ exit_debug("routine_entry");
+ return;
+} /* end routine_entry */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* routine_exit(rtn_idp) Deallocate the routine's parameters and locals. */
+/* Cut off its stack frame and return to the */
+/* caller's code segment. */
+
+routine_exit(rtn_idp)
+SYMTAB_NODE_PTR rtn_idp; /* exiting routine's id */
+{
+ SYMTAB_NODE_PTR idp; /* local variable or param id */
+ STACK_FRAME_HEADER_PTR hp; /* ptr to stack frame header */
+ TYPE_STRUCT_PTR target_tp; /* ptr to return type of routine */
+ TYPE_STRUCT_PTR expr_tp; /* ptr to type of RETURN expression */
+
+ entry_debug("routine_exit");
+ stack_debug();
+
+ trace_routine_exit(rtn_idp);
+
+ /* Treat a RETURN expression as an assignment to the routine's id */
+ if (ctoken == LPAREN) {
+ target_tp = rtn_idp->typep;
+ expr_tp = exec_expression();
+ exec_the_assign(stack_frame_basep, target_tp, expr_tp);
+ }
+
+ /* Deallocate parameters and local variables */
+ for (idp = rtn_idp->defn.info.routine.parms;
+ idp != NULL;
+ idp = idp->next) {
+ free_data(idp);
+ }
+ for (idp = rtn_idp->defn.info.routine.locals;
+ idp != NULL;
+ idp = idp->next) {
+ free_data(idp);
+ }
+
+ /* pop off the stack frame and return to caller's code segmnent */
+ entry_debug("routine_exit: pop the frame stack");
+ stack_debug();
+ hp = (STACK_FRAME_HEADER_PTR) stack_frame_basep;
+ code_segmentp = get_return_address(hp);
+ tos = (rtn_idp->defn.key == PROC_DEFN)
+ ? stack_frame_basep - 1
+ : stack_frame_basep;
+ stack_frame_basep = (STACK_ITEM_PTR) get_dynamic_link(hp);
+
+ exit_debug("routine_exit: pop the frame stack");
+ stack_debug();
+ exit_debug("routine_exit");
+ return;
+} /* end routine_exit */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* push_stack_frame_header(old_level, new_level) Allocate the callee */
+/* routine's stack frame */
+
+push_stack_frame_header(old_level, new_level)
+int old_level; /* level of caller */
+int new_level; /* level of callee */
+{
+ STACK_FRAME_HEADER_PTR hp;
+ STACK_ITEM_PTR newbasep; /* pointer to base of new frame */
+ entry_debug("push_stack_frame_header");
+
+ stack_debug();
+/* push_integer(0); return value */
+ hp = (STACK_FRAME_HEADER_PTR) stack_frame_basep;
+ newbasep = tos + 1;
+ push_frame_data(0, NULL, NULL, NULL);
+
+ /* static link */
+ if (new_level == (old_level + 1)) {
+ /* calling a routine nested in the caller */
+ /* push pointer to caller's stack frame */
+ put_static_link(newbasep, (ADDRESS) hp);
+ }
+ else if (new_level == old_level) {
+ /* calling routine at the same level */
+ /* push pointer to stack of common parent */
+ put_static_link(newbasep, get_static_link(hp));
+ }
+ else {
+ /* calling a routine at a lesser level (nested less deeply ) */
+ /* push pointer to stack of nearest common ancestor */
+ int delta = (old_level - new_level);
+
+ while (delta-- >= 0) {
+ hp = (STACK_FRAME_HEADER_PTR) get_static_link(hp);
+ }
+ put_static_link(newbasep, hp);
+ }
+
+ put_dynamic_link(newbasep, stack_frame_basep);
+
+ stack_debug();
+ exit_debug("push_stack_frame_header");
+ return;
+} /* end push_stack_frame_header */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* alloc_local(tp) Allocate a local variable on the stack */
+/* */
+
+alloc_local(tp)
+TYPE_STRUCT_PTR tp; /* ptr to type of variable */
+{
+ LBS_PTR lbs; /* pointer to dynamic agg */
+ STACK_TYPE stktyp;
+ entry_debug("alloc_local");
+
+ if (tp == integer_typep) {
+ push_integer(0);
+ }
+ else if (tp == real_typep) {
+ push_real(0.0);
+ }
+ else if (tp == boolean_typep) {
+ push_false(); /* FALSE */
+ }
+ else if (tp == string_typep || tp->form == STRING_FORM) {
+ push_string(NULL);
+ }
+ else if (tp == logical_typep) {
+ push_unknown();
+ }
+ else {
+ switch (tp->form) {
+ case ENUM_FORM: {
+ push_integer(0);
+ break;
+ }
+ case SUBRANGE_FORM: {
+ alloc_local(tp->info.subrange.range_typep);
+ break;
+ }
+ case ARRAY_FORM: {
+ ADDRESS ptr = (ADDRESS) alloc_array(STACK_ITEM_PTR, tp->size);
+ sprintf(dbuffer, "Allocated %d bytes for array at %d\n",
+ tp->size, ptr);
+ debug_print(dbuffer);
+ push_address((ADDRESS) ptr);
+ break;
+ }
+ case ENTITY_FORM: {
+ ADDRESS ptr = (ADDRESS) alloc_array(STACK_ITEM_PTR, tp->size);
+ sprintf(dbuffer, "Allocated %d bytes for entity at %d\n",
+ tp->size, ptr);
+ debug_print(dbuffer);
+ push_address_type((ADDRESS) ptr, STKENT);
+ break;
+ }
+ case BAG_FORM:
+ case LIST_FORM:
+ case SET_FORM: {
+ lbs = lbs_init();
+ push_address_type(lbs, form2stack[tp->form]);
+ break;
+ }
+ } /* end switch */
+ }
+
+ exit_debug("alloc_local");
+ return;
+} /* end alloc_local */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* free_data(idp) Deallocate the data area of an array or record local */
+/* variable or value parameter */
+
+free_data(idp)
+SYMTAB_NODE_PTR idp; /* parm or variable id */
+{
+ STACK_ITEM_PTR itemp; /* ptr to stack item */
+ TYPE_STRUCT_PTR tp = idp->typep; /* ptr to id's type */
+ entry_debug("free_data");
+
+ if (((tp->form == ARRAY_FORM) || (tp->form == ENTITY_FORM)) &&
+ (idp->defn.key != VARPARM_DEFN)) {
+ stack_frame_debug();
+ itemp = stack_frame_basep + idp->defn.info.data.offset;
+ stack_item_debug(itemp);
+ free(get_address(itemp));
+ }
+
+ exit_debug("free_data");
+ return;
+} /* end free_data */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* push_frame_data(int, add, add, add) Push frame data onto runtime stack */
+
+push_frame_data(ifrv, asl, adl, ara)
+int ifrv; /* function return value */
+ADDRESS asl; /* static link */
+ADDRESS adl; /* dynamic link */
+ADDRESS ara; /* return address */
+{
+ entry_debug("push_frame_data");
+ stack_debug();
+
+ push_integer(ifrv);
+ push_address(asl);
+ push_address(adl);
+ push_address(ara);
+
+ stack_debug();
+ exit_debug("push_frame_data");
+ return;
+} /* end push_frame_data */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* put_static_link(framep, address) Put static link data into frame */
+
+put_static_link(framep, address)
+STACK_ITEM_PTR framep; /* pointer to frame */
+ADDRESS address; /* static link */
+{
+ entry_debug("put_static_link");
+ put_address((framep+1), address);
+ exit_debug("put_static_link");
+
+} /* end put_static_link */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* ADDRESS get_static_link(framep) Get static link data from frame */
+
+ADDRESS get_static_link(framep)
+STACK_ITEM_PTR framep; /* pointer to frame */
+{
+ ADDRESS result;
+ entry_debug("get_static_link");
+
+ result = get_address(framep + 1);
+
+ exit_debug("get_static_link");
+ return(result);
+} /* end get_static_link */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* put_dynamic_link(framep, address) Put dynamic link data into frame */
+
+put_dynamic_link(framep, address)
+STACK_ITEM_PTR framep; /* pointer to frame */
+ADDRESS address; /* dynamic link */
+{
+ entry_debug("put_dynamic_link");
+ put_address((framep+2), address);
+ exit_debug("put_dynamic_link");
+
+} /* end put_dynamic_link */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* ADDRESS get_dynamic_link(framep) Get dynamic link data from frame */
+
+ADDRESS get_dynamic_link(framep)
+STACK_ITEM_PTR framep; /* pointer to base of frame */
+{
+ ADDRESS result;
+ entry_debug("get_dynamic_link");
+
+ result = get_address(framep + 2);
+
+ exit_debug("get_dynamic_link");
+ return(result);
+} /* end get_dynamic_link */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* put_return_address(framep, address) Put return address data into frame */
+
+put_return_address(framep, address)
+STACK_ITEM_PTR framep; /* pointer to frame */
+ADDRESS address; /* return link */
+{
+
+ entry_debug("put_return_address");
+ put_address((framep+3), address);
+ exit_debug("put_return_address");
+
+} /* end put_return_address */
+/***************************************************************************/
+
+
+/***************************************************************************/
+/* ADDRESS get_return_address(framep) Get return address data from frame */
+
+ADDRESS get_return_address(framep)
+STACK_ITEM_PTR framep; /* pointer to frame */
+{
+ ADDRESS result;
+ entry_debug("get_return_address");
+
+ result = get_address(framep + 3);
+
+ exit_debug("get_return_address");
+ return(result);
+} /* end get_return_address */
+/***************************************************************************/
+
+
+
+/***************************************************************************/
+/* stack_value_equal(a, b) Tests whether two stack items have the same */
+/* data value. */
+/* returns: UNKNOWN_REP if either arg is indeterminate */
+/* otherwise TRUE_REP or FALSE_REP as appropriate */
+
+LOGICAL_REP stack_value_equal(a, b)
+STACK_ITEM_PTR a;
+STACK_ITEM_PTR b;
+{
+ STACK_TYPE atype, btype;
+ int ans;
+ XPRSAINT i1, i2;
+ XPRSAREAL r1, r2;
+ LOGICAL_REP b1, b2;
+ LOGICAL_REP log = FALSE_REP;
+
+ entry_debug("stack_value_equal (l2xixutl.c)");
+
+ /* check for indeterminate values */
+ atype = get_stackval_type(a);
+ if (atype == STKUDF) log = UNKNOWN_REP;
+ btype = get_stackval_type(b);
+ if (btype == STKUDF) log = UNKNOWN_REP;
+ if (log == UNKNOWN_REP) {
+ exit_debug("stack_value_equal (indeterminate UNKNOWN_REP)");
+ return(log);
+ }
+
+
+ /* check type equality */
+ if (atype != btype) {
+ exit_debug("stack_value_equal (different types FALSE_REP)");
+ return(FALSE_REP);
+ }
+
+ switch (atype) {
+ case STKINT: {
+ i2 = get_integer(b);
+ i1 = get_integer(a);
+ sprintf(dbuffer, "Checking %d == %d\n",
+ i1, i2);
+ debug_print(dbuffer);
+ ans = (i1 == i2);
+ sprintf(dbuffer, "Checked %d == %d, with result = ",
+ i1, i2);
+ debug_print(dbuffer);
+ if (ans) sprintf(dbuffer, "TRUE\n");
+ else sprintf(dbuffer, "FALSE\n");
+ debug_print(dbuffer);
+ break;
+ }
+ case STKREA: {
+ ans = (get_real(a) == get_real(b));
+ break;
+ }
+ case STKLOG: {
+ ans = (get_logical(a) == get_logical(b));
+ break;
+ }
+ case STKSTR: {
+ ans = strcmp(get_stacked_string(a), get_stacked_string(b));
+ if (ans == 0) ans = TRUE;
+ else ans = FALSE;
+ break;
+ }
+ default: { /* for now, only test on simple types */
+ exit_debug("stack_value_equal (default UNKNOWN_REP)");
+ return(UNKNOWN_REP);
+ break;
+ }
+ } /* end switch */
+
+ if (ans) {
+ exit_debug("stack_value_equal (end switch TRUE_REP)");
+ return(TRUE_REP);
+ }
+ else {
+ exit_debug("stack_value_equal (end switch FALSE_REP)");
+ return(FALSE_REP);
+ }
+
+} /* end STACK_VALUE_EQUAL */
+/***************************************************************************/
+
+
+