/* l2xiexpr.c  LTX2X interpreter parsing routines for expressions      */
/*  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"
#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; 

  /* built-in constants */
extern SYMTAB_NODE_PTR false_idp, true_idp, unknown_idp;
extern SYMTAB_NODE_PTR conste_idp, pi_idp, undef_idp;
extern SYMTAB_NODE_PTR day_idp, month_idp, year_idp;

/* FORWARDS */
TYPE_STRUCT_PTR expression(), simple_expression(), term(), factor(),
                function_call();
TYPE_STRUCT_PTR simple_factor();
TYPE_STRUCT_PTR index_list();


/* MACROS */

/* integer_operands(tp1, tp2) TRUE if both are integer, else FALSE         */
#define integer_operands(tp1, tp2) ((tp1 == integer_typep) && \
                                    (tp2 == integer_typep))

/* real_operands(tp1, tp2)  TRUE if one or both operands are real, and     */
/*                          the other is integer, else FALSE               */
#define real_operands(tp1, tp2) (((tp1 == real_typep) &&      \
                                  ((tp2 == real_typep) ||     \
                                   (tp2 == integer_typep)))   \
                                         ||                   \
                                  ((tp2 == real_typep) &&     \
                                    ((tp1 == real_typep) ||   \
                                     (tp1 == integer_typep))))

/* boolean_operands(tp1, tp2) TRUE if both are boolean, else FALSE         */
#define boolean_operands(tp1, tp2) ((tp1 == boolean_typep) &&  \
                                    (tp2 == boolean_typep))

/* logical_operands(tp1, tp2) TRUE if both are logical/boolean, else FALSE    */
#define logical_operands(tp1, tp2) ((tp1 == boolean_typep || tp1 == logical_typep) &&  \
                                    (tp2 == boolean_typep || tp2 == logical_typep))

/* string_operands(tp1, tp2) TRUE iff both are string */
#define string_operands(tp1, tp2) ((tp1 == string_typep ||         \
                                    tp1->form == STRING_FORM) &&   \
                                   (tp2 == string_typep ||         \
                                    tp2->form == STRING_FORM))

/* NEW undef_types(tp1, tp2) TRUE if either is undefined, else FALSE */
#define undef_types(tp1, tp2) ((tp1 == any_typep) || \
                               (tp2 == any_typep))

/* NEW is_undef(tp1) TRUE if undefined, else FALSE */
#define is_undef(tp1) (tp1 == any_typep)

/* NEW set_undef(tp1)  sets tp1 to be an undef */
#define set_undef(tp1) tp1 = any_typep

/***************************************************************************/
/* expression() Process an expression consisting of a simple expression,   */
/*              optionally followed by a relational operator and a         */
/*              second simple expression.                                  */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR expression()
{
  TYPE_STRUCT_PTR result_tp, tp2;
  entry_debug("expression");

  /* first simple expression */
  result_tp = simple_expression();

  /* if operator, process following expression */
  if (token_in(rel_op_list)) {
    result_tp = base_type(result_tp);
    /* second expression */
    get_token();
    tp2 = base_type(simple_expression());
    check_rel_op_types(result_tp, tp2);
    result_tp = logical_typep;
  }

  exit_debug("expression");
  return(result_tp);
}                                                        /* end expression */
/***************************************************************************/



