# line 2 "evvexpr.y"
include	<lexnum.h>
include	<ctype.h>
include	<mach.h>
include	<math.h>
include	<evvexpr.h>

.help evvexpr
.nf --------------------------------------------------------------------------
EVVEXPR.GY -- Generic XYacc source for a general vector expression evaluator.

	    o = evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags)
		evvfree (o)

Client callbacks:

	          getop (client_data, opname, out)
	           ufcn (client_data, fcn, args, nargs, out)

here "out" is the output operand returned to EVVEXPR.  Client_data is any
arbitrary integer or pointer value passed in to EVVEXPR when by the client
when the callback was registered.  "args" is an array of operand structs,
the arguments for the user function being called.  If the operand or
function call cannot be completed normally an error exit may be made (call
error) or an invalid operand may be returned (O_TYPE set to 0).  The client
should not free the "args" input operands, this will be handled by EVVEXPR.

Operand struct (lib$evvexpr.h):

	struct operand {
		int	O_TYPE			# operand type (bcsilrd)
		int	O_LEN			# operand length (0=scalar)
		int	O_FLAGS			# O_FREEVAL, O_FREEOP
		union {
			char*	O_VALC		# string
			short	O_VALS
			int	O_VALI		# int or bool
			long	O_VALL
			real	O_VALR
			double	O_VALD
			pointer	O_VALP		# vector data
		}
	}

The macro O_VALC references the string value of a TY_CHAR operand.  The
flags are O_FREEVAL and O_FREEOP, which tell EVVEXPR and EVVFREE whether or
not to free any vector operand array or the operand struct when the operand
is freed.  The client should set these flags on operands returned to EVVEXPR
if it wants EVVEXPR to free any operand storage.

Supported types are bool, char (string), and SILRD.  Bool is indicated as
TY_BOOL in the O_TYPE field of the operand struct, but is stored internally
as an integer and the value field of a boolean operand is given by O_VALI.

Operands may be either scalars or vectors.  A vector is indicated by a O_LEN
value greater than zero.  For vector operands O_VALP points to the data array.
A special case is TY_CHAR (string), in which case O_LEN is the allocated
length of the EOS-terminated string.  A string is logically a scalar value
even though it is physically stored in the operand as a character vector.

The trig functions operate upon angles in units of radians.  The intrinsic
functions RAD and DEG are available for converting between radians and
degrees.  A string can be coerced to a binary value and vice versa, using
the INT, STR, etc. intrinsic functions.

This is a generalization of the older EVEXPR routine, adding additional
datatypes, support for vector operands, and numerous minor enhancements.
.endhelp ---------------------------------------------------------------------

define	YYMAXDEPTH	64		# parser stack length
define	MAX_ARGS	17		# max args in a function call
define	yyparse		xvv_parse

# Arglist structure.
define	LEN_ARGSTRUCT	(1+MAX_ARGS+(MAX_ARGS*LEN_OPERAND))
define	A_NARGS		Memi[$1]	# number of arguments
define	A_ARGP		Memi[$1+$2]	# array of pointers to operand structs
define	A_OPS		($1+MAX_ARGS+1)	# offset to operand storage area

# Intrinsic functions.

define	LEN_STAB	300		# for symbol table
define	LEN_SBUF	256
define	LEN_INDEX	97

define	LEN_SYM		1		# symbol data
define	SYM_CODE	Memi[$1]

define	KEYWORDS	"|abs|acos|asin|atan|atan2|bool|cos|cosh|deg|double|\
			 |exp|hiv|int|len|log|log10|long|lov|max|mean|median|\
			 |min|mod|nint|rad|real|repl|stddev|shift|short|sin|\
			 |sinh|sort|sqrt|str|sum|tan|tanh|"

define	F_ABS		01		# function codes
define	F_ACOS		02
define	F_ASIN		03
define	F_ATAN		04
define	F_ATAN2		05
define	F_BOOL		06
define	F_COS		07
define	F_COSH		08
define	F_DEG		09		# radians to degrees
define	F_DOUBLE	10
	# newline	11
define	F_EXP		12
define	F_HIV		13		# high value
define	F_INT		14
define	F_LEN		15		# vector length
define	F_LOG		16
define	F_LOG10		17
define	F_LONG		18
define	F_LOV		19		# low value
define	F_MAX		20
define	F_MEAN		21
define	F_MEDIAN	22
	# newline	23
define	F_MIN		24
define	F_MOD		25
define	F_NINT		26
define	F_RAD		27		# degrees to radians
define	F_REAL		28
define	F_REPL		29		# replicate
define	F_STDDEV	30		# standard deviation
define	F_SHIFT		31
define	F_SHORT		32
define	F_SIN		33
	# newline	34
define	F_SINH		35
define	F_SORT		36		# sort
define	F_SQRT		37		# square root
define	F_STR		38
define	F_SUM		39
define	F_TAN 		40
define	F_TANH 		41

define	T_B		TY_BOOL
define	T_C		TY_CHAR
define	T_S		TY_SHORT
define	T_I		TY_INT
define	T_L		TY_LONG
define	T_R		TY_REAL
define	T_D		TY_DOUBLE


# EVVEXPR -- Evaluate a general mixed type vector expression.  Input consists
# of the expression to be evaluated (a string) and, optionally, user
# procedures for fetching external operands and executing external functions.
# Output is a pointer to an operand structure containing the computed value of
# the expression.  The output operand structure is dynamically allocated by
# EVVEXPR and must be freed by the user.
# 
# NOTE: this is not intended to be an especially efficient procedure.  Rather,
# this is a high level, easy to use procedure, intended to provide greater
# flexibility in the parameterization of applications programs.  The main
# inefficiency is that, since compilation and execution are not broken out as
# separate steps, when the routine is repeatedly called to evaluate the same
# expression with different data, all the compile time computation (parsing
# etc.) has to be repeated.

pointer procedure evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags)

char	expr[ARB]		#I expression to be evaluated
int	getop			#I user supplied get operand procedure
int	getop_data		#I client data for above function
int	ufcn			#I user supplied function call procedure
int	ufcn_data		#I client data for above function
int	flags			#I flag bits

int	junk
pointer	sp, ip
bool	debug, first_time
int	strlen(), xvv_parse()
pointer	xvv_loadsymbols()
extern	xvv_gettok()

errchk	xvv_parse, calloc
include	"evvexpr.com"
data	debug /false/
data	first_time /true/

begin
	call smark (sp)

	if (first_time) {
	    # This creates data which remains for the life of the process.
	    ev_st = xvv_loadsymbols (KEYWORDS)
	    first_time = false
	}

	# Set user function entry point addresses.
	ev_getop = getop
	ev_getop_data = getop_data
	ev_ufcn = ufcn
	ev_ufcn_data = ufcn_data
	ev_flags = flags

	# Allocate an operand struct for the expression value.
	call calloc (ev_oval, LEN_OPERAND, TY_STRUCT)

	# Make a local copy of the input string.
	call salloc (ip, strlen(expr), TY_CHAR)
	call strcpy (expr, Memc[ip], ARB)

	# Evaluate the expression.  The expression value is copied into the
	# output operand structure by XVV_PARSE, given the operand pointer
	# passed in common.  A common must be used since the standard parser
	# subroutine has a fixed calling sequence.

	junk = xvv_parse (ip, debug, xvv_gettok)
	O_FLAGS(ev_oval) = or (O_FLAGS(ev_oval), O_FREEOP)

	call sfree (sp)
	return (ev_oval)
end


# EVVFREE -- Free an operand struct such as is returned by EVVEXPR.

procedure evvfree (o)

pointer	o			# operand struct

begin
	call xvv_freeop (o)
end

define	CONSTANT		257
define	IDENTIFIER		258
define	NEWLINE		259
define	YYEOS		260
define	PLUS		261
define	MINUS		262
define	STAR		263
define	SLASH		264
define	EXPON		265
define	CONCAT		266
define	QUEST		267
define	COLON		268
define	LT		269
define	GT		270
define	LE		271
define	EQ		272
define	NE		273
define	SE		274
define	LAND		275
define	LOR		276
define	LNOT		277
define	BAND		278
define	BOR		279
define	BXOR		280
define	BNOT		281
define	AT		282
define	GE		283
define	UMINUS		284
define	yyclearin	yychar = -1
define	yyerrok		yyerrflag = 0
define	YYMOVE		call amovi (Memi[$1], Memi[$2], YYOPLEN)
define	YYERRCODE	256


# End generic preprocessor escape.



# XVV_UNOP -- Unary operation.  Perform the indicated unary operation on the
# input operand, returning the result as the output operand.

procedure xvv_unop (opcode, in, out)

int	opcode			#I operation to be performed
pointer	in			#I input operand
pointer	out			#I output operand

short	val_s
long	val_l
int	val_i, nelem
errchk	xvv_error, xvv_initop
string	s_badswitch "unop: bad switch"

begin
	nelem = O_LEN(in)

	switch (opcode) {
	case MINUS:
	    # Unary negation.
	    call xvv_initop (out, nelem, O_TYPE(in))
	    switch (O_TYPE(in)) {
	    case TY_BOOL, TY_CHAR:
		call xvv_error ("negation of a nonarithmetic operand")

	    case TY_SHORT:
		if (nelem > 0)
		    call anegs (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem)
		else
		    O_VALS(out) = -O_VALS(in)

	    case TY_INT:
		if (nelem > 0)
		    call anegi (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem)
		else
		    O_VALI(out) = -O_VALI(in)

	    case TY_LONG:
		if (nelem > 0)
		    call anegl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem)
		else
		    O_VALL(out) = -O_VALL(in)

	    case TY_REAL:
		if (nelem > 0)
		    call anegr (Memr[O_VALP(in)], Memr[O_VALP(out)], nelem)
		else
		    O_VALR(out) = -O_VALR(in)

	    case TY_DOUBLE:
		if (nelem > 0)
		    call anegd (Memd[O_VALP(in)], Memd[O_VALP(out)], nelem)
		else
		    O_VALD(out) = -O_VALD(in)

	    default:
		call xvv_error (s_badswitch)
	    }

	case LNOT:
	    # Logical NOT.

	    call xvv_initop (out, nelem, TY_BOOL)
	    switch (O_TYPE(in)) {
	    case TY_BOOL:
		if (nelem > 0)
		    call abeqki (Memi[O_VALP(in)], NO, Memi[O_VALP(out)], nelem)
		else {
		    if (O_VALI(in) == NO)
			O_VALI(out) = YES
		    else
			O_VALI(out) = NO
		}

	    case TY_SHORT:
		if (nelem > 0) {
		    val_s = NO
		    call abeqks (Mems[O_VALP(in)], val_s, Memi[O_VALP(out)],
			nelem)
		} else {
		    if (O_VALS(in) == NO)
			O_VALS(out) = YES
		    else
			O_VALS(out) = NO
		}

	    case TY_INT:
		if (nelem > 0) {
		    val_i = NO
		    call abeqki (Memi[O_VALP(in)], val_i, Memi[O_VALP(out)],
			nelem)
		} else {
		    if (O_VALI(in) == NO)
			O_VALI(out) = YES
		    else
			O_VALI(out) = NO
		}

	    case TY_LONG:
		if (nelem > 0) {
		    val_l = NO
		    call abeqkl (Meml[O_VALP(in)], val_l, Memi[O_VALP(out)],
			nelem)
		} else {
		    if (O_VALL(in) == NO)
			O_VALL(out) = YES
		    else
			O_VALL(out) = NO
		}

	    case TY_CHAR, TY_REAL, TY_DOUBLE:
		call xvv_error ("not of a nonlogical")
	    default:
		call xvv_error (s_badswitch)
	    }

	case BNOT:
	    # Bitwise boolean NOT.

	    call xvv_initop (out, nelem, O_TYPE(in))
	    switch (O_TYPE(in)) {
	    case TY_BOOL, TY_CHAR, TY_REAL, TY_DOUBLE:
		call xvv_error ("boolean not of a noninteger operand")

	    case TY_SHORT:
		if (nelem > 0)
		    call anots (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem)
		else
		    O_VALS(out) = not(O_VALS(in))

	    case TY_INT:
		if (nelem > 0)
		    call anoti (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem)
		else
		    O_VALI(out) = not(O_VALI(in))

	    case TY_LONG:
		if (nelem > 0)
		    call anotl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem)
		else
		    O_VALL(out) = not(O_VALL(in))

	    default:
		call xvv_error (s_badswitch)
	    }

	default:
	    call xvv_error (s_badswitch)
	}

	call xvv_freeop (in)
end


# XVV_BINOP -- Binary operation.  Perform the indicated arithmetic binary
# operation on the two input operands, returning the result as the output
# operand.

procedure xvv_binop (opcode, in1, in2, out)

int	opcode			#I operation to be performed
pointer	in1, in2		#I input operands
pointer	out			#I output operand


short	v_s
short	xvv_nulls()
extern	xvv_nulls()

int	v_i
int	xvv_nulli()
extern	xvv_nulli()

long	v_l
long	xvv_nulll()
extern	xvv_nulll()

real	v_r
real	xvv_nullr()
extern	xvv_nullr()

double	v_d
double	xvv_nulld()
extern	xvv_nulld()

pointer	sp, otemp, p1, p2, po
int	dtype, nelem, len1, len2
include	"evvexpr.com"

int	xvv_newtype(), strlen()
errchk	xvv_newtype, xvv_initop, xvv_chtype, xvv_error
string	s_badswitch "binop: bad case in switch"
string	s_boolop "binop: bitwise boolean operands must be an integer type"
define	done_ 91

