/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
 */

#include <string.h>

#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 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, '\0'
	};

	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;
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 (strchr (trim, (int)istr.o_val.v_s[o1])) o1++;
		    if (trim_side & TRIM_RIGHT) {
			while (strchr (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;

	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;

	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)
{
	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;

	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;

	/* 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 = 0;
	curr = igoto1;

	while (curr != loc) {
	    last = curr;
	    curr = coderef(curr)->c_args;
	}

	if (last == 0)
	    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");
}
