Initial commit

1 files changed, 1503 insertions, 0 deletions

diff --git a/pkg/ecl/gram.c b/pkg/ecl/gram.c
new file mode 100644
index 00000000..1bc506dd
--- /dev/null
+++ b/pkg/ecl/gram.c
@@ -0,0 +1,1503 @@
+/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+ */
+
+#define import_spp
+#define import_libc
+#define import_stdio
+#include <iraf.h>
+
+#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<dim; d++) {
+		amin = *(off + 2*d);
+		amax = amin + *(len + 2*d) - 1;
+
+		if (amin != 1)
+		    sprintf (ibuf, "%d:%d", amin, amax);
+		else
+		    sprintf (ibuf, "%d", amax);
+	
+		strcat (buf, ibuf);
+		if (d+1<dim)
+		    strcat (buf, ",");
+
+		if (strlen (buf) > 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");
+}