begin
	# Set the datatype of the output operand, taking an error action if
	# the operands have incompatible datatypes.

	dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2))

	# Compute the size of the output operand.  If both input operands are
	# vectors the length of the output vector is the shorter of the two.

	switch (dtype) {
	case TY_BOOL:
	    call xvv_error ("binop: operation illegal for boolean operands")
	case TY_CHAR:
	    nelem = strlen (O_VALC(in1)) + strlen (O_VALC(in2))
	default:
	    if (opcode == CONCAT)
		nelem = max (1, O_LEN(in1)) + max (1, O_LEN(in2))
	    else {
		if (O_LEN(in1) > 0 && O_LEN(in2) > 0)
		    nelem = min (O_LEN(in1), O_LEN(in2))
		else if (O_LEN(in1) > 0)
		    nelem = O_LEN(in1)
		else if (O_LEN(in2) > 0)
		    nelem = O_LEN(in2)
		else
		    nelem = 0
	    }
	}

	# Convert input operands to desired type.
	if (O_TYPE(in1) != dtype)
	    call xvv_chtype (in1, in1, dtype)
	if (O_TYPE(in2) != dtype)
	    call xvv_chtype (in2, in2, dtype)

	# If this is a scalar/vector operation make sure the vector is the
	# first operand.

	len1 = O_LEN(in1)
	len2 = O_LEN(in2)

	if (len1 == 0 && len2 > 0) {
	    switch (opcode) {
	    case PLUS:
		# Swap operands.
		call smark (sp)
		call salloc (otemp, LEN_OPERAND, TY_STRUCT)
		YYMOVE (in1, otemp)
		YYMOVE (in2, in1)
		YYMOVE (otemp, in2)
		call sfree (sp)

	    case CONCAT:
		; # Do nothing

	    default:
		# Promote operand to a constant vector.  Inefficient, but
		# better than aborting.

		switch (dtype) {

		case TY_SHORT:
		    v_s = O_VALS(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovks (v_s, Mems[O_VALP(in1)], nelem)

		case TY_INT:
		    v_i = O_VALI(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovki (v_i, Memi[O_VALP(in1)], nelem)

		case TY_LONG:
		    v_l = O_VALL(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovkl (v_l, Meml[O_VALP(in1)], nelem)

		case TY_REAL:
		    v_r = O_VALR(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovkr (v_r, Memr[O_VALP(in1)], nelem)

		case TY_DOUBLE:
		    v_d = O_VALD(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovkd (v_d, Memd[O_VALP(in1)], nelem)

		}
	    }

	    len1 = O_LEN(in1)
	    len2 = O_LEN(in2)
	}

	# Initialize the output operand.
	call xvv_initop (out, nelem, dtype)

	p1 = O_VALP(in1)
	p2 = O_VALP(in2)
	po = O_VALP(out)

	# The bitwise boolean binary operators a special case since only the
	# integer datatypes are permitted.  Otherwise the bitwise booleans
	# are just like arithmetic booleans.

	if (opcode == BAND || opcode == BOR || opcode == BXOR) {
	    switch (dtype) {

	    case TY_SHORT:
		switch (opcode) {
		case BAND:
		    if (len1 <= 0) {
			O_VALS(out) = and (O_VALS(in1), O_VALS(in2))
		    } else if (len2 <= 0) {
			call aandks (Mems[p1], O_VALS(in2),
			    Mems[po], nelem)
		    } else {
			call aands (Mems[p1], Mems[p2],
			    Mems[po], nelem)
		    }
		case BOR:
		    if (len1 <= 0) {
			O_VALS(out) = or (O_VALS(in1), O_VALS(in2))
		    } else if (len2 <= 0) {
			call aborks (Mems[p1], O_VALS(in2),
			    Mems[po], nelem)
		    } else {
			call abors (Mems[p1], Mems[p2],
			    Mems[po], nelem)
		    }
		case BXOR:
		    if (len1 <= 0) {
			O_VALS(out) = xor (O_VALS(in1), O_VALS(in2))
		    } else if (len2 <= 0) {
			call axorks (Mems[p1], O_VALS(in2),
			    Mems[po], nelem)
		    } else {
			call axors (Mems[p1], Mems[p2],
			    Mems[po], nelem)
		    }
		}

	    case TY_INT:
		switch (opcode) {
		case BAND:
		    if (len1 <= 0) {
			O_VALI(out) = and (O_VALI(in1), O_VALI(in2))
		    } else if (len2 <= 0) {
			call aandki (Memi[p1], O_VALI(in2),
			    Memi[po], nelem)
		    } else {
			call aandi (Memi[p1], Memi[p2],
			    Memi[po], nelem)
		    }
		case BOR:
		    if (len1 <= 0) {
			O_VALI(out) = or (O_VALI(in1), O_VALI(in2))
		    } else if (len2 <= 0) {
			call aborki (Memi[p1], O_VALI(in2),
			    Memi[po], nelem)
		    } else {
			call abori (Memi[p1], Memi[p2],
			    Memi[po], nelem)
		    }
		case BXOR:
		    if (len1 <= 0) {
			O_VALI(out) = xor (O_VALI(in1), O_VALI(in2))
		    } else if (len2 <= 0) {
			call axorki (Memi[p1], O_VALI(in2),
			    Memi[po], nelem)
		    } else {
			call axori (Memi[p1], Memi[p2],
			    Memi[po], nelem)
		    }
		}

	    case TY_LONG:
		switch (opcode) {
		case BAND:
		    if (len1 <= 0) {
			O_VALL(out) = and (O_VALL(in1), O_VALL(in2))
		    } else if (len2 <= 0) {
			call aandkl (Meml[p1], O_VALL(in2),
			    Meml[po], nelem)
		    } else {
			call aandl (Meml[p1], Meml[p2],
			    Meml[po], nelem)
		    }
		case BOR:
		    if (len1 <= 0) {
			O_VALL(out) = or (O_VALL(in1), O_VALL(in2))
		    } else if (len2 <= 0) {
			call aborkl (Meml[p1], O_VALL(in2),
			    Meml[po], nelem)
		    } else {
			call aborl (Meml[p1], Meml[p2],
			    Meml[po], nelem)
		    }
		case BXOR:
		    if (len1 <= 0) {
			O_VALL(out) = xor (O_VALL(in1), O_VALL(in2))
		    } else if (len2 <= 0) {
			call axorkl (Meml[p1], O_VALL(in2),
			    Meml[po], nelem)
		    } else {
			call axorl (Meml[p1], Meml[p2],
			    Meml[po], nelem)
		    }
		}

	    default:
		call xvv_error (s_boolop)
	    }

	    goto done_
	}

	# Perform an arithmetic binary operation.
	switch (dtype) {
	case TY_CHAR:
	    switch (opcode) {
	    case CONCAT:
		call strcpy (O_VALC(in1), O_VALC(out), ARB)
		call strcat (O_VALC(in2), O_VALC(out), ARB)
	    default:
		call xvv_error ("binop: operation illegal for string operands")
	    }

	case TY_SHORT:
	    switch (opcode) {
	    case PLUS:
		if (len1 <= 0) {
		    O_VALS(out) = O_VALS(in1) + O_VALS(in2)
		} else if (len2 <= 0) {
		    call aaddks (Mems[p1], O_VALS(in2),
			Mems[po], nelem)
		} else {
		    call aadds (Mems[p1], Mems[p2],
			Mems[po], nelem)
		}
	    case MINUS:
		if (len1 <= 0)
		    O_VALS(out) = O_VALS(in1) - O_VALS(in2)
		else if (len2 <= 0)
		    call asubks (Mems[p1], O_VALS(in2), Mems[po], nelem)
		else
		    call asubs (Mems[p1], Mems[p2], Mems[po], nelem)

	    case STAR:
		if (len1 <= 0)
		    O_VALS(out) = O_VALS(in1) * O_VALS(in2)
		else if (len2 <= 0)
		    call amulks (Mems[p1], O_VALS(in2), Mems[po], nelem)
		else
		    call amuls (Mems[p1], Mems[p2], Mems[po], nelem)

	    case SLASH:
		if (and (ev_flags, EV_RNGCHK) == 0) {
		    # No range checking.
		    if (len1 <= 0)
			O_VALS(out) = O_VALS(in1) / O_VALS(in2)
		    else if (len2 <= 0)
			call adivks (Mems[p1], O_VALS(in2), Mems[po], nelem)
		    else
			call adivs (Mems[p1], Mems[p2], Mems[po], nelem)
		} else {
		    # Check for divide by zero.
		    if (len1 <= 0) {
			if (O_VALS(in2) == 0)
			    O_VALS(out) = xvv_nulls(0)
			else
			    O_VALS(out) = O_VALS(in1) / O_VALS(in2)
		    } else if (len2 <= 0) {
			if (O_VALS(in2) == 0)
			    call amovks (xvv_nulls(0), Mems[po], nelem)
			else {
			    call adivks (Mems[p1], O_VALS(in2), Mems[po],
				nelem)
			}
		    } else {
			call advzs (Mems[p1], Mems[p2], Mems[po], nelem,
			    xvv_nulls)
		    }
		}
	    case EXPON:
		if (len1 <= 0)
		    O_VALS(out) = O_VALS(in1) ** O_VALS(in2)
		else if (len2 <= 0)
		    call aexpks (Mems[p1], O_VALS(in2), Mems[po], nelem)
		else
		    call aexps (Mems[p1], Mems[p2], Mems[po], nelem)

	    case CONCAT:
		# Concatenate two numeric operands.
		if (len1 <= 0) {
		    Mems[po] = O_VALS(in1)
		    po = po + 1
		} else {
		    call amovs (Mems[p1], Mems[po], len1)
		    po = po + len1
		}
		if (len2 <= 0)
		    Mems[po] = O_VALS(in2)
		else
		    call amovs (Mems[p2], Mems[po], len2)

	    default:
		call xvv_error (s_badswitch)
	    }

	case TY_INT:
	    switch (opcode) {
	    case PLUS:
		if (len1 <= 0) {
		    O_VALI(out) = O_VALI(in1) + O_VALI(in2)
		} else if (len2 <= 0) {
		    call aaddki (Memi[p1], O_VALI(in2),
			Memi[po], nelem)
		} else {
		    call aaddi (Memi[p1], Memi[p2],
			Memi[po], nelem)
		}
	    case MINUS:
		if (len1 <= 0)
		    O_VALI(out) = O_VALI(in1) - O_VALI(in2)
		else if (len2 <= 0)
		    call asubki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		else
		    call asubi (Memi[p1], Memi[p2], Memi[po], nelem)

	    case STAR:
		if (len1 <= 0)
		    O_VALI(out) = O_VALI(in1) * O_VALI(in2)
		else if (len2 <= 0)
		    call amulki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		else
		    call amuli (Memi[p1], Memi[p2], Memi[po], nelem)

	    case SLASH:
		if (and (ev_flags, EV_RNGCHK) == 0) {
		    # No range checking.
		    if (len1 <= 0)
			O_VALI(out) = O_VALI(in1) / O_VALI(in2)
		    else if (len2 <= 0)
			call adivki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    else
			call adivi (Memi[p1], Memi[p2], Memi[po], nelem)
		} else {
		    # Check for divide by zero.
		    if (len1 <= 0) {
			if (O_VALI(in2) == 0)
			    O_VALI(out) = xvv_nulli(0)
			else
			    O_VALI(out) = O_VALI(in1) / O_VALI(in2)
		    } else if (len2 <= 0) {
			if (O_VALI(in2) == 0)
			    call amovki (xvv_nulli(0), Memi[po], nelem)
			else {
			    call adivki (Memi[p1], O_VALI(in2), Memi[po],
				nelem)
			}
		    } else {
			call advzi (Memi[p1], Memi[p2], Memi[po], nelem,
			    xvv_nulli)
		    }
		}
	    case EXPON:
		if (len1 <= 0)
		    O_VALI(out) = O_VALI(in1) ** O_VALI(in2)
		else if (len2 <= 0)
		    call aexpki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		else
		    call aexpi (Memi[p1], Memi[p2], Memi[po], nelem)

	    case CONCAT:
		# Concatenate two numeric operands.
		if (len1 <= 0) {
		    Memi[po] = O_VALI(in1)
		    po = po + 1
		} else {
		    call amovi (Memi[p1], Memi[po], len1)
		    po = po + len1
		}
		if (len2 <= 0)
		    Memi[po] = O_VALI(in2)
		else
		    call amovi (Memi[p2], Memi[po], len2)

	    default:
		call xvv_error (s_badswitch)
	    }

	case TY_LONG:
	    switch (opcode) {
	    case PLUS:
		if (len1 <= 0) {
		    O_VALL(out) = O_VALL(in1) + O_VALL(in2)
		} else if (len2 <= 0) {
		    call aaddkl (Meml[p1], O_VALL(in2),
			Meml[po], nelem)
		} else {
		    call aaddl (Meml[p1], Meml[p2],
			Meml[po], nelem)
		}
	    case MINUS:
		if (len1 <= 0)
		    O_VALL(out) = O_VALL(in1) - O_VALL(in2)
		else if (len2 <= 0)
		    call asubkl (Meml[p1], O_VALL(in2), Meml[po], nelem)
		else
		    call asubl (Meml[p1], Meml[p2], Meml[po], nelem)

	    case STAR:
		if (len1 <= 0)
		    O_VALL(out) = O_VALL(in1) * O_VALL(in2)
		else if (len2 <= 0)
		    call amulkl (Meml[p1], O_VALL(in2), Meml[po], nelem)
		else
		    call amull (Meml[p1], Meml[p2], Meml[po], nelem)

	    case SLASH:
		if (and (ev_flags, EV_RNGCHK) == 0) {
		    # No range checking.
		    if (len1 <= 0)
			O_VALL(out) = O_VALL(in1) / O_VALL(in2)
		    else if (len2 <= 0)
			call adivkl (Meml[p1], O_VALL(in2), Meml[po], nelem)
		    else
			call adivl (Meml[p1], Meml[p2], Meml[po], nelem)
		} else {
		    # Check for divide by zero.
		    if (len1 <= 0) {
			if (O_VALL(in2) == 0)
			    O_VALL(out) = xvv_nulll(0)
			else
			    O_VALL(out) = O_VALL(in1) / O_VALL(in2)
		    } else if (len2 <= 0) {
			if (O_VALL(in2) == 0)
			    call amovkl (xvv_nulll(0), Meml[po], nelem)
			else {
			    call adivkl (Meml[p1], O_VALL(in2), Meml[po],
				nelem)
			}
		    } else {
			call advzl (Meml[p1], Meml[p2], Meml[po], nelem,
			    xvv_nulll)
		    }
		}
	    case EXPON:
		if (len1 <= 0)
		    O_VALL(out) = O_VALL(in1) ** O_VALL(in2)
		else if (len2 <= 0)
		    call aexpkl (Meml[p1], O_VALL(in2), Meml[po], nelem)
		else
		    call aexpl (Meml[p1], Meml[p2], Meml[po], nelem)

	    case CONCAT:
		# Concatenate two numeric operands.
		if (len1 <= 0) {
		    Meml[po] = O_VALL(in1)
		    po = po + 1
		} else {
		    call amovl (Meml[p1], Meml[po], len1)
		    po = po + len1
		}
		if (len2 <= 0)
		    Meml[po] = O_VALL(in2)
		else
		    call amovl (Meml[p2], Meml[po], len2)

	    default:
		call xvv_error (s_badswitch)
	    }

	case TY_REAL:
	    switch (opcode) {
	    case PLUS:
		if (len1 <= 0) {
		    O_VALR(out) = O_VALR(in1) + O_VALR(in2)
		} else if (len2 <= 0) {
		    call aaddkr (Memr[p1], O_VALR(in2),
			Memr[po], nelem)
		} else {
		    call aaddr (Memr[p1], Memr[p2],
			Memr[po], nelem)
		}
	    case MINUS:
		if (len1 <= 0)
		    O_VALR(out) = O_VALR(in1) - O_VALR(in2)
		else if (len2 <= 0)
		    call asubkr (Memr[p1], O_VALR(in2), Memr[po], nelem)
		else
		    call asubr (Memr[p1], Memr[p2], Memr[po], nelem)

	    case STAR:
		if (len1 <= 0)
		    O_VALR(out) = O_VALR(in1) * O_VALR(in2)
		else if (len2 <= 0)
		    call amulkr (Memr[p1], O_VALR(in2), Memr[po], nelem)
		else
		    call amulr (Memr[p1], Memr[p2], Memr[po], nelem)

	    case SLASH:
		if (and (ev_flags, EV_RNGCHK) == 0) {
		    # No range checking.
		    if (len1 <= 0)
			O_VALR(out) = O_VALR(in1) / O_VALR(in2)
		    else if (len2 <= 0)
			call adivkr (Memr[p1], O_VALR(in2), Memr[po], nelem)
		    else
			call adivr (Memr[p1], Memr[p2], Memr[po], nelem)
		} else {
		    # Check for divide by zero.
		    if (len1 <= 0) {
			if (O_VALR(in2) == 0.0)
			    O_VALR(out) = xvv_nullr(0.0)
			else
			    O_VALR(out) = O_VALR(in1) / O_VALR(in2)
		    } else if (len2 <= 0) {
			if (O_VALR(in2) == 0.0)
			    call amovkr (xvv_nullr(0.0), Memr[po], nelem)
			else {
			    call adivkr (Memr[p1], O_VALR(in2), Memr[po],
				nelem)
			}
		    } else {
			call advzr (Memr[p1], Memr[p2], Memr[po], nelem,
			    xvv_nullr)
		    }
		}
	    case EXPON:
		if (len1 <= 0)
		    O_VALR(out) = O_VALR(in1) ** O_VALR(in2)
		else if (len2 <= 0)
		    call aexpkr (Memr[p1], O_VALR(in2), Memr[po], nelem)
		else
		    call aexpr (Memr[p1], Memr[p2], Memr[po], nelem)

	    case CONCAT:
		# Concatenate two numeric operands.
		if (len1 <= 0) {
		    Memr[po] = O_VALR(in1)
		    po = po + 1
		} else {
		    call amovr (Memr[p1], Memr[po], len1)
		    po = po + len1
		}
		if (len2 <= 0)
		    Memr[po] = O_VALR(in2)
		else
		    call amovr (Memr[p2], Memr[po], len2)

	    default:
		call xvv_error (s_badswitch)
	    }

	case TY_DOUBLE:
	    switch (opcode) {
	    case PLUS:
		if (len1 <= 0) {
		    O_VALD(out) = O_VALD(in1) + O_VALD(in2)
		} else if (len2 <= 0) {
		    call aaddkd (Memd[p1], O_VALD(in2),
			Memd[po], nelem)
		} else {
		    call aaddd (Memd[p1], Memd[p2],
			Memd[po], nelem)
		}
	    case MINUS:
		if (len1 <= 0)
		    O_VALD(out) = O_VALD(in1) - O_VALD(in2)
		else if (len2 <= 0)
		    call asubkd (Memd[p1], O_VALD(in2), Memd[po], nelem)
		else
		    call asubd (Memd[p1], Memd[p2], Memd[po], nelem)

	    case STAR:
		if (len1 <= 0)
		    O_VALD(out) = O_VALD(in1) * O_VALD(in2)
		else if (len2 <= 0)
		    call amulkd (Memd[p1], O_VALD(in2), Memd[po], nelem)
		else
		    call amuld (Memd[p1], Memd[p2], Memd[po], nelem)

	    case SLASH:
		if (and (ev_flags, EV_RNGCHK) == 0) {
		    # No range checking.
		    if (len1 <= 0)
			O_VALD(out) = O_VALD(in1) / O_VALD(in2)
		    else if (len2 <= 0)
			call adivkd (Memd[p1], O_VALD(in2), Memd[po], nelem)
		    else
			call adivd (Memd[p1], Memd[p2], Memd[po], nelem)
		} else {
		    # Check for divide by zero.
		    if (len1 <= 0) {
			if (O_VALD(in2) == 0.0D0)
			    O_VALD(out) = xvv_nulld(0.0D0)
			else
			    O_VALD(out) = O_VALD(in1) / O_VALD(in2)
		    } else if (len2 <= 0) {
			if (O_VALD(in2) == 0.0D0)
			    call amovkd (xvv_nulld(0.0D0), Memd[po], nelem)
			else {
			    call adivkd (Memd[p1], O_VALD(in2), Memd[po],
				nelem)
			}
		    } else {
			call advzd (Memd[p1], Memd[p2], Memd[po], nelem,
			    xvv_nulld)
		    }
		}
	    case EXPON:
		if (len1 <= 0)
		    O_VALD(out) = O_VALD(in1) ** O_VALD(in2)
		else if (len2 <= 0)
		    call aexpkd (Memd[p1], O_VALD(in2), Memd[po], nelem)
		else
		    call aexpd (Memd[p1], Memd[p2], Memd[po], nelem)

	    case CONCAT:
		# Concatenate two numeric operands.
		if (len1 <= 0) {
		    Memd[po] = O_VALD(in1)
		    po = po + 1
		} else {
		    call amovd (Memd[p1], Memd[po], len1)
		    po = po + len1
		}
		if (len2 <= 0)
		    Memd[po] = O_VALD(in2)
		else
		    call amovd (Memd[p2], Memd[po], len2)

	    default:
		call xvv_error (s_badswitch)
	    }

	default:
	    call xvv_error (s_badswitch)
	}
done_
	# Free any storage in input operands.
	call xvv_freeop (in1)
	call xvv_freeop (in2)
end


# XVV_BOOLOP -- Boolean (actually logical) binary operations.  Perform the
# indicated logical operation on the two input operands, returning the result
# as the output operand.  The opcodes implemented by this routine are
# characterized by the fact that they all return a logical result (YES or NO
# physically expressed as an integer).

procedure xvv_boolop (opcode, in1, in2, out)

int	opcode			#I operation to be performed
pointer	in1, in2		#I input operands
pointer	out			#I output operand


short	v_s

int	v_i

long	v_l

real	v_r

double	v_d

pointer	sp, otemp, p1, p2, po
int	dtype, nelem, len1, len2
int	xvv_newtype(), xvv_patmatch(), strncmp(), btoi()
errchk	xvv_newtype, xvv_initop, xvv_chtype, xvv_error
string	s_badop "boolop: illegal operation"
string	s_badswitch "boolop: illegal switch"

begin
	# Boolean operands are treated as integer within this routine.
	if (O_TYPE(in1) == TY_BOOL)
	    O_TYPE(in1) = TY_INT
	if (O_TYPE(in2) == TY_BOOL)
	    O_TYPE(in2) = TY_INT

	# Determine the computation type for the operation, i.e., the type
	# both input operands must have.  This is not the same as the type
	# of the output operand, which is always boolean for the operations
	# implemented by this routine.

	dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2))

	# Compute the size of the output operand.  If both input operands are
	# vectors the length of the output vector is the shorter of the two.

	if (dtype == TY_CHAR)
	    nelem = 0
	else {
	    if (O_LEN(in1) > 0 && O_LEN(in2) > 0)
		nelem = min (O_LEN(in1), O_LEN(in2))
	    else if (O_LEN(in1) > 0)
		nelem = O_LEN(in1)
	    else if (O_LEN(in2) > 0)
		nelem = O_LEN(in2)
	    else
		nelem = 0
	}

	# Convert input operands to desired computation type.
	if (O_TYPE(in1) != dtype)
	    call xvv_chtype (in1, in1, dtype)
	if (O_TYPE(in2) != dtype)
	    call xvv_chtype (in2, in2, dtype)

	# If this is a scalar/vector operation make sure the vector is the
	# first operand.

	len1 = O_LEN(in1)
	len2 = O_LEN(in2)

	if (len1 == 0 && len2 > 0) {
	    switch (opcode) {
	    case EQ, NE:
		call smark (sp)
		call salloc (otemp, LEN_OPERAND, TY_STRUCT)
		YYMOVE (in1, otemp)
		YYMOVE (in2, in1)
		YYMOVE (otemp, in2)
		call sfree (sp)
	    default:
		# Promote operand to a constant vector.  Inefficient, but
		# better than aborting.

		switch (dtype) {

		case TY_SHORT:
		    v_s = O_VALS(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovks (v_s, Mems[O_VALP(in1)], nelem)

		case TY_INT:
		    v_i = O_VALI(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovki (v_i, Memi[O_VALP(in1)], nelem)

		case TY_LONG:
		    v_l = O_VALL(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovkl (v_l, Meml[O_VALP(in1)], nelem)

		case TY_REAL:
		    v_r = O_VALR(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovkr (v_r, Memr[O_VALP(in1)], nelem)

		case TY_DOUBLE:
		    v_d = O_VALD(in1)
		    call xvv_initop (in1, nelem, dtype)
		    call amovkd (v_d, Memd[O_VALP(in1)], nelem)

		}
	    }

	    len1 = O_LEN(in1)
	    len2 = O_LEN(in2)
	}

	# Initialize the output operand.
	call xvv_initop (out, nelem, TY_BOOL)

	p1 = O_VALP(in1)
	p2 = O_VALP(in2)
	po = O_VALP(out)

	# Perform the operation.
	if (dtype == TY_CHAR) {
	    # Character data is a special case.

	    switch (opcode) {
	    case SE:
		O_VALI(out) = btoi(xvv_patmatch (O_VALC(in1), O_VALC(in2)) > 0)
	    case LT:
		O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0)
	    case LE:
		O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) <= 0)
	    case GT:
		O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0)
	    case GE:
		O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) >= 0)
	    case EQ:
		O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0)
	    case NE:
		O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) != 0)
	    default:
		call xvv_error (s_badop)
	    }

	} else if (opcode == LAND || opcode == LOR) {
	    # Operations supporting only the integer types.

	    switch (dtype) {

	    case TY_SHORT:
		switch (opcode) {
		case LAND:
		    if (len1 <= 0) {
			O_VALI(out) =
			    btoi (O_VALS(in1) != 0 && O_VALS(in2) != 0)
		    } else if (len2 <= 0) {
			call alanks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    } else
			call alans (Mems[p1], Mems[p2], Memi[po], nelem)
		case LOR:
		    if (len1 <= 0) {
			O_VALI(out) =
			    btoi (O_VALS(in1) != 0 || O_VALS(in2) != 0)
		    } else if (len2 <= 0) {
			call alorks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    } else
			call alors (Mems[p1], Mems[p2], Memi[po], nelem)
		default:
		    call xvv_error (s_badop)
		}

	    case TY_INT:
		switch (opcode) {
		case LAND:
		    if (len1 <= 0) {
			O_VALI(out) =
			    btoi (O_VALI(in1) != 0 && O_VALI(in2) != 0)
		    } else if (len2 <= 0) {
			call alanki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    } else
			call alani (Memi[p1], Memi[p2], Memi[po], nelem)
		case LOR:
		    if (len1 <= 0) {
			O_VALI(out) =
			    btoi (O_VALI(in1) != 0 || O_VALI(in2) != 0)
		    } else if (len2 <= 0) {
			call alorki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    } else
			call alori (Memi[p1], Memi[p2], Memi[po], nelem)
		default:
		    call xvv_error (s_badop)
		}

	    case TY_LONG:
		switch (opcode) {
		case LAND:
		    if (len1 <= 0) {
			O_VALI(out) =
			    btoi (O_VALL(in1) != 0 && O_VALL(in2) != 0)
		    } else if (len2 <= 0) {
			call alankl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    } else
			call alanl (Meml[p1], Meml[p2], Memi[po], nelem)
		case LOR:
		    if (len1 <= 0) {
			O_VALI(out) =
			    btoi (O_VALL(in1) != 0 || O_VALL(in2) != 0)
		    } else if (len2 <= 0) {
			call alorkl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    } else
			call alorl (Meml[p1], Meml[p2], Memi[po], nelem)
		default:
		    call xvv_error (s_badop)
		}

	    default:
		call xvv_error (s_badswitch)
	    }
	} else {
	    # Operations supporting any arithmetic type.

	    switch (dtype) {

	    case TY_SHORT:
		switch (opcode) {
		case LT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALS(in1) < O_VALS(in2))
		    else if (len2 <= 0)
			call abltks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    else
			call ablts (Mems[p1], Mems[p2], Memi[po], nelem)

		case LE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALS(in1) <= O_VALS(in2))
		    else if (len2 <= 0)
			call ableks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    else
			call ables (Mems[p1], Mems[p2], Memi[po], nelem)

		case GT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALS(in1) > O_VALS(in2))
		    else if (len2 <= 0)
			call abgtks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    else
			call abgts (Mems[p1], Mems[p2], Memi[po], nelem)

		case GE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALS(in1) >= O_VALS(in2))
		    else if (len2 <= 0)
			call abgeks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    else
			call abges (Mems[p1], Mems[p2], Memi[po], nelem)

		case EQ:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALS(in1) == O_VALS(in2))
		    else if (len2 <= 0)
			call abeqks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    else
			call abeqs (Mems[p1], Mems[p2], Memi[po], nelem)

		case NE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALS(in1) != O_VALS(in2))
		    else if (len2 <= 0)
			call abneks (Mems[p1], O_VALS(in2), Memi[po], nelem)
		    else
			call abnes (Mems[p1], Mems[p2], Memi[po], nelem)

		default:
		    call xvv_error (s_badop)
		}

	    case TY_INT:
		switch (opcode) {
		case LT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALI(in1) < O_VALI(in2))
		    else if (len2 <= 0)
			call abltki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    else
			call ablti (Memi[p1], Memi[p2], Memi[po], nelem)

		case LE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALI(in1) <= O_VALI(in2))
		    else if (len2 <= 0)
			call ableki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    else
			call ablei (Memi[p1], Memi[p2], Memi[po], nelem)

		case GT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALI(in1) > O_VALI(in2))
		    else if (len2 <= 0)
			call abgtki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    else
			call abgti (Memi[p1], Memi[p2], Memi[po], nelem)

		case GE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALI(in1) >= O_VALI(in2))
		    else if (len2 <= 0)
			call abgeki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    else
			call abgei (Memi[p1], Memi[p2], Memi[po], nelem)

		case EQ:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALI(in1) == O_VALI(in2))
		    else if (len2 <= 0)
			call abeqki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    else
			call abeqi (Memi[p1], Memi[p2], Memi[po], nelem)

		case NE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALI(in1) != O_VALI(in2))
		    else if (len2 <= 0)
			call abneki (Memi[p1], O_VALI(in2), Memi[po], nelem)
		    else
			call abnei (Memi[p1], Memi[p2], Memi[po], nelem)

		default:
		    call xvv_error (s_badop)
		}

	    case TY_LONG:
		switch (opcode) {
		case LT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALL(in1) < O_VALL(in2))
		    else if (len2 <= 0)
			call abltkl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    else
			call abltl (Meml[p1], Meml[p2], Memi[po], nelem)

		case LE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALL(in1) <= O_VALL(in2))
		    else if (len2 <= 0)
			call ablekl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    else
			call ablel (Meml[p1], Meml[p2], Memi[po], nelem)

		case GT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALL(in1) > O_VALL(in2))
		    else if (len2 <= 0)
			call abgtkl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    else
			call abgtl (Meml[p1], Meml[p2], Memi[po], nelem)

		case GE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALL(in1) >= O_VALL(in2))
		    else if (len2 <= 0)
			call abgekl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    else
			call abgel (Meml[p1], Meml[p2], Memi[po], nelem)

		case EQ:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALL(in1) == O_VALL(in2))
		    else if (len2 <= 0)
			call abeqkl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    else
			call abeql (Meml[p1], Meml[p2], Memi[po], nelem)

		case NE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALL(in1) != O_VALL(in2))
		    else if (len2 <= 0)
			call abnekl (Meml[p1], O_VALL(in2), Memi[po], nelem)
		    else
			call abnel (Meml[p1], Meml[p2], Memi[po], nelem)

		default:
		    call xvv_error (s_badop)
		}

	    case TY_REAL:
		switch (opcode) {
		case LT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALR(in1) < O_VALR(in2))
		    else if (len2 <= 0)
			call abltkr (Memr[p1], O_VALR(in2), Memi[po], nelem)
		    else
			call abltr (Memr[p1], Memr[p2], Memi[po], nelem)

		case LE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALR(in1) <= O_VALR(in2))
		    else if (len2 <= 0)
			call ablekr (Memr[p1], O_VALR(in2), Memi[po], nelem)
		    else
			call abler (Memr[p1], Memr[p2], Memi[po], nelem)

		case GT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALR(in1) > O_VALR(in2))
		    else if (len2 <= 0)
			call abgtkr (Memr[p1], O_VALR(in2), Memi[po], nelem)
		    else
			call abgtr (Memr[p1], Memr[p2], Memi[po], nelem)

		case GE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALR(in1) >= O_VALR(in2))
		    else if (len2 <= 0)
			call abgekr (Memr[p1], O_VALR(in2), Memi[po], nelem)
		    else
			call abger (Memr[p1], Memr[p2], Memi[po], nelem)

		case EQ:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALR(in1) == O_VALR(in2))
		    else if (len2 <= 0)
			call abeqkr (Memr[p1], O_VALR(in2), Memi[po], nelem)
		    else
			call abeqr (Memr[p1], Memr[p2], Memi[po], nelem)

		case NE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALR(in1) != O_VALR(in2))
		    else if (len2 <= 0)
			call abnekr (Memr[p1], O_VALR(in2), Memi[po], nelem)
		    else
			call abner (Memr[p1], Memr[p2], Memi[po], nelem)

		default:
		    call xvv_error (s_badop)
		}

	    case TY_DOUBLE:
		switch (opcode) {
		case LT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALD(in1) < O_VALD(in2))
		    else if (len2 <= 0)
			call abltkd (Memd[p1], O_VALD(in2), Memi[po], nelem)
		    else
			call abltd (Memd[p1], Memd[p2], Memi[po], nelem)

		case LE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALD(in1) <= O_VALD(in2))
		    else if (len2 <= 0)
			call ablekd (Memd[p1], O_VALD(in2), Memi[po], nelem)
		    else
			call abled (Memd[p1], Memd[p2], Memi[po], nelem)

		case GT:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALD(in1) > O_VALD(in2))
		    else if (len2 <= 0)
			call abgtkd (Memd[p1], O_VALD(in2), Memi[po], nelem)
		    else
			call abgtd (Memd[p1], Memd[p2], Memi[po], nelem)

		case GE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALD(in1) >= O_VALD(in2))
		    else if (len2 <= 0)
			call abgekd (Memd[p1], O_VALD(in2), Memi[po], nelem)
		    else
			call abged (Memd[p1], Memd[p2], Memi[po], nelem)

		case EQ:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALD(in1) == O_VALD(in2))
		    else if (len2 <= 0)
			call abeqkd (Memd[p1], O_VALD(in2), Memi[po], nelem)
		    else
			call abeqd (Memd[p1], Memd[p2], Memi[po], nelem)

		case NE:
		    if (len1 <= 0)
			O_VALI(out) = btoi (O_VALD(in1) != O_VALD(in2))
		    else if (len2 <= 0)
			call abnekd (Memd[p1], O_VALD(in2), Memi[po], nelem)
		    else
			call abned (Memd[p1], Memd[p2], Memi[po], nelem)

		default:
		    call xvv_error (s_badop)
		}

	    default:
		call xvv_error (s_badswitch)
	    }
	}

	# Free any storage in input operands.
	call xvv_freeop (in1)
	call xvv_freeop (in2)
