summaryrefslogtreecommitdiff
path: root/support/ltx2x/l2xistd.c
diff options
context:
space:
mode:
Diffstat (limited to 'support/ltx2x/l2xistd.c')
-rw-r--r--support/ltx2x/l2xistd.c667
1 files changed, 667 insertions, 0 deletions
diff --git a/support/ltx2x/l2xistd.c b/support/ltx2x/l2xistd.c
new file mode 100644
index 0000000000..49c3dbc9cb
--- /dev/null
+++ b/support/ltx2x/l2xistd.c
@@ -0,0 +1,667 @@
+/* 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 */
+/***************************************************************************/
+
+
+
+
+
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 15:14:55 +0000