/***************************************************************************/
/* simple_expression() Process a simple expression                         */
/*                     consisting of terms seperated by +, -, OR, XXOR     */
/*                     operators. There may be an initial unary operator   */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR simple_expression()
{
  TOKEN_CODE op;                   /* operator token */
  TYPE_STRUCT_PTR result_tp, tp2;
  BOOLEAN saw_unary_op = FALSE;
  entry_debug("simple_expression");

  /* remember intial unary op */
  if ((token == PLUS) || (token == MINUS)) {
    saw_unary_op = TRUE;
    get_token();
  }

  /* first term */
  result_tp = term();

  /* if there was a unary operator, check its type for integer or real. */
  if (saw_unary_op && (base_type(result_tp) != integer_typep) &&
                      (result_tp != real_typep)) error(INCOMPATIBLE_TYPES);

  /* loop to process subsequent terms seperated by operators */
  while (token_in(add_op_list)) {
    op = token;
    result_tp = base_type(result_tp);

    get_token();
    tp2 = base_type(term());    /* next term */
    if (undef_types(result_tp, tp2)) {
      set_undef(result_tp);
    }
    else {
    switch (op) {
      case PLUS:  {
        /* integer op integer -> integer */
        if (integer_operands(result_tp, tp2))  result_tp = integer_typep;
        /* numbers -> real, */
        else if (real_operands(result_tp, tp2)) result_tp = real_typep;
        /* string concatenation */
        else if (string_operands(result_tp, tp2)) result_tp = string_typep;
        else {
          error(INCOMPATIBLE_TYPES);
          result_tp = &dummy_type;
        }
        break;
      }
      case MINUS: {  
        /* integer op integer -> integer */
        if (integer_operands(result_tp, tp2))  result_tp = integer_typep;
        /* otherwise numbers -> real, else error */
        else if (real_operands(result_tp, tp2)) result_tp = real_typep;
        else {
          error(INCOMPATIBLE_TYPES);
          result_tp = &dummy_type;
        }
        break;
      }
      case OR:
      case XXOR: {
        /* boolean OR boolean -> boolean */
        if (!logical_operands(result_tp, tp2)) {
          error(INCOMPATIBLE_TYPES);
          result_tp = &dummy_type;
          break;
        }
        result_tp = logical_typep;
        break;
      }
      case XLIKE: {
         /* string LIKE string -> boolean */
        if (!string_operands(result_tp, tp2)) {
          error(INCOMPATIBLE_TYPES);
          result_tp = &dummy_type;
          break;
        }
        result_tp = logical_typep;
        break;
      }
    } /* end switch */
  }
  } /* end while */

  exit_debug("simple_expression");
  return(result_tp);
}                                                 /* end simple_expression */
/***************************************************************************/



/***************************************************************************/
/* term() Process a term                                                   */
/*                     consisting of factors seperated by                  */
/*                     *, /, DIV, MOD, or AND                              */
/*                     operators.                                          */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR term()
{
  TOKEN_CODE op;                   /* operator token */
  TYPE_STRUCT_PTR result_tp, tp2;
  entry_debug("term");

  /* first factor */
  result_tp = factor();

  /* loop to process subsequent factors seperated by operators */
  while (token_in(mult_op_list)) {
    op = token;
    result_tp = base_type(result_tp);

    get_token();
    tp2 = base_type(factor());    /* next factor */
    if (undef_types(result_tp, tp2)) {
      set_undef(result_tp);
    }
    else {
    switch (op) {
      case STAR: {  
        /* integer op integer -> integer */
        if (integer_operands(result_tp, tp2))  result_tp = integer_typep;
        /* otherwise numbers -> real, else error */
        else if (real_operands(result_tp, tp2)) result_tp = real_typep;
        else {
          error(INCOMPATIBLE_TYPES);
          result_tp = &dummy_type;
        }
        break;
      }
      case SLASH: {  
        /* number op number -> real */
        if ((!real_operands(result_tp, tp2)) && 
            (!integer_operands(result_tp, tp2))) {
          error(INCOMPATIBLE_TYPES);
        }
        result_tp = real_typep;
        break;
      }
      case DIV:
      case MOD: {
        /* integer op integer -> integer */
        if (!integer_operands(result_tp, tp2)) error(INCOMPATIBLE_TYPES);
        result_tp = integer_typep;
        break;
      }
      case AND: {
        /* boolean op boolean -> boolean */
        if (!logical_operands(result_tp, tp2)) {
          error(INCOMPATIBLE_TYPES);
          result_tp = logical_typep;
          break;
        }
      }
    } /* end switch */
  }
  } /* end while */

  exit_debug("term");
  return(result_tp);
}                                                              /* end term */
/***************************************************************************/



/***************************************************************************/
/* factor()    Process an EXPRESS factor                                   */
/*             simple_factor [ ** simple_factor ]                          */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR factor()
{
  TOKEN_CODE op;                   /* operator token */
  TYPE_STRUCT_PTR result_tp, tp2;
  entry_debug("factor");

  /* first factor */
  result_tp = simple_factor();

  op = token;
  if (op == STARSTAR) {
    result_tp = base_type(result_tp);
    get_token();
    tp2 = base_type(simple_factor());
    if (undef_types(result_tp, tp2)) {
      set_undef(result_tp);
    }
    else if (integer_operands(result_tp, tp2)) result_tp = integer_typep;
    else if (real_operands(result_tp, tp2)) result_tp = real_typep;
    else {
      error(INCOMPATIBLE_TYPES);
      result_tp = &dummy_type;
    }
  }

  exit_debug("factor");
  return(result_tp);
}                                                            /* end FACTOR */
/***************************************************************************/



