path: root/support/ltx2x/l2xistmt.c

/* l2xistmt.c  LTX2X interpreter parsing routines for statements */
/*  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 "l2xiexec.h"
#include "l2xiidbg.h"

#ifndef l2xicpr_h
#include "l2xicpr.h"     /* extern token code lists */
#endif


/* EXTERNALS */

extern TOKEN_CODE token;
extern char token_string[];
extern char word_string[];
extern LITERAL literal;
extern SYMTAB_NODE_PTR symtab_display[]; 
extern int level; 
extern ICT *code_bufferp;
extern SYMTAB_NODE_PTR true_idp, false_idp, unknown_idp;

/* FORWARDS */

TOKEN_CODE case_branch();

/***************************************************************************/
/* statement()  Call routines to process a statement, depending on the     */
/*              the first token of the statement.                          */
/*     at entry, token is one of statement_start_list                      */
/*     at exit, token is the closing (e.g., ; or END_  )                   */

statement()
{
  entry_debug("statement");

  if (token != BEGIN) crunch_statement_marker();

  /* call the proper routine from the first token */
  switch (token) {
    case IDENTIFIER: {
      SYMTAB_NODE_PTR idp;
      /* assignment or procedure call ? */
      search_and_find_all_symtab(idp);
      if (idp->defn.key == PROC_DEFN ||
          idp->defn.key == FUNC_DEFN) {
        crunch_symtab_node_ptr(idp);
        get_token();
        routine_call(idp, TRUE);
      }    
      else assignment_statement(idp);
      break;
    }
    case REPEAT: { 
      grepeat_statement();
      break;
    }
    case IF: { 
      if_statement();
      break;
    }
    case CASE: { 
      case_statement();
      break;
    }
    case BEGIN: { 
      compound_statement();
      break;
    }
    case XRETURN: {
      return_statement();
      break;
    }
    case XSKIP: {
      skip_statement();
      break;
    }
    case XESCAPE: {
      escape_statement();
      break;
    }
  } /* end switch */

  /* sync. Only a semicolon, END, ELSE or UNTIL can follow a statement */
  /*       check for mssing semicolon */
  synchronize(statement_end_list, statement_start_list, NULL); 
  if (token_in(statement_start_list)) error(MISSING_SEMICOLON);

  exit_debug("statement");
  return;
}                                                         /* end statement */
/***************************************************************************/


TOKEN_CODE end_funproc_list[] = {XEND_FUNCTION, XEND_PROCEDURE, 0};

/***************************************************************************/
/* return_statement()         Process EXPRESS return statement             */
/*                       RETURN [ '(' <expression> ')' ] ';'               */
/*    at entry, token is RETURN                                            */
/*    at exit, token is ; or END_FUNPROC                                   */

return_statement()
{
  entry_debug("return_statement");

  get_token();
  switch (token) {
    case SEMICOLON : {
      exit_debug("return_statement");
      return;
    }
    case LPAREN : {
      expression();
      exit_debug("return_statement");
      return;
    }
    default : {
      synchronize(end_funproc_list, NULL, NULL);
      exit_debug("return_statement");
      return;
    }

  } /* end switch */

}                                                  /* end RETURN_STATEMENT */
/***************************************************************************/





/***************************************************************************/
/* assignment_statement(var_idp)  Process an assignment statement          */
/*                         <id> := <expr>                                  */

assignment_statement(var_idp)
SYMTAB_NODE_PTR var_idp;                 /* target variable id */
{
  TYPE_STRUCT_PTR var_tp, expr_tp;       /* types of var and expression */
  entry_debug("assignment_statement");

  var_tp = variable(var_idp, TARGET_USE);
  if_token_get_else_error(COLONEQUAL, MISSING_COLONEQUAL);

  expr_tp = expression();

  if (!is_assign_type_compatible(var_tp, expr_tp)) {
     error(INCOMPATIBLE_ASSIGNMENT);
   }

  exit_debug("assignment_statement");
  return;
}                                              /* end assignment_statement */
/***************************************************************************/



