diff options
Diffstat (limited to 'sys/qpoe/gen')
39 files changed, 6609 insertions, 0 deletions
diff --git a/sys/qpoe/gen/mkpkg b/sys/qpoe/gen/mkpkg new file mode 100644 index 00000000..8c08a1f7 --- /dev/null +++ b/sys/qpoe/gen/mkpkg @@ -0,0 +1,47 @@ +# Update the generically expanded files in libex.a. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + qpaddb.x ../qpoe.h + qpaddc.x ../qpoe.h + qpaddd.x ../qpoe.h + qpaddi.x ../qpoe.h + qpaddl.x ../qpoe.h + qpaddr.x ../qpoe.h + qpadds.x ../qpoe.h + qpaddx.x ../qpoe.h + qpexattrld.x ../qpex.h <ctype.h> <mach.h> + qpexattrli.x ../qpex.h <ctype.h> <mach.h> + qpexattrlr.x ../qpex.h <ctype.h> <mach.h> + qpexcoded.x ../qpex.h <mach.h> + qpexcodei.x ../qpex.h <mach.h> + qpexcoder.x ../qpex.h <mach.h> + qpexparsed.x ../qpex.h <ctype.h> <mach.h> + qpexparsei.x ../qpex.h <ctype.h> <mach.h> + qpexparser.x ../qpex.h <ctype.h> <mach.h> + qpexsubd.x ../qpex.h <mach.h> + qpexsubi.x ../qpex.h <mach.h> + qpexsubr.x ../qpex.h <mach.h> + qpgetc.x ../qpoe.h + qpgetd.x ../qpoe.h + qpgeti.x ../qpoe.h + qpgetl.x ../qpoe.h + qpgetr.x ../qpoe.h + qpgets.x ../qpoe.h + qpiogetev.x ../qpio.h <pmset.h> + qpiorpixi.x ../qpio.h <mach.h> + qpiorpixs.x ../qpio.h <mach.h> + qpputc.x ../qpoe.h + qpputd.x ../qpoe.h + qpputi.x ../qpoe.h + qpputl.x ../qpoe.h + qpputr.x ../qpoe.h + qpputs.x ../qpoe.h + qprlmerged.x ../qpex.h <mach.h> + qprlmergei.x ../qpex.h <mach.h> + qprlmerger.x ../qpex.h <mach.h> + ; diff --git a/sys/qpoe/gen/qpaddb.x b/sys/qpoe/gen/qpaddb.x new file mode 100644 index 00000000..1291824a --- /dev/null +++ b/sys/qpoe/gen/qpaddb.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addb (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +bool value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_BOOL] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putb (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddc.x b/sys/qpoe/gen/qpaddc.x new file mode 100644 index 00000000..64264e20 --- /dev/null +++ b/sys/qpoe/gen/qpaddc.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addc (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_CHAR] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putc (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddd.x b/sys/qpoe/gen/qpaddd.x new file mode 100644 index 00000000..61db744e --- /dev/null +++ b/sys/qpoe/gen/qpaddd.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addd (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +double value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_DOUBLE] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putd (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddi.x b/sys/qpoe/gen/qpaddi.x new file mode 100644 index 00000000..47d746c6 --- /dev/null +++ b/sys/qpoe/gen/qpaddi.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addi (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +int value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_INT] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_puti (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddl.x b/sys/qpoe/gen/qpaddl.x new file mode 100644 index 00000000..f5e0cac2 --- /dev/null +++ b/sys/qpoe/gen/qpaddl.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addl (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +long value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_LONG] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putl (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddr.x b/sys/qpoe/gen/qpaddr.x new file mode 100644 index 00000000..ec367ab7 --- /dev/null +++ b/sys/qpoe/gen/qpaddr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addr (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +real value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_REAL] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putr (qp, param, value) +end diff --git a/sys/qpoe/gen/qpadds.x b/sys/qpoe/gen/qpadds.x new file mode 100644 index 00000000..67036fda --- /dev/null +++ b/sys/qpoe/gen/qpadds.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_adds (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +short value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_SHORT] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_puts (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddx.x b/sys/qpoe/gen/qpaddx.x new file mode 100644 index 00000000..d147748e --- /dev/null +++ b/sys/qpoe/gen/qpaddx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addx (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +complex value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_COMPLEX] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putx (qp, param, value) +end diff --git a/sys/qpoe/gen/qpexattrld.x b/sys/qpoe/gen/qpexattrld.x new file mode 100644 index 00000000..5954cbe4 --- /dev/null +++ b/sys/qpoe/gen/qpexattrld.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <ctype.h> +include "../qpex.h" + +# QPEX_ATTRL -- Get the good-value range list for the named attribute, as a +# binary range list of the indicated type. This range list is a simplified +# version of the original filter expression, which may have contained +# multiple fields, some negated or overlapping, in any order, subsequently +# modified or deleted with qpex_modfilter, etc. The final resultant range +# list is ordered and consists of discreet nonoverlapping ranges. +# +# Upon input the variables XS and XE should either point to a pair of +# preallocated buffers of length XLEN, or they should be set to NULL. +# The routine will reallocate the buffers as necessary to allow for long +# range lists, updating XLEN so that it always contains the actual length +# of the arrays (which may not be completely full). Each list element +# consists of a pair of values (xs[i],xe[i]) defining the start and end +# points of the range. If xs[1] is INDEF the range is open to the left, +# if xe[nranges] is INDEF the range is open to the right. The number of +# ranges output is returned as the function value. + +int procedure qpex_attrld (ex, attribute, xs, xe, xlen) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +pointer xs #U pointer to array of start values +pointer xe #U pointer to array of end values +int xlen #U length of xs/xe arrays + +pointer ps, pe, qs, qe +pointer sp, expr, ip, ep +int plen, qlen, np, nq, nx +int neterms, nchars, maxch +int qpex_getattribute(), qpex_parsed(), qp_rlmerged() + +begin + call smark (sp) + + # Get attribute filter expression. In the unlikely event that the + # expression is too large to fit in our buffer, repeat with a buffer + # twice as large until it fits. + + maxch = DEF_SZEXPRBUF + nchars = 0 + + repeat { + maxch = maxch * 2 + call salloc (expr, maxch, TY_CHAR) + nchars = qpex_getattribute (ex, attribute, Memc[expr], maxch) + if (nchars <= 0) + break + } until (nchars < maxch) + + # Parse expression to produce a range list. If the expression + # contains multiple eterms each is parsed separately and merged + # into the final output range list. + + nx = 0 + neterms = 0 + + if (nchars > 0) { + # Get range list storage. + plen = DEF_XLEN + call malloc (ps, plen, TY_DOUBLE) + call malloc (pe, plen, TY_DOUBLE) + qlen = DEF_XLEN + call malloc (qs, qlen, TY_DOUBLE) + call malloc (qe, qlen, TY_DOUBLE) + + # Parse each subexpression and merge into output range list. + for (ip=expr; Memc[ip] != EOS; ) { + # Get next subexpression. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + for (ep=ip; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ';') { + Memc[ip] = EOS + ip = ip + 1 + break + } + if (Memc[ep] == EOS) + break + + # Copy output range list to X list temporary. + if (max(nx,1) > plen) { + plen = max(xlen,1) + call realloc (ps, plen, TY_DOUBLE) + call realloc (pe, plen, TY_DOUBLE) + } + if (neterms <= 0) { + Memd[ps] = LEFTD + Memd[pe] = RIGHTD + np = 1 + } else { + call amovd (Memd[xs], Memd[ps], nx) + call amovd (Memd[xe], Memd[pe], nx) + np = nx + } + + # Parse next eterm into Y list temporary. + nq = qpex_parsed (Memc[ep], qs, qe, qlen) + + # Merge the X and Y lists, leaving result in output list. + nx = qp_rlmerged (xs,xe,xlen, + Memd[ps], Memd[pe], np, Memd[qs], Memd[qe], nq) + + neterms = neterms + 1 + } + + # Free temporary range list storage. + call mfree (ps, TY_DOUBLE); call mfree (pe, TY_DOUBLE) + call mfree (qs, TY_DOUBLE); call mfree (qe, TY_DOUBLE) + + # Convert LEFT/RIGHT magic values to INDEF. + if (nx > 0) { + if (IS_LEFTD (Memd[xs])) + Memd[xs] = INDEFD + if (IS_RIGHTD (Memd[xe+nx-1])) + Memd[xe+nx-1] = INDEFD + } + } + + call sfree (sp) + return (nx) +end diff --git a/sys/qpoe/gen/qpexattrli.x b/sys/qpoe/gen/qpexattrli.x new file mode 100644 index 00000000..706aecc8 --- /dev/null +++ b/sys/qpoe/gen/qpexattrli.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <ctype.h> +include "../qpex.h" + +# QPEX_ATTRL -- Get the good-value range list for the named attribute, as a +# binary range list of the indicated type. This range list is a simplified +# version of the original filter expression, which may have contained +# multiple fields, some negated or overlapping, in any order, subsequently +# modified or deleted with qpex_modfilter, etc. The final resultant range +# list is ordered and consists of discreet nonoverlapping ranges. +# +# Upon input the variables XS and XE should either point to a pair of +# preallocated buffers of length XLEN, or they should be set to NULL. +# The routine will reallocate the buffers as necessary to allow for long +# range lists, updating XLEN so that it always contains the actual length +# of the arrays (which may not be completely full). Each list element +# consists of a pair of values (xs[i],xe[i]) defining the start and end +# points of the range. If xs[1] is INDEF the range is open to the left, +# if xe[nranges] is INDEF the range is open to the right. The number of +# ranges output is returned as the function value. + +int procedure qpex_attrli (ex, attribute, xs, xe, xlen) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +pointer xs #U pointer to array of start values +pointer xe #U pointer to array of end values +int xlen #U length of xs/xe arrays + +pointer ps, pe, qs, qe +pointer sp, expr, ip, ep +int plen, qlen, np, nq, nx +int neterms, nchars, maxch +int qpex_getattribute(), qpex_parsei(), qp_rlmergei() + +begin + call smark (sp) + + # Get attribute filter expression. In the unlikely event that the + # expression is too large to fit in our buffer, repeat with a buffer + # twice as large until it fits. + + maxch = DEF_SZEXPRBUF + nchars = 0 + + repeat { + maxch = maxch * 2 + call salloc (expr, maxch, TY_CHAR) + nchars = qpex_getattribute (ex, attribute, Memc[expr], maxch) + if (nchars <= 0) + break + } until (nchars < maxch) + + # Parse expression to produce a range list. If the expression + # contains multiple eterms each is parsed separately and merged + # into the final output range list. + + nx = 0 + neterms = 0 + + if (nchars > 0) { + # Get range list storage. + plen = DEF_XLEN + call malloc (ps, plen, TY_INT) + call malloc (pe, plen, TY_INT) + qlen = DEF_XLEN + call malloc (qs, qlen, TY_INT) + call malloc (qe, qlen, TY_INT) + + # Parse each subexpression and merge into output range list. + for (ip=expr; Memc[ip] != EOS; ) { + # Get next subexpression. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + for (ep=ip; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ';') { + Memc[ip] = EOS + ip = ip + 1 + break + } + if (Memc[ep] == EOS) + break + + # Copy output range list to X list temporary. + if (max(nx,1) > plen) { + plen = max(xlen,1) + call realloc (ps, plen, TY_INT) + call realloc (pe, plen, TY_INT) + } + if (neterms <= 0) { + Memi[ps] = LEFTI + Memi[pe] = RIGHTI + np = 1 + } else { + call amovi (Memi[xs], Memi[ps], nx) + call amovi (Memi[xe], Memi[pe], nx) + np = nx + } + + # Parse next eterm into Y list temporary. + nq = qpex_parsei (Memc[ep], qs, qe, qlen) + + # Merge the X and Y lists, leaving result in output list. + nx = qp_rlmergei (xs,xe,xlen, + Memi[ps], Memi[pe], np, Memi[qs], Memi[qe], nq) + + neterms = neterms + 1 + } + + # Free temporary range list storage. + call mfree (ps, TY_INT); call mfree (pe, TY_INT) + call mfree (qs, TY_INT); call mfree (qe, TY_INT) + + # Convert LEFT/RIGHT magic values to INDEF. + if (nx > 0) { + if (IS_LEFTI (Memi[xs])) + Memi[xs] = INDEFI + if (IS_RIGHTI (Memi[xe+nx-1])) + Memi[xe+nx-1] = INDEFI + } + } + + call sfree (sp) + return (nx) +end diff --git a/sys/qpoe/gen/qpexattrlr.x b/sys/qpoe/gen/qpexattrlr.x new file mode 100644 index 00000000..c13a7511 --- /dev/null +++ b/sys/qpoe/gen/qpexattrlr.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <ctype.h> +include "../qpex.h" + +# QPEX_ATTRL -- Get the good-value range list for the named attribute, as a +# binary range list of the indicated type. This range list is a simplified +# version of the original filter expression, which may have contained +# multiple fields, some negated or overlapping, in any order, subsequently +# modified or deleted with qpex_modfilter, etc. The final resultant range +# list is ordered and consists of discreet nonoverlapping ranges. +# +# Upon input the variables XS and XE should either point to a pair of +# preallocated buffers of length XLEN, or they should be set to NULL. +# The routine will reallocate the buffers as necessary to allow for long +# range lists, updating XLEN so that it always contains the actual length +# of the arrays (which may not be completely full). Each list element +# consists of a pair of values (xs[i],xe[i]) defining the start and end +# points of the range. If xs[1] is INDEF the range is open to the left, +# if xe[nranges] is INDEF the range is open to the right. The number of +# ranges output is returned as the function value. + +int procedure qpex_attrlr (ex, attribute, xs, xe, xlen) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +pointer xs #U pointer to array of start values +pointer xe #U pointer to array of end values +int xlen #U length of xs/xe arrays + +pointer ps, pe, qs, qe +pointer sp, expr, ip, ep +int plen, qlen, np, nq, nx +int neterms, nchars, maxch +int qpex_getattribute(), qpex_parser(), qp_rlmerger() + +begin + call smark (sp) + + # Get attribute filter expression. In the unlikely event that the + # expression is too large to fit in our buffer, repeat with a buffer + # twice as large until it fits. + + maxch = DEF_SZEXPRBUF + nchars = 0 + + repeat { + maxch = maxch * 2 + call salloc (expr, maxch, TY_CHAR) + nchars = qpex_getattribute (ex, attribute, Memc[expr], maxch) + if (nchars <= 0) + break + } until (nchars < maxch) + + # Parse expression to produce a range list. If the expression + # contains multiple eterms each is parsed separately and merged + # into the final output range list. + + nx = 0 + neterms = 0 + + if (nchars > 0) { + # Get range list storage. + plen = DEF_XLEN + call malloc (ps, plen, TY_REAL) + call malloc (pe, plen, TY_REAL) + qlen = DEF_XLEN + call malloc (qs, qlen, TY_REAL) + call malloc (qe, qlen, TY_REAL) + + # Parse each subexpression and merge into output range list. + for (ip=expr; Memc[ip] != EOS; ) { + # Get next subexpression. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + for (ep=ip; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ';') { + Memc[ip] = EOS + ip = ip + 1 + break + } + if (Memc[ep] == EOS) + break + + # Copy output range list to X list temporary. + if (max(nx,1) > plen) { + plen = max(xlen,1) + call realloc (ps, plen, TY_REAL) + call realloc (pe, plen, TY_REAL) + } + if (neterms <= 0) { + Memr[ps] = LEFTR + Memr[pe] = RIGHTR + np = 1 + } else { + call amovr (Memr[xs], Memr[ps], nx) + call amovr (Memr[xe], Memr[pe], nx) + np = nx + } + + # Parse next eterm into Y list temporary. + nq = qpex_parser (Memc[ep], qs, qe, qlen) + + # Merge the X and Y lists, leaving result in output list. + nx = qp_rlmerger (xs,xe,xlen, + Memr[ps], Memr[pe], np, Memr[qs], Memr[qe], nq) + + neterms = neterms + 1 + } + + # Free temporary range list storage. + call mfree (ps, TY_REAL); call mfree (pe, TY_REAL) + call mfree (qs, TY_REAL); call mfree (qe, TY_REAL) + + # Convert LEFT/RIGHT magic values to INDEF. + if (nx > 0) { + if (IS_LEFTR (Memr[xs])) + Memr[xs] = INDEFR + if (IS_RIGHTR (Memr[xe+nx-1])) + Memr[xe+nx-1] = INDEFR + } + } + + call sfree (sp) + return (nx) +end diff --git a/sys/qpoe/gen/qpexcoded.x b/sys/qpoe/gen/qpexcoded.x new file mode 100644 index 00000000..63ec2541 --- /dev/null +++ b/sys/qpoe/gen/qpexcoded.x @@ -0,0 +1,370 @@ +# 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_codegend (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 +double 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 + +double 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] + +double xoffset, xscale +double sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] +int d_x1, d_x2 +int qpex_refd() + +bool fp_equald() + + +int qpex_parsed() +int stridxs(), btoi(), qpex_sublistd() +pointer qpex_dballoc(), qpex_dbpstr(), qpex_pbpos() +errchk qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parsed + +string qpexwarn "QPEX Warning" +define error_ 91 +define next_ 92 +define null_ 93 +define resume_ 94 +define bbmask_ 95 +define continue_ 96 +define XS Memd[xs+($1)-1] +define XE Memd[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) + # 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_ + } + + # 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_DOUBLE) + call malloc (xe_buf, xlen, TY_DOUBLE) + + # 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_parsed (expr, xs_buf, xe_buf, xlen) + if (xlen < nranges * 2) { + xlen = nranges * 2 + call realloc (xs_buf, xlen, TY_DOUBLE) + call realloc (xe_buf, xlen, TY_DOUBLE) + } + + 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) + d_x1 = qpex_refd (ex, x1) + d_x2 = qpex_refd (ex, x2) + + if (dtype == TY_SHORT) { + if (IS_LEFTD(x1) && IS_RIGHTD(x2)) + ; # pass everything (no tests) + else if (IS_LEFTD(x1)) + call qpex_pbpin (ex, LEQXS, offset, d_x2, 0) + else if (IS_RIGHTD(x2)) + call qpex_pbpin (ex, GEQXS, offset, d_x1, 0) + else if (fp_equald (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_LEFTD(x1) && IS_RIGHTD(x2)) + ; # pass everything (no tests) + else if (IS_LEFTD(x1)) + call qpex_pbpin (ex, LEQXD, offset, d_x2, 0) + else if (IS_RIGHTD(x2)) + call qpex_pbpin (ex, GEQXD, offset, d_x1, 0) + else if (fp_equald (x1, x2)) + call qpex_pbpin (ex, EQLXD, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXD, 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_LEFTD(XS(1)) && IS_RIGHTD(XE(2))) + if (fp_equald (XE(1), XS(2))) { + call qpex_pbpin (ex, NEQXD, offset, + qpex_refd(ex,XE(1)), 0) + goto resume_ + } + + # 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) { + opcode = LDDD + 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) + d_x1 = qpex_refd (ex, x1) + d_x2 = qpex_refd (ex, x2) + + if (IS_LEFTD(x1)) + call qpex_pbpin (ex, LEQD, d_x2, 0, 0) + else if (IS_RIGHTD(x2)) + call qpex_pbpin (ex, GEQD, d_x1, 0, 0) + else if (fp_equald (x1, x2)) + call qpex_pbpin (ex, EQLD, d_x1, d_x2, 0) + else + call qpex_pbpin (ex, RNGD, 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_LEFTD(xmin)) + xmin = XE(1) + xmax = XE(nranges) + if (IS_RIGHTD(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. + + nbins = min (EX_MAXRRLUTLEN(ex), nranges * EX_LUTSCALE(ex)) + + # Determine the mapping from data space to table space. + xoffset = xmin + xscale = nbins / (xmax - xmin) + + # 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_DOUBLE + LT_LUTP(lt) = lut + LT_NBINS(lt) = nbins + LT_D0(lt) = xoffset + LT_DS(lt) = xscale + LT_LEFT(lt) = btoi (IS_LEFTD(XS(1))) + LT_RIGHT(lt) = btoi (IS_RIGHTD(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, LUTXD, 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 + x2 = i / xscale + xoffset + + # Get sub-rangelist for range x1:x2. + n_nranges = qpex_sublistd (x1, x2, + Memd[xs], Memd[xe], nranges, xp, + Memd[n_xs], Memd[n_xe]) + + if (n_nranges <= 0) { + Mems[lut+i-1] = 0 + + } else if (n_nranges == 1 && IS_LEFTD(Memd[n_xs]) && + IS_RIGHTD(Memd[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 diff --git a/sys/qpoe/gen/qpexcodei.x b/sys/qpoe/gen/qpexcodei.x new file mode 100644 index 00000000..db8cbc72 --- /dev/null +++ b/sys/qpoe/gen/qpexcodei.x @@ -0,0 +1,423 @@ +# 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_codegeni (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 +int 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 + +int 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] + +int d_x1, d_x2 +real xoffset, xscale +real sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] + +define fp_equali($1==$2) + +bool complement +int maskval +int qp_ctoi() + +int qpex_parsei() +int stridxs(), btoi(), qpex_sublisti() +pointer qpex_dballoc(), qpex_dbpstr(), qpex_pbpos() +errchk qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parsei + +string qpexwarn "QPEX Warning" +define error_ 91 +define next_ 92 +define null_ 93 +define resume_ 94 +define bbmask_ 95 +define continue_ 96 +define XS Memi[xs+($1)-1] +define XE Memi[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) + # 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) + } + + # 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_INT) + call malloc (xe_buf, xlen, TY_INT) + + # 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_parsei (expr, xs_buf, xe_buf, xlen) + if (xlen < nranges * 2) { + xlen = nranges * 2 + call realloc (xs_buf, xlen, TY_INT) + call realloc (xe_buf, xlen, TY_INT) + } + + 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) + d_x1 = x1 + d_x2 = x2 + + if (dtype == TY_SHORT) { + if (IS_LEFTI(x1) && IS_RIGHTI(x2)) + ; # pass everything (no tests) + else if (IS_LEFTI(x1)) + call qpex_pbpin (ex, LEQXS, offset, d_x2, 0) + else if (IS_RIGHTI(x2)) + call qpex_pbpin (ex, GEQXS, offset, d_x1, 0) + else if (fp_equali (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_LEFTI(x1) && IS_RIGHTI(x2)) + ; # pass everything (no tests) + else if (IS_LEFTI(x1)) + call qpex_pbpin (ex, LEQXI, offset, d_x2, 0) + else if (IS_RIGHTI(x2)) + call qpex_pbpin (ex, GEQXI, offset, d_x1, 0) + else if (fp_equali (x1, x2)) + call qpex_pbpin (ex, EQLXI, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXI, 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_LEFTI(XS(1)) && IS_RIGHTI(XE(2))) + 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_ + } + + # 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 (dtype == TY_SHORT) + opcode = LDSI + else + opcode = LDII + 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) + d_x1 = x1 + d_x2 = x2 + + if (IS_LEFTI(x1)) + call qpex_pbpin (ex, LEQI, d_x2, 0, 0) + else if (IS_RIGHTI(x2)) + call qpex_pbpin (ex, GEQI, d_x1, 0, 0) + else if (fp_equali (x1, x2)) + call qpex_pbpin (ex, EQLI, d_x1, d_x2, 0) + else + call qpex_pbpin (ex, RNGI, 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_LEFTI(xmin)) + xmin = XE(1) + xmax = XE(nranges) + if (IS_RIGHTI(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. + + nbins = xmax - xmin + 1 + if (nbins > EX_MAXFRLUTLEN(ex)) + nbins = min (EX_MAXRRLUTLEN(ex), + nranges * EX_LUTSCALE(ex)) + + # Determine the mapping from data space to table space. + xoffset = xmin + xscale = nbins / (xmax - xmin + 1) + + # 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_INT + LT_LUTP(lt) = lut + LT_NBINS(lt) = nbins + LT_I0(lt) = xoffset + LT_IS(lt) = xscale + LT_LEFT(lt) = btoi (IS_LEFTI(XS(1))) + LT_RIGHT(lt) = btoi (IS_RIGHTI(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, LUTXI, 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 + x2 = i / xscale + xoffset - 1 + + # Get sub-rangelist for range x1:x2. + n_nranges = qpex_sublisti (x1, x2, + Memi[xs], Memi[xe], nranges, xp, + Memi[n_xs], Memi[n_xe]) + + if (n_nranges <= 0) { + Mems[lut+i-1] = 0 + + } else if (n_nranges == 1 && IS_LEFTI(Memi[n_xs]) && + IS_RIGHTI(Memi[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 diff --git a/sys/qpoe/gen/qpexcoder.x b/sys/qpoe/gen/qpexcoder.x new file mode 100644 index 00000000..30e1d85b --- /dev/null +++ b/sys/qpoe/gen/qpexcoder.x @@ -0,0 +1,368 @@ +# 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_codegenr (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 +real 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 + +real 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] + +real d_x1, d_x2 +real xoffset, xscale +real sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] + +bool fp_equalr() + + +int qpex_parser() +int stridxs(), btoi(), qpex_sublistr() +pointer qpex_dballoc(), qpex_dbpstr(), qpex_pbpos() +errchk qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parser + +string qpexwarn "QPEX Warning" +define error_ 91 +define next_ 92 +define null_ 93 +define resume_ 94 +define bbmask_ 95 +define continue_ 96 +define XS Memr[xs+($1)-1] +define XE Memr[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) + # 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_ + } + + # 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_REAL) + call malloc (xe_buf, xlen, TY_REAL) + + # 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_parser (expr, xs_buf, xe_buf, xlen) + if (xlen < nranges * 2) { + xlen = nranges * 2 + call realloc (xs_buf, xlen, TY_REAL) + call realloc (xe_buf, xlen, TY_REAL) + } + + 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) + d_x1 = x1 + d_x2 = x2 + + if (dtype == TY_SHORT) { + if (IS_LEFTR(x1) && IS_RIGHTR(x2)) + ; # pass everything (no tests) + else if (IS_LEFTR(x1)) + call qpex_pbpin (ex, LEQXS, offset, d_x2, 0) + else if (IS_RIGHTR(x2)) + call qpex_pbpin (ex, GEQXS, offset, d_x1, 0) + else if (fp_equalr (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_LEFTR(x1) && IS_RIGHTR(x2)) + ; # pass everything (no tests) + else if (IS_LEFTR(x1)) + call qpex_pbpin (ex, LEQXR, offset, d_x2, 0) + else if (IS_RIGHTR(x2)) + call qpex_pbpin (ex, GEQXR, offset, d_x1, 0) + else if (fp_equalr (x1, x2)) + call qpex_pbpin (ex, EQLXR, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXR, 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_LEFTR(XS(1)) && IS_RIGHTR(XE(2))) + if (fp_equalr (XE(1), XS(2))) { + call qpex_pbpin (ex, NEQXR, offset, XE(1), 0) + goto resume_ + } + + # 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) { + opcode = LDRR + 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) + d_x1 = x1 + d_x2 = x2 + + if (IS_LEFTR(x1)) + call qpex_pbpin (ex, LEQR, d_x2, 0, 0) + else if (IS_RIGHTR(x2)) + call qpex_pbpin (ex, GEQR, d_x1, 0, 0) + else if (fp_equalr (x1, x2)) + call qpex_pbpin (ex, EQLR, d_x1, d_x2, 0) + else + call qpex_pbpin (ex, RNGR, 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_LEFTR(xmin)) + xmin = XE(1) + xmax = XE(nranges) + if (IS_RIGHTR(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. + + nbins = min (EX_MAXRRLUTLEN(ex), nranges * EX_LUTSCALE(ex)) + + # Determine the mapping from data space to table space. + xoffset = xmin + xscale = nbins / (xmax - xmin) + + # 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_REAL + LT_LUTP(lt) = lut + LT_NBINS(lt) = nbins + LT_R0(lt) = xoffset + LT_RS(lt) = xscale + LT_LEFT(lt) = btoi (IS_LEFTR(XS(1))) + LT_RIGHT(lt) = btoi (IS_RIGHTR(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, LUTXR, 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 + x2 = i / xscale + xoffset + + # Get sub-rangelist for range x1:x2. + n_nranges = qpex_sublistr (x1, x2, + Memr[xs], Memr[xe], nranges, xp, + Memr[n_xs], Memr[n_xe]) + + if (n_nranges <= 0) { + Mems[lut+i-1] = 0 + + } else if (n_nranges == 1 && IS_LEFTR(Memr[n_xs]) && + IS_RIGHTR(Memr[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 diff --git a/sys/qpoe/gen/qpexparsed.x b/sys/qpoe/gen/qpexparsed.x new file mode 100644 index 00000000..ec625bd8 --- /dev/null +++ b/sys/qpoe/gen/qpexparsed.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <mach.h> +include "../qpex.h" + +.help qpexparse +.nf -------------------------------------------------------------------------- +QPEXPARSE -- Code to parse an event attribute expression, producing a binary +range list as output. + + nranges = qpex_parse[ird] (expr, xs, xe, xlen) + +The calling sequence for the parse routine is shown above. The arguments XS +and XE are pointers to dynamically allocated arrays of length XLEN and type +[IRD]. These arrays should be allocated in the calling program before calling +the parser, and deallocated when no longer needed. Reallocation to increase +the array length is automatic if the arrays fill during parsing. DTYPE should +be the same datatype as the attribute with which the list is associated. + +The form of an event attribute expression may be a list of values, + + attribute = n +or + attribute = m, n, ... + +a list of inclusive or exclusive ranges, + + attribute = m:n, !p:q + +including open ranges, + + attribute = :n, p:q + +or any combination of the above (excluding combinations of bitmasks and values +or ranges, which are mutually exclusive): + + attribute = :n, a, b, p:q, !(m, e:f) + +Parenthesis may be used for grouping where desired, e.g., + + attribute = (:n, a, b, p:q, !(m, e:f)) + +An additional form of the event attribute expression allows use of a bitmask +to specify the acceptable values, e.g., + + attribute = %17B +or + attribute = !%17B + +however, bitmasks are incompatible with range lists, and should be recognized +and dealt with elsewhere (bitmasks may not be combined with range lists in +the same expression term). + +We are concerned here only with the attribute value list itself, i.e., +everything to the right of the equals sign in the examples above. This list +should be extracted and placed into a string containing a single line of +text before we are called. Attribute value lists may be any length, but +backslash continuation, file inclusion (or whatever means is used to form +the attribute value list) is assumed to be handled at a higher level. + +The output of this package is an ordered boolean valued binary range list +with type integer, real, or double breakpoints (i.e., the breakpoints are the +same datatype as the attribute itself, but the range values are zero or one). +The range list defines the initial value, final value, and any interior +breakpoints where the attribute value changes state. Expression optimization +is used to minimize the number of breakpoints (i.e., eliminate redundant +breakpoints, such as a range within a range). + +Output range list format: + + xs[1] xe[1] + xs[2] xe[2] + ... + xs[N] xe[N] + +Where each range is inclusive and only "true" ranges are shown. If XS[1] is +LEFT a open-left range (:n) is indicated; if XE[N] is RIGHT an open-right +range (n:) is indicated. In an integer range list, isolated points appear +as a single range with (xe[i]=xs[i]). In a real or double range list, +isolated points are represented as finite ranges with a width on the order of +the machine epsilon. +.endhelp --------------------------------------------------------------------- + +define DEF_XLEN 256 # default output range list length +define INC_XLEN 256 # increment to above +define DEF_VLEN 512 # default breakpoint list length +define INC_VLEN 512 # increment to above +define MAX_NEST 20 # parser stack depth + +define STEP 1 # step at boundary of closed range +define ZERO 1000 # step at boundary of open range + +define XV Memd[xv+($1)-1] # reference x position values +define UV Memi[uv+($1)-1] # unique flags for x value pairs +define SV Memi[sv+($1)-1] # reference breakpoint step values + + +# QPEX_PARSE -- Convert the given attribute value list into a binary +# range list, returning the number of ranges as the function value. + +int procedure qpex_parsed (expr, xs, xe, xlen) + +char expr[ARB] #I attribute value list to be parsed +pointer xs #U pointer to array of start-range values +pointer xe #U pointer to array of end-range values +int xlen #U allocated length of XS, XE arrays + +bool range +pointer xv, uv, sv +double xstart, xend, xmin, temp, x, n_xs, n_xe +int vlen, nrg, ip, op, ch, ip_start, i, j, jval, r1, r2, y, v, ov, dy +int token[MAX_NEST], tokval[MAX_NEST], lev, itemp, umin +errchk syserr, malloc, realloc +define pop_ 91 + +double dtemp +bool bval, fp_equald() +int qp_ctod() + +begin + vlen = DEF_VLEN + call malloc (xv, vlen, TY_DOUBLE) + call malloc (uv, vlen, TY_INT) + call malloc (sv, vlen, TY_INT) + + lev = 0 + nrg = 0 + + # Parse the expression string and compile the raw, unoptimized + # breakpoint list in the order in which the breakpoints occur in + # the string. + + for (ip=1; expr[ip] != EOS; ) { + # Skip whitespace. + for (ch=expr[ip]; IS_WHITE(ch) || ch == '\n'; ch=expr[ip]) + ip = ip + 1 + + # Extract and process token. + switch (ch) { + case EOS: + # At end of string. + if (lev > 0) + goto pop_ + else + break + + case ',': + # Comma list token delmiter. + ip = ip + 1 + goto pop_ + + case '!', '(': + # Syntactical element - push on stack. + ip = ip + 1 + lev = lev + 1 + if (lev > MAX_NEST) + call syserr (SYS_QPEXLEVEL) + token[lev] = ch + tokval[lev] = nrg + 1 + + case ')': + # Close parenthesized group and pop parser stack. + ip = ip + 1 + if (lev < 1) + call syserr (SYS_QPEXMLP) + else if (token[lev] != '(') + call syserr (SYS_QPEXRPAREN) + lev = lev - 1 + goto pop_ + + default: + # Process a range term. + ip_start = ip + + # Scan the M in M:N. + if (qp_ctod (expr, ip, dtemp) <= 0) + xstart = LEFTD + else + xstart = dtemp + + # Scan the : in M:N. The notation M-N is also accepted, + # provided the token - immediately follows the token M. + + while (IS_WHITE(expr[ip])) + ip = ip + 1 + range = (expr[ip] == ':') + if (range) + ip = ip + 1 + else if (!IS_LEFTD (xstart)) { + range = (expr[ip] == '-') + if (range) + ip = ip + 1 + } + + # Scan the N in M:N. + if (range) { + if (qp_ctod (expr, ip, dtemp) <= 0) + xend = RIGHTD + else + xend = dtemp + } else + xend = xstart + + # Fix things if the user entered M:M explicitly. + if (range) + if (fp_equald (xstart, xend)) + range = false + + # Expand a single point into a range. For an integer list + # this produces M:M+1; for a floating list M-eps:M+eps. + # Verify ordering and that something recognizable was scanned. + + if (!range) { + if (IS_LEFTD(xstart)) + call syserr (SYS_QPEXBADRNG) + } else { + if (xstart > xend) { + temp = xstart; xstart = xend; xend = temp + } + } + + # Make more space if vectors fill up. + if (nrg+4 > vlen) { + vlen = vlen + INC_VLEN + call realloc (xv, vlen, TY_DOUBLE) + call realloc (uv, vlen, TY_INT) + call realloc (sv, vlen, TY_INT) + } + + # Save range on intermediate breakpoint list. + nrg = nrg + 1 + XV(nrg) = xstart + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = xend + UV(nrg) = 1 + SV(nrg) = -STEP +pop_ + # Pop parser stack. + if (lev > 0) + if (token[lev] == '!') { + # Invert a series of breakpoints. + do i = tokval[lev], nrg { + if (SV(i) == STEP) # invert + SV(i) = -ZERO + else if (SV(i) == -STEP) + SV(i) = ZERO + else if (SV(i) == ZERO) # undo + SV(i) = -STEP + else if (SV(i) == -ZERO) + SV(i) = STEP + } + lev = lev - 1 + } + } + } + + # If the first range entered by the user is an exclude range, + # e.g., "(!N)" or "(!(expr))" this implies that all other values + # are acceptable. Add the open range ":" to the end of the range + # list to indicate this, i.e., convert "!N" to ":,!N". + + if (SV(1) == -ZERO) { + nrg = nrg + 1 + XV(nrg) = LEFTD + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = RIGHTD + UV(nrg) = 1 + SV(nrg) = -STEP + } + + # Sort the breakpoint list. + do j = 1, nrg { + xmin = XV(j); umin = UV(j) + jval = j + do i = j+1, nrg { + bval = (XV(i) < xmin) + if (!bval) + if (abs (XV(i) - xmin) < 1.0E-5) + bval = (fp_equald(XV(i),xmin) && UV(i) < umin) + if (bval) { + xmin = XV(i); umin = UV(i) + jval = i + } + } + if (jval != j) { + temp = XV(j); XV(j) = XV(jval); XV(jval) = temp + itemp = UV(j); UV(j) = UV(jval); UV(jval) = itemp + itemp = SV(j); SV(j) = SV(jval); SV(jval) = itemp + } + } + + # Initialize the output arrays if they were passed in as null. + if (xlen <= 0) { + xlen = DEF_XLEN + call malloc (xs, xlen, TY_DOUBLE) + call malloc (xe, xlen, TY_DOUBLE) + } + + # Collapse sequences of redundant breakpoints into a single + # breakpoint, clipping the running sum value to the range 0-1. + # Accumulate and output successive nonzero ranges. + + op = 1 + ov = 0 + y = 0 + + for (r1=1; r1 <= nrg; r1=r2+1) { + # Get a range of breakpoint entries for a single XV position. + for (r2=r1; r2 <= nrg; r2=r2+1) { + bval = (UV(r2) != UV(r1)) + if (!bval) { + bval = (abs (XV(r2) - XV(r1)) > 1.0E-5) + if (!bval) + bval = !fp_equald(XV(r2),XV(r1)) + } + if (bval) + break + } + r2 = r2 - 1 + + # Collapse into a single breakpoint. + x = XV(r1) + dy = SV(r1) + do i = r1 + 1, r2 + dy = dy + SV(i) + y = y + dy + + # Clip value to the range 0-1. + v = max(0, min(1, y)) + + # Accumulate a range of nonzero value. This eliminates redundant + # points lying within a range which is already set high. + + if (v == 1 && ov == 0) { + n_xs = x + ov = 1 + } else if (v == 0 && ov == 1) { + n_xe = x + ov = 2 + } + + # Output a range. + if (ov == 2) { + if (op > xlen) { + xlen = xlen + INC_XLEN + call realloc (xs, xlen, TY_DOUBLE) + call realloc (xe, xlen, TY_DOUBLE) + } + + Memd[xs+op-1] = n_xs + Memd[xe+op-1] = n_xe + op = op + 1 + + ov = 0 + } + } + + # All done; discard breakpoint buffers. + call mfree (xv, TY_DOUBLE) + call mfree (uv, TY_INT) + call mfree (sv, TY_INT) + + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexparsei.x b/sys/qpoe/gen/qpexparsei.x new file mode 100644 index 00000000..17d6a569 --- /dev/null +++ b/sys/qpoe/gen/qpexparsei.x @@ -0,0 +1,363 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <mach.h> +include "../qpex.h" + +.help qpexparse +.nf -------------------------------------------------------------------------- +QPEXPARSE -- Code to parse an event attribute expression, producing a binary +range list as output. + + nranges = qpex_parse[ird] (expr, xs, xe, xlen) + +The calling sequence for the parse routine is shown above. The arguments XS +and XE are pointers to dynamically allocated arrays of length XLEN and type +[IRD]. These arrays should be allocated in the calling program before calling +the parser, and deallocated when no longer needed. Reallocation to increase +the array length is automatic if the arrays fill during parsing. DTYPE should +be the same datatype as the attribute with which the list is associated. + +The form of an event attribute expression may be a list of values, + + attribute = n +or + attribute = m, n, ... + +a list of inclusive or exclusive ranges, + + attribute = m:n, !p:q + +including open ranges, + + attribute = :n, p:q + +or any combination of the above (excluding combinations of bitmasks and values +or ranges, which are mutually exclusive): + + attribute = :n, a, b, p:q, !(m, e:f) + +Parenthesis may be used for grouping where desired, e.g., + + attribute = (:n, a, b, p:q, !(m, e:f)) + +An additional form of the event attribute expression allows use of a bitmask +to specify the acceptable values, e.g., + + attribute = %17B +or + attribute = !%17B + +however, bitmasks are incompatible with range lists, and should be recognized +and dealt with elsewhere (bitmasks may not be combined with range lists in +the same expression term). + +We are concerned here only with the attribute value list itself, i.e., +everything to the right of the equals sign in the examples above. This list +should be extracted and placed into a string containing a single line of +text before we are called. Attribute value lists may be any length, but +backslash continuation, file inclusion (or whatever means is used to form +the attribute value list) is assumed to be handled at a higher level. + +The output of this package is an ordered boolean valued binary range list +with type integer, real, or double breakpoints (i.e., the breakpoints are the +same datatype as the attribute itself, but the range values are zero or one). +The range list defines the initial value, final value, and any interior +breakpoints where the attribute value changes state. Expression optimization +is used to minimize the number of breakpoints (i.e., eliminate redundant +breakpoints, such as a range within a range). + +Output range list format: + + xs[1] xe[1] + xs[2] xe[2] + ... + xs[N] xe[N] + +Where each range is inclusive and only "true" ranges are shown. If XS[1] is +LEFT a open-left range (:n) is indicated; if XE[N] is RIGHT an open-right +range (n:) is indicated. In an integer range list, isolated points appear +as a single range with (xe[i]=xs[i]). In a real or double range list, +isolated points are represented as finite ranges with a width on the order of +the machine epsilon. +.endhelp --------------------------------------------------------------------- + +define DEF_XLEN 256 # default output range list length +define INC_XLEN 256 # increment to above +define DEF_VLEN 512 # default breakpoint list length +define INC_VLEN 512 # increment to above +define MAX_NEST 20 # parser stack depth + +define STEP 1 # step at boundary of closed range +define ZERO 1000 # step at boundary of open range + +define XV Memi[xv+($1)-1] # reference x position values +define UV Memi[uv+($1)-1] # unique flags for x value pairs +define SV Memi[sv+($1)-1] # reference breakpoint step values + + +# QPEX_PARSE -- Convert the given attribute value list into a binary +# range list, returning the number of ranges as the function value. + +int procedure qpex_parsei (expr, xs, xe, xlen) + +char expr[ARB] #I attribute value list to be parsed +pointer xs #U pointer to array of start-range values +pointer xe #U pointer to array of end-range values +int xlen #U allocated length of XS, XE arrays + +bool range +pointer xv, uv, sv +int xstart, xend, xmin, temp, x, n_xs, n_xe +int vlen, nrg, ip, op, ch, ip_start, i, j, jval, r1, r2, y, v, ov, dy +int token[MAX_NEST], tokval[MAX_NEST], lev, itemp, umin +errchk syserr, malloc, realloc +define pop_ 91 + +int qp_ctoi() +define fp_equali($1==$2) + +begin + vlen = DEF_VLEN + call malloc (xv, vlen, TY_INT) + call malloc (uv, vlen, TY_INT) + call malloc (sv, vlen, TY_INT) + + lev = 0 + nrg = 0 + + # Parse the expression string and compile the raw, unoptimized + # breakpoint list in the order in which the breakpoints occur in + # the string. + + for (ip=1; expr[ip] != EOS; ) { + # Skip whitespace. + for (ch=expr[ip]; IS_WHITE(ch) || ch == '\n'; ch=expr[ip]) + ip = ip + 1 + + # Extract and process token. + switch (ch) { + case EOS: + # At end of string. + if (lev > 0) + goto pop_ + else + break + + case ',': + # Comma list token delmiter. + ip = ip + 1 + goto pop_ + + case '!', '(': + # Syntactical element - push on stack. + ip = ip + 1 + lev = lev + 1 + if (lev > MAX_NEST) + call syserr (SYS_QPEXLEVEL) + token[lev] = ch + tokval[lev] = nrg + 1 + + case ')': + # Close parenthesized group and pop parser stack. + ip = ip + 1 + if (lev < 1) + call syserr (SYS_QPEXMLP) + else if (token[lev] != '(') + call syserr (SYS_QPEXRPAREN) + lev = lev - 1 + goto pop_ + + default: + # Process a range term. + ip_start = ip + + # Scan the M in M:N. + if (qp_ctoi (expr, ip, xstart) <= 0) + xstart = LEFTI + + # Scan the : in M:N. The notation M-N is also accepted, + # provided the token - immediately follows the token M. + + while (IS_WHITE(expr[ip])) + ip = ip + 1 + range = (expr[ip] == ':') + if (range) + ip = ip + 1 + else if (!IS_LEFTI (xstart)) { + range = (expr[ip] == '-') + if (range) + ip = ip + 1 + } + + # Scan the N in M:N. + if (range) { + if (qp_ctoi (expr, ip, xend) <= 0) + xend = RIGHTI + } else + xend = xstart + + # Fix things if the user entered M:M explicitly. + if (range) + if (fp_equali (xstart, xend)) + range = false + + # Expand a single point into a range. For an integer list + # this produces M:M+1; for a floating list M-eps:M+eps. + # Verify ordering and that something recognizable was scanned. + + if (!range) { + if (IS_LEFTI(xstart)) + call syserr (SYS_QPEXBADRNG) + xend = xstart + 1 + } else { + if (xstart > xend) { + temp = xstart; xstart = xend; xend = temp + } + if (!IS_RIGHTI(xend)) + xend = xend + 1 + } + + # Make more space if vectors fill up. + if (nrg+4 > vlen) { + vlen = vlen + INC_VLEN + call realloc (xv, vlen, TY_INT) + call realloc (uv, vlen, TY_INT) + call realloc (sv, vlen, TY_INT) + } + + # Save range on intermediate breakpoint list. + nrg = nrg + 1 + XV(nrg) = xstart + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = xend + UV(nrg) = 1 + SV(nrg) = -STEP +pop_ + # Pop parser stack. + if (lev > 0) + if (token[lev] == '!') { + # Invert a series of breakpoints. + do i = tokval[lev], nrg { + if (SV(i) == STEP) # invert + SV(i) = -ZERO + else if (SV(i) == -STEP) + SV(i) = ZERO + else if (SV(i) == ZERO) # undo + SV(i) = -STEP + else if (SV(i) == -ZERO) + SV(i) = STEP + } + lev = lev - 1 + } + } + } + + # If the first range entered by the user is an exclude range, + # e.g., "(!N)" or "(!(expr))" this implies that all other values + # are acceptable. Add the open range ":" to the end of the range + # list to indicate this, i.e., convert "!N" to ":,!N". + + if (SV(1) == -ZERO) { + nrg = nrg + 1 + XV(nrg) = LEFTI + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = RIGHTI + UV(nrg) = 1 + SV(nrg) = -STEP + } + + # Sort the breakpoint list. + do j = 1, nrg { + xmin = XV(j); umin = UV(j) + jval = j + do i = j+1, nrg { + if (XV(i) < xmin || (XV(i) == xmin && UV(i) < umin)) { + xmin = XV(i); umin = UV(i) + jval = i + } + } + if (jval != j) { + temp = XV(j); XV(j) = XV(jval); XV(jval) = temp + itemp = UV(j); UV(j) = UV(jval); UV(jval) = itemp + itemp = SV(j); SV(j) = SV(jval); SV(jval) = itemp + } + } + + # Initialize the output arrays if they were passed in as null. + if (xlen <= 0) { + xlen = DEF_XLEN + call malloc (xs, xlen, TY_INT) + call malloc (xe, xlen, TY_INT) + } + + # Collapse sequences of redundant breakpoints into a single + # breakpoint, clipping the running sum value to the range 0-1. + # Accumulate and output successive nonzero ranges. + + op = 1 + ov = 0 + y = 0 + + for (r1=1; r1 <= nrg; r1=r2+1) { + # Get a range of breakpoint entries for a single XV position. + for (r2=r1; r2 <= nrg; r2=r2+1) { + if (XV(r2) != XV(r1)) + break + } + r2 = r2 - 1 + + # Collapse into a single breakpoint. + x = XV(r1) + dy = SV(r1) + do i = r1 + 1, r2 + dy = dy + SV(i) + y = y + dy + + # Clip value to the range 0-1. + v = max(0, min(1, y)) + + # Accumulate a range of nonzero value. This eliminates redundant + # points lying within a range which is already set high. + + if (v == 1 && ov == 0) { + n_xs = x + ov = 1 + } else if (v == 0 && ov == 1) { + if (IS_RIGHTI(x)) + n_xe = x + else + n_xe = x - 1 + ov = 2 + } + + # Output a range. + if (ov == 2) { + if (op > xlen) { + xlen = xlen + INC_XLEN + call realloc (xs, xlen, TY_INT) + call realloc (xe, xlen, TY_INT) + } + + Memi[xs+op-1] = n_xs + Memi[xe+op-1] = n_xe + op = op + 1 + + ov = 0 + } + } + + # All done; discard breakpoint buffers. + call mfree (xv, TY_INT) + call mfree (uv, TY_INT) + call mfree (sv, TY_INT) + + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexparser.x b/sys/qpoe/gen/qpexparser.x new file mode 100644 index 00000000..bf4c849e --- /dev/null +++ b/sys/qpoe/gen/qpexparser.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <mach.h> +include "../qpex.h" + +.help qpexparse +.nf -------------------------------------------------------------------------- +QPEXPARSE -- Code to parse an event attribute expression, producing a binary +range list as output. + + nranges = qpex_parse[ird] (expr, xs, xe, xlen) + +The calling sequence for the parse routine is shown above. The arguments XS +and XE are pointers to dynamically allocated arrays of length XLEN and type +[IRD]. These arrays should be allocated in the calling program before calling +the parser, and deallocated when no longer needed. Reallocation to increase +the array length is automatic if the arrays fill during parsing. DTYPE should +be the same datatype as the attribute with which the list is associated. + +The form of an event attribute expression may be a list of values, + + attribute = n +or + attribute = m, n, ... + +a list of inclusive or exclusive ranges, + + attribute = m:n, !p:q + +including open ranges, + + attribute = :n, p:q + +or any combination of the above (excluding combinations of bitmasks and values +or ranges, which are mutually exclusive): + + attribute = :n, a, b, p:q, !(m, e:f) + +Parenthesis may be used for grouping where desired, e.g., + + attribute = (:n, a, b, p:q, !(m, e:f)) + +An additional form of the event attribute expression allows use of a bitmask +to specify the acceptable values, e.g., + + attribute = %17B +or + attribute = !%17B + +however, bitmasks are incompatible with range lists, and should be recognized +and dealt with elsewhere (bitmasks may not be combined with range lists in +the same expression term). + +We are concerned here only with the attribute value list itself, i.e., +everything to the right of the equals sign in the examples above. This list +should be extracted and placed into a string containing a single line of +text before we are called. Attribute value lists may be any length, but +backslash continuation, file inclusion (or whatever means is used to form +the attribute value list) is assumed to be handled at a higher level. + +The output of this package is an ordered boolean valued binary range list +with type integer, real, or double breakpoints (i.e., the breakpoints are the +same datatype as the attribute itself, but the range values are zero or one). +The range list defines the initial value, final value, and any interior +breakpoints where the attribute value changes state. Expression optimization +is used to minimize the number of breakpoints (i.e., eliminate redundant +breakpoints, such as a range within a range). + +Output range list format: + + xs[1] xe[1] + xs[2] xe[2] + ... + xs[N] xe[N] + +Where each range is inclusive and only "true" ranges are shown. If XS[1] is +LEFT a open-left range (:n) is indicated; if XE[N] is RIGHT an open-right +range (n:) is indicated. In an integer range list, isolated points appear +as a single range with (xe[i]=xs[i]). In a real or double range list, +isolated points are represented as finite ranges with a width on the order of +the machine epsilon. +.endhelp --------------------------------------------------------------------- + +define DEF_XLEN 256 # default output range list length +define INC_XLEN 256 # increment to above +define DEF_VLEN 512 # default breakpoint list length +define INC_VLEN 512 # increment to above +define MAX_NEST 20 # parser stack depth + +define STEP 1 # step at boundary of closed range +define ZERO 1000 # step at boundary of open range + +define XV Memr[xv+($1)-1] # reference x position values +define UV Memi[uv+($1)-1] # unique flags for x value pairs +define SV Memi[sv+($1)-1] # reference breakpoint step values + + +# QPEX_PARSE -- Convert the given attribute value list into a binary +# range list, returning the number of ranges as the function value. + +int procedure qpex_parser (expr, xs, xe, xlen) + +char expr[ARB] #I attribute value list to be parsed +pointer xs #U pointer to array of start-range values +pointer xe #U pointer to array of end-range values +int xlen #U allocated length of XS, XE arrays + +bool range +pointer xv, uv, sv +real xstart, xend, xmin, temp, x, n_xs, n_xe +int vlen, nrg, ip, op, ch, ip_start, i, j, jval, r1, r2, y, v, ov, dy +int token[MAX_NEST], tokval[MAX_NEST], lev, itemp, umin +errchk syserr, malloc, realloc +define pop_ 91 + +double dtemp +bool bval, fp_equalr() +int qp_ctod() + +begin + vlen = DEF_VLEN + call malloc (xv, vlen, TY_REAL) + call malloc (uv, vlen, TY_INT) + call malloc (sv, vlen, TY_INT) + + lev = 0 + nrg = 0 + + # Parse the expression string and compile the raw, unoptimized + # breakpoint list in the order in which the breakpoints occur in + # the string. + + for (ip=1; expr[ip] != EOS; ) { + # Skip whitespace. + for (ch=expr[ip]; IS_WHITE(ch) || ch == '\n'; ch=expr[ip]) + ip = ip + 1 + + # Extract and process token. + switch (ch) { + case EOS: + # At end of string. + if (lev > 0) + goto pop_ + else + break + + case ',': + # Comma list token delmiter. + ip = ip + 1 + goto pop_ + + case '!', '(': + # Syntactical element - push on stack. + ip = ip + 1 + lev = lev + 1 + if (lev > MAX_NEST) + call syserr (SYS_QPEXLEVEL) + token[lev] = ch + tokval[lev] = nrg + 1 + + case ')': + # Close parenthesized group and pop parser stack. + ip = ip + 1 + if (lev < 1) + call syserr (SYS_QPEXMLP) + else if (token[lev] != '(') + call syserr (SYS_QPEXRPAREN) + lev = lev - 1 + goto pop_ + + default: + # Process a range term. + ip_start = ip + + # Scan the M in M:N. + if (qp_ctod (expr, ip, dtemp) <= 0) + xstart = LEFTR + else + xstart = dtemp + + # Scan the : in M:N. The notation M-N is also accepted, + # provided the token - immediately follows the token M. + + while (IS_WHITE(expr[ip])) + ip = ip + 1 + range = (expr[ip] == ':') + if (range) + ip = ip + 1 + else if (!IS_LEFTR (xstart)) { + range = (expr[ip] == '-') + if (range) + ip = ip + 1 + } + + # Scan the N in M:N. + if (range) { + if (qp_ctod (expr, ip, dtemp) <= 0) + xend = RIGHTR + else + xend = dtemp + } else + xend = xstart + + # Fix things if the user entered M:M explicitly. + if (range) + if (fp_equalr (xstart, xend)) + range = false + + # Expand a single point into a range. For an integer list + # this produces M:M+1; for a floating list M-eps:M+eps. + # Verify ordering and that something recognizable was scanned. + + if (!range) { + if (IS_LEFTR(xstart)) + call syserr (SYS_QPEXBADRNG) + } else { + if (xstart > xend) { + temp = xstart; xstart = xend; xend = temp + } + } + + # Make more space if vectors fill up. + if (nrg+4 > vlen) { + vlen = vlen + INC_VLEN + call realloc (xv, vlen, TY_REAL) + call realloc (uv, vlen, TY_INT) + call realloc (sv, vlen, TY_INT) + } + + # Save range on intermediate breakpoint list. + nrg = nrg + 1 + XV(nrg) = xstart + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = xend + UV(nrg) = 1 + SV(nrg) = -STEP +pop_ + # Pop parser stack. + if (lev > 0) + if (token[lev] == '!') { + # Invert a series of breakpoints. + do i = tokval[lev], nrg { + if (SV(i) == STEP) # invert + SV(i) = -ZERO + else if (SV(i) == -STEP) + SV(i) = ZERO + else if (SV(i) == ZERO) # undo + SV(i) = -STEP + else if (SV(i) == -ZERO) + SV(i) = STEP + } + lev = lev - 1 + } + } + } + + # If the first range entered by the user is an exclude range, + # e.g., "(!N)" or "(!(expr))" this implies that all other values + # are acceptable. Add the open range ":" to the end of the range + # list to indicate this, i.e., convert "!N" to ":,!N". + + if (SV(1) == -ZERO) { + nrg = nrg + 1 + XV(nrg) = LEFTR + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = RIGHTR + UV(nrg) = 1 + SV(nrg) = -STEP + } + + # Sort the breakpoint list. + do j = 1, nrg { + xmin = XV(j); umin = UV(j) + jval = j + do i = j+1, nrg { + bval = (XV(i) < xmin) + if (!bval) + if (abs (XV(i) - xmin) < 1.0E-5) + bval = (fp_equalr(XV(i),xmin) && UV(i) < umin) + if (bval) { + xmin = XV(i); umin = UV(i) + jval = i + } + } + if (jval != j) { + temp = XV(j); XV(j) = XV(jval); XV(jval) = temp + itemp = UV(j); UV(j) = UV(jval); UV(jval) = itemp + itemp = SV(j); SV(j) = SV(jval); SV(jval) = itemp + } + } + + # Initialize the output arrays if they were passed in as null. + if (xlen <= 0) { + xlen = DEF_XLEN + call malloc (xs, xlen, TY_REAL) + call malloc (xe, xlen, TY_REAL) + } + + # Collapse sequences of redundant breakpoints into a single + # breakpoint, clipping the running sum value to the range 0-1. + # Accumulate and output successive nonzero ranges. + + op = 1 + ov = 0 + y = 0 + + for (r1=1; r1 <= nrg; r1=r2+1) { + # Get a range of breakpoint entries for a single XV position. + for (r2=r1; r2 <= nrg; r2=r2+1) { + bval = (UV(r2) != UV(r1)) + if (!bval) { + bval = (abs (XV(r2) - XV(r1)) > 1.0E-5) + if (!bval) + bval = !fp_equalr(XV(r2),XV(r1)) + } + if (bval) + break + } + r2 = r2 - 1 + + # Collapse into a single breakpoint. + x = XV(r1) + dy = SV(r1) + do i = r1 + 1, r2 + dy = dy + SV(i) + y = y + dy + + # Clip value to the range 0-1. + v = max(0, min(1, y)) + + # Accumulate a range of nonzero value. This eliminates redundant + # points lying within a range which is already set high. + + if (v == 1 && ov == 0) { + n_xs = x + ov = 1 + } else if (v == 0 && ov == 1) { + n_xe = x + ov = 2 + } + + # Output a range. + if (ov == 2) { + if (op > xlen) { + xlen = xlen + INC_XLEN + call realloc (xs, xlen, TY_REAL) + call realloc (xe, xlen, TY_REAL) + } + + Memr[xs+op-1] = n_xs + Memr[xe+op-1] = n_xe + op = op + 1 + + ov = 0 + } + } + + # All done; discard breakpoint buffers. + call mfree (xv, TY_REAL) + call mfree (uv, TY_INT) + call mfree (sv, TY_INT) + + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexsubd.x b/sys/qpoe/gen/qpexsubd.x new file mode 100644 index 00000000..2fab50fd --- /dev/null +++ b/sys/qpoe/gen/qpexsubd.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "../qpex.h" + +# QPEX_SUBLIST -- Extract a sublist spanning the indicated range from a +# larger range list. The number of ranges extracted is returned as the +# function value. + +int procedure qpex_sublistd (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + +double x1, x2 #I range to be extracted +double xs[nranges],xe[nranges] #I input range list +int nranges #I nranges in input list +int ip #U start position in input list +double o_xs[ARB],o_xe[ARB] #O output sublist + +double tol +int op, i + +begin + tol = (EPSILOND * 10.0D0) + + # Determine the range containing or immediately following the + # start point of the range of interest. + + while (x1 < xs[ip] && ip > 1) + ip = ip - 1 + while (x1 >= xs[ip]) + if (x1 <= xe[ip] || ip >= nranges) + break + else + ip = ip + 1 + + # Check for an empty output range list. + if (xs[ip] > x2) + return (0) + + # At least one input range contributes something to the output region. + # Copy a portion of the input range list to the ouput range list. + + op = 1 + do i = ip, nranges { + if (xs[i] <= x1) + o_xs[op] = LEFTD - tol + else + o_xs[op] = xs[i] + + if ((xe[i] - x2) >= tol) { + o_xe[op] = RIGHTD + tol + op = op + 1 + break + } else + o_xe[op] = xe[i] + + op = op + 1 + if (xs[i+1] > x2) + break + } + + ip = i + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexsubi.x b/sys/qpoe/gen/qpexsubi.x new file mode 100644 index 00000000..62ce5087 --- /dev/null +++ b/sys/qpoe/gen/qpexsubi.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "../qpex.h" + +# QPEX_SUBLIST -- Extract a sublist spanning the indicated range from a +# larger range list. The number of ranges extracted is returned as the +# function value. + +int procedure qpex_sublisti (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + +int x1, x2 #I range to be extracted +int xs[nranges],xe[nranges] #I input range list +int nranges #I nranges in input list +int ip #U start position in input list +int o_xs[ARB],o_xe[ARB] #O output sublist + +int tol +int op, i + +begin + tol = 0 + + # Determine the range containing or immediately following the + # start point of the range of interest. + + while (x1 < xs[ip] && ip > 1) + ip = ip - 1 + while (x1 >= xs[ip]) + if (x1 <= xe[ip] || ip >= nranges) + break + else + ip = ip + 1 + + # Check for an empty output range list. + if (xs[ip] > x2) + return (0) + + # At least one input range contributes something to the output region. + # Copy a portion of the input range list to the ouput range list. + + op = 1 + do i = ip, nranges { + if (xs[i] <= x1) + o_xs[op] = LEFTI - tol + else + o_xs[op] = xs[i] + + if ((xe[i] - x2) >= tol) { + o_xe[op] = RIGHTI + tol + op = op + 1 + break + } else + o_xe[op] = xe[i] + + op = op + 1 + if (xs[i+1] > x2) + break + } + + ip = i + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexsubr.x b/sys/qpoe/gen/qpexsubr.x new file mode 100644 index 00000000..147bf14b --- /dev/null +++ b/sys/qpoe/gen/qpexsubr.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "../qpex.h" + +# QPEX_SUBLIST -- Extract a sublist spanning the indicated range from a +# larger range list. The number of ranges extracted is returned as the +# function value. + +int procedure qpex_sublistr (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + +real x1, x2 #I range to be extracted +real xs[nranges],xe[nranges] #I input range list +int nranges #I nranges in input list +int ip #U start position in input list +real o_xs[ARB],o_xe[ARB] #O output sublist + +real tol +int op, i + +begin + tol = (EPSILONR * 10.0) + + # Determine the range containing or immediately following the + # start point of the range of interest. + + while (x1 < xs[ip] && ip > 1) + ip = ip - 1 + while (x1 >= xs[ip]) + if (x1 <= xe[ip] || ip >= nranges) + break + else + ip = ip + 1 + + # Check for an empty output range list. + if (xs[ip] > x2) + return (0) + + # At least one input range contributes something to the output region. + # Copy a portion of the input range list to the ouput range list. + + op = 1 + do i = ip, nranges { + if (xs[i] <= x1) + o_xs[op] = LEFTR - tol + else + o_xs[op] = xs[i] + + if ((xe[i] - x2) >= tol) { + o_xe[op] = RIGHTR + tol + op = op + 1 + break + } else + o_xe[op] = xe[i] + + op = op + 1 + if (xs[i+1] > x2) + break + } + + ip = i + return (op - 1) +end diff --git a/sys/qpoe/gen/qpgetc.x b/sys/qpoe/gen/qpgetc.x new file mode 100644 index 00000000..1b6ce6fe --- /dev/null +++ b/sys/qpoe/gen/qpgetc.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +char procedure qp_getc (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +char value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (NULL) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_CHAR) + call pargc (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgetd.x b/sys/qpoe/gen/qpgetd.x new file mode 100644 index 00000000..fea90d0f --- /dev/null +++ b/sys/qpoe/gen/qpgetd.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +double procedure qp_getd (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +double value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFD) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_DOUBLE) + call pargd (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgeti.x b/sys/qpoe/gen/qpgeti.x new file mode 100644 index 00000000..c40d5de6 --- /dev/null +++ b/sys/qpoe/gen/qpgeti.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +int procedure qp_geti (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +int value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFI) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_INT) + call pargi (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgetl.x b/sys/qpoe/gen/qpgetl.x new file mode 100644 index 00000000..804e2def --- /dev/null +++ b/sys/qpoe/gen/qpgetl.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +long procedure qp_getl (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +long value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFL) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_LONG) + call pargl (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgetr.x b/sys/qpoe/gen/qpgetr.x new file mode 100644 index 00000000..1990a413 --- /dev/null +++ b/sys/qpoe/gen/qpgetr.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +real procedure qp_getr (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +real value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFR) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_REAL) + call pargr (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgets.x b/sys/qpoe/gen/qpgets.x new file mode 100644 index 00000000..3f6500ef --- /dev/null +++ b/sys/qpoe/gen/qpgets.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +short procedure qp_gets (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +short value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFS) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_SHORT) + call pargs (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpiogetev.x b/sys/qpoe/gen/qpiogetev.x new file mode 100644 index 00000000..7d029a94 --- /dev/null +++ b/sys/qpoe/gen/qpiogetev.x @@ -0,0 +1,1968 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <pmset.h> +include "../qpio.h" + +define RLI_NEXTLINE 9998 +define RLI_INITIALIZE 9999 +define SZ_CODE 7 + +# QPIO_GETEVENTS -- Return a sequence of events sharing the same mask value +# which satisfy the current event attribute filter. The returned events will +# be only those in a rectangular subregion of the image (specified by a prior +# call to qpio_setrange) which are also visible through the current mask. +# Sequences of events are returned in storage order until the region is +# exhausted, at which time EOF is returned. +# +# NOTE - If debug statements (printfs) are placed in this code they will cause +# i/o problems at runtime due to reentrancy, since this routine is called in +# a low level FIO pseudodevice driver (QPF). This is also true of any of the +# routines called by this procedure, and of the related routine QPIO_READPIX. + +int procedure qpio_gvtevents (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int status +char code[SZ_CODE] +int qpx_gvs(), qpx_gvi(), qpx_gvl(), qpx_gvr(), qpx_gvd() +errchk syserrs +define err_ 91 + +begin + # The generic routines currently require that X,Y be the same type. + # It wouldn't be hard to remove this restriction if necessary, but + # it simplifies things and I doubt if a mixed types feature would + # be used very often. + + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + goto err_ + + # Get the events. + switch (IO_EVXTYPE(io)) { + case TY_SHORT: + status = qpx_gvs (io, o_ev, maskval, maxev, o_nev) + case TY_INT: + status = qpx_gvi (io, o_ev, maskval, maxev, o_nev) + case TY_LONG: + status = qpx_gvl (io, o_ev, maskval, maxev, o_nev) + case TY_REAL: + status = qpx_gvr (io, o_ev, maskval, maxev, o_nev) + case TY_DOUBLE: + status = qpx_gvd (io, o_ev, maskval, maxev, o_nev) + default: +err_ call sprintf (code, SZ_CODE, "%d") + call pargi (IO_EVXTYPE(io)) + call syserrs (SYS_QPINVEVT, code) + } + + return (status) +end + + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvs (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_SHORT + 1 + xs = Mems[ev_p+ev_xoff] + ys = Mems[ev_p+ev_yoff] + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_SHORT + 1 + xe = Mems[ev_p+ev_xoff] + ye = Mems[ev_p+ev_yoff] + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_SHORT + 1 + + x = Mems[ev_p+ev_xoff] + y = Mems[ev_p+ev_yoff] + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_SHORT + 1 + x = Mems[ev_p+ev_xoff] + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvi (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_INT + 1 + xs = Memi[ev_p+ev_xoff] + ys = Memi[ev_p+ev_yoff] + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_INT + 1 + xe = Memi[ev_p+ev_xoff] + ye = Memi[ev_p+ev_yoff] + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_INT + 1 + + x = Memi[ev_p+ev_xoff] + y = Memi[ev_p+ev_yoff] + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_INT + 1 + x = Memi[ev_p+ev_xoff] + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvl (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_LONG + 1 + xs = Meml[ev_p+ev_xoff] + ys = Meml[ev_p+ev_yoff] + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_LONG + 1 + xe = Meml[ev_p+ev_xoff] + ye = Meml[ev_p+ev_yoff] + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_LONG + 1 + + x = Meml[ev_p+ev_xoff] + y = Meml[ev_p+ev_yoff] + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_LONG + 1 + x = Meml[ev_p+ev_xoff] + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvr (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_REAL + 1 + xs = Memr[ev_p+ev_xoff] + 0.5 + ys = Memr[ev_p+ev_yoff] + 0.5 + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_REAL + 1 + xe = Memr[ev_p+ev_xoff] + 0.5 + ye = Memr[ev_p+ev_yoff] + 0.5 + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_REAL + 1 + + x = Memr[ev_p+ev_xoff] + 0.5 + y = Memr[ev_p+ev_yoff] + 0.5 + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_REAL + 1 + x = Memr[ev_p+ev_xoff] + 0.5 + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvd (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_DOUBLE + 1 + xs = Memd[ev_p+ev_xoff] + 0.5 + ys = Memd[ev_p+ev_yoff] + 0.5 + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_DOUBLE + 1 + xe = Memd[ev_p+ev_xoff] + 0.5 + ye = Memd[ev_p+ev_yoff] + 0.5 + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_DOUBLE + 1 + + x = Memd[ev_p+ev_xoff] + 0.5 + y = Memd[ev_p+ev_yoff] + 0.5 + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_DOUBLE + 1 + x = Memd[ev_p+ev_xoff] + 0.5 + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + diff --git a/sys/qpoe/gen/qpiorpixi.x b/sys/qpoe/gen/qpiorpixi.x new file mode 100644 index 00000000..c64f0a8a --- /dev/null +++ b/sys/qpoe/gen/qpiorpixi.x @@ -0,0 +1,150 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <syserr.h> +include "../qpio.h" + +# QPIO_READPIX -- Sample the event list within the indicated rectangular +# region, using the given blocking factor, to produce a rectangular array +# of "pixels", where each pixel is a count of the number of events mapping +# to that location which pass the event attribute filter and region mask. +# +# NOTE -- It is left up to the caller to zero the output buffer before +# we are called. (We merely increment the counts of the affected pixels). + +int procedure qpio_readpixi (io, obuf, vs, ve, ndim, xblock, yblock) + +pointer io #I QPIO descriptor +int obuf[ARB] #O output pixel buffer +int vs[ndim], ve[ndim] #I vectors defining region to be extracted +int ndim #I should be 2 for QPOE +real xblock, yblock #I blocking factors + +double x, y +pointer sp, evl, ev_p +int evtype, maxpix, maskval, xoff, yoff, xw, yw, nev, totev, pix, i, j +errchk qpio_getevents, qpio_setrange, syserr +int qpio_getevents() + +begin + # Verify arguments. + if (xblock <= 0 || xblock > (ve[1] - vs[1] + 1)) + call syserr (SYS_QPBLOCKOOR) + if (yblock <= 0 || yblock > (ve[2] - vs[2] + 1)) + call syserr (SYS_QPBLOCKOOR) + + # Compute the size of the output matrix in integer pixels. This + # truncates the last partially filled pixel in each axis. + + xw = int ((ve[1] - vs[1] + 1) / xblock + (EPSILOND * 1000)) + yw = int ((ve[2] - vs[2] + 1) / yblock + (EPSILOND * 1000)) + if (xw <= 0 || yw <= 0) + return (0) + + call smark (sp) + call salloc (evl, SZ_EVLIST, TY_POINTER) + + xoff = IO_EVXOFF(io) + yoff = IO_EVYOFF(io) + maxpix = xw * yw + totev = 0 + + evtype = IO_EVXTYPE(io) + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + call syserr (SYS_QPINVEVT) + + # Define the region from which we wish to read events. + call qpio_setrange (io, vs, ve, ndim) + + # Read the events. + while (qpio_getevents (io, Memi[evl], maskval, SZ_EVLIST, nev) > 0) { + switch (evtype) { + + case TY_SHORT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_SHORT + 1 + + x = Mems[ev_p+xoff] + y = Mems[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_INT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_INT + 1 + + x = Memi[ev_p+xoff] + y = Memi[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_LONG: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_LONG + 1 + + x = Meml[ev_p+xoff] + y = Meml[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_REAL: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_REAL + 1 + + x = Memr[ev_p+xoff] + y = Memr[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_DOUBLE: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_DOUBLE + 1 + + x = Memd[ev_p+xoff] + y = Memd[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + } + + totev = totev + nev + } + + call sfree (sp) + return (totev) +end diff --git a/sys/qpoe/gen/qpiorpixs.x b/sys/qpoe/gen/qpiorpixs.x new file mode 100644 index 00000000..d97c7c42 --- /dev/null +++ b/sys/qpoe/gen/qpiorpixs.x @@ -0,0 +1,150 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <syserr.h> +include "../qpio.h" + +# QPIO_READPIX -- Sample the event list within the indicated rectangular +# region, using the given blocking factor, to produce a rectangular array +# of "pixels", where each pixel is a count of the number of events mapping +# to that location which pass the event attribute filter and region mask. +# +# NOTE -- It is left up to the caller to zero the output buffer before +# we are called. (We merely increment the counts of the affected pixels). + +int procedure qpio_readpixs (io, obuf, vs, ve, ndim, xblock, yblock) + +pointer io #I QPIO descriptor +short obuf[ARB] #O output pixel buffer +int vs[ndim], ve[ndim] #I vectors defining region to be extracted +int ndim #I should be 2 for QPOE +real xblock, yblock #I blocking factors + +double x, y +pointer sp, evl, ev_p +int evtype, maxpix, maskval, xoff, yoff, xw, yw, nev, totev, pix, i, j +errchk qpio_getevents, qpio_setrange, syserr +int qpio_getevents() + +begin + # Verify arguments. + if (xblock <= 0 || xblock > (ve[1] - vs[1] + 1)) + call syserr (SYS_QPBLOCKOOR) + if (yblock <= 0 || yblock > (ve[2] - vs[2] + 1)) + call syserr (SYS_QPBLOCKOOR) + + # Compute the size of the output matrix in integer pixels. This + # truncates the last partially filled pixel in each axis. + + xw = int ((ve[1] - vs[1] + 1) / xblock + (EPSILOND * 1000)) + yw = int ((ve[2] - vs[2] + 1) / yblock + (EPSILOND * 1000)) + if (xw <= 0 || yw <= 0) + return (0) + + call smark (sp) + call salloc (evl, SZ_EVLIST, TY_POINTER) + + xoff = IO_EVXOFF(io) + yoff = IO_EVYOFF(io) + maxpix = xw * yw + totev = 0 + + evtype = IO_EVXTYPE(io) + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + call syserr (SYS_QPINVEVT) + + # Define the region from which we wish to read events. + call qpio_setrange (io, vs, ve, ndim) + + # Read the events. + while (qpio_getevents (io, Memi[evl], maskval, SZ_EVLIST, nev) > 0) { + switch (evtype) { + + case TY_SHORT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_SHORT + 1 + + x = Mems[ev_p+xoff] + y = Mems[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_INT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_INT + 1 + + x = Memi[ev_p+xoff] + y = Memi[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_LONG: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_LONG + 1 + + x = Meml[ev_p+xoff] + y = Meml[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_REAL: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_REAL + 1 + + x = Memr[ev_p+xoff] + y = Memr[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_DOUBLE: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_DOUBLE + 1 + + x = Memd[ev_p+xoff] + y = Memd[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + } + + totev = totev + nev + } + + call sfree (sp) + return (totev) +end diff --git a/sys/qpoe/gen/qpputc.x b/sys/qpoe/gen/qpputc.x new file mode 100644 index 00000000..4415a177 --- /dev/null +++ b/sys/qpoe/gen/qpputc.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putc (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_CHAR) + call pargi (dtype) + call pargc (value) + } + + indef = IS_INDEF(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputd.x b/sys/qpoe/gen/qpputd.x new file mode 100644 index 00000000..2c9883e0 --- /dev/null +++ b/sys/qpoe/gen/qpputd.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putd (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +double value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_DOUBLE) + call pargi (dtype) + call pargd (value) + } + + indef = IS_INDEFD(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputi.x b/sys/qpoe/gen/qpputi.x new file mode 100644 index 00000000..528e6bc7 --- /dev/null +++ b/sys/qpoe/gen/qpputi.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_puti (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +int value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_INT) + call pargi (dtype) + call pargi (value) + } + + indef = IS_INDEFI(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputl.x b/sys/qpoe/gen/qpputl.x new file mode 100644 index 00000000..50e6605a --- /dev/null +++ b/sys/qpoe/gen/qpputl.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putl (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +long value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_LONG) + call pargi (dtype) + call pargl (value) + } + + indef = IS_INDEFL(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputr.x b/sys/qpoe/gen/qpputr.x new file mode 100644 index 00000000..10af764b --- /dev/null +++ b/sys/qpoe/gen/qpputr.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putr (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +real value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_REAL) + call pargi (dtype) + call pargr (value) + } + + indef = IS_INDEFR(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputs.x b/sys/qpoe/gen/qpputs.x new file mode 100644 index 00000000..ec58607a --- /dev/null +++ b/sys/qpoe/gen/qpputs.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_puts (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +short value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_SHORT) + call pargi (dtype) + call pargs (value) + } + + indef = IS_INDEFS(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qprlmerged.x b/sys/qpoe/gen/qprlmerged.x new file mode 100644 index 00000000..d08f4e5f --- /dev/null +++ b/sys/qpoe/gen/qprlmerged.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "../qpex.h" + +# QP_RLMERGE -- Merge (AND) two range lists. Only ranges which are +# common to both range lists are output. The number of ranges in the +# output range list is returned as the function value. + +int procedure qp_rlmerged (os,oe,olen, xs,xe,nx, ys,ye,ny) + +pointer os, oe #U output range list +int olen #U allocated length of OS, OE arrays + +double xs[ARB], xe[ARB] #I range list to be merged with +int nx #I number of ranges in X list +double ys[ARB], ye[ARB] #I range list to be merged with X +int ny #I number of ranges in Y list + +double o1, o2 +int nx_out, xi, yi, i +double qp_minvald(), qp_maxvald() +bool qp_lessthand() +errchk realloc + +begin + nx_out = 0 + if (nx <= 0 || ny <= 0) + return (0) + + xi = 1 + yi = 1 + + do i = 1, ARB { + # Find a pair of ranges which intersect. + repeat { + if (qp_lessthand (xe[xi], ys[yi])) { + if (xi >= nx) + return (nx_out) + else + xi = xi + 1 + } else if (qp_lessthand (ye[yi], xs[xi])) { + if (yi >= ny) + return (nx_out) + else + yi = yi + 1 + } else + break + } + + # Compute the intersection. + o1 = qp_maxvald (xs[xi], ys[yi]) + o2 = qp_minvald (xe[xi], ye[yi]) + + # Output the range. + if (nx_out + 1 > olen) { + olen = max (DEF_XLEN, olen * 2) + call realloc (os, olen, TY_DOUBLE) + call realloc (oe, olen, TY_DOUBLE) + } + + Memd[os+nx_out] = o1 + Memd[oe+nx_out] = o2 + nx_out = nx_out + 1 + + # Advance to the next range. + if (xi < nx && qp_lessthand (xe[xi], ye[yi])) + xi = xi + 1 + else if (yi < ny) + yi = yi + 1 + else + break + } + + return (nx_out) +end + + +# QP_MINVAL -- Return the lesser of two values, where either value can +# be an open range. + +double procedure qp_minvald (x, y) + +double x #I first value +double y #I second value + +bool qp_lessthand() + +begin + if (qp_lessthand (x, y)) + return (x) + else + return (y) +end + + +# QP_MAXVAL -- Return the greater of two values, where either value can +# be an open range. + +double procedure qp_maxvald (x, y) + +double x #I first value +double y #I second value + +bool qp_lessthand() + +begin + if (qp_lessthand (x, y)) + return (y) + else + return (x) +end + + +# QP_LESSTHAN -- Test if X is less than Y, where X and Y can be open +# range values. + +bool procedure qp_lessthand (x, y) + +double x #I first value +double y #I second value + +begin + if (IS_LEFTD(x)) + return (!IS_LEFTD(y)) + else if (IS_RIGHTD(x)) + return (false) + else if (IS_LEFTD(y)) + return (false) + else if (IS_RIGHTD(y)) + return (true) + else + return (x < y) +end diff --git a/sys/qpoe/gen/qprlmergei.x b/sys/qpoe/gen/qprlmergei.x new file mode 100644 index 00000000..f8476178 --- /dev/null +++ b/sys/qpoe/gen/qprlmergei.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "../qpex.h" + +# QP_RLMERGE -- Merge (AND) two range lists. Only ranges which are +# common to both range lists are output. The number of ranges in the +# output range list is returned as the function value. + +int procedure qp_rlmergei (os,oe,olen, xs,xe,nx, ys,ye,ny) + +pointer os, oe #U output range list +int olen #U allocated length of OS, OE arrays + +int xs[ARB], xe[ARB] #I range list to be merged with +int nx #I number of ranges in X list +int ys[ARB], ye[ARB] #I range list to be merged with X +int ny #I number of ranges in Y list + +int o1, o2 +int nx_out, xi, yi, i +int qp_minvali(), qp_maxvali() +bool qp_lessthani() +errchk realloc + +begin + nx_out = 0 + if (nx <= 0 || ny <= 0) + return (0) + + xi = 1 + yi = 1 + + do i = 1, ARB { + # Find a pair of ranges which intersect. + repeat { + if (qp_lessthani (xe[xi], ys[yi])) { + if (xi >= nx) + return (nx_out) + else + xi = xi + 1 + } else if (qp_lessthani (ye[yi], xs[xi])) { + if (yi >= ny) + return (nx_out) + else + yi = yi + 1 + } else + break + } + + # Compute the intersection. + o1 = qp_maxvali (xs[xi], ys[yi]) + o2 = qp_minvali (xe[xi], ye[yi]) + + # Output the range. + if (nx_out + 1 > olen) { + olen = max (DEF_XLEN, olen * 2) + call realloc (os, olen, TY_INT) + call realloc (oe, olen, TY_INT) + } + + Memi[os+nx_out] = o1 + Memi[oe+nx_out] = o2 + nx_out = nx_out + 1 + + # Advance to the next range. + if (xi < nx && qp_lessthani (xe[xi], ye[yi])) + xi = xi + 1 + else if (yi < ny) + yi = yi + 1 + else + break + } + + return (nx_out) +end + + +# QP_MINVAL -- Return the lesser of two values, where either value can +# be an open range. + +int procedure qp_minvali (x, y) + +int x #I first value +int y #I second value + +bool qp_lessthani() + +begin + if (qp_lessthani (x, y)) + return (x) + else + return (y) +end + + +# QP_MAXVAL -- Return the greater of two values, where either value can +# be an open range. + +int procedure qp_maxvali (x, y) + +int x #I first value +int y #I second value + +bool qp_lessthani() + +begin + if (qp_lessthani (x, y)) + return (y) + else + return (x) +end + + +# QP_LESSTHAN -- Test if X is less than Y, where X and Y can be open +# range values. + +bool procedure qp_lessthani (x, y) + +int x #I first value +int y #I second value + +begin + if (IS_LEFTI(x)) + return (!IS_LEFTI(y)) + else if (IS_RIGHTI(x)) + return (false) + else if (IS_LEFTI(y)) + return (false) + else if (IS_RIGHTI(y)) + return (true) + else + return (x < y) +end diff --git a/sys/qpoe/gen/qprlmerger.x b/sys/qpoe/gen/qprlmerger.x new file mode 100644 index 00000000..a776a5db --- /dev/null +++ b/sys/qpoe/gen/qprlmerger.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "../qpex.h" + +# QP_RLMERGE -- Merge (AND) two range lists. Only ranges which are +# common to both range lists are output. The number of ranges in the +# output range list is returned as the function value. + +int procedure qp_rlmerger (os,oe,olen, xs,xe,nx, ys,ye,ny) + +pointer os, oe #U output range list +int olen #U allocated length of OS, OE arrays + +real xs[ARB], xe[ARB] #I range list to be merged with +int nx #I number of ranges in X list +real ys[ARB], ye[ARB] #I range list to be merged with X +int ny #I number of ranges in Y list + +real o1, o2 +int nx_out, xi, yi, i +real qp_minvalr(), qp_maxvalr() +bool qp_lessthanr() +errchk realloc + +begin + nx_out = 0 + if (nx <= 0 || ny <= 0) + return (0) + + xi = 1 + yi = 1 + + do i = 1, ARB { + # Find a pair of ranges which intersect. + repeat { + if (qp_lessthanr (xe[xi], ys[yi])) { + if (xi >= nx) + return (nx_out) + else + xi = xi + 1 + } else if (qp_lessthanr (ye[yi], xs[xi])) { + if (yi >= ny) + return (nx_out) + else + yi = yi + 1 + } else + break + } + + # Compute the intersection. + o1 = qp_maxvalr (xs[xi], ys[yi]) + o2 = qp_minvalr (xe[xi], ye[yi]) + + # Output the range. + if (nx_out + 1 > olen) { + olen = max (DEF_XLEN, olen * 2) + call realloc (os, olen, TY_REAL) + call realloc (oe, olen, TY_REAL) + } + + Memr[os+nx_out] = o1 + Memr[oe+nx_out] = o2 + nx_out = nx_out + 1 + + # Advance to the next range. + if (xi < nx && qp_lessthanr (xe[xi], ye[yi])) + xi = xi + 1 + else if (yi < ny) + yi = yi + 1 + else + break + } + + return (nx_out) +end + + +# QP_MINVAL -- Return the lesser of two values, where either value can +# be an open range. + +real procedure qp_minvalr (x, y) + +real x #I first value +real y #I second value + +bool qp_lessthanr() + +begin + if (qp_lessthanr (x, y)) + return (x) + else + return (y) +end + + +# QP_MAXVAL -- Return the greater of two values, where either value can +# be an open range. + +real procedure qp_maxvalr (x, y) + +real x #I first value +real y #I second value + +bool qp_lessthanr() + +begin + if (qp_lessthanr (x, y)) + return (y) + else + return (x) +end + + +# QP_LESSTHAN -- Test if X is less than Y, where X and Y can be open +# range values. + +bool procedure qp_lessthanr (x, y) + +real x #I first value +real y #I second value + +begin + if (IS_LEFTR(x)) + return (!IS_LEFTR(y)) + else if (IS_RIGHTR(x)) + return (false) + else if (IS_LEFTR(y)) + return (false) + else if (IS_RIGHTR(y)) + return (true) + else + return (x < y) +end |