/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. */ #define import_spp #define import_libc #define import_stdio #include #include "config.h" #include "clmodes.h" #include "operand.h" #include "mem.h" #include "grammar.h" #include "opcodes.h" #include "param.h" #include "task.h" #include "errs.h" #include "construct.h" #include "ytab.h" /* pick up yacc token #defines */ #include "proto.h" /* * GRAM -- These routines are used by the parser and lex files grammar.y and * grammar.l. Also we handle other things that are very visible to the user * here too, such as cracking and running the intrinsic functions. * * We define our own yywrap() here to set yeof. * TODO: clean up having to keep some of the strings upper, some lower case. */ #define SZ_PIPEFILENAME (6+4+5) /* uparm$ // pipe // XXXXX */ #define MAX_PIPECODE 30000 /* modulus for pipecodes */ #define TRIM_LEFT 1 #define TRIM_RIGHT 2 int yeof; /* set by yywrap when it sees eof. */ extern int yylval; /* declared in y.tab.c */ extern int cldebug; extern int inarglist; /* set by parser when in argument list */ extern int parenlevel; /* nesting level of parens */ extern int get_nscanval(); extern int do_error; /* runtime error handling */ int pipetable[MAXPIPES]; /* for maintaining pipe temp files */ int nextpipe = 0; char *truestr = "yes"; /* true constant as it appears in ASCII */ char *falsestr = "no"; /* false " */ char *nullstr = ""; char *undefval = ""; /* used in nextfield(), pvaldefined() */ char *indefstr = "INDEF"; /* input or output for indef operands */ char *indeflc = "indef"; /* lower case version. */ char *eofstr = "EOF"; /* list file EOF or input */ char *eoflc = "eof"; /* lower case version */ char *errorstr = "error"; /* the error statement */ char *err_cmdblk; /* Pointer where error detected */ /* Numerical constants. */ #define BASE_E 2.7182818284590452353 #define FOURPI 12.566370614359172953 #define GAMMA .57721566490153286061 #define HALFPI 1.5707963267948966192 #define LN_10 2.3025850929940456840 #define LN_2 .69314718055994530942 #define LN_PI 1.1447298858494001741 #define LOG_E .43429448190325182765 #define PI 3.1415926535897932385 #define RADIAN 57.295779513082320877 #define SQRTOF2 1.4142135623730950488 #define SQRTOFPI 1.7724538509055160273 #define TWOPI 6.2831853071795864769 /* Physical constants. */ #define AU 1.49597870691e11 /* m */ #define GRAV_ACCEL 9.80665e0 /* m / sec^2 */ #define GRAV_CONST 6.673e-11 /* m^3 / kg s^2 */ #define LIGHT_YEAR 9.46053620707e15 /* m */ #define PARSEC 3.08567758135e16 /* m */ #define SPEED_OF_LIGHT 299792458.0 /* m / sec */ #define SOLAR_MASS 1.98892e30 /* kg */ char *epsilonstr = "epsilon";/* a small value; see hlib$mach.h */ char *epsilonuc = "EPSILON";/* a small value; see hlib$mach.h */ char *pistr = "PI"; /* pi */ char *twopistr = "TWOPI"; /* 2 * pi */ char *fourpistr = "FOURPI"; /* 4 * pi */ char *halfpistr = "HALFPI"; /* pi / 2 */ char *sqrtpistr = "SQRTPI"; /* sqrt (pi) */ char *sqrttwostr = "SQRT2"; /* sqrt (2) */ char *baseestr = "BASE_E"; /* e */ char *ln2str = "LN_2"; /* ln (2) */ char *ln10str = "LN_10"; /* ln (10) */ char *lnpistr = "LN_PI"; /* ln (pi) */ char *logestr = "LOG_E"; /* log (e) */ char *gammastr = "GAMMA"; /* Euler's constant */ char *radianstr = "RADIAN"; /* Radian conversion factor */ char *austr = "AU"; /* Astronomical Unit */ char *gaccelstr = "GRAV_ACCEL"; /* Gravitational Acceleration */ char *gconststr = "GRAV_CONST"; /* Gravitational Constant */ char *lystr = "LIGHT_YEAR"; /* Light Year (meters) */ char *parsecstr = "PARSEC"; /* Parsec (meters) */ char *lightstr = "SPEED_OF_LIGHT"; /* Speed of light in vacuum */ char *solmassstr = "SOLAR_MASS"; /* Solar Mass (kg) */ extern char cmdblk[SZ_CMDBLK+1]; /* current command block (in history.c) */ extern ErrCom errcom; /* Usually the following routine is provided by the yacc library but we need * our own here to signal the parser that an eof has been read. */ int yywrap (void) { yeof = 1; return (1); } /* Yacc calls this when it gets a general error. We are doing all our own * error handling so just provide an entry point and store where the * error occurred in the input stream. */ /* ARGSUSED */ void yyerror (char *s) { extern char *ip_cmdblk; if (cldebug) eprintf ("yyerror: %s, ip_cmdblk=%d %s\n", s, ip_cmdblk, ip_cmdblk); err_cmdblk = ip_cmdblk; } /* Used by the . command: repeat whatever was last compiled. * All we need to do is advance the pc up to what it would be if the * command were typed in again. See grammar.y '.' rule. */ void rerun (void) { register struct codeentry *cp; do { cp = coderef (pc); pc += cp->c_length; } while (cp->c_opcode != END); } /* CRACKIDENT -- Check given string s against keyword, set yylval, and return * token. Used from grammar when see an identifier or from "?" and "??" lex * rules. Make these look like identifiers for the special help commands. * A few that need more complicated processing are checked separately. * This is much more core efficient than putting the keywords in the * lex spec and also makes the grammer very stable. * TODO: sort keyword list and do binary search if things get slow. * (better yet use a hashed symbol table - this list is getting huge) */ #define const_str(val) (kch == *(val) && !strcmp (s, (val))) #define retconst(val) { sprintf (sb, "%g", val); \ yylval = addconst (sb, OT_REAL); \ return (Y_CONSTANT); \ } int crackident (char *s) { struct keywords { char *k_name; /* the keyword string itself. */ short k_token; /* yacc %token for the keyword */ short k_yylval; /* the value associated with token.*/ }; static struct keywords kw[] = { /* Control flow keywords. */ { "while", Y_WHILE, 0 }, { "if", Y_IF, 0 }, { "else", Y_ELSE, 0 }, { "switch", Y_SWITCH, 0 }, { "case", Y_CASE, 0 }, { "default", Y_DEFAULT, 0 }, { "break", Y_BREAK, 0 }, { "next", Y_NEXT, 0 }, { "return", Y_RETURN, 0 }, { "goto", Y_GOTO, 0 }, { "for", Y_FOR, 0 }, { "procedure", Y_PROCEDURE, 0 }, { "begin", Y_BEGIN, 0 }, { "end", Y_END, 0 }, { "iferr", Y_IFERR, 0 }, { "ifnoerr", Y_IFNOERR, 0 }, { "then", Y_THEN, 0 }, /* Parameter and variable types. */ { "int", Y_INT, 0 }, { "char", Y_STRING, 0 }, { "real", Y_REAL, 0 }, { "string", Y_STRING, 0 }, { "file", Y_FILE, 0 }, { "gcur", Y_GCUR, 0 }, { "imcur", Y_IMCUR, 0 }, { "ukey", Y_UKEY, 0 }, { "pset", Y_PSET, 0 }, { "bool", Y_BOOL, 0 }, { "struct", Y_STRUCT, 0 }, /* debugging commands. */ { "d_d", D_D, 0 }, { "d_peek", D_PEEK, 0 }, { "", 0, 0 } /* sentinel; leave it here... */ }; static struct keywords kf[] = { /* Keywords of intrinsic functions that get built into * the grammar. Most intrinsics handled by intrinsic(). */ { "scan", Y_SCAN, 0 }, { "scanf", Y_SCANF, 0 }, { "fscan", Y_FSCAN, 0 }, { "fscanf", Y_FSCANF, 0 }, /* sentinel; leave it here... */ { "", 0, 0 } }; register struct keywords *kp; XINT oldtopd; static char sch, kch; /* static storage is faster here */ char *scopy; /* non-makelower'd copy */ char sb[REALWIDTH]; oldtopd = topd; /* save topd */ scopy = comdstr(s); /* make a copy in the dictionary */ makelower (scopy); /* make it lower case for compares */ topd = oldtopd; /*restore topd but scopy still there!*/ /* Put the first character of the identifier we are searching for * in local storage to permit fast rejection of keywords without all * the overhead involved in a call to strcmp. This is an easy way * to speed things up several times w/o coding fancy data structures. */ sch = *scopy; kch = *s; /* save original string */ /* Check for and handle special-case keywords first. */ if (sch == *truestr && !strcmp (scopy, truestr)) { yylval = addconst (truestr, OT_BOOL); return (Y_CONSTANT); } else if (sch == *falsestr && !strcmp (scopy, falsestr)) { yylval = addconst (falsestr, OT_BOOL); return (Y_CONSTANT); } else if (sch == *indeflc && !strcmp (scopy, indeflc)) { yylval = addconst (scopy, OT_INT); return (Y_CONSTANT); } else if (sch == *eoflc && !strcmp (scopy, eoflc)) { yylval = addconst (CL_EOFSTR, OT_INT); return (Y_CONSTANT); } else if (sch == *errorstr && !strcmp (scopy, errorstr)) { yylval = addconst (errorstr, OT_STRING); return (Y_IDENT); /* Check for defined numerical constants. For backwards compatability * we match 'epsilon', however this particular value is deprecated by * the fp_equal() builtin and we assume CL constants will be upper * case strings. */ } else if ((sch == *epsilonstr && !strcmp (scopy, epsilonstr)) || (kch == *epsilonuc && !strcmp (s, epsilonuc))) { sprintf (sb, "%e", EPSILON); yylval = addconst (sb, OT_REAL); return (Y_CONSTANT); } else if (const_str (pistr)) { retconst (PI); } else if (const_str (twopistr)) { retconst (TWOPI); } else if (const_str (fourpistr)) { retconst (FOURPI); } else if (const_str (halfpistr)) { retconst (HALFPI); } else if (const_str (sqrtpistr)) { retconst (SQRTOFPI); } else if (const_str (sqrttwostr)) { retconst (SQRTOF2); } else if (const_str (baseestr)) { retconst (BASE_E); } else if (const_str (ln2str)) { retconst (LN_2); } else if (const_str (ln10str)) { retconst (LN_10); } else if (const_str (lnpistr)) { retconst (LN_PI); } else if (const_str (logestr)) { retconst (LOG_E); } else if (const_str (gammastr)) { retconst (GAMMA); } else if (const_str (radianstr)) { retconst (RADIAN); } else if (const_str (austr)) { retconst (AU); } else if (const_str (gaccelstr)) { retconst (GRAV_ACCEL); } else if (const_str (gconststr)) { retconst (GRAV_CONST); } else if (const_str (lystr)) { retconst (LIGHT_YEAR); } else if (const_str (parsecstr)) { retconst (PARSEC); } else if (const_str (lightstr)) { retconst (SPEED_OF_LIGHT); } else if (const_str (solmassstr)) { retconst (SOLAR_MASS); } else if (!inarglist && parenlevel == 0) { /* Search the keyword list; kewords are not recognized in argument * lists and expressions, else unquoted strings like "for" and * "file" will cause syntax errors. */ for (kp=kw; (kch = *kp->k_name); kp++) if (kch == sch) if (strcmp (scopy, kp->k_name) == 0) { yylval = kp->k_yylval; return (kp->k_token); } } else { /* Search the list of intrinsic functions. */ for (kp=kf; (kch = *kp->k_name); kp++) if (kch == sch) if (strcmp (scopy, kp->k_name) == 0) { yylval = kp->k_yylval; return (kp->k_token); } } /* S not a keyword, so it's just an identifier. */ yylval = addconst (s, OT_STRING); /* use original */ return (Y_IDENT); } /* ADDCONST -- Called during parsing to convert string s into operand of * type t and push it as an operand onto the dictionary (NOT the operand * stack). * Use dictionary because this routine is called at compile time and the * operand stack is being filled with compiled code; use dictionary as * a quiet workspace. * Convert as per makeop(). * Return dictionary index of new operand entry so that it may be used as * ((struct operand *)&dictionary[$1])->o_... in yacc specs. */ XINT addconst (char *s, int t) { register struct operand *op; XINT lasttopd; lasttopd = topd; /* could just derefenece op */ op = (struct operand *) memneed (OPSIZ); if (t == OT_STRING) { /* makeop with an OT_STRING type will reuse the * string pointer but we want to compile into the dictionary. * fortunately, it's easy because lex has already removed any * surrounding quotes. */ op->o_type = t; op->o_val.v_s = comdstr (s); } else *op = makeop (s, t); return (lasttopd); } /* LISTPARAMS -- Go through the given pfile and list out its parameters on * t_stdout. Give all non-hidden ones first, then all hidden ones in * parentheses. */ void listparams (struct pfile *pfp) { register struct param *pp; for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) if (!(pp->p_mode & M_HIDDEN)) pretty_param (pp, currentask->t_stdout); for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) if (pp->p_mode & M_HIDDEN) pretty_param (pp, currentask->t_stdout); } /* PRETTY_PARAM -- Pretty print the name, value, and prompt string of * a parameter on the output file. Put parens around the name=value string * if a hidden parameter. */ void pretty_param (struct param *pp, FILE *fp) { register char ch, *p; char buf[SZ_LINE]; int nchars, maxch; /* Get terminal dimensions from the environment. */ maxch = c_envgeti ("ttyncols") - 1; p = buf; /* name = */ if (pp->p_mode & M_HIDDEN) *p++ = '('; sprintf (p, "%0.12s = ", pp->p_name); nchars = strlen (buf); while (nchars < 16) { fputc (' ', fp); nchars++; } fputs (buf, fp); /* For arrays print the index list. */ if (pp->p_type & PT_ARRAY) { int dim, d, amin, amax; short *len, *off; char ibuf[15]; /* Maximum length of an index range should * be 13 e.g. -DDDDD:-DDDDD, plus one for the * terminator, and one for good luck. */ buf[0]= '['; buf[1] = '\0'; dim = pp->p_val.v_a->a_dim; len = &(pp->p_val.v_a->a_len); off = &(pp->p_val.v_a->a_off); for (d=0; d SZ_LINE-14) break; } strcat (buf, "]"); fputs (buf, fp); nchars += strlen (buf); } else if (!(pp->p_valo.o_type & OT_UNDEF)) { /* For scalars print the value if available. */ sprop (buf, &pp->p_valo); if ((pp->p_type & OT_BASIC) == OT_STRING && *buf != PF_INDIRECT) { fputc ('"', fp); nchars++; } fputs (buf, fp); nchars += strlen (buf); if ((pp->p_type & OT_BASIC) == OT_STRING && *buf != PF_INDIRECT) { fputc ('"', fp); nchars++; } } if (pp->p_mode & M_HIDDEN) { fputc (')', fp); nchars++; } fputc (' ', fp); nchars++; /* Advance to next field. */ while (nchars < 32) { fputc (' ', fp); nchars++; } /* prompt */ for (p=pp->p_prompt; (ch = *p++) != '\0' && nchars < maxch; nchars++) switch (ch) { case '\t': fputs ("\\t", fp); nchars++; break; case '\n': fputs ("\\n", fp); nchars++; break; case '\r': fputs ("\\r", fp); nchars++; break; case '\f': fputs ("\\f", fp); nchars++; break; default: fputc (ch, fp); } fputc ('\n', fp); } /* DUMPPARAMS -- Go through the given pfile and list out its parameters on * t_stdout in the form `task.param=value'. */ void dumpparams (struct pfile *pfp) { register struct param *pp; register FILE *fp = currentask->t_stdout; for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) if (!(pp->p_mode & M_HIDDEN)) show_param (pfp->pf_ltp, pp, fp); for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) if (pp->p_mode & M_HIDDEN) show_param (pfp->pf_ltp, pp, fp); fputs ("# EOF\n", fp); } /* SHOW_PARAM -- Print the name and value of a parameter on the output file * in the format `task.param = value'. */ void show_param (struct ltask *ltp, struct param *pp, FILE *fp) { char buf[SZ_LINE+1]; int isstr; if (ltp) fprintf (fp, "%s.%s", ltp->lt_lname, pp->p_name); else fputs (pp->p_name, fp); fputs (" = ", fp); if (!(pp->p_valo.o_type & OT_UNDEF)) { sprop (buf, &pp->p_valo); isstr = ((pp->p_type & OT_BASIC) == OT_STRING && *buf != PF_INDIRECT); if (isstr) fputc ('"', fp); fputs (buf, fp); if (isstr) fputc ('"', fp); } fputc ('\n', fp); } /* LISTHELP -- List all the (visible) ltasks in the given package in the form * of a sorted table. Used to give menus in response to ? and ?? directives. */ void listhelp (struct package *pkp, int show_invis) { static int first_col=7, maxch=20, ncol=0; register struct ltask *ltp; register char *ip, *op; char buf[4096], *list[MAXMENU]; int nltask, last_col; FILE *fp; nltask = 0; last_col = c_envgeti ("ttyncols") - 1; fp = currentask->t_stdout; op = buf; for (ltp = pkp->pk_ltp; ltp != NULL; ltp = ltp->lt_nlt) { if (ltp->lt_flags & LT_INVIS && show_invis == NO) continue; if (nltask >= MAXMENU) cl_error (E_UERR, "too many ltasks in menu"); /* Get task name. */ list[nltask++] = op; for (ip=ltp->lt_lname; (*op = *ip++); op++) ; /* If special task, add character defining task type. */ if (showtype()) { if (ltp->lt_flags & LT_DEFPCK) *op++ = '.'; else if (ltp->lt_flags & LT_PSET) *op++ = '@'; } *op++ = EOS; } /* Sort the list and output the table. */ if (nltask) { strsort (list, nltask); strtable (fp, list, nltask, first_col, last_col, maxch, ncol); } } /* LISTALLHELP -- Starting at curpack, list out all packages and their tasks * in a circular fashion until get back to curpack. this is like the search * path works. Label the current package in some way. Serves ?? directive. * TODO: this should be optimized once a nice form is settled on. */ void listallhelp (int show_invis) { register struct package *pkp; pkp = curpack; do { oprintf (" %s:\n", pkp->pk_name); listhelp (pkp, show_invis); if ((pkp = pkp->pk_npk) == NULL) pkp = reference (package, pachead); } until (pkp == curpack); } /* Break a param spec of the form [[pack.]task.]param[.field] into its * component parts. Full is a pointer to the full name. The others are the * addresses of char pointers in the calling routine that are to be set to * point to the starting address, within full, of their respective components. * All dots are set to \0 and serve as eos's for each component. * If any of the parts are absent, the respective pointer is made to point at * the trailing null of full. * The last part, field, is handled by fieldcvt(). it overwrites the first * char of the field component with the proper FN_XXX character; it is not * made into a string by adding an additional \0. * Call error() and do not return if something goes wrong. * Also used to break apart the components of full task names, [pack.]task. In * this case, the task name will be found at p and the package name at t. * Fair enough; just keep them straight when calling. * Modified 3/26/84 by TAM to use a static buffer, rather than mutilating * the input string. This caused problems when programs looped and * executed the same PUSHPARAM (or similar) more than once, e.g. * while (i<10) {= task.param; i += 1; }. * This bug is particularly manifest when accessing arrays in specified tasks, * e.g. = task.array[*] */ void breakout (char *full, char **pk, char **t, char **p, char **f) { register char *cp; register int npts, n; char *pts[3]; static char buffer[SZ_LINE+1]; strncpy (buffer, full, SZ_LINE); buffer[SZ_LINE] = '\0'; for (npts=0, cp=buffer; *cp; cp++) { if (*cp == '.') { if (*(cp+1) == EOS) { *cp = EOS; /* chop dot if last character */ break; } else { if (npts > 3) cl_error (E_UERR, "too many dots in param name `%s'", full); pts[npts++] = cp; } } } for (n=0; n < npts; n++) *(pts[n]++) = '\0'; /* null over and skip dots */ switch (npts) { case 0: /* just a simple param name without dots */ *p = buffer; *pk = *t = *f = cp; break; case 1: /* p.f or t.p depending on f */ if (fieldcvt (pts[0])) { /* p.f */ *pk = *t = cp; *p = buffer; *f = pts[0]; } else { /* t.p */ *pk = *f = cp; *t = buffer; *p = pts[0]; } break; case 2: /* t.p.f or pk.t.p depending on f */ if (fieldcvt (pts[1])) { /* t.p.f */ *pk = cp; *t = buffer; *p = pts[0]; *f = pts[1]; } else { /* pk.t.p */ *pk = buffer; *t = pts[0]; *p = pts[1]; *f = cp; } break; case 3: /* full spec */ *pk = buffer; *t = pts[0]; *p = pts[1]; *f = pts[2]; fieldcvt (*f); break; } } /* If f is a valid parameter field spec, such as p_val, then overwrite *f * with the proper FN_XXX character and return YES, else return NO. * Let the p_value field also be called p_filename, p_length and p_default. * Call error() if f starts with p_ but is not found or if ambiguous * (and abbrevs are enabled). */ int fieldcvt (register char *f) { /* Field name and corresponding code tables. */ static char *fntbl[] = { "p_name", "p_type", "p_mode", "p_value", "p_minimum", "p_maximum", "p_prompt", "p_filename", "p_length", "p_default", "p_xtype", NULL }; static char fctbl[] = { FN_NAME, FN_TYPE, FN_MODE, FN_VALUE, FN_MIN, FN_MAX, FN_PROMPT, FN_VALUE, FN_LENGTH, FN_VALUE, FN_XTYPE, NULL }; int kentry; /* Do a quick screening first. returning NO just means that f does * not even look like a field name. */ if (strncmp (f, "p_", 2)) return (NO); kentry = keyword (fntbl, f); if (kentry == KWBAD) cl_error (E_UERR, "bad param field `%s'", f); else if (kentry == KWAMBIG) cl_error (E_UERR, "ambiguous param field `%s'", f); *f = fctbl[kentry]; return (YES); } /* Search though string table, tbl, for string s. last pointer in table * should be NULL, ie, tbl[last] == NULL (not *tbl[last] == '\0'). * Settle for an abbreviation if they are enabled. Return KWBAD if s * simply not in tbl at all, KWAMBIG if abbreviations are enabled and more * than one entry in tbl would match s, else the ordinal (index) into tbl * at which s matched. */ int keyword (register char *tbl[], register char *s) { register int i; register char *kentry; int cand, len; i = 0; cand = KWBAD; len = strlen (s); if (abbrev()) { for (kentry = tbl[0]; kentry; kentry = tbl[++i]) if (!strncmp (s, kentry, len)) { if (kentry[len] == '\0') return (i); /* exact hit */ if (cand == KWBAD) cand = i; else cand = KWAMBIG; /* might still hit exact */ } } else for (kentry = tbl[0]; kentry; kentry = tbl[++i]) if (!strcmp (s, kentry)) return (i); return (cand); } /* Given a, possibly abbreviated, function name to run, look it up and * run it if found. it gets nargs arguments from the operand stack. */ void intrfunc (char *fname, int nargs) { int op_index, op; int i, n, subi[2]; int trim_side = TRIM_LEFT|TRIM_RIGHT; char *trim = " \t"; char sbuf[SZ_LINE+1]; struct operand o; static char *ifnames[] = { "abs", "access", "atan2", "cos", "defpac", "defpar", "deftask", "envget", "exp", "frac", "int", "log", "log10", "nscan", "max", "min", "mod", "nint", "osfn", "radix", "real", "sin", "sqrt", "str", "substr", "tan", "mktemp", "stridx", "strlen", "imaccess", "defvar", "strldx", "strstr", "strlwr", "strupr", "isindef", "strlstr", "not", "or", "xor", "and", "_errpop", "_errpeek", "errmsg", "errcode", "errtask", "asin", "acos", "hypot", "rad", "deg", "sign", "dsin", "dcos", "dtan", "dasin", "dacos", "trim", "triml", "trimr", "fp_equal", "datan2", "strdic", NULL }; static int optbl[] = { UNOP|OP_ABS, UNOP|OP_ACCESS, BINOP|OP_ATAN2, UNOP|OP_COS, UNOP|OP_DEFPAC, UNOP|OP_DEFPAR, UNOP|OP_DEFTASK, UNOP|OP_ENVGET, UNOP|OP_EXP, UNOP|OP_FRAC, UNOP|OP_INT, UNOP|OP_LOG, UNOP|OP_LOG10, MULTOP|OP_NSCAN, MULTOP|OP_MAX, MULTOP|OP_MIN, BINOP|OP_MOD, UNOP|OP_NINT, UNOP|OP_OSFN, BINOP|OP_RADIX, UNOP|OP_REAL, UNOP|OP_SIN, UNOP|OP_SQRT, UNOP|OP_STR, MULTOP|OP_SUBSTR, UNOP|OP_TAN, UNOP|OP_MKTEMP, BINOP|OP_STRIDX, UNOP|OP_STRLEN, UNOP|OP_IMACCESS, UNOP|OP_DEFVAR, BINOP|OP_STRLDX, BINOP|OP_STRSTR, UNOP|OP_STRLWR, UNOP|OP_STRUPR, UNOP|OP_ISINDEF, BINOP|OP_STRLSTR, UNOP|OP_BNOT, BINOP|OP_BOR, BINOP|OP_BXOR, BINOP|OP_BAND, MULTOP|OP_ERRPOP, MULTOP|OP_ERRPEEK,MULTOP|OP_ERRMSG, MULTOP|OP_ERRCODE,MULTOP|OP_ERRTASK, UNOP|OP_ASIN, UNOP|OP_ACOS, BINOP|OP_HYPOT, UNOP|OP_RAD, UNOP|OP_DEG, UNOP|OP_SIGN, UNOP|OP_DSIN, UNOP|OP_DCOS, UNOP|OP_DTAN, UNOP|OP_DASIN, UNOP|OP_DACOS, MULTOP|OP_TRIM, MULTOP|OP_TRIML, MULTOP|OP_TRIMR, BINOP|OP_FPEQUAL, BINOP|OP_DATAN2, BINOP|OP_STRDIC }; op_index = keyword (ifnames, fname); if (op_index == KWBAD) cl_error (E_UERR, "unknown function `%s'", fname); if (op_index == KWAMBIG) cl_error (E_UERR, "ambiguous function `%s'", fname); op = optbl[op_index]; /* if do this by shifting the cases and op to the right OP_BITS, this * will compile as a jump table. not worth it until it gets larger. */ switch (op & ~OP_MASK) { case UNOP: if (nargs != 1) cl_error (E_UERR, e_onearg, ifnames[op_index]); unop (op & OP_MASK); break; case BINOP: if (nargs != 2) cl_error (E_UERR, e_twoargs, ifnames[op_index]); binop (op & OP_MASK); break; case MULTOP: /* right now, this is just for min, max, nscan, and substr. * this will have to be smarted up if add other functions. */ switch (op & OP_MASK) { case OP_NSCAN: if (nargs > 0) cl_error (E_UERR, "nscan has no arguments"); o.o_type = OT_INT; o.o_val.v_i = get_nscanval(); pushop (&o); break; case OP_MAX: case OP_MIN: if (nargs <= 0) cl_error (E_UERR, e_geonearg, ifnames[op_index]); /* just leave top op if its the only one. */ if (nargs > 1) { op &= OP_MASK; /* avoid masking for every loop */ while (--nargs) binop (op); } break; case OP_SUBSTR: if (nargs != 3) cl_error (E_UERR, "substr requires 3 arguments"); for (n=1; n >= 0; n--) { /* get indices */ opcast (OT_INT); o = popop(); subi[n] = o.o_val.v_i; } opcast (OT_STRING); /* get string arg */ o = popop(); if (subi[1] >= subi[0]) { n = subi[1] - subi[0] + 1; strncpy (sbuf, &o.o_val.v_s[subi[0]-1], n); } else { /* Reverse the string. */ n = subi[0] - subi[1] + 1; for (i = 0; i < n; i++) sbuf[i] = o.o_val.v_s[subi[0]-i-1]; } sbuf[n] = '\0'; o.o_val.v_s = sbuf; pushop (&o); break; case OP_TRIML: trim_side &= ~TRIM_RIGHT; goto trim_; case OP_TRIMR: trim_side &= ~TRIM_LEFT; goto trim_; case OP_TRIM: { int o1, o2; struct operand istr; char *index(); extern void *memset(); trim_: if (nargs >= 2) { /* Get the chars to trim, otherwise its whitespace. */ opcast (OT_STRING); trim = popop().o_val.v_s; } istr = popop(); o1 = 0; o2 = strlen (istr.o_val.v_s) - 1; memset (sbuf, 0, SZ_LINE); if (trim_side & TRIM_LEFT) while (index (trim, (int)istr.o_val.v_s[o1])) o1++; if (trim_side & TRIM_RIGHT) { while (index (trim, (int)istr.o_val.v_s[o2])) o2--; istr.o_val.v_s[++o2] = '\0'; } strncpy (sbuf, &istr.o_val.v_s[o1], o2-o1+1); o.o_type = OT_STRING; o.o_val.v_s = sbuf; pushop (&o); } break; case OP_ERRPOP: if (nargs > 0) cl_error (E_UERR, "errpop has no arguments"); o.o_type = OT_INT; o.o_val.v_i = errcom.errflag; do_error = YES; errcom.nhandlers--; pushop (&o); break; case OP_ERRPEEK: if (nargs > 0) cl_error (E_UERR, "errpeek has no arguments"); o.o_type = OT_INT; o.o_val.v_i = errcom.errflag; pushop (&o); break; case OP_ERRMSG: if (nargs > 0) cl_error (E_UERR, "errmsg has no arguments"); o.o_type = OT_STRING; o.o_val.v_s = errcom.errmsg; pushop (&o); break; case OP_ERRCODE: if (nargs > 0) cl_error (E_UERR, "errcode has no arguments"); o.o_type = OT_INT; o.o_val.v_i = errcom.errcode; pushop (&o); break; case OP_ERRTASK: if (nargs > 0) cl_error (E_UERR, "errmsg has no arguments"); o.o_type = OT_STRING; o.o_val.v_s = errcom.task; pushop (&o); break; default: goto err; } break; default: err: cl_error (E_IERR, e_badsw, op, "intrfunc()"); } } /* Convert string s to sexagesimal operand, of type OT_REAL. Set opundef() * if conversion is bad somehow. Allow both h:m and h:m:s forms. */ struct operand sexa (char *s) { struct operand o; int n, sign; int hr, minutes; float sec; extern double atof(); o.o_type = OT_REAL; sign = (*s == '-') ? (s++, -1) : 1; minutes = 0; sec = 0.; n = sscanf (s, "%d:%d:%hf", &hr, &minutes, &sec); if (n < 1 || minutes < 0 || sec < 0) setopundef (&o); else o.o_val.v_r = sign * (atof (s)); /* Old evaluation producing roundoff errors. o.o_val.v_r = sign*(hr + ((float)minutes)/60. + sec/3600.); */ return (o); } /* Convert a sexagesimal real back to an index range. */ void sexa_to_index (double r, int *i1, int *i2) { int sgn; if (r < 0) { sgn = -1; r = -r; } else sgn = 1; *i1 = (int) r; /* add a little for round-off*/ *i2 = (int) (60.0e0 * (r - *i1) + .001); *i1 = sgn * *i1; } /* ADDPIPE -- Generate a new pipe file name and push it onto the pipe stack. * The strategy is to generate a unique pipefile name of the form "pipeXXX", * where XXX is an integer of 5 digits or less which is what is saved on the * pipe stack. Return a pointer to the name of the new pipefile. */ char * addpipe (void) { static int pipecode = 0; char *pipefile(); if (pipecode == 0) pipecode = c_getpid(); /* Get unique pipefile name described by a simple integer. */ do { /* * There seems to be a problem with this code in the VMS compiler. * It has been changed to a form which will work for UNIX and VMS. * * pipecode = (pipecode++ % MAX_PIPECODE); */ pipecode %= MAX_PIPECODE; /* There can be applications where multiple CL are spawned in * relatively short order so that the PIDs are close. Incrementing * the least significant digits can result in duplications. So * instead we use the lower digits as the "unique" part and * increment the higer digits. * * pipecode++; */ pipecode += 1000; } while (c_access (pipefile(pipecode),0,0) == YES); pipetable[nextpipe++] = pipecode; if (nextpipe >= MAXPIPES) cl_error (E_UERR, "Too many pipes"); return (pipefile (pipecode)); } /* GETPIPE -- Get the name of the last pipefile. */ char * getpipe (void) { char *pipefile(); if (nextpipe == 0) cl_error (E_IERR, "Pipestack underflow"); return (pipefile (pipetable[nextpipe-1])); } /* DELPIPES -- Delete N pipefiles (the actual file may not have been created * yet), and pop N pipes off the pipe stack. If N is zero, all pipefiles are * deleted and the pipestack is cleared (i.e., during error recovery). */ void delpipes (register int npipes) { register int pipe; char *pipefile(); if (npipes == 0) { while (nextpipe > 0) c_delete (pipefile (pipetable[--nextpipe])); } else { while (npipes-- > 0) { if ((pipe = --nextpipe) < 0) cl_error (E_IERR, "Pipestack underflow"); c_delete (pipefile (pipetable[pipe])); } } } /* PIPEFILE -- Given the pipecode, format a pipefile name in static internal * buffer and return pointer to pipefile name to caller. */ char * pipefile (int pipecode) { static char fname[SZ_PIPEFILENAME+1]; char *dir; char *envget(); /* Put pipefiles in 'pipes' or 'uparm' if defined, else use tmp. Do * not put pipe files in current directory or pipe commands will fail * when used in someone elses directory. */ if (envget ("pipes") != NULL) dir = "pipes$"; else if (envget ("uparm") != NULL) dir = "uparm$"; else dir = "tmp$"; sprintf (fname, "%spipe%d", dir, pipecode); return (fname); } /* LOOPINCR -- increments the loop counter and stores the destination * address for NEXT statements. It should be called just before the * destination is compiled. */ void loopincr (void) { if (nestlevel >= MAX_LOOP) cl_error (E_UERR, "Nesting too deeply."); brkdest[nestlevel] = 0; nextdest[nestlevel] = pc; nestlevel++; } /* LOOPDECR -- decrements the loop counter, and if the break destination * has been set it resolves the GOTO statement which has been made * the target of BREAK's. */ void loopdecr (void) { int p_goto; p_goto = brkdest[--nestlevel]; if (p_goto != 0) coderef(p_goto)->c_args = pc - p_goto - SZ_CE; } /* SETSWITCH -- creates the jumptable which will be used in the SWITCH. * On entry to setswitch the stack contains a pointer to the SWITCH * operand, and pointers to the first and last operands of each * CASE and DEFAULT block, i.e. the CASE and DEFAULT operands and the * GOTO operands which terminate each block. * The jumptable is created at the location of the current pc. */ void setswitch (void) { int code, jmp, njump, assgn, oper, delta; /* First get the size of the jump table by reading * backwards on the stack until we find the switch * statement. */ oper = topcs; code = coderef(stack[oper])->c_opcode; njump = 2; while (code != SWITCH) { if (code == CASE) njump++; else if (code != GOTO && code != DEFAULT) cl_error (E_UERR, "Corrupt stack in SWITCH analysis."); oper++; code = coderef(stack[oper])->c_opcode; } assgn = stack[oper]; /* To create the jump table we read the control stack * to get the addresses of each of the case statements * and the default statement. The values associated with * each case statement are stored in that operand. The * addresses are popped and transferred to the jump table. * The first location in the jump table is reserved for * the DEFAULT statement and is 0 if this is not defined. * We know the size of the jump table, so as we pop off * the goto statements at the end of the CASE blocks * we can fill in the addresses. */ jmp = pc + 1; oper = pop(); code = coderef(oper)->c_opcode; stack[pc] = 0; while (code != SWITCH) { switch (code) { case DEFAULT: stack[pc] = oper-assgn; break; case CASE: stack[jmp++] = oper-assgn; break; case GOTO: delta = pc + njump - oper - SZ_CE; coderef(oper)->c_args = delta; break; default: cl_error (E_UERR, "Corrupt stack in SWITCH analysis."); } oper = pop(); code = coderef(oper)->c_opcode; } stack[jmp] = 0; /* Fill in terminator. */ /* Put address of jump table in ASSIGN operand. */ coderef(oper)->c_args = pc - oper; pc += njump; /* Fill in address of GOTO following ASSIGN. */ oper += SZ_CE; coderef(oper)->c_args = pc - oper - SZ_CE; } /* IN_SWITCH -- determines whether a CASE or DEFAULT block is * legal at the current location. */ int in_switch (void) { int oper, code, oper2, code2, status; oper = pop(); code = coderef(oper)->c_opcode; status = 1; switch (code) { case SWITCH: push (oper); break; case GOTO: /* Previous operand must be DEFAULT or CASE. */ oper2 = pop(); code2 = coderef(oper2)->c_opcode; if (code2 != CASE && code2 != DEFAULT) status = 0; push (oper2); push (oper); break; default: status = 0; } return (status); } /* CASESET -- Fill in the values for which the current case block is to be * executed. */ void caseset (memel *parg, int ncaseval) { struct operand *o; static char *badcase = "Invalid case constant."; int ival; for (ival = 0; ival < ncaseval; ival++) { memel p = pop(); o = (struct operand *) p; if (o->o_type == OT_STRING) { /* Only chars, not full strings. */ if (*o->o_val.v_s == 0) cl_error (E_UERR, badcase); if (*(o->o_val.v_s + 1) != 0) cl_error (E_UERR, badcase); *parg++ = (int) *o->o_val.v_s; } else if (o->o_type == OT_INT) { *parg++ = o->o_val.v_i; } else cl_error (E_UERR, badcase); } } /* SETLABEL -- called when a label is first seen. It allocates * space for the label on the dictionary and also copies the * label name onto the dictionary. The label is placed at the * top of a linked list. */ struct label * setlabel (struct operand *name) { struct label *p; p = (struct label *) memneed (sizeof(struct label)); p->l_name = comdstr (name->o_val.v_s); if (label1 == NULL) p->l_next = NULL; else p->l_next = label1; label1 = p; return (p); } /* GETLABEL -- returns the label struct corresponding to the string * name, or NULL if the label has not been defined. */ struct label * getlabel (struct operand *name) { struct label *l; l = label1; while (l != NULL) { if (!strcmp (name->o_val.v_s, l->l_name)) return (l); l = l->l_next; } return (NULL); } /* SETIGOTO -- maintains the list of indirect goto's. * Note that an indirect GOTO is identical in format to a * normal GOTO. The argument, instead of pointing to the destination * is used as the list pointer. When the destination is defined, * the GOTO is taken out of the indirect list. */ void setigoto (int loc) { if (igoto1 < 0) coderef(loc)->c_args = -1; else coderef(loc)->c_args = igoto1; igoto1 = loc; } /* UNSETIGOTO -- takes a GOTO out of the indirect list so that * the target may be put in the argument. */ void unsetigoto (int loc) { int last, curr; last = NULL; curr = igoto1; while (curr != loc) { last = curr; curr = coderef(curr)->c_args; } if (last == NULL) igoto1 = coderef(curr)->c_args; else coderef(last)->c_args = coderef(curr)->c_args; } /* MAKE_IMLOOP -- compiles the meta-code for the indexing of arrays in * implicit array loops e.g. a[*,5]. */ int make_imloop (int i1, int i2) { int mode; if (n_oarr) { /* Array limits already defined, check for agreement. */ if (i1 != oarr_beg[i_oarr] || i2 != oarr_end[i_oarr]) cl_error (E_UERR, "Inconsistent open refs.\n"); mode = -1; } else { oarr_beg[i_oarr] = i1; oarr_end[i_oarr] = i2; if (i_oarr) mode = -1; else /* This is the PUSHINDEX which will * initialize the loop variables. */ mode = 0; } i_oarr++; return (mode); } /* Y_TYPEDEF -- Convert a type specifier keyword into a datatype code. */ int y_typedef (char *key) { if (strcmp (key, "string") == 0 || strcmp (key, "char") == 0) return (V_STRING); else if (strcmp (key, "int") == 0) return (V_INT); else if (strcmp (key, "real") == 0) return (V_REAL); else if (strcmp (key, "bool") == 0) return (V_BOOL); else if (strcmp (key, "file") == 0) return (V_FILE); else if (strcmp (key, "gcur") == 0) return (V_GCUR); else if (strcmp (key, "imcur") == 0) return (V_IMCUR); else if (strcmp (key, "ukey") == 0) return (V_UKEY); else if (strcmp (key, "pset") == 0) return (V_PSET); else if (strcmp (key, "struct") == 0) return (V_STRUCT); else cl_error (E_UERR, "illegal type specifier `%s'", key); /*NOTREACHED*/ return (0); } /* P_POSITION -- Called when we get a syntax error in the parser. Print * the current cmdblk and point to the offending token. */ void p_position (void) { register int i; eprintf ("**: %s ", cmdblk); /* '\n' in cmdblk */ for (i=0; i < err_cmdblk-cmdblk; i++) eprintf ("%c", ((cmdblk[i] == '\t') ? '\t' : ' ') ); eprintf ("^\n"); }