/***************************************************************************/
/* simple_factor() Process a simple factor                                 */
/*                     a variable, a number, NOT factor, a                 */
/*                     parenthesized expression, or an interval expression */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR simple_factor()
{
  TYPE_STRUCT_PTR tp;
  TYPE_STRUCT_PTR tp1, tp2;
  TOKEN_CODE op;
  entry_debug("simple_factor");

  if (token_in(constant_list)) {             /* language defined constant */
    switch (token) {
      case XFALSE : {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(false_idp);
        tp = logical_typep;
        break;
      }
      case XTRUE : {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(true_idp);
        tp = logical_typep;
        break;
      }
      case XUNKNOWN : {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(unknown_idp);
        tp = logical_typep;
        break;
      }
      case XCONST_E : {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(conste_idp);
        tp = real_typep;
        break;
      }
      case XPI : {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(pi_idp);
        tp = real_typep;
        break;
      }
      case QUERY_CHAR : {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(undef_idp);
        set_undef(tp);
        break;
      }
      case THE_DAY: {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(day_idp);
        tp = integer_typep;
        break;
      }
      case THE_MONTH: {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(month_idp);
        tp = integer_typep;
        break;
      }
      case THE_YEAR: {
        change_crunched_token(IDENTIFIER);
        crunch_symtab_node_ptr(year_idp);
        tp = integer_typep;
        break;
      }
      default : {
        error(UNIMPLEMENTED_CONSTANT);
        tp = &dummy_type;
        break;
      }
    }  /* end switch */
    get_token();
    exit_debug("factor at defined constants");
    return(tp);
  }  /* end of language defined constants */

  switch (token) {
    case IDENTIFIER: {  
      SYMTAB_NODE_PTR idp;

      search_and_find_all_symtab(idp);
      switch (idp->defn.key) {
        case FUNC_DEFN: {
          crunch_symtab_node_ptr(idp);
          get_token();
          tp = routine_call(idp,TRUE);
          break;
        }
        case PROC_DEFN: {
          error(INVALID_IDENTIFIER_USAGE);
          get_token();
          actual_parm_list(idp,FALSE);
          tp = &dummy_type;
          break;
        }
        case CONST_DEFN: {
          crunch_symtab_node_ptr(idp);
          get_token();
          tp = idp->typep;
          break;
        }
        default: {
          tp = variable(idp, EXPR_USE);
          break;
        }
      } /* end switch */
      break;
    }
    case NUMBER_LITERAL: {
      SYMTAB_NODE_PTR np;

      np = search_symtab(token_string, symtab_display[1]);
      if (np == NULL) np = enter_symtab(token_string, symtab_display[1]);

      if (literal.type == INTEGER_LIT ) {
        tp = np->typep = integer_typep;
        np->defn.info.constant.value.integer = literal.value.integer;
      }
      else {         /* a real literal */
        tp = np->typep = real_typep;
        np->defn.info.constant.value.real = literal.value.real;
      }
      crunch_symtab_node_ptr(np);
      get_token();
      break;
    }
    case STRING_LITERAL: {
      SYMTAB_NODE_PTR np;
      int length = strlen(literal.value.string);

      np = search_symtab(token_string, symtab_display[1]);
      if (np == NULL) np = enter_symtab(token_string, symtab_display[1]);
      np->typep = tp = make_string_typep(length);
      np->info = alloc_bytes(length + 1);
      strcpy(np->info, literal.value.string);
      crunch_symtab_node_ptr(np);
      get_token();
      break;
    }
    case NOT: {
      get_token();
      tp = simple_factor();
      break;
    }
    case LPAREN: {
      get_token();
      tp = expression();

      if_token_get_else_error(RPAREN, MISSING_RPAREN);
      break;
    }
    case LBRACE: {   /* interval expression {expr op var op expr} */
      get_token();
      tp1 = simple_expression();
      op = token;
      if (op != LT && op != LE) {
        error(EXPECTED_INTERVAL_OP);
      }
      get_token();
      tp = simple_expression();
      check_rel_op_types(tp1, tp);
      op = token;
      if (op != LT && op != LE) {
        error(EXPECTED_INTERVAL_OP);
      }
      get_token();
      tp2 = simple_expression();
      check_rel_op_types(tp, tp2);
      if_token_get_else_error(RBRACE, MISSING_RBRACE);
      tp = logical_typep;
      break;
    }
    default: {
      error(INVALID_EXPRESSION);
      tp = &dummy_type;
      break;
    }
  } /* end switch */

  exit_debug("simple_factor");
  return(tp);

}                                                     /* end SIMPLE_FACTOR */
/***************************************************************************/