/***************************************************************************/
/* grepeat_statement()  Process a REPEAT statement                         */
/*   REPEAT [ <inc_control> ] [ <while_control> ] [ <until_control> ] ;    */
/*          <stmt-list> END_REPEAT                                         */
/*   at entry: token is REPEAT                                             */
/*   at exit:  token is after END_REPEAT;                                  */

grepeat_statement()
{
  TYPE_STRUCT_PTR expr_tp;
  ADDRESS loop_end_location;
  entry_debug("grepeat_statement");

  get_token();
  loop_end_location = crunch_address_marker(NULL);  /* place holder */

  /* controls */
  if (token == IDENTIFIER) {      /* increment control */
    inc_control();
  }
  while_control();
  until_control();
  if_token_get_else_error(SEMICOLON, MISSING_SEMICOLON);

        /* the list of statements */
  do {
    statement();
    while (token == SEMICOLON) get_token();
  } while (token_in(statement_start_list));

/*  if_token_get_else_error(SEMICOLON, MISSING_SEMICOLON); */
  if_token_get_else_error(XEND_REPEAT, MISSING_END_REPEAT);

  /* finally set the address marker for after the END_REPEAT */
  fixup_address_marker(loop_end_location);

  exit_debug("grepeat_statement");
  return;
}                                                 /* end GREPEAT_STATEMENT */
/***************************************************************************/



/***************************************************************************/
/* inc_control()      Process an increment control                         */
/*              var := <expr> TO <expr> [ BY <expr> ]                      */
/*   at entry: token is var                                                */
/*   at exit:  token is after <expr>                                       */

inc_control()
{
  SYMTAB_NODE_PTR by_np;
  SYMTAB_NODE_PTR for_idp;
  TYPE_STRUCT_PTR for_tp, expr_tp, by_tp;
  TOKEN_CODE save_tok;
  entry_debug("inc_control (l2xistmt.c)");

  /* fake a FOR */
  save_tok = token;
  change_crunched_token(FOR);
  crunch_extra_token(save_tok);

  search_and_find_all_symtab(for_idp);
  crunch_symtab_node_ptr(for_idp);
  if ((for_idp->level != level) || (for_idp->defn.key != VAR_DEFN)) {
    error(INVALID_INCREMENT_CONTROL);
  }

  for_tp = base_type(for_idp->typep);
  get_token();

  if ((for_tp != integer_typep) ) {
     error(INCOMPATIBLE_TYPES);
  }

  if_token_get_else_error(COLONEQUAL, MISSING_COLONEQUAL);

  expr_tp = expression();
  if (!is_assign_type_compatible(for_tp, expr_tp)) {
    error(INCOMPATIBLE_TYPES);
  }

  if (token == TO) {
    get_token();
  }
  else {
    error(MISSING_TO);
  }

  expr_tp = expression();
  if (!is_assign_type_compatible(for_tp, expr_tp)) {
    error(INCOMPATIBLE_TYPES);
  }

  if (token == XBY) {          /* BY <expr> */
    get_token();
    expr_tp = expression();
    if (!is_assign_type_compatible(for_tp, expr_tp)) {
      error(INCOMPATIBLE_TYPES);
      get_token();
    }
  }
  else {                       /* fake a BY */
    save_tok = token;
    change_crunched_token(XBY);
    crunch_extra_token(NUMBER_LITERAL);
    by_np = search_symtab("1", symtab_display[1]);
    if (by_np == NULL) {
     by_np = enter_symtab("1", symtab_display[1]);
    }
    by_tp = integer_typep;
    by_np->defn.info.constant.value.integer = 1;
    crunch_symtab_node_ptr(by_np);
    crunch_extra_token(save_tok);
  }

  exit_debug("inc_control");
}                                                       /* end INC_CONTROL */
/***************************************************************************/



/***************************************************************************/
/* while_control()  Process a WHILE control                                */
/*                    WHILE <expr>                                         */
/*  at entry: token may be WHILE                                           */
/*  at exit:  token is after <expr>                                        */