end


# XVV_PATMATCH -- Match a string against a pattern, returning the patmatch
# index if the string matches.  The pattern may contain any of the conventional
# pattern matching metacharacters.  Closure (i.e., "*") is mapped to "?*".

int procedure xvv_patmatch (str, pat)

char	str[ARB]		#I operand string
char	pat[ARB]		#I pattern

int	junk, ip, index
pointer	sp, patstr, patbuf, op
int	patmake(), patmatch()

begin
	call smark (sp)
	call salloc (patstr, SZ_FNAME, TY_CHAR)
	call salloc (patbuf, SZ_LINE,  TY_CHAR)
	call aclrc (Memc[patstr], SZ_FNAME)
	call aclrc (Memc[patbuf], SZ_LINE)

	# Map pattern, changing '*' into '?*'.
	op = patstr
	for (ip=1;  pat[ip] != EOS;  ip=ip+1) {
	    if (pat[ip] == '*') {
		Memc[op] = '?'
		op = op + 1
	    }
	    Memc[op] = pat[ip]
	    op = op + 1
	}

	# Encode pattern.
	junk = patmake (Memc[patstr], Memc[patbuf], SZ_LINE)

	# Perform the pattern matching operation.
	index = patmatch (str, Memc[patbuf])

	call sfree (sp)
	return (index)
end


# XVV_NEWTYPE -- Get the datatype of a binary operation, given the datatypes
# of the two input operands.  An error action is taken if the datatypes are
# incompatible, e.g., boolean and anything else or string and anything else.

int procedure xvv_newtype (type1, type2)

int	type1			#I datatype of first operand
int	type2			#I datatype of second operand

int	newtype, p, q, i
int	tyindex[NTYPES], ttbl[NTYPES*NTYPES]
data	tyindex	/T_B, T_C, T_S, T_I, T_L, T_R, T_D/

data	(ttbl(i),i= 1, 7)	/T_B,    0,    0,    0,    0,    0,    0/
data	(ttbl(i),i= 8,14)	/  0,  T_C,    0,    0,    0,    0,    0/
data	(ttbl(i),i=15,21)	/  0,    0,  T_S,  T_I,  T_L,  T_R,  T_D/
data	(ttbl(i),i=22,28)	/  0,    0,  T_I,  T_I,  T_L,  T_R,  T_D/
data	(ttbl(i),i=29,35)	/  0,    0,  T_L,  T_L,  T_L,  T_R,  T_D/
data	(ttbl(i),i=36,42)	/  0,    0,  T_R,  T_R,  T_R,  T_R,  T_D/
data	(ttbl(i),i=43,49)	/  0,    0,  T_D,  T_D,  T_D,  T_D,  T_D/

begin
	do i = 1, NTYPES {
	    if (tyindex[i] == type1)
		p = i
	    if (tyindex[i] == type2)
		q = i
	}

	newtype = ttbl[(p-1)*NTYPES+q]
	if (newtype == 0)
	    call xvv_error ("operands have incompatible types")
	else
	    return (newtype)
end


# XVV_QUEST -- Conditional expression.  If the condition operand is true
# return the first (true) operand, else return the second (false) operand.

procedure xvv_quest (cond, in1, in2, out)

pointer	cond			#I pointer to condition operand
pointer	in1, in2		#I pointer to true,false operands
pointer	out			#I pointer to output operand

int	dtype, nelem, i
pointer	sp, otemp, ip1, ip2, op, sel
errchk	xvv_error, xvv_newtype, xvv_initop, xvv_chtype
int	xvv_newtype(), btoi()

