/* l2xirtne.c LTX2X interpreter Routine parser */
/* parse programs and declared procedures and functions */
/* 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"
#ifndef l2xicpr_h
#include "l2xicpr.h" /* extern token code lists */
#endif
/* EXTERNALS */
extern int line_number;;
extern long exec_stmt_count;
extern TOKEN_CODE token;
extern char word_string[];
extern SYMTAB_NODE_PTR symtab_display[];
extern int level;
extern ICT *code_buffer;
extern ICT *code_bufferp;
extern STACK_ITEM *stack;
extern STACK_ITEM_PTR tos;
extern STACK_ITEM_PTR stack_frame_basep;
extern STACK_ITEM_PTR maxtos;
extern TYPE_STRUCT_PTR get_type();
/* GLOBALS */
char buffer[MAX_PRINT_LINE_LENGTH];
/* FORWARDS */
SYMTAB_NODE_PTR formal_parm_list();
SYMTAB_NODE_PTR procedure_header();
SYMTAB_NODE_PTR function_header();
ICT *create_code_segment();
/***************************************************************************/
/* init_stack initialise the runtime stack */
init_stack()
{
entry_debug("init_stack");
/* allocate runtime stack */
stack = alloc_array(STACK_ITEM, MAX_STACK_SIZE);
stack_frame_basep = tos = stack;
stack_frame_debug();
maxtos = tos; /* current max top of stack */
/* initialise the program's stack frame */
level = 1;
stack_frame_basep = tos + 1;
stack_frame_debug();
push_integer(0); /* function return value */
push_address(NULL); /* static link */
push_address(NULL); /* dynamic link */
push_address(NULL); /* return address */
exit_debug("init_stack");
return;
} /* end init_stack */
/***************************************************************************/
/***************************************************************************/
/* create_dummy_prog() create a dummy program symbol table node */
/* Based on program and program_header */
/* Must be called BEFORE any scanning or parsing */
/* returns pointer to program id node */
SYMTAB_NODE_PTR create_dummy_prog()
{
SYMTAB_NODE_PTR program_idp; /* program id */
entry_debug("creat_dummy_prog");
/* make up fake program name */
strcpy(word_string, "_PrOgRaM");
search_and_enter_local_symtab(program_idp);
program_idp->defn.key = PROG_DEFN;
program_idp->defn.info.routine.key = DECLARED;
program_idp->defn.info.routine.parm_count = 0;
program_idp->defn.info.routine.total_parm_size = 0;
program_idp->defn.info.routine.total_local_size = 0;
program_idp->typep = &dummy_type;
program_idp->label_index = 0;
enter_scope(NULL);
/* no program parameters */
program_idp->defn.info.routine.locals = NULL;
program_idp->defn.info.routine.parms = NULL;
exit_debug("create_dummy_prog");
return(program_idp);
} /* end create_dummy_prog */
/***************************************************************************/
/***************************************************************************/
/* a_function Process an EXPRESS function */
/* FUNCTION <header> <body> END_FUNCTION ; */
/* at entry, token is FUNCTION */
/* at exit, token is after END_FUNCTION ; */
a_function()
{
SYMTAB_NODE_PTR rtn_idp; /* routine id */
entry_debug("a_function");
rtn_idp = function_header();
/* sync. Should be ; */
synchronize(follow_header_list, declaration_start_list, statement_start_list);
if_token_get(SEMICOLON);
else if (token_in(declaration_start_list) || token_in(statement_start_list))
error(MISSING_SEMICOLON);
/* block or forward */
if (strcmp(word_string, "forward") != 0) {
rtn_idp->defn.info.routine.key = DECLARED;
analyze_routine_header(rtn_idp);
rtn_idp->defn.info.routine.locals = NULL;
function_body(rtn_idp);
rtn_idp->defn.info.routine.code_segment = create_code_segment();
analyze_block(rtn_idp->defn.info.routine.code_segment);
if_token_get_else_error(XEND_FUNCTION, MISSING_END_FUNCTION);
if_token_get_else_error(SEMICOLON, MISSING_SEMICOLON);
}
else {
get_token();
rtn_idp->defn.info.routine.key = FORWARD;
analyze_routine_header(rtn_idp);
}
rtn_idp->defn.info.routine.local_symtab = exit_scope();
exit_debug("a_function");
return;
} /* end A_FUNCTION */
/***************************************************************************/
/***************************************************************************/
/* function_body(rtn_idp) Process body of a function */
/* at entry, token is after ; ending the header */
/* at exit, token is after a ; and should be END_FUNCTION */
function_body(rtn_idp)
SYMTAB_NODE_PTR rtn_idp; /* routine id */
{
extern BOOLEAN block_flag;
entry_debug("function_body");
if (token_in(declaration_start_list)) {
declarations(rtn_idp);
/* synchronize(follow_decls_list, NULL, NULL); */
}
/* possibly need an else skip_declarations(rtn_idp); here */
block_flag = TRUE;
/* possibly empty list of statements */
if (token_in(statement_start_list)) {
crunch_token();
statements();
crunch_statement_marker();
change_crunched_token(END_OF_STATEMENTS);
}
block_flag = FALSE;
/* if_token_get_else_error(XEND_FUNCTION, MISSING_END_FUNCTION);
* if_token_get_else_error(SEMICOLON, MISSING_SEMICOLON);
*/
exit_debug("function_body");
return;
} /* end FUNCTION_BODY */
/***************************************************************************/
/***************************************************************************/
/* a_procedure() Process EXPRESS procedure */
/* FUN/PROC <routine_header> ; <block> */
/* at entry, token is PROCEDURE */
/* at exit, token is past final ; */
a_procedure()
{
SYMTAB_NODE_PTR rtn_idp; /* routine id */
entry_debug("a_procedure");
rtn_idp = procedure_header();
/* sync. Should be ; */
synchronize(follow_header_list, declaration_start_list, statement_start_list);
if_token_get(SEMICOLON);
else if (token_in(declaration_start_list) || token_in(statement_start_list))
error(MISSING_SEMICOLON);
/* block or forward */
if (strcmp(word_string, "forward") != 0) {
rtn_idp->defn.info.routine.key = DECLARED;
analyze_routine_header(rtn_idp);
rtn_idp->defn.info.routine.locals = NULL;
function_body(rtn_idp);
rtn_idp->defn.info.routine.code_segment = create_code_segment();
analyze_block(rtn_idp->defn.info.routine.code_segment);
if_token_get_else_error(XEND_PROCEDURE, MISSING_END_PROCEDURE);
if_token_get_else_error(SEMICOLON, MISSING_SEMICOLON);
}
else {
get_token();
rtn_idp->defn.info.routine.key = FORWARD;
analyze_routine_header(rtn_idp);
}
rtn_idp->defn.info.routine.local_symtab = exit_scope();
exit_debug("a_procedure");
return;
} /* end A_PROCEDURE */
/***************************************************************************/
/***************************************************************************/
/* procedure_header() Process a procedure header */
/* PROCEDURE <id> */
/* or PROCEDURE <id> ( <parm-list> ) */
/* returns pointer to the procedure id node. */
SYMTAB_NODE_PTR procedure_header()
{
SYMTAB_NODE_PTR proc_idp; /* procedure id */
SYMTAB_NODE_PTR parm_listp; /* formal param list */
int parm_count;
int total_parm_size;
BOOLEAN forward_flag = FALSE; /* TRUE iff forward */
entry_debug("procedure_header");
get_token();
/* if proc id has already been declared in this scope, */
/* it must be a forward */
if (token == IDENTIFIER) {
search_local_symtab(proc_idp);
if (proc_idp == NULL) {
enter_local_symtab(proc_idp);
proc_idp->defn.key = PROC_DEFN;
proc_idp->defn.info.routine.total_local_size = 0;
proc_idp->typep = &dummy_type;
proc_idp->label_index = 0;
}
else if ((proc_idp->defn.key == PROC_DEFN) &&
(proc_idp->defn.info.routine.key == FORWARD))
forward_flag = TRUE;
else error(REDEFINED_IDENTIFIER);
get_token();
}
else error(MISSING_IDENTIFIER);
/* sync. Should be ( or ; */
synchronize(follow_proc_id_list, declaration_start_list, statement_start_list);
enter_scope(NULL);
/* optional formal parameters, if FORWARD shouldn't be any, but parse */
/* for error recovery */
if (token == LPAREN) {
parm_listp = formal_parm_list(&parm_count, &total_parm_size);
if (forward_flag) error(ALREADY_FORWARDED);
else {
proc_idp->defn.info.routine.parm_count = parm_count;
proc_idp->defn.info.routine.total_parm_size = total_parm_size;
proc_idp->defn.info.routine.parms = parm_listp;
}
}
else if (!forward_flag) {
proc_idp->defn.info.routine.parm_count = 0;
proc_idp->defn.info.routine.total_parm_size = 0;
proc_idp->defn.info.routine.parms = NULL;
}
proc_idp->typep = NULL;
exit_debug("procedure_header");
return(proc_idp);
} /* end procedure_header */
/***************************************************************************/
/***************************************************************************/
/* function_header() Process a function header */
/* FUNCTION <id> : <type-id> */
/* or FUNCTION <id> ( <parm-list> ) : <type-id> */
/* returns pointer to the function id node. */
SYMTAB_NODE_PTR function_header()
{
SYMTAB_NODE_PTR func_idp, type_idp; /* function and type id */
SYMTAB_NODE_PTR parm_listp; /* formal param list */
int parm_count;
int total_parm_size;
BOOLEAN forward_flag = FALSE; /* TRUE iff forward */
entry_debug("function_header");
get_token();
/* if func id has already been declared in this scope, */
/* it must be a forward */
if (token == IDENTIFIER) {
search_local_symtab(func_idp);
if (func_idp == NULL) {
enter_local_symtab(func_idp);
func_idp->defn.key = FUNC_DEFN;
func_idp->defn.info.routine.total_local_size = 0;
func_idp->typep = &dummy_type;
func_idp->label_index = 0;
}
else if ((func_idp->defn.key == FUNC_DEFN) &&
(func_idp->defn.info.routine.key == FORWARD))
forward_flag = TRUE;
else error(REDEFINED_IDENTIFIER);
get_token();
}
else error(MISSING_IDENTIFIER);
/* sync. Should be ( or : or ; */
synchronize(follow_func_id_list, declaration_start_list, statement_start_list);
enter_scope(NULL);
/* optional formal parameters, if FORWARD shouldn't be any, but parse */
/* for error recovery */
if (token == LPAREN) {
parm_listp = formal_parm_list(&parm_count, &total_parm_size);
if (forward_flag) error(ALREADY_FORWARDED);
else {
func_idp->defn.info.routine.parm_count = parm_count;
func_idp->defn.info.routine.total_parm_size = total_parm_size;
func_idp->defn.info.routine.parms = parm_listp;
}
}
else if (!forward_flag) {
func_idp->defn.info.routine.parm_count = 0;
func_idp->defn.info.routine.total_parm_size = 0;
func_idp->defn.info.routine.parms = NULL;
}
/* for a forward, should not be a type, but parse anyway */
if (!forward_flag || (token == COLON)) {
if_token_get_else_error(COLON, MISSING_COLON);
/* changed for EXPRESS
if (token == IDENTIFIER) {
search_and_find_all_symtab(type_idp);
if (type_idp->defn.key != TYPE_DEFN) error(INVALID_TYPE);
if (!forward_flag) func_idp->typep = type_idp->typep;
get_token();
}
else {
error(MISSING_IDENTIFIER);
func_idp->typep = &dummy_type;
}
*/
if (!forward_flag) func_idp->typep = get_type();
get_token();
if (forward_flag) error(ALREADY_FORWARDED);
}
exit_debug("function_header");
return(func_idp);
} /* end function_header */
/***************************************************************************/
/***************************************************************************/
/* formal_parm_list(countp, total_size) Process formal parameter list */
/* ( VAR <id-list> : <type> ; */
/* <id-list> : <type> ; ... ) */
/* return a pointer to the head of the parameter id list */
SYMTAB_NODE_PTR formal_parm_list(countp, total_sizep)
int *countp; /* ptr to count of parameters */
int *total_sizep; /* ptr to total byte size of parameters */
{
SYMTAB_NODE_PTR parm_idp, first_idp, last_idp; /* parm ids */
SYMTAB_NODE_PTR prev_last_idp = NULL; /* last id of list */
SYMTAB_NODE_PTR parm_listp = NULL; /* parm list */
SYMTAB_NODE_PTR type_idp; /* type id */
TYPE_STRUCT_PTR parm_tp; /* parm type */
DEFN_KEY parm_defn; /* parm definition */
int parm_count = 0; /* count of parms */
int parm_offset = STACK_FRAME_HEADER_SIZE;
entry_debug("formal_parm_list");
get_token();
/* loop to process declarations seperated by ; */
while ((token == IDENTIFIER) || (token == VAR)) {
first_idp = NULL;
/* VAR parm? */
if (token == VAR) {
parm_defn = VARPARM_DEFN;
get_token();
}
else parm_defn = VALPARM_DEFN;
/* <id list> */
while (token == IDENTIFIER) {
search_and_enter_local_symtab(parm_idp);
parm_idp->defn.key = parm_defn;
parm_idp->label_index = 0;
++parm_count;
if (parm_listp == NULL) parm_listp = parm_idp;
/* link parms together */
if (first_idp == NULL) first_idp = last_idp = parm_idp;
else {
last_idp->next = parm_idp;
last_idp = parm_idp;
}
get_token();
if_token_get(COMMA);
}
if_token_get_else_error(COLON, MISSING_COLON);
/* changed following for EXPRESS
if (token == IDENTIFIER) {
search_and_find_all_symtab(type_idp);
if (type_idp->defn.key != TYPE_DEFN) error(INVALID_TYPE);
parm_tp = type_idp->typep;
get_token();
}
else {
error(MISSING_IDENTIFIER);
parm_tp = &dummy_type;
}
*/
parm_tp = get_type();
get_token();
/* assign the offset and the type to all parm ids in the sublist */
for (parm_idp = first_idp; parm_idp != NULL; parm_idp = parm_idp->next) {
parm_idp->typep = parm_tp;
parm_idp->defn.info.data.offset = parm_offset++;
}
/* link this sublist to the list of all parm ids */
if (prev_last_idp != NULL) prev_last_idp->next = first_idp;
prev_last_idp = last_idp;
/* sync: Should be ; or ) */
synchronize(follow_parms_list, NULL, NULL);
if_token_get(SEMICOLON);
} /* end while */
if_token_get_else_error(RPAREN, MISSING_RPAREN);
*countp = parm_count;
*total_sizep = parm_offset - STACK_FRAME_HEADER_SIZE;
exit_debug("formal_parm_list");
return(parm_listp);
} /* end formal_parm_list */
/***************************************************************************/
/***************************************************************************/
/* routine_call(rtn_idp, parm_check_flag) Process a call to a procedure */
/* or function */
/* return pointer to the type structure of the call */
TYPE_STRUCT_PTR routine_call(rtn_idp, parm_check_flag)
SYMTAB_NODE_PTR rtn_idp; /* routine id */
BOOLEAN parm_check_flag; /* if TRUE then check parms */
{
TYPE_STRUCT_PTR declared_routine_call(), standard_routine_call();
entry_debug("routine_call");
if ((rtn_idp->defn.info.routine.key == DECLARED) ||
(rtn_idp->defn.info.routine.key == FORWARD) ||
(!parm_check_flag)) {
exit_debug("routine_call");
return(declared_routine_call(rtn_idp, parm_check_flag));
}
else {
exit_debug("routine_call");
return(standard_routine_call(rtn_idp));
}
} /* end routine_call */
/***************************************************************************/
/***************************************************************************/
/* declared_routine_call(rtn_idp, parm_check_flag) Process a call to a */
/* declared function or procedure */
/* <id> or */
/* <id> ( <parm-list> ) */
/* The actual params are checked against the */
/* formal params for type and number. */
/* return pointer to type structure of the call */
TYPE_STRUCT_PTR declared_routine_call(rtn_idp, parm_check_flag)
SYMTAB_NODE_PTR rtn_idp; /* routine id */
BOOLEAN parm_check_flag; /* if TRUE then check parms */
{
entry_debug("declared_routine_call");
actual_parm_list(rtn_idp, parm_check_flag);
exit_debug("declared_routine_call");
return(rtn_idp->defn.key == PROC_DEFN ? NULL : rtn_idp->typep);
} /* end declared_routine_call */
/***************************************************************************/
/***************************************************************************/
/* actual_parm_list(rtn_idp, parm_check_flag) Process actual param list */
/* ( <expr-list> ) */
actual_parm_list(rtn_idp, parm_check_flag)
SYMTAB_NODE_PTR rtn_idp; /* routine id */
BOOLEAN parm_check_flag; /* if TRUE then check parms */
{
SYMTAB_NODE_PTR formal_parm_idp;
DEFN_KEY formal_parm_defn;
TYPE_STRUCT_PTR formal_parm_tp, actual_parm_tp;
entry_debug("actual_parm_list");
if (parm_check_flag) formal_parm_idp = rtn_idp->defn.info.routine.parms;
if (token == LPAREN) {
/* loop to process actual param expressions */
do {
/* get info on corresponding formal params */
if (parm_check_flag && (formal_parm_idp != NULL)) {
formal_parm_defn = formal_parm_idp->defn.key;
formal_parm_tp = formal_parm_idp->typep;
}
get_token();
/* Actual and formal parms must be consistent. */
/* Actual parm may be an expression */
if ((formal_parm_idp == NULL) ||
(formal_parm_defn == VALPARM_DEFN) ||
(!parm_check_flag)) {
actual_parm_tp = expression();
if (parm_check_flag &&
(formal_parm_idp != NULL) &&
(!is_assign_type_compatible(formal_parm_tp, actual_parm_tp)))
error(INCOMPATIBLE_TYPES);
}
/* Now the same for VAR params */
else {
if (token == IDENTIFIER) {
SYMTAB_NODE_PTR idp;
search_and_find_all_symtab(idp);
actual_parm_tp = variable(idp, VARPARM_USE);
if (formal_parm_tp != actual_parm_tp) error(INCOMPATIBLE_TYPES);
}
else { /* not a variable, but parse anyway */
actual_parm_tp = expression();
error(INVALID_VAR_PARM);
}
}
/* check if there are more actuals than formals */
if (parm_check_flag) {
if (formal_parm_idp == NULL) error(WRONG_NUMBER_OF_PARMS);
else formal_parm_idp = formal_parm_idp->next;
}
/* sync. Should be , or ) */
synchronize(follow_parm_list, statement_end_list, NULL);
} while (token == COMMA); /* end do */
if_token_get_else_error(RPAREN, MISSING_RPAREN);
}
/* check for fewer actuals than formals */
if (parm_check_flag && (formal_parm_idp != NULL)) error(WRONG_NUMBER_OF_PARMS);
exit_debug("actual_parm_list");
return;
} /* end actual_parm_list */
/***************************************************************************/
/***************************************************************************/
/* block(rtn_idp) Process a block, which consists of declarations */
/* followed by a compound statement */
old_block(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;
{
extern BOOLEAN block_flag;
entry_debug("block");
declarations(rtn_idp);
/* sync. Should be ; */
synchronize(follow_decls_list, NULL, NULL);
if (token != BEGIN) error(MISSING_BEGIN);
crunch_token();
block_flag = TRUE;
compound_statement();
block_flag = FALSE;
exit_debug("block");
return;
} /* end block */
/***************************************************************************/