/* 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 #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 OF */ /* */ /* 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 THEN END_IF */ /* or */ /* IF THEN ELSE 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 [ ] */ /* 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 */ /***************************************************************************/