begin
	switch (O_TYPE(cond)) {
	case TY_BOOL, TY_INT:
	    ;
	case TY_SHORT, TY_LONG:
	    call xvv_chtype (cond, cond, TY_BOOL)
	default:
	    call xvv_error ("evvexpr: nonboolean condition operand")
	}

	if (O_LEN(cond) <= 0 &&
	    (O_LEN(in1) <= 0 || O_TYPE(in1) == TY_CHAR) &&
	    (O_LEN(in2) <= 0 || O_TYPE(in2) == TY_CHAR)) {

	    # Both operands and the conditional are scalars; the expression
	    # type is the type of the selected operand.

	    if (O_VALI(cond) != 0) {
		YYMOVE (in1, out)
		call xvv_freeop (in2)
	    } else {
		YYMOVE (in2, out)
		call xvv_freeop (in1)
	    }

	} else if (O_TYPE(in1) == TY_CHAR || O_TYPE(in2) == TY_CHAR) {
	    # This combination is not legal.
	    call xvv_error ("evvexpr: character and vector in cond expr")

	} else {
	    # Vector/scalar or vector/vector operation.  Both operands must
	    # be of the same type.

	    dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2))

	    # Compute the size of the output operand.  If both input operands
	    # are vectors the length of the output vector is the shorter of
	    # the two.  The condition operand contributes to the dimension of
	    # the expression result, although not to the datatype.

	    nelem = 0
	    if (O_LEN(in1) > 0 && O_LEN(in2) > 0)
		nelem = min (O_LEN(in1), O_LEN(in2))
	    else if (O_LEN(in1) > 0)
		nelem = O_LEN(in1)
	    else if (O_LEN(in2) > 0)
		nelem = O_LEN(in2)

	    if (O_LEN(cond) > 0 && nelem > 0)
		nelem = min (O_LEN(cond), nelem)
	    else if (O_LEN(cond) > 0)
		nelem = O_LEN(cond)

	    # If this is a scalar/vector operation make sure the vector is the
	    # first operand.

	    if (O_LEN(in1) == 0 && O_LEN(in2) > 0) {
		call smark (sp)
		call salloc (otemp, LEN_OPERAND, TY_STRUCT)
		YYMOVE (in1, otemp)
		YYMOVE (in2, in1)
		YYMOVE (otemp, in2)
		call sfree (sp)

		# Since we are swapping arguments we need to negate the cond.
		if (O_LEN(cond) <= 0)
		    O_VALI(cond) = btoi (O_VALI(cond) == 0)
		else {
		    call abeqki (Memi[O_VALP(cond)], NO, Memi[O_VALP(cond)],
			nelem)
		}
	    }

	    # Initialize the output operand.
	    call xvv_initop (out, nelem, dtype)

	    # Convert input operands to desired computation type.
	    if (O_TYPE(in1) != dtype)
		call xvv_chtype (in1, in1, dtype)
	    if (O_TYPE(in2) != dtype)
		call xvv_chtype (in2, in2, dtype)

	    ip1 = O_VALP(in1)
	    ip2 = O_VALP(in2)
	    op  = O_VALP(out)
	    sel = O_VALP(cond)

	    # Perform the operation.
	    switch (dtype) {

	    case TY_SHORT:
		if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) {
		    # Vector conditional, both operands are scalars.
		    do i = 1, nelem
			if (Memi[sel+i-1] != 0)
			    Mems[op+i-1] = O_VALS(in1)
			else
			    Mems[op+i-1] = O_VALS(in2)

		} else if (O_LEN(in2) <= 0) {
		    # Operand 1 is a vector, operand 2 is a scalar.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovs (Mems[ip1], Mems[op], nelem)
			else
			    call amovks (O_VALS(in2), Mems[op], nelem)
		    } else {
			# Conditional is a vector.
			call aselks (Mems[ip1], O_VALS(in2), Mems[op],
			    Memi[sel], nelem)
		    }
		} else {
		    # Both operands are vectors.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovs (Mems[ip1], Mems[op], nelem)
			else
			    call amovs (Mems[ip2], Mems[op], nelem)
		    } else {
			# Conditional is a vector.
			call asels (Mems[ip1], Mems[ip2], Mems[op],
			    Memi[sel], nelem)
		    }
		}

	    case TY_INT:
		if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) {
		    # Vector conditional, both operands are scalars.
		    do i = 1, nelem
			if (Memi[sel+i-1] != 0)
			    Memi[op+i-1] = O_VALI(in1)
			else
			    Memi[op+i-1] = O_VALI(in2)

		} else if (O_LEN(in2) <= 0) {
		    # Operand 1 is a vector, operand 2 is a scalar.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovi (Memi[ip1], Memi[op], nelem)
			else
			    call amovki (O_VALI(in2), Memi[op], nelem)
		    } else {
			# Conditional is a vector.
			call aselki (Memi[ip1], O_VALI(in2), Memi[op],
			    Memi[sel], nelem)
		    }
		} else {
		    # Both operands are vectors.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovi (Memi[ip1], Memi[op], nelem)
			else
			    call amovi (Memi[ip2], Memi[op], nelem)
		    } else {
			# Conditional is a vector.
			call aseli (Memi[ip1], Memi[ip2], Memi[op],
			    Memi[sel], nelem)
		    }
		}

	    case TY_LONG:
		if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) {
		    # Vector conditional, both operands are scalars.
		    do i = 1, nelem
			if (Memi[sel+i-1] != 0)
			    Meml[op+i-1] = O_VALL(in1)
			else
			    Meml[op+i-1] = O_VALL(in2)

		} else if (O_LEN(in2) <= 0) {
		    # Operand 1 is a vector, operand 2 is a scalar.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovl (Meml[ip1], Meml[op], nelem)
			else
			    call amovkl (O_VALL(in2), Meml[op], nelem)
		    } else {
			# Conditional is a vector.
			call aselkl (Meml[ip1], O_VALL(in2), Meml[op],
			    Memi[sel], nelem)
		    }
		} else {
		    # Both operands are vectors.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovl (Meml[ip1], Meml[op], nelem)
			else
			    call amovl (Meml[ip2], Meml[op], nelem)
		    } else {
			# Conditional is a vector.
			call asell (Meml[ip1], Meml[ip2], Meml[op],
			    Memi[sel], nelem)
		    }
		}

	    case TY_REAL:
		if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) {
		    # Vector conditional, both operands are scalars.
		    do i = 1, nelem
			if (Memi[sel+i-1] != 0)
			    Memr[op+i-1] = O_VALR(in1)
			else
			    Memr[op+i-1] = O_VALR(in2)

		} else if (O_LEN(in2) <= 0) {
		    # Operand 1 is a vector, operand 2 is a scalar.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovr (Memr[ip1], Memr[op], nelem)
			else
			    call amovkr (O_VALR(in2), Memr[op], nelem)
		    } else {
			# Conditional is a vector.
			call aselkr (Memr[ip1], O_VALR(in2), Memr[op],
			    Memi[sel], nelem)
		    }
		} else {
		    # Both operands are vectors.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovr (Memr[ip1], Memr[op], nelem)
			else
			    call amovr (Memr[ip2], Memr[op], nelem)
		    } else {
			# Conditional is a vector.
			call aselr (Memr[ip1], Memr[ip2], Memr[op],
			    Memi[sel], nelem)
		    }
		}

	    case TY_DOUBLE:
		if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) {
		    # Vector conditional, both operands are scalars.
		    do i = 1, nelem
			if (Memi[sel+i-1] != 0)
			    Memd[op+i-1] = O_VALD(in1)
			else
			    Memd[op+i-1] = O_VALD(in2)

		} else if (O_LEN(in2) <= 0) {
		    # Operand 1 is a vector, operand 2 is a scalar.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovd (Memd[ip1], Memd[op], nelem)
			else
			    call amovkd (O_VALD(in2), Memd[op], nelem)
		    } else {
			# Conditional is a vector.
			call aselkd (Memd[ip1], O_VALD(in2), Memd[op],
			    Memi[sel], nelem)
		    }
		} else {
		    # Both operands are vectors.
		    if (O_LEN(cond) <= 0) {
			# Conditional is a scalar.
			if (O_VALI(cond) != 0)
			    call amovd (Memd[ip1], Memd[op], nelem)
			else
			    call amovd (Memd[ip2], Memd[op], nelem)
		    } else {
			# Conditional is a vector.
			call aseld (Memd[ip1], Memd[ip2], Memd[op],
			    Memi[sel], nelem)
		    }
		}

	    default:
		call xvv_error ("evvexpr: bad datatype in cond expr")
	    }

	    call xvv_freeop (in1)
	    call xvv_freeop (in2)
	}

	call xvv_freeop (cond)
end


# XVV_CALLFCN -- Call an intrinsic function.  If the function named is not
# one of the standard intrinsic functions, call an external user function
# if a function call procedure was supplied.

procedure xvv_callfcn (fcn, args, nargs, out)

char	fcn[ARB]		#I function to be called
pointer	args[ARB]		#I pointer to arglist descriptor
int	nargs			#I number of arguments
pointer	out			#I output operand (function value)


short	v_s
short	ahivs(), alovs()
short	ameds()
int	aravs()

int	v_i
int	ahivi(), alovi()
int	amedi()
int	aravi()

long	v_l
long	ahivl(), alovl()
long	amedl()
int	aravl()

real	v_r
real	ahivr(), alovr()
real	amedr()
int	aravr()

double	v_d
double	ahivd(), alovd()
double	amedd()
int	aravd()


real	mean_r, sigma_r
double	mean_d, sigma_d
real	asums(), asumi(), asumr()
double	asuml(), asumd()

bool	rangecheck
int	optype, opcode
int	chunk, repl, nelem, v_nargs, ch, shift, i, j
pointer	sp, sym, buf, ap, ip, op, in1, in2
include	"evvexpr.com"

pointer	stfind()
int	xvv_newtype(), strlen(), gctod(), btoi()
errchk	xvv_chtype, xvv_initop, xvv_newtype, xvv_error1, xvv_error2
errchk	zcall5, malloc

string	s_badtype "%s: illegal operand type"
define	free_ 91

