/* l2xixstm.c LTX2X interpreter statement executor routines */
/* Written by: Peter Wilson, CUA pwilson@cme.nist.gov */
/* This code is partly based on algorithms presented by Ronald Mak in */
/* "Writing Compilers & Interpreters", John Wiley & Sons, 1991 */
#include <stdio.h>
#include "l2xicmon.h"
#include "l2xierr.h"
#include "l2xiscan.h"
#include "l2xisymt.h"
#include "l2xiprse.h"
#include "l2xiidbg.h"
#include "l2xiexec.h"
/* GLOBALS */
BOOLEAN executed_return; /* TRUE iff return statement executed */
/* EXTERNALS */
extern int level;
extern int exec_line_number;;
extern long exec_stmt_count;
extern ICT *code_segmentp; /* code segment ptr */
extern ICT *statement_startp; /* ptr to start of statement */
extern TOKEN_CODE ctoken; /* token from code segment */
extern STACK_ITEM *stack; /* runtime stack */
extern STACK_ITEM_PTR tos; /* ptr to top of runtime stack */
extern STACK_ITEM_PTR stack_frame_basep; /* ptr to stack fame base */
extern BOOLEAN stack_flag;
extern BOOLEAN is_value_undef();
extern STRING get_stacked_string();
/* MACROS */
/* is_undef(tp1) TRUE iff type tp1 is undef */
#define is_undef(tp1) (tp1 == any_typep)
/***************************************************************************/
/* exec_statement() Execute a statement by calling appropriate routine */
/* returns the token code of the statement */
TOKEN_CODE exec_statement()
{
TOKEN_CODE stmt_tok;
entry_debug("exec_statement (l2xixstm.c)");
if (ctoken == STATEMENT_MARKER) {
exec_line_number = get_statement_cmarker();
++exec_stmt_count;
statement_startp = code_segmentp;
trace_statement_execution();
get_ctoken();
}
stmt_tok = ctoken;
switch (ctoken) {
case IDENTIFIER: {
SYMTAB_NODE_PTR idp = get_symtab_cptr();
if (idp->defn.key == PROC_DEFN ||
idp->defn.key == FUNC_DEFN) exec_routine_call(idp);
else exec_assignment_statement(idp);
break;
}
case BEGIN: {
exec_compound_statement();
break;
}
case CASE: {
exec_case_statement();
break;
}
case IF: {
exec_if_statement();
break;
}
case REPEAT: {
exec_grepeat_statement();
break;
}
case SEMICOLON:
case END:
case ELSE:
case UNTIL: {
break;
}
/* extensions for EXPRESS and ltx2x */
case XSKIP : {
break;
}
case XESCAPE : {
break;
}
case XRETURN : {
exec_return_statement();
exit_debug("exec_statement at XRETURN");
return(stmt_tok);
}
case END_OF_STATEMENTS: {
exit_debug("exec_statement at END_OF_STATEMENTS");
return(stmt_tok);
}
case ENDCODE: {
exit_debug("exec_statement at ENDCODE");
return(stmt_tok);
}
/* case ENDCODE: { added for ltx2x to stop execution */
/* exit_debug("exec_statement");
* return;
* break;
* }
*/
default: {
runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE);
break;
}
} /* end switch */
while (ctoken == SEMICOLON) get_ctoken();
exit_debug("exec_statement");
return(stmt_tok);
} /* end exec_statement */
/***************************************************************************/
/***************************************************************************/
/* exec_return_statement() Execute a return statement */
/* at entry, ctoken = RETURN */
/* at exit, ctoken is token after RETURN */
exec_return_statement()
{
entry_debug("exec_return_statement");
get_ctoken();
/* if (ctoken == LPAREN) exec_expression(); */
executed_return = TRUE;
exit_debug("exec_return_statement");
return;
} /* end EXEC_RETURN_STATEMENT */
/***************************************************************************/
/***************************************************************************/
/* exec_assignment_statement(idp) Execute an assignment statement */
/* */
exec_assignment_statement(idp)
SYMTAB_NODE_PTR idp; /* target variable id */
{
STACK_ITEM_PTR targetp; /* ptr to assignment target */
TYPE_STRUCT_PTR target_tp, base_target_tp, expr_tp;
BOOLEAN data_area;
entry_debug("exec_assignment_statement");
data_area = FALSE;
/* Assignment to function id: target is first item of appropriate stack frame */
if (idp->defn.key == FUNC_DEFN) {
STACK_ITEM_PTR hp;
int delta; /* difference in levels */
hp = (STACK_ITEM_PTR) stack_frame_basep;
delta = level - idp->level - 1;
while (delta-- > 0) {
hp = (STACK_ITEM_PTR) get_static_link((ADDRESS) hp);
}
targetp = (STACK_ITEM_PTR) hp;
target_tp = idp->typep;
get_ctoken();
}
/* Assignment to variable: Routine exec_variable leaves target address */
/* on top of stack */
else {
if ((idp->typep->form == ARRAY_FORM) || (idp->typep->form == ENTITY_FORM)) {
data_area = TRUE;
debug_print("data_area is TRUE\n");
}
target_tp = exec_variable(idp, TARGET_USE);
targetp = (STACK_ITEM_PTR) get_address(tos);
pop(); /* pop off the target address */
}
base_target_tp = base_type(target_tp);
/* Routine exec-expression leaves expression value on top of stack */
get_ctoken();
expr_tp = exec_expression();
if (stack_flag) {
log_print("Assignment LHS: ");
expression_type_debug(target_tp);
log_print("Assignment RHS: ");
expression_type_debug(expr_tp);
}
/* do the assignment */
exec_the_assign(targetp, target_tp, expr_tp);
trace_data_store(idp, idp->typep, targetp, target_tp);
exit_debug("exec_assignment_statement");
return;
} /* end exec_assignment_statement */
/***************************************************************************/
/***************************************************************************/
/* exec_the_assign(targetp, target_tp, expr_tp) Do the actual assignment */
/* targetp, target_tp are the target and its type; */
/* expr_tp is the RHS type with its value on top of the stack. */
/* The current token is unchanged */
exec_the_assign(targetp, target_tp, expr_tp)
STACK_ITEM_PTR targetp; /* ptr to LHS */
TYPE_STRUCT_PTR target_tp; /* ptr to type of LHS */
TYPE_STRUCT_PTR expr_tp; /* ptr to type of RHS */
{
TYPE_STRUCT_PTR base_target_tp; /* ptr to LHS base type */
STACK_TYPE rhstype; /* type on top of the stack */
int size;
entry_debug("exec_the_assign");
if (is_undef(expr_tp) || is_value_undef(tos)) {
put_undef(targetp);
pop();
exit_debug("exec_the_assign at undef");
return;
}
rhstype = get_stackval_type(tos);
if (expr_tp->form == ARRAY_FORM) { /* then RHS is an array (element?) */
if (rhstype == STKADD) {
copy_value(tos, get_address(tos));
}
}
base_target_tp = base_type(target_tp);
if ((target_tp == real_typep) && (base_type(expr_tp) == integer_typep)) {
/* real := integer */
put_real(targetp, (XPRSAREAL) get_integer(tos));
}
else if (target_tp == logical_typep) {
/* logical := logical */
put_logical(targetp, get_logical(tos));
}
else if (target_tp->form == STRING_FORM && expr_tp->form == STRING_FORM) {
/* string := string */
exec_string_assign((STACK_ITEM_PTR) targetp);
}
else if (target_tp->form == ARRAY_FORM) {
if (base_type(expr_tp) == target_tp->info.array.elmt_typep) { /* array := el */
copy_value(targetp, tos);
}
else { /* assume array := array */
ICT *ptr1 = (ICT *) targetp;
ICT *ptr2 = get_address(tos);
size = target_tp->size;
while (size--) *ptr1++ = *ptr2++;
}
}
else if (target_tp->form == ENTITY_FORM ) {
/* entity := entity */
ICT *ptr1 = (ICT *) targetp;
ICT *ptr2 = get_address(tos);
size = target_tp->size;
while (size--) *ptr1++ = *ptr2++;
}
else if ((base_target_tp == integer_typep) ||
(target_tp->form == ENUM_FORM)) {
/* Range check assignment to integer or enumeration subrange */
if ((target_tp->form == SUBRANGE_FORM) &&
((get_integer(tos) < target_tp->info.subrange.min) ||
(get_integer(tos) > target_tp->info.subrange.max))) {
runtime_error(VALUE_OUT_OF_RANGE);
}
/* integer := integer */
/* enumeration := enumeration */
put_integer(targetp, get_integer(tos));
}
else {
/* real := real */
put_real(targetp, get_real(tos));
}
pop(); /* pop expression value */
exit_debug("exec_the_assign");
return;
} /* end EXEC_THE_ASSIGN */
/***************************************************************************/
/***************************************************************************/
/* exec_string_assign Execute string := string */
/* */
exec_string_assign(targetp)
STACK_ITEM_PTR targetp; /* the LHS */
{
STRING rhs; /* the RHS */
STRING lhs;
int num;
int maxchrs;
entry_debug("exec_string_assign");
rhs = get_stacked_string(tos); /* top of stack points to the string */
free(targetp->value.string);
num = strlen(rhs);
sprintf(dbuffer, "strlen(str) = %d, str = %s\n", num, rhs);
debug_print(dbuffer);
lhs = alloc_bytes(num+1);
sprintf(dbuffer, "lhs = %d", lhs);
debug_print(dbuffer);
strcpy(lhs, rhs);
sprintf(dbuffer, ", str = %s\n", lhs);
debug_print(dbuffer);
put_string(targetp, lhs);
/* set_string(targetp, rhs); */
exit_debug("exec_string_assign");
return;
} /* end EXEC_STRING_ASSIGN */
/***************************************************************************/
/***************************************************************************/
/* set_string(var_idp, str) Attaches string str to variable */
set_string(var_idp, str)
SYMTAB_NODE_PTR var_idp; /* variable in the symbol table */
STRING str; /* the string */
{
int num;
int maxchrs = 527;
TYPE_STRUCT_PTR strtyp;
entry_debug("set_string (l2xixstm.c)");
sprintf(dbuffer, "var_idp = %d\n", var_idp);
debug_print(dbuffer);
num = strlen(str);
sprintf(dbuffer, "num = strlen(str) = %d\n", num);
debug_print(dbuffer);
debug_print(str);
strtyp = var_idp->typep;
/* maxchrs = var_idp->typep->info.string.max_length; */
/* maxchrs = strtyp->info.string.max_length; */
sprintf(dbuffer, "\nmaxchrs = %d\n", maxchrs);
debug_print(dbuffer);
if (num > maxchrs) {
runtime_error(RUNTIME_STRING_TOO_LONG);
free(var_idp->info);
var_idp->info = alloc_bytes(maxchrs + 1);
strncpy(var_idp->info, str, maxchrs);
var_idp->info[maxchrs] = '\0';
strtyp->info.string.length = maxchrs;
}
else {
/* free(var_idp->info); */
var_idp->info = alloc_bytes(num+1);
strcpy(var_idp->info, str);
/* strtyp->info.string.length = num; */
}
exit_debug("set_string");
} /* end SET_STRING */
/***************************************************************************/
/***************************************************************************/
/* exec_routine_call(rtn_idp) Execute procedure or function call. */
/* return pointer to the type structure */
TYPE_STRUCT_PTR exec_routine_call(rtn_idp)
SYMTAB_NODE_PTR rtn_idp; /* routine id */
{
TYPE_STRUCT_PTR exec_declared_routine_call();
TYPE_STRUCT_PTR exec_standard_routine_call();
entry_debug("exec_routine_call");
if (rtn_idp->defn.info.routine.key == DECLARED) {
exit_debug("exec_routine_call");
return(exec_declared_routine_call(rtn_idp));
}
else {
exit_debug("exec_routine_call");
return(exec_standard_routine_call(rtn_idp));
}
} /* end exec_routine_call */
/***************************************************************************/
/***************************************************************************/
/* exec_declared_routine_call(rtn_idp) Execute a call to a declared */
/* function or procedure */
/* return pointer to the type structure */
TYPE_STRUCT_PTR exec_declared_routine_call(rtn_idp)
SYMTAB_NODE_PTR rtn_idp; /* routine id */
{
int old_level = level; /* level of caller */
int new_level = rtn_idp->level + 1; /* level of callee */
STACK_ITEM_PTR new_stack_frame_basep;
STACK_ITEM_PTR hp; /* ptr to frame header */
entry_debug("exec_declared_routine_call");
/* set up stack frame of callee */
new_stack_frame_basep = tos + 1;
push_stack_frame_header(old_level, new_level);
/* push parameter values onto the stack */
get_ctoken();
if (ctoken == LPAREN) {
exec_actual_parms(rtn_idp);
get_ctoken(); /* the token after the RPAREN */
}
/* set the return address in the new stack frame, and execute callee */
level = new_level;
stack_frame_basep = new_stack_frame_basep;
hp = stack_frame_basep;
/* put_address(hp->return_address, (code_segmentp - 1)); */
put_return_address(hp, (code_segmentp - 1));
/* execute(rtn_idp); changed this call for EXPRESS */
exec_algorithm(rtn_idp);
/* return from callee */
level = old_level;
get_ctoken(); /* first token after return */
exit_debug("exec_declared_routine_call");
return(rtn_idp->defn.key == PROC_DEFN ? NULL : rtn_idp->typep);
} /* end exec_declared_routine_call */
/***************************************************************************/
/***************************************************************************/
/* exec_actual_parms(rtn_idp) Push the values of the actual parameters */
/* onto the stack */
exec_actual_parms(rtn_idp)
SYMTAB_NODE_PTR rtn_idp; /* id of callee routine */
{
SYMTAB_NODE_PTR formal_idp; /* formal param id */
TYPE_STRUCT_PTR formal_tp, actual_tp;
entry_debug("exec_actual_parms");
/* loop to execute actual params */
for (formal_idp = rtn_idp->defn.info.routine.parms;
formal_idp != NULL;
formal_idp = formal_idp->next) {
formal_tp = formal_idp->typep;
get_ctoken();
/* value parameter */
if (formal_idp->defn.key == VALPARM_DEFN) {
actual_tp = exec_expression();
/* Range check for a subrange formal param */
if (formal_tp->form == SUBRANGE_FORM) {
TYPE_STRUCT_PTR base_formal_tp = base_type(formal_tp);
XPRSAINT value;
value = get_integer(tos);
if ((value < formal_tp->info.subrange.min) ||
(value > formal_tp->info.subrange.max)) {
runtime_error(VALUE_OUT_OF_RANGE);
}
}
else if ((formal_tp == real_typep) &&
(base_type(actual_tp) == integer_typep)) {
/* real formal := integer actual */
put_real(tos, (XPRSAREAL) get_integer(tos));
}
if ((formal_tp->form == ARRAY_FORM) ||
(formal_tp->form == ENTITY_FORM)) {
/* formal param is array or entity. Make a copy */
int size = formal_tp->size;
ICT *ptr1 = alloc_array(ICT, size);
ICT *ptr2 = get_address(tos); /* ??????????????????? */
ICT *save_ptr = ptr1;
while (size--) *ptr1++ = *ptr2++;
put_address(tos, save_ptr);
}
} /* end value param */
/* a VAR parameter */
else {
SYMTAB_NODE_PTR idp = get_symtab_cptr();
exec_variable(idp, VARPARM_USE);
}
} /* end for loop */
exit_debug("exec_actual_parms");
} /* end exec_actual_parms */
/***************************************************************************/
/***************************************************************************/
/* exec_compound_statement() Execute a compound statement */
/* */
exec_compound_statement()
{
entry_debug("exec_compound_statement");
get_ctoken();
while (ctoken != END) exec_statement();
get_ctoken();
exit_debug("exec_compound_statement");
return;
} /* end exec_compound_statement */
/***************************************************************************/
/***************************************************************************/
/* exec_case_statement() Execute a CASE statement */
/* CASE <expr> OF */
/* <case-branch> */
/* END */
exec_case_statement()
{
XPRSAINT case_expr_value; /* CASE expr value */
XPRSAINT case_label_count; /* CASE label count */
XPRSAINT case_label_value; /* CASE label value */
ADDRESS branch_table_location; /* branch table address */
ADDRESS case_branch_location; /* CASE branch address */
TYPE_STRUCT_PTR case_expr_tp; /* CASE expr type */
BOOLEAN done = FALSE;
BOOLEAN found_otherwise = FALSE;
ADDRESS otherwise_location;
entry_debug("exec_case_statement");
get_ctoken(); /* token after CASE */
branch_table_location = get_address_cmarker();
/* evaluate the CASE expr */
get_ctoken();
case_expr_tp = exec_expression();
case_expr_value = get_integer(tos);
pop(); /* expression value */
/* search the branch table for the expr value */
code_segmentp = branch_table_location;
get_ctoken();
case_label_count = get_cinteger();
while (!done && case_label_count--) {
case_label_value = get_cinteger();
case_branch_location = get_caddress();
done = case_label_value == case_expr_value;
if (case_label_value == XOTHERWISE) {
found_otherwise = TRUE;
otherwise_location = case_branch_location;
}
}
/* if found, goto the appropriate CASE branch */
if (case_label_count >= 0) {
code_segmentp = case_branch_location;
get_ctoken();
exec_statement();
code_segmentp = get_address_cmarker();
get_ctoken();
}
else if (found_otherwise) {
code_segmentp = otherwise_location;
get_ctoken();
exec_statement();
code_segmentp = get_address_cmarker();
get_ctoken();
}
else {
runtime_error(INVALID_CASE_VALUE);
}
exit_debug("exec_case_statement");
return;
} /* end exec_case_statement */
/***************************************************************************/
/***************************************************************************/
/* exec_if_statement() Execute an IF statement */
/* IF <expr> THEN <stmt> END_IF */
/* or */
/* IF <expr> THEN <stmt> ELSE <stmt> END_IF */
exec_if_statement()
{
ADDRESS false_location; /* address of false branch */
BOOLEAN test;
entry_debug("exec_if_statement");
get_ctoken(); /* token after if */
false_location = get_address_cmarker();
/* evaluate the boolean expression */
get_ctoken();
exec_expression();
test = get_logical(tos) == TRUE_REP;
pop(); /* boolean value */
if (test) { /* do the TRUE branch */
get_ctoken(); /* token after THEN */
while (ctoken != ELSE && ctoken != XEND_IF) exec_statement();
if (ctoken == ELSE) {
get_ctoken();
code_segmentp = get_address_cmarker();
get_ctoken(); /* token after false stmt */
}
}
else { /* do the ELSE branch if there is one */
code_segmentp = false_location;
get_ctoken();
if (ctoken == ELSE ) {
get_ctoken();
get_address_cmarker(); /* skip the address marker */
get_ctoken();
while(ctoken != XEND_IF) exec_statement();
}
}
get_ctoken(); /* after the END_IF */
exit_debug("exec_if_statement");
return;
} /* end exec_if_statement */
/***************************************************************************/
/***************************************************************************/
/* exec_grepeat_statement() Execute an EXPRESS REPEAT statement */
/* REPEAT [ <inc_control> ] <while_control> <until_control> */
/* <stmt-list> END_REPEAT; */
/* at entry: ctoken is REPEAT */
/* at exit: ctoken is after END_REPEAT; */
exec_grepeat_statement()
{
SYMTAB_NODE_PTR control_idp; /* control var id */
TYPE_STRUCT_PTR control_tp; /* control var type */
STACK_ITEM_PTR targetp; /* ptr to control target */
ADDRESS loop_start_location; /* address of start of loop */
ADDRESS loop_end_location; /* address of end of loop */
ADDRESS until_start_location;
ADDRESS to_start_location;
ADDRESS while_start_location;
ADDRESS statements_start_location;
BOOLEAN loop_done = FALSE;
BOOLEAN is_increment_control = FALSE; /* TRUE iff there is an inc. control */
int control_value; /* value of control var */
int initial_value, final_value, delta_value;
TOKEN_CODE stmt_tok;
entry_debug("exec_grepeat_statement (l2xixstm.c)");
/* the first time through */
get_ctoken(); /* code (address marker) token after REPEAT */
loop_end_location = get_address_cmarker();
sprintf(dbuffer, "loop_end_location = %d\n", loop_end_location);
debug_print(dbuffer);
get_ctoken(); /* source token after REPEAT */
if (ctoken == FOR) { /* increment control */
is_increment_control = TRUE;
get_ctoken(); /* IDENTIFIER for the variable */
/* get address of control var's stack item */
control_idp = get_symtab_cptr();
control_tp = exec_variable(control_idp, TARGET_USE);
targetp = (STACK_ITEM_PTR) get_address(tos);
pop(); /* pop control var's address */
/* evaluate the initial expression */
get_ctoken();
exec_expression();
initial_value = get_integer(tos);
pop(); /* initial value */
put_integer(targetp, initial_value);
control_value = initial_value;
/* evaluate the final expression */
get_ctoken();
to_start_location = code_segmentp -1;
sprintf(dbuffer, "to_start_location = %d\n", to_start_location);
debug_print(dbuffer);
exec_expression();
final_value = get_integer(tos);
pop(); /* final value */
/* get the increment */
get_ctoken();
exec_expression();
delta_value = get_integer(tos);
pop(); /* delta value */
/* check the bound */
if ((delta_value >= 0 && control_value > final_value) ||
(delta_value < 0 && control_value < final_value)) {
code_segmentp = loop_end_location;
get_ctoken();
loop_done = TRUE;
}
if (loop_done) {
exit_debug("exec_grepeat_statement");
return;
}
}
/* check the WHILE condition */
get_ctoken();
while_start_location = code_segmentp -1;
sprintf(dbuffer, "while_start_location = %d\n", while_start_location);
debug_print(dbuffer);
exec_expression();
if (get_logical(tos) == FALSE_REP) { /* finished */
code_segmentp = loop_end_location;
get_ctoken();
loop_done = TRUE;
}
pop(); /* the WHILE value */
if (loop_done) {
exit_debug("exec_grepeat_statement");
return;
}
/* skip the UNTIL condition */
get_ctoken();
until_start_location = code_segmentp -1;
sprintf(dbuffer, "until_start_location = %d\n", until_start_location);
debug_print(dbuffer);
while (ctoken != STATEMENT_MARKER) get_ctoken();
statements_start_location = code_segmentp -1;
sprintf(dbuffer, "statements_start_location = %d\n", statements_start_location);
debug_print(dbuffer);
/* do the statements */
do {
stmt_tok = exec_statement();
if (stmt_tok == XSKIP) {
code_segmentp = until_start_location;
break;
}
else if (stmt_tok == XESCAPE) {
code_segmentp = loop_end_location;
get_ctoken();
loop_done = TRUE;
pop();
exit_debug("exec_grepeat_statement");
return;
}
} while (ctoken != XEND_REPEAT);
/* This finishes the first pass, do subsequent passes */
do {
/* check the UNTIL expression */
code_segmentp = until_start_location;
get_ctoken();
exec_expression();
if (get_logical(tos) == TRUE_REP) { /* finished */
code_segmentp = loop_end_location;
get_ctoken();
loop_done = TRUE;
}
pop(); /* the UNTIL value */
if (loop_done) {
exit_debug("exec_grepeat_statement");
return;
}
/* increment control now */
if (is_increment_control) {
/* perform the increment */
control_value = get_integer(targetp) + delta_value;
put_integer(targetp, control_value);
/* do the check */
code_segmentp = to_start_location;
get_ctoken();
exec_expression();
get_integer(tos);
if ((delta_value >= 0 && control_value > final_value) ||
(delta_value < 0 && control_value < final_value)) {
code_segmentp = loop_end_location;
get_ctoken();
loop_done = TRUE;
}
pop(); /* the to value */
if (loop_done) {
exit_debug("exec_grepeat_statement");
return;
}
}
/* check the WHILE */
code_segmentp = while_start_location;
get_ctoken();
exec_expression();
if (get_logical(tos) == FALSE_REP) {
code_segmentp = loop_end_location;
get_ctoken();
loop_done = TRUE;
}
pop(); /* the WHILE value */
if (loop_done) {
exit_debug("exec_grepeat_statement");
return;
}
/* and now back to executing the statements */
code_segmentp = statements_start_location;
get_ctoken();
do {
exec_statement();
} while (ctoken != XEND_REPEAT);
/* start again checking the UNTIL condition */
code_segmentp = until_start_location;
} while(TRUE);
exit_debug("exec_grepeat_statement");
return;
} /* end EXEC_GREPEAT_STATEMENT */
/***************************************************************************/