Repatch (from linux) of OSX IRAF

1 files changed, 441 insertions, 0 deletions

diff --git a/sys/qpoe/qpexdebug.x b/sys/qpoe/qpexdebug.x
new file mode 100644
index 00000000..26f63e8b
--- /dev/null
+++ b/sys/qpoe/qpexdebug.x
@@ -0,0 +1,441 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<qpexset.h>
+include	<mach.h>
+include	"qpex.h"
+include	"qpoe.h"
+
+define	NLUTPERLINE	15
+define	SZ_TEXT		4
+define	SZ_FILTERBUF	32768
+
+# QPEX_DEBUG -- Output text describing the state and contents of the QPEX
+# descriptor (compiled event attribute filter).
+
+procedure qpex_debug (ex, out, what)
+
+pointer	ex			#I QPEX descriptor
+int	out			#I output stream
+int	what			#I bitflags defining what to print
+
+char	binval[SZ_TEXT]
+pointer	sp, text, label, lutp, et, lt, pb, ip
+int	neterms, lutno, proglen, dest, nout, ch, i
+int	qpex_getfilter()
+define	lut_ 91
+
+begin
+	call smark (sp)
+
+	neterms = 0
+	for (et=EX_ETHEAD(ex);  et != NULL;  et=ET_NEXT(et))
+	    neterms = neterms + 1
+	proglen = (EX_PBOP(ex) - EX_PB(ex)) / LEN_INSTRUCTION
+
+	# Print summary information.
+	if (and (what, QPEXD_SUMMARY) != 0) {
+	    call fprintf (out,
+		"QPEX_DEBUG: ex=%xX, neterms=%d, proglen=%d/%d\n")
+		call pargi (ex)
+		call pargi (neterms)
+		call pargi (proglen)
+		call pargi ((EX_PBTOP(ex) - EX_PB(ex)) / LEN_INSTRUCTION)
+
+	    call fprintf (out, "pb=%xX, pbtop=%xX, pbop=%xX, start=%xX\n")
+		call pargi (EX_PB(ex))
+		call pargi (EX_PBTOP(ex))
+		call pargi (EX_PBOP(ex))
+		call pargi (EX_START(ex))
+
+	    call fprintf (out, "db=%xX, dbtop=%xX, dbop=%xX, datalen=%d/%d\n")
+		call pargi (EX_DB(ex))
+		call pargi (EX_DBTOP(ex))
+		call pargi (EX_DBOP(ex))
+		call pargi (EX_DBOP(ex) - EX_DB(ex))
+		call pargi (EX_DBTOP(ex) - EX_DB(ex))
+
+	    call fprintf (out, "max_frlutlen=%d, max_rrlutlen=%d, ")
+		call pargi (EX_MAXFRLUTLEN(ex))
+		call pargi (EX_MAXRRLUTLEN(ex))
+	    call fprintf (out, "lut_scale=%d, lut_minranges=%d\n")
+		call pargi (EX_LUTSCALE(ex))
+		call pargi (EX_LUTMINRANGES(ex))
+
+	    call fprintf (out, "ethead=%xX, ettail=%xX, lthead=%xX\n")
+		call pargi (EX_ETHEAD(ex))
+		call pargi (EX_ETTAIL(ex))
+		call pargi (EX_LTHEAD(ex))
+	}
+
+	# Regenerate and print the compiled expression.
+	if (and (what, QPEXD_SHOWEXPR) != 0) {
+	    call salloc (text, SZ_FILTERBUF, TY_CHAR)
+	    call fprintf (out,
+		"==================== expr ========================\n")
+	    if (qpex_getfilter (ex, Memc[text], SZ_FILTERBUF) > 0) {
+		call putline (out, Memc[text])
+		call fprintf (out, "\n")
+	    }
+	}
+
+	# Decode the compiled program (print assembled instructions).
+	if (and (what, QPEXD_PROGRAM) != 0) {
+	    pb = EX_PB(ex)
+
+	    call salloc (label, proglen+1, TY_INT)
+	    call aclri (Memi[label], proglen+1)
+
+	    # Flag those instructions which are the destinations of branches.
+	    do i = 1, proglen {
+		ip = pb + (i - 1) * LEN_INSTRUCTION
+		switch (OPCODE(ip)) {
+		case GOTO:
+		    dest = (IARG1(ip) - pb) / LEN_INSTRUCTION
+		    Memi[label+dest] = YES
+		case LUTXS, LUTXI, LUTXR, LUTXD:
+		    if (IARG3(ip) == NULL)
+			dest = i
+		    else
+			dest = (IARG3(ip) - pb) / LEN_INSTRUCTION
+		    Memi[label+dest] = YES
+		}
+	    }
+
+	    # Do the same for code segments pointed to by lookup tables.
+	    for (lt=EX_LTHEAD(ex);  lt != NULL;  lt=LT_NEXT(lt)) {
+		lutp  = LT_LUTP(lt)
+		do i = 0, LT_NBINS(lt) - 1 {
+		    dest = Mems[lutp+i]
+		    if (dest > 1) {
+			dest = dest / LEN_INSTRUCTION
+			Memi[label+dest] = YES
+		    }
+		}
+	    }
+
+	    # Output the program.
+	    call fprintf (out,
+		"==================== program =====================\n")
+
+	    do i = 1, proglen + 1 {
+		ip = pb + (i - 1) * LEN_INSTRUCTION
+
+		# Output instruction label if target of a branch.
+		if (Memi[label+i-1] == YES) {
+		    call fprintf (out, "L%d:\t")
+			call pargi (i)
+		} else
+		    call fprintf (out, "\t")
+
+		# Decode and output the instruction itself.
+		switch (OPCODE(ip)) {
+		case NOP:
+		    call fprintf (out, "nop")
+		case GOTO:
+		    dest = (IARG1(ip) - pb) / LEN_INSTRUCTION + 1
+		    call fprintf (out, "goto L%d")
+			call pargi (dest)
+		case XIFT:
+		    call fprintf (out, "xift")
+		case XIFF:
+		    call fprintf (out, "xiff")
+		case PASS:
+		    call fprintf (out, "pass")
+		case RET:
+		    call fprintf (out, "ret")
+
+		case LDSI:
+		    call fprintf (out, "ldsi\t(%d)")
+			call pargi (IARG1(ip))
+		case LDII:
+		    call fprintf (out, "ldii\t(%d)")
+			call pargi (IARG1(ip))
+		case LDRR:
+		    call fprintf (out, "ldrr\t(%d)")
+			call pargi (IARG1(ip))
+		case LDRD:
+		    call fprintf (out, "ldrd\t(%d)")
+			call pargi (IARG1(ip))
+		case LDDD:
+		    call fprintf (out, "lddd\t(%d)")
+			call pargi (IARG1(ip))
+
+		case BTTI:
+		    call fprintf (out, "btti\t%oB")
+			call pargi (IARG1(ip))
+		case EQLI:
+		    call fprintf (out, "eqli\t%d")
+			call pargi (IARG1(ip))
+		case EQLR:
+		    call fprintf (out, "eqlr\t%g")
+			call pargr (RARG1(ip))
+		case EQLD:
+		    call fprintf (out, "eqld\t%g")
+			call pargd (DARG1(ip))
+		case LEQI:
+		    call fprintf (out, "leqi\t%d")
+			call pargi (IARG1(ip))
+		case LEQR:
+		    call fprintf (out, "leqr\t%g")
+			call pargr (RARG1(ip))
+		case LEQD:
+		    call fprintf (out, "leqd\t%g")
+			call pargd (DARG1(ip))
+		case GEQI:
+		    call fprintf (out, "geqi\t%d")
+			call pargi (IARG1(ip))
+		case GEQR:
+		    call fprintf (out, "geqr\t%g")
+			call pargr (RARG1(ip))
+		case GEQD:
+		    call fprintf (out, "geqd\t%g")
+			call pargd (DARG1(ip))
+
+		case RNGI:
+		    call fprintf (out, "rngi\t%d, %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case RNGR:
+		    call fprintf (out, "rngr\t%g, %g")
+			call pargr (RARG1(ip))
+			call pargr (RARG2(ip))
+		case RNGD:
+		    call fprintf (out, "rngd\t%g, %g")
+			call pargd (DARG1(ip))
+			call pargd (DARG2(ip))
+
+		case BTTXS:
+		    call fprintf (out, "bttxs\t(%d), %oB")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case BTTXI:
+		    call fprintf (out, "bttxi\t(%d), %oB")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+
+		case NEQXS:
+		    call fprintf (out, "neqxs\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case NEQXI:
+		    call fprintf (out, "neqxi\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case NEQXR:
+		    call fprintf (out, "neqxr\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargr (RARG2(ip))
+		case NEQXD:
+		    call fprintf (out, "neqxd\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargd (DARG2(ip))
+
+		case EQLXS:
+		    call fprintf (out, "eqlxs\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case EQLXI:
+		    call fprintf (out, "eqlxi\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case EQLXR:
+		    call fprintf (out, "eqlxr\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargr (RARG2(ip))
+		case EQLXD:
+		    call fprintf (out, "eqlxd\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargd (DARG2(ip))
+
+		case LEQXS:
+		    call fprintf (out, "leqxs\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case LEQXI:
+		    call fprintf (out, "leqxi\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case LEQXR:
+		    call fprintf (out, "leqxr\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargr (RARG2(ip))
+		case LEQXD:
+		    call fprintf (out, "leqxd\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargd (DARG2(ip))
+
+		case GEQXS:
+		    call fprintf (out, "geqxs\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case GEQXI:
+		    call fprintf (out, "geqxi\t(%d), %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+		case GEQXR:
+		    call fprintf (out, "geqxr\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargr (RARG2(ip))
+		case GEQXD:
+		    call fprintf (out, "geqxd\t(%d), %g")
+			call pargi (IARG1(ip))
+			call pargd (DARG2(ip))
+
+		case RNGXS:
+		    call fprintf (out, "rngxs\t(%d), %d, %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+			call pargi (IARG3(ip))
+		case RNGXI:
+		    call fprintf (out, "rngxi\t(%d), %d, %d")
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+			call pargi (IARG3(ip))
+		case RNGXR:
+		    call fprintf (out, "rngxr\t(%d), %g, %g")
+			call pargi (IARG1(ip))
+			call pargr (RARG2(ip))
+			call pargr (RARG3(ip))
+		case RNGXD:
+		    call fprintf (out, "rngxd\t(%d), %g, %g")
+			call pargi (IARG1(ip))
+			call pargd (DARG2(ip))
+			call pargd (DARG3(ip))
+
+		case LUTXS:
+		    ch = 's'
+		    goto lut_
+		case LUTXI:
+		    ch = 'i'
+		    goto lut_
+		case LUTXR:
+		    ch = 'r'
+		    goto lut_
+		case LUTXD:
+		    ch = 'd'
+lut_		    call fprintf (out, "lutx%c\t(%d), %xX, L%d")
+			call pargi (ch)
+			call pargi (IARG1(ip))
+			call pargi (IARG2(ip))
+			if (IARG3(ip) != NULL)
+			    call pargi ((IARG3(ip) - pb) / LEN_INSTRUCTION + 1)
+			else
+			    call pargi (i + 1)
+		}
+
+		call fprintf (out, "\n")
+	    }
+	}
+
+	# Output expression terms list.
+	if (and (what, QPEXD_ETLIST) != 0) {
+	    call fprintf (out,
+		"==================== eterms ======================\n")
+	    if (neterms > 0) {
+		call fprintf (out,
+		    " N TYPE OFF  IP  LEN DEL ATTRIBUTE OP EXPR\n")
+		neterms = 0
+		for (et=EX_ETHEAD(ex);  et != NULL;  et=ET_NEXT(et)) {
+		    neterms = neterms + 1
+		    call fprintf (out,
+			"%2d %4d %3d %3d %4d %3d %9.9s %2s ")
+			call pargi (neterms)
+			call pargi (ET_ATTTYPE(et))
+			call pargi (ET_ATTOFF(et))
+			call pargi ((ET_PROGPTR(et) - pb) / LEN_INSTRUCTION + 1)
+			call pargi (ET_NINSTR(et))
+			call pargi (ET_DELETED(et))
+			call pargstr (Memc[ET_ATNAME(et)])
+			call pargstr (Memc[ET_ASSIGNOP(et)])
+		    call putline (out, Memc[ET_EXPRTEXT(et)])
+		    call putline (out, "\n")
+		}
+	    }
+	}
+
+	# Output lookup table list.
+	if (and (what, QPEXD_LTLIST+QPEXD_SHOWLUTS) != 0) {
+	    if (EX_LTHEAD(ex) != NULL) {
+		call fprintf (out,
+		    "==================== lutlist =====================\n")
+
+		# Output column labels.
+		call fprintf (out,
+		    " N     LT   LUTP TYPE NBINS  L R %*wZERO  SCALE\n")
+		    if (LT_TYPE(EX_LTHEAD(ex)) == TY_DOUBLE)
+			call pargi (NDIGITS_DP - 4)
+		    else
+			call pargi (NDIGITS_RP - 4)
+
+		# Output lookup table descriptors.
+		lutno = 0
+		for (lt=EX_LTHEAD(ex);  lt != NULL;  lt=LT_NEXT(lt)) {
+		    lutno = lutno + 1
+		    call fprintf (out, "%2d %6x %6x %4d %5d  %d %d %*g  %g\n")
+			call pargi (lutno)
+			call pargi (lt)
+			call pargi (LT_LUTP(lt))
+			call pargi (LT_TYPE(lt))
+			call pargi (LT_NBINS(lt))
+			call pargi (LT_LEFT(lt))
+			call pargi (LT_RIGHT(lt))
+
+			switch (LT_TYPE(lt)) {
+			case TY_INT:
+			    call pargi (NDIGITS_RP)
+			    call pargr (LT_I0(lt))
+			    call pargr (LT_IS(lt))
+			case TY_REAL:
+			    call pargi (NDIGITS_RP)
+			    call pargr (LT_R0(lt))
+			    call pargr (LT_RS(lt))
+			case TY_DOUBLE:
+			    call pargi (NDIGITS_DP)
+			    call pargd (LT_D0(lt))
+			    call pargd (LT_DS(lt))
+			}
+		}
+	    }
+
+	    # Dump the lookup table data.
+	    if (and (what, QPEXD_SHOWLUTS) != 0) {
+		lutno = 0
+		for (lt=EX_LTHEAD(ex);  lt != NULL;  lt=LT_NEXT(lt)) {
+		    lutno = lutno + 1
+		    lutp  = LT_LUTP(lt)
+		    call fprintf (out,
+			"================== LUT %d (%x) ==================\n")
+			call pargi (lutno)
+			call pargi (lutp)
+		    nout = 0
+		    do i = 0, LT_NBINS(lt) - 1 {
+			if (i == 0 || nout >= NLUTPERLINE) {
+			    if (i > 0)
+				call fprintf (out, "\n")
+			    call fprintf (out, "%04d")
+				call pargi (i)
+			    nout = 0
+			}
+
+			# Print the bin value as 0, 1, or a statement label.
+			dest = Mems[lutp+i]
+			if (dest <= 1) {
+			    call fprintf (out, " %4d")
+				call pargi (dest)
+			} else {
+			    call sprintf (binval, SZ_TEXT, "L%d")
+				call pargi (dest / LEN_INSTRUCTION + 1)
+			    call fprintf (out, " %4s")
+				call pargstr (binval)
+			}
+
+			nout = nout + 1
+		    }
+		    if (nout > 0)
+			call fprintf (out, "\n")
+		}
+	    }
+	}
+
+	call sfree (sp)
+end