begin
	call smark (sp)
	call salloc (buf, SZ_FNAME, TY_CHAR)

	# Lookup the function name in the symbol table.
	sym = stfind (ev_st, fcn)
	if (sym != NULL)
	    opcode = SYM_CODE(sym)
	else
	    opcode = 0

	# If the function named is not a standard one and the user has supplied
	# the entry point of an external function evaluation procedure, call
	# the user procedure to evaluate the function, otherwise abort.

	if (opcode <= 0)
	    if (ev_ufcn != NULL) {
		call zcall5 (ev_ufcn, ev_ufcn_data, fcn, args, nargs, out)
		if (O_TYPE(out) <= 0)
		    call xvv_error1 ("unrecognized macro or function `%s'", fcn)
		goto free_
	    } else
		call xvv_error1 ("unknown function `%s' called", fcn)

	# Range checking on functions that need it?
	rangecheck = (and (ev_flags, EV_RNGCHK) != 0)

	# Verify correct number of arguments.
	switch (opcode) {
	case F_MOD, F_REPL, F_SHIFT:
	    v_nargs = 2
	case F_MAX, F_MIN, F_ATAN, F_ATAN2, F_MEAN, F_STDDEV, F_MEDIAN:
	    v_nargs = -1
	default:
	    v_nargs = 1
	}
	if (v_nargs > 0 && nargs != v_nargs)
	    call xvv_error2 ("function `%s' requires %d arguments",
		fcn, v_nargs)
	else if (v_nargs < 0 && nargs < abs(v_nargs))
	    call xvv_error2 ("function `%s' requires at least %d arguments",
		fcn, abs(v_nargs))

	# Some functions require that the input operand be a certain type,
	# e.g. floating.  Handle the simple cases, converting input operands
	# to the desired type.

	switch (opcode) {
	case F_ACOS, F_ASIN, F_ATAN, F_ATAN2, F_COS, F_COSH, F_DEG, F_EXP,
	     F_LOG, F_LOG10, F_RAD, F_SIN, F_SINH, F_SQRT, F_TAN, F_TANH:

	    # These functions want a floating point input operand.
	    optype = TY_REAL
	    do i = 1, nargs {
		if (O_TYPE(args[i]) == TY_DOUBLE || O_TYPE(args[i]) == TY_LONG)
		    optype = TY_DOUBLE
	    }
	    do i = 1, nargs {
		if (O_TYPE(args[i]) != optype)
		    call xvv_chtype (args[i], args[i], optype)
	    }
	    call xvv_initop (out, O_LEN(args[1]), optype)

	case F_MOD, F_MIN, F_MAX, F_MEDIAN:
	    # These functions may have multiple arguments, all of which
	    # should be the same type.

	    optype = O_TYPE(args[1])
	    nelem = O_LEN(args[1])
	    do i = 2, nargs {
		optype = xvv_newtype (optype, O_TYPE(args[i]))
		if (O_LEN(args[i]) > 0)
		    if (nelem > 0)
			nelem = min (nelem, O_LEN(args[i]))
		    else if (nelem == 0)
			nelem = O_LEN(args[i])
	    }

	    do i = 1, nargs
		if (O_TYPE(args[i]) != optype)
		    call xvv_chtype (args[i], args[i], optype)

	    if (nargs == 1 && opcode == F_MEDIAN)
		nelem = 0
	    call xvv_initop (out, nelem, optype)

	case F_LEN:
	    # This function always returns an integer scalar value.
	    nelem = 0
	    optype = TY_INT
	    call xvv_initop (out, nelem, optype)

	case F_HIV, F_LOV:
	    # These functions return a scalar value.
	    nelem = 0
	    optype = O_TYPE(args[1])
	    if (optype == TY_BOOL)
		optype = TY_INT
	    call xvv_initop (out, nelem, optype)

	case F_SUM, F_MEAN, F_STDDEV:
	    # These functions require a vector argument and return a scalar
	    # value.

	    nelem = 0
	    optype = O_TYPE(args[1])
	    if (optype == TY_BOOL)
		optype = TY_INT
	    
	    if (optype == TY_DOUBLE)
		call xvv_initop (out, nelem, TY_DOUBLE)
	    else
		call xvv_initop (out, nelem, TY_REAL)

	case F_SORT, F_SHIFT:
	    # Vector to vector, no type conversions.
	    nelem = O_LEN(args[1])
	    optype = O_TYPE(args[1])
	    call xvv_initop (out, nelem, optype)

	default:
	    optype = 0
	}

	# Evaluate the function.
	ap = args[1]

	switch (opcode) {
	case F_ABS:
	    call xvv_initop (out, O_LEN(ap), O_TYPE(ap))
	    switch (O_TYPE(ap)) {

	    case TY_SHORT:
		if (O_LEN(ap) > 0) {
		    call aabss (Mems[O_VALP(ap)], Mems[O_VALP(out)],
			O_LEN(ap))
		} else
		    O_VALS(out) = abs(O_VALS(ap))

	    case TY_INT:
		if (O_LEN(ap) > 0) {
		    call aabsi (Memi[O_VALP(ap)], Memi[O_VALP(out)],
			O_LEN(ap))
		} else
		    O_VALI(out) = abs(O_VALI(ap))

	    case TY_LONG:
		if (O_LEN(ap) > 0) {
		    call aabsl (Meml[O_VALP(ap)], Meml[O_VALP(out)],
			O_LEN(ap))
		} else
		    O_VALL(out) = abs(O_VALL(ap))

	    case TY_REAL:
		if (O_LEN(ap) > 0) {
		    call aabsr (Memr[O_VALP(ap)], Memr[O_VALP(out)],
			O_LEN(ap))
		} else
		    O_VALR(out) = abs(O_VALR(ap))

	    case TY_DOUBLE:
		if (O_LEN(ap) > 0) {
		    call aabsd (Memd[O_VALP(ap)], Memd[O_VALP(out)],
			O_LEN(ap))
		} else
		    O_VALD(out) = abs(O_VALD(ap))

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_ACOS:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = acos (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = acos (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = acos (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = acos (O_VALD(ap))

	case F_ASIN:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = asin (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = asin (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = asin (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = asin (O_VALD(ap))

	case F_COS:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = cos (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = cos (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = cos (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = cos (O_VALD(ap))

	case F_COSH:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = cosh (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = cosh (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = cosh (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = cosh (O_VALD(ap))

	case F_DEG:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = RADTODEG(Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = RADTODEG (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = RADTODEG(Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = RADTODEG (O_VALD(ap))

	case F_EXP:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = exp (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = exp (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = exp (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = exp (O_VALD(ap))

	case F_LOG:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    op = O_VALP(out)
		    do i = 1, O_LEN(ap) {
			v_r = Memr[O_VALP(ap)+i-1]
			if (rangecheck && v_r <= 0)
			    Memr[op] = 0
			else
			    Memr[op] = log (v_r)
			op = op + 1
		    }
		} else {
		    v_r = O_VALR(ap)
		    if (rangecheck && v_r <= 0)
			O_VALR(out) = 0
		    else
			O_VALR(out) = log (v_r)
		}

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    op = O_VALP(out)
		    do i = 1, O_LEN(ap) {
			v_d = Memd[O_VALP(ap)+i-1]
			if (rangecheck && v_d <= 0)
			    Memd[op] = 0
			else
			    Memd[op] = log (v_d)
			op = op + 1
		    }
		} else {
		    v_d = O_VALD(ap)
		    if (rangecheck && v_d <= 0)
			O_VALD(out) = 0
		    else
			O_VALD(out) = log (v_d)
		}

	case F_LOG10:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    op = O_VALP(out)
		    do i = 1, O_LEN(ap) {
			v_r = Memr[O_VALP(ap)+i-1]
			if (rangecheck && v_r <= 0)
			    Memr[op] = 0
			else
			    Memr[op] = log10 (v_r)
			op = op + 1
		    }
		} else {
		    v_r = O_VALR(ap)
		    if (rangecheck && v_r <= 0)
			O_VALR(out) = 0
		    else
			O_VALR(out) = log10 (v_r)
		}

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    op = O_VALP(out)
		    do i = 1, O_LEN(ap) {
			v_d = Memd[O_VALP(ap)+i-1]
			if (rangecheck && v_d <= 0)
			    Memd[op] = 0
			else
			    Memd[op] = log10 (v_d)
			op = op + 1
		    }
		} else {
		    v_d = O_VALD(ap)
		    if (rangecheck && v_d <= 0)
			O_VALD(out) = 0
		    else
			O_VALD(out) = log10 (v_d)
		}

	case F_RAD:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = DEGTORAD(Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = DEGTORAD (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = DEGTORAD(Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = DEGTORAD (O_VALD(ap))

	case F_SIN:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = sin (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = sin (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = sin (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = sin (O_VALD(ap))

	case F_SINH:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = sinh (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = sinh (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = sinh (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = sinh (O_VALD(ap))

	case F_SQRT:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    op = O_VALP(out)
		    do i = 1, O_LEN(ap) {
			v_r = Memr[O_VALP(ap)+i-1]
			if (rangecheck && v_r < 0)
			    Memr[op] = 0
			else
			    Memr[op] = sqrt (v_r)
			op = op + 1
		    }
		} else {
		    v_r = O_VALR(ap)
		    if (rangecheck && v_r <= 0)
			O_VALR(out) = 0
		    else
			O_VALR(out) = sqrt (v_r)
		}

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    op = O_VALP(out)
		    do i = 1, O_LEN(ap) {
			v_d = Memd[O_VALP(ap)+i-1]
			if (rangecheck && v_d < 0)
			    Memd[op] = 0
			else
			    Memd[op] = sqrt (v_d)
			op = op + 1
		    }
		} else {
		    v_d = O_VALD(ap)
		    if (rangecheck && v_d <= 0)
			O_VALD(out) = 0
		    else
			O_VALD(out) = sqrt (v_d)
		}

	case F_TAN:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = tan (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = tan (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = tan (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = tan (O_VALD(ap))

	case F_TANH:

	    if (optype == TY_REAL) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memr[O_VALP(out)+i-1] = tanh (Memr[O_VALP(ap)+i-1])
		} else
		    O_VALR(out) = tanh (O_VALR(ap))

	    if (optype == TY_DOUBLE) 
		if (O_LEN(ap) > 0) {
		    do i = 1, O_LEN(ap)
			Memd[O_VALP(out)+i-1] = tanh (Memd[O_VALP(ap)+i-1])
		} else
		    O_VALD(out) = tanh (O_VALD(ap))


	case F_LEN:
	    # Vector length.
	    O_VALI(out) = O_LEN(ap)

	case F_HIV:
	    # High value.
	    switch (optype) {

	    case TY_SHORT:
		if (O_LEN(ap) > 0)
		    O_VALS(out) = ahivs (Mems[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALS(out) = O_VALS(ap)

	    case TY_INT:
		if (O_LEN(ap) > 0)
		    O_VALI(out) = ahivi (Memi[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALI(out) = O_VALI(ap)

	    case TY_LONG:
		if (O_LEN(ap) > 0)
		    O_VALL(out) = ahivl (Meml[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALL(out) = O_VALL(ap)

	    case TY_REAL:
		if (O_LEN(ap) > 0)
		    O_VALR(out) = ahivr (Memr[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALR(out) = O_VALR(ap)

	    case TY_DOUBLE:
		if (O_LEN(ap) > 0)
		    O_VALD(out) = ahivd (Memd[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALD(out) = O_VALD(ap)

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }
	case F_LOV:
	    # Low value.
	    switch (optype) {

	    case TY_SHORT:
		if (O_LEN(ap) > 0)
		    O_VALS(out) = alovs (Mems[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALS(out) = O_VALS(ap)

	    case TY_INT:
		if (O_LEN(ap) > 0)
		    O_VALI(out) = alovi (Memi[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALI(out) = O_VALI(ap)

	    case TY_LONG:
		if (O_LEN(ap) > 0)
		    O_VALL(out) = alovl (Meml[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALL(out) = O_VALL(ap)

	    case TY_REAL:
		if (O_LEN(ap) > 0)
		    O_VALR(out) = alovr (Memr[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALR(out) = O_VALR(ap)

	    case TY_DOUBLE:
		if (O_LEN(ap) > 0)
		    O_VALD(out) = alovd (Memd[O_VALP(ap)], O_LEN(ap))
		else
		    O_VALD(out) = O_VALD(ap)

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_SUM:
	    # Vector sum.
	    switch (optype) {

	    case TY_SHORT:
		if (O_LEN(ap) > 0)
		    v_r = asums (Mems[O_VALP(ap)], O_LEN(ap))
		else
		    v_r = O_VALS(ap)

	    case TY_INT:
		if (O_LEN(ap) > 0)
		    v_r = asumi (Memi[O_VALP(ap)], O_LEN(ap))
		else
		    v_r = O_VALI(ap)

	    case TY_LONG:
		if (O_LEN(ap) > 0)
		    v_r = asuml (Meml[O_VALP(ap)], O_LEN(ap))
		else
		    v_r = O_VALL(ap)

	    case TY_REAL:
		if (O_LEN(ap) > 0)
		    v_r = asumr (Memr[O_VALP(ap)], O_LEN(ap))
		else
		    v_r = O_VALR(ap)

	    case TY_DOUBLE:
		if (O_LEN(ap) > 0)
		    v_d = asumd (Memd[O_VALP(ap)], O_LEN(ap))
		else
		    v_d = O_VALD(ap)
	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	    if (optype == TY_DOUBLE)
		O_VALD(out) = v_d
	    else
		O_VALR(out) = v_r

	case F_MEAN, F_STDDEV:
	    # Compute the mean or standard deviation of a vector.  An optional
	    # second argument may be supplied to compute a K-sigma rejection
	    # mean and sigma.

	    if (nargs == 2) {
		if (O_LEN(args[2]) > 0)
		    call xvv_error1 ("%s: ksigma arg must be a scalar" , fcn)

		switch (O_TYPE(args[2])) {
		case TY_REAL:
		    v_r = O_VALR(args[2])
		    v_d = v_r
		case TY_DOUBLE:
		    v_d = O_VALD(args[2])
		    v_r = v_d
		default:
		    call xvv_chtype (args[2], args[2], TY_REAL)
		    v_r = O_VALR(args[2])
		    v_d = v_r
		}
	    } else {
		v_r = 0.0
		v_d = 0.0
	    }

	    switch (optype) {

	    case TY_SHORT:
		v_i = aravs (Mems[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r)

	    case TY_INT:
		v_i = aravi (Memi[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r)

	    case TY_REAL:
		v_i = aravr (Memr[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r)


	    case TY_LONG:
		v_i = aravl (Meml[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d)

	    case TY_DOUBLE:
		v_i = aravd (Memd[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d)

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	    if (opcode == F_MEAN) {
		if (O_TYPE(out) == TY_REAL)
		    O_VALR(out) = mean_r
		else
		    O_VALD(out) = mean_d
	    } else {
		if (O_TYPE(out) == TY_REAL)
		    O_VALR(out) = sigma_r
		else
		    O_VALD(out) = sigma_d
	    }

	case F_MEDIAN:
	    # Compute the median value of a vector, or the vector median
	    # of 3 or more vectors.

	    switch (nargs) {
	    case 1:
		switch (optype) {

		case TY_SHORT:
		    O_VALS(out) = ameds (Mems[O_VALP(ap)], O_LEN(ap))

		case TY_INT:
		    O_VALI(out) = amedi (Memi[O_VALP(ap)], O_LEN(ap))

		case TY_LONG:
		    O_VALL(out) = amedl (Meml[O_VALP(ap)], O_LEN(ap))

		case TY_REAL:
		    O_VALR(out) = amedr (Memr[O_VALP(ap)], O_LEN(ap))

		case TY_DOUBLE:
		    O_VALD(out) = amedd (Memd[O_VALP(ap)], O_LEN(ap))

		default:
		    call xvv_error1 (s_badtype, fcn)
		}
	    case 3:
		switch (optype) {

		case TY_SHORT:
		    call amed3s (Mems[O_VALP(args[1])],
				  Mems[O_VALP(args[2])],
				  Mems[O_VALP(args[3])],
				  Mems[O_VALP(out)], nelem)

		case TY_INT:
		    call amed3i (Memi[O_VALP(args[1])],
				  Memi[O_VALP(args[2])],
				  Memi[O_VALP(args[3])],
				  Memi[O_VALP(out)], nelem)

		case TY_LONG:
		    call amed3l (Meml[O_VALP(args[1])],
				  Meml[O_VALP(args[2])],
				  Meml[O_VALP(args[3])],
				  Meml[O_VALP(out)], nelem)

		case TY_REAL:
		    call amed3r (Memr[O_VALP(args[1])],
				  Memr[O_VALP(args[2])],
				  Memr[O_VALP(args[3])],
				  Memr[O_VALP(out)], nelem)

		case TY_DOUBLE:
		    call amed3d (Memd[O_VALP(args[1])],
				  Memd[O_VALP(args[2])],
				  Memd[O_VALP(args[3])],
				  Memd[O_VALP(out)], nelem)

		default:
		    call xvv_error1 (s_badtype, fcn)
		}
	    case 4:
		switch (optype) {

		case TY_SHORT:
		    call amed4s (Mems[O_VALP(args[1])],
				  Mems[O_VALP(args[2])],
				  Mems[O_VALP(args[3])],
				  Mems[O_VALP(args[4])],
				  Mems[O_VALP(out)], nelem)

		case TY_INT:
		    call amed4i (Memi[O_VALP(args[1])],
				  Memi[O_VALP(args[2])],
				  Memi[O_VALP(args[3])],
				  Memi[O_VALP(args[4])],
				  Memi[O_VALP(out)], nelem)

		case TY_LONG:
		    call amed4l (Meml[O_VALP(args[1])],
				  Meml[O_VALP(args[2])],
				  Meml[O_VALP(args[3])],
				  Meml[O_VALP(args[4])],
				  Meml[O_VALP(out)], nelem)

		case TY_REAL:
		    call amed4r (Memr[O_VALP(args[1])],
				  Memr[O_VALP(args[2])],
				  Memr[O_VALP(args[3])],
				  Memr[O_VALP(args[4])],
				  Memr[O_VALP(out)], nelem)

		case TY_DOUBLE:
		    call amed4d (Memd[O_VALP(args[1])],
				  Memd[O_VALP(args[2])],
				  Memd[O_VALP(args[3])],
				  Memd[O_VALP(args[4])],
				  Memd[O_VALP(out)], nelem)

		default:
		    call xvv_error1 (s_badtype, fcn)
		}
	    case 5:
		switch (optype) {

		case TY_SHORT:
		    call amed5s (Mems[O_VALP(args[1])],
				  Mems[O_VALP(args[2])],
				  Mems[O_VALP(args[3])],
				  Mems[O_VALP(args[4])],
				  Mems[O_VALP(args[5])],
				  Mems[O_VALP(out)], nelem)

		case TY_INT:
		    call amed5i (Memi[O_VALP(args[1])],
				  Memi[O_VALP(args[2])],
				  Memi[O_VALP(args[3])],
				  Memi[O_VALP(args[4])],
				  Memi[O_VALP(args[5])],
				  Memi[O_VALP(out)], nelem)

		case TY_LONG:
		    call amed5l (Meml[O_VALP(args[1])],
				  Meml[O_VALP(args[2])],
				  Meml[O_VALP(args[3])],
				  Meml[O_VALP(args[4])],
				  Meml[O_VALP(args[5])],
				  Meml[O_VALP(out)], nelem)

		case TY_REAL:
		    call amed5r (Memr[O_VALP(args[1])],
				  Memr[O_VALP(args[2])],
				  Memr[O_VALP(args[3])],
				  Memr[O_VALP(args[4])],
				  Memr[O_VALP(args[5])],
				  Memr[O_VALP(out)], nelem)

		case TY_DOUBLE:
		    call amed5d (Memd[O_VALP(args[1])],
				  Memd[O_VALP(args[2])],
				  Memd[O_VALP(args[3])],
				  Memd[O_VALP(args[4])],
				  Memd[O_VALP(args[5])],
				  Memd[O_VALP(out)], nelem)

		default:
		    call xvv_error1 (s_badtype, fcn)
		}
	    default:
		call xvv_error1 ("%s: wrong number of arguments", fcn)
	    }

	case F_REPL:
	    # Replicate an item to make a longer vector.

	    chunk = O_LEN(ap)
	    optype = O_TYPE(ap)
	    if (optype == TY_BOOL)
		optype = TY_INT

	    if (O_LEN(args[2]) > 0)
		call xvv_error1 ("%s: replication factor must be a scalar", fcn)
	    if (O_TYPE(args[2]) != TY_INT)
		call xvv_chtype (args[2], args[2], TY_INT)
	    repl = max (1, O_VALI(args[2]))

	    if (chunk <= 0)
		nelem = repl
	    else
		nelem = chunk * repl
	    call xvv_initop (out, nelem, optype)

	    switch (optype) {

	    case TY_SHORT:
		if (chunk > 0) {
		    ip = O_VALP(ap)
		    op = O_VALP(out)
		    do i = 1, repl {
			call amovs (Mems[ip], Mems[op], chunk)
			op = op + chunk
		    }
		} else
		    call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem)

	    case TY_INT:
		if (chunk > 0) {
		    ip = O_VALP(ap)
		    op = O_VALP(out)
		    do i = 1, repl {
			call amovi (Memi[ip], Memi[op], chunk)
			op = op + chunk
		    }
		} else
		    call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem)

	    case TY_LONG:
		if (chunk > 0) {
		    ip = O_VALP(ap)
		    op = O_VALP(out)
		    do i = 1, repl {
			call amovl (Meml[ip], Meml[op], chunk)
			op = op + chunk
		    }
		} else
		    call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem)

	    case TY_REAL:
		if (chunk > 0) {
		    ip = O_VALP(ap)
		    op = O_VALP(out)
		    do i = 1, repl {
			call amovr (Memr[ip], Memr[op], chunk)
			op = op + chunk
		    }
		} else
		    call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem)

	    case TY_DOUBLE:
		if (chunk > 0) {
		    ip = O_VALP(ap)
		    op = O_VALP(out)
		    do i = 1, repl {
			call amovd (Memd[ip], Memd[op], chunk)
			op = op + chunk
		    }
		} else
		    call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem)

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_SHIFT:
	    # Vector shift.
	    if (O_LEN(args[2]) > 0)
		call xvv_error1 ("%s: shift arg must be a scalar" , fcn)
	    if (O_TYPE(args[2]) != TY_INT)
		call xvv_chtype (args[2], args[2], TY_INT)
	    shift = O_VALI(args[2])

	    if (abs(shift) > nelem) {
		if (shift > 0)
		    shift = nelem
		else
		    shift = -nelem
	    }

	    switch (optype) {

	    case TY_SHORT:
		if (nelem > 0) {
		    do i = 1, nelem {
			j = i - shift
			if (j < 1)
			    j = j + nelem
			else if (j > nelem)
			    j = j - nelem
			Mems[O_VALP(out)+i-1] = Mems[O_VALP(ap)+j-1]
		    }
		} else
		    O_VALS(out) = (O_VALS(ap))

	    case TY_INT:
		if (nelem > 0) {
		    do i = 1, nelem {
			j = i - shift
			if (j < 1)
			    j = j + nelem
			else if (j > nelem)
			    j = j - nelem
			Memi[O_VALP(out)+i-1] = Memi[O_VALP(ap)+j-1]
		    }
		} else
		    O_VALI(out) = (O_VALI(ap))

	    case TY_LONG:
		if (nelem > 0) {
		    do i = 1, nelem {
			j = i - shift
			if (j < 1)
			    j = j + nelem
			else if (j > nelem)
			    j = j - nelem
			Meml[O_VALP(out)+i-1] = Meml[O_VALP(ap)+j-1]
		    }
		} else
		    O_VALL(out) = (O_VALL(ap))

	    case TY_REAL:
		if (nelem > 0) {
		    do i = 1, nelem {
			j = i - shift
			if (j < 1)
			    j = j + nelem
			else if (j > nelem)
			    j = j - nelem
			Memr[O_VALP(out)+i-1] = Memr[O_VALP(ap)+j-1]
		    }
		} else
		    O_VALR(out) = (O_VALR(ap))

	    case TY_DOUBLE:
		if (nelem > 0) {
		    do i = 1, nelem {
			j = i - shift
			if (j < 1)
			    j = j + nelem
			else if (j > nelem)
			    j = j - nelem
			Memd[O_VALP(out)+i-1] = Memd[O_VALP(ap)+j-1]
		    }
		} else
		    O_VALD(out) = (O_VALD(ap))

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_SORT:
	    # Sort a vector.
	    switch (optype) {

	    case TY_SHORT:
		if (nelem > 0)
		    call asrts (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem)
		else
		    O_VALS(out) = (O_VALS(ap))

	    case TY_INT:
		if (nelem > 0)
		    call asrti (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)
		else
		    O_VALI(out) = (O_VALI(ap))

	    case TY_LONG:
		if (nelem > 0)
		    call asrtl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem)
		else
		    O_VALL(out) = (O_VALL(ap))

	    case TY_REAL:
		if (nelem > 0)
		    call asrtr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem)
		else
		    O_VALR(out) = (O_VALR(ap))

	    case TY_DOUBLE:
		if (nelem > 0)
		    call asrtd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem)
		else
		    O_VALD(out) = (O_VALD(ap))

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_ATAN, F_ATAN2:

	    if (optype == TY_REAL) {
		if (nargs == 1) {
		    if (O_LEN(ap) > 0) {
			do i = 1, O_LEN(ap)
			    Memr[O_VALP(out)+i-1] =
				atan (Memr[O_VALP(ap)+i-1])
		    } else
			O_VALR(out) = atan (O_VALR(ap))
		} else {
		    if (O_LEN(ap) > 0) {
			do i = 1, O_LEN(ap)
			    Memr[O_VALP(out)+i-1] =
				atan2 (Memr[O_VALP(args[1])+i-1],
				       Memr[O_VALP(args[2])+i-1])
		    } else
			O_VALR(out) = atan2(O_VALR(args[1]), O_VALR(args[2]))
		}
	    }

	    if (optype == TY_DOUBLE) {
		if (nargs == 1) {
		    if (O_LEN(ap) > 0) {
			do i = 1, O_LEN(ap)
			    Memd[O_VALP(out)+i-1] =
				atan (Memd[O_VALP(ap)+i-1])
		    } else
			O_VALD(out) = atan (O_VALD(ap))
		} else {
		    if (O_LEN(ap) > 0) {
			do i = 1, O_LEN(ap)
			    Memd[O_VALP(out)+i-1] =
				atan2 (Memd[O_VALP(args[1])+i-1],
				       Memd[O_VALP(args[2])+i-1])
		    } else
			O_VALD(out) = atan2(O_VALD(args[1]), O_VALD(args[2]))
		}
	    }


	case F_MOD:
	    in1 = args[1]
	    in2 = args[2]

	    switch (optype) {

	    case TY_SHORT:
		if (O_LEN(in1) <= 0) {
		    O_VALS(out) = mod (O_VALS(in1), O_VALS(in2))
		} else if (O_LEN(in2) <= 0) {
		    call amodks (Mems[O_VALP(in1)], O_VALS(in2),
			Mems[O_VALP(out)], nelem)
		} else {
		    call amods (Mems[O_VALP(in1)], Mems[O_VALP(in2)],
			Mems[O_VALP(out)], nelem)
		}

	    case TY_INT:
		if (O_LEN(in1) <= 0) {
		    O_VALI(out) = mod (O_VALI(in1), O_VALI(in2))
		} else if (O_LEN(in2) <= 0) {
		    call amodki (Memi[O_VALP(in1)], O_VALI(in2),
			Memi[O_VALP(out)], nelem)
		} else {
		    call amodi (Memi[O_VALP(in1)], Memi[O_VALP(in2)],
			Memi[O_VALP(out)], nelem)
		}

	    case TY_LONG:
		if (O_LEN(in1) <= 0) {
		    O_VALL(out) = mod (O_VALL(in1), O_VALL(in2))
		} else if (O_LEN(in2) <= 0) {
		    call amodkl (Meml[O_VALP(in1)], O_VALL(in2),
			Meml[O_VALP(out)], nelem)
		} else {
		    call amodl (Meml[O_VALP(in1)], Meml[O_VALP(in2)],
			Meml[O_VALP(out)], nelem)
		}

	    case TY_REAL:
		if (O_LEN(in1) <= 0) {
		    O_VALR(out) = mod (O_VALR(in1), O_VALR(in2))
		} else if (O_LEN(in2) <= 0) {
		    call amodkr (Memr[O_VALP(in1)], O_VALR(in2),
			Memr[O_VALP(out)], nelem)
		} else {
		    call amodr (Memr[O_VALP(in1)], Memr[O_VALP(in2)],
			Memr[O_VALP(out)], nelem)
		}

	    case TY_DOUBLE:
		if (O_LEN(in1) <= 0) {
		    O_VALD(out) = mod (O_VALD(in1), O_VALD(in2))
		} else if (O_LEN(in2) <= 0) {
		    call amodkd (Memd[O_VALP(in1)], O_VALD(in2),
			Memd[O_VALP(out)], nelem)
		} else {
		    call amodd (Memd[O_VALP(in1)], Memd[O_VALP(in2)],
			Memd[O_VALP(out)], nelem)
		}

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_MAX:
	    switch (optype) {

	    case TY_SHORT:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem)
		    else
			O_VALS(out) = O_VALS(ap)
		} else
		    call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALS(out) = max (O_VALS(ap), O_VALS(out))
			else {
			    call amaxks (Mems[O_VALP(out)], O_VALS(ap),
				Mems[O_VALP(out)], nelem)
			}
		    } else {
			call amaxs (Mems[O_VALP(out)], Mems[O_VALP(ap)],
			    Mems[O_VALP(out)], nelem)
		    }
		}

	    case TY_INT:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem)
		    else
			O_VALI(out) = O_VALI(ap)
		} else
		    call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALI(out) = max (O_VALI(ap), O_VALI(out))
			else {
			    call amaxki (Memi[O_VALP(out)], O_VALI(ap),
				Memi[O_VALP(out)], nelem)
			}
		    } else {
			call amaxi (Memi[O_VALP(out)], Memi[O_VALP(ap)],
			    Memi[O_VALP(out)], nelem)
		    }
		}

	    case TY_LONG:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem)
		    else
			O_VALL(out) = O_VALL(ap)
		} else
		    call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALL(out) = max (O_VALL(ap), O_VALL(out))
			else {
			    call amaxkl (Meml[O_VALP(out)], O_VALL(ap),
				Meml[O_VALP(out)], nelem)
			}
		    } else {
			call amaxl (Meml[O_VALP(out)], Meml[O_VALP(ap)],
			    Meml[O_VALP(out)], nelem)
		    }
		}

	    case TY_REAL:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem)
		    else
			O_VALR(out) = O_VALR(ap)
		} else
		    call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALR(out) = max (O_VALR(ap), O_VALR(out))
			else {
			    call amaxkr (Memr[O_VALP(out)], O_VALR(ap),
				Memr[O_VALP(out)], nelem)
			}
		    } else {
			call amaxr (Memr[O_VALP(out)], Memr[O_VALP(ap)],
			    Memr[O_VALP(out)], nelem)
		    }
		}

	    case TY_DOUBLE:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem)
		    else
			O_VALD(out) = O_VALD(ap)
		} else
		    call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALD(out) = max (O_VALD(ap), O_VALD(out))
			else {
			    call amaxkd (Memd[O_VALP(out)], O_VALD(ap),
				Memd[O_VALP(out)], nelem)
			}
		    } else {
			call amaxd (Memd[O_VALP(out)], Memd[O_VALP(ap)],
			    Memd[O_VALP(out)], nelem)
		    }
		}

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_MIN:
	    switch (optype) {

	    case TY_SHORT:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem)
		    else
			O_VALS(out) = O_VALS(ap)
		} else
		    call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALS(out) = min (O_VALS(ap), O_VALS(out))
			else {
			    call aminks (Mems[O_VALP(out)], O_VALS(ap),
				Mems[O_VALP(out)], nelem)
			}
		    } else {
			call amins (Mems[O_VALP(out)], Mems[O_VALP(ap)],
			    Mems[O_VALP(out)], nelem)
		    }
		}

	    case TY_INT:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem)
		    else
			O_VALI(out) = O_VALI(ap)
		} else
		    call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALI(out) = min (O_VALI(ap), O_VALI(out))
			else {
			    call aminki (Memi[O_VALP(out)], O_VALI(ap),
				Memi[O_VALP(out)], nelem)
			}
		    } else {
			call amini (Memi[O_VALP(out)], Memi[O_VALP(ap)],
			    Memi[O_VALP(out)], nelem)
		    }
		}

	    case TY_LONG:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem)
		    else
			O_VALL(out) = O_VALL(ap)
		} else
		    call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALL(out) = min (O_VALL(ap), O_VALL(out))
			else {
			    call aminkl (Meml[O_VALP(out)], O_VALL(ap),
				Meml[O_VALP(out)], nelem)
			}
		    } else {
			call aminl (Meml[O_VALP(out)], Meml[O_VALP(ap)],
			    Meml[O_VALP(out)], nelem)
		    }
		}

	    case TY_REAL:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem)
		    else
			O_VALR(out) = O_VALR(ap)
		} else
		    call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALR(out) = min (O_VALR(ap), O_VALR(out))
			else {
			    call aminkr (Memr[O_VALP(out)], O_VALR(ap),
				Memr[O_VALP(out)], nelem)
			}
		    } else {
			call aminr (Memr[O_VALP(out)], Memr[O_VALP(ap)],
			    Memr[O_VALP(out)], nelem)
		    }
		}

	    case TY_DOUBLE:
		# Copy the first argument.
		ap = args[1]
		if (O_LEN(ap) <= 0) {
		    if (O_LEN(out) > 0)
			call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem)
		    else
			O_VALD(out) = O_VALD(ap)
		} else
		    call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem)

		# Process the second and remaining arguments.
		do i = 2, nargs {
		    ap = args[i]
		    if (O_LEN(ap) <= 0) {
			if (O_LEN(out) <= 0)
			    O_VALD(out) = min (O_VALD(ap), O_VALD(out))
			else {
			    call aminkd (Memd[O_VALP(out)], O_VALD(ap),
				Memd[O_VALP(out)], nelem)
			}
		    } else {
			call amind (Memd[O_VALP(out)], Memd[O_VALP(ap)],
			    Memd[O_VALP(out)], nelem)
		    }
		}

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_BOOL:
	    nelem = 0
	    if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR)
		nelem = O_LEN(ap)
	    call xvv_initop (out, nelem, TY_BOOL)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALI(ap)
		else
		    call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_CHAR:
		ch = O_VALC(ap)
		O_VALI(out) = btoi (ch == 'y' || ch == 'Y')


	    case TY_SHORT:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = btoi (O_VALS(ap) != 0)
		else {
		    v_s = 0
		    call abneks (Mems[O_VALP(ap)], v_s, Memi[O_VALP(out)],
			nelem)
		}

	    case TY_INT:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = btoi (O_VALI(ap) != 0)
		else {
		    v_i = 0
		    call abneki (Memi[O_VALP(ap)], v_i, Memi[O_VALP(out)],
			nelem)
		}

	    case TY_LONG:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = btoi (O_VALL(ap) != 0)
		else {
		    v_l = 0
		    call abnekl (Meml[O_VALP(ap)], v_l, Memi[O_VALP(out)],
			nelem)
		}

	    case TY_REAL:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = btoi (O_VALR(ap) != 0.0)
		else {
		    v_r = 0.0
		    call abnekr (Memr[O_VALP(ap)], v_r, Memi[O_VALP(out)],
			nelem)
		}

	    case TY_DOUBLE:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = btoi (O_VALD(ap) != 0.0D0)
		else {
		    v_d = 0.0D0
		    call abnekd (Memd[O_VALP(ap)], v_d, Memi[O_VALP(out)],
			nelem)
		}


	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_SHORT:
	    nelem = 0
	    if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR)
		nelem = O_LEN(ap)
	    call xvv_initop (out, nelem, TY_SHORT)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		if (O_LEN(ap) <= 0)
		    O_VALS(out) = O_VALI(ap)
		else
		    call achtis (Memi[O_VALP(ap)], Mems[O_VALP(out)], nelem)

	    case TY_CHAR:
		ip = O_VALP(ap)
		if (gctod (Memc, ip, v_d) <= 0)
		    O_VALS(out) = 0
		else
		    O_VALS(out) = v_d


	    case TY_SHORT:
		if (O_LEN(ap) <= 0)
		    O_VALS(out) = O_VALS(ap)
		else
		    call achtss (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_INT:
		if (O_LEN(ap) <= 0)
		    O_VALS(out) = O_VALI(ap)
		else
		    call achtis (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_LONG:
		if (O_LEN(ap) <= 0)
		    O_VALS(out) = O_VALL(ap)
		else
		    call achtls (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_REAL:
		if (O_LEN(ap) <= 0)
		    O_VALS(out) = O_VALR(ap)
		else
		    call achtrs (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_DOUBLE:
		if (O_LEN(ap) <= 0)
		    O_VALS(out) = O_VALD(ap)
		else
		    call achtds (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem)


	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_INT:
	    nelem = 0
	    if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR)
		nelem = O_LEN(ap)
	    call xvv_initop (out, nelem, TY_INT)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALI(ap)
		else
		    call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_CHAR:
		ip = O_VALP(ap)
		if (gctod (Memc, ip, v_d) <= 0)
		    O_VALI(out) = 0
		else
		    O_VALI(out) = v_d


	    case TY_SHORT:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALS(ap)
		else
		    call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_INT:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALI(ap)
		else
		    call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_LONG:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALL(ap)
		else
		    call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_REAL:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALR(ap)
		else
		    call achtri (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_DOUBLE:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALD(ap)
		else
		    call achtdi (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem)


	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_LONG:
	    nelem = 0
	    if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR)
		nelem = O_LEN(ap)
	    call xvv_initop (out, nelem, TY_LONG)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		if (O_LEN(ap) <= 0)
		    O_VALL(out) = O_VALI(ap)
		else
		    call amovi (Memi[O_VALP(ap)], Meml[O_VALP(out)], nelem)

	    case TY_CHAR:
		ip = O_VALP(ap)
		if (gctod (Memc, ip, v_d) <= 0)
		    O_VALL(out) = 0
		else
		    O_VALL(out) = v_d


	    case TY_SHORT:
		if (O_LEN(ap) <= 0)
		    O_VALL(out) = O_VALS(ap)
		else
		    call achtsl (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_INT:
		if (O_LEN(ap) <= 0)
		    O_VALL(out) = O_VALI(ap)
		else
		    call achtil (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_LONG:
		if (O_LEN(ap) <= 0)
		    O_VALL(out) = O_VALL(ap)
		else
		    call achtll (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_REAL:
		if (O_LEN(ap) <= 0)
		    O_VALL(out) = O_VALR(ap)
		else
		    call achtrl (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_DOUBLE:
		if (O_LEN(ap) <= 0)
		    O_VALL(out) = O_VALD(ap)
		else
		    call achtdl (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem)


	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_NINT:
	    nelem = 0
	    if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR)
		nelem = O_LEN(ap)
	    call xvv_initop (out, nelem, TY_INT)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALI(ap)
		else
		    call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_CHAR:
		ip = O_VALP(ap)
		if (gctod (Memc, ip, v_d) <= 0)
		    O_VALI(out) = 0
		else
		    O_VALI(out) = nint (v_d)


	    case TY_SHORT:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALS(ap)
		else
		    call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_INT:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALI(ap)
		else
		    call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem)

	    case TY_LONG:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = O_VALL(ap)
		else
		    call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem)



	    case TY_REAL:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = nint (O_VALR(ap))
		else {
		    do i = 1, nelem
			Memi[O_VALP(out)+i-1] = nint (Memr[O_VALP(ap)+i-1])
		}

	    case TY_DOUBLE:
		if (O_LEN(ap) <= 0)
		    O_VALI(out) = nint (O_VALD(ap))
		else {
		    do i = 1, nelem
			Memi[O_VALP(out)+i-1] = nint (Memd[O_VALP(ap)+i-1])
		}


	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_REAL:
	    nelem = 0
	    if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR)
		nelem = O_LEN(ap)
	    call xvv_initop (out, nelem, TY_REAL)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		if (O_LEN(ap) <= 0)
		    O_VALR(out) = O_VALI(ap)
		else
		    call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem)

	    case TY_CHAR:
		ip = O_VALP(ap)
		if (gctod (Memc, ip, v_d) <= 0)
		    O_VALR(out) = 0
		else
		    O_VALR(out) = v_d


	    case TY_SHORT:
		if (O_LEN(ap) <= 0)
		    O_VALR(out) = O_VALS(ap)
		else
		    call achtsr (Mems[O_VALP(ap)], Memr[O_VALP(out)], nelem)

	    case TY_INT:
		if (O_LEN(ap) <= 0)
		    O_VALR(out) = O_VALI(ap)
		else
		    call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem)

	    case TY_LONG:
		if (O_LEN(ap) <= 0)
		    O_VALR(out) = O_VALL(ap)
		else
		    call achtlr (Meml[O_VALP(ap)], Memr[O_VALP(out)], nelem)

	    case TY_REAL:
		if (O_LEN(ap) <= 0)
		    O_VALR(out) = O_VALR(ap)
		else
		    call achtrr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem)

	    case TY_DOUBLE:
		if (O_LEN(ap) <= 0)
		    O_VALR(out) = O_VALD(ap)
		else
		    call achtdr (Memd[O_VALP(ap)], Memr[O_VALP(out)], nelem)


	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_DOUBLE:
	    nelem = 0
	    if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR)
		nelem = O_LEN(ap)
	    call xvv_initop (out, nelem, TY_DOUBLE)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		if (O_LEN(ap) <= 0)
		    O_VALD(out) = O_VALI(ap)
		else
		    call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem)

	    case TY_CHAR:
		ip = O_VALP(ap)
		if (gctod (Memc, ip, v_d) <= 0)
		    O_VALD(out) = 0
		else
		    O_VALD(out) = v_d


	    case TY_SHORT:
		if (O_LEN(ap) <= 0)
		    O_VALD(out) = O_VALS(ap)
		else
		    call achtsd (Mems[O_VALP(ap)], Memd[O_VALP(out)], nelem)

	    case TY_INT:
		if (O_LEN(ap) <= 0)
		    O_VALD(out) = O_VALI(ap)
		else
		    call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem)

	    case TY_LONG:
		if (O_LEN(ap) <= 0)
		    O_VALD(out) = O_VALL(ap)
		else
		    call achtld (Meml[O_VALP(ap)], Memd[O_VALP(out)], nelem)

	    case TY_REAL:
		if (O_LEN(ap) <= 0)
		    O_VALD(out) = O_VALR(ap)
		else
		    call achtrd (Memr[O_VALP(ap)], Memd[O_VALP(out)], nelem)

	    case TY_DOUBLE:
		if (O_LEN(ap) <= 0)
		    O_VALD(out) = O_VALD(ap)
		else
		    call achtdd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem)


	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	case F_STR:
	    optype = TY_CHAR
	    if (O_TYPE(ap) == TY_CHAR)
		nelem = strlen (O_VALC(ap))
	    else
		nelem = MAX_DIGITS
	    call xvv_initop (out, nelem, TY_CHAR)

	    switch (O_TYPE(ap)) {
	    case TY_BOOL:
		call sprintf (O_VALC(out), nelem, "%b")
		    call pargi (O_VALI(ap))
	    case TY_CHAR:
		call sprintf (O_VALC(out), nelem, "%s")
		    call pargstr (O_VALC(ap))

	    case TY_SHORT:
		call sprintf (O_VALC(out), nelem, "%d")
		    call pargs (O_VALS(ap))

	    case TY_INT:
		call sprintf (O_VALC(out), nelem, "%d")
		    call pargi (O_VALI(ap))

	    case TY_LONG:
		call sprintf (O_VALC(out), nelem, "%d")
		    call pargl (O_VALL(ap))


	    case TY_REAL:
		call sprintf (O_VALC(out), nelem, "%g")
		    call pargr (O_VALR(ap))

	    case TY_DOUBLE:
		call sprintf (O_VALC(out), nelem, "%g")
		    call pargd (O_VALD(ap))

	    default:
		call xvv_error1 (s_badtype, fcn)
	    }

	default:
	    call xvv_error ("callfcn: unknown function type")
	}

free_
	# Free any storage used by the argument list operands.
	do i = 1, nargs
	    call xvv_freeop (args[i])

	call sfree (sp)
end


# XVV_STARTARGLIST -- Allocate an argument list descriptor to receive
# arguments as a function call is parsed.  We are called with either
# zero or one arguments.  The argument list descriptor is pointed to by
# a ficticious operand.  The descriptor itself contains a count of the
# number of arguments, an array of pointers to the operand structures,
# as well as storage for the operand structures.  The operands must be
# stored locally since the parser will discard its copy of the operand
# structure for each argument as the associated grammar rule is reduced.

procedure xvv_startarglist (arg, out)

pointer	arg			#I pointer to first argument, or NULL
pointer	out			#I output operand pointing to arg descriptor

pointer	ap
errchk	xvv_initop

begin
	call xvv_initop (out, LEN_ARGSTRUCT, TY_STRUCT)
	ap = O_VALP(out)

	if (arg == NULL)
	    A_NARGS(ap) = 0
	else {
	    A_NARGS(ap) = 1
	    A_ARGP(ap,1) = A_OPS(ap)
	    YYMOVE (arg, A_OPS(ap))
	}
end


# XVV_ADDARG -- Add an argument to the argument list for a function call.

procedure xvv_addarg (arg, arglist, out)

pointer	arg			#I pointer to argument to be added
pointer	arglist			#I pointer to operand pointing to arglist
pointer	out			#I output operand pointing to arg descriptor

pointer	ap, o
int	nargs

begin
	ap = O_VALP(arglist)

	nargs = A_NARGS(ap) + 1
	A_NARGS(ap) = nargs
	if (nargs > MAX_ARGS)
	    call xvv_error ("too many function arguments")

	o = A_OPS(ap) + ((nargs - 1) * LEN_OPERAND)
	A_ARGP(ap,nargs) = o
	YYMOVE (arg, o)

	YYMOVE (arglist, out)
end


# XVV_ERROR1 -- Take an error action, formatting an error message with one
# format string plus one string argument.

procedure xvv_error1 (fmt, arg)

char	fmt[ARB]		#I printf format string
char	arg[ARB]		#I string argument

pointer	sp, buf

begin
	call smark (sp)
	call salloc (buf, SZ_LINE, TY_CHAR)

	call sprintf (Memc[buf], SZ_LINE, fmt)
	    call pargstr (arg)

	call xvv_error (Memc[buf])
	call sfree (sp)
end


# XVV_ERROR2 -- Take an error action, formatting an error message with one
# format string plus one string argument and one integer argument.

procedure xvv_error2 (fmt, arg1, arg2)

char	fmt[ARB]		#I printf format string
char	arg1[ARB]		#I string argument
int	arg2			#I integer argument

pointer	sp, buf

begin
	call smark (sp)
	call salloc (buf, SZ_LINE, TY_CHAR)

	call sprintf (Memc[buf], SZ_LINE, fmt)
	    call pargstr (arg1)
	    call pargi (arg2)

	call xvv_error (Memc[buf])
	call sfree (sp)
end


# XVV_ERROR -- Take an error action, given an error message string as the
# sole argument.

procedure xvv_error (errmsg)

char	errmsg[ARB]			#I error message

begin
	call error (1, errmsg)
end


# XVV_CHTYPE -- Change the datatype of an operand.  The input and output
# operands may be the same.

procedure xvv_chtype (o1, o2, dtype)

pointer	o1		#I input operand
pointer	o2		#I output operand
int	dtype		#I new datatype

short	v_s
int	v_i
long	v_l
real	v_r
double	v_d
pointer	vp, ip, op
bool	float, freeval
int	old_type, nelem, ch

pointer	coerce()
int	sizeof(), btoi(), gctod()
string	s_badtype "chtype: invalid operand type"

begin
	old_type = O_TYPE(o1)
	nelem = O_LEN(o1)

	# No type conversion needed?
	if (old_type == dtype) {
	    if (o1 != o2) {
		if (nelem <= 0)
		    YYMOVE (o1, o2)
		else {
		    call xvv_initop (o2, nelem, old_type)
		    call amovc (O_VALC(o1), O_VALC(o2), nelem * sizeof(dtype))
		}
	    }
	    return
	}

	if (nelem <= 0) {
	    # Scalar input operand.

	    O_TYPE(o2) = dtype
	    O_LEN(o2) = 0
	    float = false

	    # Read the old value into a local variable of type long or double.
	    switch (old_type) {
	    case TY_BOOL:
		v_l = O_VALI(o1)
	    case TY_CHAR:
		v_l = 0  # null string?

	    case TY_SHORT:
		v_l = O_VALS(o1)

	    case TY_INT:
		v_l = O_VALI(o1)

	    case TY_LONG:
		v_l = O_VALL(o1)


	    case TY_REAL:
		v_d = O_VALR(o1)
		float = true

	    case TY_DOUBLE:
		v_d = O_VALD(o1)
		float = true

	    default:
		call xvv_error (s_badtype)
	    }

	    # Set the value of the output operand.
	    switch (dtype) {
	    case TY_BOOL:
		if (float)
		    O_VALI(o2) = btoi (v_d != 0)
		else
		    O_VALI(o2) = btoi (v_l != 0)
	    case TY_CHAR:
		call xvv_initop (o2, MAX_DIGITS, TY_CHAR)
		if (float) {
		    call sprintf (O_VALC(o2), MAX_DIGITS, "%g")
			call pargd (v_d)
		} else {
		    call sprintf (O_VALC(o2), MAX_DIGITS, "%d")
			call pargl (v_l)
		}

	    case TY_SHORT:
		if (float)
		    O_VALS(o2) = v_d
		else
		    O_VALS(o2) = v_l

	    case TY_INT:
		if (float)
		    O_VALI(o2) = v_d
		else
		    O_VALI(o2) = v_l

	    case TY_LONG:
		if (float)
		    O_VALL(o2) = v_d
		else
		    O_VALL(o2) = v_l


	    case TY_REAL:
		if (float)
		    O_VALR(o2) = v_d
		else
		    O_VALR(o2) = v_l

	    case TY_DOUBLE:
		if (float)
		    O_VALD(o2) = v_d
		else
		    O_VALD(o2) = v_l

	    default:
		call xvv_error (s_badtype)
	    }

	} else {
	    # Vector input operand.

	    # Save a pointer to the input operand data vector, to avoid it
	    # getting clobbered if O1 and O2 are the same operand.

	    vp = O_VALP(o1)

	    # If we have a char string input operand the output numeric
	    # operand can only be a scalar.  If we have a char string output
	    # operand nelem is the length of the string.

	    if (old_type == TY_CHAR)
		nelem = 0
	    else if (dtype == TY_CHAR)
		nelem = MAX_DIGITS

	    # Initialize the output operand O2.  The freeval flag is cleared
	    # cleared to keep the initop from freeing the input operand array,
	    # inherited when the input operand is copied (or when the input
	    # and output operands are the same).  We free the old operand
	    # array manually below.

	    if (o1 != o2)
		YYMOVE (o1, o2)
	    freeval = (and (O_FLAGS(o1), O_FREEVAL) != 0)
	    O_FLAGS(o2) = and (O_FLAGS(o2), not(O_FREEVAL))
	    call xvv_initop (o2, nelem, dtype)

	    # Write output value.
	    switch (dtype) {
	    case TY_BOOL:
		if (old_type == TY_CHAR) {
		    ch = Memc[vp]
		    O_VALI(o2) = btoi (ch == 'y' || ch == 'Y')
		} else {
		    switch (old_type) {

		    case TY_SHORT:
			v_s = 0
			call abneks (Mems[vp], v_s, Memi[O_VALP(o2)], nelem)

		    case TY_INT:
			v_i = 0
			call abneki (Memi[vp], v_i, Memi[O_VALP(o2)], nelem)

		    case TY_LONG:
			v_l = 0
			call abnekl (Meml[vp], v_l, Memi[O_VALP(o2)], nelem)

		    case TY_REAL:
			v_r = 0.0
			call abnekr (Memr[vp], v_r, Memi[O_VALP(o2)], nelem)

		    case TY_DOUBLE:
			v_d = 0.0D0
			call abnekd (Memd[vp], v_d, Memi[O_VALP(o2)], nelem)

		    default:
			call xvv_error (s_badtype)
		    }
		}

	    case TY_CHAR:
		call xvv_error (s_badtype)

	    case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE:
		switch (old_type) {
		case TY_BOOL:
		    op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR)
		    call achti (Memi[vp], Memc[op], nelem, dtype)
		case TY_CHAR:
		    ip = vp
		    if (gctod (Memc, ip, v_d) <= 0)
			v_d = 0
		    switch (dtype) {

		    case TY_SHORT:
			O_VALS(o2) = v_d

		    case TY_INT:
			O_VALI(o2) = v_d

		    case TY_LONG:
			O_VALL(o2) = v_d

		    case TY_REAL:
			O_VALR(o2) = v_d

		    case TY_DOUBLE:
			O_VALD(o2) = v_d

		    }

		case TY_SHORT:
		    op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR)
		    call achts (Mems[vp], Memc[op], nelem, dtype)

		case TY_INT:
		    op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR)
		    call achti (Memi[vp], Memc[op], nelem, dtype)

		case TY_LONG:
		    op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR)
		    call achtl (Meml[vp], Memc[op], nelem, dtype)

		case TY_REAL:
		    op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR)
		    call achtr (Memr[vp], Memc[op], nelem, dtype)

		case TY_DOUBLE:
		    op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR)
		    call achtd (Memd[vp], Memc[op], nelem, dtype)

		default:
		    call xvv_error (s_badtype)
		}
	    default:
		call xvv_error (s_badtype)
	    }

	    # Free old operand value.
	    if (freeval)
		call mfree (vp, old_type)
	}
