diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/ltx2x/l2xixutl.c |
Initial commit
Diffstat (limited to 'support/ltx2x/l2xixutl.c')
-rw-r--r-- | support/ltx2x/l2xixutl.c | 1866 |
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 */ +/***************************************************************************/ + + + |