while_control()
{
  TYPE_STRUCT_PTR expr_tp;
  TOKEN_CODE save_tok;
  entry_debug("while_control (l2xistmt.c)");

  if (token != WHILE) {  /* fake a WHILE */ 
    save_tok = token;
    change_crunched_token(WHILE);
    crunch_extra_token(IDENTIFIER);
    crunch_symtab_node_ptr(true_idp);
    crunch_extra_token(save_tok);
    exit_debug("while_control");
    return;
  }

  get_token();

  expr_tp = expression();
  if (expr_tp != logical_typep) error(INCOMPATIBLE_TYPES);

  exit_debug("while_control");
  return;
}                                                     /* end WHILE_CONTROL */
/***************************************************************************/



/***************************************************************************/
/* until_control()  Process an UNTIL control                               */
/*                    UNTIL <expr>                                         */
/*  at entry: token may be UNTIL                                           */
/*  at exit:  token is after <expr>                                        */

until_control()
{
  TYPE_STRUCT_PTR expr_tp;
  TOKEN_CODE save_tok;
  entry_debug("until_control (l2xistmt.c)");

  if (token != UNTIL) {  /* fake an UNTIL */ 
    save_tok = token;
    change_crunched_token(UNTIL);
    crunch_extra_token(IDENTIFIER);
    crunch_symtab_node_ptr(false_idp);
    crunch_extra_token(save_tok);
    exit_debug("until_control");
    return;
  }

  get_token();

  expr_tp = expression();
  if (expr_tp != logical_typep) error(INCOMPATIBLE_TYPES);


  exit_debug("until_control");
  return;
}                                                     /* end UNTIL_CONTROL */
/***************************************************************************/



/***************************************************************************/
/* if_statement()  Process an IF statement                                 */
/*                 IF <expr> THEN <stmt> END_IF  or                        */
/*                 IF <expr> THEN <stmt> ELSE <stmt> END_IF                */

if_statement()
{
  TYPE_STRUCT_PTR expr_tp;
  ADDRESS if_end_location;
  ADDRESS false_location;
  entry_debug("if_statement");

  get_token();
  false_location = crunch_address_marker(NULL); 

  expr_tp = expression();
  if (expr_tp != logical_typep) error(INCOMPATIBLE_TYPES);

  if_token_get_else_error(THEN, MISSING_THEN);
  statements();
  fixup_address_marker(false_location);

  /* the ELSE branch */
  if (token == ELSE) {
    get_token();
    if_end_location = crunch_address_marker(NULL);

    statements();

    fixup_address_marker(if_end_location);
  }
  if_token_get_else_error(XEND_IF, MISSING_END_IF);

  exit_debug("if_statement");
  return;
}                                                      /* end if_statement */
/***************************************************************************/



/***************************************************************************/
/* case_statement()  Process a CASE statement                              */
/*                   CASE <expr> OF                                        */
/*                     <case-branch>                                       */
/*                   END_CASE                                              */
/* CASE globals */

typedef struct case_item {
  int label_value;
  ADDRESS branch_location;
  struct case_item *next;
} CASE_ITEM, *CASE_ITEM_PTR;

CASE_ITEM_PTR case_item_head, case_item_tail;
int case_label_count;

