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

include <mach.h>
include "../qpex.h"

# QPEX_CODEGEN -- Generate interpreter metacode to evaluate the given
# expression.  The new code is appended to the current compiled program,
# adding additional constraints which a data event will have to meet to
# pass the filter.

int procedure qpex_codegen$t (ex, atname, assignop, expr, offset, dtype)

pointer ex			#I qpex descriptor
char	atname[ARB]		#I attribute name (for expr regeneration)
char	assignop[ARB]		#I "=" or "+=" (for expr regeneration)
char	expr[ARB]		#I expression to be compiled
int	offset			#I typed offset of referenced attribute
int	dtype			#I datatype of referenced attribute

int	nbins, bin, xp
pointer	lt, lut, lutx, pb
PIXEL	x1, x2, xmin, xmax
int	xlen, nranges, n_nranges, level, opcode, ip, i
pointer	pb_save, db_save, xs_buf, xe_buf, xs, xe, n_xs, n_xe, et, prev

PIXEL	sv_xs[MAX_LEVELS], sv_xe[MAX_LEVELS]
pointer	sv_lt[MAX_LEVELS], sv_lut[MAX_LEVELS], sv_lutx[MAX_LEVELS]
int	sv_xp[MAX_LEVELS], sv_nranges[MAX_LEVELS], sv_bin[MAX_LEVELS]
int	sv_nbins[MAX_LEVELS]

$if (datatype == d)
double	xoffset, xscale
double	sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS]
int	d_x1, d_x2
int	qpex_refd()
$else
PIXEL	d_x1, d_x2
real	xoffset, xscale
real	sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS]
$endif

$if (datatype == rd)
bool	fp_equal$t()
$else
define	fp_equal$t($1==$2)
$endif

$if (datatype == i)
bool	complement
int	maskval
int	qp_ctoi()
$endif

int	qpex_parse$t()
int	stridxs(), btoi(), qpex_sublist$t()
pointer	qpex_dballoc(), qpex_dbpstr(), qpex_pbpos()
errchk	qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parse$t

string	qpexwarn "QPEX Warning"
define	error_ 91
define	next_  92
define	null_  93
define	resume_ 94
define	bbmask_ 95
define	continue_ 96
define	XS Mem$t[xs+($1)-1]
define	XE Mem$t[xe+($1)-1]