end


# XVV_INITOP -- Initialize an operand, providing storage for an operand value
# of the given size and type.

procedure xvv_initop (o, o_len, o_type)

pointer	o		#I pointer to operand structure
int	o_len		#I length of operand (zero if scalar)
int	o_type		#I datatype of operand

begin
	O_LEN(o) = 0
	call xvv_makeop (o, o_len, o_type)
end


# XVV_MAKEOP -- Set up the operand structure.  If the operand structure has
# already been initialized and array storage allocated, free the old array.

procedure xvv_makeop (o, o_len, o_type)

pointer	o		#I pointer to operand structure
int	o_len		#I length of operand (zero if scalar)
int	o_type		#I datatype of operand

errchk	malloc

begin
	# Free old array storage if any.
	if (O_TYPE(o) != 0 && O_LEN(o) > 0)
	    if (and (O_FLAGS(o), O_FREEVAL) != 0) {
		if (O_TYPE(o) == TY_BOOL)
		    call mfree (O_VALP(o), TY_INT)
		else
		    call mfree (O_VALP(o), O_TYPE(o))
		O_LEN(o) = 0
	    }

	# Set new operand type.
	O_TYPE(o) = o_type

	# Allocate array storage if nonscalar operand.
	if (o_len > 0) {
	    if (o_type == TY_BOOL)
		call malloc (O_VALP(o), o_len, TY_INT)
	    else
		call malloc (O_VALP(o), o_len, o_type)
	    O_LEN(o) = o_len
	}

	O_FLAGS(o) = O_FREEVAL
