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