begin
	pb = EX_PB(ex)

	# Save the program state in case we have to abort.
	call qpex_mark (ex, pb_save, db_save)

	# Allocate and initialize a new expression term descriptor, linking
	# it onto the tail of the ETTERMs list.

	et = qpex_dballoc (ex, LEN_ETDES, TY_STRUCT)

	ET_ATTTYPE(et)	= dtype
	ET_ATTOFF(et)	= offset
	ET_ATNAME(et)	= qpex_dbpstr (ex, atname)
	ET_ASSIGNOP(et)	= qpex_dbpstr (ex, assignop)
	ET_EXPRTEXT(et) = qpex_dbpstr (ex, expr)
	ET_PROGPTR(et)	= qpex_pbpos (ex)
	ET_DELETED(et)	= NO

	prev = EX_ETTAIL(ex)
	if (prev != NULL)
	    ET_NEXT(prev) = et
	ET_NEXT(et) = NULL
	EX_ETTAIL(ex) = et
	if (EX_ETHEAD(ex) == NULL)
	    EX_ETHEAD(ex) = et

	ip = stridxs ("%", expr)
	$if (datatype == i)
	    # Attempt to compile a bitmask test if `%' is found in the
	    # expression.  Since bitmasks cannot be mixed with range list
	    # expressions, this case is handled separately.

	    if (ip > 0) {
		complement = false
		level = 0

		# Parse expression (very limited for this case).
		for (ip=1;  expr[ip] != EOS;  ip=ip+1) {
		    switch (expr[ip]) {
		    case '!':
			complement = !complement
		    case '(', '[':
			level = level + 1
		    case ')', ']':
			level = level - 1
		    case '%':
			ip = ip + 1
			if (qp_ctoi (expr, ip, maskval) < 0)
			    goto bbmask_
			else
			    ip = ip - 1
		    default:
			goto bbmask_
		    }
		}

		# Verify paren level, handle errors.
		if (level != 0) {
bbmask_		    call eprintf ("%s: bad bitmask expression `%s'\n")
			call pargstr (qpexwarn)
			call pargstr (expr)
			goto error_
		}

		# Compile the bitmask test.
		if (complement)
		    maskval = not(maskval)
		if (dtype == TY_SHORT)
		    call qpex_pbpin (ex, BTTXS, offset, maskval, 0)
		else
		    call qpex_pbpin (ex, BTTXI, offset, maskval, 0)

		# Finish setting up the eterm descriptor.
		ET_NINSTR(et)  = 1
		return (OK)
	    }
	$else
	    # Bitmask tests are meaningless for floating point data.
	    if (ip > 0) {
		call eprintf ("%s: bitmasks not permitted for floating data\n")
		    call pargstr (qpexwarn)
		goto error_
	    }
	$endif

	# Compile a general range list expression.  The basic procedure is
	# to parse the expression to produce an optimized binary range list,
	# then either compile the range list as an explicit series of
	# instructions or as a lookup table, depending upon the number of
	# ranges.

	xlen = DEF_XLEN
	call malloc (xs_buf, xlen, TY_PIXEL)
	call malloc (xe_buf, xlen, TY_PIXEL)

	# Convert expr to a binary range list and set up the initial context.
	# Ensure that the range list buffers are large enough to hold any
	# sublists extracted during compilation.

	nranges = qpex_parse$t (expr, xs_buf, xe_buf, xlen)
	if (xlen < nranges * 2) {
	    xlen = nranges * 2
	    call realloc (xs_buf, xlen, TY_PIXEL)
	    call realloc (xe_buf, xlen, TY_PIXEL)
	}

	xs = xs_buf
	xe = xe_buf
	level = 0

	repeat {
next_
	    # Compile a new range list (or sublist).
	    if (nranges <= 0) {
		# This shouldn't happen.
null_		call eprintf ("%s: null range list\n")
		    call pargstr (qpexwarn)
		call qpex_pbpin (ex, PASS, 0, 0, 0)

	    } else if (nranges == 1) {
		# Output an instruction to load the data, perform the range
		# test, and conditionally exit all in a single instruction.

		x1 = XS(1);  x2 = XE(1)
		$if (datatype == d)
		    d_x1 = qpex_refd (ex, x1)
		    d_x2 = qpex_refd (ex, x2)
		$else
		    d_x1 = x1
		    d_x2 = x2
		$endif

		if (dtype == TY_SHORT) {
		    if (IS_LEFT$T(x1) && IS_RIGHT$T(x2))
			; # pass everything (no tests)
		    else if (IS_LEFT$T(x1))
			call qpex_pbpin (ex, LEQXS, offset, d_x2, 0)
		    else if (IS_RIGHT$T(x2))
			call qpex_pbpin (ex, GEQXS, offset, d_x1, 0)
		    else if (fp_equal$t (x1, x2))
			call qpex_pbpin (ex, EQLXS, offset, d_x1, d_x2)
		    else
			call qpex_pbpin (ex, RNGXS, offset, d_x1, d_x2)
		} else {
		    if (IS_LEFT$T(x1) && IS_RIGHT$T(x2))
			; # pass everything (no tests)
		    else if (IS_LEFT$T(x1))
			call qpex_pbpin (ex, LEQX$T, offset, d_x2, 0)
		    else if (IS_RIGHT$T(x2))
			call qpex_pbpin (ex, GEQX$T, offset, d_x1, 0)
		    else if (fp_equal$t (x1, x2))
			call qpex_pbpin (ex, EQLX$T, offset, d_x1, d_x2)
		    else
			call qpex_pbpin (ex, RNGX$T, offset, d_x1, d_x2)
		}

	    } else if (nranges < EX_LUTMINRANGES(ex)) {
		# If the number of ranges to be tested for the data is small,
		# compile explicit code to perform the range tests directly.
		# Otherwise skip forward and compile a lookup table instead.
		# In either case, the function of the instructions compiled
		# is to test the data loaded into the register above, setting
		# the value of PASS to true if the data lies in any of the
		# indicated ranges.

		# Check for !X, which is indicated in range list form by a
		# two element list bracketing the X on each side.

		if (nranges == 2)
		    if (IS_LEFT$T(XS(1)) && IS_RIGHT$T(XE(2)))
		    $if (datatype == si)
			if (XE(1)+1 == XS(2)-1) {
			    if (dtype == TY_SHORT)
				opcode = NEQXS
			    else
				opcode = NEQXI
			    call qpex_pbpin (ex, opcode, offset, XE(1)+1, 0)
			    goto resume_
			}
		    $else $if (datatype == r)
			if (fp_equal$t (XE(1), XS(2))) {
			    call qpex_pbpin (ex, NEQX$T, offset, XE(1), 0)
			    goto resume_
			}
		    $else
			if (fp_equal$t (XE(1), XS(2))) {
			    call qpex_pbpin (ex, NEQX$T, offset,
				qpex_refd(ex,XE(1)), 0)
			    goto resume_
			}
		    $endif $endif

		# If at level zero, output instruction to load data into
		# register and initialize PASS to false.  Don't bother if
		# compiling a subprogram, as these operations will already
		# have been performed by the caller.

		if (level == 0) {
		    $if (datatype == i)
			if (dtype == TY_SHORT)
			    opcode = LDSI
			else
			    opcode = LDII
		    $else
			opcode = LD$T$T
		    $endif
		    call qpex_pbpin (ex, opcode, offset, 0, 0)
		}

		# Compile a series of equality or range tests.
		do i = 1, nranges {
		    x1 = XS(i);  x2 = XE(i)
		    $if (datatype == d)
			d_x1 = qpex_refd (ex, x1)
			d_x2 = qpex_refd (ex, x2)
		    $else
			d_x1 = x1
			d_x2 = x2
		    $endif

		    if (IS_LEFT$T(x1))
			call qpex_pbpin (ex, LEQ$T, d_x2, 0, 0)
		    else if (IS_RIGHT$T(x2))
			call qpex_pbpin (ex, GEQ$T, d_x1, 0, 0)
		    else if (fp_equal$t (x1, x2))
			call qpex_pbpin (ex, EQL$T, d_x1, d_x2, 0)
		    else
			call qpex_pbpin (ex, RNG$T, d_x1, d_x2, 0)
		}

		# Compile a test and exit instruction.
		call qpex_pbpin (ex, XIFF, 0, 0, 0)

	    } else {
		# Compile a lookup table test. Lookup tables may be
		# either compressed or fully resolved.  If compressed
		# (the resolution of the table is less than that of the
		# range data, e.g., for floating point lookup tables) a
		# LUT bin may have as its value, in addition to the
		# usual 0 or 1, the address of an interpreter subprogram
		# to be executed to test data values mapping to that bin.
		# The subprogram pointed to may in turn be another lookup
		# table, hence in the general case a tree of lookup tables
		# and little code segments may be compiled to implement
		# a complex range list test.

		# Get the data range of the lookup table.
		xmin = XS(1)
		if (IS_LEFT$T(xmin))
		    xmin = XE(1)
		xmax = XE(nranges)
		if (IS_RIGHT$T(xmax))
		    xmax = XS(nranges)

		# Get the lookup table size.  Use a fully resolved table
		# if the data is integer and the number of bins required
		# is modest.

		$if (datatype == i)
		    nbins = xmax - xmin + 1
		    if (nbins > EX_MAXFRLUTLEN(ex))
			nbins = min (EX_MAXRRLUTLEN(ex),
			    nranges * EX_LUTSCALE(ex))
		$else
		    nbins = min (EX_MAXRRLUTLEN(ex), nranges * EX_LUTSCALE(ex))
		$endif

		# Determine the mapping from data space to table space.
		xoffset = xmin
		$if (datatype == i)
		    xscale = nbins / (xmax - xmin + 1)
		$else
		    xscale = nbins / (xmax - xmin)
		$endif

		# Allocate and initialize the lookup table descriptor.
		lt = qpex_dballoc (ex, LEN_LTDES, TY_STRUCT)
		call calloc (lut, nbins, TY_SHORT)

		LT_NEXT(lt)	= EX_LTHEAD(ex)
		EX_LTHEAD(ex)	= lt
		LT_TYPE(lt)	= TY_PIXEL
		LT_LUTP(lt)	= lut
		LT_NBINS(lt)	= nbins
		LT_$T0(lt)	= xoffset
		LT_$TS(lt)	= xscale
		LT_LEFT(lt)	= btoi (IS_LEFT$T(XS(1)))
		LT_RIGHT(lt)	= btoi (IS_RIGHT$T(XE(nranges)))

		# Compile the LUTX test instruction.  Save a back pointer
		# to the instruction so that we can edit the jump field in
		# case a subprogram is compiled after the LUTXt.

		lutx = qpex_pbpos (ex)
		if (dtype == TY_SHORT)
		    call qpex_pbpin (ex, LUTXS, offset, lt, 0)
		else
		    call qpex_pbpin (ex, LUTX$T, offset, lt, 0)

		xp = 1
		bin = 1
continue_
		n_xs = xs + nranges
		n_xe = xe + nranges

		# Initialize the lookup table.
		do i = bin, nbins {
		    x1 = (i-1) / xscale + xoffset
		    $if (datatype == i)
			x2 = i / xscale + xoffset - 1
		    $else
			x2 = i / xscale + xoffset
		    $endif

		    # Get sub-rangelist for range x1:x2.
		    n_nranges = qpex_sublist$t (x1, x2,
			Mem$t[xs], Mem$t[xe], nranges, xp,
			Mem$t[n_xs], Mem$t[n_xe])

		    if (n_nranges <= 0) {
			Mems[lut+i-1] = 0

		    } else if (n_nranges == 1 && IS_LEFT$T(Mem$t[n_xs]) &&
			IS_RIGHT$T(Mem$t[n_xe])) {

			Mems[lut+i-1] = 1

		    } else {
			# Compile the sub-rangelist as a subprogram.

			# First set the LUT bin to point to the subprogram.
			# We cannot use the IP directly here since the LUT
			# bins are short integer, so store the offset into
			# the pb instead (guaranteed to be >= 4).

			Mems[lut+i-1] = qpex_pbpos(ex) - pb

			# Push a new context.
			level = level + 1
			if (level > MAX_LEVELS) {
			    call eprintf ("%s: ")
				call pargstr (qpexwarn)
			    call eprintf ("Excessive LUT nesting\n")
			    goto error_
			}

			# Save current LUT compilation context.
			sv_xs[level] = xs
			sv_xe[level] = xe
			sv_xp[level] = xp
			sv_xoffset[level] = xoffset
			sv_xscale[level] = xscale
			sv_nranges[level] = nranges
			sv_lt[level] = lt
			sv_bin[level] = i
			sv_nbins[level] = nbins
			sv_lut[level] = lut
			sv_lutx[level] = lutx

			# Set up context for the new rangelist.
			xs = n_xs
			xe = n_xe
			nranges = n_nranges

			goto next_
		    }
		}

		# Compile a test and exit instruction if the LUT calls any
		# subprograms.

		if (qpex_pbpos(ex) - lutx > LEN_INSTRUCTION)
		    call qpex_pbpin (ex, XIFF, 0, 0, 0)
	    }
resume_
	    # Resume lookup table compilation if exiting due to LUT-bin
	    # subprogram compilation.

	    if (level > 0) {
		# Pop saved context.
		xs = sv_xs[level]
		xe = sv_xe[level]
		xp = sv_xp[level]
		xoffset = sv_xoffset[level]
		xscale = sv_xscale[level]
		nranges = sv_nranges[level]
		lt = sv_lt[level]
		bin = sv_bin[level]
		nbins = sv_nbins[level]
		lut = sv_lut[level]
		lutx = sv_lutx[level]

		# Compile a return from subprogram.
		call qpex_pbpin (ex, RET, 0, 0, 0)

		# Patch up the original LUTX instruction to jump over the
		# subprogram we have just finished compiling.

		IARG3(lutx) = qpex_pbpos (ex)

		# Resume compilation at the next LUT bin.
		bin = bin + 1
		level = level - 1
		goto continue_
	    }
	} until (level <= 0)

	# Finish setting up the eterm descriptor.
	ET_NINSTR(et) = (qpex_pbpos(ex) - ET_PROGPTR(et)) / LEN_INSTRUCTION

	return (OK)
error_
	call qpex_free (ex, pb_save, db_save)
	return (ERR)
end