end


# XVV_FREEOP -- Reinitialize an operand structure, i.e., free any associated
# array storage and clear the operand datatype field, but do not free the
# operand structure itself (which may be only a segment of an array and not
# a separately allocated structure).

procedure xvv_freeop (o)

pointer	o		#I pointer to operand structure

begin
	# Free old array storage if any.
	if (O_TYPE(o) != 0 && O_LEN(o) > 0)
	    if (and (O_FLAGS(o), O_FREEVAL) != 0) {
		if (O_TYPE(o) == TY_BOOL)
		    call mfree (O_VALP(o), TY_INT)
		else
		    call mfree (O_VALP(o), O_TYPE(o))
		O_LEN(o) = 0
	    }

	# Either free operand struct or clear the operand type to mark
	# operand invalid.

	if (and (O_FLAGS(o), O_FREEOP) != 0)
	    call mfree (o, TY_STRUCT)
	else
	    O_TYPE(o) = 0
end


# XVV_LOADSYMBOLS -- Load a list of symbol names into a symbol table.  Each
# symbol is tagged with an integer code corresponding to its sequence number
# in the symbol list.

pointer procedure xvv_loadsymbols (s)

char	s[ARB]			#I symbol list "|sym1|sym2|...|"

int	delim, symnum, ip
pointer	sp, symname, st, sym, op
pointer	stopen(), stenter()

begin
	call smark (sp)
	call salloc (symname, SZ_FNAME, TY_CHAR)

	st = stopen ("evvexpr", LEN_INDEX, LEN_STAB, LEN_SBUF)
	delim = s[1]
	symnum = 0

	for (ip=2;  s[ip] != EOS;  ip=ip+1) {
	    op = symname
	    while (s[ip] != delim && s[ip] != EOS) {
		Memc[op] = s[ip]
		op = op + 1
		ip = ip + 1
	    }
	    Memc[op] = EOS
	    symnum = symnum + 1

	    if (op > symname && IS_ALPHA(Memc[symname])) {
		sym = stenter (st, Memc[symname], LEN_SYM)
		SYM_CODE(sym) = symnum
	    }
	}

	call sfree (sp)
	return (st)
end


# XVV_NULL -- Return a null value to be used when a computation cannot be
# performed and range checking is enabled.  Perhaps we should permit a user
# specified value here, however this doesn't really work in an expression
# evaluator since the value generated may be used in subsequent calculations
# and hence may change.  If more careful treatment of out of range values
# is needed a conditional expression can be used in which case the value
# we return here is ignored (but still needed to avoid a hardware exception
# when computing a vector).


short procedure xvv_nulls (ignore)
short	ignore			#I ignored
begin
	return (0)
end

int procedure xvv_nulli (ignore)
int	ignore			#I ignored
begin
	return (0)
end

long procedure xvv_nulll (ignore)
long	ignore			#I ignored
begin
	return (0)
end

real procedure xvv_nullr (ignore)
real	ignore			#I ignored
begin
	return (0.0)
end

double procedure xvv_nulld (ignore)
double	ignore			#I ignored
begin
	return (0.0D0)
end

define	YYNPROD		39
define	YYLAST		303
# line	1 "/iraf/iraf/lib/yaccpar.x"
# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

# Parser for yacc output, translated to the IRAF SPP language.  The contents
# of this file form the bulk of the source of the parser produced by Yacc.
# Yacc recognizes several macros in the yaccpar input source and replaces
# them as follows:
#	A	user suppled "global" definitions and declarations
# 	B	parser tables
# 	C	user supplied actions (reductions)
# The remainder of the yaccpar code is not changed.

define	yystack_	10		# statement labels for gotos
define	yynewstate_	20
define	yydefault_	30
define	yyerrlab_	40
define	yyabort_	50

define	YYFLAG		(-1000)		# defs used in user actions
define	YYERROR		goto yyerrlab_
define	YYACCEPT	return (OK)
define	YYABORT		return (ERR)


# YYPARSE -- Parse the input stream, returning OK if the source is
# syntactically acceptable (i.e., if compilation is successful),
# otherwise ERR.  The parameters YYMAXDEPTH and YYOPLEN must be
# supplied by the caller in the %{ ... %} section of the Yacc source.
# The token value stack is a dynamically allocated array of operand
# structures, with the length and makeup of the operand structure being
# application dependent.

int procedure yyparse (fd, yydebug, yylex)

int	fd			# stream to be parsed
bool	yydebug			# print debugging information?
int	yylex()			# user-supplied lexical input function
extern	yylex()

short	yys[YYMAXDEPTH]		# parser stack -- stacks tokens
pointer	yyv			# pointer to token value stack
pointer	yyval			# value returned by action
pointer	yylval			# value of token
int	yyps			# token stack pointer
pointer	yypv			# value stack pointer
int	yychar			# current input token number
int	yyerrflag		# error recovery flag
int	yynerrs			# number of errors

short	yyj, yym		# internal variables
pointer	yysp, yypvt
short	yystate, yyn
int	yyxi, i
errchk	salloc, yylex


# XVV_PARSE -- SPP/Yacc parser for the evaluation of an expression passed as
# a text string.  Expression evaluation is carried out as the expression is
# parsed, rather than being broken into separate compile and execute stages.
# There is only one statement in this grammar, the expression.  Our function
# is to reduce an expression to a single value of type bool, string, int,
# or real.

pointer	ap
bool	streq()
errchk	zcall3, xvv_error1, xvv_unop, xvv_binop, xvv_boolop
errchk	xvv_quest, xvv_callfcn, xvv_addarg
include	"evvexpr.com"

