/* 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 #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: */ /* or */ /* : or */ /* : : */ 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: */ /* or */ /* : or */ /* : : */ /* 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 */ /***************************************************************************/