Repatch (from linux) of OSX IRAF

1 files changed, 362 insertions, 0 deletions

diff --git a/sys/qpoe/qpexeval.x b/sys/qpoe/qpexeval.x
new file mode 100644
index 00000000..5e120296
--- /dev/null
+++ b/sys/qpoe/qpexeval.x
@@ -0,0 +1,362 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+include "qpex.h"
+
+define	RTOL	(EPSILONR * 10.0)	# (only useful for normalized numbers)
+define	DTOL	(EPSILOND * 10.0)
+
+# QPEX_EVALUATE -- Evaluate the compiled event-attribute expression for the
+# given seqeuence of event structs.  Expression evaluation for each event
+# terminates as soon as an attribute test fails.  If all attribute tests
+# succeed (i.e., the full expression is evaluated or the evaluate function
+# runs to completion) then the event pointer is put on the output list O_EV,
+# indicating that the event satisfies the given selection expression.
+# The function value is the number of events which passed the filter.
+# The time required to evaluate an expression depends upon the complexity of
+# the expression to be evaluated, and the fraction of events which fail the
+# test (a fail is determined quicker than a pass - attribute tests likely to
+# fail should appear first in the expression).
+
+int procedure qpex_evaluate (ex, i_ev, o_ev, nev)
+
+pointer ex			#I QPEX descriptor (expression)
+pointer i_ev[nev]		#I array of pointers to event structs
+pointer	o_ev[nev]		#O receives the pointers of the passed events
+int	nev			#I number of input events
+
+int	i0			# integer data register
+real	r0			# real data register
+double	d0			# double data register
+bool	pass			# expression value
+int	npass			# number of events which pass expr
+
+real	rbin
+bool	pv_save[MAX_LEVELS]
+pointer ip_save[MAX_LEVELS]
+pointer lt, ev, ev_i, ev_r, ev_d, ip
+int	level, bin, i, j, v
+
+define	lut_ 91
+define	ret_ 92
+define	ev_s ev
+
+begin
+	npass = 0
+
+	do j = 1, nev {
+	    pass = false
+	    ev = i_ev[j]
+
+	    # Get event struct pointers of various types.
+	    ev_d = (ev - 1) * SZ_SHORT / SZ_DOUBLE + 1
+	    ev_i = (ev - 1) * SZ_SHORT / SZ_INT + 1
+	    ev_r = ev_i
+
+	    # Execute each compiled instruction in sequence until the value
+	    # of the compiled attribute-value expression is known.  The call
+	    # stack level is used to keep track of subroutine calls
+	    # (subroutines are used to evaluate the indeterminate cells of
+	    # compressed lookup tables).
+
+	    # Notes on expression evaluation.
+	    # ---------------------------------
+	    # An expression consists of 1 or more expression terms, all of
+	    # which must pass the event for the event to pass the filter.
+	    #
+	    # An expression term consists of a range list giving a list of
+	    # acceptable values or ranges of values.
+	    #
+	    # The compiled expression consists of a sequence of instruction
+	    # blocks, one for each expression term.  If the event fails to
+	    # pass any expression term (instruction block) then the event
+	    # fails and we are done.  Instruction blocks are of three types:
+	    #
+	    #	1)	Multiple instructions consisting of a load register,
+	    #		any number of register tests, then a XIFF or XIFT
+	    #		test at the end of the block.  PASS is set to false
+	    # 		at the beginning of the block and can be set to true
+	    #		by any register test to pass the event to the next
+	    #		expression term.
+	    #
+	    #   2)	In simple cases the above can all be expressed as a
+	    #		single test-and-exit-if-false instruction.  These are
+	    #		the "X" instructions below.
+	    #
+	    #   3)	The lookup table (LUTX) instruction.  LUTX is like
+	    #		case 2) except that it may compile as a sequence of
+	    #		many instructions, using subprograms to evaluate the
+	    #		value of LUT bins.  LUTs may nest.  When lookup table
+	    #		evaluation is complete the instruction branches
+	    #		forward to a closing XIFF which is used to test the
+	    #		value of PASS returned by the executed LUT-bin
+	    #		subprograms.
+	    #
+	    # The blocks of instructions corresponding to successive expression
+	    # terms are executed until the PASS instruction is encountered.
+	    # Execution of PASS terminates evaluation and passes the event.
+
+	    ip = EX_START(ex)
+	    level = 0
+
+	    do i = 1, MAX_INSTRUCTIONS {
+		pragma switch_no_range_check
+		switch (OPCODE(ip)) {
+		case NOP:				# null operation
+		    ;
+		case GOTO:				# go-to prog offset
+		    ip = IARG1(ip)
+		    next
+		case XIFT: 				# exit if true
+		    if (pass) {
+			pass = false
+			goto ret_
+		    }
+		case XIFF:				# exit if false
+		    if (!pass)
+			goto ret_
+		case PASS:
+		    pass = true
+		    break
+		case RET:				# return from subprog
+ret_		    if (level > 0) {
+			pass = (pv_save[level] || pass)
+			ip = ip_save[level]
+			level = level - 1
+			next
+		    } else
+			break
+
+		case LDSI: 				 # load registers
+		    i0 = Mems[ev_s+IARG1(ip)]
+		    pass = false
+		case LDII:
+		    i0 = Memi[ev_i+IARG1(ip)]
+		    pass = false
+		case LDRR:
+		    r0 = Memr[ev_r+IARG1(ip)]
+		    pass = false
+		case LDRD:
+		    d0 = Memr[ev_r+IARG1(ip)]
+		    pass = false
+		case LDDD:
+		    d0 = Memd[ev_d+IARG1(ip)]
+		    pass = false
+
+		case BTTI: 				 # register tests
+		    pass = pass || (and (i0, IARG1(ip)) != 0)
+		case EQLI:
+		    pass = pass || (i0 == IARG1(ip))
+		case EQLR:
+		    pass = pass || (abs(r0 - RARG1(ip)) < RTOL)
+		case EQLD:
+		    pass = pass || (abs(d0 - DARG1(ip)) < DTOL)
+		case LEQI:
+		    pass = pass || (i0 <= IARG1(ip))
+		case LEQR:
+		    pass = pass || (r0 <= RARG1(ip))
+		case LEQD:
+		    pass = pass || (d0 <= DARG1(ip))
+		case GEQI:
+		    pass = pass || (i0 >= IARG1(ip))
+		case GEQR:
+		    pass = pass || (r0 >= RARG1(ip))
+		case GEQD:
+		    pass = pass || (d0 >= DARG1(ip))
+		case RNGI:
+		    pass = pass || (i0 >= IARG1(ip) && i0 <= IARG2(ip))
+		case RNGR:
+		    pass = pass || (r0 >= RARG1(ip) && r0 <= RARG2(ip))
+		case RNGD:
+		    pass = pass || (d0 >= DARG1(ip) && d0 <= DARG2(ip))
+
+		case BTTXS:				# load, test, and
+		    i0 = Mems[ev_s+IARG1(ip)]		# exit if false
+		    pass = (and (i0, IARG2(ip)) != 0)
+		    if (!pass)
+			goto ret_
+		case BTTXI:
+		    pass = (and (Memi[ev_i+IARG1(ip)], IARG2(ip)) != 0)
+		    if (!pass)
+			goto ret_
+
+		case NEQXS:
+		    pass = (Mems[ev_s+IARG1(ip)] != IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case NEQXI:
+		    pass = (Memi[ev_i+IARG1(ip)] != IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case NEQXR:
+		    pass = (abs(Memr[ev_r+IARG1(ip)] - RARG2(ip)) > RTOL)
+		    if (!pass)
+			goto ret_
+		case NEQXD:
+		    pass = (abs(Memd[ev_d+IARG1(ip)] - DARG2(ip)) > DTOL)
+		    if (!pass)
+			goto ret_
+
+		case EQLXS:
+		    pass = (Mems[ev_s+IARG1(ip)] == IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case EQLXI:
+		    pass = (Memi[ev_i+IARG1(ip)] == IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case EQLXR:
+		    pass = (abs(Memr[ev_r+IARG1(ip)] - RARG2(ip)) <= RTOL)
+		    if (!pass)
+			goto ret_
+		case EQLXD:
+		    pass = (abs(Memd[ev_d+IARG1(ip)] - DARG2(ip)) <= DTOL)
+		    if (!pass)
+			goto ret_
+
+		case LEQXS:
+		    pass = (Mems[ev_s+IARG1(ip)] <= IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case LEQXI:
+		    pass = (Memi[ev_i+IARG1(ip)] <= IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case LEQXR:
+		    pass = (Memr[ev_r+IARG1(ip)] <= RARG2(ip))
+		    if (!pass)
+			goto ret_
+		case LEQXD:
+		    pass = (Memd[ev_d+IARG1(ip)] <= DARG2(ip))
+		    if (!pass)
+			goto ret_
+
+		case GEQXS:
+		    pass = (Mems[ev_s+IARG1(ip)] >= IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case GEQXI:
+		    pass = (Memi[ev_i+IARG1(ip)] >= IARG2(ip))
+		    if (!pass)
+			goto ret_
+		case GEQXR:
+		    pass = (Memr[ev_r+IARG1(ip)] >= RARG2(ip))
+		    if (!pass)
+			goto ret_
+		case GEQXD:
+		    pass = (Memd[ev_d+IARG1(ip)] >= DARG2(ip))
+		    if (!pass)
+			goto ret_
+
+		case RNGXS:
+		    i0 = Mems[ev_s+IARG1(ip)]
+		    pass = (i0 >= IARG2(ip) && i0 <= IARG3(ip))
+		    if (!pass)
+			goto ret_
+		case RNGXI:
+		    i0 = Memi[ev_i+IARG1(ip)]
+		    pass = (i0 >= IARG2(ip) && i0 <= IARG3(ip))
+		    if (!pass)
+			goto ret_
+		case RNGXR:
+		    r0 = Memr[ev_r+IARG1(ip)]
+		    pass = (r0 >= RARG2(ip) && r0 <= RARG3(ip))
+		    if (!pass)
+			goto ret_
+		case RNGXD:
+		    d0 = Memd[ev_d+IARG1(ip)]
+		    pass = (d0 >= DARG2(ip) && d0 <= DARG3(ip))
+		    if (!pass)
+			goto ret_
+
+		case LUTXS:				# lookup tables
+		    i0 = Mems[ev_s+IARG1(ip)]
+		    lt = IARG2(ip)
+		    rbin = (i0 - int(LT_I0(lt))) * LT_IS(lt)
+		    goto lut_
+		case LUTXI:
+		    i0 = Memi[ev_i+IARG1(ip)]
+		    lt = IARG2(ip)
+		    rbin = (i0 - int(LT_I0(lt))) * LT_IS(lt)
+		    goto lut_
+		case LUTXR:
+		    r0 = Memr[ev_r+IARG1(ip)]
+		    lt = IARG2(ip)
+		    rbin = (r0 - LT_R0(lt)) * LT_RS(lt)
+		    goto lut_
+		case LUTXD:
+		    d0 = Memd[ev_d+IARG1(ip)]
+		    lt = IARG2(ip)
+		    rbin = (d0 - LT_D0(lt)) * LT_DS(lt)
+lut_
+		    # Common code for any lookup table.
+		    if (rbin <= 0)
+			v = LT_LEFT(lt)
+		    else {
+			bin = int(rbin) + 1
+			if (bin > LT_NBINS(lt))
+			    v = LT_RIGHT(lt)
+			else
+			    v = LT_LUT(lt,bin)
+		    }
+
+		    # Table value may be 0, 1, or indeterminate, i.e., the
+		    # offset of a subprogram to be called to evaluate the
+		    # subrangelist for that bin.
+
+		    if (v == 0) {
+			# Table value is zero, !pass, all done.
+			pass = false
+			goto ret_
+
+		    } else if (v > 1) {
+			# Table value is indeterminate and depends on the
+			# data value.  Call subroutine to evaluate subrange.
+			# At level=0 where we are starting to evaluate an
+			# independent expression term we must initialize pass
+			# to false before entering the subprogram instruction
+			# sequence.
+
+			if (level == 0)
+			    pass = false
+
+			level = level + 1
+			pv_save[level] = pass
+
+			if (IARG3(ip) != NULL)
+			    ip_save[level] = IARG3(ip)
+			else
+			    ip_save[level] = ip + LEN_INSTRUCTION
+
+			pass = false
+			ip = EX_PB(ex) + v
+			next
+
+		    } else if (v == 1) {
+			# Table value is one, value passes this test.
+			pass = true
+		    }
+
+		    # Go to the jump address if set.  The jump is needed
+		    # to skip over any subprograms that may have been compiled
+		    # after the LUTX.
+
+		    if (IARG3(ip) != NULL) {
+			ip = IARG3(ip)
+			next
+		    }
+		}
+
+		# Advance to the next instruction.
+		ip = ip + LEN_INSTRUCTION
+	    }
+
+	    # Output event pointer if event passed the filter.
+	    if (pass) {
+		npass = npass + 1
+		o_ev[npass] = ev
+	    }
+	}
+
+	return (npass)
+end