Repatch (from linux) of OSX IRAF

1 files changed, 247 insertions, 0 deletions

diff --git a/sys/qpoe/qpexmodfil.x b/sys/qpoe/qpexmodfil.x
new file mode 100644
index 00000000..7df4b926
--- /dev/null
+++ b/sys/qpoe/qpexmodfil.x
@@ -0,0 +1,247 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+include "qpoe.h"
+include "qpex.h"
+
+# QPEX_MODFILTER -- Compile an event attribute expression to be used for event
+# attribute filtering, modifying the the current EAF as directed by the expr.
+# An event attribute expression consists of a sequence of independent terms
+# of the form "attribute = expr", e.g.,
+#
+#       pha=%104B, e=100:, t=(:9,11:29,33,42:65,67:99,!(82,87),103), ...
+#
+# 
+# Variants on "attr = expr" are "attr := expr" and "attr += expr".  In the
+# case of :=, any expression terms already entered for the named attribute
+# will be REPLACED by the new expression.  In the case of +=, the given
+# expression denotes an additional condition which the attribute must satisfy
+# to pass the filter, i.e., a new term is added to the existing filter.  The
+# case = is the same as +=, i.e., the default action is to modify rather than
+# replace any existing filter.
+# 
+#
+# Our function is to extract each attribute=expr term and compile it into a
+# series of instructions to be repeatedly executed (interpreted) at runtime
+# to evaluate the expression for a particular event structure.  Terms are
+# compiled and evaluated in the order in which they appear in the expression
+# list (except for replacement terms), allowing the user to manually optimize
+# the filter by giving terms which are most likely to fail first.
+#
+# The expression list may contain references to predefined global or local
+# (datafile) macros, external macro files, or back-quoted CL commands for
+# which the output is to be substituted as for a macro.  In all cases, macro
+# substitution is handled at a lower level in the gettok routine.  In
+# particular, the logical names of the fields of the event structure are
+# implemented as predefined datafile-local macros, hence we are concerned only
+# with physical field names here.  The form of a physical field name is
+# a datatype code [SIRD] followed by the decimal zero-indexed byte offset
+# of the field in the event structure, e.g., S0, S2, R4, etc. (short integer
+# field at offset 0, same at offset 2, Real*4 field at offset 4, etc.).
+#
+# The function value is OK if the expression list compiles without any errors,
+# or ERR if some compilation error occurs.  Compilation errors cause an error
+# message to be output to STDERR and the affected terms to be skipped, but are
+# otherwise ignored.
+
+int procedure qpex_modfilter (ex, exprlist)
+
+pointer ex                      #I qpex descriptor
+char    exprlist[ARB]           #I list of attribute=expr expressions
+
+bool	replace
+int	boffset, offset, max_offset, dtype
+int	status, sz_expr, token, parenlevel, nchars, buflen
+pointer	sp, atname, assignop, tokbuf, expr, qp, ip, op, in, et_tail
+
+pointer	qp_opentext()
+int	qpex_codegeni(), qpex_codegenr(), qpex_codegend()
+int	qp_gettok(), strlen(), gstrcpy(), ctoi(), sizeof()
+errchk	malloc, qp_opentext, qp_gettok, realloc, qpex_delete
+
+string	qpexwarn "QPEX Warning"
+define	eatup_ 91
+define	badatt_ 92
+
+begin
+	call smark (sp)
+	call salloc (atname, SZ_TOKBUF, TY_CHAR)
+	call salloc (assignop, SZ_TOKBUF, TY_CHAR)
+	call salloc (tokbuf, SZ_TOKBUF, TY_CHAR)
+
+	status = OK
+	sz_expr = DEF_SZEXPRBUF
+	et_tail = EX_ETTAIL(ex)
+	qp = EX_QP(ex)
+
+	# Allocate a variable size expression buffer.
+	call malloc (expr, sz_expr, TY_CHAR)
+
+	# Open the expression list for token input with macro expansion.
+	in = qp_opentext (qp, exprlist)
+
+	# Accumulate and compile successive attribute=expr terms of the
+	# expression list.
+
+	repeat {
+	    # Get attribute name.
+	    switch (qp_gettok (in, Memc[atname], SZ_TOKBUF)) {
+	    case EOF:
+		break			# input exhausted
+	    case ',', ';':
+		next			# null statement
+	    case TOK_IDENTIFIER:
+		;			# got one
+	    default:
+		call eprintf ("%s: unexpected token `%s'\n")
+		    call pargstr (qpexwarn)
+		    call pargstr (Memc[atname])
+		goto eatup_
+	    }
+
+	    # Get operator.
+	    switch (qp_gettok (in, Memc[assignop], SZ_TOKBUF)) {
+	    case TOK_PLUSEQUALS, '=':
+		replace = false
+	    case TOK_COLONEQUALS:
+		replace = true
+
+	    default:
+		call eprintf ("%s: missing assignment token (`%s')\n")
+		    call pargstr (qpexwarn)
+		    call pargstr (Memc[atname])
+eatup_
+		# A half-hearted attempt to ignore the offending statement...
+		while (qp_gettok (in, Memc[expr], sz_expr) != EOF)
+		    if (Memc[expr] == ',')
+			break
+
+		# The default is to add to any existing filter.
+		replace = false
+	    }
+
+	    parenlevel = 0
+	    token = NULL
+
+	    # Accumulate expression.
+	    for (op=expr;  token != EOF;  ) {
+		# Get next token from input stream.
+		token = qp_gettok (in, Memc[tokbuf], SZ_TOKBUF)
+
+		# Process any special tokens.
+		switch (token) {
+		case EOF:
+		    break
+		case '(':
+		    parenlevel = parenlevel + 1
+		case ')':
+		    parenlevel = parenlevel - 1
+		    if (parenlevel < 0) {
+			call eprintf ("%s: missing left parenthesis\n")
+			    call pargstr (qpexwarn)
+			parenlevel = 0
+			status = ERR
+			next
+		    }
+		case ',', ';':
+		    # An unparenthesized comma terminates the expression.
+		    if (parenlevel <= 0)
+			break
+		}
+
+		# Allocate more storage if expr buf fills.
+		nchars = strlen (Memc[tokbuf])
+		buflen = op - expr
+		if (buflen + nchars > sz_expr) {
+		    sz_expr = sz_expr + INC_SZEXPRBUF
+		    call realloc (expr, sz_expr, TY_CHAR)
+		    op = expr + buflen
+		}
+
+		# Concatenate token string to expr.
+		op = op + gstrcpy (Memc[tokbuf], Memc[op], SZ_TOKBUF)
+	    }
+
+	    Memc[op] = EOS
+	    if (parenlevel > 0) {
+		call eprintf ("%s: missing right parenthesis in expression\n")
+		    call pargstr (qpexwarn)
+		status = ERR
+	    }
+
+	    # Parse the attribute name to determine the datatype and offset.
+
+	    # Get byte offset of field.
+	    ip = atname + 1
+	    if (ctoi (Memc, ip, boffset) <= 0)
+		goto badatt_
+
+	    # Get datatype and scaled offset; check field alignment.
+	    switch (Memc[atname]) {
+	    case 'S', 's':
+		dtype = TY_SHORT
+		offset = boffset / (SZ_SHORT * SZB_CHAR)
+		if (offset * SZ_SHORT * SZB_CHAR != boffset)
+		    goto badatt_
+	    case 'I', 'i':
+		dtype = TY_INT
+		offset = boffset / (SZ_INT * SZB_CHAR)
+		if (offset * SZ_INT * SZB_CHAR != boffset)
+		    goto badatt_
+	    case 'R', 'r':
+		dtype = TY_REAL
+		offset = boffset / (SZ_REAL * SZB_CHAR)
+		if (offset * SZ_REAL * SZB_CHAR != boffset)
+		    goto badatt_
+	    case 'D', 'd':
+		dtype = TY_DOUBLE
+		offset = boffset / (SZ_DOUBLE * SZB_CHAR)
+		if (offset * SZ_DOUBLE * SZB_CHAR != boffset)
+		    goto badatt_
+	    default:
+		goto badatt_
+	    }
+	    
+	    # Verify that the field is in range in the event struct.
+	    # (Actually, we don't know the event struct at compile time...)
+
+	    max_offset = (boffset / SZB_CHAR) + sizeof(dtype) - 1
+	    if (boffset < 0 || max_offset > ARB) {
+badatt_		call eprintf ("%s: bad attribute name `%s'\n")
+		    call pargstr (qpexwarn)
+		    call pargstr (Memc[atname])
+		status = ERR
+		next
+	    }
+
+	    # Clobber any old expression for the given attribute if replace
+	    # mode is in effect.  Only previous expression terms are affected,
+	    # hence in single expressions like "pha=x,pha=y", the second entry
+	    # does not clobber the first.
+
+	    if (replace)
+		call qpex_delete (ex, et_tail, offset, dtype)
+
+	    # Compile the expression.
+	    switch (dtype) {
+	    case TY_SHORT, TY_INT:
+		if (qpex_codegeni (ex, Memc[atname], Memc[assignop],
+		    Memc[expr], offset, dtype) == ERR)
+		    status = ERR
+	    case TY_REAL:
+		if (qpex_codegenr (ex, Memc[atname], Memc[assignop],
+		    Memc[expr], offset, dtype) == ERR)
+		    status = ERR
+	    case TY_DOUBLE:
+		if (qpex_codegend (ex, Memc[atname], Memc[assignop],
+		    Memc[expr], offset, dtype) == ERR)
+		    status = ERR
+	    }
+	}
+
+	call qp_closetext (in)
+	call mfree (expr, TY_CHAR)
+	call sfree (sp)
+
+	return (status)
+end