/* l2xistd.c  LTX2X interpreter  Parsing for calls to standard 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"


#define DEFAULT_NUMERIC_FIELD_WIDTH 10
#define DEFAULT_PRECISION 2

/* EXTERNALS */

extern TOKEN_CODE token;
extern char word_string[];
extern SYMTAB_NODE_PTR symtab_display[];
extern int level;
extern TOKEN_CODE follow_parm_list[];
extern TOKEN_CODE statement_end_list[];

/* FORWARDS */

TYPE_STRUCT_PTR eof_eoln(), abs_sqr(), arctan_cos_exp_ln_sin_sqrt(),
                pred_succ(), odd(), ord(), round_trunc();
TYPE_STRUCT_PTR atan(), exists_etc(), nvl_etc();
TYPE_STRUCT_PTR rexpr_etc(), hibound_etc(), length_etc();

/***************************************************************************/
/* standard_routine_call (rtn_idp) Process call to standard function       */
/* return pointer to type structure of the call                            */

TYPE_STRUCT_PTR standard_routine_call(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;           /* routine id */
{

  switch (rtn_idp->defn.info.routine.key) {
    case READ:
    case READLN: {
      read_readln(rtn_idp);
      return(NULL);
    }
    case WRITE:
    case WRITELN: {
      write_writeln(rtn_idp);
      return(NULL);
    }
    case EOFF: 
    case EOLN: {
      return(eof_eoln(rtn_idp));
    }
    case ABS:          /* real or int arg -> real or int */
              {
      return(abs_sqr());
    }
    case COS:          /* real or int arg -> real */ 
    case EXP: 
    case SIN: 
    case SQRT: 
    case XACOS: 
    case XASIN:
    case XLOG:
    case XLOG2:
    case XLOG10:
    case XTAN: {
      return(arctan_cos_exp_ln_sin_sqrt());
    }
    case XATAN: {  
      return(atan());
    }
    case ODD:  {       /* int arg -> boolean */
      return(odd());
    }
    case ROUND:        /* real arg -> int */
    case TRUNC: {
      return(round_trunc());
    }
    case L2XPRINT:
    case L2XPRINTLN: {               /* extra for ltx2x */
      print_println(rtn_idp);
      return(NULL);
    }
    case L2XSYSTEM: {                /* extra for ltx2x */
      system_etc(rtn_idp);
      return(NULL);
    }
    case L2XREXPR: {                 /* extra for ltx2x two strings -> boolean */
      return(rexpr_etc());
    }
    case XEXISTS: {    /* any arg -> boolean */
      return(exists_etc());
    }
    case XNVL: {       /* two args -> one of these */
      return(nvl_etc());
    }
    case XHIBOUND:         /* agg arg -> int */
    case XHIINDEX:
    case XLOBOUND:
    case XLOINDEX:
    case XSIZEOF: {
      return(hibound_etc());
    }
    case XLENGTH: {        /* string arg -> int */
      return(length_etc());
    }
    case XINSERT:
    case XREMOVE: {
      insert_etc(rtn_idp);
      return(NULL);
    }
    case XBLENGTH:                 /* unimplemented EXPRESS functions */
    case XFORMAT:
    case XROLESOF:
    case XTYPEOF:
    case XUSEDIN:
    case XVALUE:
    case XVALUE_IN:
    case XVALUE_UNIQUE: {
      error(UNIMPLEMENTED_FEATURE);
      return(NULL);
    }
    default : {    /* should not be here */
      error(UNEXPECTED_TOKEN);
      return(NULL);
    }
  }  /* end switch */
}                                             /* end standard_routine_call */
/***************************************************************************/


/***************************************************************************/
/* read_readln(rtn_idp) Process call to read or readln                     */

read_readln(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;
{
  TYPE_STRUCT_PTR actual_parm_tp;      /* actual param type */

  /* parameters are optional for readln */
  if (token == LPAREN) {
    do {
      get_token();
      /* actuals should be variables, but parse anyway */
      if (token == IDENTIFIER) {
        SYMTAB_NODE_PTR idp;
        search_and_find_all_symtab(idp);
        actual_parm_tp = base_type(variable(idp, VARPARM_USE));
/*        if (actual_parm_tp->form != SCALAR_FORM) error(INCOMPATIBLE_TYPES); */
        if (actual_parm_tp != integer_typep &&
            actual_parm_tp != real_typep &&
            actual_parm_tp != logical_typep &&
            actual_parm_tp != string_typep) {
          error(INCOMPATIBLE_TYPES);
        }
      }
      else {
        actual_parm_tp = expression();
        error(INVALID_VAR_PARM);
      }
     /* 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); 
  } /* end if */
  else {
    if (rtn_idp->defn.info.routine.key == READ) error(WRONG_NUMBER_OF_PARMS);
  }

}                                                       /* end read_readln */
/***************************************************************************/



/***************************************************************************/
/* write_writeln(rtn_idp) Process call to write or writeln                 */
/*                        Each actual parameter can be:                    */
/*                        <expr> or                                        */
/*                        <expr> : <expr> or                               */
/*                        <expr> : <expr> : <expr>                         */

write_writeln(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;
{
  TYPE_STRUCT_PTR actual_parm_tp;             /* actual parm type */
  TYPE_STRUCT_PTR field_width_tp, precision_tp;

  /* params are optional for writeln */
  if (token == LPAREN) {
    do {
      get_token();
      actual_parm_tp = base_type(expression());

      if ((actual_parm_tp->form != SCALAR_FORM) &&
          (actual_parm_tp != logical_typep) &&
          (actual_parm_tp->form != STRING_FORM) &&
          (actual_parm_tp->form != ENUM_FORM))
        error(INVALID_EXPRESSION);

      /* optional field width expression */
      if (token == COLON) {
        get_token();
        field_width_tp = base_type(expression());
        if (field_width_tp != integer_typep) error(INCOMPATIBLE_TYPES);

        /* optional precision spec */
        if (token == COLON) {
          get_token();
          precision_tp = base_type(expression());
          if (precision_tp != integer_typep) error(INCOMPATIBLE_TYPES);
       
        } /* end colon if */
      } /* end colon if */
      /* 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);
  } /* end if */
  else {
    if (rtn_idp->defn.info.routine.key == WRITE) error(WRONG_NUMBER_OF_PARMS);
  }

}                                                     /* end write_writeln */
/***************************************************************************/



/***************************************************************************/
/* print_println(rtn_idp) Process call to print or println                 */
/*                        Each actual parameter can be:                    */
/*                        <expr> or                                        */
/*                        <expr> : <expr> or                               */
/*                        <expr> : <expr> : <expr>                         */
/*    At this point, identical to write_writeln                            */

print_println(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;
{
  TYPE_STRUCT_PTR actual_parm_tp;             /* actual parm type */
  TYPE_STRUCT_PTR field_width_tp, precision_tp;

  /* params are optional for println */
  if (token == LPAREN) {
    do {
      get_token();
      actual_parm_tp = base_type(expression());

      if ((actual_parm_tp->form != SCALAR_FORM) &&
          (actual_parm_tp != logical_typep) &&
          (actual_parm_tp->form != STRING_FORM) &&
          (actual_parm_tp->form != ENUM_FORM))
        error(INVALID_EXPRESSION);

      /* optional field width expression */
      if (token == COLON) {
        get_token();
        field_width_tp = base_type(expression());
        if (field_width_tp != integer_typep) error(INCOMPATIBLE_TYPES);

        /* optional precision spec */
        if (token == COLON) {
          get_token();
          precision_tp = base_type(expression());
          if (precision_tp != integer_typep) error(INCOMPATIBLE_TYPES);
       
        } /* end colon if */
      } /* end colon if */
      /* 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);
  } /* end if */
  else {
    if (rtn_idp->defn.info.routine.key == WRITE) error(WRONG_NUMBER_OF_PARMS);
  }

}                                                     /* end print_println */
/***************************************************************************/



/***************************************************************************/
/* eof_eoln(rtn_idp)  Process call to eof or eoln. No parameters.          */
/* return boolean result.                                                  */

TYPE_STRUCT_PTR eof_eoln(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;
{
  TYPE_STRUCT_PTR result_tp = logical_typep;

  if (token == LPAREN) {
    error(WRONG_NUMBER_OF_PARMS);
    actual_parm_list(rtn_idp, FALSE);
  }
  return(result_tp);
}                                                          /* end eof_eoln */
/***************************************************************************/



/***************************************************************************/
/* system_etc()         Process call to system, etc                        */
/*                      fun('string')                                      */
/*              One string parameter, no return value                      */
/*    at entry, token is `fun'                                             */
/*    at exit, token is after closing )                                    */

system_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                 /* routine id */
{
  TYPE_STRUCT_PTR actual_parm_tp;         /* actual parm type */

  if (token == LPAREN) {
    get_token();     
    actual_parm_tp = base_type(expression());
    if (actual_parm_tp != string_typep &&
          (actual_parm_tp->form != STRING_FORM)) {
      error(INVALID_EXPRESSION);
    }
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else {
    error(WRONG_NUMBER_OF_PARMS);
  }

  return;
}                                                        /* end SYSTEM_ETC */
/***************************************************************************/



/***************************************************************************/
/* length_etc()         Process call to length, etc                        */
/*                      fun('string')                                      */
/*              One string parameter, integer return value                 */
/*    at entry, token is `fun'                                             */
/*    at exit, token is after closing )                                    */

TYPE_STRUCT_PTR length_etc()
{
  TYPE_STRUCT_PTR actual_parm_tp;         /* actual parm type */
  TYPE_STRUCT_PTR result_tp = integer_typep;  /* result type */
  if (token == LPAREN) {
    get_token();     
    actual_parm_tp = base_type(expression());
    if (actual_parm_tp != string_typep &&
          (actual_parm_tp->form != STRING_FORM)) {
      error(INVALID_EXPRESSION);
    }
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else {
    error(WRONG_NUMBER_OF_PARMS);
  }

  return(result_tp);
}                                                        /* end LENGTH_ETC */
/***************************************************************************/



/***************************************************************************/
/* hibound_etc()         Process call to hibound, etc                      */
/*                      fun(agg)                                           */
/*              One aggregate parameter, integer return value              */
/*    at entry, token is `fun'                                             */
/*    at exit, token is after closing )                                    */

TYPE_STRUCT_PTR hibound_etc()
{
  TYPE_STRUCT_PTR actual_parm_tp;         /* actual parm type */
  TYPE_STRUCT_PTR result_tp = integer_typep;  /* result type */
  if (token == LPAREN) {
    get_token();     
    actual_parm_tp = base_type(expression());
    if ((actual_parm_tp->form != ARRAY_FORM) &&
        (actual_parm_tp->form != BAG_FORM) &&
        (actual_parm_tp->form != LIST_FORM) &&
        (actual_parm_tp->form != SET_FORM) ) {
      error(INVALID_EXPRESSION);
    }
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else {
    error(WRONG_NUMBER_OF_PARMS);
  }

  return(result_tp);
}                                                       /* end HIBOUND_ETC */
/***************************************************************************/



/***************************************************************************/
/* rexpr_etc()         Process call to rexpr, etc                          */
/*                      fun('string', 'string')                            */
/*              Two string parameters, boolean return value                */
/*    at entry, token is `fun'                                             */
/*    at exit, token is after closing )                                    */

TYPE_STRUCT_PTR rexpr_etc()
{
  TYPE_STRUCT_PTR actual_parm_tp;         /* actual parm type */
  TYPE_STRUCT_PTR result_tp = logical_typep; /* result type */

  if (token == LPAREN) {
    get_token();     
    actual_parm_tp = base_type(expression());
    if (actual_parm_tp != string_typep && 
        actual_parm_tp->form != STRING_FORM) {
      error(INVALID_EXPRESSION);
    }
    if_token_get_else_error(COMMA, MISSING_COMMA);
    actual_parm_tp = base_type(expression());
    if (actual_parm_tp != string_typep && 
        actual_parm_tp->form != STRING_FORM) {
      error(INVALID_EXPRESSION);
    }
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else {
    error(WRONG_NUMBER_OF_PARMS);
  }

  return(result_tp);
}                                                         /* end REXPR_ETC */
/***************************************************************************/



/***************************************************************************/
/* exists_etc   Process call to exists, etc                                */
/*              fun(any) -> boolean                                        */
/*          any type parm -> boolean result                                */

TYPE_STRUCT_PTR exists_etc()
{
  TYPE_STRUCT_PTR parm_tp;                   /* actual param type */
  TYPE_STRUCT_PTR result_tp = logical_typep; /* result type */

  if (token == LPAREN) {
    get_token();
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

  return(result_tp);
}                                                        /* end EXISTS_ETC */
/***************************************************************************/



/***************************************************************************/
/* nvl_etc    Process NVL, etc                                             */
/*            fun(p1, p2) -> p1 or p2                                      */
/*            Two args, any type, returns one of them                      */

TYPE_STRUCT_PTR nvl_etc()
{
  TYPE_STRUCT_PTR parm_tp;                 /* actual param type */

  if (token == LPAREN) {
    get_token();
    parm_tp = base_type(expression());

    if_token_get_else_error(COMMA, MISSING_COMMA);
        /* PERHAPS SHOULD CHECK FOR ASSIGNMENT COMPATIBILITY */
/*
*    if (parm_tp != base_type(expression()) ) {
*      error(INCOMPATIBLE_TYPES);
*    }
*/
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

  return(parm_tp);
}                                                           /* end NVL_ETC */
/***************************************************************************/



/***************************************************************************/
/* abs_sqr  Process call to abs or sqr.                                    */
/*          integer parm -> integer result                                 */
/*          real parm -> real result                                       */

TYPE_STRUCT_PTR abs_sqr()
{
  TYPE_STRUCT_PTR parm_tp;                 /* actual param type */
  TYPE_STRUCT_PTR result_tp;               /* result type */

  if (token == LPAREN) {
    get_token();
    parm_tp = base_type(expression());

    if ((parm_tp != integer_typep) && (parm_tp != real_typep)) {
      error(INCOMPATIBLE_TYPES);
      result_tp = real_typep;
    }
    else result_tp = parm_tp;

    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

  return(result_tp);
}                                                           /* end abs_sqr */
/***************************************************************************/



/***************************************************************************/
/* arctan_cos_exp_ln_sin_sqrt  Process call to these                       */
/*          integer parm -> real result                                    */
/*          real parm -> real result                                       */

TYPE_STRUCT_PTR arctan_cos_exp_ln_sin_sqrt()
{
  TYPE_STRUCT_PTR parm_tp;                 /* actual param type */

  if (token == LPAREN) {
    get_token();
    parm_tp = base_type(expression());

    if ((parm_tp != integer_typep) && (parm_tp != real_typep)) {
      error(INCOMPATIBLE_TYPES);
    }
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

  return(real_typep);
}                                        /* end arctan_cos_exp_ln_sin_sqrt */
/***************************************************************************/



/***************************************************************************/
/* atan  Process call to these                                             */
/*              fun(p1, p2)                                                */
/*          integer parm -> real result                                    */
/*          real parm -> real result                                       */

TYPE_STRUCT_PTR atan()
{
  TYPE_STRUCT_PTR parm_tp;                 /* actual param type */

  if (token == LPAREN) {
    get_token();
    parm_tp = base_type(expression());

    if ((parm_tp != integer_typep) && (parm_tp != real_typep)) {
      error(INCOMPATIBLE_TYPES);
    }
    if_token_get_else_error(COMMA, MISSING_COMMA);
    parm_tp = base_type(expression());
    if ((parm_tp != integer_typep) && (parm_tp != real_typep)) {
      error(INCOMPATIBLE_TYPES);
    }
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

  return(real_typep);
}                                                              /* end ATAN */
/***************************************************************************/





/***************************************************************************/
/* odd                 Process call to odd.                                */
/*          integer parm -> boolean result                                 */

TYPE_STRUCT_PTR odd()
{
  TYPE_STRUCT_PTR parm_tp;                 /* actual param type */
  TYPE_STRUCT_PTR result_tp = logical_typep;

  if (token == LPAREN) {
    get_token();
    parm_tp = base_type(expression());

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

    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

  return(logical_typep);
}                                                               /* end odd */
/***************************************************************************/



/***************************************************************************/
/* round_trunc  Process call to round or trunc.                            */
/*          real parm -> integer result                                    */

TYPE_STRUCT_PTR round_trunc()
{
  TYPE_STRUCT_PTR parm_tp;                 /* actual param type */

  if (token == LPAREN) {
    get_token();
    parm_tp = base_type(expression());

    if (parm_tp != real_typep) {
      error(INCOMPATIBLE_TYPES);
    }

    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

  return(integer_typep);
}                                                       /* end round_trunc */
/***************************************************************************/



/***************************************************************************/
/* insert_etc   Process a call to INSERT, etc                              */
/*              list procedures                                            */
/*       INSERT(LIST, GENERIC, INTEGER)                                    */
/*       REMOVE(LIST, INTEGER)                                             */

insert_etc(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;
{
  TYPE_STRUCT_PTR parm_tp;               /* actual parm type */

  if (token == LPAREN) {
    get_token();
    parm_tp = base_type(expression());
    if (parm_tp->form != LIST_FORM) {
      error(INCOMPATIBLE_TYPES);
    }
    if_token_get_else_error(COMMA, MISSING_COMMA);
    if (rtn_idp->defn.info.routine.key == XINSERT) {
      expression();
      if_token_get_else_error(COMMA, MISSING_COMMA);
    }
    parm_tp = base_type(expression());
    if (parm_tp != integer_typep) {
      error(INCOMPATIBLE_TYPES);
    }
    if_token_get_else_error(RPAREN, MISSING_RPAREN);
  }
  else error(WRONG_NUMBER_OF_PARMS);

}                                                        /* end INSERT_ETC */
/***************************************************************************/