/***************************************************************************/
/* variable(var_idp, use) Process a variable                               */
/*                     consisting of                                       */
/*                     a simple id, an array id with subscripts,           */
/*                     or an entity id with attributes                     */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR variable(var_idp, use)
SYMTAB_NODE_PTR var_idp;                  /* var id */
USE use;                                  /* how variable is used */
{
  TYPE_STRUCT_PTR tp = var_idp->typep;
  DEFN_KEY defn_key = var_idp->defn.key;
  TYPE_STRUCT_PTR array_subscript_list();
  TYPE_STRUCT_PTR entity_attr();
  entry_debug("variable");

  crunch_symtab_node_ptr(var_idp);

  /* check the definition of the variable */
  switch (defn_key) {
    case VAR_DEFN:
    case VALPARM_DEFN:
    case VARPARM_DEFN:
    case FUNC_DEFN:
    case UNDEFINED: {
      break;
    }
    default: {
      tp = &dummy_type;
      error(INVALID_IDENTIFIER_USAGE);
      break;
    }
  } /* end switch */

  get_token();

  /* there must not be a parameter list, but parse for one anyway */
  if (token == LPAREN) {
    error(UNEXPECTED_TOKEN);
    actual_parm_list(var_idp, FALSE);
    exit_debug("variable (unexpected parm list)");
    return(tp);
  }

  /* subscripts or fields? */
  while ((token == LBRACKET) || (token == PERIOD)) {
    if (token == PERIOD) {
      tp = entity_attr(tp);
    }
    else {
      if (var_idp->typep == string_typep || 
          var_idp->typep->form == STRING_FORM) { /* substring op */
        tp = index_list(tp);
      }
      else {                                     /* aggregate index */
        tp = array_subscript_list(tp); 
      }
    }
  }

  exit_debug("variable");
  return(tp);

}                                                          /* end variable */
/***************************************************************************/



/***************************************************************************/
/* index_list(tp) Process a (pair of) subscript v                          */
/*                     '[' <int_expr> [ ':' <int_expr> ] ']'               */
/* return a pointer to the type structure                                  */
/*  at entry: token is opening [                                           */
/*  at exit: token is after closing ]                                      */

TYPE_STRUCT_PTR index_list(tp)
TYPE_STRUCT_PTR tp;                 /* type of var just before opening [ */
{
  TYPE_STRUCT_PTR ss1_tp, ss2_tp;
  entry_debug("index_list (l2xiexpr.c)");

            /* check on var type */
  if (tp == string_typep || tp->form == STRING_FORM) {  /* OK */
    ;
  }
  else {
    error(UNEXPECTED_TOKEN);
  }

     /* do first expression */
  get_token();
  ss1_tp = expression();
  if (ss1_tp != integer_typep) error(INCOMPATIBLE_TYPES);

  if (token == COLON) {           /* do second expression */
    get_token();
    ss2_tp = expression();
    if (ss2_tp != integer_typep) error(INCOMPATIBLE_TYPES);
  }

  if_token_get_else_error(RBRACKET, MISSING_RBRACKET);
  exit_debug("index_list");
  return(tp);

}                                                        /* end INDEX_LIST */
/***************************************************************************/


