summaryrefslogtreecommitdiff
path: root/support/ltx2x/l2xirtne.c
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/ltx2x/l2xirtne.c
Initial commit
Diffstat (limited to 'support/ltx2x/l2xirtne.c')
-rw-r--r--support/ltx2x/l2xirtne.c651
1 files changed, 651 insertions, 0 deletions
diff --git a/support/ltx2x/l2xirtne.c b/support/ltx2x/l2xirtne.c
new file mode 100644
index 0000000000..c7dc7b8675
--- /dev/null
+++ b/support/ltx2x/l2xirtne.c
@@ -0,0 +1,651 @@
+/* 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 */
+/***************************************************************************/
+