case_statement()
{
  BOOLEAN another_branch;
  TYPE_STRUCT_PTR expr_tp;
  TYPE_STRUCT_PTR case_label();
  CASE_ITEM_PTR case_itemp, next_case_itemp;
  ICT *branch_table_location;
  ICT *case_end_chain = NULL;
  TOKEN_CODE save_tok;
  entry_debug("case_statement");

  /* initialisations for the branch table */
  get_token();
  branch_table_location = crunch_address_marker(NULL); 
  case_item_head = case_item_tail = NULL;
  case_label_count = 0;


  expr_tp = expression();
  if (((expr_tp->form != SCALAR_FORM) &&
       (expr_tp->form != ENUM_FORM) &&
       (expr_tp->form != SUBRANGE_FORM)) ||
      (expr_tp == real_typep)) error(INCOMPATIBLE_TYPES);

  /* sync. Should be OF */
  synchronize(follow_expr_list, case_label_start_list, NULL);
  if_token_get_else_error(OF, MISSING_OF);

  /* loop to process CASE branches */
  another_branch = token_in(case_label_start_list);
  while (another_branch) {
    if (token_in(case_label_start_list)) case_branch(expr_tp);
    /* link another address marker at the end of the branch to point to */
    /* the end of the CASE statement                                    */
    case_end_chain = crunch_address_marker(case_end_chain); 

    if (token == SEMICOLON) {
      get_token();
      another_branch = TRUE;
    }
    else if (token_in(case_label_start_list)) {
/*      error(MISSING_SEMICOLON); */
      another_branch = TRUE;
    }
    else another_branch = FALSE;
  } /* end while */

  debug_print("case_statement: finished case branches\n");

  /* emit the branch table */
  fixup_address_marker(branch_table_location); 
  crunch_integer(case_label_count);
  case_itemp = case_item_head;
  debug_print("case_statement: starting loop over case_itemp\n");
  while (case_itemp != NULL) {
    crunch_integer(case_itemp->label_value);
    crunch_offset(case_itemp->branch_location);
    next_case_itemp = case_itemp->next;
    free(case_itemp);
    case_itemp = next_case_itemp;
  }

  debug_print("case_statement: finished loop over case_itemp\n");

  if_token_get_else_error(XEND_CASE, MISSING_END_CASE);

  /* fix up the branch address markers */
  while (case_end_chain != NULL) {
    sprintf(dbuffer, "case statement: case_end_chain = %d\n", case_end_chain);
    debug_print(dbuffer);
    case_end_chain = fixup_address_marker(case_end_chain);
  }


  exit_debug("case_statement");
  return;
}                                                    /* end case_statement */
/***************************************************************************/



/***************************************************************************/
/* case_branch(expr_tp)  Process a CASE branch                             */
/*                       <case-label-list> : <stmt>                        */

TOKEN_CODE case_branch(expr_tp)
TYPE_STRUCT_PTR expr_tp;     /* type of CASE expression */
{
  BOOLEAN another_label;
  TYPE_STRUCT_PTR label_tp;
  CASE_ITEM_PTR case_itemp;
  CASE_ITEM_PTR old_case_item_tail = case_item_tail;
  TYPE_STRUCT_PTR case_label();
  TOKEN_CODE save_tok;
  entry_debug("case_branch");

  /* process <case-label-list> */
  do {
    label_tp = case_label();
    if (expr_tp != label_tp && label_tp != any_typep) error(INCOMPATIBLE_TYPES);

    get_token();
    if (token == COMMA) {
      get_token();
      if (token_in(case_label_start_list)) another_label = TRUE;
      else {
        error(MISSING_CONSTANT);
        another_label = FALSE;
      }
    }
    else another_label = FALSE;
  } while (another_label); /* end  do over case label list */

  /* sync Sholud be : */
  synchronize(follow_case_label_list, statement_start_list, NULL);
  if_token_get_else_error(COLON, MISSING_COLON);

  /* loop to fill in the branch location field of each item for this branch */
  case_itemp = old_case_item_tail == NULL      
                     ? case_item_head
		     : old_case_item_tail->next;
  while (case_itemp != NULL) {
    case_itemp->branch_location = code_bufferp;
    case_itemp = case_itemp->next;
  }


  statement();
             /* make a `fake' compound statement to enable multiple */
             /* statements for a particular case                    */
/*
*  save_tok = token;
*  change_crunched_token(BEGIN);
*  crunch_extra_token(save_tok);
*  statements();
*  save_tok = token;
*  change_crunched_token(END);
*  crunch_extra_token(SEMICOLON); 
*  crunch_extra_token(save_tok);
*/

  exit_debug("case_branch");
  return(save_tok);
}                                                       /* end case_branch */
/***************************************************************************/



/***************************************************************************/
/* case_label()  Process a case label                                      */
/* return a pointer to its type structure                                  */