/***************************************************************************/
/* array_subscript_list(tp) Process a list of subscripts                   */
/*                     [ <expr>, <expr>, ... ]                             */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR array_subscript_list(tp)
TYPE_STRUCT_PTR tp;
{
  TYPE_STRUCT_PTR index_tp, elmt_tp, ss_tp;

  /* loop to process the list */
  do {
    if (tp->form == ARRAY_FORM) {
      index_tp = tp->info.array.index_typep;
      elmt_tp = tp->info.array.elmt_typep;
      get_token();
      ss_tp = expression();
     
      /* check assignment compatibility */
      if (!is_assign_type_compatible(index_tp, ss_tp)) error(INCOMPATIBLE_TYPES);
      tp = elmt_tp;
    }
    else if (tp->form == BAG_FORM ||
             tp->form == LIST_FORM ||
             tp->form == SET_FORM) {
      index_tp = tp->info.dynagg.index_typep;
      elmt_tp = tp->info.dynagg.elmt_typep;
      get_token();
      ss_tp = expression();
     
      /* check assignment compatibility */
      if (!is_assign_type_compatible(index_tp, ss_tp)) error(INCOMPATIBLE_TYPES);
      tp = elmt_tp;
    }
    else {
      error(TOO_MANY_SUBSCRIPTS);
      while ((token != RBRACKET) && (!token_in(statement_end_list))) {
        get_token();
      }
    }
  } while (token == COMMA); /* end do */

  if_token_get_else_error(RBRACKET, MISSING_RBRACKET);
  return(tp);

}                                              /* end array_subscript_list */
/***************************************************************************/


/***************************************************************************/
/* entity_attr(tp) Process an entity attribute                             */
/*                     .  <attr-variable>                                  */
/* return a pointer to the type structure                                  */

TYPE_STRUCT_PTR entity_attr(tp)
TYPE_STRUCT_PTR tp;
{
  SYMTAB_NODE_PTR attr_idp;

  get_token();

  if ((token == IDENTIFIER) && (tp->form == ENTITY_FORM)) {
    search_this_symtab(attr_idp, tp->info.entity.attribute_symtab);

    crunch_symtab_node_ptr(attr_idp);
    get_token();
    if (attr_idp != NULL) return(attr_idp->typep);
    else {
      error(INVALID_ATTRIBUTE);
      return(&dummy_type);
    }
  }
  else {
    get_token();
    error(INVALID_ATTRIBUTE);
    return(&dummy_type);
  }

}                                                       /* end entity_attr */
/***************************************************************************/




/* TYPE COMPATIBILITY */


/***************************************************************************/
/* check_rel_op_types(tp1, tp2) Check operand types of a relational         */
/*                             operator                                    */

check_rel_op_types(tp1, tp2)
TYPE_STRUCT_PTR tp1;
TYPE_STRUCT_PTR tp2;
{

  /* identical scalar or enumeration types */
  if ((tp1 == tp2) && 
      ((tp1->form == SCALAR_FORM) || (tp1->form == ENUM_FORM))) {
    return;
  }

  /* one integer and one real */
  if (((tp1 == integer_typep) && (tp2 == real_typep)) ||
      ((tp2 == integer_typep) && (tp1 == real_typep))) {
    return;
  }

  /* two arbitrary strings */
  if (string_operands(tp1, tp2)) {
    return;
  }

  /* for the IN operator */
  /* tp2 is a dynamic aggregate, tp1 is the elmt type */
  if (is_dynagg(tp2)) {
    if (tp1 == tp2->info.dynagg.elmt_typep) {
      return;
    }
  }

  error(INCOMPATIBLE_TYPES);
}                                                /* end check_rel_op_types */
/***************************************************************************/


/***************************************************************************/
/* is_assign_type_compatible(tp1, tp2) Check if a value of type tp2        */
/*                               can be assigned to a variable of type tp1 */
/*                            (i.e. tp1 := tp2)                            */
/* return TRUE if types assignment compatible, else FALSE                  */

BOOLEAN is_assign_type_compatible(tp1, tp2)
TYPE_STRUCT_PTR tp1;
TYPE_STRUCT_PTR tp2;
{

  tp1 = base_type(tp1);
  tp2 = base_type(tp2);

  if (tp1 == tp2) return(TRUE);
  if (is_undef(tp2)) {
    compile_warning(ASSIGN_TO_UNDEF);
    return(TRUE);
  }

  /* real := integer */
  if ((tp1 == real_typep) && (tp2 == integer_typep)) return(TRUE);

  if (string_operands(tp1, tp2)) return(TRUE);

  /* incompatible */
  return(FALSE);

}                                         /* end is_assign_type_compatible */
/***************************************************************************/


/***************************************************************************/
/* base_type(tp)  Return the range type of a subrange type                 */

TYPE_STRUCT_PTR base_type(tp)
TYPE_STRUCT_PTR tp;
{
  return((tp->form == SUBRANGE_FORM)
                   ? tp->info.subrange.range_typep
                   : tp);
}                                                         /* end base_type */
/***************************************************************************/