Initial commit

106 files changed, 21116 insertions, 0 deletions

diff --git a/sys/fmtio/README b/sys/fmtio/README
new file mode 100644
index 00000000..08d8bd28
--- /dev/null
+++ b/sys/fmtio/README
@@ -0,0 +1,6 @@
+This directory contains the IRAF Formatted I/O (FMTIO) routines.  The FMTIO
+package includes the string utilities (str___), character utilities (chr___),
+encode/decode primitives (ctod, itoc, etc.), and the high level SCAN and
+PRINTF routines.  This is a full implementation of FMTIO (excluding the
+language dependent features that will be provided when the full language
+becomes available).
diff --git a/sys/fmtio/cctoc.x b/sys/fmtio/cctoc.x
new file mode 100644
index 00000000..6ad6ea8f
--- /dev/null
+++ b/sys/fmtio/cctoc.x
@@ -0,0 +1,67 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<chars.h>
+
+define	OCTAL		8
+
+# CCTOC -- Convert a character constant into the ASCII value of the character
+# represented.  A character constant may be any whitespace delimited
+# character, backslash escaped character, or a string of the form 'c', '\c',
+# or '\nnn'.  The following are all legal character constants:
+# 
+# 	c	'c'	'\n'	'\07'	\	\\	\n
+# 
+# The number of characters successfully converted is returned as the function
+# value.
+
+int procedure cctoc (str, ip, cval)
+
+char	str[ARB]		# input string
+int	ip			# index into input string
+char	cval			# receives character value
+
+long	lval
+bool	eat_tick
+int	n, junk, ip_save
+int	stridx(), gctol()
+include	"escchars.inc"
+
+begin
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+	ip_save = ip
+
+	if (str[ip] == SQUOTE) {				# '...'
+	    eat_tick = true
+	    ip = ip + 1
+	} else
+	    eat_tick = false
+
+	if (str[ip] == ESCAPE && str[ip+1] != EOS) {		# \...
+	    ip = ip + 1
+	    n = stridx (str[ip], escape_chars)			# \c
+	    if (n > 0) {
+		cval = mapped_chars[n]
+		ip = ip + 1
+	    } else if (IS_DIGIT (str[ip])) {			# \nnn
+		junk = gctol (str, ip, lval, -OCTAL)
+		cval = lval
+	    } else if (eat_tick) {				# '\c'
+		cval = str[ip]
+		ip = ip + 1
+	    } else
+		cval = ESCAPE					# \ alone
+
+	} else if (str[ip] != EOS) {
+	    cval = str[ip]					# c or 'c'
+	    ip = ip + 1
+
+	} else if (eat_tick)
+	    cval = SQUOTE					# 'EOS
+
+	if (eat_tick && str[ip] == SQUOTE)
+	    ip = ip + 1
+
+	return (ip - ip_save)
+end
diff --git a/sys/fmtio/chdeposit.x b/sys/fmtio/chdeposit.x
new file mode 100644
index 00000000..0e0dc961
--- /dev/null
+++ b/sys/fmtio/chdeposit.x
@@ -0,0 +1,17 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# CHDEPOSIT -- Deposit a character in a string at the offset OP.  Bump OP,
+# taking care not to overflow the string.
+
+procedure chdeposit (ch, str, maxch, op)
+
+char	ch			# character to be deposited
+char	str[ARB]		# output string
+int	maxch			# maxch chars in output string
+int	op			# pointer into output string
+
+begin
+	str[op] = ch
+	if (op < maxch)
+	    op = op + 1
+end
diff --git a/sys/fmtio/chfetch.x b/sys/fmtio/chfetch.x
new file mode 100644
index 00000000..f9ab4197
--- /dev/null
+++ b/sys/fmtio/chfetch.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# CHFETCH -- Return the next character from a string, bump pointer.
+
+char procedure chfetch (str, ip, ch)
+
+char	str[ARB], ch
+int	ip
+
+begin
+	ch = str[ip]
+	if (ch != EOS)
+	    ip = ip + 1
+
+	return (ch)
+end
diff --git a/sys/fmtio/chrlwr.x b/sys/fmtio/chrlwr.x
new file mode 100644
index 00000000..a0050207
--- /dev/null
+++ b/sys/fmtio/chrlwr.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# CHRLWR -- Convert char to lower case
+
+char procedure chrlwr (ch)
+
+char	ch
+
+begin
+	if (IS_UPPER (ch))
+	    return (TO_LOWER (ch))
+	else
+	    return (ch)
+end
diff --git a/sys/fmtio/chrupr.x b/sys/fmtio/chrupr.x
new file mode 100644
index 00000000..53f6582e
--- /dev/null
+++ b/sys/fmtio/chrupr.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# CHRUPR -- Convert char to upper case.
+
+char procedure chrupr (ch)
+
+char	ch
+
+begin
+	if (IS_LOWER (ch))
+	    return (TO_UPPER (ch))
+	else
+	    return (ch)
+end
diff --git a/sys/fmtio/clprintf.x b/sys/fmtio/clprintf.x
new file mode 100644
index 00000000..d456c0a5
--- /dev/null
+++ b/sys/fmtio/clprintf.x
@@ -0,0 +1,17 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# CLPRINTF -- Format and output a string to the CL to set the value of the
+# named (string or struct type) parameter.  For example, to set a cursor
+# struct parameter,  "clprintf (param, "%8.4f %8.4f %c")" ...
+
+procedure clprintf (param, format_string)
+
+char	param[ARB], format_string[ARB]
+
+begin
+	call putline (CLOUT, param)
+	call putline (CLOUT, " = \"")
+	call fprntf (CLOUT, format_string, CL_PARAM)
+end
diff --git a/sys/fmtio/clscan.x b/sys/fmtio/clscan.x
new file mode 100644
index 00000000..563954d3
--- /dev/null
+++ b/sys/fmtio/clscan.x
@@ -0,0 +1,32 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# CLSCAN -- Begin a scan of the value of a CL parameter
+
+int procedure clscan (param)
+
+char	param[ARB]
+int	getline(), strncmp(), clc_fetch()
+include	"scan.com"
+errchk	clreqpar, getline
+
+begin
+	# Fetch the value of a CL parameter.  First look in the parameter
+	# cache, querying the CL for the value of the parameter only if it
+	# is not found in the cache.
+
+	if (clc_fetch (param, sc_scanbuf, SZ_SCANBUF) == ERR) {
+	    call clreqpar (param)
+	    if (getline (CLIN, sc_scanbuf) == EOF)
+		return (EOF)
+	}
+
+	# Check for EOF on a list structured parameter; if not EOF initialize
+	# formatted input for the clget procedures.
+
+	if (strncmp ("EOF\n", sc_scanbuf, 4) == 0)
+	    return (EOF)
+	else {
+	    call reset_scan()
+	    return (OK)
+	}
+end
diff --git a/sys/fmtio/ctocc.x b/sys/fmtio/ctocc.x
new file mode 100644
index 00000000..b2f4197a
--- /dev/null
+++ b/sys/fmtio/ctocc.x
@@ -0,0 +1,64 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+define	OCTAL		8
+
+# CTOCC -- Convert a character into a printable character constant.
+# Printable characters are output as is.  The standard control characters
+# (newline, tab, etc.) are output as escape sequences (\n, \t, etc.).
+# Other control characters are output in the form '^X'.  Characters which
+# are neither printable nor standard control characters are output as
+# octal constants of the form '\DDD'.  Note that the ouput string is not
+# enclosed in ticks ('\n', etc.), because the generated character constant
+# might appear in a quoted string (or someplace other than an explicit
+# character constant).
+
+int procedure ctocc (ch, outstr, maxch)
+
+char	ch			# character to be output
+char	outstr[ARB]		# output string
+int	maxch			# max chars out
+
+int	op, n
+int	stridx()
+define	output 	{outstr[op]=$1;op=op+1;if(op>maxch)goto overflow_}
+define	overflow_ 99
+include	"escchars.inc"
+
+begin
+	op = 1
+
+	if (maxch > 0) {
+	    if (IS_PRINT(ch)) {				# output char as is
+		output (ch)
+	    } else if (IS_CNTRL (ch)) {
+		n = stridx (ch, mapped_chars)
+		if (n > 0) {				# '\c'
+		    output ('\\')
+		    output (escape_chars[n])
+		} else {
+		    output ('^')			# control chars
+		    output (ch + 'A' - 1)
+		}
+
+	    } else {					# '\nnn' 
+		# Always output 3 digits so that strings like \0405 (a blank
+		# followed by a `5') can be interpreted during the reverse
+		# encoding operation.
+
+		output ('\\')
+		output (TO_DIGIT (mod (ch / 0100B, 010B)))
+		output (TO_DIGIT (mod (ch / 0010B, 010B)))
+		output (TO_DIGIT (mod (ch / 0001B, 010B)))
+	    }
+	}
+
+	outstr[op] = EOS
+	return (op-1)
+
+overflow_
+	outstr[1] = '?'					# no room, print '?'
+	outstr[2] = EOS
+	return (1)
+end
diff --git a/sys/fmtio/ctod.x b/sys/fmtio/ctod.x
new file mode 100644
index 00000000..06b1d351
--- /dev/null
+++ b/sys/fmtio/ctod.x
@@ -0,0 +1,154 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+include <ctype.h>
+
+define	DECIMAL		10
+
+.help
+.nf _________________________________________________________________________
+Attempt to convert a string to a number:  nchar = ctod (str, ip, dval)
+The index IP must be set to the first character to be scanned upon entry
+to CTOD, and will be left pointing at the first untranslated character.
+
+If the string is successfully converted, the number of characters used
+is returned as the function argument.  If the string (or the first few
+characters of the string) cannot be interpreted as a number, zero will be
+returned.  Note that even if no numeric characters are encountered, the
+index IP may be incremented, if leading whitespace is encountered (but the
+return value N will still be zero).
+
+The upper case string "INDEF" is a legal real number, as is "." (. == 0.0).
+Sexagesimal numbers are permitted.  Excess digits of precision are ignored.
+Out of range exponents are detected, and result in the value INDEF being
+returned (this is not considered an ERROR condition).  Any number with an
+exponent greater than or equal to MAX_EXPONENT is interpreted as INDEF,
+regardless of the mantissa.  The number need not contain a decimal point.
+
+Lexical form of a sexagesimal number:
+
+	D :==	[0-9]		numeric digit
+	E :==	[eEdD]		exponent symbol
+
+	({D}*:)+{D}*(".")?{D}*({E}("+"|"-")?{D}+)?
+
+The format for sexagesimal numbers is fairly permissive.  Any number of
+colon fields are permitted, with any number of digits (including zero) in
+each field.  An exponent may occur at the end of a sexagesimal number.
+Leading zeros may be omitted in the fields.
+.endhelp ____________________________________________________________________
+
+
+# CTOD -- Convert a string to double precision real.
+
+int procedure ctod (str, ip, dval)
+
+char	str[ARB]		# string to be converted
+int	ip			# pointer into str
+double	dval			# receives binary value
+
+bool	neg
+char	dig[MAX_DIGITS]
+int	j, e, vexp, ip_start
+long	expon
+double	value, scalar
+int	strncmp(), gctol(), stridx()
+
+begin
+	while (IS_WHITE (str[ip]))			# skip whitespace
+	    ip = ip + 1
+	ip_start = ip
+	dval = INDEFD
+				
+	if (strncmp (str[ip], "INDEF", 5) == 0) {	# check for "INDEF"
+	    for (ip=ip+5;  IS_ALPHA (str[ip]) || str[ip] == '_';  ip=ip+1)
+		;
+	    return (ip - ip_start)
+	}
+
+	neg = (str[ip] == '-')				# check for sign
+	if (neg || str[ip] == '+')
+	    ip = ip + 1
+
+	while (str[ip] == '0')				# ignore leading zeros
+	    ip = ip + 1
+
+	dval = 0.0
+	scalar = 60.0
+
+	repeat {					# accumulate digits
+	    for (j=1;  j <= MAX_DIGITS && IS_DIGIT(str[ip]);  j=j+1) {
+		dig[j] = str[ip]
+		ip = ip + 1
+	    }
+
+	    for (e=0;  IS_DIGIT(str[ip]);  e=e+1)	# ignore the rest
+		ip = ip + 1
+
+	    scalar = scalar / 60.0
+	    if (ip > 1 && stridx(str[ip], "'\":dDhHmMsS")>0) {  # sexagesimal?
+		ip = ip + 1
+		dig[j] = EOS
+		value = 0.0				# convert digits
+		for (j=1;  dig[j] != EOS;  j=j+1)
+		    value = value * 10.0D0 + TO_INTEG (dig[j])
+		dval = dval + value * scalar * (10.0 ** e)
+
+		while (str[ip] != EOS && 		# multiple spaces etc
+		    stridx(str[ip]," '\":dDhHmMsS")>0)
+		        ip = ip + 1
+	    } else
+		break
+	}
+
+	if (str[ip] == '.') {				# check for a fraction
+	    ip = ip + 1
+	    if (j == 1)					# skip leading zeros
+		while (str[ip] == '0') {		# if str = "0.00ddd"
+		    ip = ip + 1
+		    e = e - 1
+		}
+	    for (;  j <= MAX_DIGITS && IS_DIGIT(str[ip]);  j=j+1) {
+		dig[j] = str[ip]
+		e = e - 1				# adjust scale factor
+		ip = ip + 1
+	    }						# discard insignificant
+	    while (IS_DIGIT (str[ip]))			# fractional digits
+		ip = ip + 1
+	}
+
+	dig[j] = EOS					# no more digits
+	vexp = e + j - 1				# save for ovfl check
+	if (ip == ip_start)				# not a number?
+	    return (0)
+
+	value = 0.0					# convert the mantissa
+	for (j=1;  dig[j] != EOS;  j=j+1)
+	    value = value * 10.0D0 + TO_INTEG (dig[j])
+	if (e != 0)
+	    value = value * (10.0D0 ** e)		# scale by e
+
+
+	# Check for exponent.
+
+	j = ip
+	expon = 0
+	if (stridx (str[ip], "eEdD") > 0) {		# exponent?
+	    ip = ip + 1
+	    if (gctol (str, ip, expon, DECIMAL) <= 0) {
+		ip = j					# return chars
+		expon = 0
+	    }
+	}
+
+	if (abs(vexp+expon) > MAX_EXPONENTD)		# check for overflow
+	    return (ip - ip_start)
+
+	dval = dval + value * scalar
+	if (expon != 0)
+	    dval = dval * (10.0D0 ** expon)		# apply exponent
+
+	if (neg)
+	    dval = -dval
+	return (ip - ip_start)
+end
diff --git a/sys/fmtio/ctoi.x b/sys/fmtio/ctoi.x
new file mode 100644
index 00000000..ce791222
--- /dev/null
+++ b/sys/fmtio/ctoi.x
@@ -0,0 +1,48 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# CTOI -- Simple character to integer (decimal radix).
+
+int procedure ctoi (str, ip, ival)
+
+char	str[ARB]	# decimal encoded numeric string
+int	ip		# starting index in string (input/output)
+int	ival		# decoded integer value (output)
+
+bool	neg
+int	sum
+int	ip_start
+int	strncmp()
+
+begin
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+	ip_start = ip
+
+	# Check for "INDEF".
+	if (str[ip] == 'I')
+	    if (strncmp (str[ip], "INDEF", 5) == 0)
+		if (!IS_ALNUM (str[ip+5])) {
+		    ival = INDEFI
+		    ip = ip + 5
+		    return (5)
+		}
+
+	neg = (str[ip] == '-')
+	if (neg)
+	    ip = ip + 1
+
+	sum = 0
+	while (IS_DIGIT (str[ip])) {
+	    sum = sum * 10 + TO_INTEG (str[ip])
+	    ip = ip + 1
+	}
+
+	if (neg)
+	    ival = -sum
+	else
+	    ival = sum
+
+	return (ip - ip_start)
+end
diff --git a/sys/fmtio/ctol.x b/sys/fmtio/ctol.x
new file mode 100644
index 00000000..a83d1384
--- /dev/null
+++ b/sys/fmtio/ctol.x
@@ -0,0 +1,52 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# CTOL -- Simple character to long integer (decimal radix).
+
+int procedure ctol (str, ip, lval)
+
+char	str[ARB]	# decimal encoded numeric string
+int	ip		# starting index in string (input/output)
+long	lval		# decoded integer value (output)
+
+bool	neg
+long	sum
+int	ip_start
+int	strncmp()
+
+begin
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+	ip_start = ip
+
+	# Check for "INDEF".
+	if (str[ip] == 'I')
+	    if (strncmp (str[ip], "INDEF", 5) == 0)
+		if (!IS_ALNUM (str[ip+5])) {
+		    lval = INDEFL
+		    ip = ip + 5
+		    return (5)
+		}
+
+	neg = false
+	if (IS_DIGIT (str[ip+1]))
+	    if (str[ip] == '-') {
+		neg = true
+		ip = ip + 1
+	    } else if (str[ip] == '+')
+		ip = ip + 1
+
+	sum = 0
+	while (IS_DIGIT (str[ip])) {
+	    sum = sum * 10 + TO_INTEG (str[ip])
+	    ip = ip + 1
+	}
+
+	if (neg)
+	    lval = -sum
+	else
+	    lval = sum
+
+	return (ip - ip_start)
+end
diff --git a/sys/fmtio/ctor.x b/sys/fmtio/ctor.x
new file mode 100644
index 00000000..a8fd16f1
--- /dev/null
+++ b/sys/fmtio/ctor.x
@@ -0,0 +1,34 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+
+# CTOR -- Character to real.  The number of characters converted to produce
+# the output number is returned as the function value (0 is returned if the
+# input cannot be interpreted as a number).
+
+int procedure ctor (str, ip, rval)
+
+char	str[ARB]		# input string to be decoded
+int	ip			# first character to be used in string
+real	rval			# decoded real value (output)
+
+double	dval
+int	nchars, expon
+int	ctod()
+
+begin
+	nchars = ctod (str, ip, dval)
+	if (abs(dval) > EPSILOND)
+	    expon = int (log10 (abs(dval)))
+	else
+	    expon = 0
+
+	if (IS_INDEFD(dval))
+	    rval = INDEFR
+	else if (expon > MAX_EXPONENTR)
+	    return (0)
+	else
+	    rval = dval
+	
+	return (nchars)
+end
diff --git a/sys/fmtio/ctotok.x b/sys/fmtio/ctotok.x
new file mode 100644
index 00000000..333984c9
--- /dev/null
+++ b/sys/fmtio/ctotok.x
@@ -0,0 +1,167 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <ctotok.h>
+include <ctype.h>
+include	<chars.h>
+include	<lexnum.h>
+
+.help CTOTOK 2 "String Utilities"
+.ih ___________________________________________________________________________
+NAME
+CTOTOK -- Return next token from input text.
+.ih
+USAGE
+token = ctotok (string, ip, outstr, maxch)
+.ih
+PARAMETERS
+The integer value returned by CTOTOK is a code identifying the type of token
+matched.  The predefined tokens recognized by CTOTOK (defined in <ctotok.h>)
+are the following:
+.ls
+.nf
+TOK_IDENTIFER		[a-zA-Z][a-zA-Z0-9_$.]*
+TOK_NUMBER		[0-9][-+0-9.:xXa-fA-F]*
+TOK_OPERATOR		[-+*/!@#$%^&=`~<>?|]+
+TOK_PUNCTUATION		[,:;(){}] or "[", "]"
+TOK_STRING		"..."
+TOK_CHARCON		'.'
+TOK_EOS			end of string
+TOK_NEWLINE		end of line
+TOK_UNKNOWN		control characters
+.fi
+.le
+.ls string
+The EOS delimited character string from which the next token is to be
+extracted.
+.le
+.ls ip
+On input, contains the index of the first character to be scanned
+(initially 1).  On output, left pointing at the first character after
+the current token, unless EOS was reached.  IP should normally be left
+alone in successive calls to CTOTOK.
+.le
+.ls outstr
+String to receive the extracted token value.
+.le
+.ls maxch
+Capacity of the "outstr" buffer.
+.le
+.ih
+DESCRIPTION
+CTOTOK is useful for many simple parsing tasks.  For example, it is used
+by the HELP utility to parse the ".help" directive, which consists of
+a list of keywords (delimited by commas), followed by two strings or
+identifiers.
+
+CTOTOK selects the type of token to be extracted based on the token
+class membership of the first nonwhitespace character encountered.
+Characters are copied to the output string until a character not belonging
+to the current class is encountered (or until MAXCH characters have been
+output).  Whitespace is always a token delimiter.  The integer code for the
+corresponding token is returned as the function value.
+
+An identifier is a letter followed by any number of letters, digits, or
+one of the characters [_.$].  A number is any legal integer, octal,
+hexadecimal, sexagesimal, or floating point number.  All legal numbers are
+matched: however, many illegal numbers (e.g. "99.33.22") are matched as well.
+The numeric conversion routines may be used to verify that a number token
+is actually a legal number, as well as to convert the number to binary.
+
+An operator is one or more operator characters, or any of the characters
+[_.$], not occurring as part of an identifier, but occurring instead as the
+first character of an operator.  Note that a string of operator characters
+is considered a single token, whereas punctuation characters are returned
+as separate tokens.  Strings are enclosed by either single or double quotes,
+and all escape sequences are recognized and processed.
+Control characters and DEL match the "unknown" token.
+.ih
+SEE ALSO
+tokens(1), strmatch(), patmatch()
+.endhelp ______________________________________________________________________
+
+define	TABLESIZE	95
+define	NUMCHSIZE	6
+define	OFFSET		' '
+
+
+# CTOTOK -- Character string to token.  The token is returned in OUTSTR and the
+# token type code is returned as the function value.
+
+int procedure ctotok (str, ip, outstr, maxch)
+
+char	str[ARB]		# input string
+int	ip			# pointer into input string
+char	outstr[ARB]		# buffer to receive token
+int	maxch			# max chars in output buffer
+
+int	currclass
+char	class[TABLESIZE]
+int	op, ch, i, junk, nchars
+int	ctowrd(), lexnum(), cctoc()
+include	"tokdata.inc"
+
+begin
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+
+	ch = str[ip]
+	i  = max(1, min(TABLESIZE, ch - OFFSET))
+	op = 1
+
+	if (ch == EOS) {				# select class (token)
+	    outstr[1] = EOS
+	    return (TOK_EOS)
+
+	} else if (ch == NEWLINE) {			# end of line
+	    outstr[1] = ch
+	    outstr[2] = EOS
+	    ip = ip + 1
+	    return (TOK_NEWLINE)
+
+	} else if (ch <= OFFSET) {			# control characters
+	    while (op <= maxch && ch != EOS && ch <= OFFSET) {
+		outstr[op] = ch
+		op = op + 1
+		ip = ip + 1
+		ch = str[ip]
+	    }
+	    outstr[op] = EOS
+	    return (TOK_UNKNOWN)
+
+	} else if (ch == DQUOTE) {			# string constant
+	    junk = ctowrd (str, ip, outstr, maxch)
+	    return (TOK_STRING)
+
+	} else if (ch == SQUOTE || ch == ESCAPE) {
+	    nchars = cctoc (str, ip, junk)
+	    call strcpy (str[ip-nchars], outstr, nchars)
+	    return (TOK_CHARCON)
+
+	} else if (lexnum (str, ip, nchars) != LEX_NONNUM) {
+	    call strcpy (str[ip], outstr, nchars)
+	    ip = ip + nchars
+	    return (TOK_NUMBER)
+
+	} else if (class[i] == TOK_IDENTIFIER && !IS_ALPHA (ch)) {
+	    currclass = TOK_OPERATOR
+
+	} else if (class[i] == TOK_PUNCTUATION) {	# only one at a time
+	    outstr[1] = ch
+	    outstr[2] = EOS
+	    ip = ip + 1
+	    return (TOK_PUNCTUATION)
+
+	} else
+	    currclass = class[i]
+
+	repeat {					# copy token to output
+	    outstr[op] = ch
+	    op = op + 1
+	    ip = ip + 1
+	    ch = str[ip]
+	    i  = max(1, min(TABLESIZE, ch - OFFSET))
+	} until (ch == EOS || ch <= OFFSET || class[i] != currclass)
+
+	outstr[op] = EOS
+	return (currclass)
+end
diff --git a/sys/fmtio/ctowrd.x b/sys/fmtio/ctowrd.x
new file mode 100644
index 00000000..5f511075
--- /dev/null
+++ b/sys/fmtio/ctowrd.x
@@ -0,0 +1,83 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<chars.h>
+
+# CTOWRD -- Break whitespace delimited token or quoted string out of input
+# stream.  If string, process escape sequences.  The number of characters
+# converted from the input string, excluding whitespace, is returned as the
+# function value.
+
+int procedure ctowrd (str, ip, outstr, maxch)
+
+char	str[ARB]			# input string
+int	ip				# pointer into input string
+char	outstr[ARB]			# receives extracted word
+int	maxch
+
+char	cch
+int	ch, junk, op
+int	ip_start, delim, i
+define	qsput_ 91
+define	wsput_ 92
+int	cctoc()
+
+begin
+	while (IS_WHITE(str[ip]))
+	    ip = ip + 1
+	ip_start = ip
+
+	delim = str[ip]
+	if (delim == DQUOTE || delim == SQUOTE) {
+	    # Extract a quoted string.
+	    op = 1
+	    ip = ip + 1
+	    do i = 1, ARB {
+		ch = str[ip]
+		if (ch == EOS) {
+		    break
+		} else if (ch == ESCAPE) {
+		    ch = str[ip+1]
+		    if (ch == delim) {
+			ip = ip + 2
+			goto qsput_
+		    } else {
+			junk = cctoc (str, ip, cch)
+			ch = cch
+			goto qsput_
+		    }
+		} else if (ch == delim) {
+		    ip = ip + 1
+		    break
+		} else {
+	   	    ip = ip + 1
+qsput_		    if (op <= maxch) {
+			outstr[op] = ch
+			op = op + 1
+		    }
+		}
+	    }
+	} else {
+	    # Extract a whitespace delimited string.
+	    op = 1
+	    do i = 1, ARB {
+		ch = str[ip]
+		if (IS_WHITE(ch) || ch == '\n' || ch == EOS) {
+		    break
+		} else if (ch == ESCAPE) {
+		    junk = cctoc (str, ip, cch)
+		    ch = cch
+		    goto wsput_
+		} else {
+		    ip = ip + 1
+wsput_		    if (op <= maxch) {
+			outstr[op] = ch
+			op = op + 1
+		    }
+		}
+	    }
+	}
+
+	outstr[op] = EOS
+	return (ip - ip_start)
+end
diff --git a/sys/fmtio/ctox.x b/sys/fmtio/ctox.x
new file mode 100644
index 00000000..3f0479a2
--- /dev/null
+++ b/sys/fmtio/ctox.x
@@ -0,0 +1,48 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# CTOX -- Convert a character string into a complex number.  The complex
+# number must have the form (r,i), with no embedded whitespace (GCTOX is
+# cabable of accepting numbers in other formats).
+
+int procedure ctox (str, ip, xval)
+
+char	str[ARB]
+int	ip, ip_save
+double	dval1, dval2
+complex	xval
+int	ctod()
+define	notanumber_ 99
+
+begin
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+	ip_save = ip
+	dval2 = 0.0d0
+
+	if (str[ip] == '(') {				# x = (r1,r2)
+	    ip = ip + 1
+	    if (ctod (str, ip, dval1) <= 0)
+		goto notanumber_
+	    if (str[ip] != ',')
+		goto notanumber_
+	    ip = ip + 1
+	    if (ctod (str, ip, dval2) <= 0)
+		goto notanumber_
+	    if (str[ip] != ')')
+		goto notanumber_
+	    ip = ip + 1
+	} else
+	    goto notanumber_
+
+	if (IS_INDEFD(dval1) || IS_INDEFD(dval2))
+	    xval = INDEFX
+	else
+	    xval = complex (dval1, dval2)
+	return (ip - ip_save)
+
+notanumber_
+	ip = ip_save
+	return (0)
+end
diff --git a/sys/fmtio/doc/evexpr.hlp b/sys/fmtio/doc/evexpr.hlp
new file mode 100644
index 00000000..386baf91
--- /dev/null
+++ b/sys/fmtio/doc/evexpr.hlp
@@ -0,0 +1,147 @@
+				    EVEXPR
+		 Evaluating Algebraic Expressions in SPP Programs
+			      dct 17 April 1985
+
+
+
+1. Introduction
+
+    EVEXPR is a function which takes an algebraic expression as input,
+evaluates the expression, and returns the value of the expression as the
+function value.  The input expression (a character string) is parsed and
+reduced to a single value.  The operands to the expression may be either
+constants or identifiers (foreign strings).  If an identifier is encountered
+the user supplied get operand procedure is called to return the value of
+the operand.  Operands are described by the operand structure, and operands
+are passed about by a pointer to such a structure.  The value of the
+expression is returned as the function value and is a pointer to an operand
+structure.  Operands of different datatypes may be mixed in an expression
+with the usual automatic type coercion rules.  All SPP datatypes are
+supported plus the string datatype.  All SPP operators and intrinsic
+functions are recognized.
+
+
+2. Procedures
+
+	op = evexpr (expr, locpr(getop), locpr(ufcn))
+	      getop (identifier, op)
+	       ufcn (fcn, args, nargs, op)
+
+where
+
+	evexpr	The main entry point.
+	expr	A character string, the expression to be evaluated.
+	getop	A user supplied procedure which returns the value
+		  of a nonconstant operand given the NAME of the operand
+		  (a character string) as input.  If locpr(getop) is
+		  NULL only constant operands are permitted in the
+		  expression.
+	ufcn	A user supplied procedure which returns the value of
+		  a user defined function given the name of the function
+		  as the first argument (a string).  If locpr(ufcn) is
+		  NULL only the standard functions are permitted.
+	fcn	Name of the function to be evaluated.
+	args	Array of pointers to operands (the arguments to the function).
+	nargs	Number of arguments to function.
+	op	A pointer to an operand structure
+
+
+A a simple example, consider the following statement which evaluates a
+constant expression and prints the value on the standard output.
+
+
+	include	<evexpr.h>
+	pointer	o, evexpr()
+
+	o = evexpr ("sin(.5)**2 + cos(.5)**2)", NULL, NULL)
+	switch (O_TYPE(o)) {
+	case TY_INT:
+	    call printf ("result = %d\n")
+		call pargi (O_VALI(o))
+	case TY_REAL:
+	    call printf ("result = %g\n")
+		call pargr (O_VALR(o))
+	case TY_CHAR:
+	    call printf ("result = %s\n")
+		call pargstr (O_VALC(o))
+	}
+
+
+If a syntax error occurs while parsing the expression EVEXPR will take the
+error action "syntax error".  The NULL arguments could be replaced by the
+LOCPR addresses of get operand and/or user function procedures if required
+by the application.
+
+
+3. Lexical Form
+
+    The lexical form of the input expression is the same as that of SPP and
+the CL for all numeric, character, and  string constants and operators.
+Any other sequence of characters is considered an identifier and will be
+passed to the user supplied get operand function to be turned into an operand.
+
+
+4. Syntax
+
+    Parsing and evaluating of the input expression is carried out by an SPP/Yacc
+parser.  The grammar recognized by the parser is given below.
+
+
+expr	:	CONST				# numeric or string constant
+	|	IDENT				# external operand (getop)
+	|	'-' expr %prec UMINUS
+	|	expr '+'  expr
+	|	expr '-'  expr
+	|	expr '*'  expr
+	|	expr '/'  expr
+	|	expr '**' expr
+	|	expr '//' expr
+	|	'!' expr
+	|	expr '<'  expr
+	|	expr '<=' expr
+	|	expr '>'  expr
+	|	expr '>=' expr
+	|	expr '==' expr
+	|	expr '!=' expr
+	|	expr '&&' expr
+	|	expr '||' expr
+	|	IDENT '(' arglist ')'		# function call
+	|	'?' expr ':' expr		# conditional expression
+	|	'(' expr ')'
+	;
+
+arglist	:	# Empty.
+	|	arglist ',' expr
+	;
+
+
+2. Data Structures
+
+    The operand structure (size 3 su) is used to represent all operands in
+expressions and on the parser stack.  Operands are passed to and from the
+outside world by means of a pointer to an operand structure.  The caller
+is responsible for string storage of string operands passed to EVEXPR.
+EVEXPR manages string storage for temporary string operands created during
+expression evaluation, as well as storage for the final string value if
+the expression is string valued.  In the latter case the value string should
+be used before EVEXPR is again called.
+
+
+	struct operand {
+		int	type		# operand datatype
+		union {
+		bool	v_b		# boolean value
+		int	v_i		# integer value
+		real	v_r		# real value
+		char	*v_s		# string value
+		} v
+	}
+
+
+SPP equivalent (<evexpr.h>)
+
+		O_TYPE(o)		# operand datatype
+		O_VALB(o)		# boolean value
+		O_VALI(o)		# integer value (or string ptr)
+		O_VALR(o)		# real value
+		O_VALC(o)		# string value
diff --git a/sys/fmtio/doc/fmtio.hd b/sys/fmtio/doc/fmtio.hd
new file mode 100644
index 00000000..525911dc
--- /dev/null
+++ b/sys/fmtio/doc/fmtio.hd
@@ -0,0 +1,77 @@
+# Help directory for the FMTIO (formatted i/o) package.
+
+$fmtio	= "sys$fmtio/"
+
+cctoc		hlp = xtoc.hlp,		src = fmtio$cctoc.x
+chdeposit	hlp = chdeposit.hlp,	src = fmtio$chdeposit.x
+chfetch		hlp = chfetch.hlp,	src = fmtio$chfetch.x
+chrlwr		hlp = chrlwr.hlp,	src = fmtio$chrlwr.x
+chrupr		hlp = chrupr.hlp,	src = fmtio$chrupr.x
+clprintf	hlp = printf.hlp,	src = fmtio$clprintf.x
+clscan		hlp = scan.hlp,		src = fmtio$clscan.x
+ctocc		hlp = ctox.hlp,		src = fmtio$ctocc.x
+ctod		hlp = ctox.hlp,		src = fmtio$ctod.x
+ctoi		hlp = ctox.hlp,		src = fmtio$ctoi.x
+ctol		hlp = ctox.hlp,		src = fmtio$ctol.x
+ctor		hlp = ctox.hlp,		src = fmtio$ctor.x
+ctotok		hlp = ctox.hlp,		src = fmtio$ctotok.x
+ctowrd		hlp = ctox.hlp,		src = fmtio$ctowrd.x
+ctox		hlp = ctox.hlp,		src = fmtio$ctox.x
+dtoc		hlp = xtoc.hlp,		src = fmtio$dtoc.x
+eprintf		hlp = printf.hlp,	src = fmtio$eprintf.x
+fprintf		hlp = printf.hlp,	src = fmtio$fprintf.x
+fscan		hlp = scan.hlp,		src = fmtio$fscan.x
+gargb		hlp = garg.hlp,		src = fmtio$gargb.x
+gargc		hlp = garg.hlp,		src = fmtio$gargc.x
+gargd		hlp = garg.hlp,		src = fmtio$gargd.x
+gargi		hlp = garg.hlp,		src = fmtio$gargi.x
+gargl		hlp = garg.hlp,		src = fmtio$gargl.x
+gargr		hlp = garg.hlp,		src = fmtio$gargr.x
+gargrad		hlp = garg.hlp,		src = fmtio$gargrad.x
+gargs		hlp = garg.hlp,		src = fmtio$gargs.x
+gargstr		hlp = garg.hlp,		src = fmtio$gargstr.x
+gargtok		hlp = garg.hlp,		src = fmtio$gargtok.x
+gargwrd		hlp = garg.hlp,		src = fmtio$gargwrd.x
+gargx		hlp = garg.hlp,		src = fmtio$gargx.x
+gctod		hlp = ctox.hlp,		src = fmtio$gctod.x
+gctol		hlp = ctox.hlp,		src = fmtio$gctol.x
+gltoc		hlp = xtoc.hlp,		src = fmtio$gltoc.x
+gstrcat		hlp = gstrcat.hlp,	src = fmtio$gstrcat.x
+gstrcpy		hlp = gstrcpy.hlp,	src = fmtio$gstrcpy.x
+itoc		hlp = xtoc.hlp,		src = fmtio$itoc.x
+lexnum		hlp = lexnum.hlp,	src = fmtio$lexnum.x
+ltoc		hlp = xtoc.hlp,		src = fmtio$ltoc.x
+nscan		hlp = scan.hlp,		src = fmtio$nscan.x
+pargb		hlp = parg.hlp, 	src = fmtio$pargb.x
+pargc		hlp = parg.hlp,		src = fmtio$parg.x
+pargs		hlp = parg.hlp,		src = fmtio$parg.x
+pargi		hlp = parg.hlp,		src = fmtio$parg.x
+pargl		hlp = parg.hlp,		src = fmtio$parg.x
+pargr		hlp = parg.hlp,		src = fmtio$parg.x
+pargd		hlp = parg.hlp,		src = fmtio$parg.x
+pargx		hlp = parg.hlp,		src = fmtio$parg.x
+pargstr		hlp = parg.hlp,		src = fmtio$pargstr.x
+patmatch	hlp = patmatch.hlp,	src = fmtio$patmatch.x
+printf		hlp = printf.hlp,	src = fmtio$printf.x
+scanc		hlp = scan.hlp,		src = fmtio$scanc.x
+sprintf		hlp = printf.hlp,	src = fmtio$sprintf.x
+sscan		hlp = scan.hlp,		src = fmtio$sscan.x
+strcat		hlp = strcat.hlp,	src = fmtio$strcat.x
+strcpy		hlp = strcpy.hlp,	src = fmtio$strcpy.x
+strdic		hlp = strdic.hlp,	src = fmtio$strdic.x
+streq		hlp = streq.hlp,	src = fmtio$streq.x
+strge		hlp = strge.hlp,	src = fmtio$strge.x
+strgt		hlp = strgt.hlp,	src = fmtio$strgt.x
+stridx		hlp = stridx.hlp,	src = fmtio$stridx.x
+strldx		hlp = strldx.hlp,	src = fmtio$strldx.x
+strle		hlp = strle.hlp,	src = fmtio$strle.x
+strlen		hlp = strlen.hlp,	src = fmtio$strlen.x
+strlt		hlp = strlt.hlp,	src = fmtio$strlt.x
+strlwr		hlp = strlwr.hlp,	src = fmtio$strlwr.x
+strmatch	hlp = strmatch.hlp,	src = fmtio$strmatch.x
+strncmp		hlp = strncmp.hlp,	src = fmtio$strncmp.x
+strne		hlp = strne.hlp,	src = fmtio$strne.x
+strsearch	hlp = strsearch.hlp,	src = fmtio$strsearch.x
+strtbl		hlp = strtbl.hlp,	src = fmtio$strtbl.x
+strupr		hlp = strupr.hlp,	src = fmtio$strupr.x
+xtoc		hlp = xtoc.hlp,		src = fmtio$xtoc.x
diff --git a/sys/fmtio/doc/fmtio.men b/sys/fmtio/doc/fmtio.men
new file mode 100644
index 00000000..897a8139
--- /dev/null
+++ b/sys/fmtio/doc/fmtio.men
@@ -0,0 +1,59 @@
+	  cctoc - Character constant to char
+      chdeposit - Deposit a character in a string with overflow protection
+	chfetch - Fetch a character from a string
+	 chrlwr - Convert a character to lower case
+	 chrupr - Convert a character to upper case
+       clprintf - Formatted print to a CL parameter
+	 clscan - Scan a CL parameter
+	  ctocc - Char to character constant
+	   ctod - Character to double
+	   ctoi - Character to integer
+	   ctol - Character to long
+	   ctor - Character to real
+	   ctox - Character to complex
+	 ctotok - Character to lexical token
+	 ctowrd - Character to whitespace delimited word
+	   dtoc - Double to character
+	eprintf - Formatted print to STDERR
+	fprintf - Formatted print to any file
+	  fscan - Scan a file
+ garg[bcsilrdx] - Get scan argument
+	gargrad - Get scan argument in any numerical radix
+	gargstr - Get scan argument of type string
+	gargtok - Get scan argument of type token
+	gargwrd - Get scan argument of type word
+	  gctod - General character to double
+	  gctol - General character to long (any radix)
+	  gltoc - General long to character (any radix)
+	gstrcat - String concatenation returning length of output string
+	gstrcpy - String copy returning length of output string
+	   itoc - Integer to character
+	 lexnum - Lexically analyze a string to determine if it is a number
+	   ltoc - Long to character
+	  nscan - Get number of arguments successfully converted in last scan
+ parg[bcsilrdx] - Pass an argument to a printf
+	pargstr - Pass a string type argument to a printf
+       patmatch - General pattern matching
+	 printf - Formatted print to STDOUT
+	  scanc - Get the next character from a scan
+	sprintf - Formatted print to a string buffer
+	  sscan - Scan a string buffer
+	 strcat - String concatenation
+	 strcpy - String copy
+	 strdic - Look a string up in a dictionary
+	  streq - Compare strings for equality
+	  strge - Is string A greater than or equal to string B
+	  strgt - Is string A greater than string B
+	 stridx - First occurrence of a character in a string
+	 strldx - Last occurrence of a character in a string
+	  strle - Is string A less than or equal to string B
+	 strlen - Length of a string
+	  strlt - Is string A less than string B
+	 strlwr - Convert string to lower case
+       strmatch - Search a string for a pattern
+	strncmp - Compare the first N characters of two strings
+	  strne - Is string A not equal to string B
+      strsearch - Fast string search, no metacharacters
+	 strtbl - Print a list of strings in a table
+	 strupr - Convert a string to upper case
+	   xtoc - Complex to character
diff --git a/sys/fmtio/doc/lexnum.hlp b/sys/fmtio/doc/lexnum.hlp
new file mode 100644
index 00000000..647654b1
--- /dev/null
+++ b/sys/fmtio/doc/lexnum.hlp
@@ -0,0 +1,303 @@
+
+.help lexnum 2 "string utilities"
+.ih _________________________________________________________________________
+NAME
+lexnum -- Determine if string is a number
+.ih
+USAGE
+token_type = lexnum (str, ip, nchars)
+
+.ih
+PARAMETERS
+.ls str
+String to be scanned.
+.le
+.ls ip
+Index within the string as which scanning is to start.  Not modified.
+.le
+.ls nchars
+On output, the number of characters in the number, not including any
+leading whitespace.
+.le
+.ih
+DESCRIPTION
+The character string is scanned to determine if the next token is a
+legal number, and if so, the type of number.  The function value identifies
+the type of number.  The possible return values, defined in <lexnum.h>,
+as as follows:
+
+.nf
+	LEX_OCTAL	(+|-)?[0-7]+[bB]
+	LEX_DECIMAL	(+|-)?[0-9]+
+	LEX_HEX		(+|-)?[0-9a-fA-F]+[xX]
+	LEX_REAL	floating, exponential [eEdD], sexagesimal
+	LEX_NONNUM	not a number
+.fi
+.ih
+IMPLEMENTATION
+Numtype is implemented as a finite state automaton.  Additional documentation
+is provided with the source code.
+.ih
+SEE ALSO
+gctod(2), ctotok(2).
+.endhelp ___________________________________________________________________
+
+
+
+.help states 2 "States of the LEXNUM Finite State Automaton"
+.fi
+
+
+.ks
+.nf
+start:								(1)
+	+-		shift	unop_or_number
+	0-7		shift	odhr
+	8-9		shift	dhr
+	acf		reduce	not_a_number
+	ed		reduce	not_a_number
+	:		shift	maybe_real_number
+	.		shift	maybe_real_fraction
+	x		reduce	not_a_number
+	b		reduce	not_a_number
+	other		reduce	not_a_number
+.fi
+.ke
+
+
+.ks
+.nf
+unop_or_number:		(+|-)					(2)
+	+-		revert
+	0-7		shift	odhr
+	8-9		shift	dhr
+	acf		revert
+	ed		revert
+	:		revert
+	.		shift	maybe_real_fraction
+	x		revert
+	b		revert
+	other		revert
+.fi
+.ke
+
+
+.ks
+.nf
+odhr:			(+|-)?[0-7]				(3)
+	+-		reduce	decimal_number
+	0-7		accept
+	8-9		shift	dhr
+	acf		shift	h
+	ed		shift	maybe_hex_or_rexp
+	:		shift	maybe_real_number
+	.		shift	real_fraction
+	x		reduce	hex_number
+	b		shift	octal_or_hex_number
+	other		reduce	decimal_number
+.fi
+.ke
+
+
+.ks
+.nf
+dhr:			(+|-)?[0-9]+				(4)
+	+-		reduce	decimal_number
+	0-7		accept
+	8-9		accept
+	acf		shift	h
+	ed		shift	maybe_hex_or_rexp
+	:		shift	maybe_real_number
+	.		shift	real_fraction
+	x		reduce	hex_number
+	b		shift	h
+	other		reduce	decimal_number
+.fi
+.ke
+
+
+.ks
+.nf
+maybe_real_fraction:	(+|-)?"."				(5)
+	+-		revert
+	0-7		shift	real_fraction
+	8-9		shift	real_fraction
+	acf		revert
+	ed		revert
+	:		revert
+	.		revert
+	x		revert
+	b		revert
+	other		revert
+.fi
+.ke
+
+
+.ks
+.nf
+h:			(+|-)?[0-9]*[a-f]			(6)
+	+-		revert
+	0-7		accept
+	8-9		accept
+	acf		accept
+	ed		accept
+	:		revert
+	.		revert
+	x		reduce	hex_number
+	b		accept
+	other		revert
+.fi
+.ke
+
+
+.ks
+.nf
+maybe_hex_or_rexp:	(+|-)?[0-9]+[ed]			(7)
+	+-		shift	maybe_rexp
+	0-7		shift	hex_or_rexp
+	8-9		shift	hex_or_rexp
+	acf		shift	h
+	ed		shift	h
+	:		revert
+	.		revert
+	x		reduce	hex_number
+	b		shift	h
+	other		revert
+.fi
+.ke
+
+
+.ks
+.nf
+maybe_real_number:	(+|-)?[0-9]*":"				(8)
+	+-		revert
+	0-7		shift	r
+	8-9		shift	r
+	acf		revert
+	ed		revert
+	:		accept
+	.		revert
+	x		revert
+	b		revert
+	other		revert
+.fi
+.ke
+
+
+.ks
+.nf
+octal_or_hex_number:	(+|-)?[0-7]"b"				(9)
+	+-		reduce	octal_number
+	0-7		shift	h
+	8-9		shift	h
+	acf		shift	h
+	ed		shift	h
+	:		reduce	octal_number
+	.		reduce	octal_number
+	x		reduce	hex_number
+	b		shift	h
+	other		reduce	octal_number
+.fi
+.ke
+
+
+.ks
+.nf
+real_fraction:		(+|-)?"."[0-9]				(10)
+	+-		reduce	real_number
+	0-7		accept
+	8-9		accept
+	acf		reduce	real_number
+	ed		shift	rfr_or_rexp
+	:		reduce	real_number
+	.		reduce	real_number
+	x		reduce	real_number
+	b		reduce	real_number
+	other		reduce	real_number
+.fi
+.ke
+
+
+.ks
+.nf
+rfr_or_rexp:		(+|-)?"."[0-9]+[ed]			(11)
+	+-		shift	maybe_rexp
+	0-7		shift	rexp
+	8-9		shift	rexp
+	acf		revert
+	ed		revert
+	:		revert
+	.		revert
+	x		revert
+	b		revert
+	other		revert
+.fi
+.ke
+
+
+.ks
+.nf
+maybe_rexp:		(+|-)?[0-9]+[ed](+|-)			(12)
+	+-		revert
+	0-7		shift	rexp
+	8-9		shift	rexp
+	acf		revert
+	ed		revert
+	:		revert
+	.		revert
+	x		revert
+	b		revert
+	other		revert
+.fi
+.ke
+
+
+.ks
+.nf
+hex_or_rexp:		(+|-)?[0-9]+[ed][0-9]			(13)
+	+-		reduce	real_number
+	0-7		accept
+	8-9		accept
+	acf		shift	h
+	ed		shift	h
+	:		reduce	real_number
+	.		reduce	real_number
+	x		reduce	hex_number
+	b		reduce	real_number
+	other		reduce	real_number
+.fi
+.ke
+
+
+.ks
+.nf
+r:			(+|-)?[0-9]*":"[0-9]			(14)
+	+-		reduce	real_number
+	0-7		accept
+	8-9		accept
+	acf		reduce	real_number
+	ed		shift	maybe_rexp
+	:		accept
+	.		shift	maybe_real_fraction
+	x		reduce	real_number
+	b		reduce	real_number
+	other		reduce	real_number
+.fi
+.ke
+
+
+.ks
+.nf
+rexp:			(+|-)?[0-9]+[ed](+|-)[0-9]		(15)
+	+-		reduce	real_number
+	0-7		accept
+	8-9		accept
+	acf		reduce	real_number
+	ed		reduce	real_number
+	:		reduce	real_number
+	.		reduce	real_number
+	x		reduce	real_number
+	b		reduce	real_number
+	other		reduce	real_number
+.fi
+.ke
diff --git a/sys/fmtio/dtcscl.x b/sys/fmtio/dtcscl.x
new file mode 100644
index 00000000..afd6adc5
--- /dev/null
+++ b/sys/fmtio/dtcscl.x
@@ -0,0 +1,35 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# DTCSCL -- Scales a double precision real, maintaining maximum precision.
+# Called by DTOC and CTOD.
+
+procedure dtcscl (v, e, sense)
+
+double	v		# value to be scaled
+int	e		# exponent
+int	sense		# sense of scaling (0=apply e to v;  1=calc e)
+
+begin
+	if (sense == 0) 		# scale v by 10 ** e
+	    v = v * (10.0d0 ** e)
+
+	else {				# scale number to 0.1 <= v < 1.0
+	    if (v == 0.0d0)
+		e = 0
+	    else {
+	        e = -1
+	        while (v < 0.1d0) {
+		    v = v * 10.0d0
+		    e = e - 1
+		    if (v == 0.0d0) {	# check for underflow to zero
+			e = 0
+			break
+		    }
+	        }
+	        while (v >= 1.0d0) {
+		    v = v / 10.0d0
+		    e = e + 1
+	        }
+	    }
+	}
+end
diff --git a/sys/fmtio/dtoc.x b/sys/fmtio/dtoc.x
new file mode 100644
index 00000000..6bf7571e
--- /dev/null
+++ b/sys/fmtio/dtoc.x
@@ -0,0 +1,129 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<printf.h>
+
+# DTOC -- Format and output a floating point number, in any of the formats
+# F,E,G,H, or M (H and M are hours-minutes-seconds and minutes-seconds formats,
+# respectively).
+
+int procedure dtoc (dval, outstr, maxch, decpl, a_fmt, width)
+
+double	dval			# number to be output
+char	outstr[ARB]		# output string
+int	maxch			# size of the output string
+int	decpl			# number of decimal places or precision
+int	a_fmt, fmt		# format type (feghm)
+int	width			# field width
+
+bool	neg
+double	val
+int	op, round, h, m, s, f, v, i
+int	dtoc3(), ltoc()
+
+define	output {outstr[op]=$1;op=op+1;if(op>maxch)goto retry_}
+define	retry_ 91
+
+begin
+	# If HMS format is not desired, simply call DTOC3.  Control also
+	# returns to this point in the event of overflow.
+
+	fmt = a_fmt
+	if (IS_UPPER (fmt))
+	    fmt = TO_LOWER (fmt)
+
+	if (fmt == FMT_FIXED || fmt == FMT_EXPON || fmt == FMT_GENERAL ||
+	    IS_INDEFD(dval)) {
+retry_	
+	    return (dtoc3 (dval, outstr, maxch, decpl, fmt, width))
+	}
+
+	# HMS format is implemented using calls to DTOC3, LTOC.  Use zero
+	# fill to get two chars for the second and third fields, if necessary.
+	# The second field is omitted for "m" format.  No whitespace is
+	# permitted in an HMS (or other) number.  If the format is %H or %M
+	# (instead of the usual %h or %m) scale the number by 15 before output
+	# (converting degrees to hours).
+
+	if (IS_UPPER (a_fmt))
+	    val = dval / 15.0
+	else
+	    val = dval
+
+	# Working with a positive number simplifies things.
+	neg = (val < 0.0)
+	if (neg)
+	    val = -val
+
+	# Decompose number into HMS or MS.
+	h = 0
+	if (fmt == FMT_HMS) {
+	    h = int(val);  val = (val - h) * 60.0
+	}
+	m = int(val);  val = (val - m) * 60.0
+	s = int(val);  val = (val - s)
+
+	# Round the fractional seconds field and carry if the rounded value
+	# is greater than 60.  This has to be done explicitly due to the
+	# "base 60" sexagesimal arithmetic.
+
+	round = (10.0 ** decpl)
+	f = int (val * round + 0.5)
+	while (f >= round) {
+	    f = f - round
+	    s = s + 1
+	}
+	while (s >= 60) {
+	    s = s - 60
+	    m = m + 1
+	}
+	while (m >= 60) {
+	    m = m - 60
+	    h = h + 1
+	}
+
+	# Format the output string.
+	op = 1
+	if (neg)
+	    output ('-')
+
+	# Output the first field, which is the hours field for HMS format,
+	# or the minutes field for MS format.
+
+	if (fmt == FMT_HMS)
+	    v = h
+	else
+	    v = h * 60 + m
+	op = op + ltoc (v, outstr[op], maxch-op+1)
+	output (':')
+
+	# Output the minutes field in HMS format.
+	if (fmt == FMT_HMS) {
+	    output (TO_DIGIT (m / 10))
+	    output (TO_DIGIT (mod (m, 10)))
+	    output (':')
+	}
+
+	# Output the seconds field.
+	output (TO_DIGIT (s / 10))
+	output (TO_DIGIT (mod (s, 10)))
+
+	# Output the fraction, if any.
+	if (decpl > 0) {
+	    output ('.')
+	    do i = 1, decpl {
+		round = round / 10
+		output (TO_DIGIT (f / round))
+		f = mod (f, round)
+	    }
+	}
+
+	# If the HMS format does not fit, go try a more compact format.
+	if (op-1 > abs(width) || op > maxch) {
+	    fmt = FMT_GENERAL
+	    goto retry_
+	}
+
+	outstr[op] = EOS
+	return (op-1)
+end
diff --git a/sys/fmtio/dtoc3.x b/sys/fmtio/dtoc3.x
new file mode 100644
index 00000000..76101dd1
--- /dev/null
+++ b/sys/fmtio/dtoc3.x
@@ -0,0 +1,285 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+include <ctype.h>
+include <printf.h>
+
+.help dtoc3
+.nf ___________________________________________________________________________
+This routine is based on the TOOLS routine of the same name by J. Chong.
+The major changes are translation to the IRAF pp language, implementation
+of the "G" format, and some restructuring to avoid duplicated code.
+This procedure is called by the more general routine DTOC, which adds the
+additional format type "H" (sexageximal, or hms format).
+
+Formats:	f	Fixed format.  D == number of decimal places.  If D
+			is -1 (or less), the "." will not be printed.  If the
+			number being printed is too large to fit in F format,
+			"E" format will be used instead.  Nonsignificant
+			digits are returned as zeros.
+
+		e	Exponential format.  D == number of significant digits.
+
+		g	General format.  D == number of significant digits.
+			The actual format used may be either F or E, depending
+			on which is smaller.  If D is negative, the "." will
+			be omitted if possible (abs(D) remains the precision).
+
+If the field width is too small to convert the number, the field will be
+filled with asterisks instead.  If the number being converted is INDEF, the
+string "INDEF" will be returned.  The number is rounded to the desired precision
+before being printed.
+.endhelp ______________________________________________________________________
+
+# DTOC3 --- Convert double precision real to string.
+
+int procedure dtoc3 (val, out, maxch, decpl, a_fmt, width)
+
+double	val			# value to be encoded
+char	out[ARB]		# output string
+int	maxch			# max chars out
+int	decpl			# precision
+int	a_fmt			# type of encoding ('f', 'e', etc.)
+int	width			# field width
+
+double	v
+char	digits[MAX_DIGITS]
+bool	neg, small, exp_format, squeeze
+int	i, w, d, e, j, len, no_digits, max_size, e_size, f_size, fmt
+int	itoc(), gstrcpy()
+
+begin
+	# Set flags indicating whether the number is greater or less that zero,
+	# and whether its absolute value is greater or less than 1.
+
+	v = abs (val)
+	w = abs (width)
+
+	fmt = a_fmt
+	if (IS_UPPER(a_fmt))
+	    fmt = TO_LOWER(a_fmt)
+	squeeze = (fmt == FMT_GENERAL)
+	neg = (val < 0.0)
+	small = (v < 0.1)
+
+	if (squeeze)
+	    d = abs (decpl)
+	else
+	    d = max (0, decpl)
+
+	if (IS_INDEFD (val))			# INDEF is a special case
+	    return (gstrcpy ("INDEF", out, w))
+
+	# Scale number to 0.1 <= v < 1.0
+	call dtcscl (v, e, 1)
+
+	# Start tally for the maximum size of the number to determine if an
+	# error should be returned.
+	if (neg)				# 1 for neg, plus 1 for .
+	    max_size = 2
+	else
+	    max_size = 1
+	no_digits = min (MAX_DIGITS, d)
+
+
+	# Determine exact format for printing.
+
+	len = abs (e)				# base size of E format
+	e_size = 1
+	for (i=10;  i <= 10000;  i=i*10) {
+	    if (len < i)
+		break
+	    e_size = e_size + 1
+	}
+	e_size = e_size + max_size + 1
+	if (e < 0)
+	    e_size = e_size + 1			# allow space for leading '0'
+
+	if (squeeze) {				# G-format: find best format
+	    e_size = e_size + d
+	    if (e > 0)
+	        f_size = max (d, e + 1)
+	    else
+		f_size = d - e
+	    f_size = f_size + max_size
+	} else if (fmt == FMT_FIXED)
+	    f_size = max (e, 1) + max_size + d
+
+
+	if (squeeze) {				# 'G' format
+	    if (f_size <= e_size) {
+		exp_format = false
+		if (e > 0)
+		    no_digits = f_size - max_size
+	        max_size = f_size
+	    } else {
+		exp_format = true
+		max_size = e_size
+	    }
+	    d = w				# deactivate dec-places count
+
+	} else if (fmt == FMT_FIXED) {		# Fortran 'F' format
+	    exp_format = f_size > w
+
+	    if (exp_format) {			# is there too little space?
+		no_digits = max (1, w - e_size)
+		max_size = no_digits + e_size
+	    } else {
+		no_digits = e + d + 1		# negative e is OK here
+		max_size = f_size
+	    }
+
+	} else { 				# Fortran 'E' format
+	    exp_format = true
+	    max_size = e_size + d
+	    d = w
+	}
+
+	# Round the number at digit (no_digits + 1).
+	if (no_digits >= 0)
+	    v = v + 0.5 * 10. ** (-no_digits)
+
+	# Be sure the number of digits is in range.
+	no_digits = max(1, min(MAX_DIGITS, no_digits))
+
+	# Handle the unusual situation of rounding from .999..  up to 1.000.
+	if (v >= 1.0) {
+	    v = v / 10.0
+	    e = e + 1
+	    if (!exp_format) {
+		max_size = max_size + 1
+		no_digits = min (MAX_DIGITS, no_digits + 1)
+	    }
+	}
+
+	# See if the number will fit in 'w' characters
+	if (max_size > w) {
+	    for (i=1;  i <= w;  i=i+1)
+		out[i] = OVFL_CHAR
+	    out[i] = EOS
+	    return (w)
+	}
+
+	# Extract the first <no_digits> digits.  At the start V is normalized
+	# to a value less than 1.0.  The algorithm is to multiply by ten and
+	# take the integer part to get each digit.  
+
+	do i = 1, no_digits {
+	    v = v * 10.0d0
+	    j = int (v + EPSILOND)		# truncate to integer
+	    v = v - j				# lop off the integral part
+
+	    # Make sure the next iteration will produce a decimal J in the
+	    # range 1-9.  On some systems, due to precision problems J=int(V)
+	    # can be off by one compared to V-J and this will result in a J
+	    # of 10 in the next iteration.  The expression below attempts to
+	    # look ahead for J>=10 and adjusts the J for the current iteration
+	    # up by one if this will occur.
+
+	    if (int (v * 10.0d0 + EPSILOND) >= 10) {
+		j = j + 1
+		v = v - 1
+		if (v < 0)
+		    v = 0
+	    }
+
+	    digits[i] = TO_DIGIT(j)
+	}
+
+	# Take digit string and exponent and arrange into desired format.
+	len = 1
+	if (neg) {
+	    out[1] = '-'
+	    len = len + 1
+	}
+
+	if (exp_format) {			# set up exponential format
+	    out[len] = digits[1]
+	    out[len+1] = '.'
+	    len = len + 2
+	    for (i=2;  i <= no_digits;  i=i+1) {
+	        out[len] = digits[i]
+	        len = len + 1
+	    }
+	    out[len] = 'E'
+	    len = len + 1
+	    if (e < 0) {
+		out[len] = '-'
+		len = len + 1
+		e = -e
+	    }
+	    len = len + itoc (e, out[len], w - len + 1)
+
+	} else if (e >= no_digits) {
+	    # Handle numbers >= 1 with dp after figures.
+	    for (i=1;  i <= no_digits;  i=i+1) {
+		out[len] = digits[i]
+		len = len + 1
+	    }
+    	    for (i=no_digits;  i <= e;  i=i+1) {
+		out[len] = '0'
+		len = len + 1
+	    }
+	    if (decpl > 0) {
+	        out[len] = '.'
+	        len = len + 1
+	        if (!squeeze) {
+		    for (i=1;  i <= d;  i=i+1) {
+		        out[len] = '0'
+		        len = len + 1
+		    }
+	        }
+	    }
+
+	} else {
+	    if (e < 0) {
+		# Handle fixed numbers < 1.
+	        if (d == 0 && e == -1 && digits[1] >= '5') 
+		    out[len] = '1'
+	        else
+		    out[len] = '0'
+	        out[len + 1] = '.'
+	        len = len + 2
+	        for (i=1;  i < -e && d > 0;  i=i+1) {
+		    out[len] = '0'
+		    len = len + 1
+		    d = d - 1
+	        }
+		i = 1
+	    } else {
+		# Handle numbers > 1 with dp inside figures.
+	        e = e + 2				# one more zero below
+	        for (i=1;  i < e;  i=i+1) {
+		    out[len] = digits[i]
+		    len = len + 1
+	        }
+		if (decpl > 0) {
+	            out[len] = '.'
+	            len = len + 1
+		}
+	    }
+
+	    for (j=1;  i <= no_digits && j <= d;  j=j+1) {
+		out[len] = digits[i]
+		i = i + 1
+		len = len + 1
+	    }
+	    if (squeeze) {
+	        while (len > 2) {			# skip trailing zeroes
+		    len = len - 1
+		    if (out[len] != '0') {
+		        len = len + 1			# non-digit -- keep it
+		        break
+		    }
+		}
+	    } else {
+		for (i=1;  i < d+e-no_digits && i <= d;  i=i+1) {
+		    out[len] = '0'
+		    len = len + 1
+		}
+	    }
+	}
+
+	out[len] = EOS
+	return (len - 1)
+end
diff --git a/sys/fmtio/eprintf.x b/sys/fmtio/eprintf.x
new file mode 100644
index 00000000..51b2d196
--- /dev/null
+++ b/sys/fmtio/eprintf.x
@@ -0,0 +1,14 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# EPRINTF -- Format output to the standard error output.
+
+procedure eprintf (format_string)
+
+char	format_string[ARB]
+
+begin
+	call flush (STDOUT)
+	call fprntf (STDERR, format_string, REGULAR_FILE)
+end
diff --git a/sys/fmtio/escchars.inc b/sys/fmtio/escchars.inc
new file mode 100644
index 00000000..d3c4d33e
--- /dev/null
+++ b/sys/fmtio/escchars.inc
@@ -0,0 +1,5 @@
+
+# Escape sequences
+
+string	escape_chars "ntfr'\"\\"
+string	mapped_chars "\n\t\f\r'\"\\"
diff --git a/sys/fmtio/evexpr.com b/sys/fmtio/evexpr.com
new file mode 100644
index 00000000..65488986
--- /dev/null
+++ b/sys/fmtio/evexpr.com
@@ -0,0 +1,7 @@
+# EVEXPR common.
+
+pointer	ev_oval				# pointer to expr value operand
+int	ev_getop			# user supplied get operand procedure
+int	ev_ufcn				# user supplied function call procedure
+
+common	/xevcom/ ev_oval, ev_getop, ev_ufcn
diff --git a/sys/fmtio/evexpr.x b/sys/fmtio/evexpr.x
new file mode 100644
index 00000000..4d512a20
--- /dev/null
+++ b/sys/fmtio/evexpr.x
@@ -0,0 +1,1477 @@
+
+# line 2 "evexpr.y"
+include	<lexnum.h>
+include	<ctype.h>
+include	<mach.h>
+include	<evexpr.h>
+
+define	YYMAXDEPTH	64		# parser stack length
+define	MAX_ARGS	16		# max args in a function call
+define	yyparse		xev_parse
+
+define	DTOR		(($1)/57.2957795)
+define	RTOD		(($1)*57.2957795)
+
+# 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	KEYWORDS	"|abs|acos|asin|atan|atan2|bool|cos|exp|int|log|log10|\
+			 |max|min|mod|nint|real|sin|sqrt|str|tan|"
+
+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_EXP		08
+define	F_INT		09
+define	F_LOG		10
+define	F_LOG10		11
+	# newline	12
+define	F_MAX		13
+define	F_MIN		14
+define	F_MOD		15
+define	F_NINT		16
+define	F_REAL		17
+define	F_SIN		18
+define	F_SQRT		19
+define	F_STR		20
+define	F_TAN 		21
+
+
+# EVEXPR -- Evaluate an expression.  This is the top level procedure, and the
+# only externally callable entry point.  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 EVEXPR and must be
+# freed by the user.
+#
+# N.B.: 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.
+
+pointer procedure evexpr (expr, getop_epa, ufcn_epa)
+
+char	expr[ARB]		# expression to be evaluated
+int	getop_epa		# user supplied get operand procedure
+int	ufcn_epa		# user supplied function call procedure
+
+int	junk
+bool	debug
+pointer	sp, ip
+extern	xev_gettok()
+int	strlen(), xev_parse()
+
+errchk	xev_parse, calloc
+include	"evexpr.com"
+data	debug /false/
+
+begin
+	call smark (sp)
+
+	# Set user function entry point addresses.
+	ev_getop = getop_epa
+	ev_ufcn  = ufcn_epa
+
+	# 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 XEV_PARSE, given the operand pointer
+	# passed in common.  A common must be used since the standard parser
+	# subroutine has a fixed calling sequence.
+
+	junk = xev_parse (ip, debug, xev_gettok)
+
+	call sfree (sp)
+	return (ev_oval)
+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	AND		275
+define	OR		276
+define	NOT		277
+define	AT		278
+define	GE		279
+define	UMINUS		280
+define	yyclearin	yychar = -1
+define	yyerrok		yyerrflag = 0
+define	YYMOVE		call amovi (Memi[$1], Memi[$2], YYOPLEN)
+define	YYERRCODE	256
+
+
+
+# XEV_UNOP -- Unary operation.  Perform the indicated unary operation on the
+# input operand, returning the result as the output operand.
+
+procedure xev_unop (opcode, in, out)
+
+int	opcode			# operation to be performed
+pointer	in			# input operand
+pointer	out			# output operand
+
+errchk	xev_error
+define	badsw_ 91
+
+begin
+	call xev_initop (out, 0, O_TYPE(in))
+
+	switch (opcode) {
+	case MINUS:
+	    # Unary negation.
+	    switch (O_TYPE(in)) {
+	    case TY_BOOL, TY_CHAR:
+		call xev_error ("negation of a nonarithmetic operand")
+	    case TY_INT:
+		O_VALI(out) = -O_VALI(in)
+	    case TY_REAL:
+		O_VALR(out) = -O_VALR(in)
+	    default:
+		goto badsw_
+	    }
+
+	case NOT:
+	    switch (O_TYPE(in)) {
+	    case TY_BOOL:
+		O_VALB(out) = !O_VALB(in)
+	    case TY_CHAR, TY_INT, TY_REAL:
+		call xev_error ("not of a nonlogical")
+	    default:
+		goto badsw_
+	    }
+
+	default:
+badsw_	    call xev_error ("bad switch in unop")
+	}
+end
+
+
+# XEV_BINOP -- Binary operation.  Perform the indicated arithmetic binary
+# operation on the two input operands, returning the result as the output
+# operand.
+
+procedure xev_binop (opcode, in1, in2, out)
+
+int	opcode			# operation to be performed
+pointer	in1, in2		# input operands
+pointer	out			# output operand
+
+real	r1, r2
+int	i1, i2, dtype, nchars
+int	xev_newtype(), strlen()
+errchk	xev_newtype
+
+begin
+	# Set the datatype of the output operand, taking an error action if
+	# the operands have incompatible datatypes.
+
+	dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2))
+	call xev_initop (out, 0, dtype)
+
+	switch (dtype) {
+	case TY_BOOL:
+	    call xev_error ("operation illegal for boolean operands")
+	case TY_CHAR:
+	    if (opcode != CONCAT)
+		call xev_error ("operation illegal for string operands")
+	case TY_INT:
+	    i1 = O_VALI(in1)
+	    i2 = O_VALI(in2)
+	case TY_REAL:
+	    if (O_TYPE(in1) == TY_INT)
+		r1 = O_VALI(in1)
+	    else
+		r1 = O_VALR(in1)
+	    if (O_TYPE(in2) == TY_INT)
+		r2 = O_VALI(in2)
+	    else
+		r2 = O_VALR(in2)
+	default:
+	    call xev_error ("unknown datatype code in binop")
+	}
+
+	# Perform the operation.
+	switch (opcode) {
+	case PLUS:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 + i2
+	    else
+		O_VALR(out) = r1 + r2
+
+	case MINUS:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 - i2
+	    else
+		O_VALR(out) = r1 - r2
+
+	case STAR:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 * i2
+	    else
+		O_VALR(out) = r1 * r2
+
+	case SLASH:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 / i2
+	    else
+		O_VALR(out) = r1 / r2
+
+	case EXPON:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 ** i2
+	    else if (O_TYPE(in1) == TY_REAL && O_TYPE(in2) == TY_INT)
+		O_VALR(out) = r1 ** (O_VALI(in2))
+	    else
+		O_VALR(out) = r1 ** r2
+
+	case CONCAT:
+	    if (dtype != TY_CHAR)
+		call xev_error ("concatenation of a nonstring operand")
+	    nchars = strlen (O_VALC(in1)) + strlen (O_VALC(in2))
+	    call xev_makeop (out, nchars, TY_CHAR)
+	    call strcpy (O_VALC(in1), O_VALC(out), ARB)
+	    call strcat (O_VALC(in2), O_VALC(out), ARB)
+	    call xev_freeop (in1)
+	    call xev_freeop (in2)
+
+	default:
+	    call xev_error ("bad switch in binop")
+	}
+end
+
+
+# XEV_BOOLOP -- Boolean binary operations.  Perform the indicated boolean binary
+# operation on the two input operands, returning the result as the output
+# operand.
+
+procedure xev_boolop (opcode, in1, in2, out)
+
+int	opcode			# operation to be performed
+pointer	in1, in2		# input operands
+pointer	out			# output operand
+
+bool	result
+real	r1, r2
+int	i1, i2, dtype
+int	xev_newtype(), xev_patmatch(), strncmp()
+errchk	xev_newtype, xev_error
+define	badsw_ 91
+
+begin
+	# Set the datatype of the output operand, taking an error action if
+	# the operands have incompatible datatypes.
+
+	dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2))
+	call xev_initop (out, 0, dtype)
+
+	switch (opcode) {
+	case AND, OR:
+	    if (dtype != TY_BOOL)
+		call xev_error ("AND or OR of nonlogical")
+	case LT, GT, LE, GE:
+	    if (dtype == TY_BOOL)
+		call xev_error ("order comparison of a boolean operand")
+	}
+
+	if (dtype == TY_INT) {
+	    i1 = O_VALI(in1)
+	    i2 = O_VALI(in2)
+	} else if (dtype == TY_REAL) {
+	    if (O_TYPE(in1) == TY_INT) {
+		i1 = O_VALI(in1)
+		r1 = i1
+	    } else
+		r1 = O_VALR(in1)
+	    if (O_TYPE(in2) == TY_INT) {
+		i2 = O_VALI(in2)
+		r2 = i2
+	    } else
+		r2 = O_VALR(in2)
+	}
+
+	# Perform the operation.
+	switch (opcode) {
+	case AND:
+	    result = O_VALB(in1) && O_VALB(in2)
+	case OR:
+	    result = O_VALB(in1) || O_VALB(in2)
+
+	case LT, GE:
+	    if (dtype == TY_INT)
+		result = i1 < i2
+	    else if (dtype == TY_REAL)
+		result = r1 < r2
+	    else
+		result = strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0
+	    if (opcode == GE)
+		result = !result
+
+	case GT, LE:
+	    if (dtype == TY_INT)
+		result = i1 > i2
+	    else if (dtype == TY_REAL)
+		result = r1 > r2
+	    else
+		result = strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0
+	    if (opcode == LE)
+		result = !result
+
+	case EQ, SE, NE:
+	    switch (dtype) {
+	    case TY_BOOL:
+		if (O_VALB(in1))
+		    result =  O_VALB(in2)
+		else
+		    result = !O_VALB(in2)
+	    case TY_CHAR:
+		if (opcode == SE)
+		    result = xev_patmatch (O_VALC(in1), O_VALC(in2)) > 0
+		else
+		    result = strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0
+	    case TY_INT:
+		result = i1 == i2
+	    case TY_REAL:
+		result = r1 == r2
+	    default:
+		goto badsw_
+	    }
+	    if (opcode == NE)
+		result = !result
+
+	default:
+badsw_	    call xev_error ("bad switch in boolop")
+	}
+
+	call xev_makeop (out, 0, TY_BOOL)
+	O_VALB(out) = result
+
+	# Free storage if there were any string type input operands.
+	call xev_freeop (in1)
+	call xev_freeop (in2)
+end
+
+
+# XEV_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 xev_patmatch (str, pat)
+
+char	str[ARB]		# operand string
+char	pat[ARB]		# 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
+
+
+# XEV_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 xev_newtype (type1, type2)
+
+int	type1, type2
+int	newtype, p, q, i
+int	tyindex[NTYPES], ttbl[NTYPES*NTYPES]
+data	tyindex	/TY_BOOL, TY_CHAR,  TY_INT,  TY_REAL/
+data	(ttbl(i),i=1,4)		/TY_BOOL,       0,       0,        0/
+data	(ttbl(i),i=5,8)		/      0, TY_CHAR,       0,        0/
+data	(ttbl(i),i=9,12)	/      0,       0,  TY_INT,  TY_REAL/
+data	(ttbl(i),i=13,16)	/      0,       0, TY_REAL,  TY_REAL/
+
+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 xev_error ("operands have incompatible types")
+	else
+	    return (newtype)
+end
+
+
+# XEV_QUEST -- Conditional expression.  If the condition operand is true
+# return the first (true) operand, else return the second (false) operand.
+
+procedure xev_quest (cond, trueop, falseop, out)
+
+pointer	cond			# pointer to condition operand
+pointer	trueop, falseop		# pointer to true,false operands
+pointer	out			# pointer to output operand
+errchk	xev_error
+
+begin
+	if (O_TYPE(cond) != TY_BOOL)
+	    call xev_error ("nonboolean condition operand")
+
+	if (O_VALB(cond)) {
+	    YYMOVE (trueop, out)
+	    call xev_freeop (falseop)
+	} else {
+	    YYMOVE (falseop, out)
+	    call xev_freeop (trueop)
+	}
+end
+
+
+# XEV_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 xev_callfcn (fcn, args, nargs, out)
+
+char	fcn[ARB]		# function to be called
+pointer	args[ARB]		# pointer to arglist descriptor
+int	nargs			# number of arguments
+pointer	out			# output operand (function value)
+
+real	rresult, rval[2], rtemp
+int	iresult, ival[2], type[2], optype, oplen, itemp
+int	opcode, v_nargs, i
+pointer	sp, buf, ap
+include	"evexpr.com"
+
+bool	strne()
+int	strdic(), strlen()
+errchk	zcall4, xev_error1, xev_error2, malloc
+string	keywords KEYWORDS
+define	badtype_ 91
+define	free_ 92
+
+begin
+	call smark (sp)
+	call salloc (buf, SZ_FNAME, TY_CHAR)
+
+	oplen = 0
+
+	# Lookup the function name in the dictionary.  An exact match is
+	# required (strdic permits abbreviations).
+
+	opcode = strdic (fcn, Memc[buf], SZ_FNAME, keywords)
+	if (opcode > 0 && strne(fcn,Memc[buf]))
+	    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 zcall4 (ev_ufcn, fcn, args, nargs, out)
+		goto free_
+	    } else
+		call xev_error1 ("unknown function `%s' called", fcn)
+
+	# Verify correct number of arguments.
+	switch (opcode) {
+	case F_MOD:
+	    v_nargs = 2
+	case F_MAX, F_MIN, F_ATAN, F_ATAN2:
+	    v_nargs = -1
+	default:
+	    v_nargs = 1
+	}
+
+	if (v_nargs > 0 && nargs != v_nargs)
+	    call xev_error2 ("function `%s' requires %d arguments",
+		fcn, v_nargs)
+	else if (v_nargs < 0 && nargs < abs(v_nargs))
+	    call xev_error2 ("function `%s' requires at least %d arguments",
+		fcn, abs(v_nargs))
+
+	# Verify datatypes.
+	if (opcode != F_STR && opcode != F_BOOL) {
+	    optype = TY_REAL
+	    do i = 1, min(2,nargs) {
+		switch (O_TYPE(args[i])) {
+		case TY_INT:
+		    ival[i] = O_VALI(args[i])
+		    rval[i] = ival[i]
+		    type[i] = TY_INT
+		case TY_REAL:
+		    rval[i] = O_VALR(args[i])
+		    ival[i] = nint (rval[i])
+		    type[i] = TY_REAL
+		default:
+		    goto badtype_
+		}
+	    }
+	}
+
+	# Evaluate the function.
+
+	ap = args[1]
+
+	switch (opcode) {
+	case F_ABS:
+	    if (type[1] == TY_INT) {
+		iresult = abs (ival[1])
+		optype = TY_INT
+	    } else
+		rresult = abs (rval[1])
+
+	case F_ACOS:
+	    rresult = RTOD (acos (rval[1]))
+	case F_ASIN:
+	    rresult = RTOD (asin (rval[1]))
+	case F_COS:
+	    rresult =   cos (DTOR (rval[1]))
+	case F_EXP:
+	    rresult =   exp (rval[1])
+	case F_LOG:
+	    rresult =   log (rval[1])
+	case F_LOG10:
+	    rresult = log10 (rval[1])
+	case F_SIN:
+	    rresult =   sin (DTOR (rval[1]))
+	case F_SQRT:
+	    rresult =  sqrt (rval[1])
+	case F_TAN:
+	    rresult =   tan (DTOR (rval[1]))
+
+	case F_ATAN, F_ATAN2:
+	    if (nargs == 1)
+		rresult = RTOD (atan (rval[1]))
+	    else
+		rresult = RTOD (atan2 (rval[1], rval[2]))
+
+	case F_MOD:
+	    if (type[1] == TY_REAL || type[2] == TY_REAL)
+		rresult = mod (rval[1], rval[2])
+	    else {
+		iresult = mod (ival[1], ival[2])
+		optype = TY_INT
+	    }
+		
+	case F_NINT:
+	    iresult = nint (rval[1])
+	    optype = TY_INT
+
+	case F_MAX, F_MIN:
+	    # Determine datatype of result.
+	    optype = TY_INT
+	    do i = 1, nargs
+		if (O_TYPE(args[i]) == TY_REAL)
+		    optype = TY_REAL
+		else if (O_TYPE(args[i]) != TY_INT)
+		    goto badtype_
+
+	    # Compute result.
+	    if (optype == TY_INT) {
+		iresult = O_VALI(ap)
+		do i = 2, nargs {
+		    itemp = O_VALI(args[i])
+		    if (opcode == F_MAX)
+			iresult = max (iresult, itemp)
+		    else
+			iresult = min (iresult, itemp)
+		}
+
+	    } else {
+		if (O_TYPE(ap) == TY_INT)
+		    rresult = O_VALI(ap)
+		else
+		    rresult = O_VALR(ap)
+
+		do i = 2, nargs {
+		    if (O_TYPE(args[i]) == TY_INT)
+			rtemp = O_VALI(args[i])
+		    else
+			rtemp = O_VALR(args[i])
+		    if (opcode == F_MAX)
+			rresult = max (rresult, rtemp)
+		    else
+			rresult = min (rresult, rtemp)
+		}
+	    }
+
+	case F_BOOL:
+	    optype = TY_BOOL
+	    switch (O_TYPE(ap)) {
+	    case TY_BOOL:
+		if (O_VALB(ap))
+		    iresult = 1
+		else
+		    iresult = 0
+	    case TY_CHAR:
+		iresult = strlen (O_VALC(ap))
+	    case TY_INT:
+		iresult = O_VALI(ap)
+	    case TY_REAL:
+		if (abs(rval[1]) > .001)
+		    iresult = 1
+		else
+		    iresult = 0
+	    default:
+		goto badtype_
+	    }
+
+	case F_INT:
+	    optype = TY_INT
+	    if (type[1] == TY_INT)
+		iresult = ival[1]
+	    else
+		iresult = rval[1]
+		
+	case F_REAL:
+	    rresult = rval[1]
+
+	case F_STR:
+	    # Convert operand to operand of type string.
+
+	    optype = TY_CHAR
+	    switch (O_TYPE(ap)) {
+	    case TY_BOOL:
+		call malloc (iresult, 3, TY_CHAR)
+		oplen = 3
+		if (O_VALB(ap))
+		    call strcpy ("yes", Memc[iresult], 3)
+		else
+		    call strcpy ("no",  Memc[iresult], 3)
+	    case TY_CHAR:
+		oplen = strlen (O_VALC(ap))
+		call malloc (iresult, oplen, TY_CHAR)
+		call strcpy (O_VALC(ap), Memc[iresult], ARB)
+	    case TY_INT:
+		oplen = MAX_DIGITS
+		call malloc (iresult, oplen, TY_CHAR)
+		call sprintf (Memc[iresult], SZ_FNAME, "%d")
+		    call pargi (O_VALI(ap))
+	    case TY_REAL:
+		oplen = MAX_DIGITS
+		call malloc (iresult, oplen, TY_CHAR)
+		call sprintf (Memc[iresult], SZ_FNAME, "%g")
+		    call pargr (O_VALR(ap))
+	    default:
+		goto badtype_
+	    }
+
+	default:
+	    call xev_error ("bad switch in callfcn")
+	}
+
+	# Write the result to the output operand.  Bool results are stored in
+	# iresult as an integer value, string results are stored in iresult as
+	# a pointer to the output string, and integer and real results are
+	# stored in iresult and rresult without any tricks.
+
+	call xev_initop (out, oplen, optype)
+
+	switch (optype) {
+	case TY_BOOL:
+	    O_VALB(out) = (iresult != 0)
+	case TY_CHAR:
+	    O_VALP(out) = iresult
+	case TY_INT:
+	    O_VALI(out) = iresult
+	case TY_REAL:
+	    O_VALR(out) = rresult
+	}
+
+free_
+	# Free any storage used by the argument list operands.
+	do i = 1, nargs
+	    call xev_freeop (args[i])
+
+	call sfree (sp)
+	return
+
+badtype_
+	call xev_error1 ("bad argument to function `%s'", fcn)
+	call sfree (sp)
+	return
+end
+
+
+# XEV_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 xev_startarglist (arg, out)
+
+pointer	arg			# pointer to first argument, or NULL
+pointer	out			# output operand pointing to arg descriptor
+pointer	ap
+
+errchk	malloc
+
+begin
+	call xev_initop (out, 0, TY_POINTER)
+	call malloc (ap, LEN_ARGSTRUCT, TY_STRUCT)
+	O_VALP(out) = ap
+
+	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
+
+
+# XEV_ADDARG -- Add an argument to the argument list for a function call.
+
+procedure xev_addarg (arg, arglist, out)
+
+pointer	arg			# pointer to argument to be added
+pointer	arglist			# pointer to operand pointing to arglist
+pointer	out			# 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 xev_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
+
+
+# XEV_ERROR1 -- Take an error action, formatting an error message with one
+# format string plus one string argument.
+
+procedure xev_error1 (fmt, arg)
+
+char	fmt[ARB]		# printf format string
+char	arg[ARB]		# 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 xev_error (Memc[buf])
+	call sfree (sp)
+end
+
+
+# XEV_ERROR2 -- Take an error action, formatting an error message with one
+# format string plus one string argument and one integer argument.
+
+procedure xev_error2 (fmt, arg1, arg2)
+
+char	fmt[ARB]		# printf format string
+char	arg1[ARB]		# string argument
+int	arg2			# 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 xev_error (Memc[buf])
+	call sfree (sp)
+end
+
+
+# XEV_ERROR -- Take an error action, given an error message string as the
+# sole argument.
+
+procedure xev_error (errmsg)
+
+char	errmsg[ARB]			# error message
+
+begin
+	call error (1, errmsg)
+end
+
+
+# XEV_INITOP -- Set up an unintialized operand structure.
+
+procedure xev_initop (o, o_len, o_type)
+
+pointer	o		# pointer to operand structure
+int	o_len		# length of operand (zero if scalar)
+int	o_type		# datatype of operand
+
+begin
+	O_LEN(o) = 0
+	call xev_makeop (o, o_len, o_type)
+end
+
+
+# XEV_MAKEOP -- Set up the operand structure.  If the operand structure has
+# already been initialized and array storage allocated, free the old array.
+
+procedure xev_makeop (o, o_len, o_type)
+
+pointer	o		# pointer to operand structure
+int	o_len		# length of operand (zero if scalar)
+int	o_type		# datatype of operand
+
+errchk	malloc
+
+begin
+	# Free old array storage if any.
+	if (O_TYPE(o) != 0 && O_LEN(o) > 1) {
+	    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) {
+	    call malloc (O_VALP(o), o_len, o_type)
+	    O_LEN(o) = o_len
+	}
+end
+
+
+# XEV_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 xev_freeop (o)
+
+pointer	o		# pointer to operand structure
+
+begin
+	# Free old array storage if any.
+	if (O_TYPE(o) != 0 && O_LEN(o) > 1) {
+	    call mfree (O_VALP(o), O_TYPE(o))
+	    O_LEN(o) = 0
+	}
+
+	# Clear the operand type to mark operand invalid.
+	O_TYPE(o) = 0
+end
+define	YYNPROD		33
+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
+
+
+# XEV_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	zcall2, xev_error1, xev_unop, xev_binop, xev_boolop
+errchk	xev_quest, xev_callfcn, xev_addarg
+include	"evexpr.com"
+
+short	yyexca[96]
+data	(yyexca(i),i=  1,  8)	/  -1,   1,   0,  -1,  -2,   0,  -1,   4/
+data	(yyexca(i),i=  9, 16)	/  40,  27,  -2,   3,  -1,   5,  40,  26/
+data	(yyexca(i),i= 17, 24)	/  -2,   4,  -1,  61, 269,   0, 270,   0/
+data	(yyexca(i),i= 25, 32)	/ 271,   0, 279,   0,  -2,  16,  -1,  62/
+data	(yyexca(i),i= 33, 40)	/ 269,   0, 270,   0, 271,   0, 279,   0/
+data	(yyexca(i),i= 41, 48)	/  -2,  17,  -1,  63, 269,   0, 270,   0/
+data	(yyexca(i),i= 49, 56)	/ 271,   0, 279,   0,  -2,  18,  -1,  64/
+data	(yyexca(i),i= 57, 64)	/ 269,   0, 270,   0, 271,   0, 279,   0/
+data	(yyexca(i),i= 65, 72)	/  -2,  19,  -1,  65, 272,   0, 273,   0/
+data	(yyexca(i),i= 73, 80)	/ 274,   0,  -2,  20,  -1,  66, 272,   0/
+data	(yyexca(i),i= 81, 88)	/ 273,   0, 274,   0,  -2,  21,  -1,  67/
+data	(yyexca(i),i= 89, 96)	/ 272,   0, 273,   0, 274,   0,  -2,  22/
+short	yyact[303]
+data	(yyact(i),i=  1,  8)	/  12,  13,  14,  15,  16,  17,  27,  71/
+data	(yyact(i),i=  9, 16)	/  20,  21,  22,  24,  26,  25,  18,  19/
+data	(yyact(i),i= 17, 24)	/  51,  16,  23,  11,  12,  13,  14,  15/
+data	(yyact(i),i= 25, 32)	/  16,  17,  27,  28,  20,  21,  22,  24/
+data	(yyact(i),i= 33, 40)	/  26,  25,  18,  19,  31,  49,  23,  12/
+data	(yyact(i),i= 41, 48)	/  13,  14,  15,  16,  17,  27,  10,  20/
+data	(yyact(i),i= 49, 56)	/  21,  22,  24,  26,  25,  18,  19,  10/
+data	(yyact(i),i= 57, 64)	/   9,  23,  12,  13,  14,  15,  16,  17/
+data	(yyact(i),i= 65, 72)	/  10,   1,  20,  21,  22,  24,  26,  25/
+data	(yyact(i),i= 73, 80)	/  18,  14,  15,  16,  23,  12,  13,  14/
+data	(yyact(i),i= 81, 88)	/  15,  16,  17,   0,   0,  20,  21,  22/
+data	(yyact(i),i= 89, 96)	/  24,  26,  25,  69,   0,   0,  70,  23/
+data	(yyact(i),i= 97,104)	/  12,  13,  14,  15,  16,  17,   0,   0/
+data	(yyact(i),i=105,112)	/  20,  21,  22,  12,  13,  14,  15,  16/
+data	(yyact(i),i=113,120)	/  17,   2,  23,  12,  13,  14,  15,  16/
+data	(yyact(i),i=121,128)	/   0,  29,  30,   0,  32,   0,   0,   0/
+data	(yyact(i),i=129,136)	/   0,   0,   0,   0,   0,   0,   0,   0/
+data	(yyact(i),i=137,144)	/   0,   0,   0,   0,   0,   0,   0,   0/
+data	(yyact(i),i=145,152)	/   0,  50,   0,  52,  54,  55,  56,  57/
+data	(yyact(i),i=153,160)	/  58,  59,  60,  61,  62,  63,  64,  65/
+data	(yyact(i),i=161,168)	/  66,  67,  68,   0,   0,   0,   0,   0/
+data	(yyact(i),i=169,176)	/   0,   0,   0,   0,   0,   0,   0,   0/
+data	(yyact(i),i=177,184)	/   0,   0,   0,   0,  33,   0,   0,   0/
+data	(yyact(i),i=185,192)	/  72,   0,   0,  74,   0,   0,   0,   0/
+data	(yyact(i),i=193,200)	/   0,   0,  34,  35,  36,  37,  38,  39/
+data	(yyact(i),i=201,208)	/  40,  41,  42,  43,  44,  45,  46,  47/
+data	(yyact(i),i=209,216)	/  48,   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,  12,  13,  14,  15/
+data	(yyact(i),i=241,248)	/  16,  17,  27,   0,  20,  21,  22,  24/
+data	(yyact(i),i=249,256)	/  26,  25,  18,  19,  73,   0,  23,   0/
+data	(yyact(i),i=257,264)	/   0,   0,   0,   0,   0,   0,   0,   4/
+data	(yyact(i),i=265,272)	/   5,  53,   0,   0,   7,   0,   0,   3/
+data	(yyact(i),i=273,280)	/   4,   5,   0,   0,   0,   7,   0,   0/
+data	(yyact(i),i=281,288)	/   0,   4,   5,   8,   6,   0,   7,   0/
+data	(yyact(i),i=289,296)	/   0,   0,   0,   0,   8,   6,   0,   0/
+data	(yyact(i),i=297,303)	/   0,   0,   0,   0,   0,   8,   6/
+short	yypact[75]
+data	(yypact(i),i=  1,  8)	/  15,-1000,-241,-1000,-1000,-1000,-230,  24/
+data	(yypact(i),i=  9, 16)	/  24,  -4,  24,-1000,-1000,-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,  24/
+data	(yypact(i),i= 33, 40)	/ -25,   6,   6,   6,   6,   6,   6,   6/
+data	(yypact(i),i= 41, 48)	/   6,   6,   6,   6,   6,   6,   6,   6/
+data	(yypact(i),i= 49, 56)	/   6,  50,-222,-1000,-190,-1000,-190,-248/
+data	(yypact(i),i= 57, 64)	/-248,-1000,-146,-184,-203,-154,-154,-154/
+data	(yypact(i),i= 65, 72)	/-154,-165,-165,-165,-261,-1000,  24,-1000/
+data	(yypact(i),i= 73, 75)	/-222,   6,-222/
+short	yypgo[6]
+data	(yypgo(i),i=  1,  6)	/   0,  65, 113, 180,  56,  37/
+short	yyr1[33]
+data	(yyr1(i),i=  1,  8)	/   0,   1,   1,   2,   2,   2,   2,   2/
+data	(yyr1(i),i=  9, 16)	/   2,   2,   2,   2,   2,   2,   2,   2/
+data	(yyr1(i),i= 17, 24)	/   2,   2,   2,   2,   2,   2,   2,   2/
+data	(yyr1(i),i= 25, 32)	/   2,   2,   4,   4,   5,   5,   5,   3/
+data	(yyr1(i),i= 33, 33)	/   3/
+short	yyr2[33]
+data	(yyr2(i),i=  1,  8)	/   0,   2,   1,   1,   1,   2,   2,   2/
+data	(yyr2(i),i=  9, 16)	/   4,   4,   4,   4,   4,   4,   4,   4/
+data	(yyr2(i),i= 17, 24)	/   4,   4,   4,   4,   4,   4,   4,   7/
+data	(yyr2(i),i= 25, 32)	/   4,   3,   1,   1,   0,   1,   3,   0/
+data	(yyr2(i),i= 33, 33)	/   2/
+short	yychk[75]
+data	(yychk(i),i=  1,  8)	/-1000,  -1,  -2, 256, 257, 258, 278, 262/
+data	(yychk(i),i=  9, 16)	/ 277,  -4,  40, 260, 261, 262, 263, 264/
+data	(yychk(i),i= 17, 24)	/ 265, 266, 275, 276, 269, 270, 271, 279/
+data	(yychk(i),i= 25, 32)	/ 272, 274, 273, 267, 257,  -2,  -2,  40/
+data	(yychk(i),i= 33, 40)	/  -2,  -3,  -3,  -3,  -3,  -3,  -3,  -3/
+data	(yychk(i),i= 41, 48)	/  -3,  -3,  -3,  -3,  -3,  -3,  -3,  -3/
+data	(yychk(i),i= 49, 56)	/  -3,  -5,  -2,  41,  -2, 259,  -2,  -2/
+data	(yychk(i),i= 57, 64)	/  -2,  -2,  -2,  -2,  -2,  -2,  -2,  -2/
+data	(yychk(i),i= 65, 72)	/  -2,  -2,  -2,  -2,  -2,  41,  44, 268/
+data	(yychk(i),i= 73, 75)	/  -2,  -3,  -2/
+short	yydef[75]
+data	(yydef(i),i=  1,  8)	/   0,  -2,   0,   2,  -2,  -2,   0,   0/
+data	(yydef(i),i=  9, 16)	/   0,   0,   0,   1,  31,  31,  31,  31/
+data	(yydef(i),i= 17, 24)	/  31,  31,  31,  31,  31,  31,  31,  31/
+data	(yydef(i),i= 25, 32)	/  31,  31,  31,  31,   5,   6,   7,  28/
+data	(yydef(i),i= 33, 40)	/   0,   0,   0,   0,   0,   0,   0,   0/
+data	(yydef(i),i= 41, 48)	/   0,   0,   0,   0,   0,   0,   0,   0/
+data	(yydef(i),i= 49, 56)	/   0,   0,  29,  25,   8,  32,   9,  10/
+data	(yydef(i),i= 57, 64)	/  11,  12,  13,  14,  15,  -2,  -2,  -2/
+data	(yydef(i),i= 65, 72)	/  -2,  -2,  -2,  -2,   0,  24,   0,  31/
+data	(yydef(i),i= 73, 75)	/  30,   0,  23/
+
+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 135 "evexpr.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)
+			return (OK)
+		}
+case 2:
+# line 143 "evexpr.y"
+{
+			call error (1, "syntax error")
+		}
+case 3:
+# line 149 "evexpr.y"
+{
+			# Numeric constant.
+			YYMOVE (yypvt, yyval)
+		    }
+case 4:
+# line 153 "evexpr.y"
+{
+			# The boolean constants "yes" and "no" are implemented
+			# as reserved operands.
+
+			call xev_initop (yyval, 0, TY_BOOL)
+			if (streq (O_VALC(yypvt), "yes"))
+			    O_VALB(yyval) = true
+			else if (streq (O_VALC(yypvt), "no"))
+			    O_VALB(yyval) = false
+			else if (ev_getop != NULL)
+			    call zcall2 (ev_getop, O_VALC(yypvt), yyval)
+			else
+			    call xev_error1 ("illegal operand `%s'", O_VALC(yypvt))
+			call xev_freeop (yypvt)
+		    }
+case 5:
+# line 168 "evexpr.y"
+{
+			# e.g., @"param"
+			if (ev_getop != NULL)
+			    call zcall2 (ev_getop, O_VALC(yypvt), yyval)
+			else
+			    call xev_error1 ("illegal operand `%s'", O_VALC(yypvt))
+			call xev_freeop (yypvt)
+		    }
+case 6:
+# line 176 "evexpr.y"
+{
+			# Unary arithmetic minus.
+			call xev_unop (MINUS, yypvt, yyval)
+		    }
+case 7:
+# line 180 "evexpr.y"
+{
+			# Boolean not.
+			call xev_unop (NOT, yypvt, yyval)
+		    }
+case 8:
+# line 184 "evexpr.y"
+{
+			# Addition.
+			call xev_binop (PLUS, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 9:
+# line 188 "evexpr.y"
+{
+			# Subtraction.
+			call xev_binop (MINUS, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 10:
+# line 192 "evexpr.y"
+{
+			# Multiplication.
+			call xev_binop (STAR, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 11:
+# line 196 "evexpr.y"
+{
+			# Division.
+			call xev_binop (SLASH, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 12:
+# line 200 "evexpr.y"
+{
+			# Exponentiation.
+			call xev_binop (EXPON, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 13:
+# line 204 "evexpr.y"
+{
+			# String concatenation.
+			call xev_binop (CONCAT, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 14:
+# line 208 "evexpr.y"
+{
+			# Boolean and.
+			call xev_boolop (AND, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 15:
+# line 212 "evexpr.y"
+{
+			# Boolean or.
+			call xev_boolop (OR, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 16:
+# line 216 "evexpr.y"
+{
+			# Boolean less than.
+			call xev_boolop (LT, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 17:
+# line 220 "evexpr.y"
+{
+			# Boolean greater than.
+			call xev_boolop (GT, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 18:
+# line 224 "evexpr.y"
+{
+			# Boolean less than or equal.
+			call xev_boolop (LE, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 19:
+# line 228 "evexpr.y"
+{
+			# Boolean greater than or equal.
+			call xev_boolop (GE, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 20:
+# line 232 "evexpr.y"
+{
+			# Boolean equal.
+			call xev_boolop (EQ, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 21:
+# line 236 "evexpr.y"
+{
+			# String pattern-equal.
+			call xev_boolop (SE, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 22:
+# line 240 "evexpr.y"
+{
+			# Boolean not equal.
+			call xev_boolop (NE, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 23:
+# line 244 "evexpr.y"
+{
+			# Conditional expression.
+			call xev_quest (yypvt-6*YYOPLEN, yypvt-3*YYOPLEN, yypvt, yyval)
+		    }
+case 24:
+# line 248 "evexpr.y"
+{
+			# Call an intrinsic or external function.
+			ap = O_VALP(yypvt-YYOPLEN)
+			call xev_callfcn (O_VALC(yypvt-3*YYOPLEN),
+			    A_ARGP(ap,1), A_NARGS(ap), yyval)
+			call mfree (ap, TY_STRUCT)
+			call xev_freeop (yypvt-3*YYOPLEN)
+		    }
+case 25:
+# line 256 "evexpr.y"
+{
+			YYMOVE (yypvt-YYOPLEN, yyval)
+		    }
+case 26:
+# line 262 "evexpr.y"
+{
+			YYMOVE (yypvt, yyval)
+		    }
+case 27:
+# line 265 "evexpr.y"
+{
+			if (O_TYPE(yypvt) != TY_CHAR)
+			    call error (1, "illegal function name")
+			YYMOVE (yypvt, yyval)
+		    }
+case 28:
+# line 273 "evexpr.y"
+{
+			# Empty.
+			call xev_startarglist (NULL, yyval)
+		    }
+case 29:
+# line 277 "evexpr.y"
+{
+			# First arg; start a nonnull list.
+			call xev_startarglist (yypvt, yyval)
+		    }
+case 30:
+# line 281 "evexpr.y"
+{
+			# Add an argument to an existing list.
+			call xev_addarg (yypvt, yypvt-2*YYOPLEN, yyval)
+		    }	}
+
+	goto yystack_				# stack new state and value
+end
diff --git a/sys/fmtio/evexpr.y b/sys/fmtio/evexpr.y
new file mode 100644
index 00000000..297950bc
--- /dev/null
+++ b/sys/fmtio/evexpr.y
@@ -0,0 +1,1087 @@
+%{
+include	<lexnum.h>
+include	<ctype.h>
+include	<mach.h>
+include	<evexpr.h>
+
+define	YYMAXDEPTH	64		# parser stack length
+define	MAX_ARGS	16		# max args in a function call
+define	yyparse		xev_parse
+
+define	DTOR		(($1)/57.2957795)
+define	RTOD		(($1)*57.2957795)
+
+# 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	KEYWORDS	"|abs|acos|asin|atan|atan2|bool|cos|exp|int|log|log10|\
+			 |max|min|mod|nint|real|sin|sqrt|str|tan|"
+
+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_EXP		08
+define	F_INT		09
+define	F_LOG		10
+define	F_LOG10		11
+	# newline	12
+define	F_MAX		13
+define	F_MIN		14
+define	F_MOD		15
+define	F_NINT		16
+define	F_REAL		17
+define	F_SIN		18
+define	F_SQRT		19
+define	F_STR		20
+define	F_TAN 		21
+
+
+# EVEXPR -- Evaluate an expression.  This is the top level procedure, and the
+# only externally callable entry point.  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 EVEXPR and must be
+# freed by the user.
+#
+# N.B.: 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.
+
+pointer procedure evexpr (expr, getop_epa, ufcn_epa)
+
+char	expr[ARB]		# expression to be evaluated
+int	getop_epa		# user supplied get operand procedure
+int	ufcn_epa		# user supplied function call procedure
+
+int	junk
+bool	debug
+pointer	sp, ip
+extern	xev_gettok()
+int	strlen(), xev_parse()
+
+errchk	xev_parse, calloc
+include	"evexpr.com"
+data	debug /false/
+
+begin
+	call smark (sp)
+
+	# Set user function entry point addresses.
+	ev_getop = getop_epa
+	ev_ufcn  = ufcn_epa
+
+	# 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 XEV_PARSE, given the operand pointer
+	# passed in common.  A common must be used since the standard parser
+	# subroutine has a fixed calling sequence.
+
+	junk = xev_parse (ip, debug, xev_gettok)
+
+	call sfree (sp)
+	return (ev_oval)
+end
+
+%L
+# XEV_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	zcall2, xev_error1, xev_unop, xev_binop, xev_boolop
+errchk	xev_quest, xev_callfcn, xev_addarg
+include	"evexpr.com"
+
+%}
+
+%token		CONSTANT IDENTIFIER NEWLINE YYEOS
+%token		PLUS MINUS STAR SLASH EXPON CONCAT QUEST COLON
+%token		LT GT LE GT EQ NE SE AND OR NOT AT
+
+%nonassoc	QUEST
+%left		OR
+%left 		AND
+%nonassoc	EQ NE SE
+%nonassoc	LT GT LE GE
+%left		CONCAT
+%left		PLUS MINUS
+%left		STAR SLASH
+%left		EXPON
+%right		UMINUS NOT
+%right		AT
+
+%%
+
+stmt	:	expr YYEOS {
+			# Normal exit.  Move the final expression value operand
+			# into the operand structure pointed to by the global
+			# variable ev_oval.
+
+			YYMOVE ($1, ev_oval)
+			return (OK)
+		}
+	|	error {
+			call error (1, "syntax error")
+		}
+	;
+
+
+expr	:	CONSTANT {
+			# Numeric constant.
+			YYMOVE ($1, $$)
+		    }
+	|	IDENTIFIER {
+			# The boolean constants "yes" and "no" are implemented
+			# as reserved operands.
+
+			call xev_initop ($$, 0, TY_BOOL)
+			if (streq (O_VALC($1), "yes"))
+			    O_VALB($$) = true
+			else if (streq (O_VALC($1), "no"))
+			    O_VALB($$) = false
+			else if (ev_getop != NULL)
+			    call zcall2 (ev_getop, O_VALC($1), $$)
+			else
+			    call xev_error1 ("illegal operand `%s'", O_VALC($1))
+			call xev_freeop ($1)
+		    }
+	|	AT CONSTANT {
+			# e.g., @"param"
+			if (ev_getop != NULL)
+			    call zcall2 (ev_getop, O_VALC($2), $$)
+			else
+			    call xev_error1 ("illegal operand `%s'", O_VALC($2))
+			call xev_freeop ($2)
+		    }
+	|	MINUS expr %prec UMINUS {
+			# Unary arithmetic minus.
+			call xev_unop (MINUS, $2, $$)
+		    }
+	|	NOT expr {
+			# Boolean not.
+			call xev_unop (NOT, $2, $$)
+		    }
+	|	expr PLUS opnl expr {
+			# Addition.
+			call xev_binop (PLUS, $1, $4, $$)
+		    }
+	|	expr MINUS opnl expr {
+			# Subtraction.
+			call xev_binop (MINUS, $1, $4, $$)
+		    }
+	| 	expr STAR opnl expr {
+			# Multiplication.
+			call xev_binop (STAR, $1, $4, $$)
+		    }
+	|	expr SLASH opnl expr {
+			# Division.
+			call xev_binop (SLASH, $1, $4, $$)
+		    }
+	|	expr EXPON opnl expr {
+			# Exponentiation.
+			call xev_binop (EXPON, $1, $4, $$)
+		    }
+	|	expr CONCAT opnl expr {
+			# String concatenation.
+			call xev_binop (CONCAT, $1, $4, $$)
+		    }
+	|	expr AND opnl expr {
+			# Boolean and.
+			call xev_boolop (AND, $1, $4, $$)
+		    }
+	|	expr OR opnl expr {
+			# Boolean or.
+			call xev_boolop (OR, $1, $4, $$)
+		    }
+	|	expr LT opnl expr {
+			# Boolean less than.
+			call xev_boolop (LT, $1, $4, $$)
+		    }
+	|	expr GT opnl expr {
+			# Boolean greater than.
+			call xev_boolop (GT, $1, $4, $$)
+		    }
+	|	expr LE opnl expr {
+			# Boolean less than or equal.
+			call xev_boolop (LE, $1, $4, $$)
+		    }
+	|	expr GE opnl expr {
+			# Boolean greater than or equal.
+			call xev_boolop (GE, $1, $4, $$)
+		    }
+	|	expr EQ opnl expr {
+			# Boolean equal.
+			call xev_boolop (EQ, $1, $4, $$)
+		    }
+	|	expr SE opnl expr {
+			# String pattern-equal.
+			call xev_boolop (SE, $1, $4, $$)
+		    }
+	|	expr NE opnl expr {
+			# Boolean not equal.
+			call xev_boolop (NE, $1, $4, $$)
+		    }
+	|	expr QUEST opnl expr COLON opnl expr {
+			# Conditional expression.
+			call xev_quest ($1, $4, $7, $$)
+		    }
+	|	funct '(' arglist ')' {
+			# Call an intrinsic or external function.
+			ap = O_VALP($3)
+			call xev_callfcn (O_VALC($1),
+			    A_ARGP(ap,1), A_NARGS(ap), $$)
+			call mfree (ap, TY_STRUCT)
+			call xev_freeop ($1)
+		    }
+	|	'(' expr ')' {
+			YYMOVE ($2, $$)
+		    }
+	;
+
+
+funct	:	IDENTIFIER {
+			YYMOVE ($1, $$)
+		    }
+	|	CONSTANT {
+			if (O_TYPE($1) != TY_CHAR)
+			    call error (1, "illegal function name")
+			YYMOVE ($1, $$)
+		    }
+	;
+
+
+arglist	:	{
+			# Empty.
+			call xev_startarglist (NULL, $$)
+		    }
+	|	expr {
+			# First arg; start a nonnull list.
+			call xev_startarglist ($1, $$)
+		    }
+	|	arglist ',' expr {
+			# Add an argument to an existing list.
+			call xev_addarg ($3, $1, $$)
+		    }
+	;
+
+
+opnl	:	# Empty.
+	|	opnl NEWLINE
+	;
+
+%%
+
+
+# XEV_UNOP -- Unary operation.  Perform the indicated unary operation on the
+# input operand, returning the result as the output operand.
+
+procedure xev_unop (opcode, in, out)
+
+int	opcode			# operation to be performed
+pointer	in			# input operand
+pointer	out			# output operand
+
+errchk	xev_error
+define	badsw_ 91
+
+begin
+	call xev_initop (out, 0, O_TYPE(in))
+
+	switch (opcode) {
+	case MINUS:
+	    # Unary negation.
+	    switch (O_TYPE(in)) {
+	    case TY_BOOL, TY_CHAR:
+		call xev_error ("negation of a nonarithmetic operand")
+	    case TY_INT:
+		O_VALI(out) = -O_VALI(in)
+	    case TY_REAL:
+		O_VALR(out) = -O_VALR(in)
+	    default:
+		goto badsw_
+	    }
+
+	case NOT:
+	    switch (O_TYPE(in)) {
+	    case TY_BOOL:
+		O_VALB(out) = !O_VALB(in)
+	    case TY_CHAR, TY_INT, TY_REAL:
+		call xev_error ("not of a nonlogical")
+	    default:
+		goto badsw_
+	    }
+
+	default:
+badsw_	    call xev_error ("bad switch in unop")
+	}
+end
+
+
+# XEV_BINOP -- Binary operation.  Perform the indicated arithmetic binary
+# operation on the two input operands, returning the result as the output
+# operand.
+
+procedure xev_binop (opcode, in1, in2, out)
+
+int	opcode			# operation to be performed
+pointer	in1, in2		# input operands
+pointer	out			# output operand
+
+real	r1, r2
+int	i1, i2, dtype, nchars
+int	xev_newtype(), strlen()
+errchk	xev_newtype
+
+begin
+	# Set the datatype of the output operand, taking an error action if
+	# the operands have incompatible datatypes.
+
+	dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2))
+	call xev_initop (out, 0, dtype)
+
+	switch (dtype) {
+	case TY_BOOL:
+	    call xev_error ("operation illegal for boolean operands")
+	case TY_CHAR:
+	    if (opcode != CONCAT)
+		call xev_error ("operation illegal for string operands")
+	case TY_INT:
+	    i1 = O_VALI(in1)
+	    i2 = O_VALI(in2)
+	case TY_REAL:
+	    if (O_TYPE(in1) == TY_INT)
+		r1 = O_VALI(in1)
+	    else
+		r1 = O_VALR(in1)
+	    if (O_TYPE(in2) == TY_INT)
+		r2 = O_VALI(in2)
+	    else
+		r2 = O_VALR(in2)
+	default:
+	    call xev_error ("unknown datatype code in binop")
+	}
+
+	# Perform the operation.
+	switch (opcode) {
+	case PLUS:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 + i2
+	    else
+		O_VALR(out) = r1 + r2
+
+	case MINUS:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 - i2
+	    else
+		O_VALR(out) = r1 - r2
+
+	case STAR:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 * i2
+	    else
+		O_VALR(out) = r1 * r2
+
+	case SLASH:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 / i2
+	    else
+		O_VALR(out) = r1 / r2
+
+	case EXPON:
+	    if (dtype == TY_INT)
+		O_VALI(out) = i1 ** i2
+	    else if (O_TYPE(in1) == TY_REAL && O_TYPE(in2) == TY_INT)
+		O_VALR(out) = r1 ** (O_VALI(in2))
+	    else
+		O_VALR(out) = r1 ** r2
+
+	case CONCAT:
+	    if (dtype != TY_CHAR)
+		call xev_error ("concatenation of a nonstring operand")
+	    nchars = strlen (O_VALC(in1)) + strlen (O_VALC(in2))
+	    call xev_makeop (out, nchars, TY_CHAR)
+	    call strcpy (O_VALC(in1), O_VALC(out), ARB)
+	    call strcat (O_VALC(in2), O_VALC(out), ARB)
+	    call xev_freeop (in1)
+	    call xev_freeop (in2)
+
+	default:
+	    call xev_error ("bad switch in binop")
+	}
+end
+
+
+# XEV_BOOLOP -- Boolean binary operations.  Perform the indicated boolean binary
+# operation on the two input operands, returning the result as the output
+# operand.
+
+procedure xev_boolop (opcode, in1, in2, out)
+
+int	opcode			# operation to be performed
+pointer	in1, in2		# input operands
+pointer	out			# output operand
+
+bool	result
+real	r1, r2
+int	i1, i2, dtype
+int	xev_newtype(), xev_patmatch(), strncmp()
+errchk	xev_newtype, xev_error
+define	badsw_ 91
+
+begin
+	# Set the datatype of the output operand, taking an error action if
+	# the operands have incompatible datatypes.
+
+	dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2))
+	call xev_initop (out, 0, dtype)
+
+	switch (opcode) {
+	case AND, OR:
+	    if (dtype != TY_BOOL)
+		call xev_error ("AND or OR of nonlogical")
+	case LT, GT, LE, GE:
+	    if (dtype == TY_BOOL)
+		call xev_error ("order comparison of a boolean operand")
+	}
+
+	if (dtype == TY_INT) {
+	    i1 = O_VALI(in1)
+	    i2 = O_VALI(in2)
+	} else if (dtype == TY_REAL) {
+	    if (O_TYPE(in1) == TY_INT) {
+		i1 = O_VALI(in1)
+		r1 = i1
+	    } else
+		r1 = O_VALR(in1)
+	    if (O_TYPE(in2) == TY_INT) {
+		i2 = O_VALI(in2)
+		r2 = i2
+	    } else
+		r2 = O_VALR(in2)
+	}
+
+	# Perform the operation.
+	switch (opcode) {
+	case AND:
+	    result = O_VALB(in1) && O_VALB(in2)
+	case OR:
+	    result = O_VALB(in1) || O_VALB(in2)
+
+	case LT, GE:
+	    if (dtype == TY_INT)
+		result = i1 < i2
+	    else if (dtype == TY_REAL)
+		result = r1 < r2
+	    else
+		result = strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0
+	    if (opcode == GE)
+		result = !result
+
+	case GT, LE:
+	    if (dtype == TY_INT)
+		result = i1 > i2
+	    else if (dtype == TY_REAL)
+		result = r1 > r2
+	    else
+		result = strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0
+	    if (opcode == LE)
+		result = !result
+
+	case EQ, SE, NE:
+	    switch (dtype) {
+	    case TY_BOOL:
+		if (O_VALB(in1))
+		    result =  O_VALB(in2)
+		else
+		    result = !O_VALB(in2)
+	    case TY_CHAR:
+		if (opcode == SE)
+		    result = xev_patmatch (O_VALC(in1), O_VALC(in2)) > 0
+		else
+		    result = strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0
+	    case TY_INT:
+		result = i1 == i2
+	    case TY_REAL:
+		result = r1 == r2
+	    default:
+		goto badsw_
+	    }
+	    if (opcode == NE)
+		result = !result
+
+	default:
+badsw_	    call xev_error ("bad switch in boolop")
+	}
+
+	call xev_makeop (out, 0, TY_BOOL)
+	O_VALB(out) = result
+
+	# Free storage if there were any string type input operands.
+	call xev_freeop (in1)
+	call xev_freeop (in2)
+end
+
+
+# XEV_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 xev_patmatch (str, pat)
+
+char	str[ARB]		# operand string
+char	pat[ARB]		# 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
+
+
+# XEV_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 xev_newtype (type1, type2)
+
+int	type1, type2
+int	newtype, p, q, i
+int	tyindex[NTYPES], ttbl[NTYPES*NTYPES]
+data	tyindex	/TY_BOOL, TY_CHAR,  TY_INT,  TY_REAL/
+data	(ttbl(i),i=1,4)		/TY_BOOL,       0,       0,        0/
+data	(ttbl(i),i=5,8)		/      0, TY_CHAR,       0,        0/
+data	(ttbl(i),i=9,12)	/      0,       0,  TY_INT,  TY_REAL/
+data	(ttbl(i),i=13,16)	/      0,       0, TY_REAL,  TY_REAL/
+
+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 xev_error ("operands have incompatible types")
+	else
+	    return (newtype)
+end
+
+
+# XEV_QUEST -- Conditional expression.  If the condition operand is true
+# return the first (true) operand, else return the second (false) operand.
+
+procedure xev_quest (cond, trueop, falseop, out)
+
+pointer	cond			# pointer to condition operand
+pointer	trueop, falseop		# pointer to true,false operands
+pointer	out			# pointer to output operand
+errchk	xev_error
+
+begin
+	if (O_TYPE(cond) != TY_BOOL)
+	    call xev_error ("nonboolean condition operand")
+
+	if (O_VALB(cond)) {
+	    YYMOVE (trueop, out)
+	    call xev_freeop (falseop)
+	} else {
+	    YYMOVE (falseop, out)
+	    call xev_freeop (trueop)
+	}
+end
+
+
+# XEV_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 xev_callfcn (fcn, args, nargs, out)
+
+char	fcn[ARB]		# function to be called
+pointer	args[ARB]		# pointer to arglist descriptor
+int	nargs			# number of arguments
+pointer	out			# output operand (function value)
+
+real	rresult, rval[2], rtemp
+int	iresult, ival[2], type[2], optype, oplen, itemp
+int	opcode, v_nargs, i
+pointer	sp, buf, ap
+include	"evexpr.com"
+
+bool	strne()
+int	strdic(), strlen()
+errchk	zcall4, xev_error1, xev_error2, malloc
+string	keywords KEYWORDS
+define	badtype_ 91
+define	free_ 92
+
+begin
+	call smark (sp)
+	call salloc (buf, SZ_FNAME, TY_CHAR)
+
+	oplen = 0
+
+	# Lookup the function name in the dictionary.  An exact match is
+	# required (strdic permits abbreviations).
+
+	opcode = strdic (fcn, Memc[buf], SZ_FNAME, keywords)
+	if (opcode > 0 && strne(fcn,Memc[buf]))
+	    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 zcall4 (ev_ufcn, fcn, args, nargs, out)
+		goto free_
+	    } else
+		call xev_error1 ("unknown function `%s' called", fcn)
+
+	# Verify correct number of arguments.
+	switch (opcode) {
+	case F_MOD:
+	    v_nargs = 2
+	case F_MAX, F_MIN, F_ATAN, F_ATAN2:
+	    v_nargs = -1
+	default:
+	    v_nargs = 1
+	}
+
+	if (v_nargs > 0 && nargs != v_nargs)
+	    call xev_error2 ("function `%s' requires %d arguments",
+		fcn, v_nargs)
+	else if (v_nargs < 0 && nargs < abs(v_nargs))
+	    call xev_error2 ("function `%s' requires at least %d arguments",
+		fcn, abs(v_nargs))
+
+	# Verify datatypes.
+	if (opcode != F_STR && opcode != F_BOOL) {
+	    optype = TY_REAL
+	    do i = 1, min(2,nargs) {
+		switch (O_TYPE(args[i])) {
+		case TY_INT:
+		    ival[i] = O_VALI(args[i])
+		    rval[i] = ival[i]
+		    type[i] = TY_INT
+		case TY_REAL:
+		    rval[i] = O_VALR(args[i])
+		    ival[i] = nint (rval[i])
+		    type[i] = TY_REAL
+		default:
+		    goto badtype_
+		}
+	    }
+	}
+
+	# Evaluate the function.
+
+	ap = args[1]
+
+	switch (opcode) {
+	case F_ABS:
+	    if (type[1] == TY_INT) {
+		iresult = abs (ival[1])
+		optype = TY_INT
+	    } else
+		rresult = abs (rval[1])
+
+	case F_ACOS:
+	    rresult = RTOD (acos (rval[1]))
+	case F_ASIN:
+	    rresult = RTOD (asin (rval[1]))
+	case F_COS:
+	    rresult =   cos (DTOR (rval[1]))
+	case F_EXP:
+	    rresult =   exp (rval[1])
+	case F_LOG:
+	    rresult =   log (rval[1])
+	case F_LOG10:
+	    rresult = log10 (rval[1])
+	case F_SIN:
+	    rresult =   sin (DTOR (rval[1]))
+	case F_SQRT:
+	    rresult =  sqrt (rval[1])
+	case F_TAN:
+	    rresult =   tan (DTOR (rval[1]))
+
+	case F_ATAN, F_ATAN2:
+	    if (nargs == 1)
+		rresult = RTOD (atan (rval[1]))
+	    else
+		rresult = RTOD (atan2 (rval[1], rval[2]))
+
+	case F_MOD:
+	    if (type[1] == TY_REAL || type[2] == TY_REAL)
+		rresult = mod (rval[1], rval[2])
+	    else {
+		iresult = mod (ival[1], ival[2])
+		optype = TY_INT
+	    }
+		
+	case F_NINT:
+	    iresult = nint (rval[1])
+	    optype = TY_INT
+
+	case F_MAX, F_MIN:
+	    # Determine datatype of result.
+	    optype = TY_INT
+	    do i = 1, nargs
+		if (O_TYPE(args[i]) == TY_REAL)
+		    optype = TY_REAL
+		else if (O_TYPE(args[i]) != TY_INT)
+		    goto badtype_
+
+	    # Compute result.
+	    if (optype == TY_INT) {
+		iresult = O_VALI(ap)
+		do i = 2, nargs {
+		    itemp = O_VALI(args[i])
+		    if (opcode == F_MAX)
+			iresult = max (iresult, itemp)
+		    else
+			iresult = min (iresult, itemp)
+		}
+
+	    } else {
+		if (O_TYPE(ap) == TY_INT)
+		    rresult = O_VALI(ap)
+		else
+		    rresult = O_VALR(ap)
+
+		do i = 2, nargs {
+		    if (O_TYPE(args[i]) == TY_INT)
+			rtemp = O_VALI(args[i])
+		    else
+			rtemp = O_VALR(args[i])
+		    if (opcode == F_MAX)
+			rresult = max (rresult, rtemp)
+		    else
+			rresult = min (rresult, rtemp)
+		}
+	    }
+
+	case F_BOOL:
+	    optype = TY_BOOL
+	    switch (O_TYPE(ap)) {
+	    case TY_BOOL:
+		if (O_VALB(ap))
+		    iresult = 1
+		else
+		    iresult = 0
+	    case TY_CHAR:
+		iresult = strlen (O_VALC(ap))
+	    case TY_INT:
+		iresult = O_VALI(ap)
+	    case TY_REAL:
+		if (abs(rval[1]) > .001)
+		    iresult = 1
+		else
+		    iresult = 0
+	    default:
+		goto badtype_
+	    }
+
+	case F_INT:
+	    optype = TY_INT
+	    if (type[1] == TY_INT)
+		iresult = ival[1]
+	    else
+		iresult = rval[1]
+		
+	case F_REAL:
+	    rresult = rval[1]
+
+	case F_STR:
+	    # Convert operand to operand of type string.
+
+	    optype = TY_CHAR
+	    switch (O_TYPE(ap)) {
+	    case TY_BOOL:
+		call malloc (iresult, 3, TY_CHAR)
+		oplen = 3
+		if (O_VALB(ap))
+		    call strcpy ("yes", Memc[iresult], 3)
+		else
+		    call strcpy ("no",  Memc[iresult], 3)
+	    case TY_CHAR:
+		oplen = strlen (O_VALC(ap))
+		call malloc (iresult, oplen, TY_CHAR)
+		call strcpy (O_VALC(ap), Memc[iresult], ARB)
+	    case TY_INT:
+		oplen = MAX_DIGITS
+		call malloc (iresult, oplen, TY_CHAR)
+		call sprintf (Memc[iresult], SZ_FNAME, "%d")
+		    call pargi (O_VALI(ap))
+	    case TY_REAL:
+		oplen = MAX_DIGITS
+		call malloc (iresult, oplen, TY_CHAR)
+		call sprintf (Memc[iresult], SZ_FNAME, "%g")
+		    call pargr (O_VALR(ap))
+	    default:
+		goto badtype_
+	    }
+
+	default:
+	    call xev_error ("bad switch in callfcn")
+	}
+
+	# Write the result to the output operand.  Bool results are stored in
+	# iresult as an integer value, string results are stored in iresult as
+	# a pointer to the output string, and integer and real results are
+	# stored in iresult and rresult without any tricks.
+
+	call xev_initop (out, oplen, optype)
+
+	switch (optype) {
+	case TY_BOOL:
+	    O_VALB(out) = (iresult != 0)
+	case TY_CHAR:
+	    O_VALP(out) = iresult
+	case TY_INT:
+	    O_VALI(out) = iresult
+	case TY_REAL:
+	    O_VALR(out) = rresult
+	}
+
+free_
+	# Free any storage used by the argument list operands.
+	do i = 1, nargs
+	    call xev_freeop (args[i])
+
+	call sfree (sp)
+	return
+
+badtype_
+	call xev_error1 ("bad argument to function `%s'", fcn)
+	call sfree (sp)
+	return
+end
+
+
+# XEV_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 xev_startarglist (arg, out)
+
+pointer	arg			# pointer to first argument, or NULL
+pointer	out			# output operand pointing to arg descriptor
+pointer	ap
+
+errchk	malloc
+
+begin
+	call xev_initop (out, 0, TY_POINTER)
+	call malloc (ap, LEN_ARGSTRUCT, TY_STRUCT)
+	O_VALP(out) = ap
+
+	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
+
+
+# XEV_ADDARG -- Add an argument to the argument list for a function call.
+
+procedure xev_addarg (arg, arglist, out)
+
+pointer	arg			# pointer to argument to be added
+pointer	arglist			# pointer to operand pointing to arglist
+pointer	out			# 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 xev_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
+
+
+# XEV_ERROR1 -- Take an error action, formatting an error message with one
+# format string plus one string argument.
+
+procedure xev_error1 (fmt, arg)
+
+char	fmt[ARB]		# printf format string
+char	arg[ARB]		# 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 xev_error (Memc[buf])
+	call sfree (sp)
+end
+
+
+# XEV_ERROR2 -- Take an error action, formatting an error message with one
+# format string plus one string argument and one integer argument.
+
+procedure xev_error2 (fmt, arg1, arg2)
+
+char	fmt[ARB]		# printf format string
+char	arg1[ARB]		# string argument
+int	arg2			# 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 xev_error (Memc[buf])
+	call sfree (sp)
+end
+
+
+# XEV_ERROR -- Take an error action, given an error message string as the
+# sole argument.
+
+procedure xev_error (errmsg)
+
+char	errmsg[ARB]			# error message
+
+begin
+	call error (1, errmsg)
+end
+
+
+# XEV_INITOP -- Set up an unintialized operand structure.
+
+procedure xev_initop (o, o_len, o_type)
+
+pointer	o		# pointer to operand structure
+int	o_len		# length of operand (zero if scalar)
+int	o_type		# datatype of operand
+
+begin
+	O_LEN(o) = 0
+	call xev_makeop (o, o_len, o_type)
+end
+
+
+# XEV_MAKEOP -- Set up the operand structure.  If the operand structure has
+# already been initialized and array storage allocated, free the old array.
+
+procedure xev_makeop (o, o_len, o_type)
+
+pointer	o		# pointer to operand structure
+int	o_len		# length of operand (zero if scalar)
+int	o_type		# datatype of operand
+
+errchk	malloc
+
+begin
+	# Free old array storage if any.
+	if (O_TYPE(o) != 0 && O_LEN(o) > 1) {
+	    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) {
+	    call malloc (O_VALP(o), o_len, o_type)
+	    O_LEN(o) = o_len
+	}
+end
+
+
+# XEV_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 xev_freeop (o)
+
+pointer	o		# pointer to operand structure
+
+begin
+	# Free old array storage if any.
+	if (O_TYPE(o) != 0 && O_LEN(o) > 1) {
+	    call mfree (O_VALP(o), O_TYPE(o))
+	    O_LEN(o) = 0
+	}
+
+	# Clear the operand type to mark operand invalid.
+	O_TYPE(o) = 0
+end
diff --git a/sys/fmtio/evvexpr.com b/sys/fmtio/evvexpr.com
new file mode 100644
index 00000000..34a98be6
--- /dev/null
+++ b/sys/fmtio/evvexpr.com
@@ -0,0 +1,12 @@
+# EVVEXPR common.
+
+pointer	ev_oval				# pointer to expr value operand
+int	ev_st				# symbol table
+int	ev_getop			# user supplied get operand procedure
+int	ev_getop_data			# client data for above
+int	ev_ufcn				# user supplied function call procedure
+int	ev_ufcn_data			# client data for above
+int	ev_flags			# flag bits
+
+common	/xvvcom/ ev_oval, ev_st, ev_getop, ev_getop_data, ev_ufcn,
+	ev_ufcn_data, ev_flags
diff --git a/sys/fmtio/evvexpr.gy b/sys/fmtio/evvexpr.gy
new file mode 100644
index 00000000..32a91153
--- /dev/null
+++ b/sys/fmtio/evvexpr.gy
@@ -0,0 +1,2680 @@
+%{
+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
+
+%L
+# 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"
+
+%}
+
+# The $/ following causes the generic preprocessor to pass this block of code
+# through unchanged.
+
+$/
+
+%token		CONSTANT IDENTIFIER NEWLINE YYEOS
+%token		PLUS MINUS STAR SLASH EXPON CONCAT QUEST COLON
+%token		LT GT LE GT EQ NE SE LAND LOR LNOT BAND BOR BXOR BNOT AT
+
+%nonassoc	QUEST
+%left		LAND LOR
+%left		BAND BOR BXOR
+%nonassoc	EQ NE SE
+%nonassoc	LT GT LE GE
+%left		CONCAT
+%left		PLUS MINUS
+%left		STAR SLASH
+%right		UMINUS LNOT BNOT
+%left		EXPON
+%right		AT
+
+%%
+
+stmt	:	exprlist YYEOS {
+			# Normal exit.  Move the final expression value operand
+			# into the operand structure pointed to by the global
+			# variable ev_oval.
+
+			YYMOVE ($1, ev_oval)
+			call sfree (yysp)
+			return (OK)
+		}
+	|	error {
+			call error (1, "syntax error")
+		}
+	;
+
+exprlist:	expr {
+			YYMOVE ($1, $$)
+		}
+	|	exprlist ',' opnl expr {
+			YYMOVE ($4, $$)
+			call xvv_freeop ($1)
+		}
+
+
+expr	:	CONSTANT {
+			# Numeric constant.
+			YYMOVE ($1, $$)
+		    }
+	|	IDENTIFIER {
+			# The boolean constants "yes" and "no" are implemented
+			# as reserved operands.
+
+			call xvv_initop ($$, 0, TY_BOOL)
+			if (streq (O_VALC($1), "yes")) {
+			    O_VALI($$) = YES
+			} else if (streq (O_VALC($1), "no")) {
+			    O_VALI($$) = NO
+			} else if (ev_getop != NULL) {
+			    call zcall3 (ev_getop,ev_getop_data, O_VALC($1), $$)
+			    if (O_TYPE($$) <= 0)
+				call xvv_error1 ("unknown operand `%s'",
+				    O_VALC($1))
+			} else
+			    call xvv_error1 ("illegal operand `%s'", O_VALC($1))
+			call xvv_freeop ($1)
+		    }
+	|	AT CONSTANT {
+			# e.g., @"param"
+			if (ev_getop != NULL) {
+			    call zcall3 (ev_getop,ev_getop_data, O_VALC($2), $$)
+			    if (O_TYPE($$) <= 0)
+				call xvv_error1 ("unknown operand `%s'",
+				    O_VALC($1))
+			} else
+			    call xvv_error1 ("illegal operand `%s'", O_VALC($2))
+			call xvv_freeop ($2)
+		    }
+	|	MINUS expr %prec UMINUS {
+			# Unary arithmetic minus.
+			call xvv_unop (MINUS, $2, $$)
+		    }
+	|	LNOT expr {
+			# Logical not.
+			call xvv_unop (LNOT, $2, $$)
+		    }
+	|	BNOT expr {
+			# Boolean not.
+			call xvv_unop (BNOT, $2, $$)
+		    }
+	|	expr PLUS opnl expr {
+			# Addition.
+			call xvv_binop (PLUS, $1, $4, $$)
+		    }
+	|	expr MINUS opnl expr {
+			# Subtraction.
+			call xvv_binop (MINUS, $1, $4, $$)
+		    }
+	| 	expr STAR opnl expr {
+			# Multiplication.
+			call xvv_binop (STAR, $1, $4, $$)
+		    }
+	|	expr SLASH opnl expr {
+			# Division.
+			call xvv_binop (SLASH, $1, $4, $$)
+		    }
+	|	expr EXPON opnl expr {
+			# Exponentiation.
+			call xvv_binop (EXPON, $1, $4, $$)
+		    }
+	|	expr CONCAT opnl expr {
+			# Concatenate two operands.
+			call xvv_binop (CONCAT, $1, $4, $$)
+		    }
+	|	expr LAND opnl expr {
+			# Logical and.
+			call xvv_boolop (LAND, $1, $4, $$)
+		    }
+	|	expr LOR opnl expr {
+			# Logical or.
+			call xvv_boolop (LOR, $1, $4, $$)
+		    }
+	|	expr BAND opnl expr {
+			# Boolean and.
+			call xvv_binop (BAND, $1, $4, $$)
+		    }
+	|	expr BOR opnl expr {
+			# Boolean or.
+			call xvv_binop (BOR, $1, $4, $$)
+		    }
+	|	expr BXOR opnl expr {
+			# Boolean xor.
+			call xvv_binop (BXOR, $1, $4, $$)
+		    }
+	|	expr LT opnl expr {
+			# Boolean less than.
+			call xvv_boolop (LT, $1, $4, $$)
+		    }
+	|	expr GT opnl expr {
+			# Boolean greater than.
+			call xvv_boolop (GT, $1, $4, $$)
+		    }
+	|	expr LE opnl expr {
+			# Boolean less than or equal.
+			call xvv_boolop (LE, $1, $4, $$)
+		    }
+	|	expr GE opnl expr {
+			# Boolean greater than or equal.
+			call xvv_boolop (GE, $1, $4, $$)
+		    }
+	|	expr EQ opnl expr {
+			# Boolean equal.
+			call xvv_boolop (EQ, $1, $4, $$)
+		    }
+	|	expr SE opnl expr {
+			# String pattern-equal.
+			call xvv_boolop (SE, $1, $4, $$)
+		    }
+	|	expr NE opnl expr {
+			# Boolean not equal.
+			call xvv_boolop (NE, $1, $4, $$)
+		    }
+	|	expr QUEST opnl expr COLON opnl expr {
+			# Conditional expression.
+			call xvv_quest ($1, $4, $7, $$)
+		    }
+	|	funct '(' arglist ')' {
+			# Call an intrinsic or external function.
+			ap = O_VALP($3)
+			call xvv_callfcn (O_VALC($1),
+			    A_ARGP(ap,1), A_NARGS(ap), $$)
+			call xvv_freeop ($1)
+			call xvv_freeop ($3)
+		    }
+	|	'(' expr ')' {
+			YYMOVE ($2, $$)
+		    }
+	;
+
+
+funct	:	IDENTIFIER {
+			YYMOVE ($1, $$)
+		    }
+	|	CONSTANT {
+			if (O_TYPE($1) != TY_CHAR)
+			    call error (1, "illegal function name")
+			YYMOVE ($1, $$)
+		    }
+	;
+
+
+arglist	:	{
+			# Empty.
+			call xvv_startarglist (NULL, $$)
+		    }
+	|	expr {
+			# First arg; start a nonnull list.
+			call xvv_startarglist ($1, $$)
+		    }
+	|	arglist ',' opnl expr {
+			# Add an argument to an existing list.
+			call xvv_addarg ($4, $1, $$)
+		    }
+	;
+
+
+opnl	:	# Empty.
+	|	opnl NEWLINE
+	;
+
+%%
+
+# 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")
+$for (silrd)
+	    case TY_PIXEL:
+		if (nelem > 0)
+		    call aneg$t (Mem$t[O_VALP(in)], Mem$t[O_VALP(out)], nelem)
+		else
+		    O_VAL$T(out) = -O_VAL$T(in)
+$endfor
+	    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
+		}
+$for (sil)
+	    case TY_PIXEL:
+		if (nelem > 0) {
+		    val_$t = NO
+		    call abeqk$t (Mem$t[O_VALP(in)], val_$t, Memi[O_VALP(out)],
+			nelem)
+		} else {
+		    if (O_VAL$T(in) == NO)
+			O_VAL$T(out) = YES
+		    else
+			O_VAL$T(out) = NO
+		}
+$endfor
+	    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")
+$for (sil)
+	    case TY_PIXEL:
+		if (nelem > 0)
+		    call anot$t (Mem$t[O_VALP(in)], Mem$t[O_VALP(out)], nelem)
+		else
+		    O_VAL$T(out) = not(O_VAL$T(in))
+$endfor
+	    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
+
+$for (silrd)
+PIXEL	v_$t
+PIXEL	xvv_null$t()
+extern	xvv_null$t()
+$endfor
+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) {
+		$for (silrd)
+		case TY_PIXEL:
+		    v_$t = O_VAL$T(in1)
+		    call xvv_initop (in1, nelem, dtype)
+		    call amovk$t (v_$t, Mem$t[O_VALP(in1)], nelem)
+		$endfor
+		}
+	    }
+
+	    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) {
+$for (sil)
+	    case TY_PIXEL:
+		switch (opcode) {
+		case BAND:
+		    if (len1 <= 0) {
+			O_VAL$T(out) = and (O_VAL$T(in1), O_VAL$T(in2))
+		    } else if (len2 <= 0) {
+			call aandk$t (Mem$t[p1], O_VAL$T(in2),
+			    Mem$t[po], nelem)
+		    } else {
+			call aand$t (Mem$t[p1], Mem$t[p2],
+			    Mem$t[po], nelem)
+		    }
+		case BOR:
+		    if (len1 <= 0) {
+			O_VAL$T(out) = or (O_VAL$T(in1), O_VAL$T(in2))
+		    } else if (len2 <= 0) {
+			call abork$t (Mem$t[p1], O_VAL$T(in2),
+			    Mem$t[po], nelem)
+		    } else {
+			call abor$t (Mem$t[p1], Mem$t[p2],
+			    Mem$t[po], nelem)
+		    }
+		case BXOR:
+		    if (len1 <= 0) {
+			O_VAL$T(out) = xor (O_VAL$T(in1), O_VAL$T(in2))
+		    } else if (len2 <= 0) {
+			call axork$t (Mem$t[p1], O_VAL$T(in2),
+			    Mem$t[po], nelem)
+		    } else {
+			call axor$t (Mem$t[p1], Mem$t[p2],
+			    Mem$t[po], nelem)
+		    }
+		}
+$endfor
+	    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")
+	    }
+$for (silrd)
+	case TY_PIXEL:
+	    switch (opcode) {
+	    case PLUS:
+		if (len1 <= 0) {
+		    O_VAL$T(out) = O_VAL$T(in1) + O_VAL$T(in2)
+		} else if (len2 <= 0) {
+		    call aaddk$t (Mem$t[p1], O_VAL$T(in2),
+			Mem$t[po], nelem)
+		} else {
+		    call aadd$t (Mem$t[p1], Mem$t[p2],
+			Mem$t[po], nelem)
+		}
+	    case MINUS:
+		if (len1 <= 0)
+		    O_VAL$T(out) = O_VAL$T(in1) - O_VAL$T(in2)
+		else if (len2 <= 0)
+		    call asubk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem)
+		else
+		    call asub$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem)
+
+	    case STAR:
+		if (len1 <= 0)
+		    O_VAL$T(out) = O_VAL$T(in1) * O_VAL$T(in2)
+		else if (len2 <= 0)
+		    call amulk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem)
+		else
+		    call amul$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem)
+
+	    case SLASH:
+		if (and (ev_flags, EV_RNGCHK) == 0) {
+		    # No range checking.
+		    if (len1 <= 0)
+			O_VAL$T(out) = O_VAL$T(in1) / O_VAL$T(in2)
+		    else if (len2 <= 0)
+			call adivk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem)
+		    else
+			call adiv$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem)
+		} else {
+		    # Check for divide by zero.
+		    if (len1 <= 0) {
+			if (O_VAL$T(in2) == 0$f)
+			    O_VAL$T(out) = xvv_null$t(0$f)
+			else
+			    O_VAL$T(out) = O_VAL$T(in1) / O_VAL$T(in2)
+		    } else if (len2 <= 0) {
+			if (O_VAL$T(in2) == 0$f)
+			    call amovk$t (xvv_null$t(0$f), Mem$t[po], nelem)
+			else {
+			    call adivk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po],
+				nelem)
+			}
+		    } else {
+			call advz$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem,
+			    xvv_null$t)
+		    }
+		}
+	    case EXPON:
+		if (len1 <= 0)
+		    O_VAL$T(out) = O_VAL$T(in1) ** O_VAL$T(in2)
+		else if (len2 <= 0)
+		    call aexpk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem)
+		else
+		    call aexp$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem)
+
+	    case CONCAT:
+		# Concatenate two numeric operands.
+		if (len1 <= 0) {
+		    Mem$t[po] = O_VAL$T(in1)
+		    po = po + 1
+		} else {
+		    call amov$t (Mem$t[p1], Mem$t[po], len1)
+		    po = po + len1
+		}
+		if (len2 <= 0)
+		    Mem$t[po] = O_VAL$T(in2)
+		else
+		    call amov$t (Mem$t[p2], Mem$t[po], len2)
+
+	    default:
+		call xvv_error (s_badswitch)
+	    }
+$endfor
+	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
+
+$for (silrd)
+PIXEL	v_$t
+$endfor
+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) {
+		$for (silrd)
+		case TY_PIXEL:
+		    v_$t = O_VAL$T(in1)
+		    call xvv_initop (in1, nelem, dtype)
+		    call amovk$t (v_$t, Mem$t[O_VALP(in1)], nelem)
+		$endfor
+		}
+	    }
+
+	    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) {
+$for (sil)
+	    case TY_PIXEL:
+		switch (opcode) {
+		case LAND:
+		    if (len1 <= 0) {
+			O_VALI(out) =
+			    btoi (O_VAL$T(in1) != 0 && O_VAL$T(in2) != 0)
+		    } else if (len2 <= 0) {
+			call alank$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    } else
+			call alan$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+		case LOR:
+		    if (len1 <= 0) {
+			O_VALI(out) =
+			    btoi (O_VAL$T(in1) != 0 || O_VAL$T(in2) != 0)
+		    } else if (len2 <= 0) {
+			call alork$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    } else
+			call alor$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+		default:
+		    call xvv_error (s_badop)
+		}
+$endfor
+	    default:
+		call xvv_error (s_badswitch)
+	    }
+	} else {
+	    # Operations supporting any arithmetic type.
+
+	    switch (dtype) {
+$for (silrd)
+	    case TY_PIXEL:
+		switch (opcode) {
+		case LT:
+		    if (len1 <= 0)
+			O_VALI(out) = btoi (O_VAL$T(in1) < O_VAL$T(in2))
+		    else if (len2 <= 0)
+			call abltk$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    else
+			call ablt$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+
+		case LE:
+		    if (len1 <= 0)
+			O_VALI(out) = btoi (O_VAL$T(in1) <= O_VAL$T(in2))
+		    else if (len2 <= 0)
+			call ablek$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    else
+			call able$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+
+		case GT:
+		    if (len1 <= 0)
+			O_VALI(out) = btoi (O_VAL$T(in1) > O_VAL$T(in2))
+		    else if (len2 <= 0)
+			call abgtk$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    else
+			call abgt$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+
+		case GE:
+		    if (len1 <= 0)
+			O_VALI(out) = btoi (O_VAL$T(in1) >= O_VAL$T(in2))
+		    else if (len2 <= 0)
+			call abgek$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    else
+			call abge$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+
+		case EQ:
+		    if (len1 <= 0)
+			O_VALI(out) = btoi (O_VAL$T(in1) == O_VAL$T(in2))
+		    else if (len2 <= 0)
+			call abeqk$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    else
+			call abeq$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+
+		case NE:
+		    if (len1 <= 0)
+			O_VALI(out) = btoi (O_VAL$T(in1) != O_VAL$T(in2))
+		    else if (len2 <= 0)
+			call abnek$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem)
+		    else
+			call abne$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem)
+
+		default:
+		    call xvv_error (s_badop)
+		}
+$endfor
+	    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) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		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)
+			    Mem$t[op+i-1] = O_VAL$T(in1)
+			else
+			    Mem$t[op+i-1] = O_VAL$T(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 amov$t (Mem$t[ip1], Mem$t[op], nelem)
+			else
+			    call amovk$t (O_VAL$T(in2), Mem$t[op], nelem)
+		    } else {
+			# Conditional is a vector.
+			call aselk$t (Mem$t[ip1], O_VAL$T(in2), Mem$t[op],
+			    Memi[sel], nelem)
+		    }
+		} else {
+		    # Both operands are vectors.
+		    if (O_LEN(cond) <= 0) {
+			# Conditional is a scalar.
+			if (O_VALI(cond) != 0)
+			    call amov$t (Mem$t[ip1], Mem$t[op], nelem)
+			else
+			    call amov$t (Mem$t[ip2], Mem$t[op], nelem)
+		    } else {
+			# Conditional is a vector.
+			call asel$t (Mem$t[ip1], Mem$t[ip2], Mem$t[op],
+			    Memi[sel], nelem)
+		    }
+		}
+	    $endfor
+	    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)
+
+$for (silrd)
+PIXEL	v_$t
+PIXEL	ahiv$t(), alov$t()
+PIXEL	amed$t()
+int	arav$t()
+$endfor
+
+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, 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)) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) > 0) {
+		    call aabs$t (Mem$t[O_VALP(ap)], Mem$t[O_VALP(out)],
+			O_LEN(ap))
+		} else
+		    O_VAL$T(out) = abs(O_VAL$T(ap))
+	    $endfor
+	    default:
+		call xvv_error1 (s_badtype, fcn)
+	    }
+
+	case F_ACOS:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = acos (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = acos (O_VAL$T(ap))
+	    $endfor
+	case F_ASIN:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = asin (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = asin (O_VAL$T(ap))
+	    $endfor
+	case F_COS:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = cos (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = cos (O_VAL$T(ap))
+	    $endfor
+	case F_COSH:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = cosh (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = cosh (O_VAL$T(ap))
+	    $endfor
+	case F_DEG:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = RADTODEG(Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = RADTODEG (O_VAL$T(ap))
+	    $endfor
+	case F_EXP:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = exp (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = exp (O_VAL$T(ap))
+	    $endfor
+	case F_LOG:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    op = O_VALP(out)
+		    do i = 1, O_LEN(ap) {
+			v_$t = Mem$t[O_VALP(ap)+i-1]
+			if (rangecheck && v_$t <= 0)
+			    Mem$t[op] = 0
+			else
+			    Mem$t[op] = log (v_$t)
+			op = op + 1
+		    }
+		} else {
+		    v_$t = O_VAL$T(ap)
+		    if (rangecheck && v_$t <= 0)
+			O_VAL$T(out) = 0
+		    else
+			O_VAL$T(out) = log (v_$t)
+		}
+	    $endfor
+	case F_LOG10:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    op = O_VALP(out)
+		    do i = 1, O_LEN(ap) {
+			v_$t = Mem$t[O_VALP(ap)+i-1]
+			if (rangecheck && v_$t <= 0)
+			    Mem$t[op] = 0
+			else
+			    Mem$t[op] = log10 (v_$t)
+			op = op + 1
+		    }
+		} else {
+		    v_$t = O_VAL$T(ap)
+		    if (rangecheck && v_$t <= 0)
+			O_VAL$T(out) = 0
+		    else
+			O_VAL$T(out) = log10 (v_$t)
+		}
+	    $endfor
+	case F_RAD:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = DEGTORAD(Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = DEGTORAD (O_VAL$T(ap))
+	    $endfor
+	case F_SIN:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = sin (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = sin (O_VAL$T(ap))
+	    $endfor
+	case F_SINH:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = sinh (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = sinh (O_VAL$T(ap))
+	    $endfor
+	case F_SQRT:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    op = O_VALP(out)
+		    do i = 1, O_LEN(ap) {
+			v_$t = Mem$t[O_VALP(ap)+i-1]
+			if (rangecheck && v_$t < 0)
+			    Mem$t[op] = 0
+			else
+			    Mem$t[op] = sqrt (v_$t)
+			op = op + 1
+		    }
+		} else {
+		    v_$t = O_VAL$T(ap)
+		    if (rangecheck && v_$t <= 0)
+			O_VAL$T(out) = 0
+		    else
+			O_VAL$T(out) = sqrt (v_$t)
+		}
+	    $endfor
+	case F_TAN:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = tan (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = tan (O_VAL$T(ap))
+	    $endfor
+	case F_TANH:
+	    $for (rd)
+	    if (optype == TY_PIXEL) 
+		if (O_LEN(ap) > 0) {
+		    do i = 1, O_LEN(ap)
+			Mem$t[O_VALP(out)+i-1] = tanh (Mem$t[O_VALP(ap)+i-1])
+		} else
+		    O_VAL$T(out) = tanh (O_VAL$T(ap))
+	    $endfor
+
+	case F_LEN:
+	    # Vector length.
+	    O_VALI(out) = O_LEN(ap)
+
+	case F_HIV:
+	    # High value.
+	    switch (optype) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) > 0)
+		    O_VAL$T(out) = ahiv$t (Mem$t[O_VALP(ap)], O_LEN(ap))
+		else
+		    O_VAL$T(out) = O_VAL$T(ap)
+	    $endfor
+	    default:
+		call xvv_error1 (s_badtype, fcn)
+	    }
+	case F_LOV:
+	    # Low value.
+	    switch (optype) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) > 0)
+		    O_VAL$T(out) = alov$t (Mem$t[O_VALP(ap)], O_LEN(ap))
+		else
+		    O_VAL$T(out) = O_VAL$T(ap)
+	    $endfor
+	    default:
+		call xvv_error1 (s_badtype, fcn)
+	    }
+
+	case F_SUM:
+	    # Vector sum.
+	    switch (optype) {
+	    $for (silr)
+	    case TY_PIXEL:
+		if (O_LEN(ap) > 0)
+		    v_r = asum$t (Mem$t[O_VALP(ap)], O_LEN(ap))
+		else
+		    v_r = O_VAL$T(ap)
+	    $endfor
+	    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) {
+	    $for (sir)
+	    case TY_PIXEL:
+		v_i = arav$t (Mem$t[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r)
+	    $endfor
+	    $for (ld)
+	    case TY_PIXEL:
+		v_i = arav$t (Mem$t[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d)
+	    $endfor
+	    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) {
+		$for (silrd)
+		case TY_PIXEL:
+		    O_VAL$T(out) = amed$t (Mem$t[O_VALP(ap)], O_LEN(ap))
+		$endfor
+		default:
+		    call xvv_error1 (s_badtype, fcn)
+		}
+	    case 3:
+		switch (optype) {
+		$for (silrd)
+		case TY_PIXEL:
+		    call amed3$t (Mem$t[O_VALP(args[1])],
+				  Mem$t[O_VALP(args[2])],
+				  Mem$t[O_VALP(args[3])],
+				  Mem$t[O_VALP(out)], nelem)
+		$endfor
+		default:
+		    call xvv_error1 (s_badtype, fcn)
+		}
+	    case 4:
+		switch (optype) {
+		$for (silrd)
+		case TY_PIXEL:
+		    call amed4$t (Mem$t[O_VALP(args[1])],
+				  Mem$t[O_VALP(args[2])],
+				  Mem$t[O_VALP(args[3])],
+				  Mem$t[O_VALP(args[4])],
+				  Mem$t[O_VALP(out)], nelem)
+		$endfor
+		default:
+		    call xvv_error1 (s_badtype, fcn)
+		}
+	    case 5:
+		switch (optype) {
+		$for (silrd)
+		case TY_PIXEL:
+		    call amed5$t (Mem$t[O_VALP(args[1])],
+				  Mem$t[O_VALP(args[2])],
+				  Mem$t[O_VALP(args[3])],
+				  Mem$t[O_VALP(args[4])],
+				  Mem$t[O_VALP(args[5])],
+				  Mem$t[O_VALP(out)], nelem)
+		$endfor
+		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) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (chunk > 0) {
+		    ip = O_VALP(ap)
+		    op = O_VALP(out)
+		    do i = 1, repl {
+			call amov$t (Mem$t[ip], Mem$t[op], chunk)
+			op = op + chunk
+		    }
+		} else
+		    call amovk$t (O_VAL$T(ap), Mem$t[O_VALP(out)], nelem)
+	    $endfor
+	    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) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (nelem > 0) {
+		    do i = 1, nelem {
+			j = i - shift
+			if (j < 1)
+			    j = j + nelem
+			else if (j > nelem)
+			    j = j - nelem
+			Mem$t[O_VALP(out)+i-1] = Mem$t[O_VALP(ap)+j-1]
+		    }
+		} else
+		    O_VAL$T(out) = (O_VAL$T(ap))
+	    $endfor
+	    default:
+		call xvv_error1 (s_badtype, fcn)
+	    }
+
+	case F_SORT:
+	    # Sort a vector.
+	    switch (optype) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (nelem > 0)
+		    call asrt$t (Mem$t[O_VALP(ap)], Mem$t[O_VALP(out)], nelem)
+		else
+		    O_VAL$T(out) = (O_VAL$T(ap))
+	    $endfor
+	    default:
+		call xvv_error1 (s_badtype, fcn)
+	    }
+
+	case F_ATAN, F_ATAN2:
+	    $for (rd)
+	    if (optype == TY_PIXEL) {
+		if (nargs == 1) {
+		    if (O_LEN(ap) > 0) {
+			do i = 1, O_LEN(ap)
+			    Mem$t[O_VALP(out)+i-1] =
+				atan (Mem$t[O_VALP(ap)+i-1])
+		    } else
+			O_VAL$T(out) = atan (O_VAL$T(ap))
+		} else {
+		    if (O_LEN(ap) > 0) {
+			do i = 1, O_LEN(ap)
+			    Mem$t[O_VALP(out)+i-1] =
+				atan2 (Mem$t[O_VALP(args[1])+i-1],
+				       Mem$t[O_VALP(args[2])+i-1])
+		    } else
+			O_VAL$T(out) = atan2(O_VAL$T(args[1]), O_VAL$T(args[2]))
+		}
+	    }
+	    $endfor
+
+	case F_MOD:
+	    in1 = args[1]
+	    in2 = args[2]
+
+	    switch (optype) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(in1) <= 0) {
+		    O_VAL$T(out) = mod (O_VAL$T(in1), O_VAL$T(in2))
+		} else if (O_LEN(in2) <= 0) {
+		    call amodk$t (Mem$t[O_VALP(in1)], O_VAL$T(in2),
+			Mem$t[O_VALP(out)], nelem)
+		} else {
+		    call amod$t (Mem$t[O_VALP(in1)], Mem$t[O_VALP(in2)],
+			Mem$t[O_VALP(out)], nelem)
+		}
+	    $endfor
+	    default:
+		call xvv_error1 (s_badtype, fcn)
+	    }
+
+	case F_MAX:
+	    switch (optype) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		# Copy the first argument.
+		ap = args[1]
+		if (O_LEN(ap) <= 0) {
+		    if (O_LEN(out) > 0)
+			call amovk$t (O_VAL$T(ap), Mem$t[O_VALP(out)], nelem)
+		    else
+			O_VAL$T(out) = O_VAL$T(ap)
+		} else
+		    call amov$t (Mem$t[O_VALP(ap)], Mem$t[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_VAL$T(out) = max (O_VAL$T(ap), O_VAL$T(out))
+			else {
+			    call amaxk$t (Mem$t[O_VALP(out)], O_VAL$T(ap),
+				Mem$t[O_VALP(out)], nelem)
+			}
+		    } else {
+			call amax$t (Mem$t[O_VALP(out)], Mem$t[O_VALP(ap)],
+			    Mem$t[O_VALP(out)], nelem)
+		    }
+		}
+	    $endfor
+	    default:
+		call xvv_error1 (s_badtype, fcn)
+	    }
+
+	case F_MIN:
+	    switch (optype) {
+	    $for (silrd)
+	    case TY_PIXEL:
+		# Copy the first argument.
+		ap = args[1]
+		if (O_LEN(ap) <= 0) {
+		    if (O_LEN(out) > 0)
+			call amovk$t (O_VAL$T(ap), Mem$t[O_VALP(out)], nelem)
+		    else
+			O_VAL$T(out) = O_VAL$T(ap)
+		} else
+		    call amov$t (Mem$t[O_VALP(ap)], Mem$t[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_VAL$T(out) = min (O_VAL$T(ap), O_VAL$T(out))
+			else {
+			    call amink$t (Mem$t[O_VALP(out)], O_VAL$T(ap),
+				Mem$t[O_VALP(out)], nelem)
+			}
+		    } else {
+			call amin$t (Mem$t[O_VALP(out)], Mem$t[O_VALP(ap)],
+			    Mem$t[O_VALP(out)], nelem)
+		    }
+		}
+	    $endfor
+	    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')
+
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALI(out) = btoi (O_VAL$T(ap) != 0$f)
+		else {
+		    v_$t = 0$f
+		    call abnek$t (Mem$t[O_VALP(ap)], v_$t, Memi[O_VALP(out)],
+			nelem)
+		}
+	    $endfor
+
+	    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
+
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALS(out) = O_VAL$T(ap)
+		else
+		    call acht$ts (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem)
+	    $endfor
+
+	    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
+
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALI(out) = O_VAL$T(ap)
+		else
+		    call acht$ti (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem)
+	    $endfor
+
+	    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
+
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALL(out) = O_VAL$T(ap)
+		else
+		    call acht$tl (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem)
+	    $endfor
+
+	    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)
+
+	    $for (sil)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALI(out) = O_VAL$T(ap)
+		else
+		    call acht$ti (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem)
+	    $endfor
+
+	    $for (rd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALI(out) = nint (O_VAL$T(ap))
+		else {
+		    do i = 1, nelem
+			Memi[O_VALP(out)+i-1] = nint (Mem$t[O_VALP(ap)+i-1])
+		}
+	    $endfor
+
+	    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
+
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALR(out) = O_VAL$T(ap)
+		else
+		    call acht$tr (Mem$t[O_VALP(ap)], Memr[O_VALP(out)], nelem)
+	    $endfor
+
+	    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
+
+	    $for (silrd)
+	    case TY_PIXEL:
+		if (O_LEN(ap) <= 0)
+		    O_VALD(out) = O_VAL$T(ap)
+		else
+		    call acht$td (Mem$t[O_VALP(ap)], Memd[O_VALP(out)], nelem)
+	    $endfor
+
+	    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))
+	    $for (sil)
+	    case TY_PIXEL:
+		call sprintf (O_VALC(out), nelem, "%d")
+		    call parg$t (O_VAL$T(ap))
+	    $endfor
+	    $for (rd)
+	    case TY_PIXEL:
+		call sprintf (O_VALC(out), nelem, "%g")
+		    call parg$t (O_VAL$T(ap))
+	    $endfor
+	    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?
+	    $for (sil)
+	    case TY_PIXEL:
+		v_l = O_VAL$T(o1)
+	    $endfor
+	    $for (rd)
+	    case TY_PIXEL:
+		v_d = O_VAL$T(o1)
+		float = true
+	    $endfor
+	    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)
+		}
+	    $for (sil)
+	    case TY_PIXEL:
+		if (float)
+		    O_VAL$T(o2) = v_d
+		else
+		    O_VAL$T(o2) = v_l
+	    $endfor
+	    $for (rd)
+	    case TY_PIXEL:
+		if (float)
+		    O_VAL$T(o2) = v_d
+		else
+		    O_VAL$T(o2) = v_l
+	    $endfor
+	    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) {
+		    $for (silrd)
+		    case TY_PIXEL:
+			v_$t = 0$f
+			call abnek$t (Mem$t[vp], v_$t, Memi[O_VALP(o2)], nelem)
+		    $endfor
+		    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) {
+		    $for (silrd)
+		    case TY_PIXEL:
+			O_VAL$T(o2) = v_d
+		    $endfor
+		    }
+		$for (silrd)
+		case TY_PIXEL:
+		    op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR)
+		    call acht$t (Mem$t[vp], Memc[op], nelem, dtype)
+		$endfor
+		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).
+
+$for (silrd)
+PIXEL procedure xvv_null$t (ignore)
+PIXEL	ignore			#I ignored
+begin
+	return (0$f)
+end
+$endfor
diff --git a/sys/fmtio/evvexpr.x b/sys/fmtio/evvexpr.x
new file mode 100644
index 00000000..19bc4790
--- /dev/null
+++ b/sys/fmtio/evvexpr.x
@@ -0,0 +1,5050 @@
+
+# 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
diff --git a/sys/fmtio/evvexpr.y b/sys/fmtio/evvexpr.y
new file mode 100644
index 00000000..d6efa629
--- /dev/null
+++ b/sys/fmtio/evvexpr.y
@@ -0,0 +1,4644 @@
+%{
+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
+
+%L
+# 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"
+
+%}
+
+# The $/ following causes the generic preprocessor to pass this block of code
+# through unchanged.
+
+
+
+%token		CONSTANT IDENTIFIER NEWLINE YYEOS
+%token		PLUS MINUS STAR SLASH EXPON CONCAT QUEST COLON
+%token		LT GT LE GT EQ NE SE LAND LOR LNOT BAND BOR BXOR BNOT AT
+
+%nonassoc	QUEST
+%left		LAND LOR
+%left		BAND BOR BXOR
+%nonassoc	EQ NE SE
+%nonassoc	LT GT LE GE
+%left		CONCAT
+%left		PLUS MINUS
+%left		STAR SLASH
+%right		UMINUS LNOT BNOT
+%left		EXPON
+%right		AT
+
+%%
+
+stmt	:	exprlist YYEOS {
+			# Normal exit.  Move the final expression value operand
+			# into the operand structure pointed to by the global
+			# variable ev_oval.
+
+			YYMOVE ($1, ev_oval)
+			call sfree (yysp)
+			return (OK)
+		}
+	|	error {
+			call error (1, "syntax error")
+		}
+	;
+
+exprlist:	expr {
+			YYMOVE ($1, $$)
+		}
+	|	exprlist ',' opnl expr {
+			YYMOVE ($4, $$)
+			call xvv_freeop ($1)
+		}
+
+
+expr	:	CONSTANT {
+			# Numeric constant.
+			YYMOVE ($1, $$)
+		    }
+	|	IDENTIFIER {
+			# The boolean constants "yes" and "no" are implemented
+			# as reserved operands.
+
+			call xvv_initop ($$, 0, TY_BOOL)
+			if (streq (O_VALC($1), "yes")) {
+			    O_VALI($$) = YES
+			} else if (streq (O_VALC($1), "no")) {
+			    O_VALI($$) = NO
+			} else if (ev_getop != NULL) {
+			    call zcall3 (ev_getop,ev_getop_data, O_VALC($1), $$)
+			    if (O_TYPE($$) <= 0)
+				call xvv_error1 ("unknown operand `%s'",
+				    O_VALC($1))
+			} else
+			    call xvv_error1 ("illegal operand `%s'", O_VALC($1))
+			call xvv_freeop ($1)
+		    }
+	|	AT CONSTANT {
+			# e.g., @"param"
+			if (ev_getop != NULL) {
+			    call zcall3 (ev_getop,ev_getop_data, O_VALC($2), $$)
+			    if (O_TYPE($$) <= 0)
+				call xvv_error1 ("unknown operand `%s'",
+				    O_VALC($1))
+			} else
+			    call xvv_error1 ("illegal operand `%s'", O_VALC($2))
+			call xvv_freeop ($2)
+		    }
+	|	MINUS expr %prec UMINUS {
+			# Unary arithmetic minus.
+			call xvv_unop (MINUS, $2, $$)
+		    }
+	|	LNOT expr {
+			# Logical not.
+			call xvv_unop (LNOT, $2, $$)
+		    }
+	|	BNOT expr {
+			# Boolean not.
+			call xvv_unop (BNOT, $2, $$)
+		    }
+	|	expr PLUS opnl expr {
+			# Addition.
+			call xvv_binop (PLUS, $1, $4, $$)
+		    }
+	|	expr MINUS opnl expr {
+			# Subtraction.
+			call xvv_binop (MINUS, $1, $4, $$)
+		    }
+	| 	expr STAR opnl expr {
+			# Multiplication.
+			call xvv_binop (STAR, $1, $4, $$)
+		    }
+	|	expr SLASH opnl expr {
+			# Division.
+			call xvv_binop (SLASH, $1, $4, $$)
+		    }
+	|	expr EXPON opnl expr {
+			# Exponentiation.
+			call xvv_binop (EXPON, $1, $4, $$)
+		    }
+	|	expr CONCAT opnl expr {
+			# Concatenate two operands.
+			call xvv_binop (CONCAT, $1, $4, $$)
+		    }
+	|	expr LAND opnl expr {
+			# Logical and.
+			call xvv_boolop (LAND, $1, $4, $$)
+		    }
+	|	expr LOR opnl expr {
+			# Logical or.
+			call xvv_boolop (LOR, $1, $4, $$)
+		    }
+	|	expr BAND opnl expr {
+			# Boolean and.
+			call xvv_binop (BAND, $1, $4, $$)
+		    }
+	|	expr BOR opnl expr {
+			# Boolean or.
+			call xvv_binop (BOR, $1, $4, $$)
+		    }
+	|	expr BXOR opnl expr {
+			# Boolean xor.
+			call xvv_binop (BXOR, $1, $4, $$)
+		    }
+	|	expr LT opnl expr {
+			# Boolean less than.
+			call xvv_boolop (LT, $1, $4, $$)
+		    }
+	|	expr GT opnl expr {
+			# Boolean greater than.
+			call xvv_boolop (GT, $1, $4, $$)
+		    }
+	|	expr LE opnl expr {
+			# Boolean less than or equal.
+			call xvv_boolop (LE, $1, $4, $$)
+		    }
+	|	expr GE opnl expr {
+			# Boolean greater than or equal.
+			call xvv_boolop (GE, $1, $4, $$)
+		    }
+	|	expr EQ opnl expr {
+			# Boolean equal.
+			call xvv_boolop (EQ, $1, $4, $$)
+		    }
+	|	expr SE opnl expr {
+			# String pattern-equal.
+			call xvv_boolop (SE, $1, $4, $$)
+		    }
+	|	expr NE opnl expr {
+			# Boolean not equal.
+			call xvv_boolop (NE, $1, $4, $$)
+		    }
+	|	expr QUEST opnl expr COLON opnl expr {
+			# Conditional expression.
+			call xvv_quest ($1, $4, $7, $$)
+		    }
+	|	funct '(' arglist ')' {
+			# Call an intrinsic or external function.
+			ap = O_VALP($3)
+			call xvv_callfcn (O_VALC($1),
+			    A_ARGP(ap,1), A_NARGS(ap), $$)
+			call xvv_freeop ($1)
+			call xvv_freeop ($3)
+		    }
+	|	'(' expr ')' {
+			YYMOVE ($2, $$)
+		    }
+	;
+
+
+funct	:	IDENTIFIER {
+			YYMOVE ($1, $$)
+		    }
+	|	CONSTANT {
+			if (O_TYPE($1) != TY_CHAR)
+			    call error (1, "illegal function name")
+			YYMOVE ($1, $$)
+		    }
+	;
+
+
+arglist	:	{
+			# Empty.
+			call xvv_startarglist (NULL, $$)
+		    }
+	|	expr {
+			# First arg; start a nonnull list.
+			call xvv_startarglist ($1, $$)
+		    }
+	|	arglist ',' opnl expr {
+			# Add an argument to an existing list.
+			call xvv_addarg ($4, $1, $$)
+		    }
+	;
+
+
+opnl	:	# Empty.
+	|	opnl NEWLINE
+	;
+
+%%
+
+# 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
+
diff --git a/sys/fmtio/fmt.com b/sys/fmtio/fmt.com
new file mode 100644
index 00000000..3f6d2525
--- /dev/null
+++ b/sys/fmtio/fmt.com
@@ -0,0 +1,17 @@
+# Printf common block.
+
+int	fd			# output file
+int	ip			# pointer to next char in format string
+int	width, decpl		# field width, number of decimal places
+int	col			# output column
+int	left_justify		# left or right justify output in field
+int	radix			# output radix
+int	fmt_state		# current state of FPRFMT (gets a format)
+int	ofile_type		# type of output file
+int	format_char 		# format type character (bcdefghmorstuxz#*)
+char	fill_char		# filler char for rt. justification
+char	format[SZ_OBUF]		# format string
+char	obuf[SZ_OBUF]		# for formatting output
+
+common	/fmtcom/  fd,ip,width,decpl,col,left_justify,radix,fmt_state,
+		  ofile_type,format_char,fill_char,format,obuf
diff --git a/sys/fmtio/fmterr.x b/sys/fmtio/fmterr.x
new file mode 100644
index 00000000..7a341764
--- /dev/null
+++ b/sys/fmtio/fmterr.x
@@ -0,0 +1,25 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# FMT_ERR -- Print the format string on the standard error output, marking
+# the position within the string to which the error refers.
+
+procedure fmt_err (preamble, format, index)
+
+char	preamble[ARB], format[ARB]
+int	index, ip
+
+begin
+	call putline (STDERR, "(")
+	call putline (STDERR, preamble)
+	call putline (STDERR, "format = \"")
+
+	for (ip=1;  ip < index && format[ip] != EOS;  ip=ip+1)
+	    call putcc (STDERR, format[ip])
+
+	if (format[ip] != EOS) {			# mark position of error
+	    call putline (STDERR, "<>")
+	    for (;  format[ip] != EOS;  ip=ip+1)
+		call putcc (STDERR, format[ip])
+	}
+	call putline (STDERR, "\")\n")
+end
diff --git a/sys/fmtio/fmtinit.x b/sys/fmtio/fmtinit.x
new file mode 100644
index 00000000..0d8ea547
--- /dev/null
+++ b/sys/fmtio/fmtinit.x
@@ -0,0 +1,23 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# FMT_INIT -- The following is called by SPRINTF and CLPRINTF to set a flag to
+# close the mem file or finish the CL command, respectively, when
+# the end of the format string is reached.  This entry is also called
+# by the iraf main at startup time to initialize the printf common.
+
+procedure fmt_init (ftype)
+
+int	ftype
+include	"fmt.com"
+
+begin
+	if (ftype == FMT_INITIALIZE) {
+	    ip = 1
+	    format[ip] = EOS
+	    ofile_type = REGULAR_FILE			# fpradv
+	    fmt_state = FMT_START			# fprfmt
+	} else
+	    ofile_type = ftype
+end
diff --git a/sys/fmtio/fmtread.x b/sys/fmtio/fmtread.x
new file mode 100644
index 00000000..e7506ab9
--- /dev/null
+++ b/sys/fmtio/fmtread.x
@@ -0,0 +1,23 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# FMT_READ -- Read and interpret a format specification.  Called in
+# circumstances where a NOT_DONE_YET return from FPRFMT is certain to
+# indicate a missing PARGI type argument.  If this happens, print warning
+# message, and exhaust format string so that default formats will be used.
+
+procedure fmt_read()
+
+int	fprfmt()
+include	"fmt.com"
+
+begin
+	while (fprfmt(0) != ALL_DONE) {			# read format
+	    call putline (STDERR, "Warning: Missing argument to printf\n")
+	    call fmt_err ("", format, ip)
+	    while (format[ip] != EOS)			# discard rest of format
+		ip = ip + 1
+	    fmt_state = FMT_START			# set defaults
+	}
+end
diff --git a/sys/fmtio/fmtsetcol.x b/sys/fmtio/fmtsetcol.x
new file mode 100644
index 00000000..a8d06855
--- /dev/null
+++ b/sys/fmtio/fmtsetcol.x
@@ -0,0 +1,28 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<printf.h>
+
+# FMT_SETCOL -- Called when a control character is output, to keep track of
+# the column index during output, for the "%nt" (tabulate) format.  Columns
+# are indexed from the start of the printf, rather than in absolute units on
+# the output, unless a \r or \n is output during the print.
+
+procedure fmt_setcol (ch, col)
+
+char	ch
+int	col
+
+begin
+	switch (ch) {
+	case '\t':					# next tab stop
+	    col = ((col + TABSTOP-1) / TABSTOP) * TABSTOP + 1
+	case '\n', '\r', '\f':
+	    col = 1
+	case '\b':
+	    col = col - 1
+	default:
+	    if (IS_PRINT (ch))
+		col = col + 1
+	}
+end
diff --git a/sys/fmtio/fmtstr.x b/sys/fmtio/fmtstr.x
new file mode 100644
index 00000000..197ea2bd
--- /dev/null
+++ b/sys/fmtio/fmtstr.x
@@ -0,0 +1,49 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# FMTSTR -- Place a string in a field of the given width, left or right
+# justifying as indicated, and output to the named file.  The length of
+# the text string may exceed the field width, in which case there is no
+# filling.
+
+procedure fmtstr (fd, str, col, fill_char, left_justify, maxch, width)
+		    
+int	fd			# output file
+char	str[ARB]		# string to be output
+int	col			# column: both input and output parameter
+char	fill_char		# fill character, if right justify
+int	left_justify		# YES or NO
+int	maxch			# maximum string chars to output
+int	width			# field width
+int	nchars, nfill, ip
+int	strlen()
+errchk	putc, putci
+
+begin
+	if (fd <= 0)
+	    return
+
+	if (width > 0) {
+	    nchars = min (maxch, strlen(str))
+	    nfill = max (0, width - nchars)
+	} else {
+	    nchars = maxch
+	    nfill = 0						# free format
+	}
+
+	if (left_justify == NO)					# fill at left
+	    for (col=col+nfill;  nfill > 0;  nfill=nfill-1)
+		call putc (fd, fill_char)
+
+	for (ip=1;  str[ip] != EOS && ip <= nchars;  ip=ip+1) {	# put string
+	    call putc (fd, str[ip])
+	    if (IS_PRINT (str[ip]))
+		col = col + 1
+	    else
+		call fmt_setcol (str[ip], col)
+	}
+
+	for (col=col+nfill;  nfill > 0;  nfill=nfill-1)		# fill at right
+	    call putci (fd, ' ')
+end
diff --git a/sys/fmtio/fpradv.x b/sys/fmtio/fpradv.x
new file mode 100644
index 00000000..942c29aa
--- /dev/null
+++ b/sys/fmtio/fpradv.x
@@ -0,0 +1,76 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<chars.h>
+include	<printf.h>
+
+# FPRADV -- Copy format chars to output until next "%w.dC" format sequence is
+# encountered, or until EOS is encountered on format string.  When EOS is
+# encountered, return buffer containing format string, and if mem_flag is set,
+# close the output file (a string) as well.  If a format string contains no
+# regular format sequences, and hence requires no PARG_ calls, we are all done.
+
+procedure fpradv()
+
+int	i, junk, ival, ch
+char	cch
+int	ip_save
+int	ctoi(), cctoc()
+include "fmt.com"
+errchk	putci
+
+begin
+	for (ch = format[ip];  ch != EOS;  ch = format[ip]) {
+	    cch = ch
+	    if (ch == ESCAPE) {
+		junk = cctoc (format, ip, cch)
+
+	    } else if (ch == START_OF_FORMAT) {
+		if (format[ip+1] == START_OF_FORMAT)	# '%%' --> '%'
+		    ip = ip + 2
+
+		else if (IS_DIGIT (format[ip+1])) {	# %Nw or %Nt
+		    ip_save = ip			# ip_save --> '%'
+		    ip = ip + 1
+
+		    junk = ctoi (format, ip, ival)
+
+		    switch (format[ip]) {
+		    case FMT_WHITESPACE:		# output blanks
+			do i = 1, ival
+			    call putci (fd, BLANK)
+			col = col + ival
+		    case FMT_TOCOLUMN:			# advance to column
+			for (;  col < ival;  col=col+1)
+			    call putci (fd, BLANK)
+		    default:
+			ip = ip_save			# regular format spec
+			return
+		    }
+
+		    ip = ip + 1				# eat "t" or "w"
+		    next
+
+		} else
+		    return				# regular format spec
+
+	    } else
+		ip = ip + 1
+
+	    call putc (fd, cch)				# output ordinary chars
+	    if (IS_PRINT (cch))				# keep track of column
+		col = col + 1
+	    else
+		call fmt_setcol (cch, col)
+	}
+
+	switch (ofile_type) {				# EOS of format reached
+	case STRING_FILE:
+	    call close (fd)
+	case CL_PARAM:
+	    call putline (CLOUT, "\"\n")
+	}
+
+	ofile_type = REGULAR_FILE			# restore default
+	fd = NULL
+end
diff --git a/sys/fmtio/fprfmt.x b/sys/fmtio/fprfmt.x
new file mode 100644
index 00000000..d5e68fb6
--- /dev/null
+++ b/sys/fmtio/fprfmt.x
@@ -0,0 +1,180 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<printf.h>
+
+.help
+.nf _________________________________________________________________________
+Process a format descriptor, setting the variables "decpl", "fill_char",
+"format_char", and "width" in the fmtio common.  Called from PARG_
+to determine the format specification for printing a variable.
+
+Format: "%[w[.d]]C[n]", where W is the field width, D the number of decimal
+places or precision, C the format type character, and N the radix numeral,
+for format type FMT_RADIX only.  A negative field width signifies left
+justification.  A leading zero in the W field sets the fill character to the
+numeral zero (when right justifying).  Default values will be supplied if
+any of the fields are omitted.  The minimum format is "%C".
+
+If any of the fields (wdCn) have the value GET_FIELD (= "*") the value of
+the field will be taken from the next PARG_ call, rather than from the
+format string.  This makes it easy to vary the format specification at run
+time.  For example, "%10.*g" would print a number in G-floating format,
+with a constant field width of 10, and with the number of digits of precision
+being given by a PARGI call at execution time (followed by a PARG_ call to
+pass the value to be printed).
+.endhelp ____________________________________________________________________
+
+# The following macro marks the position in the FPRFMT procedure (saves the
+# code for the needed field), and returns the not done status to PARG_.
+# A subsequent call to a PARG_ (with the value of the field we are waiting for
+# as argument) causes FPRFMT to be reentered at the point where we left off.
+
+define	(waitfor,	if (ival_already_used) { fmt_state = $1; return (NOT_DONE_YET) } ; $1 ival_already_used = true)
+
+#define	(waitfor,	if (ival_already_used) {
+#			    fmt_state = $1
+#			    return (NOT_DONE_YET)
+#			}
+#			$1 ival_already_used = true)
+
+# FPRFMT -- Process a %W.Dn format specification.  ALL_DONE is returned when
+# the format specification has been fully processed, else NOT_DONE_YET is
+# returned, indicating that an additional PARG call is required to complete
+# the format (which therefore contained one or more "*" specifiers).
+
+int procedure fprfmt (ival)
+
+int	ival					# argument value (from parg_)
+bool	ival_already_used			# wait for next parg
+int	ctoi(), stridx()
+char	ch, chrlwr()
+include "fmt.com"
+
+begin
+	# This routine functions as a coroutine.  If one of the fields in
+	# the format spec is to be given in a pargi call, an early return
+	# is taken.  The routine is later reentered with the value of the
+	# needed field, and execution continues at the point it left off.
+	# (Sorry, I could not think of a simpler way to do it...)
+
+	switch (fmt_state) {				# return from "waitfor"
+	case FMT_START:					# initial state
+	    ival_already_used = false
+	case GET_WIDTH_1:				# "%*.dC"
+	    goto GET_WIDTH_1
+	case GET_WIDTH_2:				# "%-0*.dC"
+	    goto GET_WIDTH_2
+	case GET_DECPL:					# "%w.*C"
+	    goto GET_DECPL
+	case GET_FMTCHAR:				# "%w.d*"
+	    goto GET_FMTCHAR
+	case GET_RADIX:					# "%w.dr*"
+	    goto GET_RADIX
+	case GET_OPERAND:				# used ival for format
+	    goto GET_OPERAND
+	}
+	
+	# It is not an error if there is no format string.
+	if (format[ip] == EOS || format[ip] != START_OF_FORMAT) {
+	    width = USE_DEFAULT
+	    decpl = USE_DEFAULT
+	    format_char = USE_DEFAULT
+	    fill_char = ' '
+	    left_justify = NO
+	    fmt_state = FMT_START
+	    return (ALL_DONE)
+	} else
+	    ip = ip + 1					# eat the "%"
+	    
+	if (format[ip] == GET_FIELD) {			# "%*.dC"
+	    ip = ip + 1
+	    waitfor (GET_WIDTH_1)			# go get field width...
+	    if (ival < 0)				# ...and come back here
+		left_justify = YES
+	    else
+		left_justify = NO
+
+	    fill_char = ' '
+	    width = abs (ival)
+
+	} else {					# "%-0*.dC"
+	    if (format[ip] == '-') {			# left or right justify
+		left_justify = YES
+		ip = ip + 1
+	    } else
+		left_justify = NO
+
+	    fill_char = ' '				# zero or blank fill
+	    if (format[ip] == '0') {
+		if (IS_DIGIT (format[ip+1]) || format[ip+1] == GET_FIELD) {
+		    fill_char = '0'
+		    ip = ip + 1
+		} else
+		    fill_char = ' '
+	    }
+
+	    if (format[ip] == GET_FIELD) {
+		ip = ip + 1
+		waitfor (GET_WIDTH_2)			# go get field width...
+		if (ival < 0)				# ... and come back here
+		    left_justify = YES
+		else
+		    left_justify = NO
+		width = abs (ival)
+
+	    } else if (ctoi (format, ip, width) <= 0)	# "%N.dC"
+		width = USE_DEFAULT
+	}
+
+	if (width == 0)					# make as big as needed
+	    width = USE_DEFAULT
+
+	if (format[ip] == '.') {			# get decpl field
+	    ip = ip + 1
+	    if (format[ip] == GET_FIELD) {		# "%w.*C"
+		ip = ip + 1
+		waitfor (GET_DECPL)
+		decpl = ival
+	    } else if (ctoi (format, ip, decpl) <= 0)	# "%w.NC"
+		decpl = USE_DEFAULT
+	} else
+	    decpl = USE_DEFAULT
+
+	if (format[ip] == GET_FIELD) {			# "%w.d*"
+	    ip = ip + 1
+	    waitfor (GET_FMTCHAR)
+	    format_char = ival
+	} else {
+	    format_char = format[ip]			# "%w.dC"
+	    ip = ip + 1
+	}
+
+	ch = format_char
+	if (stridx (ch, "bcdefghHmMorstuwxz") <= 0) {
+	    call putline (STDERR, "Warning: Unknown format type char\n")
+	    call fmt_err ("", format, ip-1)
+	    format_char = USE_DEFAULT
+
+	} else if (format_char == FMT_RADIX) {		# get radix
+	    ch = chrlwr (format[ip])
+	    ip = ip + 1
+	    if (ch == GET_FIELD) {			# "%w.dr*"
+		waitfor (GET_RADIX)
+		radix = ival
+	    } else if (IS_DIGIT (ch)) {
+		radix = TO_INTEG (ch)
+	    } else if (IS_LOWER (ch)) {
+		radix = ch - 'a' + 10
+	    } else {
+		radix = DECIMAL
+		ip = ip - 1
+	    }
+
+	} else if (format_char == FMT_WHITESPACE || format_char == FMT_TOCOLUMN)
+	    ival_already_used = false			# no operand
+
+	waitfor (GET_OPERAND)				# used ival for format,
+	fmt_state = FMT_START				# need to get another
+	return (ALL_DONE)
+end
diff --git a/sys/fmtio/fprintf.x b/sys/fmtio/fprintf.x
new file mode 100644
index 00000000..dd5304d2
--- /dev/null
+++ b/sys/fmtio/fprintf.x
@@ -0,0 +1,14 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# FPRINTF  -- Format output to a file.
+
+procedure fprintf (fd, format_string)
+
+int	fd
+char	format_string[ARB]
+
+begin
+	call fprntf (fd, format_string, REGULAR_FILE)
+end
diff --git a/sys/fmtio/fprntf.x b/sys/fmtio/fprntf.x
new file mode 100644
index 00000000..095b57b2
--- /dev/null
+++ b/sys/fmtio/fprntf.x
@@ -0,0 +1,40 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# FPRNTF -- Initiate a formatted print.  Called by FPRINTF, SPRINTF, etc.
+# Check that the previous print has completed, initialize the current
+# print, and advance to the first format specification (if any).
+
+procedure fprntf (new_fd, format_string, file_type)
+
+int	new_fd, file_type
+char	format_string[ARB]
+include "fmt.com"
+
+begin
+	# Printf is not reentrant.  An expression in a PARG_ call must not
+	# directly or indirectly call any of the printf entry points.  There
+	# must be a PARG_ for each "%w.dC" format specification in the format
+	# string.  Errors result in lost output, but are otherwise harmless,
+	# and are diagnosed below.
+
+ 	if (format[ip] != EOS) {
+	    call putline (STDERR, "Warning: Incomplete or reentrant printf\n")
+	    call fmt_err ("Old ", format, ip)
+	    call fmt_err ("New ", format_string, ARB)
+
+	    while (format[ip] != EOS)		# discard rest of format string
+		ip = ip + 1
+	    call fpradv()			# possibly close mem file
+	}
+
+	fd = new_fd				# normal initialization
+	ip = 1	
+	col = 1
+	fmt_state = FMT_START			# initialize FPRFMT state
+	ofile_type = file_type
+
+	call strcpy (format_string, format, SZ_OBUF)
+	call fpradv()
+end
diff --git a/sys/fmtio/fscan.x b/sys/fmtio/fscan.x
new file mode 100644
index 00000000..4a76c772
--- /dev/null
+++ b/sys/fmtio/fscan.x
@@ -0,0 +1,30 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# FSCAN -- Begin scanning a line from a file.
+
+int procedure fscan (fd)
+
+int	fd
+int	getlline()
+include	"scan.com"
+errchk	getlline
+
+begin
+	if (getlline (fd, sc_scanbuf, SZ_SCANBUF) == EOF)
+	    return (EOF)
+	else {
+	    call reset_scan()
+	    return (OK)
+	}
+end
+
+
+# SCAN -- Scan the standard input.
+
+int procedure scan()
+
+int	fscan()
+
+begin
+	return (fscan (STDIN))
+end
diff --git a/sys/fmtio/gargb.x b/sys/fmtio/gargb.x
new file mode 100644
index 00000000..82d9e0cb
--- /dev/null
+++ b/sys/fmtio/gargb.x
@@ -0,0 +1,33 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# GARGB -- Interpret the next token in the input as a boolean quantity
+# (token "y...." or "n....").
+
+procedure gargb (bval)
+
+bool	bval
+include	"scan.com"
+
+begin
+	if (sc_stopscan)
+	    return
+
+	while (IS_WHITE (sc_scanbuf[sc_ip]))
+	    sc_ip = sc_ip + 1
+
+	switch (sc_scanbuf[sc_ip]) {
+	case 'Y','y':
+	    bval = true
+	case 'N','n':
+	    bval = false
+	default:
+	    sc_stopscan = true
+	    return
+	}
+
+	while (IS_ALPHA(sc_scanbuf[sc_ip]) || sc_scanbuf[sc_ip] == '_')
+	    sc_ip = sc_ip + 1
+	sc_ntokens = sc_ntokens + 1
+end
diff --git a/sys/fmtio/gargc.x b/sys/fmtio/gargc.x
new file mode 100644
index 00000000..e6ce6996
--- /dev/null
+++ b/sys/fmtio/gargc.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGC -- Interpret the next input token as a character constant.
+
+procedure gargc (cval)
+
+char	cval
+int	cctoc()
+include	"scan.com"
+
+begin
+	if (sc_stopscan)
+	    return
+
+	if (cctoc (sc_scanbuf, sc_ip, cval) > 0)
+	    sc_ntokens = sc_ntokens + 1
+	else
+	    sc_stopscan = true
+end
diff --git a/sys/fmtio/gargd.x b/sys/fmtio/gargd.x
new file mode 100644
index 00000000..cb8c4561
--- /dev/null
+++ b/sys/fmtio/gargd.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGD -- Interpret the next input token as a double precision floating
+# number.
+
+procedure gargd (dval)
+
+double	dval
+int	gctod()
+include	"scan.com"
+
+begin
+	if (sc_stopscan)
+	    return
+
+	if (gctod (sc_scanbuf, sc_ip, dval) > 0)
+	    sc_ntokens = sc_ntokens + 1
+	else
+	    sc_stopscan = true
+end
diff --git a/sys/fmtio/gargi.x b/sys/fmtio/gargi.x
new file mode 100644
index 00000000..5b53bba8
--- /dev/null
+++ b/sys/fmtio/gargi.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+
+# GARGI -- Interpret the next input token as an integer quantity.
+
+procedure gargi (ival)
+
+int	ival
+double	dval
+
+begin
+	call gargd (dval)
+	if (IS_INDEFD (dval))
+	    ival = INDEFI
+	else if (abs(dval) > MAX_INT)
+	    ival = INDEFI
+	else
+	    ival = dval
+end
diff --git a/sys/fmtio/gargl.x b/sys/fmtio/gargl.x
new file mode 100644
index 00000000..142ac0e1
--- /dev/null
+++ b/sys/fmtio/gargl.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+
+# GARGL -- Interpret the next input token as an integer quantity.
+
+procedure gargl (lval)
+
+long	lval
+double	dval
+
+begin
+	call gargd (dval)
+	if (IS_INDEFD (dval))
+	    lval = INDEFL
+	else if (abs(dval) > MAX_LONG)
+	    lval = INDEFL
+	else
+	    lval = dval
+end
diff --git a/sys/fmtio/gargr.x b/sys/fmtio/gargr.x
new file mode 100644
index 00000000..4f25d717
--- /dev/null
+++ b/sys/fmtio/gargr.x
@@ -0,0 +1,17 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGR -- Interpret the next input token as a single precision floating
+# quantity.
+
+procedure gargr (rval)
+
+real	rval
+double	dval
+
+begin
+	call gargd (dval)
+	if (IS_INDEFD (dval))
+	    rval = INDEFR
+	else
+	    rval = dval
+end
diff --git a/sys/fmtio/gargrad.x b/sys/fmtio/gargrad.x
new file mode 100644
index 00000000..8ff78bf8
--- /dev/null
+++ b/sys/fmtio/gargrad.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGRAD -- Convert the next number using the radix given as the second
+# argument.
+
+procedure gargrad (lval, radix)
+
+long	lval
+int	radix, gctol()
+include	"scan.com"
+
+begin
+	if (sc_stopscan)
+	    return
+
+	if (gctol (sc_scanbuf, sc_ip, lval, radix) > 0)
+	    sc_ntokens = sc_ntokens + 1
+	else
+	    sc_stopscan = true
+end
diff --git a/sys/fmtio/gargs.x b/sys/fmtio/gargs.x
new file mode 100644
index 00000000..193a725f
--- /dev/null
+++ b/sys/fmtio/gargs.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+
+# GARGS -- Interpret the next input token as an integer quantity.
+
+procedure gargs (sval)
+
+short	sval
+double	dval
+
+begin
+	call gargd (dval)
+	if (IS_INDEFD (dval))
+	    sval = INDEFS
+	else if (abs(dval) > MAX_SHORT)
+	    sval = INDEFS
+	else
+	    sval = dval
+end
diff --git a/sys/fmtio/gargstr.x b/sys/fmtio/gargstr.x
new file mode 100644
index 00000000..9ae30462
--- /dev/null
+++ b/sys/fmtio/gargstr.x
@@ -0,0 +1,24 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGSTR -- Return the remainder of the scanned input line as a string.
+
+procedure gargstr (outstr, maxch)
+
+char	outstr[ARB]
+int	maxch, op
+include	"scan.com"
+
+begin
+	if (sc_stopscan)
+	    return
+
+	for (op=1;  op <= maxch && sc_scanbuf[sc_ip] != EOS;  op=op+1) {
+	    if (sc_scanbuf[sc_ip] == '\n')
+		break					# don't keep newlines
+	    outstr[op] = sc_scanbuf[sc_ip]
+	    sc_ip = sc_ip + 1
+	}
+
+	outstr[op] = EOS
+	sc_ntokens = sc_ntokens + 1			# null strings are ok
+end
diff --git a/sys/fmtio/gargtok.x b/sys/fmtio/gargtok.x
new file mode 100644
index 00000000..b775c7ea
--- /dev/null
+++ b/sys/fmtio/gargtok.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGTOK -- Return the next token from the scanned input line.
+
+procedure gargtok (token, outstr, maxch)
+
+int	token
+char	outstr[ARB]
+int	maxch, ctotok()
+include	"scan.com"
+
+begin
+	if (sc_stopscan)
+	    return
+
+	sc_ntokens = sc_ntokens + 1		# Newline, EOS are legal tokens
+	token = ctotok (sc_scanbuf, sc_ip, outstr, maxch)
+end
diff --git a/sys/fmtio/gargwrd.x b/sys/fmtio/gargwrd.x
new file mode 100644
index 00000000..cc8aa695
--- /dev/null
+++ b/sys/fmtio/gargwrd.x
@@ -0,0 +1,22 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGWRD -- Return the next whitespace delimited token or quoted string from
+# the scan buffer.
+
+procedure gargwrd (outstr, maxch)
+
+char	outstr[ARB]
+int	maxch, ctowrd()
+include	"scan.com"
+
+begin
+	if (sc_stopscan) {
+	    outstr[1] = EOS
+	    return
+	}
+
+	if (ctowrd (sc_scanbuf, sc_ip, outstr, maxch) > 0)
+	    sc_ntokens = sc_ntokens + 1
+	else
+	    sc_stopscan = true
+end
diff --git a/sys/fmtio/gargx.x b/sys/fmtio/gargx.x
new file mode 100644
index 00000000..2a1be607
--- /dev/null
+++ b/sys/fmtio/gargx.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GARGX -- Interpret the next input token as a complex number.
+
+procedure gargx (xval)
+
+complex	xval
+int	gctox()
+include	"scan.com"
+
+begin
+	if (sc_stopscan)
+	    return
+
+	if (gctox (sc_scanbuf, sc_ip, xval) > 0)
+	    sc_ntokens = sc_ntokens + 1
+	else
+	    sc_stopscan = true
+end
diff --git a/sys/fmtio/gctod.x b/sys/fmtio/gctod.x
new file mode 100644
index 00000000..ff58555b
--- /dev/null
+++ b/sys/fmtio/gctod.x
@@ -0,0 +1,81 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<chars.h>
+include	<lexnum.h>
+
+define	OCTAL		8
+define	DECIMAL		10
+define	HEX		16
+
+
+# GCTOD -- General character string to double precision real.  Any legal
+# number, e.g., integer, floating point, complex, or character constant,
+# is decoded and returned as a double.
+
+int procedure gctod (str, ip, odval)
+
+char	str[ARB]		# input string
+int	ip			# pointer into input string
+double	odval			# output double
+
+char	ch
+double	dval
+complex	xval
+long	lval
+int	ip_save, radix, nchars, vtype
+int	ctox(), cctoc(), ctod(), gctol(), lexnum()
+
+begin
+	vtype = TY_DOUBLE				# val to be returned
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+
+	ip_save = ip
+	ch = str[ip]					# first nonwhite
+
+	if (ch == '(') {				# complex number?
+	    if (ctox (str, ip, xval) <= 0)
+		return (0)				# not a number
+	    else
+		vtype = TY_COMPLEX
+
+	} else if (ch == SQUOTE || ch == ESCAPE) {
+	    if (cctoc (str, ip, ch) <= 0)		# character constant?
+		return (0)
+	    else
+		dval = ch
+
+	} else {				# determine type of number
+	    switch (lexnum (str, ip, nchars)) {
+	    case LEX_OCTAL:
+		radix = OCTAL
+	    case LEX_DECIMAL:
+		radix = DECIMAL
+	    case LEX_HEX:
+		radix = HEX
+	    case LEX_REAL:
+		radix = TY_REAL
+	    default:
+		return (0)
+	    }
+
+	    if (radix == TY_REAL)		# perform the conversion
+		nchars = ctod (str, ip, dval)
+	    else {
+		nchars = gctol (str, ip, lval, radix)
+		dval = lval
+		if (IS_INDEFL (lval))
+		    dval = INDEFD
+	    }
+	}
+
+	if (vtype == TY_COMPLEX) {
+	    odval = xval
+	    if (IS_INDEFX (xval))
+		odval = INDEFD
+	} else
+	    odval = dval
+
+	return (ip - ip_save)
+end
diff --git a/sys/fmtio/gctol.x b/sys/fmtio/gctol.x
new file mode 100644
index 00000000..f1478ff0
--- /dev/null
+++ b/sys/fmtio/gctol.x
@@ -0,0 +1,78 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+define	OCTAL		8
+define	DECIMAL		10
+define	HEX		16
+
+.help gctol
+.nf _______________________________________________________________________
+GCTOL -- Convert string to long integer (any radix).  The long integer
+value is returned in LVAL, and the pointer IP is left pointing at the
+first character following the number.  IP must be set to the index of
+the character at which conversion is to start before calling GCTOL.
+
+If the conversion radix is octal (hex), and the number is immediately
+followed by the suffix "b|B" ("x|X"), IP will be advanced past the suffix
+character, which is considered to be part of the number.
+.endhelp __________________________________________________________________
+
+
+int procedure gctol (str, ip, lval, radix)
+
+char	str[ARB]		# string to be decoded
+int	ip			# pointer within string
+int	radix			# radix of number
+long	lval			# output variable
+
+int	digit, base, ip_save, first_char
+char	ch
+bool	neg
+
+begin
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+	ip_save = ip
+	
+	neg = (str[ip] == '-')
+	if (neg || str[ip] == '+')		# eat the +/-
+	    ip = ip + 1
+
+	first_char = ip
+	base = abs (radix)
+
+	# The first character (following than the sign character) must be
+	# a digit, regardless of the radix.
+
+	for (lval=0;  str[ip] != EOS;  ip=ip+1) {
+	    ch = str[ip]
+
+	    if (IS_DIGIT (ch))			# cvt char to binary
+		digit = TO_INTEG (ch)
+	    else if (base > DECIMAL) {
+		if (IS_UPPER (ch))
+		    ch = TO_LOWER (ch)
+		else if (! IS_LOWER (ch))
+		    break
+		digit = ch - 'a' + 10		# for radices > 10
+	    } else
+		break
+
+	    if (digit < 0 || digit >= base)
+		break
+	    lval = lval * base + digit
+	}
+	
+ 	if (neg)
+	    lval = -lval
+
+	if (ip == first_char)			# not a number ?
+	    ip = ip_save			# restore pointer
+	else if (radix == OCTAL && ch == 'b' || ch == 'B')
+	    ip = ip + 1
+	else if (radix == HEX && ch == 'x' || ch == 'X')
+	    ip = ip + 1				# eat suffix char
+
+	return (ip - first_char)
+end
diff --git a/sys/fmtio/gctox.x b/sys/fmtio/gctox.x
new file mode 100644
index 00000000..2a23a917
--- /dev/null
+++ b/sys/fmtio/gctox.x
@@ -0,0 +1,81 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<chars.h>
+include	<lexnum.h>
+
+define	OCTAL		8
+define	DECIMAL		10
+define	HEX		16
+
+
+# GCTOX -- General character string to complex.  Any legal number, e.g.,
+# integer, floating point, complex, or character constant, is decoded and
+# returned as a complex.
+
+int procedure gctox (str, ip, oxval)
+
+char	str[ARB]		# input string
+int	ip			# pointer into input string
+complex	oxval			# output complex
+
+char	ch
+double	dval
+complex	xval
+long	lval
+int	ip_save, radix, nchars, vtype
+int	ctox(), cctoc(), ctod(), gctol(), lexnum()
+
+begin
+	vtype = TY_DOUBLE				# val to be returned
+	while (IS_WHITE (str[ip]))
+	    ip = ip + 1
+
+	ip_save = ip
+	ch = str[ip]					# first nonwhite
+
+	if (ch == '(') {				# complex number?
+	    if (ctox (str, ip, xval) <= 0)
+		return (0)				# not a number
+	    else
+		vtype = TY_COMPLEX
+
+	} else if (ch == SQUOTE || ch == ESCAPE) {
+	    if (cctoc (str, ip, ch) <= 0)		# character constant?
+		return (0)
+	    else
+		dval = ch
+
+	} else {				# determine type of number
+	    switch (lexnum (str, ip, nchars)) {
+	    case LEX_OCTAL:
+		radix = OCTAL
+	    case LEX_DECIMAL:
+		radix = DECIMAL
+	    case LEX_HEX:
+		radix = HEX
+	    case LEX_REAL:
+		radix = TY_REAL
+	    default:
+		return (0)
+	    }
+
+	    if (radix == TY_REAL)		# perform the conversion
+		nchars = ctod (str, ip, dval)
+	    else {
+		nchars = gctol (str, ip, lval, radix)
+		dval = lval
+		if (IS_INDEFL (lval))
+		    dval = INDEFD
+	    }
+	}
+
+	if (vtype == TY_DOUBLE) {
+	    oxval = dval
+	    if (IS_INDEFD (dval))
+		oxval = INDEFX
+	} else
+	    oxval = xval
+
+	return (ip - ip_save)
+end
diff --git a/sys/fmtio/gltoc.x b/sys/fmtio/gltoc.x
new file mode 100644
index 00000000..eaf47405
--- /dev/null
+++ b/sys/fmtio/gltoc.x
@@ -0,0 +1,82 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+include	<ctype.h>
+
+define	OCTAL		8
+define	DECIMAL		10
+define	HEX		16
+define	MAX_RADIX	'Z' - 'A' + 11
+
+# GLTOC -- Convert long integer to any radix string.  Returns the
+# number of characters generated.
+
+int procedure gltoc (lval, outstr, maxch, base)
+
+long	lval			# long integer to be encoded
+char	outstr[maxch]		# output buffer
+int	maxch, base		# numeric base (2..16)
+
+int	carry, d, op, radix, n, size, nchars, gstrcpy()
+long	andl(), orl()
+bool	unsigned
+
+begin
+	if (IS_INDEFL(lval) && base > 0)
+	    return (gstrcpy ("INDEF", outstr, maxch))
+	size = maxch
+
+	# Digit string is generated backwards, then reversed.  Unsigned
+	# conversion used if radix negative.
+
+	radix = max(2, min(MAX_RADIX, abs(base)))
+
+	unsigned = (base < 0)			# get raw number
+	if (unsigned) {
+	    n = andl (lval, MAX_LONG) / 2
+	    if (lval < 0)
+		n = orl (n, (MAX_LONG / 2 + 1))
+	    carry = andl (lval, 1)		# get initial carry
+	} else
+	    n = lval
+
+	op = 0
+	repeat {
+	    d = abs (mod (n, radix))		# generate next digit
+	    if (unsigned) {
+		d = 2 * d + carry		# get actual digit value
+		if (d >= radix) {		# check for generated carry
+		    d = d - radix
+		    carry = 1
+	        } else
+		    carry = 0
+	    }
+	    op = op + 1
+	    if (d < 10)				# convert to char and store
+		outstr[op] = TO_DIGIT (d)
+	    else
+		outstr[op] = d - 10 + 'A'
+	    n = n / radix
+	} until (n == 0 || op >= size)
+
+	if (unsigned) {
+	    if (carry != 0 && op < size) {	# check for final carry
+		op = op + 1
+		outstr[op] = '1'
+	    }
+	} else if (lval < 0 && op < size) {	# add sign if needed
+	    op = op + 1
+	    outstr[op] = '-'
+	}
+	nchars = op				# return length of string
+
+	for (d=1;  d < op;  d=d+1) {		# reverse digits
+	    carry = outstr[d]
+	    outstr[d] = outstr[op]
+	    outstr[op] = carry
+	    op = op - 1
+	}
+
+	outstr[nchars+1] = EOS
+	return (nchars)
+end
diff --git a/sys/fmtio/gstrcat.x b/sys/fmtio/gstrcat.x
new file mode 100644
index 00000000..d3f3fa94
--- /dev/null
+++ b/sys/fmtio/gstrcat.x
@@ -0,0 +1,26 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GSTRCAT -- String concatenation.  String STR is appended to OUTSTR.
+
+int procedure gstrcat (str, outstr, maxch)
+
+char	str[ARB], outstr[ARB]
+int	maxch
+
+int	ip, op, n
+
+begin
+	do op = 0, maxch-1
+	    if (outstr[op+1] == EOS)
+		break
+
+	n = maxch - op
+	do ip = 1, n {
+	    outstr[op+ip] = str[ip]
+	    if (str[ip] == EOS)
+		return (op + ip-1)
+	}
+
+	outstr[maxch+1] = EOS
+	return (maxch)
+end
diff --git a/sys/fmtio/gstrcpy.x b/sys/fmtio/gstrcpy.x
new file mode 100644
index 00000000..e2d6e7b1
--- /dev/null
+++ b/sys/fmtio/gstrcpy.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# GSTRCPY -- Copy string s1 to s2, return the number of characters copied.
+
+int procedure gstrcpy (s1, s2, maxch)
+
+char	s1[ARB], s2[ARB]
+int	maxch, i
+
+begin
+	do i = 1, maxch {
+	    s2[i] = s1[i]
+	    if (s2[i] == EOS)
+		return (i - 1)
+	}
+
+	s2[maxch+1] = EOS
+	return (maxch)
+end
diff --git a/sys/fmtio/itoc.x b/sys/fmtio/itoc.x
new file mode 100644
index 00000000..726fbc40
--- /dev/null
+++ b/sys/fmtio/itoc.x
@@ -0,0 +1,53 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+include	<ctype.h>
+
+# ITOC -- Integer to character string.  We do not resolve this into a call
+# to GLTOC for reasons of efficiency.
+
+int procedure itoc (ival, str, maxch)
+
+int	ival, maxch
+char	str[ARB]
+
+char	buf[MAX_DIGITS]
+int	b_op, s_op, num, temp
+int	gstrcpy()
+
+begin	
+	s_op = 1
+
+	if (IS_INDEFI (ival)) {
+	    return (gstrcpy ("INDEF", str, maxch))
+	} else if (ival < 0) {
+	    str[1] = '-'
+	    s_op = 2
+	    num = -ival
+	} else
+	    num = ival
+
+	# Encode nonnegative number in BUF, least significant digits first.
+
+	b_op = 0
+	repeat {
+	    temp = num / 10
+	    b_op = b_op + 1
+	    buf[b_op] = TO_DIGIT (num - temp * 10)
+	    num = temp
+	} until (num == 0)
+
+	# Copy encoded number to output string, reversing the order of the
+	# digits so that the most significant digits are first.
+
+	while (b_op > 0) {
+	    if (s_op > maxch)
+		return (gstrcpy ("**********", str, maxch))
+	    str[s_op] = buf[b_op]
+	    s_op = s_op + 1
+	    b_op = b_op - 1
+	}
+
+	str[s_op] = EOS
+	return (s_op - 1)
+end
diff --git a/sys/fmtio/lexdata.inc b/sys/fmtio/lexdata.inc
new file mode 100644
index 00000000..1a1bf3e4
--- /dev/null
+++ b/sys/fmtio/lexdata.inc
@@ -0,0 +1,28 @@
+# Actions of the LEXNUM finite state automaton.
+
+define	Acc	ACCEPT			# special actions
+define	Rvt	REVERT
+
+define	o_o	LEX_OCTAL		# reductions
+define	d_d	LEX_DECIMAL
+define	x_x	LEX_HEX
+define	r_r	LEX_REAL
+define	n__	LEX_NONNUM		# (other actions are new states)
+
+# cc:		+-   0-7  8-9  ACF  ED   :    .    X    B    other
+
+data	action /UNM, ODH, DHR, n__, n__, QRN, QRF, n__, n__, n__,	# start
+		Rvt, ODH, DHR, Rvt, Rvt, Rvt, QRF, Rvt, Rvt, Rvt,	# UNM
+		d_d, Acc, DHR, HEX, QHX, QRN, RFR, x_x, OHN, d_d,	# ODH
+		d_d, Acc, Acc, HEX, QHX, QRN, RFR, x_x, HEX, d_d,	# DHR
+		Rvt, RFR, RFR, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt,	# QRF
+		Rvt, Acc, Acc, Acc, Acc, Rvt, Rvt, x_x, Acc, Rvt,	# HEX
+		QRX, HRX, HRX, HEX, HEX, Rvt, Rvt, x_x, HEX, Rvt,	# QHX
+		Rvt, RNM, RNM, Rvt, Rvt, Acc, Rvt, Rvt, Rvt, Rvt,	# QRN
+		o_o, HEX, HEX, HEX, HEX, o_o, o_o, x_x, HEX, o_o,	# OHN
+		r_r, Acc, Acc, r_r, RRX, r_r, r_r, r_r, r_r, r_r,	# RFR
+		QRX, REX, REX, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt,	# RRX
+		Rvt, REX, REX, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt,	# QRX
+		r_r, Acc, Acc, HEX, HEX, r_r, r_r, x_x, r_r, r_r,	# HRX
+		r_r, Acc, Acc, r_r, QRX, Acc, QRF, r_r, r_r, r_r,	# RNM
+		r_r, Acc, Acc, r_r, r_r, r_r, r_r, r_r, r_r, r_r/	# REX
diff --git a/sys/fmtio/lexnum.x b/sys/fmtio/lexnum.x
new file mode 100644
index 00000000..f62b0ed2
--- /dev/null
+++ b/sys/fmtio/lexnum.x
@@ -0,0 +1,190 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+include	<ctype.h>
+include	<lexnum.h>
+
+# LEXNUM -- Lexically analyse a character string, determine if string is
+# a number, and if so, the type of number, and the number of characters
+# in the number.  The ip_start argument is left pointing at the first char
+# of the number (or other token), and the number of chars in the number is
+# returned as the third argument (0 if not a number).
+#
+# NOTE - See .doc/lexnum.hlp for a description of the states of the automaton.
+
+define	SZ_STACK	15
+
+# Lexical actions.  "Reduce" means exit, returning code identifying lexical
+# type of token.  "Shift" means switch to a new state in the automaton.
+# "Revert" means reduce class "other" in the previous state.
+
+define	ACCEPT		-6		# remain in same state
+define	REVERT		-5		# revert to earlier state
+
+
+# Character classes
+
+define	SIGNCHAR	1		# +-
+define	OCTDIG		2		# 0-7
+define	DECDIG		3		# 8-9
+define	HEXDIG		4		# a-fA-F
+define	REALEXP		5		# eEdD
+define	SEXAG		6		# :
+define	FRACTION	7		# .
+define	HEXSUFFIX	8		# xX
+define	OCTSUFFIX	9		# bB
+define	OTHER		10		# invalid character
+define	NCC		10
+
+
+# States of the automaton
+
+define	START		1		# initial state
+define	UNM		2		# unop or number
+define	ODH		3		# octal, decimal, hex, or real
+define	DHR		4		# decimal, hex, or real
+define	QRF		5		# maybe real fraction
+define	HEX		6		# hex
+define	QHX		7		# maybe hex or real exponent
+define	QRN		8		# maybe real number
+define	OHN		9		# octal or hex number
+define	RFR		10		# real fraction
+define	RRX		11		# real or real exponent
+define	QRX		12		# maybe real exponent
+define	HRX		13		# hex or real exponent
+define	RNM		14		# real number
+define	REX		15		# real exponent
+define	NSTATES		15
+
+
+# LEXNUM -- Determine if the next sequence of characters in the string STR
+# can be interpreted as a number.  Return the numeric type as the function
+# value or LEX_NONNUM if the string is not a number.
+
+int procedure lexnum (str, ip_start, nchars)
+
+char	str[ARB]		# string to be decoded
+int	ip_start		# starting index in string
+int	nchars			# receives nchars in next token
+
+char	ch
+int	stk_ip[SZ_STACK]
+int	ip, sp, cc, state, ip_save, toktype, act
+short	stk_state[SZ_STACK], action[NCC,NSTATES]
+int	strncmp()
+include	"lexdata.inc"
+
+begin
+	while (IS_WHITE (str[ip_start]))
+	    ip_start = ip_start + 1
+	ip = ip_start
+
+	# INDEF is a legal number and is best dealt with as a special case.
+	if (str[ip] == 'I')
+	    if (strncmp (str[ip], "INDEF", 5) == 0) {
+		nchars = 5
+		return (LEX_REAL)
+	    }
+
+	state = START				# initialization
+	ip_save = ip
+	sp = 0
+
+	repeat {
+	    ch = str[ip]
+
+	    repeat {				# determine character class
+		switch (ch) {
+		case '+','-':
+		    cc = SIGNCHAR
+		    break
+		case '0','1','2','3','4','5','6','7':
+		    cc = OCTDIG
+		    break
+		case '8','9':
+		    cc = DECDIG
+		    break
+		case 'B':
+		    cc = OCTSUFFIX
+		    break
+		case 'D','E':
+		    cc = REALEXP
+		    break
+		case 'A','C','F':
+		    cc = HEXDIG
+		    break
+		case ':':
+		    cc = SEXAG
+		    break
+		case '.':
+		    cc = FRACTION
+		    break
+		default:
+		    if (IS_LOWER (ch))
+			ch = TO_UPPER (ch)	# and repeat
+		    else if (ch == 'X') {
+			cc = HEXSUFFIX
+			break
+		    } else {
+			cc = OTHER
+			break
+		    }
+		}
+	    }
+
+#call eprintf ("ip=%2d, sp=%2d, ch=%c, cc=%d, state=%d, action=%d\n")
+#call pargi(ip); call pargi(sp)
+#call pargc(ch); call pargi(cc); call pargi(state)
+#call pargs(action[cc,state])
+
+	    # Perform the action indicated by the action table when this
+	    # class of character is encountered in the current state.
+
+	    act = action[cc,state]
+	    if (act == ACCEPT) {
+		ip = ip + 1			# a simple optimization
+		next
+	    }
+
+	    switch (act) {
+	    case REVERT:
+		repeat {
+		    ip = stk_ip[sp]
+		    state = stk_state[sp]
+		    toktype = action[OTHER,state]
+		    sp = sp - 1
+		} until (toktype != REVERT || sp <= 0)
+
+		break
+
+	    case LEX_OCTAL, LEX_DECIMAL, LEX_HEX, LEX_REAL, LEX_NONNUM:
+		toktype = action[cc,state]
+		if (toktype == LEX_OCTAL && cc == OCTSUFFIX)
+		    ip = ip + 1			# discard suffix char
+		else if (toktype == LEX_HEX && cc == HEXSUFFIX)
+		    ip = ip + 1
+		break
+
+	    default:				# shift to new state
+		sp = sp + 1
+		if (sp > SZ_STACK) {
+		    toktype = LEX_NONNUM
+		    break
+		}
+		stk_ip[sp] = ip
+		stk_state[sp] = state
+
+		ip = ip + 1
+		state = action[cc,state]
+		if (state < 1 || state > NSTATES)
+		    call error (0, "In LEXNUM: cannot happen")
+	    }
+	}
+
+	if (toktype == LEX_NONNUM)
+	    nchars = 0
+	else
+	    nchars = ip - ip_save
+
+	return (toktype)
+end
diff --git a/sys/fmtio/ltoc.x b/sys/fmtio/ltoc.x
new file mode 100644
index 00000000..d2105433
--- /dev/null
+++ b/sys/fmtio/ltoc.x
@@ -0,0 +1,17 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+define	DECIMAL		10
+
+# LTOC -- Convert long integer to decimal string.
+# Returns the number of characters generated.
+
+int procedure ltoc (lval, outstr, maxch)
+
+long	lval				# long integer to be encoded
+char	outstr[ARB]			# output buffer
+int	maxch				# size of output buffer
+int	gltoc()
+
+begin
+	return (gltoc (lval, outstr, maxch, DECIMAL))
+end
diff --git a/sys/fmtio/mkpkg b/sys/fmtio/mkpkg
new file mode 100644
index 00000000..b27d6a5f
--- /dev/null
+++ b/sys/fmtio/mkpkg
@@ -0,0 +1,125 @@
+# Formatted i/o (FMTIO) portion of the system library.
+
+$checkout libsys.a lib$
+$update   libsys.a
+$checkin  libsys.a lib$
+$exit
+
+tfiles:
+	$ifnewer (evvexpr.gy, evvexpr.y)
+	    $generic -k evvexpr.gy -o evvexpr.y
+	$endif
+
+	$ifnewer (evvexpr.y, evvexpr.x)
+	    $ifeq (HOSTID, unix)
+		$echo "fmtio/evvexpr.x is out of date; rebuilding with XYACC:"
+		!(xyacc evvexpr.y; mv -f ytab.x evvexpr.x)
+	    $else
+		$echo "fmtio/evvexpr.x is out of date; rebuild with XYACC"
+	    $endif
+	$endif
+
+	$ifnewer (evexpr.y, evexpr.x)
+	    $ifeq (HOSTID, unix)
+		$echo "fmtio/evexpr.x is out of date; rebuilding with XYACC:"
+		!(xyacc evexpr.y; mv -f ytab.x evexpr.x)
+	    $else
+		$echo "fmtio/evexpr.x is out of date; rebuild with XYACC"
+	    $endif
+	$endif
+	;
+
+libsys.a:
+	$ifeq (USE_GENERIC, yes) $call tfiles $endif
+
+	cctoc.x	escchars.inc <chars.h> <ctype.h>
+	chdeposit.x	
+	chfetch.x	
+	chrlwr.x	<ctype.h>
+	chrupr.x	<ctype.h>
+	clprintf.x	<printf.h>
+	clscan.x	scan.com
+	ctocc.x		escchars.inc <ctype.h>
+	ctod.x		<ctype.h> <mach.h>
+	ctoi.x		<ctype.h>
+	ctol.x		<ctype.h>
+	ctor.x		<mach.h>
+	ctotok.x	tokdata.inc <chars.h> <lexnum.h> <ctotok.h> <ctype.h>
+	ctowrd.x	<chars.h> <ctype.h>
+	ctox.x		<ctype.h>
+	dtcscl.x	
+	dtoc.x		<ctype.h> <printf.h>
+	dtoc3.x		<ctype.h> <mach.h> <printf.h>
+	eprintf.x	<printf.h>
+	evexpr.x	evexpr.com <ctype.h> <evexpr.h> <lexnum.h> <mach.h>
+	evvexpr.x	evvexpr.com <ctype.h> <evvexpr.h> <lexnum.h>\
+			<mach.h> <math.h>
+	fmterr.x	
+	fmtinit.x	fmt.com <printf.h>
+	fmtread.x	fmt.com <printf.h>
+	fmtsetcol.x	<ctype.h> <printf.h>
+	fmtstr.x	<ctype.h>
+	fpradv.x	<chars.h> <ctype.h> <printf.h> fmt.com
+	fprfmt.x	<ctype.h> <printf.h> fmt.com
+	fprintf.x	<printf.h>
+	fprntf.x	<printf.h> fmt.com
+	fscan.x		scan.com
+	gargb.x		scan.com <ctype.h>
+	gargc.x		scan.com
+	gargd.x		scan.com
+	gargi.x		<mach.h>
+	gargl.x		<mach.h>
+	gargr.x	
+	gargrad.x	scan.com
+	gargs.x		<mach.h>
+	gargstr.x	scan.com
+	gargtok.x	scan.com
+	gargwrd.x	scan.com
+	gargx.x		scan.com
+	gctod.x		<chars.h> <ctype.h> <lexnum.h>
+	gctol.x		<ctype.h>
+	gctox.x		<chars.h> <ctype.h> <lexnum.h>
+	gltoc.x		<ctype.h> <mach.h>
+	gstrcat.x	
+	gstrcpy.x	
+	itoc.x		<ctype.h> <mach.h>
+	lexnum.x	lexdata.inc <ctype.h> <lexnum.h> <mach.h>
+	ltoc.x	
+	nscan.x		scan.com
+	parg.x		<ctype.h> <mach.h> <printf.h> fmt.com
+	pargb.x		<printf.h>
+	pargstr.x	<printf.h> fmt.com
+	pargx.x		<ctype.h> <mach.h> <printf.h> fmt.com
+	patmatch.x	<chars.h> <ctype.h> <pattern.h>
+	printf.x	<printf.h>
+	resetscan.x	scan.com
+	scanc.x		scan.com
+	sprintf.x	<printf.h>
+	sscan.x		scan.com
+	strcat.x	
+	strcmp.x	
+	strcpy.x	
+	strdic.x	<ctype.h>
+	streq.x	
+	strge.x	
+	strgt.x	
+	stridx.x	
+	stridxs.x	
+	strldx.x	
+	strldxs.x	
+	strle.x	
+	strlen.x	
+	strlt.x	
+	strlwr.x	<ctype.h>
+	strmac.x	<ctype.h>
+	strmatch.x	<ctype.h> <pattern.h>
+	strncmp.x	
+	strne.x	
+	strsearch.x	
+	strsrt.x	
+	strtbl.x	
+	strupr.x	<ctype.h>
+	xevgettok.x	<lexnum.h> <ctype.h> <evexpr.h>
+	xvvgettok.x	<lexnum.h> <ctype.h> <mach.h> <math.h> <evexpr.h>
+	xtoc.x	
+	;
diff --git a/sys/fmtio/nscan.x b/sys/fmtio/nscan.x
new file mode 100644
index 00000000..c9069927
--- /dev/null
+++ b/sys/fmtio/nscan.x
@@ -0,0 +1,12 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# NSCAN -- Return the number of tokens successfully converted in the most
+# recent scan.
+
+int procedure nscan()
+
+include	"scan.com"
+
+begin
+	return (sc_ntokens)
+end
diff --git a/sys/fmtio/parg.x b/sys/fmtio/parg.x
new file mode 100644
index 00000000..d65bd3ce
--- /dev/null
+++ b/sys/fmtio/parg.x
@@ -0,0 +1,283 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+include	<ctype.h>
+include	<printf.h>
+
+.help parg
+.nf ___________________________________________________________________________
+PARG[CSILRDX] -- Pass a numeric argument to printf.  Get the format spec and
+format the number on the output file.  Try to provide reasonable automatic
+type conversions.  Avoid any type coercion of indefinites.
+We try to make the operand fit in the specified field width, decreasing the
+precision if necessary, but if it cannot be made to fit we increase the field
+width until it does.  We feel that it is more important to output a readable
+number than to keep the output columns justified.
+.endhelp ______________________________________________________________________
+
+
+# PARGD -- Pass a double.
+
+procedure pargd (dval)
+
+double	dval
+
+begin
+	call pargg (dval, TY_DOUBLE)
+end
+
+
+# PARGC -- Pass a char.
+
+procedure pargc (cval)
+
+char	cval
+double	dval
+
+begin
+	dval = cval
+	call pargg (dval, TY_CHAR)
+end
+
+
+# PARGS -- Pass a short.
+
+procedure pargs (sval)
+
+short	sval
+double	dval
+
+begin
+	dval = sval
+	if (IS_INDEFS (sval))
+	    dval = INDEFD
+
+	call pargg (dval, TY_SHORT)
+end
+
+
+# PARGI -- Pass an int.
+
+procedure pargi (ival)
+
+int	ival
+double	dval
+
+begin
+	dval = ival
+	if (IS_INDEFI (ival))
+	    dval = INDEFD
+
+	call pargg (dval, TY_INT)
+end
+
+
+# PARGL -- Pass a long.
+
+procedure pargl (lval)
+
+long	lval
+double	dval
+
+begin
+	dval = lval
+	if (IS_INDEFL (lval))
+	    dval = INDEFD
+
+	call pargg (dval, TY_LONG)
+end
+
+
+# PARGR -- Pass a real.
+
+procedure pargr (rval)
+
+real	rval
+double	dval
+
+begin
+	dval = rval
+	if (IS_INDEFR (rval))
+	    dval = INDEFD
+
+	call pargg (dval, TY_REAL)
+end
+
+
+# PARGG -- Generic put argument.  Encode a value of a specific datatype passed
+# as a double precision value.
+
+procedure pargg (value, dtype)
+
+double	value
+int	dtype
+
+char	ch
+long	lnum
+complex	xnum
+int	n, precision, i, junk, ival, nchars, nbits, fmt
+int	ctocc(), gltoc(), dtoc(), xtoc(), fprfmt()
+errchk	putci, fmtstr, fpradv
+include "fmt.com"
+
+begin
+	# Read format.  If format spec contains "*" fields, VALUE is a part of
+	# the format, rather than a true operand.  In that case we return,
+	# and the next call again checks to see if the format spec is complete.
+	# Note that if VALUE is not part of the format but is instead a floating
+	# point value to be printed, it may have an exponent large enough to
+	# cause integer overflow in an INT(VALUE) operation, hence we must
+	# guard against this.  This is easy since only PARGI will be used to
+	# pass format information.
+
+	if (dtype == TY_REAL || dtype == TY_DOUBLE)
+	    ival = 0
+	else if (IS_INDEFD (value))
+	    ival = INDEFI
+	else
+	    ival = nint (value)
+
+	if (fprfmt (ival) == NOT_DONE_YET)
+	    return
+
+ 	if (format_char == USE_DEFAULT || format_char == FMT_STRING)
+	    switch (dtype) {
+	    case TY_CHAR:
+		format_char = FMT_CHAR
+	    case TY_INT:
+		format_char = FMT_DECIMAL
+	    default:
+		format_char = FMT_GENERAL
+	    }
+
+	if (dtype == TY_DOUBLE)				# supply def. precision
+	    precision = NDIGITS_DP
+	else
+	    precision = NDIGITS_RP
+
+	if (width == USE_DEFAULT)			# make as big as needed
+	    width = SZ_OBUF
+
+	# Convert number from binary into character form in OBUF, applying
+	# defaults as needed.
+
+	# Ignore case in testing format type.
+	fmt = format_char
+	if (IS_UPPER (fmt))
+	    fmt = TO_LOWER(fmt)
+
+	switch (fmt) {
+	case FMT_BOOL:
+	    if (IS_INDEFD (value))
+		call strcpy ("INDEF", obuf, SZ_OBUF)
+	    else if (int (value) == 0)
+		call strcpy ("NO", obuf, SZ_OBUF)
+	    else
+		call strcpy ("YES", obuf, SZ_OBUF)
+
+	case FMT_CHAR:
+	    if (IS_INDEFD (value))
+		call strcpy ("INDEF", obuf, SZ_OBUF)
+	    else {
+		ch = nint (value)
+		junk = ctocc (ch, obuf, SZ_OBUF)
+	    }
+
+	case FMT_DECIMAL, FMT_OCTAL, FMT_HEX, FMT_RADIX, FMT_UNSIGNED:
+	    switch (fmt) {
+	    case FMT_DECIMAL:
+		radix = DECIMAL				# signed decimal
+	    case FMT_OCTAL:
+		radix = -OCTAL				# unsigned octal
+	    case FMT_HEX:
+		radix = -HEX				# unsigned hex
+	    case FMT_UNSIGNED:
+		radix = -DECIMAL			# unsigned decimal
+	    default:
+		radix = -abs(radix)			# unsigned radix
+	    }
+
+	    if (IS_INDEFD (value)) {
+		lnum = INDEFL
+		nchars = gltoc (lnum, obuf, SZ_OBUF, radix)
+
+	    } else {
+		lnum = long (value)
+		nchars = gltoc (lnum, obuf, SZ_OBUF, radix)
+
+		# Limit sign extension if negative number, hex or octal.
+		if (lnum < 0 && (dtype == TY_SHORT || dtype == TY_CHAR)) {
+		    nbits = SZB_CHAR * NBITS_BYTE
+		    if (dtype == TY_SHORT)
+			nbits = nbits * SZ_SHORT
+		    if (fmt == FMT_OCTAL) {
+			n = nchars - (nbits + 2) / 3
+			if (n > 0) {
+			    call strcpy (obuf[n+2], obuf[2], SZ_OBUF)
+			    obuf[1] = '1'
+			}
+		    } else if (fmt == FMT_HEX) {
+			n = nchars - (nbits + 3) / 4
+			if (n > 0)
+			    call strcpy (obuf[n+1], obuf[1], SZ_OBUF)
+		    }
+		}
+	    }
+
+	case FMT_EXPON, FMT_FIXED, FMT_GENERAL, FMT_HMS, FMT_MINSEC:
+	    if (decpl == USE_DEFAULT || decpl == 0)
+		switch (fmt) {
+		case FMT_EXPON, FMT_GENERAL:
+		    decpl = precision
+		case FMT_HMS, FMT_MINSEC:
+		    if (decpl == USE_DEFAULT)
+			decpl = 1
+		default:
+		    if (decpl == USE_DEFAULT)
+			decpl = precision
+		}
+	    repeat {
+		# Need the case sensitive format char here.
+		n = dtoc (value, obuf, SZ_OBUF, decpl, format_char, width+1)
+		decpl = decpl - 1
+	    } until (n <= width || decpl <= 0)
+
+	case FMT_TOCOLUMN:				# advance to column
+	    for (i=int(value);  col < i;  col=col+1)
+		call putci (fd, ' ')
+	    call fpradv()
+	    return
+
+	case FMT_WHITESPACE:				# output whitespace
+	    for (i=0;  i < int(value);  i=i+1)
+		call putci (fd, ' ')
+	    col = col + i
+	    call fpradv()
+	    return
+
+	case FMT_COMPLEX:
+	    if (decpl == USE_DEFAULT)			# set defaults
+		decpl = precision
+	    else
+		decpl = abs (decpl)
+
+	    if (IS_INDEFD (value))
+		xnum = INDEFX
+	    else
+		xnum = complex (value)
+
+	    # Convert, decrease precision until it fits in given field width.
+	    repeat {
+		n = xtoc (xnum, obuf, SZ_OBUF, decpl, 'e', SZ_OBUF)
+		decpl = decpl - 1
+	    } until (n <= width || decpl <= 0)
+	}
+	    
+	# Move the string in OBUF to the output file, left or right justifying
+	# as specified.  Advance to the next format spec (or finish up).
+
+	if (width == SZ_OBUF)				# free format?
+	    width = 0
+	call fmtstr (fd, obuf, col, fill_char, left_justify, SZ_OBUF, width)
+	call fpradv ()
+end
diff --git a/sys/fmtio/pargb.x b/sys/fmtio/pargb.x
new file mode 100644
index 00000000..bc3e6eb0
--- /dev/null
+++ b/sys/fmtio/pargb.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# PARGB -- Print a boolean operand (as a string).
+
+procedure pargb (bval)
+
+bool	bval
+
+begin
+	if (bval)
+	    call pargstr ("yes")
+	else
+	    call pargstr ("no")
+end
diff --git a/sys/fmtio/pargstr.x b/sys/fmtio/pargstr.x
new file mode 100644
index 00000000..59fc7433
--- /dev/null
+++ b/sys/fmtio/pargstr.x
@@ -0,0 +1,26 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# PARGSTR -- Pass a string type operand to printf.
+
+procedure pargstr (str)
+
+char	str[ARB]
+int	maxch
+include "fmt.com"
+
+begin
+	call fmt_read()					# get format
+
+	if (decpl == USE_DEFAULT)
+	    maxch = SZ_OBUF
+	else
+	    maxch = abs (decpl)
+
+	if (width == USE_DEFAULT)
+	    width = 0
+
+	call fmtstr (fd, str, col, fill_char, left_justify, maxch, width)
+	call fpradv ()
+end
diff --git a/sys/fmtio/pargx.x b/sys/fmtio/pargx.x
new file mode 100644
index 00000000..d399da29
--- /dev/null
+++ b/sys/fmtio/pargx.x
@@ -0,0 +1,57 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+include	<ctype.h>
+include	<printf.h>
+
+# PARGX -- Pass a numeric argument of type complex to printf.  Get the format
+# spec and format the number on the output file.  Try to provide reasonable
+# automatic type conversions.  Avoid any type coercion of indefinites.
+
+procedure pargx (xval)
+
+complex	xval			# complex value to be encoded
+double	value
+int	n, xtoc()
+include "fmt.com"
+
+begin
+	call fmt_read()					# read format
+
+	if (format_char == FMT_COMPLEX || format_char == USE_DEFAULT) {
+	    if (width == USE_DEFAULT)			# print as (r,r)
+		width = SZ_OBUF
+
+	    if (decpl == USE_DEFAULT || decpl == 0)
+		decpl = NDIGITS_RP
+	    else
+		decpl = abs (decpl)
+
+	    # Encode number in the available field width, decreasing the
+	    # precision until the number fits.
+
+	    repeat {
+		n = xtoc (xval, obuf, SZ_OBUF, decpl, FMT_EXPON, SZ_OBUF)
+		decpl = decpl - 1
+	    } until (n <= width || decpl <= 0)
+
+	    # Move the string in OBUF to the output file, left or right
+	    # justifying as specified.  Advance to the next format spec
+	    # (or finish up).
+
+	    if (width == SZ_OBUF)				# free format?
+		width = 0
+	    call fmtstr (fd, obuf, col, fill_char, left_justify, SZ_OBUF, width)
+	    call fpradv ()
+
+	} else {
+	    # Print real part of complex number in some format other than
+	    # complex.
+
+	    value = real (xval)
+	    if (IS_INDEFR (real(xval)))
+		value = INDEFD
+
+	    call pargg (value, TY_REAL)
+	}
+end
diff --git a/sys/fmtio/patmatch.x b/sys/fmtio/patmatch.x
new file mode 100644
index 00000000..9972060f
--- /dev/null
+++ b/sys/fmtio/patmatch.x
@@ -0,0 +1,568 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<pattern.h>
+include	<ctype.h>
+include	<chars.h>
+
+# PATMATCH.X -- Routines for matching regular expressions (general pattern
+# matching).  Adapted from Software Tools.
+# 
+#	      patsize = patmake (patstr, patbuf, sz_patbuf)
+#	   next_char = patmatch (str, patbuf)
+#	  next_char = gpatmatch (str, patbuf, first_char, last_char)
+#	          ip = patindex (patbuf, index_number)
+#
+# The pattern string must be encoded with PATMAKE before use.  See also
+# STRMATCH, STRNCMP, etc.
+
+# Pattern codes (for encoded patterns).
+
+define	EOP		-1		# end of encoded pattern
+define	CHAR		-2		# match char
+define	UCHAR		-3		# match either case
+define	LCHAR		-4		# match either case
+define	BOL		-5		# match at beginning of line
+define	EOL		-6		# match at end of line
+define	ANY		-7		# "?"
+define	WHITESPACE	-8		# "#"
+define	CCL		-9		# [...
+define	NCCL		-10		# [^...
+define	CLOSURE		-11		# "*"
+define	INDEX		-12		# % (mark index of ^ in pattern)
+
+define	CH_INDEX	'%'		# move to <chars.h> after a while
+
+# Definitions for the closure structure.
+
+define	CLOSIZE		4		# size of closure structure
+define	COUNT		1		# repeat count for matches
+define	PREVCL		2		# index of previous closure in pat
+define	START		3		# index in str where match starts
+
+
+# PATMATCH -- Match pattern anywhere on line.  Returns the index of the
+# first character AFTER the match, or zero if no match.
+
+int procedure patmatch (str, pat)
+
+char	str[ARB]		# string to be scanned
+char	pat[ARB]		# encoded pattern
+
+int	first_char, last_char
+int	gpatmatch()
+
+begin
+	return (gpatmatch (str, pat, first_char, last_char))
+end
+
+
+# GPATMATCH -- Generalized pattern match.  Matches pattern anywhere on
+# line (the first such pattern matched terminates the search).  Function
+# return same as for PATMATCH, but also returns indices of the first and
+# last characters in the matched substring.
+
+int procedure gpatmatch (str, pat, first_char, last_char)
+
+char	str[ARB]		# string to be scanned
+char	pat[ARB]		# encoded pattern
+int	first_char		# index of first char matched (output)
+int	last_char		# index of last  char matched (output)
+
+int	ip, nchars_matched
+int	pat_amatch()				# anchored match
+
+begin
+	nchars_matched = 0
+
+	if (pat[1] == BOL) {
+	    ip = 1
+	    nchars_matched = pat_amatch (str, ip, pat)
+	} else {
+	    for (ip=1;  str[ip] != EOS;  ip=ip+1) {
+		nchars_matched = pat_amatch (str, ip, pat)
+		if (nchars_matched > 0)
+		    break
+	    }
+	}
+
+	if (nchars_matched > 0) {
+	    first_char = ip
+	    last_char = ip + nchars_matched - 1
+	    return (last_char + 1)
+	} else
+	    return (0)
+end
+
+
+# PATINDEX -- Return the index of a marked position in the pattern.  Inclusion
+# of the character % in the pattern causes the index of the character following
+# the % to be saved in the encoded pattern at patmatch time.  We are called
+# after a patmatch operation to scan the pattern and recall the Nth saved index.
+# Zero is returned if N is larger than the number of saved index points.
+
+int procedure patindex (pat, n)
+
+char	pat[ARB]		# encoded pattern
+int	n			# number of index to be returned
+
+int	pp, ix
+int	pat_gsize()
+
+begin
+	ix = 1
+	for (pp=1;  pat[pp] != EOP;  pp=pp+pat_gsize(pat,pp))
+	    if (pat[pp] == INDEX)
+		if (ix >= n)
+		    return (pat[pp+1])
+		else
+		    ix = ix + 1
+
+	return (0)
+end
+
+
+# PAT_AMATCH -- Anchored match.  Look for match starting at the given
+# offset.  Return the number of characters matched.
+
+int procedure pat_amatch (str, from, pat)
+
+char	str[ARB]		# string to be matched
+int	from			# starting at this index
+char	pat[ARB]		# encoded pattern
+
+int	ip, pp, offset, stack
+int	pat_omatch(), pat_gsize()
+
+begin
+	stack = 0
+	offset = from				# next unexamined input char
+
+	for (pp=1;  pat[pp] != EOP;  pp = pp + pat_gsize(pat,pp)) {
+	    if (pat[pp] == CLOSURE) {		# a closure entry
+		stack = pp
+		pp = pp + CLOSIZE	
+		# Match as many characters as possible, save results
+		for (ip=offset;  str[ip] != EOS;  )
+		    if (pat_omatch (str, ip, pat, pp) == NO)
+			break
+		pat[stack+COUNT] = ip - offset
+		pat[stack+START] = offset
+		offset = ip			# character that made us fail
+
+	    } else if (pat_omatch (str, offset, pat, pp) == NO) {
+		for (;  stack > 0;  stack = pat[stack+PREVCL])
+		    if (pat[stack+COUNT] > 0)
+			break
+		if (stack <= 0)			# stack is empty
+		    return (0)			# return failure
+
+		pat[stack+COUNT] = pat[stack+COUNT] - 1
+		pp = stack + CLOSIZE
+		offset = pat[stack+START] + pat[stack+COUNT]
+	    }
+	}
+
+	return (offset-from)			# successful match
+end
+
+
+# PAT_GSIZE -- Returns size of pattern entry at pat[n].
+
+int procedure pat_gsize (pat, n)
+
+char	pat[ARB]		# encoded pattern
+int	n			# pointer into pattern
+int	pattern_size
+
+begin
+	switch (pat[n]) {
+	case CHAR, UCHAR, LCHAR, INDEX:
+	    pattern_size = 2
+	case BOL, EOL, ANY, WHITESPACE:
+	    pattern_size = 1
+	case CCL, NCCL:
+	    pattern_size = pat[n+1] + 2
+	case CLOSURE:					# not used
+	    pattern_size = CLOSIZE
+	default:
+	    call error (0, "In patsize: can't happen.")
+	}
+
+	return (pattern_size)
+end
+
+
+# PAT_OMATCH -- Try to match a single pattern at pat[pp].  If match, bump IP
+# to point to the next unmatched character.  Return OK if match.
+
+int procedure pat_omatch (str, ip, pat, pp)
+
+char	str[ARB]		# string to be scanned
+int	ip			# starting index in string (may be changed)
+char	pat[ARB]		# encoded pattern
+int	pp			# pointer to next pattern element
+
+char	str_ch
+int	bump, pat_locate()
+
+begin
+	if (str[ip] == EOS)
+	    if (pat[pp] == INDEX) {
+		pat[pp+1] = ip
+		return (YES)
+	    } else if (pat[pp] == EOL) {
+		return (YES)
+	    } else
+		return (NO)
+
+	# Treat CHAR (simple character match) as a special case to speed
+	# things up a bit.
+
+	if (pat[pp] == CHAR)
+	    if (str[ip] == pat[pp+1]) {
+		ip = ip + 1
+		return (YES)
+	    } else
+		return (NO)
+
+	# Compare as indicated by encoded pattern opcode.
+	bump = -1
+
+	switch (pat[pp]) {
+	case UCHAR:					# match either case
+	    str_ch = str[ip]
+	    if (IS_LOWER (str_ch))
+		str_ch = TO_UPPER (str_ch)
+	    if (str_ch == pat[pp+1])
+		bump = 1
+	case LCHAR:					# match either case
+	    str_ch = str[ip]
+	    if (IS_UPPER (str_ch))
+		str_ch = TO_LOWER (str_ch)
+	    if (str_ch == pat[pp+1])
+		bump = 1
+	case BOL:					# beg. of line
+	    if (ip == 1)
+		bump = 0
+	case EOL:					# end of line
+	    if (str[ip] == '\n')
+		bump = 0
+	case ANY:					# match any char
+	    if (str[ip] != '\n')
+		bump = 1
+	case WHITESPACE:
+	    for (bump=0;  IS_WHITE (str[ip+bump]);  bump=bump+1)
+		;
+	case CCL:					# char class
+	    if (pat_locate (str[ip], pat, pp + 1) == YES)
+		bump = 1
+	case NCCL:					# not in char class
+	    if (str[ip] != '\n' && pat_locate (str[ip], pat, pp + 1) == NO)
+		bump = 1
+	case INDEX:
+	    pat[pp+1] = ip
+	    bump = 0
+	default:
+	    call error (0, "In omatch: can't happen.")
+	}
+
+	if (bump >= 0) {
+	    ip = ip + bump
+	    return (YES)
+	} else
+	    return (NO)
+end
+
+
+# PAT_LOCATE -- Look for c in char class at pat[offset].
+
+int procedure pat_locate (ch, pat, offset)
+
+char	ch			# char to search for
+char	pat[ARB]		# encoded pattern
+int	offset			# offset of character class in pattern
+
+int	nchars, i
+
+begin
+	# Size of class is at pat[offset], characters follow.
+	nchars = pat[offset]
+	do i = 1, nchars
+	    if (ch == pat[offset+i])
+		return (YES)
+
+	return (NO)
+end
+
+
+# PATMAKE -- Encode pattern specification string.  Returns the size of
+# the encoded pattern string.
+
+int procedure patmake (str, pat, sz_pat)
+
+char	str[ARB]		# pattern to be encoded
+char	pat[ARB]		# encoded pattern (output)
+int	sz_pat			# max size of the pattern string
+int	gpatmake()
+
+begin
+	return (gpatmake (str, 1, EOS, pat, sz_pat))
+end
+
+
+# GPATMAKE -- Make pattern from str[from], terminate at delim.
+
+int procedure gpatmake (patstr, from, delim, patbuf, sz_pat)
+
+char	patstr[ARB]		# pattern to be encoded
+int	from			# starting index
+int	delim			# delimiter character
+char	patbuf[ARB]		# put encoded pattern here
+int	sz_pat			# max chars in encoded pattern
+
+int	ip, op, last_closure, last_op, l_op
+char	cval
+bool	ignore_case
+int	cctoc(), pat_getccl(), pat_stclos()
+
+begin
+	op = 1					      # pat index
+	last_op = 1
+	last_closure = 0
+	ignore_case = false
+
+	for (ip=from;  patstr[ip] != delim && patstr[ip] != EOS;  ip=ip+1) {
+	    l_op = op
+
+	    # If CVAL gets set to nonzero it will be deposited in the output
+	    # buffer at end of switch.
+
+	    cval = 0
+
+	    switch (patstr[ip]) {
+	    case CH_ANY:
+		cval = ANY
+	    case CH_WHITESPACE:
+		cval = WHITESPACE
+
+	    case CH_BOL:
+		if (ip == from)
+		    cval = BOL
+		else {
+		    cval = CHAR
+		    call chdeposit (cval, patbuf, sz_pat, op)
+		    cval = CH_BOL
+		}
+
+	    case CH_EOL:
+		if (patstr[ip+1] == delim)
+		    cval = EOL
+		else {
+		    cval = CHAR
+		    call chdeposit (cval, patbuf, sz_pat, op)
+		    cval = CH_EOL
+		}
+
+	    case CH_IGNORECASE:
+		ignore_case = true
+	    case CH_MATCHCASE:
+		ignore_case = false
+
+	    case CH_CCL:
+		if (pat_getccl (patstr, patbuf, sz_pat, ip, op) == ERR)
+		    return (ERR)
+
+	    case CH_CLOSURE:
+		# The "closure" of a pattern, e.g., "..*".
+
+		l_op = last_op
+		# Convert a pattern such as "*..." into "?*...".
+		if (ip == from)				# closure of nothing
+		    cval = ANY
+		else {
+		    switch (patbuf[l_op]) {
+		    case BOL, EOL, CLOSURE:
+			cval = ANY
+		    }
+		}
+
+		if (cval != 0)
+		    call chdeposit (cval, patbuf, sz_pat, op)
+		cval = 0
+
+		last_closure = pat_stclos (patbuf, sz_pat, op, last_op,
+		    last_closure)
+
+	    case CH_INDEX:
+		# This metacharacter does not match anything, but rather is
+		# used to record the index of the marked position in the
+		# matched pattern.  The index is recorded in the pattern
+		# buffer at match time, to be later recovered with patindex.
+
+		cval = INDEX
+		call chdeposit (cval, patbuf, sz_pat, op)
+		cval = 0
+		call chdeposit (cval, patbuf, sz_pat, op)
+
+	    default:
+		# Ordinary character.
+
+		# Deposit command code.
+		if (ignore_case) {
+		    if (IS_UPPER (patstr[ip]))
+			cval = UCHAR
+		    else
+			cval = LCHAR
+		} else
+		    cval = CHAR
+		call chdeposit (cval, patbuf, sz_pat, op)
+
+		# Set CVAL to actual character value.
+		if (patstr[ip] == CH_ESCAPE) {
+		    if (cctoc (patstr, ip, cval) == 1)
+			cval = patstr[ip]
+		    else
+			ip = ip - 1
+		} else
+		    cval = patstr[ip]
+	    }
+
+	    # Deposit the character left in CVAL by the code above.
+	    if (cval != 0)
+		call chdeposit (cval, patbuf, sz_pat, op)
+
+	    last_op = l_op
+	}
+
+	# Terminate the pattern.
+	cval = EOP
+	call chdeposit (cval, patbuf, sz_pat, op)
+
+	if (patstr[ip] != delim || op >= sz_pat)
+	    return (ERR)
+	else
+	    return (op - 1)				# return size patbuf
+end
+
+
+# PAT_GETCCL -- Expand character class at patstr[i] into patbuf[op].
+
+int procedure pat_getccl (patstr, patbuf, sz_pat, ip, op)
+
+char	patstr[ARB], patbuf[ARB]
+int	sz_pat, ip, op
+char	cval
+int	op_start
+
+begin
+	ip = ip + 1					# skip over [
+	if (patstr[ip] == CH_NOT) {
+	    cval = NCCL
+	    ip = ip + 1
+	} else
+	    cval = CCL
+
+	call chdeposit (cval, patbuf, sz_pat, op)
+
+	op_start = op
+	cval = 0
+	call chdeposit (cval, patbuf, sz_pat, op)	# leave room for count
+	call pat_filset (CH_CCLEND, patstr, ip, patbuf, sz_pat, op)
+	patbuf[op_start] = op - op_start - 1		# fix up count
+
+	if (patstr[ip] == CH_CCLEND)
+	    return (OK)
+	else
+	    return (ERR)
+end
+
+
+# PAT_STCLOS -- Insert closure entry at patbuf[op].
+
+int procedure pat_stclos (patbuf, sz_pat, op, last_op, last_closure)
+
+char	patbuf[ARB]
+int	sz_pat
+int	op
+int	last_op
+int	last_closure
+
+char	cvals[4]
+int	next_closure, jp, jt, i
+
+begin
+	for (jp=op-1;  jp >= last_op;  jp=jp-1) {	# make a hole
+	    jt = min (sz_pat, jp + CLOSIZE)
+	    patbuf[jt] = patbuf[jp]
+	}
+
+	op = op + CLOSIZE
+	next_closure = last_op
+
+	cvals[1] = CLOSURE
+	cvals[2] = 0				# COUNT
+	cvals[3] = last_closure			# PREVCL
+	cvals[4] = 0				# START
+
+	do i = 1, 4
+	    call chdeposit (cvals[i], patbuf, sz_pat, last_op)
+
+	return (next_closure)
+end
+
+
+# PAT_FILSET -- Process a character class into a simple list of characters.
+
+procedure pat_filset (delim, patstr, ip, patbuf, sz_pat, op)
+
+int	delim			# character class delimiter character
+char	patstr[ARB]		# character class characters
+int	ip			# index where they start
+char	patbuf[ARB]		# encode character class in this string
+int	sz_pat			# max chars out
+int	op			# offset into patbuf
+
+char	ch, ch1, ch2
+int	cctoc()
+
+begin
+	for (;  patstr[ip] != delim && patstr[ip] != EOS;  ip=ip+1) {
+	    if (patstr[ip] == ESCAPE) {				# escape seq.
+		if (cctoc (patstr, ip, ch) == 1)
+		    ch = patstr[ip]
+		else
+		    ip = ip - 1
+		call chdeposit (ch, patbuf, sz_pat, op)
+
+	    } else if (patstr[ip] != CH_RANGE) {
+		call chdeposit (patstr[ip], patbuf, sz_pat, op)
+
+	    } else if (op <= 1 || patstr[ip+1] == EOS) {	# literal "-"
+		ch = CH_RANGE
+		call chdeposit (ch, patbuf, sz_pat, op)
+
+	    } else {
+		# Here if char is CH_RANGE, denoting a range of characters to be
+		# included in the character class.  Range is valid only if limit
+		# chars are both digits, both lower case, or both upper case.
+
+		ch1 = patbuf[op-1]		# not same as patstr[ip-1]
+		ch2 = patstr[ip+1]
+
+		if ((IS_DIGIT (ch1) && IS_DIGIT (ch2)) ||
+		    (IS_LOWER (ch1) && IS_LOWER (ch2)) ||
+		    (IS_UPPER (ch1) && IS_UPPER (ch2))) {
+			if (ch1 <= ch2)
+			    for (ch=ch1+1;  ch <= ch2;  ch=ch+1)
+				call chdeposit (ch, patbuf, sz_pat, op)
+			else
+			    for (ch=ch1-1;  ch >= ch2;  ch=ch-1)
+				call chdeposit (ch, patbuf, sz_pat, op)
+			ip = ip + 1
+		} else {
+		    ch = CH_RANGE
+		    call chdeposit (ch, patbuf, sz_pat, op)
+		}
+	    }
+	}
+end
diff --git a/sys/fmtio/printf.x b/sys/fmtio/printf.x
new file mode 100644
index 00000000..e0662d90
--- /dev/null
+++ b/sys/fmtio/printf.x
@@ -0,0 +1,13 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# PRINTF -- Format output to the standard output.
+
+procedure printf (format_string)
+
+char	format_string[ARB]
+
+begin
+	call fprntf (STDOUT, format_string, REGULAR_FILE)
+end
diff --git a/sys/fmtio/resetscan.x b/sys/fmtio/resetscan.x
new file mode 100644
index 00000000..bde3a8f7
--- /dev/null
+++ b/sys/fmtio/resetscan.x
@@ -0,0 +1,14 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# RESET_SCAN -- Initialize the scan common at the start of a scan.  May also
+# be called by the user to rescan a line, following a conversion failure.
+
+procedure reset_scan()
+
+include	"scan.com"
+
+begin
+	sc_ip = 1
+	sc_ntokens = 0
+	sc_stopscan = false
+end
diff --git a/sys/fmtio/scan.com b/sys/fmtio/scan.com
new file mode 100644
index 00000000..cb60824c
--- /dev/null
+++ b/sys/fmtio/scan.com
@@ -0,0 +1,10 @@
+# SCAN.COM -- Global common for the scan family of routines.
+
+define	SZ_SCANBUF	4096
+
+int	sc_ip			# char pointer into lbuf
+int	sc_ntokens		# keep track of successful conversions
+bool	sc_stopscan		# set if conversion is unsuccessful
+char	sc_scanbuf[SZ_SCANBUF]	# line buffer for scan procedures
+
+common	/scncom/ sc_ip, sc_ntokens, sc_stopscan, sc_scanbuf
diff --git a/sys/fmtio/scanc.x b/sys/fmtio/scanc.x
new file mode 100644
index 00000000..1578af42
--- /dev/null
+++ b/sys/fmtio/scanc.x
@@ -0,0 +1,14 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# SCANC -- Return the next character from the scanned input.
+
+procedure scanc (cval)
+
+char	cval
+include	"scan.com"
+
+begin
+	cval = sc_scanbuf[sc_ip]
+	if (cval != EOS)
+	    sc_ip = sc_ip + 1
+end
diff --git a/sys/fmtio/sprintf.x b/sys/fmtio/sprintf.x
new file mode 100644
index 00000000..c247d868
--- /dev/null
+++ b/sys/fmtio/sprintf.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<printf.h>
+
+# SPRINTF: Open string as a file, call fprntf.  When the last argument is
+# passed, and EOS is reached, the string will be closed (by fpradv).
+
+procedure sprintf (outstr, maxch, format_string)
+
+char	outstr[maxch]
+int	maxch
+char	format_string[ARB]
+int	mem_fd, stropen()
+errchk	stropen, fprntf
+
+begin
+	mem_fd = stropen (outstr, maxch, WRITE_ONLY)
+	call fprntf (mem_fd, format_string, STRING_FILE)
+end
diff --git a/sys/fmtio/sscan.x b/sys/fmtio/sscan.x
new file mode 100644
index 00000000..6c877dc2
--- /dev/null
+++ b/sys/fmtio/sscan.x
@@ -0,0 +1,24 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# SSCAN -- Begin a scan from a string.  Only the first newline terminated
+# line in the string buffer will be scanned.  If a string buffer containing
+# more than a single line must be scanned, MEMOPEN and FSCAN may be used.
+
+procedure sscan (str)
+
+char	str[ARB]
+int	ip, op
+include	"scan.com"
+
+begin
+	op = 1
+	for (ip=1;  str[ip] != EOS && str[ip] != '\n';  ip=ip+1) {
+	    sc_scanbuf[op] = str[ip]
+	    op = op + 1
+	    if (op >= SZ_SCANBUF)
+		break
+	}
+
+	sc_scanbuf[op] = EOS
+	call reset_scan()				# initialize scan
+end
diff --git a/sys/fmtio/strcat.x b/sys/fmtio/strcat.x
new file mode 100644
index 00000000..777174a3
--- /dev/null
+++ b/sys/fmtio/strcat.x
@@ -0,0 +1,12 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRCAT -- String concatenation.  String STR is appended to OUTSTR.
+
+procedure strcat (str, outstr, maxch)
+
+char	str[ARB], outstr[ARB]
+int	maxch, junk, gstrcat()
+
+begin
+	junk = gstrcat (str, outstr, maxch)
+end
diff --git a/sys/fmtio/strcmp.x b/sys/fmtio/strcmp.x
new file mode 100644
index 00000000..67dbc2ba
--- /dev/null
+++ b/sys/fmtio/strcmp.x
@@ -0,0 +1,17 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRCMP -- Compare two strings.  -N is returned if S1 < S2, 0 if S1 == S2,
+# and +N if S1 > S2.
+
+int procedure strcmp (s1, s2)
+
+char	s1[ARB], s2[ARB]		# strings to be compared
+int	i
+
+begin
+	do i = 1, ARB
+	    if (s1[i] != s2[i])
+		return (s1[i] - s2[i])
+	    else if (s1[i] == EOS)
+		return (0)
+end
diff --git a/sys/fmtio/strcpy.x b/sys/fmtio/strcpy.x
new file mode 100644
index 00000000..8892e89d
--- /dev/null
+++ b/sys/fmtio/strcpy.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRCPY -- Copy string s1 to s2.
+
+procedure strcpy (s1, s2, maxch)
+
+char	s1[ARB], s2[ARB]
+int	maxch, i
+
+begin
+	do i = 1, maxch {
+	    s2[i] = s1[i]
+	    if (s2[i] == EOS)
+		return
+	}
+
+	s2[maxch+1] = EOS
+end
diff --git a/sys/fmtio/strdic.x b/sys/fmtio/strdic.x
new file mode 100644
index 00000000..3da4a71b
--- /dev/null
+++ b/sys/fmtio/strdic.x
@@ -0,0 +1,73 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# STRDIC -- Search a dictionary string for a match with an input string.
+# The input string may be an abbreviation of a dictionary entry, however,
+# it is an error if the abbreviation is not unique.  The entries in the
+# dictionary string are separated by a delimiter character which is the first
+# character of the dictionary string.  The full name of the matched dictionary
+# entry found is returned in out_str; the function value is the word index of
+# the dictionary entry.  The output string may be the same as the input string.
+
+int procedure strdic (in_str, out_str, maxchars, dict)
+
+char	in_str[ARB]		# Input string, always lower case
+char	out_str[ARB]		# Output string as found in dictionary
+int	maxchars		# Maximum length of output string
+char	dict[ARB]		# Dictionary string
+
+char	ch, fch
+int	start, len, ip, i, match, entry
+int	strlen(), strncmp()
+
+begin
+	if (dict[1] == EOS)
+	    return (0)
+
+	for (i=1;  IS_WHITE (in_str[i]);  i=i+1)
+	    ;
+
+	start = i
+	match = 0
+	ip    = 2
+	len   = strlen (in_str[start])
+	fch   = in_str[start]
+
+	# Search the dictionary string.  If the input string matches a
+	# dictionary entry it is either an exact match (len = dictionary
+	# entry length) or a legal abbreviation.  If an abbreviation
+	# matches two entries it is ambiguous and an error.
+
+	for (entry=1;  dict[ip] != EOS;  entry=entry+1) {
+	    if (dict[ip] == fch) {
+		if (strncmp (dict[ip], in_str[start], len) == 0) {
+		    for (i=1;  i <= maxchars;  i=i+1) {
+			ch = dict[ip+i-1]
+			if ((ch == dict[1]) || (ch == EOS))
+			    break
+			out_str[i] = ch
+		    }
+		    out_str[i] = EOS
+
+		    if ((dict[ip+len] == dict[1]) || (dict[ip+len] == EOS))
+			return (entry)		# exact match
+		    else {
+			# If we already have a match and the new match is not
+			# exact, then the abbreviation is ambiguous.
+
+			if (match != 0)
+			    return (0)
+			else
+			    match = entry
+		    }
+		}
+	    }
+
+	    repeat {
+		ip = ip + 1
+	    } until (dict[ip-1] == dict[1] || dict[ip] == EOS)
+	}
+
+        return (match)
+end
diff --git a/sys/fmtio/streq.x b/sys/fmtio/streq.x
new file mode 100644
index 00000000..0f394d6d
--- /dev/null
+++ b/sys/fmtio/streq.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STREQ -- Compare two strings for equality.
+
+bool procedure streq (s1, s2)
+
+char	s1[ARB], s2[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (s1[ip] != s2[ip])
+		return (false)
+	    else if (s1[ip] == EOS)
+		return (s2[ip] == EOS)
+end
diff --git a/sys/fmtio/strge.x b/sys/fmtio/strge.x
new file mode 100644
index 00000000..4fc24c59
--- /dev/null
+++ b/sys/fmtio/strge.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRGE -- Is S1 >= S2.
+
+bool procedure strge (s1, s2)
+
+char	s1[ARB], s2[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (s2[ip] == EOS)
+		return (true)
+	    else if (s1[ip] != s2[ip])
+		return (s1[ip] > s2[ip])
+end
diff --git a/sys/fmtio/strgt.x b/sys/fmtio/strgt.x
new file mode 100644
index 00000000..720a1397
--- /dev/null
+++ b/sys/fmtio/strgt.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRGT -- Is S1 > S2.
+
+bool procedure strgt (s1, s2)
+
+char	s1[ARB], s2[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (s1[ip] == EOS)
+		return (false)
+	    else if (s1[ip] != s2[ip])
+		return (s1[ip] > s2[ip])
+end
diff --git a/sys/fmtio/stridx.x b/sys/fmtio/stridx.x
new file mode 100644
index 00000000..dda74f5a
--- /dev/null
+++ b/sys/fmtio/stridx.x
@@ -0,0 +1,17 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRIDX -- Return the index of the first occurrence of a character in a
+# string.
+
+int procedure stridx (ch, str)
+
+char	ch, str[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (str[ip] == EOS)
+		return (0)
+	    else if (str[ip] == ch)
+		return (ip)
+end
diff --git a/sys/fmtio/stridxs.x b/sys/fmtio/stridxs.x
new file mode 100644
index 00000000..fef58806
--- /dev/null
+++ b/sys/fmtio/stridxs.x
@@ -0,0 +1,43 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+define	BIGSET		10
+define	SZ_ASCII	128
+
+# STRIDXS -- Return the index of the first occurrence of any of a set of
+# characters in a string.
+
+int procedure stridxs (set, str)
+
+char	set[ARB]		# set of characters to be searched for
+char	str[ARB]		# string to be searched
+
+int	setlen, ip, i
+char	ch, lut[SZ_ASCII]
+int	strlen()
+
+begin
+	setlen = strlen (set)
+
+	if (setlen > BIGSET) {
+	    # Encode the set in a lookup table.
+	    call aclrc (lut, SZ_ASCII)
+	    do i = 1, setlen
+		lut[set[i]] = 1
+
+	    # Search the string.
+	    for (ip=1;  str[ip] != EOS;  ip=ip+1)
+		if (lut[str[ip]] != 0)
+		    return (ip)
+
+	} else {
+	    # Set is too small to be worth using a lookup table.
+	    for (ip=1;  str[ip] != EOS;  ip=ip+1) {
+		ch = str[ip]
+		do i = 1, setlen
+		    if (ch == set[i])
+			return (ip)
+	    }
+	}
+	
+	return (0)
+end
diff --git a/sys/fmtio/strldx.x b/sys/fmtio/strldx.x
new file mode 100644
index 00000000..0087a208
--- /dev/null
+++ b/sys/fmtio/strldx.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRLDX -- Return the index of the last occurrence of a character in a
+# string.
+
+int procedure strldx (ch, str)
+
+char	ch, str[ARB]
+int	ip, offset
+
+begin
+	offset = 0
+	do ip = 1, ARB
+	    if (str[ip] == EOS)
+		break
+	    else if (str[ip] == ch)
+		offset = ip
+
+	return (offset)
+end
diff --git a/sys/fmtio/strldxs.x b/sys/fmtio/strldxs.x
new file mode 100644
index 00000000..1c583d0f
--- /dev/null
+++ b/sys/fmtio/strldxs.x
@@ -0,0 +1,46 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+define	BIGSET		10
+define	SZ_ASCII	128
+
+# STRLDXS -- Return the index of the last occurrence of any of a set of
+# characters in a string.
+
+int procedure strldxs (set, str)
+
+char	set[ARB]		# set of characters to be searched for
+char	str[ARB]		# string to be searched
+
+int	setlen, ip, i, last_member
+char	ch, lut[SZ_ASCII]
+int	strlen()
+
+begin
+	setlen = strlen (set)
+	last_member = 0
+
+	if (setlen > BIGSET) {
+	    # Encode the set in a lookup table.
+	    call aclrc (lut, SZ_ASCII)
+	    do i = 1, setlen
+		lut[set[i]] = 1
+
+	    # Search the string.
+	    for (ip=1;  str[ip] != EOS;  ip=ip+1)
+		if (lut[str[ip]] != 0)
+		    last_member = ip
+
+	} else {
+	    # Set is too small to be worth using a lookup table.
+	    for (ip=1;  str[ip] != EOS;  ip=ip+1) {
+		ch = str[ip]
+		do i = 1, setlen
+		    if (ch == set[i]) {
+			last_member = ip
+			break
+		    }
+	    }
+	}
+	
+	return (last_member)
+end
diff --git a/sys/fmtio/strle.x b/sys/fmtio/strle.x
new file mode 100644
index 00000000..34ad7870
--- /dev/null
+++ b/sys/fmtio/strle.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRLE -- Is S1 <= S2.
+
+bool procedure strle (s1, s2)
+
+char	s1[ARB], s2[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (s1[ip] == EOS)
+		return (true)
+	    else if (s1[ip] != s2[ip])
+		return (s1[ip] < s2[ip])
+end
diff --git a/sys/fmtio/strlen.x b/sys/fmtio/strlen.x
new file mode 100644
index 00000000..4c3e7364
--- /dev/null
+++ b/sys/fmtio/strlen.x
@@ -0,0 +1,14 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRLEN -- Return length of string (EOS not included).
+
+int procedure strlen (str)
+
+char	str[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (str[ip] == EOS)
+		return (ip - 1)
+end
diff --git a/sys/fmtio/strlt.x b/sys/fmtio/strlt.x
new file mode 100644
index 00000000..0a530d4d
--- /dev/null
+++ b/sys/fmtio/strlt.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRLT -- Is S1 < S2.
+
+bool procedure strlt (s1, s2)
+
+char	s1[ARB], s2[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (s2[ip] == EOS)
+		return (false)
+	    else if (s1[ip] != s2[ip])
+		return (s1[ip] < s2[ip])
+end
diff --git a/sys/fmtio/strlwr.x b/sys/fmtio/strlwr.x
new file mode 100644
index 00000000..318366ac
--- /dev/null
+++ b/sys/fmtio/strlwr.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# STRLWR -- Convert string to lower case.
+
+procedure strlwr (a)
+
+char	a[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (a[ip] == EOS)
+		break
+	    else if (IS_UPPER(a[ip]))
+		a[ip] = TO_LOWER (a[ip])
+end
diff --git a/sys/fmtio/strmac.x b/sys/fmtio/strmac.x
new file mode 100644
index 00000000..1f3f3e98
--- /dev/null
+++ b/sys/fmtio/strmac.x
@@ -0,0 +1,86 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+define	MAX_ARGS	9
+
+.help strmac
+.nf ___________________________________________________________________________
+STRMAC -- Expand a macro (nonrecursively) by string substitution.
+The macro string may contain zero or more occurrences of the sequences
+"$1" through "$9".  The substitution strings are passed in the string
+buffer "argstr", wherein successive strings are delimited by the EOS marker.
+A double EOS marks the end of the list.
+
+Macros $1-$9 are replaced by the substitution string.  The sequence $$ is
+replaced by a single $.  If any other character follows the $, both the $
+and the following character are passed to the output unchanged.  An error
+action is taken if there are insufficient arguments or if the output buffer
+overflows.  Bugs: null substitution strings don't work.
+.endhelp ______________________________________________________________________
+
+int procedure strmac (macro, argstr, outstr, maxch)
+
+char	macro[ARB]		# substitution string
+char	argstr[ARB]		# argument strings, if any
+char	outstr[maxch]		# output string
+int	maxch	
+
+short	offset[MAX_ARGS]
+char	ch
+int	i, ip, op, arg, nargs, nchars
+int	strlen()
+
+begin
+	# Determine the offsets of the argument strings.
+	ip = 1
+	for (nargs=1;  nargs <= MAX_ARGS;  nargs=nargs+1) {
+	    nchars = strlen (argstr[ip])
+	    if (nchars > 0) {
+		offset[nargs] = ip
+		ip = ip + nchars + 1
+	    } else
+		break
+	}
+	nargs = nargs - 1
+
+	# Expand the macro. 
+	op = 1
+	for (ip=1;  macro[ip] != EOS;  ip=ip+1) {
+	    ch = macro[ip]
+
+	    if (ch == '$') {			# Process $ arg sequence.
+		ip = ip + 1
+		ch = macro[ip]
+		if (ch >= '1' && ch <= '9') {
+		    arg = TO_INTEG(ch)
+		    if (arg > nargs)
+			call error (1, "Strmac: too few substitution arguments")
+		    for (i = offset[arg];  argstr[i] != EOS;  i=i+1) {
+			outstr[op] = argstr[i]
+			op = op + 1
+		    }
+
+		} else if (ch == '$') {		# "$$" --> "$"
+		    outstr[op] = '$'
+		    op = op + 1
+
+		} else {			# "$?" --> "$?"
+		    outstr[op] = '$'
+		    op = op + 1
+		    outstr[op] = ch
+		    op = op + 1
+		}
+
+	    } else {				# ordinary character
+		outstr[op] = ch
+		op = op + 1
+	    }
+
+	    if (op > maxch)
+		call error (2, "Strmac: output buffer overflow")
+	}
+
+	outstr[op] = EOS
+	return (op - 1)
+end
diff --git a/sys/fmtio/strmatch.x b/sys/fmtio/strmatch.x
new file mode 100644
index 00000000..ad16bef8
--- /dev/null
+++ b/sys/fmtio/strmatch.x
@@ -0,0 +1,136 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include <pattern.h>
+
+.help strmatch, gstrmatch
+.nf ________________________________________________________________________
+STRMATCH -- Find the first occurrence of the string A in the string B.
+If not found, return zero, else return the index of the first character
+following the matched substring.
+
+GSTRMATCH -- More general version of strmatch.  The indices of the
+first and last characters matched are returned as arguments.  The function
+value is the same as for STRMATCH.
+
+STRMATCH recognizes the metacharacters BOL, EOL, ANY, WHITESPACE, IGNORECASE,
+and MATCHCASE (BOL and EOL are special only as the first and last chars
+in the pattern).  The null pattern matches any string.  Metacharacters
+can be escaped.
+.endhelp ___________________________________________________________________
+
+
+# STRMATCH -- Search string STR for pattern PAT.  Return the index of the
+# next character following the matched substring, or 0.
+
+int procedure strmatch (str, pat)
+
+char	pat[ARB], str[ARB]
+int	first_char, last_char
+int	gstrmatch()
+
+begin
+	return (gstrmatch (str, pat, first_char, last_char))
+end
+
+
+# GSTRMATCH -- Generalized string match.  Returns the indices of the first and
+# last characters in the matched substring if a match occurs.
+
+int procedure gstrmatch (str, pat, first_char, last_char)
+
+char	pat[ARB], str[ARB]
+int	first_char, last_char
+bool	ignore_case, bolflag
+char	ch, pch
+int	i, ip, initial_pp, pp
+
+begin
+	ignore_case = false
+	bolflag = false
+	first_char = 1
+	initial_pp = 1
+
+	if (pat[1] == CH_BOL) {			# match at beginning of line?
+	    bolflag = true
+	    initial_pp = 2
+	}
+	    
+	# Try to match pattern starting at each character offset in string.
+	do ip = 1, ARB {
+	    if (str[ip] == EOS)
+		break
+	    i = ip
+
+	    # Compare pattern to string str[ip].
+	    for (pp=initial_pp;  pat[pp] != EOS;  pp=pp+1) {
+		switch (pat[pp]) {
+		case CH_WHITESPACE:
+		    while (IS_WHITE (str[i]))
+			i = i + 1
+		case CH_ANY:
+		    if (str[i] != '\n')
+			i = i + 1
+		case CH_IGNORECASE:
+		    ignore_case = true
+		case CH_MATCHCASE:
+		    ignore_case = false
+		
+		default:
+		    pch = pat[pp]
+		    if (pch == CH_ESCAPE && pat[pp+1] != EOS) {
+			pp = pp + 1
+			pch = pat[pp]
+		    } else if (pch == CH_EOL)
+		        if (pat[pp+1] == EOS && (str[i]=='\n' || str[i]==EOS)) {
+			    first_char = ip
+			    last_char = i
+			    if (str[i] == EOS)
+				last_char = last_char - 1
+			    return (last_char + 1)
+			}
+
+		    ch = str[i]
+		    i = i + 1
+
+		    # Compare ordinary characters.  The comparison is trivial
+		    # unless case insensitivity is required.
+
+		    if (ignore_case) {
+	                if (IS_UPPER (ch)) {
+			    if (IS_UPPER (pch)) {
+				if (pch != ch)
+				    break
+			    } else if (pch != TO_LOWER (ch))
+		                    break
+	                } else if (IS_LOWER (ch)) {
+			    if (IS_LOWER (pch)) {
+		                if (pch != ch)
+		                    break
+			    } else if (pch != TO_UPPER (ch))
+				    break
+	                } else {
+			    if (pch != ch)
+				break
+			}
+		    } else {
+			if (pch != ch)
+			    break
+		    }
+	        }
+	    }
+
+	    # If the above loop was exited before the end of the pattern
+	    # was reached, the pattern did not match.
+
+	    if (pat[pp] == EOS) {
+		first_char = ip
+		last_char = i-1
+		return (i)
+
+	    } else if (bolflag || str[i] == EOS)
+		break
+	}
+
+	return (0)				# no match
+end
diff --git a/sys/fmtio/strncmp.x b/sys/fmtio/strncmp.x
new file mode 100644
index 00000000..515aeaaf
--- /dev/null
+++ b/sys/fmtio/strncmp.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRNCMP -- Compare the first N characters of two strings.  A negative value
+# is returned if S1 < S2, 0 if S1 == S2, and a positive value if S1 > S2.
+
+int procedure strncmp (s1, s2, n)
+
+char	s1[ARB], s2[ARB]		# strings to be compared
+int	n				# number of chars to compare
+int	i
+
+begin
+	do i = 1, n
+	    if (s1[i] != s2[i])
+		return (s1[i] - s2[i])
+	    else if (s1[i] == EOS)
+		return (0)
+
+	return (0)
+end
diff --git a/sys/fmtio/strne.x b/sys/fmtio/strne.x
new file mode 100644
index 00000000..ee95d3fe
--- /dev/null
+++ b/sys/fmtio/strne.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRNE -- Compare two strings for inequality.
+
+bool procedure strne (s1, s2)
+
+char	s1[ARB], s2[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (s1[ip] == EOS)
+		return (s2[ip] != EOS)
+	    else if (s1[ip] != s2[ip])
+		return (true)
+end
diff --git a/sys/fmtio/strsearch.x b/sys/fmtio/strsearch.x
new file mode 100644
index 00000000..e3006ed8
--- /dev/null
+++ b/sys/fmtio/strsearch.x
@@ -0,0 +1,55 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRSEARCH -- Search a string for a substring.  This is the simplest and
+# fastest member of the pattern matching family.  A significant increase in
+# efficiency will result if this procedure is used to search for substrings
+# that do not use any metacharacters.
+
+int procedure strsearch (str, patstr)
+
+char	str[ARB]		# string to be searched
+char	patstr[ARB]		# substring to search for
+
+int	first_char, ch
+int	ip, patlen
+bool	strse1()
+
+begin
+	# The null pattern matches any string.
+	if (patstr[1] == EOS)
+	    return (1)
+
+	first_char = patstr[1]
+
+	do ip = 1, ARB {
+	    ch = str[ip]
+	    if (ch == EOS)
+		break
+	    if (ch == first_char)
+		if (strse1 (str[ip], patstr, patlen))
+		    return (ip + patlen)
+	}
+
+	return (0)
+end
+
+
+# STRSE1 -- Internal routine which compares a substring of the first string
+# with the pattern string.  STREQ cannot be used because it does not give a
+# match unless the two strings have the same length.
+
+bool procedure strse1 (str, patstr, patlen)
+
+char	str[ARB]
+char	patstr[ARB]
+int	patlen
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (patstr[ip] == EOS || str[ip] != patstr[ip])
+		break
+
+	patlen = ip - 1
+	return (patstr[ip] == EOS)
+end
diff --git a/sys/fmtio/strsrt.x b/sys/fmtio/strsrt.x
new file mode 100644
index 00000000..67318f01
--- /dev/null
+++ b/sys/fmtio/strsrt.x
@@ -0,0 +1,73 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+define	LOGPTR	20		# log2(maxpts)  (1e6)
+
+# STRSRT -- Sort a list of strings, given an array of indices pointing into a
+# string buffer (e.g., sbuf=1 is Memc).  The sort is performed by permutation
+# of the index array.
+
+procedure strsrt (x, sb, nstr)
+
+int	x[ARB]			# array of string pointers or indices
+char	sb[ARB]			# string buffer
+int	nstr			# number of strings
+
+int	i, j, k, p, temp
+int	lv[LOGPTR], uv[LOGPTR], pivot
+define	swap {temp=$1;$1=$2;$2=temp}
+int	strcmp()
+
+begin
+	lv[1] = 1
+	uv[1] = nstr
+	p = 1
+
+	while (p > 0) {
+	    if (lv[p] >= uv[p])			# only one elem in this subset
+		p = p - 1			# pop stack
+	    else {
+		# Dummy do-loop to trigger optimizer.
+		do p = p, ARB {
+		    i = lv[p] - 1
+		    j = uv[p]
+
+		    # Select as the pivot the element at the middle of the
+		    # subfile; move it to the end of the range so that the
+		    # for loops below do not have to skip over it.  Selecting
+		    # a pivot near the center of the subfile helps prevent
+		    # quadratic behavior when sorting an already sorted array.
+
+		    k = (lv[p] + uv[p]) / 2
+		    swap (x[j], x[k])
+		    pivot = x[j]
+
+		    while (i < j) {
+			for (i=i+1;  strcmp (sb[x[i]], sb[pivot]) < 0;  i=i+1)
+			    ;
+			for (j=j-1;  j > i;  j=j-1)
+			    if (strcmp (sb[x[j]], sb[pivot]) <= 0)
+				break
+			if (i < j)		# out of order pair
+			    swap (x[i], x[j])	# interchange elements
+		    }
+
+		    j = uv[p]			# move pivot to position i
+		    swap (x[i], x[j])		# interchange elements
+
+		    if (i-lv[p] < uv[p] - i) {	# stack so shorter done first
+			lv[p+1] = lv[p]
+			uv[p+1] = i - 1
+			lv[p] = i + 1
+		    } else {
+			lv[p+1] = i + 1
+			uv[p+1] = uv[p]
+			uv[p] = i - 1
+		    }
+
+		    break
+		}
+
+		p = p + 1			# push onto stack
+	    }
+	}
+end
diff --git a/sys/fmtio/strtbl.x b/sys/fmtio/strtbl.x
new file mode 100644
index 00000000..7ec0205d
--- /dev/null
+++ b/sys/fmtio/strtbl.x
@@ -0,0 +1,81 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# STRTBL -- Print a list of strings on the named file.  If NCOL is zero,
+# the maximum number of columns is calculated based on the maximum
+# string length.  If NCOL is nonzero, it is taken to be the maximum
+# number of columns (the actual number may be less, depending on the
+# maximum string length).  FIRST_COL and LAST_COL define where on the
+# page the table will be placed.
+
+procedure strtbl (fd, buf, strp, nstr, first_col, last_col, maxch, ncol)
+
+int	fd			# output file
+char	buf[ARB]		# buffer containing the strings
+int	strp[ARB]		# array of string pointers
+int	nstr			# number of strings
+int	first_col, last_col	# where to place table on a line
+int	maxch			# maximum chars to print from a string
+int	ncol			# desired number of columns (0 to autoscale)
+
+pointer	sp, obuf, op
+int	row, i, j, p, nspaces, maxlen, colwidth, numcol, numrow, str
+int	strlen()
+
+begin
+	call smark (sp)
+	call salloc (obuf, last_col + 1, TY_CHAR)
+
+	maxlen = 0
+	do i = 1, nstr
+	    maxlen = max (maxlen, strlen(buf[strp[i]]))
+	if (maxch > 0)
+	    maxlen = min (maxch, maxlen)
+	numcol = max (1, (last_col - first_col + 1) / (maxlen + 2))
+
+	if (ncol > 0)
+	    numcol = min (numcol, ncol)
+	colwidth = (last_col - first_col + 1) / numcol
+	numrow = (nstr + numcol-1) / numcol 
+
+	# For each row in the table:
+	do row = 1, numrow {
+	    op = obuf
+
+	    # Space to the first column.
+	    do i = 2, first_col {
+		Memc[op] = ' '
+		op = op + 1
+	    }
+
+	    # For each string in the row:
+	    do i = 1, numcol {
+		str = row + (i-1) * numrow
+		if (str > nstr)
+		    next
+		p = strp[str]
+
+		# Output the string.
+		for (j=0;  buf[p+j] != EOS && j < maxlen;  j=j+1) {
+		    Memc[op] = buf[p+j]
+		    op = op + 1
+		}
+
+		# Advance to the next column.
+		if (i < numcol) {
+		    nspaces = max (2, colwidth - j)
+		    for (j=1;  j <= nspaces;  j=j+1) {
+			Memc[op] = ' '
+			op = op + 1
+		    }
+		}
+	    }
+
+	    # Terminate this row of the table.
+	    Memc[op] = '\n'
+	    op = op + 1
+	    Memc[op] = EOS
+	    call putline (fd, Memc[obuf])
+	}
+
+	call sfree (sp)
+end
diff --git a/sys/fmtio/strupr.x b/sys/fmtio/strupr.x
new file mode 100644
index 00000000..6e80108c
--- /dev/null
+++ b/sys/fmtio/strupr.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# STRUPR -- Convert string to upper case.
+
+procedure strupr (str)
+
+char	str[ARB]
+int	ip
+
+begin
+	do ip = 1, ARB
+	    if (str[ip] == EOS)
+		return
+	    else if (IS_LOWER (str[ip]))
+		str[ip] = TO_UPPER (str[ip])
+end
diff --git a/sys/fmtio/tokdata.inc b/sys/fmtio/tokdata.inc
new file mode 100644
index 00000000..ceb7c090
--- /dev/null
+++ b/sys/fmtio/tokdata.inc
@@ -0,0 +1,32 @@
+# TOKDATA.INC -- Character classes for ctotok.x.
+# identifier=1, number=2, operator=3, punctuation=4, string=5, unknown=8
+
+#				  !   "   #   $   %   &   '   (   )   *
+data	(class(i),i= 1,10)	/ 3,  5,  3,  1,  3,  3,  5,  4,  4,  3/
+
+#				  +   ,   -   .   /   0   1   2   3   4
+data	(class(i),i=11,20)	/ 3,  4,  3,  1,  3,  1,  1,  1,  1,  1/
+
+#				  5   6   7   8   9   :   ;   <   =   >
+data	(class(i),i=21,30)	/ 1,  1,  1,  1,  1,  4,  4,  3,  3,  3/
+
+#				  ?   @   A   B   C   D   E   F   G   H
+data	(class(i),i=31,40)	/ 3,  3,  1,  1,  1,  1,  1,  1,  1,  1/
+
+#				  I   J   K   L   M   N   O   P   Q   R
+data	(class(i),i=41,50)	/ 1,  1,  1,  1,  1,  1,  1,  1,  1,  1/
+
+#				  S   T   U   V   W   X   Y   Z   [   \
+data	(class(i),i=51,60)	/ 1,  1,  1,  1,  1,  1,  1,  1,  4,  4/
+
+#				  ]   ^   _   `   a   b   c   d   e   f
+data	(class(i),i=61,70)	/ 4,  3,  1,  3,  1,  1,  1,  1,  1,  1/
+
+#				  g   h   i   j   k   l   m   n   o   p
+data	(class(i),i=71,80)	/ 1,  1,  1,  1,  1,  1,  1,  1,  1,  1/
+
+#				  q   r   s   t   u   v   w   x   y   z
+data	(class(i),i=81,90)	/ 1,  1,  1,  1,  1,  1,  1,  1,  1,  1/
+
+#				  {   |   }   ~  DEL
+data	(class(i),i=91,96)	/ 4,  3,  4,  3,  8, EOS/
diff --git a/sys/fmtio/xevgettok.x b/sys/fmtio/xevgettok.x
new file mode 100644
index 00000000..34e6c37e
--- /dev/null
+++ b/sys/fmtio/xevgettok.x
@@ -0,0 +1,208 @@
+include	<lexnum.h>
+include	<ctype.h>
+include	<evexpr.h>
+
+
+
+# Parse definitions.
+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  AND             275
+define  OR              276
+define  NOT             277
+define  AT              278
+define  GE              279
+define  UMINUS          280
+
+
+# XEV_GETTOK -- Lexical analyzer for EVEXPR.  Returns the token code as the
+# function value.  If the token is an operand (identifier or constant) the
+# operand value is returned in OUT.
+
+int procedure xev_gettok (ip, out)
+
+pointer	ip			# pointer into input string (expression)
+pointer	out			# pointer to yacc YYLVAL token value operand
+
+char	ch
+long	lval
+double	dval
+pointer	ip_start
+int	nchars, token, junk
+int	stridx(), lexnum(), gctod(), gctol()
+define	ident_ 91
+
+begin
+	while (IS_WHITE(Memc[ip]))
+	    ip = ip + 1
+
+	ch = Memc[ip]
+	switch (ch) {
+	case 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',      'J', 'K', 'L', 'M',
+	     'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 
+	     'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
+	     'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z': 
+
+	    # Return an identifier.
+ident_
+	    ip_start = ip
+	    while (IS_ALNUM(ch) || stridx (ch, "_.$@#%&;[]\\^{}~") > 0) {
+		ip = ip + 1
+		ch = Memc[ip]
+	    }
+
+	    nchars = ip - ip_start
+	    call xev_initop (out, nchars, TY_CHAR)
+	    call strcpy (Memc[ip_start], O_VALC(out), nchars)
+
+	    return (IDENTIFIER)
+
+	case 'I', '.', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
+	    # Return a numeric constant.  The character I vectors here so
+	    # that we can check for INDEF, a legal number.
+
+	    token = lexnum (Memc, ip, nchars)
+	    switch (token) {
+	    case LEX_OCTAL:
+		junk = gctol (Memc, ip, lval, 8)
+		call xev_initop (out, 0, TY_INT)
+		O_VALI(out) = lval
+	    case LEX_DECIMAL:
+		junk = gctol (Memc, ip, lval, 10)
+		call xev_initop (out, 0, TY_INT)
+		O_VALI(out) = lval
+	    case LEX_HEX:
+		junk = gctol (Memc, ip, lval, 16)
+		call xev_initop (out, 0, TY_INT)
+		O_VALI(out) = lval
+	    case LEX_REAL:
+		junk = gctod (Memc, ip, dval)
+		call xev_initop (out, 0, TY_REAL)
+		if (IS_INDEFD (dval))
+		    O_VALR(out) = INDEFR
+		else
+		    O_VALR(out) = dval
+	    default:
+		goto ident_
+	    }
+
+	    return (CONSTANT)
+
+	case '\'', '"':
+	    # Return a string constant.
+
+	    ip_start = ip + 1
+	    for (ip=ip+1;  Memc[ip] != ch && Memc[ip] != EOS;  ip=ip+1)
+		;
+
+	    nchars = ip - ip_start
+	    if (Memc[ip] == EOS)
+		call xev_error ("missing closing quote in string constant")
+	    else
+		ip = ip + 1
+
+	    call xev_initop (out, nchars, TY_CHAR)
+	    call strcpy (Memc[ip_start], O_VALC(out), nchars)
+
+	    return (CONSTANT)
+
+	case '+':
+	    token = PLUS
+	case '-':
+	    token = MINUS
+	case '*':
+	    if (Memc[ip+1] == '*') {
+		ip = ip + 1
+		token = EXPON
+	    } else
+		token = STAR
+	case '/':
+	    if (Memc[ip+1] == '/') {
+		ip = ip + 1
+		token = CONCAT
+	    } else
+		token = SLASH
+
+	case '?':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = SE
+	    } else
+		token = QUEST
+
+	case ':':
+	    token = COLON
+
+	case '@':
+	    token = AT
+
+	case '<':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = LE
+	    } else
+		token = LT
+	case '>':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = GE
+	    } else
+		token = GT
+	case '!':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = NE
+	    } else
+		token = NOT
+	case '=':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = EQ
+	    } else
+		token = EQ
+	case '&':
+	    if (Memc[ip+1] == '&') {
+		ip = ip + 1
+		token = AND
+	    } else
+		token = AND
+	case '|':
+	    if (Memc[ip+1] == '|') {
+		ip = ip + 1
+		token = OR
+	    } else
+		token = OR
+
+	case '(', ')', ',':
+	    token = ch
+
+	default:
+	    if (ch == '\n')
+		token = NEWLINE
+	    else if (ch == EOS)
+		token = YYEOS
+	    else {
+		# Anything we don't understand is assumed to be an identifier.
+		goto ident_
+	    }
+	}
+
+	ip = ip + 1
+	return (token)
+end
diff --git a/sys/fmtio/xtoc.x b/sys/fmtio/xtoc.x
new file mode 100644
index 00000000..8315b4cd
--- /dev/null
+++ b/sys/fmtio/xtoc.x
@@ -0,0 +1,39 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# XTOC -- Encode a complex number as a character string in a field width of
+# at most WIDTH characters.
+
+int procedure xtoc (xval, outstr, maxch, decpl, fmt, width)
+
+complex	xval			# value to be formatted
+char	outstr[ARB]		# output string
+int	fmt			# format encoding (f,e,etc.)
+int	maxch			# max chars out
+int	decpl			# precision
+int	width			# field width
+
+int	op, dtoc()
+double	real_part, imag_part
+define	output {outstr[op]=$1;op=op+1;if(op>maxch)goto overflow_}
+define	overflow_ 91
+
+begin
+	if (IS_INDEFX (xval)) {
+	    real_part = INDEFD
+	    imag_part = INDEFD
+	} else {
+	    real_part = real (xval)
+	    imag_part = aimag (xval)
+	}
+
+	op = 1
+	output ('(')
+	op = op + dtoc (real_part, outstr[op], maxch-op+1, decpl, fmt, width)
+	output (',')
+	op = op + dtoc (imag_part, outstr[op], maxch-op+1, decpl, fmt, width)
+	output (')')
+
+overflow_
+	outstr[op] = EOS
+	return (op-1)
+end
diff --git a/sys/fmtio/xvvgettok.x b/sys/fmtio/xvvgettok.x
new file mode 100644
index 00000000..f2a05977
--- /dev/null
+++ b/sys/fmtio/xvvgettok.x
@@ -0,0 +1,234 @@
+include	<lexnum.h>
+include	<ctype.h>
+include	<mach.h>
+include	<math.h>
+include	<evvexpr.h>
+
+
+# Parser definitions.
+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
+
+
+# XVV_GETTOK -- Lexical analyzer for EVVEXPR.  Returns the token code as the
+# function value.  If the token is an operand (identifier or constant) the
+# operand value is returned in OUT.
+
+int procedure xvv_gettok (ip, out)
+
+pointer	ip			#I pointer into input string (expression)
+pointer	out			#I pointer to yacc YYLVAL token value operand
+
+char	ch
+long	lval
+double	dval
+pointer	ip_start
+char	numbuf[MAX_DIGITS]
+int	nchars, token, junk, dtype
+int	stridx(), stridxs(), lexnum(), gctod(), gctol()
+define	ident_ 91
+
+begin
+	while (IS_WHITE(Memc[ip]))
+	    ip = ip + 1
+
+	ch = Memc[ip]
+	switch (ch) {
+	case 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',      'J', 'K', 'L', 'M',
+	     'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 
+	     'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
+	     'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z': 
+
+	    # Return an identifier.
+ident_
+	    ip_start = ip
+	    while (IS_ALNUM(ch) || stridx (ch, "_.$@#%&;[]\\^{}~") > 0) {
+		ip = ip + 1
+		ch = Memc[ip]
+	    }
+
+	    nchars = ip - ip_start
+	    call xvv_initop (out, nchars, TY_CHAR)
+	    call strcpy (Memc[ip_start], O_VALC(out), nchars)
+
+	    return (IDENTIFIER)
+
+	case 'I', '.', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
+	    # Return a numeric constant.  The character I vectors here so
+	    # that we can check for INDEF, a legal number.
+
+	    token = lexnum (Memc, ip, nchars)
+	    switch (token) {
+	    case LEX_OCTAL:
+		junk = gctol (Memc, ip, lval, 8)
+		call xvv_initop (out, 0, TY_INT)
+		O_VALI(out) = lval
+	    case LEX_DECIMAL:
+		junk = gctol (Memc, ip, lval, 10)
+		call xvv_initop (out, 0, TY_INT)
+		O_VALI(out) = lval
+	    case LEX_HEX:
+		junk = gctol (Memc, ip, lval, 16)
+		call xvv_initop (out, 0, TY_INT)
+		O_VALI(out) = lval
+
+	    case LEX_REAL:
+		ip_start = ip
+		nchars = gctod (Memc, ip, dval)
+		call strcpy (Memc[ip], numbuf, min(nchars,MAX_DIGITS))
+
+		dtype = TY_REAL
+		if (stridxs ("dD", numbuf) > 0 || nchars > NDIGITS_RP+3)
+		    dtype = TY_DOUBLE
+
+		call xvv_initop (out, 0, dtype)
+		if (dtype == TY_REAL) {
+		    if (IS_INDEFD (dval))
+			O_VALR(out) = INDEFR
+		    else
+			O_VALR(out) = dval
+		} else {
+		    if (IS_INDEFD (dval))
+			O_VALD(out) = INDEFD
+		    else
+			O_VALD(out) = dval
+		}
+	    default:
+		goto ident_
+	    }
+
+	    return (CONSTANT)
+
+	case '\'', '"':
+	    # Return a string constant.
+
+	    ip_start = ip + 1
+	    for (ip=ip+1;  Memc[ip] != ch && Memc[ip] != EOS;  ip=ip+1)
+		;
+
+	    nchars = ip - ip_start
+	    if (Memc[ip] == EOS)
+		call xvv_error ("missing closing quote in string constant")
+	    else
+		ip = ip + 1
+
+	    call xvv_initop (out, nchars, TY_CHAR)
+	    call strcpy (Memc[ip_start], O_VALC(out), nchars)
+
+	    return (CONSTANT)
+
+	case '+':
+	    token = PLUS
+	case '-':
+	    token = MINUS
+	case '*':
+	    if (Memc[ip+1] == '*') {
+		ip = ip + 1
+		token = EXPON
+	    } else
+		token = STAR
+	case '/':
+	    if (Memc[ip+1] == '/') {
+		ip = ip + 1
+		token = CONCAT
+	    } else
+		token = SLASH
+
+	case '?':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = SE
+	    } else
+		token = QUEST
+
+	case ':':
+	    token = COLON
+
+	case '@':
+	    token = AT
+
+	case '<':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = LE
+	    } else
+		token = LT
+	case '>':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = GE
+	    } else
+		token = GT
+	case '!':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = NE
+	    } else
+		token = LNOT
+	case '=':
+	    if (Memc[ip+1] == '=') {
+		ip = ip + 1
+		token = EQ
+	    } else
+		token = EQ
+	case '&':
+	    if (Memc[ip+1] == '&') {
+		ip = ip + 1
+		token = LAND
+	    } else
+		token = BAND
+	case '|':
+	    if (Memc[ip+1] == '|') {
+		ip = ip + 1
+		token = LOR
+	    } else
+		token = BOR
+
+	case '^':
+	    token = BXOR
+	case '~':
+	    token = BNOT
+
+	case '(', ')', ',':
+	    token = ch
+
+	default:
+	    if (ch == '\n')
+		token = NEWLINE
+	    else if (ch == EOS)
+		token = YYEOS
+	    else {
+		# Anything we don't understand is assumed to be an identifier.
+		goto ident_
+	    }
+	}
+
+	ip = ip + 1
+	return (token)
+end
diff --git a/sys/fmtio/zzdebug.x b/sys/fmtio/zzdebug.x
new file mode 100644
index 00000000..3729a1ff
--- /dev/null
+++ b/sys/fmtio/zzdebug.x
@@ -0,0 +1,319 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<evexpr.h>
+include	<lexnum.h>
+
+task	ev	= t_ev,
+	lex	= t_lex,
+	eq	= t_eq,
+	ne	= t_ne,
+	lt	= t_lt,
+	le	= t_le,
+	gt	= t_gt,
+	ge	= t_ge,
+	cmp	= t_cmp,
+	ncmp	= t_ncmp,
+	mat	= t_mat,
+	srch	= t_srch,
+	ctowrd	= t_ctowrd
+
+
+# EV -- Text EVEXPR.
+
+procedure t_ev
+
+char	expr[SZ_LINE]
+pointer	o, evexpr()
+int	clglstr()
+
+begin
+	while (clglstr ("expr", expr, SZ_LINE) != EOF) {
+	    o = evexpr (expr, 0, 0)
+
+	    switch (O_TYPE(o)) {
+	    case TY_BOOL:
+		call printf ("%b = %s\n")
+		    call pargb (O_VALB(o))
+		    call pargstr (expr)
+
+	    case TY_CHAR:
+		call printf ("%s = %s\n")
+		    call pargstr (O_VALC(o))
+		    call pargstr (expr)
+
+	    case TY_INT:
+		call printf ("%d = %s\n")
+		    call pargi (O_VALI(o))
+		    call pargstr (expr)
+
+	    case TY_REAL:
+		call printf ("%g = %s\n")
+		    call pargr (O_VALR(o))
+		    call pargstr (expr)
+
+	    default:
+		call error (1, "expression datatype unknown")
+	    }
+	} 
+
+	call printf ("\n")
+end
+
+
+# LEX -- Test LEXNUM.
+
+procedure t_lex()
+
+int	ip, nchars, toktype
+char	token[SZ_FNAME]
+int	lexnum(), strlen()
+
+begin
+	repeat {
+	    call clgstr ("token", token, SZ_FNAME)
+	    if (strlen (token) == 0)
+		break
+
+	    ip = 1
+	    toktype = lexnum (token, ip, nchars)
+
+	    call printf ("tokchars=%d, type = %s\n")
+		call pargi (nchars)
+
+		switch (toktype) {
+		case LEX_OCTAL:
+		    call pargstr ("octal")
+		case LEX_DECIMAL:
+		    call pargstr ("decimal")
+		case LEX_HEX:
+		    call pargstr ("hex")
+		case LEX_REAL:
+		    call pargstr ("real")
+		case LEX_NONNUM:
+		    call pargstr ("nonnumeric")
+		default:
+		    call pargstr ("unknown")
+		}
+	}
+end
+
+
+# EQ -- Test string equals.
+
+procedure t_eq()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+bool	streq()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("%s == %s: %b\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargb (streq (s1, s2))
+	    call flush (STDOUT)
+	}
+end
+
+
+# NE -- Test string not equals.
+
+procedure t_ne()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+bool	strne()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("%s != %s: %b\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargb (strne (s1, s2))
+	    call flush (STDOUT)
+	}
+end
+
+
+# LT -- Test string less than.
+
+procedure t_lt()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+bool	strlt()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("%s < %s: %b\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargb (strlt (s1, s2))
+	    call flush (STDOUT)
+	}
+end
+
+
+# LE -- Test string less than or equals.
+
+procedure t_le()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+bool	strle()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("%s <= %s: %b\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargb (strle (s1, s2))
+	    call flush (STDOUT)
+	}
+end
+
+
+# GT -- Test string greater than.
+
+procedure t_gt()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+bool	strgt()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("%s > %s: %b\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargb (strgt (s1, s2))
+	    call flush (STDOUT)
+	}
+end
+
+
+# GE -- Test string greater than or equals.
+
+procedure t_ge()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+bool	strge()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("%s >= %s: %b\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargb (strge (s1, s2))
+	    call flush (STDOUT)
+	}
+end
+
+
+# CMP -- Test string compare.
+
+procedure t_cmp()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+int	strcmp()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("compare %s, %s: %d\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargi (strcmp (s1, s2))
+	    call flush (STDOUT)
+	}
+end
+
+
+# NCMP -- Test counted string compare.
+
+procedure t_ncmp()
+
+char	s1[SZ_FNAME], s2[SZ_FNAME]
+int	strncmp(), clgeti()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("s2", s2, SZ_FNAME)
+	    call printf ("compare %s, %s: %d\n")
+		call pargstr (s1)
+		call pargstr (s2)
+		call pargi (strncmp (s1, s2, clgeti("nchars")))
+	    call flush (STDOUT)
+	}
+end
+
+
+# MAT -- Test string match.
+
+procedure t_mat()
+
+char	s1[SZ_FNAME], pat[SZ_FNAME]
+int	strmatch()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("pat", pat, SZ_FNAME)
+	    call printf ("match %s, pat=%s: %d\n")
+		call pargstr (s1)
+		call pargstr (pat)
+		call pargi (strmatch (s1, pat))
+	    call flush (STDOUT)
+	}
+end
+
+
+# SRCH -- Test string search.
+
+procedure t_srch()
+
+char	s1[SZ_FNAME], pat[SZ_FNAME]
+int	strsearch()
+
+begin
+	repeat {
+	    call clgstr ("s1", s1, SZ_FNAME)
+	    call clgstr ("pat", pat, SZ_FNAME)
+	    call printf ("search %s, pat=%s: %d\n")
+		call pargstr (s1)
+		call pargstr (pat)
+		call pargi (strsearch (s1, pat))
+	    call flush (STDOUT)
+	}
+end
+
+
+# CTOWRD -- Test ctowrd.
+
+procedure t_ctowrd()
+
+char	buf1[SZ_LINE], buf2[SZ_LINE]
+int	n, ip, ctowrd(), getline()
+
+begin
+	while (getline (STDIN, buf1) != EOF) {
+	    ip = 1
+	    repeat {
+		buf2[1] = EOS
+		n = ctowrd (buf1, ip, buf2, SZ_LINE)
+		call printf ("n=%d, token=%s\n")
+		    call pargi (n)
+		    call pargstr (buf2)
+	    } until (n <= 0)
+	}
+end