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