short	yyexca[96]
data	(yyexca(i),i=  1,  8)	/  -1,   1,   0,  -1,  -2,   0,  -1,   5/
data	(yyexca(i),i=  9, 16)	/  40,  33,  -2,   5,  -1,   6,  40,  32/
data	(yyexca(i),i= 17, 24)	/  -2,   6,  -1,  76, 269,   0, 270,   0/
data	(yyexca(i),i= 25, 32)	/ 271,   0, 283,   0,  -2,  22,  -1,  77/
data	(yyexca(i),i= 33, 40)	/ 269,   0, 270,   0, 271,   0, 283,   0/
data	(yyexca(i),i= 41, 48)	/  -2,  23,  -1,  78, 269,   0, 270,   0/
data	(yyexca(i),i= 49, 56)	/ 271,   0, 283,   0,  -2,  24,  -1,  79/
data	(yyexca(i),i= 57, 64)	/ 269,   0, 270,   0, 271,   0, 283,   0/
data	(yyexca(i),i= 65, 72)	/  -2,  25,  -1,  80, 272,   0, 273,   0/
data	(yyexca(i),i= 73, 80)	/ 274,   0,  -2,  26,  -1,  81, 272,   0/
data	(yyexca(i),i= 81, 88)	/ 273,   0, 274,   0,  -2,  27,  -1,  82/
data	(yyexca(i),i= 89, 96)	/ 272,   0, 273,   0, 274,   0,  -2,  28/
short	yyact[303]
data	(yyact(i),i=  1,  8)	/  15,  16,  17,  18,  19,  20,  33,  86/
data	(yyact(i),i=  9, 16)	/  26,  27,  28,  30,  32,  31,  21,  22/
data	(yyact(i),i= 17, 24)	/  62,  23,  24,  25,  19,  34,  29,  15/
data	(yyact(i),i= 25, 32)	/  16,  17,  18,  19,  20,  33,  38,  26/
data	(yyact(i),i= 33, 40)	/  27,  28,  30,  32,  31,  21,  22,  60/
data	(yyact(i),i= 41, 48)	/  23,  24,  25,  12,  11,  29,  15,  16/
data	(yyact(i),i= 49, 56)	/  17,  18,  19,  20,  12,   2,  26,  27/
data	(yyact(i),i= 57, 64)	/  28,  30,  32,  31,  12,   1,   0,  23/
data	(yyact(i),i= 65, 72)	/  24,  25,   0,  14,  29,  15,  16,  17/
data	(yyact(i),i= 73, 80)	/  18,  19,  20,   0,   0,  26,  27,  28/
data	(yyact(i),i= 81, 88)	/  30,  32,  31,   0,  15,  16,  17,  18/
data	(yyact(i),i= 89, 96)	/  19,  20,   0,  29,  26,  27,  28,  15/
data	(yyact(i),i= 97,104)	/  16,  17,  18,  19,  20,  15,  16,  17/
data	(yyact(i),i=105,112)	/  18,  19,  29,  17,  18,  19,   4,   0/
data	(yyact(i),i=113,120)	/  84,   0,  40,  85,   0,   0,   0,  35/
data	(yyact(i),i=121,128)	/  36,  37,   0,  39,   0,   0,   0,   0/
data	(yyact(i),i=129,136)	/   0,   0,  41,  42,  43,  44,  45,  46/
data	(yyact(i),i=137,144)	/  47,  48,  49,  50,  51,  52,  53,  54/
data	(yyact(i),i=145,152)	/  55,  56,  57,  58,  59,  61,   0,  63/
data	(yyact(i),i=153,160)	/  65,  66,  67,  68,  69,  70,  71,  72/
data	(yyact(i),i=161,168)	/  73,  74,  75,  76,  77,  78,  79,  80/
data	(yyact(i),i=169,176)	/  81,  82,  83,   0,   0,   0,   0,   0/
data	(yyact(i),i=177,184)	/   0,   0,   0,   0,   0,   0,   0,   0/
data	(yyact(i),i=185,192)	/   0,   0,   0,   0,   0,   0,   0,   0/
data	(yyact(i),i=193,200)	/   0,   0,   0,   0,   0,   0,  89,  90/
data	(yyact(i),i=201,208)	/  87,  88,   0,   0,   0,   0,   0,   0/
data	(yyact(i),i=209,216)	/   0,   0,   0,   0,   0,   0,   0,   0/
data	(yyact(i),i=217,224)	/   0,   0,   0,   0,   0,   0,   0,   0/
data	(yyact(i),i=225,232)	/   0,   0,   0,   0,   0,   0,   0,   0/
data	(yyact(i),i=233,240)	/   0,   0,   0,   0,  15,  16,  17,  18/
data	(yyact(i),i=241,248)	/  19,  20,  33,   0,  26,  27,  28,  30/
data	(yyact(i),i=249,256)	/  32,  31,  21,  22,   0,  23,  24,  25/
data	(yyact(i),i=257,264)	/   0,   0,  29,   0,   5,   6,  64,   0/
data	(yyact(i),i=265,272)	/   0,   8,   0,   0,   3,   5,   6,   0/
data	(yyact(i),i=273,280)	/   0,   0,   8,   0,   0,   5,   6,   0/
data	(yyact(i),i=281,288)	/   9,   0,   8,  13,  10,   7,   0,   0/
data	(yyact(i),i=289,296)	/   0,   9,   0,   0,   0,  10,   7,   0/
data	(yyact(i),i=297,303)	/   0,   9,   0,   0,   0,  10,   7/
short	yypact[91]
data	(yypact(i),i=  1,  8)	/  12,-1000,  23,-1000,-238,-1000,-1000,-236/
data	(yypact(i),i=  9, 16)	/  20,  20,  20, -10,  20,-1000,-1000,-1000/
data	(yypact(i),i= 17, 24)	/-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/
data	(yypact(i),i= 25, 32)	/-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/
data	(yypact(i),i= 33, 40)	/-1000,-1000,-1000,-245,-245,-245,  20, -25/
data	(yypact(i),i= 41, 48)	/   3,   3,   3,   3,   3,   3,   3,   3/
data	(yypact(i),i= 49, 56)	/   3,   3,   3,   3,   3,   3,   3,   3/
data	(yypact(i),i= 57, 64)	/   3,   3,   3,   3,  71,-238,-1000,-238/
data	(yypact(i),i= 65, 72)	/-1000,-156,-156,-245,-245,-1000,-160,-215/
data	(yypact(i),i= 73, 80)	/-215,-192,-192,-192,-166,-166,-166,-166/
data	(yypact(i),i= 81, 88)	/-177,-177,-177,-261,-1000,-1000,-1000,   3/
data	(yypact(i),i= 89, 91)	/   3,-238,-238/
short	yypgo[7]
data	(yypgo(i),i=  1,  7)	/   0,  61,  53, 110, 114,  44,  39/
short	yyr1[39]
data	(yyr1(i),i=  1,  8)	/   0,   1,   1,   2,   2,   3,   3,   3/
data	(yyr1(i),i=  9, 16)	/   3,   3,   3,   3,   3,   3,   3,   3/
data	(yyr1(i),i= 17, 24)	/   3,   3,   3,   3,   3,   3,   3,   3/
data	(yyr1(i),i= 25, 32)	/   3,   3,   3,   3,   3,   3,   3,   3/
data	(yyr1(i),i= 33, 39)	/   5,   5,   6,   6,   6,   4,   4/
short	yyr2[39]
data	(yyr2(i),i=  1,  8)	/   0,   2,   1,   1,   4,   1,   1,   2/
data	(yyr2(i),i=  9, 16)	/   2,   2,   2,   4,   4,   4,   4,   4/
data	(yyr2(i),i= 17, 24)	/   4,   4,   4,   4,   4,   4,   4,   4/
data	(yyr2(i),i= 25, 32)	/   4,   4,   4,   4,   4,   7,   4,   3/
data	(yyr2(i),i= 33, 39)	/   1,   1,   0,   1,   4,   0,   2/
short	yychk[91]
data	(yychk(i),i=  1,  8)	/-1000,  -1,  -2, 256,  -3, 257, 258, 282/
data	(yychk(i),i=  9, 16)	/ 262, 277, 281,  -5,  40, 260,  44, 261/
data	(yychk(i),i= 17, 24)	/ 262, 263, 264, 265, 266, 275, 276, 278/
data	(yychk(i),i= 25, 32)	/ 279, 280, 269, 270, 271, 283, 272, 274/
data	(yychk(i),i= 33, 40)	/ 273, 267, 257,  -3,  -3,  -3,  40,  -3/
data	(yychk(i),i= 41, 48)	/  -4,  -4,  -4,  -4,  -4,  -4,  -4,  -4/
data	(yychk(i),i= 49, 56)	/  -4,  -4,  -4,  -4,  -4,  -4,  -4,  -4/
data	(yychk(i),i= 57, 64)	/  -4,  -4,  -4,  -4,  -6,  -3,  41,  -3/
data	(yychk(i),i= 65, 72)	/ 259,  -3,  -3,  -3,  -3,  -3,  -3,  -3/
data	(yychk(i),i= 73, 80)	/  -3,  -3,  -3,  -3,  -3,  -3,  -3,  -3/
data	(yychk(i),i= 81, 88)	/  -3,  -3,  -3,  -3,  41,  44, 268,  -4/
data	(yychk(i),i= 89, 91)	/  -4,  -3,  -3/
short	yydef[91]
data	(yydef(i),i=  1,  8)	/   0,  -2,   0,   2,   3,  -2,  -2,   0/
data	(yydef(i),i=  9, 16)	/   0,   0,   0,   0,   0,   1,  37,  37/
data	(yydef(i),i= 17, 24)	/  37,  37,  37,  37,  37,  37,  37,  37/
data	(yydef(i),i= 25, 32)	/  37,  37,  37,  37,  37,  37,  37,  37/
data	(yydef(i),i= 33, 40)	/  37,  37,   7,   8,   9,  10,  34,   0/
data	(yydef(i),i= 41, 48)	/   0,   0,   0,   0,   0,   0,   0,   0/
data	(yydef(i),i= 49, 56)	/   0,   0,   0,   0,   0,   0,   0,   0/
data	(yydef(i),i= 57, 64)	/   0,   0,   0,   0,   0,  35,  31,   4/
data	(yydef(i),i= 65, 72)	/  38,  11,  12,  13,  14,  15,  16,  17/
data	(yydef(i),i= 73, 80)	/  18,  19,  20,  21,  -2,  -2,  -2,  -2/
data	(yydef(i),i= 81, 88)	/  -2,  -2,  -2,   0,  30,  37,  37,   0/
data	(yydef(i),i= 89, 91)	/   0,  36,  29/

begin
	call smark (yysp)
	call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT)

	# Initialization.  The first element of the dynamically allocated
	# token value stack (yyv) is used for yyval, the second for yylval,
	# and the actual stack starts with the third element.

	yystate = 0
	yychar = -1
	yynerrs = 0
	yyerrflag = 0
	yyps = 0
	yyval = yyv
	yylval = yyv + YYOPLEN
	yypv = yylval

yystack_
	# SHIFT -- Put a state and value onto the stack.  The token and
	# value stacks are logically the same stack, implemented as two
	# separate arrays.

	if (yydebug) {
	    call printf ("state %d, char 0%o\n")
		call pargs (yystate)
		call pargi (yychar)
	}
	yyps = yyps + 1
	yypv = yypv + YYOPLEN
	if (yyps > YYMAXDEPTH) {
	    call sfree (yysp)
	    call eprintf ("yacc stack overflow\n")
	    return (ERR)
	}
	yys[yyps] = yystate
	YYMOVE (yyval, yypv)

yynewstate_
	# Process the new state.
	yyn = yypact[yystate+1]

	if (yyn <= YYFLAG)
	    goto yydefault_			# simple state

	# The variable "yychar" is the lookahead token.
	if (yychar < 0) {
	    yychar = yylex (fd, yylval)
	    if (yychar < 0)
		yychar = 0
	}
	yyn = yyn + yychar
	if (yyn < 0 || yyn >= YYLAST)
	    goto yydefault_

	yyn = yyact[yyn+1]
	if (yychk[yyn+1] == yychar) {		# valid shift
	    yychar = -1
	    YYMOVE (yylval, yyval)
	    yystate = yyn
	    if (yyerrflag > 0)
		yyerrflag = yyerrflag - 1
	    goto yystack_
	}

yydefault_
	# Default state action.

	yyn = yydef[yystate+1]
	if (yyn == -2) {
	    if (yychar < 0) {
		yychar = yylex (fd, yylval)
		if (yychar < 0)
		    yychar = 0
	    }

	    # Look through exception table.
	    yyxi = 1
	    while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate))
		yyxi = yyxi + 2
	    for (yyxi=yyxi+2;  yyexca[yyxi] >= 0;  yyxi=yyxi+2) {
		if (yyexca[yyxi] == yychar)
		    break
	    }

	    yyn = yyexca[yyxi+1]
	    if (yyn < 0) {
		call sfree (yysp)
		return (OK)			# ACCEPT -- all done
	    }
	}


	# SYNTAX ERROR -- resume parsing if possible.

	if (yyn == 0) {
	    switch (yyerrflag) {
	    case 0, 1, 2:
		if (yyerrflag == 0) {		# brand new error
		    call eprintf ("syntax error\n")
yyerrlab_
		    yynerrs = yynerrs + 1
		    # fall through...
		}

	    # case 1:
	    # case 2: incompletely recovered error ... try again
		yyerrflag = 3

		# Find a state where "error" is a legal shift action.
		while (yyps >= 1) {
		    yyn = yypact[yys[yyps]+1] + YYERRCODE
		    if ((yyn >= 0) && (yyn < YYLAST) &&
			(yychk[yyact[yyn+1]+1] == YYERRCODE)) {
			    # Simulate a shift of "error".
			    yystate = yyact[yyn+1]
			    goto yystack_
		    }
		    yyn = yypact[yys[yyps]+1]

		    # The current yyps has no shift on "error", pop stack.
		    if (yydebug) {
			call printf ("error recovery pops state %d, ")
			    call pargs (yys[yyps])
			call printf ("uncovers %d\n")
			    call pargs (yys[yyps-1])
		    }
		    yyps = yyps - 1
		    yypv = yypv - YYOPLEN
		}

		# ABORT -- There is no state on the stack with an error shift.
yyabort_
		call sfree (yysp)
		return (ERR)


	    case 3: # No shift yet; clobber input char.

		if (yydebug) {
		    call printf ("error recovery discards char %d\n")
			call pargi (yychar)
		}

		if (yychar == 0)
		    goto yyabort_		# don't discard EOF, quit
		yychar = -1
		goto yynewstate_		# try again in the same state
	    }
	}


	# REDUCE -- Reduction by production yyn.

	if (yydebug) {
	    call printf ("reduce %d\n")
		call pargs (yyn)
	}
	yyps  = yyps - yyr2[yyn+1]
	yypvt = yypv
	yypv  = yypv - yyr2[yyn+1] * YYOPLEN
	YYMOVE (yypv + YYOPLEN, yyval)
	yym   = yyn

	# Consult goto table to find next state.
	yyn = yyr1[yyn+1]
	yyj = yypgo[yyn+1] + yys[yyps] + 1
	if (yyj >= YYLAST)
	    yystate = yyact[yypgo[yyn+1]+1]
	else {
	    yystate = yyact[yyj+1]
	    if (yychk[yystate+1] != -yyn)
		yystate = yyact[yypgo[yyn+1]+1]
	}

	# Perform action associated with the grammar rule, if any.
	switch (yym) {
	    
case 1:
# line 266 "evvexpr.y"
{
			# Normal exit.  Move the final expression value operand
			# into the operand structure pointed to by the global
			# variable ev_oval.

			YYMOVE (yypvt-YYOPLEN, ev_oval)
			call sfree (yysp)
			return (OK)
		}
case 2:
# line 275 "evvexpr.y"
{
			call error (1, "syntax error")
		}
case 3:
# line 280 "evvexpr.y"
{
			YYMOVE (yypvt, yyval)
		}
case 4:
# line 283 "evvexpr.y"
{
			YYMOVE (yypvt, yyval)
			call xvv_freeop (yypvt-3*YYOPLEN)
		}
case 5:
# line 289 "evvexpr.y"
{
			# Numeric constant.
			YYMOVE (yypvt, yyval)
		    }
case 6:
# line 293 "evvexpr.y"
{
			# The boolean constants "yes" and "no" are implemented
			# as reserved operands.

			call xvv_initop (yyval, 0, TY_BOOL)
			if (streq (O_VALC(yypvt), "yes")) {
			    O_VALI(yyval) = YES
			} else if (streq (O_VALC(yypvt), "no")) {
			    O_VALI(yyval) = NO
			} else if (ev_getop != NULL) {
			    call zcall3 (ev_getop,ev_getop_data, O_VALC(yypvt), yyval)
			    if (O_TYPE(yyval) <= 0)
				call xvv_error1 ("unknown operand `%s'",
				    O_VALC(yypvt))
			} else
			    call xvv_error1 ("illegal operand `%s'", O_VALC(yypvt))
			call xvv_freeop (yypvt)
		    }
case 7:
# line 311 "evvexpr.y"
{
			# e.g., @"param"
			if (ev_getop != NULL) {
			    call zcall3 (ev_getop,ev_getop_data, O_VALC(yypvt), yyval)
			    if (O_TYPE(yyval) <= 0)
				call xvv_error1 ("unknown operand `%s'",
				    O_VALC(yypvt-YYOPLEN))
			} else
			    call xvv_error1 ("illegal operand `%s'", O_VALC(yypvt))
			call xvv_freeop (yypvt)
		    }
case 8:
# line 322 "evvexpr.y"
{
			# Unary arithmetic minus.
			call xvv_unop (MINUS, yypvt, yyval)
		    }
case 9:
# line 326 "evvexpr.y"
{
			# Logical not.
			call xvv_unop (LNOT, yypvt, yyval)
		    }
case 10:
# line 330 "evvexpr.y"
{
			# Boolean not.
			call xvv_unop (BNOT, yypvt, yyval)
		    }
case 11:
# line 334 "evvexpr.y"
{
			# Addition.
			call xvv_binop (PLUS, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 12:
# line 338 "evvexpr.y"
{
			# Subtraction.
			call xvv_binop (MINUS, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 13:
# line 342 "evvexpr.y"
{
			# Multiplication.
			call xvv_binop (STAR, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 14:
# line 346 "evvexpr.y"
{
			# Division.
			call xvv_binop (SLASH, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 15:
# line 350 "evvexpr.y"
{
			# Exponentiation.
			call xvv_binop (EXPON, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 16:
# line 354 "evvexpr.y"
{
			# Concatenate two operands.
			call xvv_binop (CONCAT, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 17:
# line 358 "evvexpr.y"
{
			# Logical and.
			call xvv_boolop (LAND, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 18:
# line 362 "evvexpr.y"
{
			# Logical or.
			call xvv_boolop (LOR, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 19:
# line 366 "evvexpr.y"
{
			# Boolean and.
			call xvv_binop (BAND, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 20:
# line 370 "evvexpr.y"
{
			# Boolean or.
			call xvv_binop (BOR, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 21:
# line 374 "evvexpr.y"
{
			# Boolean xor.
			call xvv_binop (BXOR, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 22:
# line 378 "evvexpr.y"
{
			# Boolean less than.
			call xvv_boolop (LT, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 23:
# line 382 "evvexpr.y"
{
			# Boolean greater than.
			call xvv_boolop (GT, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 24:
# line 386 "evvexpr.y"
{
			# Boolean less than or equal.
			call xvv_boolop (LE, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 25:
# line 390 "evvexpr.y"
{
			# Boolean greater than or equal.
			call xvv_boolop (GE, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 26:
# line 394 "evvexpr.y"
{
			# Boolean equal.
			call xvv_boolop (EQ, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 27:
# line 398 "evvexpr.y"
{
			# String pattern-equal.
			call xvv_boolop (SE, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 28:
# line 402 "evvexpr.y"
{
			# Boolean not equal.
			call xvv_boolop (NE, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 29:
# line 406 "evvexpr.y"
{
			# Conditional expression.
			call xvv_quest (yypvt-6*YYOPLEN, yypvt-3*YYOPLEN, yypvt, yyval)
		    }
case 30:
# line 410 "evvexpr.y"
{
			# Call an intrinsic or external function.
			ap = O_VALP(yypvt-YYOPLEN)
			call xvv_callfcn (O_VALC(yypvt-3*YYOPLEN),
			    A_ARGP(ap,1), A_NARGS(ap), yyval)
			call xvv_freeop (yypvt-3*YYOPLEN)
			call xvv_freeop (yypvt-YYOPLEN)
		    }
case 31:
# line 418 "evvexpr.y"
{
			YYMOVE (yypvt-YYOPLEN, yyval)
		    }
case 32:
# line 424 "evvexpr.y"
{
			YYMOVE (yypvt, yyval)
		    }
case 33:
# line 427 "evvexpr.y"
{
			if (O_TYPE(yypvt) != TY_CHAR)
			    call error (1, "illegal function name")
			YYMOVE (yypvt, yyval)
		    }
case 34:
# line 435 "evvexpr.y"
{
			# Empty.
			call xvv_startarglist (NULL, yyval)
		    }
case 35:
# line 439 "evvexpr.y"
{
			# First arg; start a nonnull list.
			call xvv_startarglist (yypvt, yyval)
		    }
case 36:
# line 443 "evvexpr.y"
{
			# Add an argument to an existing list.
			call xvv_addarg (yypvt, yypvt-3*YYOPLEN, yyval)
		    }	}

	goto yystack_				# stack new state and value
end