TYPE_STRUCT_PTR case_label()
{
  TOKEN_CODE sign = PLUS;  /* unary + or - */
  BOOLEAN saw_sign = FALSE; /* TRUE iff unary sign */
  TYPE_STRUCT_PTR label_tp;
  CASE_ITEM_PTR case_itemp = alloc_struct(CASE_ITEM);
  entry_debug("case_label");

  /* link in case item for this label */
  if (case_item_head != NULL) {  
    case_item_tail->next = case_itemp;
    case_item_tail = case_itemp;
  }
  else {
    case_item_head = case_item_tail = case_itemp;
  }
  case_itemp->next = NULL;
  ++case_label_count;


  /* unary + or - */
  if ((token == PLUS) || (token == MINUS)) {
    sign = token;
    saw_sign = TRUE;
    get_token();
  }

  /* numeric constant --- integer only */
  if (token == NUMBER_LITERAL) {
    SYMTAB_NODE_PTR np = search_symtab(token_string, symtab_display[1]);
    if (np == NULL) np = enter_symtab(token_string, symtab_display[1]);
    crunch_symtab_node_ptr(np);

    if (literal.type == INTEGER_LIT)
      case_itemp->label_value = sign == PLUS
                       ? literal.value.integer
		       : -literal.value.integer;
    else error(INVALID_CONSTANT);
    exit_debug("case_label");
    return(integer_typep);
  }

  else if (token == XOTHERWISE) {             /* default --- any type */
    case_itemp->label_value = XOTHERWISE;
    exit_debug("case_label");
    return(any_typep);
  }

  /* id constant: int, char, or enum only */
  else if (token == IDENTIFIER) {
    SYMTAB_NODE_PTR idp;

    search_all_symtab(idp);
    crunch_symtab_node_ptr(idp);

    if (idp == NULL) {
      error(UNDEFINED_IDENTIFIER);
      exit_debug("case_label");
      return(&dummy_type);
    }
    else if (idp->defn.key != CONST_DEFN) {
      error(NOT_A_CONSTANT_IDENTIFIER);
      exit_debug("case_label");
      return(&dummy_type);
    }
    else if (idp->typep == integer_typep) {
      case_itemp->label_value = sign = PLUS    
                              ? idp->defn.info.constant.value.integer
                              : -idp->defn.info.constant.value.integer;

      exit_debug("case_label");
      return(integer_typep);
    }
    else if (idp->typep->form == ENUM_FORM) {
      if (saw_sign) error(INVALID_CONSTANT);
      case_itemp->label_value = idp->defn.info.constant.value.integer; 
      exit_debug("case_label");
      return(idp->typep);
    }
    else {
      exit_debug("case_label");
       return(&dummy_type);
    }
  }
  
  else {
    error(INVALID_CONSTANT);
    exit_debug("case_label");
    return(&dummy_type);
  }

}                                                        /* end case_label */
/***************************************************************************/



/***************************************************************************/
/* compound_statement()  Process a compound statement                      */
/*                       BEGIN <stmt-list> END                             */

compound_statement()
{
  entry_debug("compound_statement");

  get_token();
  do {
    statement();
    while (token == SEMICOLON) get_token();
    if (token == END) break;
    /* sync. Should be at the start of next statement */
    synchronize(statement_start_list, NULL, NULL);
  } while (token_in(statement_start_list));
  if_token_get_else_error(END, MISSING_END);

  exit_debug("compound_statement");
  return;
}                                                /* end compound_statement */
/***************************************************************************/


/***************************************************************************/
/* skip_statement()  Process a SKIP statement                              */
/*                   SKIP;                                                 */
/*  at entry: token is SKIP                                                */
/*  at exit:  token is after SKIP                                          */

skip_statement()
{
  entry_debug("skip_statement (l2xistmt.c)");

  get_token();

  exit_debug("skip_statement");
}                                                    /* end SKIP_STATEMENT */
/***************************************************************************/


/***************************************************************************/
/* escape_statement()  Process a ESCAPE statement                          */
/*                   ESCAPE;                                               */
/*  at entry: token is ESCAPE                                              */
/*  at exit:  token is after ESCAPE                                        */

escape_statement()
{
  entry_debug("escape_statement (l2xistmt.c)");

  get_token();

  exit_debug("escape_statement");
}                                                  /* end ESCAPE_STATEMENT */
/***************************************************************************/