diff options
Diffstat (limited to 'pkg/tbtables/selector')
37 files changed, 6689 insertions, 0 deletions
diff --git a/pkg/tbtables/selector/generic/mkpkg b/pkg/tbtables/selector/generic/mkpkg new file mode 100644 index 00000000..eaa97971 --- /dev/null +++ b/pkg/tbtables/selector/generic/mkpkg @@ -0,0 +1,16 @@ +# Update the generic routines in selector + +default: + $checkout libtbtables.a ../../ + $update libtbtables.a + $checkin libtbtables.a ../../ +$exit + +libtbtables.a: + tcsrdaryb.x ../tcs.h + tcsrdaryc.x ../tcs.h + tcsrdaryd.x ../tcs.h + tcsrdaryi.x ../tcs.h + tcsrdaryr.x ../tcs.h + tcsrdarys.x ../tcs.h + ; diff --git a/pkg/tbtables/selector/generic/tcsrdaryb.x b/pkg/tbtables/selector/generic/tcsrdaryb.x new file mode 100644 index 00000000..b951ecf0 --- /dev/null +++ b/pkg/tbtables/selector/generic/tcsrdaryb.x @@ -0,0 +1,116 @@ +include "../tcs.h" + +# TCS_RDARY -- Read an array using the column selector + +procedure tcs_rdaryb (tp, descrip, irow, maxbuf, nbuf, buffer) + +pointer tp # i: table descriptor +pointer descrip # i: column selector +int irow # i: table row number +int maxbuf # i: declared length of buffer +int nbuf # o: length of output array +bool buffer[ARB] # o: array of values +#-- +int idim, ndim, pdim, plen, psize, off +int axsize, axlen[MAXDIM], axpos[MAXDIM] + +int tbagtb() + +begin + if (TCS_DIMEN(descrip) == 0) { + # Column is a scalar, use a scalar read routine + + if (maxbuf > 0) { + nbuf = 1 + call tbegtb (tp, TCS_COLUMN(descrip), irow, buffer) + } else { + nbuf = 0 + } + + } else { + # Compute size and dimensionality of the largest contigous + # piece that can be read from the array + + call tbciga (tp, TCS_COLUMN(descrip), ndim, axlen, MAXDIM) + + pdim = 0 + psize = 1 + do idim = 1, TCS_DIMEN(descrip) { + if (TCS_INC(descrip,idim) > 1) + break + + pdim = pdim + 1 + plen = (TCS_LAST(descrip,idim) - TCS_FIRST(descrip,idim) + 1) + psize = psize * plen + + if (plen < axlen[idim]) + break + } + + # Compute offset to first element to be read into array + + off = 0 + do idim = ndim-1, 1, -1 + off = (off + TCS_FIRST(descrip,idim+1) - 1) * axlen[idim] + + off = off + TCS_FIRST(descrip,1) + + # Save position of first element to be read in array + + do idim = 1 , ndim + axpos[idim] = TCS_FIRST(descrip,idim) + + nbuf = 1 + + repeat { + + # Adjust piece size for possible overflow + + if (nbuf + psize > maxbuf) + psize = maxbuf - (nbuf - 1) + + # Read chunk from array + + psize = tbagtb (tp, TCS_COLUMN(descrip), irow, + buffer[nbuf], off, psize) + + # Exit if array is full + + nbuf = nbuf + psize + if (nbuf > maxbuf) + break + + # Compute offset to next piece to read into array + + axsize = 1 + for (idim = 1; idim <= ndim; idim = idim + 1) { + if (idim > pdim) { + axpos[idim] = axpos[idim] + TCS_INC(descrip,idim) + + if (axpos[idim] + TCS_INC(descrip,idim) <= + TCS_LAST(descrip,idim)) { + + off = off + axsize * TCS_INC(descrip,idim) + break + + } else { + axpos[idim] = TCS_FIRST(descrip,idim) + + off = off - axsize * (TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) + } + } + + axsize = axsize * axlen[idim] + } + + # Exit if array has been traversed + + if (idim > ndim) + break + } + + nbuf = nbuf - 1 + } +end + diff --git a/pkg/tbtables/selector/generic/tcsrdaryc.x b/pkg/tbtables/selector/generic/tcsrdaryc.x new file mode 100644 index 00000000..33a2b610 --- /dev/null +++ b/pkg/tbtables/selector/generic/tcsrdaryc.x @@ -0,0 +1,117 @@ +include "../tcs.h" + +# TCS_RDARY -- Read an array using the column selector + +procedure tcs_rdaryt (tp, descrip, irow, maxch, maxbuf, nbuf, buffer) + +pointer tp # i: table descriptor +pointer descrip # i: column selector +int irow # i: table row number +int maxch # i: max length of string +int maxbuf # i: declared length of buffer +int nbuf # o: length of output array +char buffer[maxch,ARB] # o: array of values +#-- +int idim, ndim, pdim, plen, psize, off +int axsize, axlen[MAXDIM], axpos[MAXDIM] + +int tbagtt() + +begin + if (TCS_DIMEN(descrip) == 0) { + # Column is a scalar, use a scalar read routine + + if (maxbuf > 0) { + nbuf = 1 + call tbegtt (tp, TCS_COLUMN(descrip), irow, buffer, maxch) + } else { + nbuf = 0 + } + + } else { + # Compute size and dimensionality of the largest contigous + # piece that can be read from the array + + call tbciga (tp, TCS_COLUMN(descrip), ndim, axlen, MAXDIM) + + pdim = 0 + psize = 1 + do idim = 1, TCS_DIMEN(descrip) { + if (TCS_INC(descrip,idim) > 1) + break + + pdim = pdim + 1 + plen = (TCS_LAST(descrip,idim) - TCS_FIRST(descrip,idim) + 1) + psize = psize * plen + + if (plen < axlen[idim]) + break + } + + # Compute offset to first element to be read into array + + off = 0 + do idim = ndim-1, 1, -1 + off = (off + TCS_FIRST(descrip,idim+1) - 1) * axlen[idim] + + off = off + TCS_FIRST(descrip,1) + + # Save position of first element to be read in array + + do idim = 1 , ndim + axpos[idim] = TCS_FIRST(descrip,idim) + + nbuf = 1 + + repeat { + + # Adjust piece size for possible overflow + + if (nbuf + psize > maxbuf) + psize = maxbuf - (nbuf - 1) + + # Read chunk from array + + psize = tbagtt (tp, TCS_COLUMN(descrip), irow, + buffer[1,nbuf], maxch, off, psize) + + # Exit if array is full + + nbuf = nbuf + psize + if (nbuf > maxbuf) + break + + # Compute offset to next piece to read into array + + axsize = 1 + for (idim = 1; idim <= ndim; idim = idim + 1) { + if (idim > pdim) { + axpos[idim] = axpos[idim] + TCS_INC(descrip,idim) + + if (axpos[idim] + TCS_INC(descrip,idim) <= + TCS_LAST(descrip,idim)) { + + off = off + axsize * TCS_INC(descrip,idim) + break + + } else { + axpos[idim] = TCS_FIRST(descrip,idim) + + off = off - axsize * (TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) + } + } + + axsize = axsize * axlen[idim] + } + + # Exit if array has been traversed + + if (idim > ndim) + break + } + + nbuf = nbuf - 1 + } +end + diff --git a/pkg/tbtables/selector/generic/tcsrdaryd.x b/pkg/tbtables/selector/generic/tcsrdaryd.x new file mode 100644 index 00000000..de054a3b --- /dev/null +++ b/pkg/tbtables/selector/generic/tcsrdaryd.x @@ -0,0 +1,116 @@ +include "../tcs.h" + +# TCS_RDARY -- Read an array using the column selector + +procedure tcs_rdaryd (tp, descrip, irow, maxbuf, nbuf, buffer) + +pointer tp # i: table descriptor +pointer descrip # i: column selector +int irow # i: table row number +int maxbuf # i: declared length of buffer +int nbuf # o: length of output array +double buffer[ARB] # o: array of values +#-- +int idim, ndim, pdim, plen, psize, off +int axsize, axlen[MAXDIM], axpos[MAXDIM] + +int tbagtd() + +begin + if (TCS_DIMEN(descrip) == 0) { + # Column is a scalar, use a scalar read routine + + if (maxbuf > 0) { + nbuf = 1 + call tbegtd (tp, TCS_COLUMN(descrip), irow, buffer) + } else { + nbuf = 0 + } + + } else { + # Compute size and dimensionality of the largest contigous + # piece that can be read from the array + + call tbciga (tp, TCS_COLUMN(descrip), ndim, axlen, MAXDIM) + + pdim = 0 + psize = 1 + do idim = 1, TCS_DIMEN(descrip) { + if (TCS_INC(descrip,idim) > 1) + break + + pdim = pdim + 1 + plen = (TCS_LAST(descrip,idim) - TCS_FIRST(descrip,idim) + 1) + psize = psize * plen + + if (plen < axlen[idim]) + break + } + + # Compute offset to first element to be read into array + + off = 0 + do idim = ndim-1, 1, -1 + off = (off + TCS_FIRST(descrip,idim+1) - 1) * axlen[idim] + + off = off + TCS_FIRST(descrip,1) + + # Save position of first element to be read in array + + do idim = 1 , ndim + axpos[idim] = TCS_FIRST(descrip,idim) + + nbuf = 1 + + repeat { + + # Adjust piece size for possible overflow + + if (nbuf + psize > maxbuf) + psize = maxbuf - (nbuf - 1) + + # Read chunk from array + + psize = tbagtd (tp, TCS_COLUMN(descrip), irow, + buffer[nbuf], off, psize) + + # Exit if array is full + + nbuf = nbuf + psize + if (nbuf > maxbuf) + break + + # Compute offset to next piece to read into array + + axsize = 1 + for (idim = 1; idim <= ndim; idim = idim + 1) { + if (idim > pdim) { + axpos[idim] = axpos[idim] + TCS_INC(descrip,idim) + + if (axpos[idim] + TCS_INC(descrip,idim) <= + TCS_LAST(descrip,idim)) { + + off = off + axsize * TCS_INC(descrip,idim) + break + + } else { + axpos[idim] = TCS_FIRST(descrip,idim) + + off = off - axsize * (TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) + } + } + + axsize = axsize * axlen[idim] + } + + # Exit if array has been traversed + + if (idim > ndim) + break + } + + nbuf = nbuf - 1 + } +end + diff --git a/pkg/tbtables/selector/generic/tcsrdaryi.x b/pkg/tbtables/selector/generic/tcsrdaryi.x new file mode 100644 index 00000000..ee05ee36 --- /dev/null +++ b/pkg/tbtables/selector/generic/tcsrdaryi.x @@ -0,0 +1,116 @@ +include "../tcs.h" + +# TCS_RDARY -- Read an array using the column selector + +procedure tcs_rdaryi (tp, descrip, irow, maxbuf, nbuf, buffer) + +pointer tp # i: table descriptor +pointer descrip # i: column selector +int irow # i: table row number +int maxbuf # i: declared length of buffer +int nbuf # o: length of output array +int buffer[ARB] # o: array of values +#-- +int idim, ndim, pdim, plen, psize, off +int axsize, axlen[MAXDIM], axpos[MAXDIM] + +int tbagti() + +begin + if (TCS_DIMEN(descrip) == 0) { + # Column is a scalar, use a scalar read routine + + if (maxbuf > 0) { + nbuf = 1 + call tbegti (tp, TCS_COLUMN(descrip), irow, buffer) + } else { + nbuf = 0 + } + + } else { + # Compute size and dimensionality of the largest contigous + # piece that can be read from the array + + call tbciga (tp, TCS_COLUMN(descrip), ndim, axlen, MAXDIM) + + pdim = 0 + psize = 1 + do idim = 1, TCS_DIMEN(descrip) { + if (TCS_INC(descrip,idim) > 1) + break + + pdim = pdim + 1 + plen = (TCS_LAST(descrip,idim) - TCS_FIRST(descrip,idim) + 1) + psize = psize * plen + + if (plen < axlen[idim]) + break + } + + # Compute offset to first element to be read into array + + off = 0 + do idim = ndim-1, 1, -1 + off = (off + TCS_FIRST(descrip,idim+1) - 1) * axlen[idim] + + off = off + TCS_FIRST(descrip,1) + + # Save position of first element to be read in array + + do idim = 1 , ndim + axpos[idim] = TCS_FIRST(descrip,idim) + + nbuf = 1 + + repeat { + + # Adjust piece size for possible overflow + + if (nbuf + psize > maxbuf) + psize = maxbuf - (nbuf - 1) + + # Read chunk from array + + psize = tbagti (tp, TCS_COLUMN(descrip), irow, + buffer[nbuf], off, psize) + + # Exit if array is full + + nbuf = nbuf + psize + if (nbuf > maxbuf) + break + + # Compute offset to next piece to read into array + + axsize = 1 + for (idim = 1; idim <= ndim; idim = idim + 1) { + if (idim > pdim) { + axpos[idim] = axpos[idim] + TCS_INC(descrip,idim) + + if (axpos[idim] + TCS_INC(descrip,idim) <= + TCS_LAST(descrip,idim)) { + + off = off + axsize * TCS_INC(descrip,idim) + break + + } else { + axpos[idim] = TCS_FIRST(descrip,idim) + + off = off - axsize * (TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) + } + } + + axsize = axsize * axlen[idim] + } + + # Exit if array has been traversed + + if (idim > ndim) + break + } + + nbuf = nbuf - 1 + } +end + diff --git a/pkg/tbtables/selector/generic/tcsrdaryr.x b/pkg/tbtables/selector/generic/tcsrdaryr.x new file mode 100644 index 00000000..27a5ed13 --- /dev/null +++ b/pkg/tbtables/selector/generic/tcsrdaryr.x @@ -0,0 +1,116 @@ +include "../tcs.h" + +# TCS_RDARY -- Read an array using the column selector + +procedure tcs_rdaryr (tp, descrip, irow, maxbuf, nbuf, buffer) + +pointer tp # i: table descriptor +pointer descrip # i: column selector +int irow # i: table row number +int maxbuf # i: declared length of buffer +int nbuf # o: length of output array +real buffer[ARB] # o: array of values +#-- +int idim, ndim, pdim, plen, psize, off +int axsize, axlen[MAXDIM], axpos[MAXDIM] + +int tbagtr() + +begin + if (TCS_DIMEN(descrip) == 0) { + # Column is a scalar, use a scalar read routine + + if (maxbuf > 0) { + nbuf = 1 + call tbegtr (tp, TCS_COLUMN(descrip), irow, buffer) + } else { + nbuf = 0 + } + + } else { + # Compute size and dimensionality of the largest contigous + # piece that can be read from the array + + call tbciga (tp, TCS_COLUMN(descrip), ndim, axlen, MAXDIM) + + pdim = 0 + psize = 1 + do idim = 1, TCS_DIMEN(descrip) { + if (TCS_INC(descrip,idim) > 1) + break + + pdim = pdim + 1 + plen = (TCS_LAST(descrip,idim) - TCS_FIRST(descrip,idim) + 1) + psize = psize * plen + + if (plen < axlen[idim]) + break + } + + # Compute offset to first element to be read into array + + off = 0 + do idim = ndim-1, 1, -1 + off = (off + TCS_FIRST(descrip,idim+1) - 1) * axlen[idim] + + off = off + TCS_FIRST(descrip,1) + + # Save position of first element to be read in array + + do idim = 1 , ndim + axpos[idim] = TCS_FIRST(descrip,idim) + + nbuf = 1 + + repeat { + + # Adjust piece size for possible overflow + + if (nbuf + psize > maxbuf) + psize = maxbuf - (nbuf - 1) + + # Read chunk from array + + psize = tbagtr (tp, TCS_COLUMN(descrip), irow, + buffer[nbuf], off, psize) + + # Exit if array is full + + nbuf = nbuf + psize + if (nbuf > maxbuf) + break + + # Compute offset to next piece to read into array + + axsize = 1 + for (idim = 1; idim <= ndim; idim = idim + 1) { + if (idim > pdim) { + axpos[idim] = axpos[idim] + TCS_INC(descrip,idim) + + if (axpos[idim] + TCS_INC(descrip,idim) <= + TCS_LAST(descrip,idim)) { + + off = off + axsize * TCS_INC(descrip,idim) + break + + } else { + axpos[idim] = TCS_FIRST(descrip,idim) + + off = off - axsize * (TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) + } + } + + axsize = axsize * axlen[idim] + } + + # Exit if array has been traversed + + if (idim > ndim) + break + } + + nbuf = nbuf - 1 + } +end + diff --git a/pkg/tbtables/selector/generic/tcsrdarys.x b/pkg/tbtables/selector/generic/tcsrdarys.x new file mode 100644 index 00000000..1ae34565 --- /dev/null +++ b/pkg/tbtables/selector/generic/tcsrdarys.x @@ -0,0 +1,116 @@ +include "../tcs.h" + +# TCS_RDARY -- Read an array using the column selector + +procedure tcs_rdarys (tp, descrip, irow, maxbuf, nbuf, buffer) + +pointer tp # i: table descriptor +pointer descrip # i: column selector +int irow # i: table row number +int maxbuf # i: declared length of buffer +int nbuf # o: length of output array +short buffer[ARB] # o: array of values +#-- +int idim, ndim, pdim, plen, psize, off +int axsize, axlen[MAXDIM], axpos[MAXDIM] + +int tbagts() + +begin + if (TCS_DIMEN(descrip) == 0) { + # Column is a scalar, use a scalar read routine + + if (maxbuf > 0) { + nbuf = 1 + call tbegts (tp, TCS_COLUMN(descrip), irow, buffer) + } else { + nbuf = 0 + } + + } else { + # Compute size and dimensionality of the largest contigous + # piece that can be read from the array + + call tbciga (tp, TCS_COLUMN(descrip), ndim, axlen, MAXDIM) + + pdim = 0 + psize = 1 + do idim = 1, TCS_DIMEN(descrip) { + if (TCS_INC(descrip,idim) > 1) + break + + pdim = pdim + 1 + plen = (TCS_LAST(descrip,idim) - TCS_FIRST(descrip,idim) + 1) + psize = psize * plen + + if (plen < axlen[idim]) + break + } + + # Compute offset to first element to be read into array + + off = 0 + do idim = ndim-1, 1, -1 + off = (off + TCS_FIRST(descrip,idim+1) - 1) * axlen[idim] + + off = off + TCS_FIRST(descrip,1) + + # Save position of first element to be read in array + + do idim = 1 , ndim + axpos[idim] = TCS_FIRST(descrip,idim) + + nbuf = 1 + + repeat { + + # Adjust piece size for possible overflow + + if (nbuf + psize > maxbuf) + psize = maxbuf - (nbuf - 1) + + # Read chunk from array + + psize = tbagts (tp, TCS_COLUMN(descrip), irow, + buffer[nbuf], off, psize) + + # Exit if array is full + + nbuf = nbuf + psize + if (nbuf > maxbuf) + break + + # Compute offset to next piece to read into array + + axsize = 1 + for (idim = 1; idim <= ndim; idim = idim + 1) { + if (idim > pdim) { + axpos[idim] = axpos[idim] + TCS_INC(descrip,idim) + + if (axpos[idim] + TCS_INC(descrip,idim) <= + TCS_LAST(descrip,idim)) { + + off = off + axsize * TCS_INC(descrip,idim) + break + + } else { + axpos[idim] = TCS_FIRST(descrip,idim) + + off = off - axsize * (TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) + } + } + + axsize = axsize * axlen[idim] + } + + # Exit if array has been traversed + + if (idim > ndim) + break + } + + nbuf = nbuf - 1 + } +end + diff --git a/pkg/tbtables/selector/mkpkg b/pkg/tbtables/selector/mkpkg new file mode 100644 index 00000000..85a6b7ba --- /dev/null +++ b/pkg/tbtables/selector/mkpkg @@ -0,0 +1,50 @@ +# Update the selector library. +# Author: Bernie Simon, 18-Mar-96 +# +# Modified: 11/21/96, to be part of threed package (I.Busko) +# Modified: 103/17/97, added selrows function (I.Busko) +# Modified: 04/22/97, incorporated into sgraph package (W. Hack) +# 4 Dec 1997, added "$call generic" after "libtbtables.a" (Phil Hodge) +# 26 Mar 1998, added tbcga.x and tbcnel.x (Phil Hodge). + +$checkout libtbtables.a ../ +$update libtbtables.a +$checkin libtbtables.a ../ +$exit + +generic: + $ifnfile (generic/tcsrdaryi.x) + $generic -k -p generic/ -t bcsird tcsrdary.gx + $endif + $ifolder (generic/tcsrdaryi.x, tcsrdary.gx) + $generic -k -p generic/ -t bcsird tcsrdary.gx + $endif + ; + +libtbtables.a: + $call generic + @generic + omniread.x <tbset.h> <imhdr.h> <imio.h> + rdselect.x + rst.x + selrows.x + tcsaddcol.x + tcsclose.x + tcscolumn.x "tcs.h" + tcsintinfo.x "tcs.h" + tcslinesize.x "tcs.h" + tcsopen.x <tbset.h> "tcs.h" + tcsshape.x "tcs.h" + tcstotsize.x "tcs.h" + tcstxtinfo.x "tcs.h" + tbcga.x <tbset.h> + tbcnel.x <tbset.h> + trsclose.x "trs.h" + trseval.x "trs.h" + trsgencode.x <tbset.h> "trs.h" + trsopen.x "trs.h" "trsopen.com" + trsrows.x "trs.h" + trstree.x "trs.h" + trstrim.x + whatfile.x <imhdr.h> "whatfile.h" + ; diff --git a/pkg/tbtables/selector/omniread.x b/pkg/tbtables/selector/omniread.x new file mode 100644 index 00000000..71615a89 --- /dev/null +++ b/pkg/tbtables/selector/omniread.x @@ -0,0 +1,625 @@ +include <tbset.h> +include <imhdr.h> +include <imio.h> + +# OMNIREAD -- High level routine to read columns from image or table + +procedure omniread (file, dtype, data, nelem, ncol, maxcol) + +char file[ARB] # i: file name, including sections or selectors +int dtype # i: data type of data to be read +pointer data[ARB] # o: pointers to columns of output data +int nelem # o: length of output columns +int ncol # o: number of output columns +int maxcol # i: maximum number of columns +#-- +pointer sp, project + +errchk omniproject + +begin + # Allocate dummy projection array and set to zero, + # indicating projection should not be done + + call smark (sp) + call salloc (project, maxcol, TY_INT) + call aclri (Memi[project], maxcol) + + call omniproject (file, dtype, Memi[project], + data, nelem, ncol, maxcol) + + call sfree (sp) +end + +# OMNIPROJECT -- Read with optional projection of multi-dimensional columns + +procedure omniproject (file, dtype, project, data, nelem, ncol, maxcol) + +char file[ARB] # i: file name, including sections or selectors +int dtype # i: data type of data to be read +int project # i: axis to project multi-dimensional data on +pointer data[ARB] # o: pointers to columns of output data +int nelem # o: length of output columns +int ncol # o: number of output columns +int maxcol # i: maximum number of columns +#-- +string badtype "Unrecognized file type" + +int is_image() +errchk is_image, om_rdimage, om_rdtable, om_error + +begin + switch (is_image (file)) { + case YES: + if (maxcol > 0) { + ncol = 1 + call om_rdimage (file, dtype, project, data[1], nelem) + } else { + ncol = 0 + nelem = 0 + } + + case NO: + call om_rdtable (file, dtype, project, data, nelem, ncol, maxcol) + + default: + call om_error (file, badtype) + } + +end + +# -------------------------------------------------------------- +# The routines beyond this point are not in the public interface +# -------------------------------------------------------------- + +# OM_ERROR -- Error exit routine + +procedure om_error (file, message) + +char file[ARB] # i: file name +char message[ARB] # i: error message +#-- +pointer sp, text + +begin + call smark (sp) + call salloc (text, SZ_LINE, TY_CHAR) + + call sprintf (Memc[text], SZ_LINE, "%s (%s)\n") + call pargstr (message) + call pargstr (file) + + call error (1, Memc[text]) + + call sfree (sp) +end + +# OM_PROJIM -- Project a multi-dimensional image onto one dimension + +procedure om_projim (im, dtype, project, data, nelem) + +pointer im # i: image descriptor +int dtype # i: data type of data to be read +int project # i: axis to project multi-dimensional data on +pointer data # o: pointers to columns of output data +int nelem # o: length of output columns +#-- +int axis, nline +pointer sp, sum, vec, buf + +string badaxis "Cannot project data on axis" +string badtype "Unrecognized input datatype" + +double asumd() +int imgnld() +errchk om_error + +begin + # The projection is the average of the data along the + # non-included axes + + if (project <= 0 || project > IM_NDIM(im)) { + call om_error (IM_NAME(im), badaxis) + } + + # All calculations are done in double precision and then + # converted to the output type + + nelem = IM_LEN(im,project) + + call smark (sp) + call salloc (sum, nelem, TY_DOUBLE) + call salloc (vec, IM_MAXDIM, TY_LONG) + + call aclrd (Memd[sum], nelem) + call amovkl (long(1), Meml[vec], IM_MAXDIM) + + # Sum the data. In the general case, we read each line, + # get the index of the projected axis, compute the sum of + # that line and add the summed line to the indexed element + # of the sum. In the case where the projection is onto the + # first axis, we simply accumulate each line into the sum. + + if (project == 1) { + while (imgnld (im, buf, Meml[vec]) != EOF) + call aaddd (Memd[buf], Memd[sum], Memd[sum], nelem) + + } else { + axis = Meml[vec+project-1] + + while (imgnld (im, buf, Meml[vec]) != EOF) { + Memd[sum+axis-1] = Memd[sum+axis-1] + + asumd (Memd[buf], IM_LEN(im,1)) + axis = Meml[vec+project-1] + } + } + + # Divide sum by number of lines to get average + + nline = 1 + do axis = 1, IM_NDIM(im) { + if (axis != project) + nline = nline * IM_LEN(im,axis) + } + + call adivkd (Memd[sum], double(nline), Memd[sum], nelem) + + # Copy the result to an array of the proper data type + + call malloc (data, nelem, dtype) + + switch (dtype) { + case TY_SHORT: + call achtds (Memd[sum], Mems[data], nelem) + case TY_INT: + call achtdi (Memd[sum], Memi[data], nelem) + case TY_LONG: + call achtdl (Memd[sum], Meml[data], nelem) + case TY_REAL: + call achtdr (Memd[sum], Memr[data], nelem) + case TY_DOUBLE: + call amovd (Memd[sum], Memd[data], nelem) + default: + call om_error (IM_NAME(im), badtype) + } + + call sfree (sp) + +end + +# OM_PROJTAB -- Project a multidimensional array on a line + +procedure om_projtab (array, length, ndim, project, dtype, line) + +double array[ARB] # i: input array +int length[ARB] # i: array shape +int ndim # i: number of array dimensions +int project # i: axis to project onto +int dtype # i: datatype of output line +pointer line # o: output line +#-- +int linelen, elem, axis, idim +pointer sp, sum, nsum, vec + +string badtype "om_projtab: illegal datatype" + +begin + # Allocate temporary arrays for computing sums + + linelen = length[project] + + call smark (sp) + call salloc (sum, linelen, TY_DOUBLE) + call salloc (nsum, linelen, TY_INT) + call salloc (vec, ndim, TY_INT) + + # Initialize arrays + + call amovkd (double(0.0), Memd[sum], linelen) + call amovki (0, Memi[nsum], linelen) + call amovki (1, Memi[vec], ndim) + + elem = 1 + repeat { + # Determine which line element the array element is projected + # onto and add it to the sum + + axis = Memi[vec+project-1] + Memd[sum+axis-1] = Memd[sum+axis-1] + array[elem] + Memi[nsum+axis-1] = Memi[nsum+axis-1] + 1 + + # Increment array and line element + + elem = elem + 1 + for (idim = 1; idim <= ndim; idim = idim +1) { + Memi[vec+idim-1] = Memi[vec+idim-1] + 1 + if (Memi[vec+idim-1] > length[idim]) { + Memi[vec+idim-1] = 1 + } else { + break + } + } + + } until (idim > ndim) + + # Compute average + + do axis = 1, linelen { + if (Memi[nsum+axis-1] > 0) + Memd[sum+axis-1] = Memd[sum+axis-1] / Memi[nsum+axis-1] + } + + # Copy to output array of correct datatype + + switch (dtype) { + case TY_SHORT: + call achtds (Memd[sum], Mems[line], linelen) + case TY_INT: + call achtdi (Memd[sum], Memi[line], linelen) + case TY_LONG: + call achtdl (Memd[sum], Meml[line], linelen) + case TY_REAL: + call achtdr (Memd[sum], Memr[line], linelen) + case TY_DOUBLE: + call amovd (Memd[sum], Memd[line], linelen) + default: + call error (1, badtype) + } + + call sfree (sp) +end + +# OM_RDARRAY -- Read array data from a table + +procedure om_rdarray (tp, col, rcode, dtype, project, data, nelem, ncol) + +pointer tp # i: table descriptor +pointer col[ARB] # i: column selectors +pointer rcode # i: row selector +int dtype # i: data type of output columns +int project # i: axis to project multi-dimensional data on +pointer data[ARB] # o: pointers to output columns +int nelem # o: length of each output column +int ncol # i: number of columns +#-- +bool done +int irow, nrow, icol, coltype, osize, size, ndim +pointer sp, length, file, olddata + +string ambiguous "More than one row matches in file" +string badtype "Unrecognized input datatype" +string badsize "All arrays are not the same length" + +bool trseval() +int tbpsta(), tcs_totsize() +errchk trseval, om_error, tcs_rdarys, tcs_rdaryi, tcs_rdaryr, tcsrdaryd + +begin + # Allocate temporary arrays + + call smark (sp) + call salloc (length, IM_MAXDIM, TY_INT) + call salloc (file, SZ_PATHNAME, TY_CHAR) + + # Get table name for error messages + + call tbtnam (tp, Memc[file], SZ_PATHNAME) + + # Find the row which matches the row selector + # It is an error to have more than one row match + + done = false + nrow = tbpsta (tp, TBL_NROWS) + do irow = 1, nrow { + if (trseval (tp, irow, rcode)) { + if (done) + call om_error (Memc[file], ambiguous) + + done = true + do icol = 1, ncol { + # Determine which datatype is use to read the array + + if (project > 0) { + coltype = TY_DOUBLE + } else if (dtype == TY_LONG) { + coltype = TY_INT + } else { + coltype = dtype + } + + # Read the array from the table + + osize = tcs_totsize (col[icol]) + call malloc (data[icol], osize, coltype) + + switch (coltype) { + case TY_SHORT: + call tcs_rdarys (tp, col[icol], irow, osize, + size, Mems[data[icol]]) + case TY_INT, TY_LONG: + call tcs_rdaryi (tp, col[icol], irow, osize, + size, Memi[data[icol]]) + case TY_REAL: + call tcs_rdaryr (tp, col[icol], irow, osize, + size, Memr[data[icol]]) + case TY_DOUBLE: + call tcs_rdaryd (tp, col[icol], irow, osize, + size, Memd[data[icol]]) + default: + call om_error (Memc[file], badtype) + } + + + if (project > 0) { + # Project a multi-dimensional array onto + # a single dimension + + call tcs_shape (col[icol], Memi[length], + ndim, IM_MAXDIM) + + size = Memi[length+project-1] + + olddata = data[icol] + call malloc (data[icol], size, dtype) + + call om_projtab (Memd[olddata], Memi[length], ndim, + project, dtype, data[icol]) + + call mfree (olddata, TY_DOUBLE) + + } else if (dtype == TY_LONG) { + # Copy integer data to a long array + + olddata = data[icol] + call malloc (data[icol], size, dtype) + call achtil (Memi[olddata], Meml[data[icol]], size) + call mfree (olddata, TY_INT) + } + + # Check array lengths to make sure they are equal + + if (icol == 1) { + nelem = size + } else if (nelem != size) { + call om_error (Memc[file], badsize) + } + } + } + } + + call sfree (sp) +end + +# OM_RDIMAGE -- Read a line from an image + +procedure om_rdimage (file, dtype, project, data, nelem) + +char file[ARB] # i: file name, including sections or selectors +int dtype # i: data type of data to be read +int project # i: axis to project multi-dimensional data on +pointer data # o: pointers to columns of output data +int nelem # o: length of output columns +#-- +pointer im, buf + +string notline "Cannot read multi-dimensional data" +string badtype "Unrecognized input datatype" +string badaxis "Cannot project data on axis" + +pointer immap(), imgl1s(), imgl1i(), imgl1l(), imgl1r(), imgl1d() + +errchk immap, om_error, om_projim + +begin + data = NULL + nelem = 0 + + im = immap (file, READ_ONLY, NULL) + + if (project == 0 || IM_NDIM(im) == 1) { + # No projection, so check to see if the image is really + # one dimensional and read the line with the routine of + # the appropriate datatype + + if (IM_NDIM(im) > 1) + call om_error (file, notline) + + if (project > 1) + call om_error (file, badaxis) + + nelem = IM_LEN(im,1) + call malloc (data, nelem, dtype) + + switch (dtype) { + case TY_SHORT: + buf = imgl1s (im) + call amovs (Mems[buf], Mems[data], nelem) + case TY_INT: + buf = imgl1i (im) + call amovi (Memi[buf], Memi[data], nelem) + case TY_LONG: + buf = imgl1l (im) + call amovl (Meml[buf], Meml[data], nelem) + case TY_REAL: + buf = imgl1r (im) + call amovr (Memr[buf], Memr[data], nelem) + case TY_DOUBLE: + buf = imgl1d (im) + call amovd (Memd[buf], Memd[data], nelem) + default: + call om_error (file, badtype) + } + + } else { + call om_projim (im, dtype, project, data, nelem) + } + + call imunmap (im) +end + +# OM_RDSCALAR -- Read scalar data from a table + +procedure om_rdscalar (tp, col, rcode, dtype, data, nelem, ncol) + +pointer tp # i: table descriptor +pointer col[ARB] # i: column selectors +pointer rcode # i: row selector +int dtype # i: data type of output columns +pointer data[ARB] # o: pointers to output columns +int nelem # o: length of each output column +int ncol # i: number of columns +#-- +int irow, nrow, icol, ival +pointer sp, cp + +bool trseval() +int tbpsta() +pointer tcs_column() +errchk trseval, tbegts, tbegti, tbegtr, tbegtd + +begin + # Allocate arrays to read data and + # get column pointers from selectors + + nrow = tbpsta (tp, TBL_NROWS) + + call smark (sp) + call salloc (cp, ncol, TY_INT) + + do icol = 1, ncol { + Memi[cp+icol-1] = tcs_column (col[icol]) + call malloc (data[icol], nrow, dtype) + } + + # Look at each row and read values from rows where + # row selector expression is true. Use appropriate + # routine for the data type. + + nelem = 0 + do irow = 1, nrow { + if (trseval (tp, irow, rcode)) { + switch (dtype) { + case TY_SHORT: + do icol = 1, ncol + call tbegts (tp, Memi[cp+icol-1], irow, + Mems[data[icol]+nelem]) + case TY_INT: + do icol = 1, ncol + call tbegti (tp, Memi[cp+icol-1], irow, + Memi[data[icol]+nelem]) + case TY_LONG: + do icol = 1, ncol { + call tbegti (tp, Memi[cp+icol-1], irow, ival) + Memi[data[icol]+nelem] = ival + } + case TY_REAL: + do icol = 1, ncol + call tbegtr (tp, Memi[cp+icol-1], irow, + Memr[data[icol]+nelem]) + case TY_DOUBLE: + do icol = 1, ncol + call tbegtd (tp, Memi[cp+icol-1], irow, + Memd[data[icol]+nelem]) + } + + nelem = nelem + 1 + } + } + + # Reallocate memory to fit number of elements read + # Free memory if no elements were read + + do icol = 1, ncol { + if (nelem > 0) { + call realloc (data[icol], nelem, dtype) + } else { + call mfree (data[icol], dtype) + } + } + + call sfree (sp) +end + +# OM_RDTABLE -- Read data from table columns or arrays + +procedure om_rdtable (file, dtype, project, data, nelem, ncol, maxcol) + +char file[ARB] # i: file name, including sections or selectors +int dtype # i: data type of data to be read +int project # i: axis to project multi-dimensional data on +pointer data[ARB] # o: pointers to columns of output data +int nelem # o: length of output columns +int ncol # o: number of output columns +int maxcol # i: maximum number of columns +#-- +int nscalar, icol, length, ndim +pointer tp, sp, col, root, rowselect, colselect, rcode + +string nodata "Could not read data from file" +string norows "No rows read from file" +string mixtype "Cannot read both scalar and array columns" +string badaxis "Cannot project data on axis" + +pointer tbtopn(), trsopen() + +errchk rdselect, tbtopn, tcs_open, trsopen, om_error + +begin + # Break the table name into its various parts + + call smark (sp) + call salloc (col, maxcol, TY_INT) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (rowselect, SZ_PATHNAME, TY_CHAR) + call salloc (colselect, SZ_PATHNAME, TY_CHAR) + + call rdselect (file, Memc[root], Memc[rowselect], + Memc[colselect], SZ_PATHNAME) + + # Open then table + + tp = tbtopn (Memc[root], READ_ONLY, NULL) + + # Check to see if we are dealing with scalar or array columns + # It is an error to mix scalar and array columns in one call. + + call tcs_open (tp, Memc[colselect], Memi[col], ncol, maxcol) + + if (ncol == 0) + call om_error (file, nodata) + + nscalar = 0 + do icol = 1, ncol { + call tcs_shape (Memi[col+icol-1], length, ndim, 1) + if (ndim == 0) + nscalar = nscalar + 1 + } + + # Process the row selector + + rcode = trsopen (tp, Memc[rowselect]) + + # Call the appropriate + if (nscalar == ncol) { + do icol = 1, ncol { + if (project > 1) + call om_error (file, badaxis) + } + + call om_rdscalar (tp, Memi[col], rcode, dtype, + data, nelem, ncol) + if (nelem == 0) + call om_error (file, norows) + + } else if (nscalar == 0) { + call om_rdarray (tp, Memi[col], rcode, dtype, + project, data, nelem, ncol) + + } else { + call om_error (file, mixtype) + } + + call trsclose (rcode) + call tcs_close (Memi[col], ncol) + call tbtclo (tp) +end diff --git a/pkg/tbtables/selector/rdselect.x b/pkg/tbtables/selector/rdselect.x new file mode 100644 index 00000000..22b25db5 --- /dev/null +++ b/pkg/tbtables/selector/rdselect.x @@ -0,0 +1,152 @@ +define MAXSECT 3 + +# RDSELECT -- Break a filename into root and selectors + +procedure rdselect (file, root, rowselect, colselect, maxch) + +char file[ARB] # i: filename +char root[ARB] # o: filename minus any selectors +char rowselect[ARB] # o: row selector +char colselect[ARB] # o: column selector +int maxch # i: max length of output strings +#-- +char colon +int ic, nc, isect, nsect, idtype +pointer sp, ident, extend, errmsg, bracket[MAXSECT] + +data colon / ':' / +string idlist "|row|column|" +string badtype "Unrecognized selector (%s)" + +bool nextbrak() +int stridx(), strdic() + +errchk nextbrak + +begin + call smark (sp) + call salloc (ident, SZ_FNAME, TY_CHAR) + call salloc (extend, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Search for the first unescaped bracket + # Copy all chars prior to bracket into root + + for (ic = 1; file[ic] != EOS; ic = ic + 1) { + if (file[ic] == '\\' && file[ic+1] != EOS) { + ic = ic + 1 + } else if (file[ic] == '['){ + break + } + } + + nc = min (ic-1, maxch) + call strcpy (file, root, nc) + + # Get bracketed sections from file name + + for (isect = 1; isect <= MAXSECT; isect = isect + 1) { + + call salloc (bracket[isect], SZ_FNAME, TY_CHAR) + if (! nextbrak (file, ic, Memc[bracket[isect]], maxch)) + break + } + + nsect = isect - 1 + + rowselect[1] = EOS + colselect[1] = EOS + + # Use leading identifier to determine type of selector + + do isect = 1, nsect { + ic = stridx (colon, Memc[bracket[isect]]) + if (ic == 0) { + # Append bracketed sections with no identifier to the root + + call sprintf (Memc[extend], SZ_FNAME, "[%s]") + call pargstr (Memc[bracket[isect]]) + + call strcat (Memc[extend], root, maxch) + + } else if (ic > 0) { + call strcpy (Memc[bracket[isect]], Memc[ident], ic-1) + idtype = strdic (Memc[ident], Memc[ident], SZ_FNAME, idlist) + + if (idtype == 0) { + call sprintf (Memc[extend], SZ_FNAME, "[%s]") + call pargstr (Memc[bracket[isect]]) + + call strcat (Memc[extend], root, maxch) + + } else if (idtype == 1 && rowselect[1] == EOS) { + call strcpy (Memc[bracket[isect]+ic], rowselect, maxch) + + } else if (idtype == 2 && colselect[1] == EOS) { + call strcpy (Memc[bracket[isect]+ic], colselect, maxch) + + } else { + call sprintf (Memc[errmsg], SZ_LINE, badtype) + call pargstr (file) + + call error (1, Memc[errmsg]) + } + } + } + + call sfree (sp) +end + +# NEXTBRAK -- Get next bracketed section from file name + +bool procedure nextbrak (file, ic, section, maxch) + +char file[ARB] # i: file name +int ic # u: index to char within name +char section[ARB] # o: section extracted from name +int maxch # i: maximum length of section +#-- +int jc, level +pointer sp, errmsg + +string badsect "No closing bracket (%s)" + +begin + if (file[ic] != '[') { + section[1] = EOS + return (false) + } else { + level = 1 + ic = ic + 1 + } + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + jc = 1 + while (level > 0 && file[ic] != EOS) { + if (file[ic] == '[' && file[ic-1] != '\\') { + level = level + 1 + } else if (file[ic] == ']' && file[ic-1] != '\\') { + level = level - 1 + } + + if (level > 0 && jc <= maxch) { + section[jc] = file[ic] + jc = jc + 1 + } + + ic = ic + 1 + } + + section[jc] = EOS + + if (level > 0) { + call sprintf (Memc[errmsg], SZ_LINE, badsect) + call pargstr (file) + call error (1, Memc[errmsg]) + } + + call sfree (sp) + return (true) +end diff --git a/pkg/tbtables/selector/rst.x b/pkg/tbtables/selector/rst.x new file mode 100644 index 00000000..315c18df --- /dev/null +++ b/pkg/tbtables/selector/rst.x @@ -0,0 +1,1067 @@ +.help ----------------------------------------------------------------- +RST -- Functions used to manipulate row sets + +A row set is a structure used to represent some boolean condition over +the rows of a table. Rows for which the condition is true are included +in the set. The structure stores row numbers as an array of +ranges. The structure also contains the cumulative number of rows up +to the end of the range for each range in order to assist in searching +for the i-th row in the set. + +.nf +Create and destroy a row set + +set = rst_create (loval, hival) +set2 = rst_copy (set1) +call rst_free (set) + +Add or delete a row from the set + +call rst_addval (set, value) +call rst_delval (set, value) + +Update set to match insertion or deletions to table + +call rst_addtab (set, loval, nval) +call rst_deltab (set, loval, nval) + +Logical operations on a set + +set3 = rst_and (set1, set2) +set3 = rst_or (set1, set2) +set2 = rst_not (nrow, set1) + +Check to see if a row is in the set + +found = rst_inset (set, value) + +Get number of rows in the set + +count = rst_nelem (set) + +Retrieve the i-th row from the set + +row = rst_rownum (set, index) + +Make a string representation of a set + +call rst_show (set, str, maxch) + +.fi + +See the comments in the source for more information on the use of +these functions. Or ask Bernie Simon (bsimon@stsci.edu). + +.endhelp --------------------------------------------------------------- + +define LEN_RST 6 # length of row set structure +define LEN_TAIL 5 # length of tail structure + +define RST_LAST Memi[$1] # last element in row set +define RST_MAX Memi[$1+1] # max elements in row set +define RST_CURRENT Memi[$1+2] # current element in row set +define RST_LOARY Memi[$1+3] # array of low range ends +define RST_HIARY Memi[$1+4] # array of high range ends +define RST_NUMARY Memi[$1+5] # array of cumulative number of rows + +define RST_LOVAL Memi[RST_LOARY($1)+($2)-1] +define RST_HIVAL Memi[RST_HIARY($1)+($2)-1] +define RST_NROW Memi[RST_NUMARY($1)+($2)-1] + +# RST_ADDTAB -- Update set to reflect inserted rows in underlying table +# +# The important point is rows are inserted *after* loval and loval is +# not modified. All inserted rows are added to the set. Values after +# the range are increased by the number of values in the range. + +procedure rst_addtab (set, loval, nval) + +pointer set # i: row set +int loval # i: rows are inserted after this row +int nval # i: number of rows inserted +#-- +int idx, ndx, hival, range[2] +pointer tail + +int rst_findloc() +pointer rst_tail() + +begin + # Find range where new rows are inserted in the table + + idx = rst_findloc (set, loval + 1) + + # Handle the simple case where new rows are beyond rows already in set + + if (idx > RST_LAST(set)) { + call rst_addrange (set, loval + 1, loval + nval) + return + } + + # Check for union with existing range + + hival = loval + nval + + if (loval + 1 < RST_LOVAL(set,idx)) { + range[1] = loval + 1 + range[2] = hival + ndx = 0 + + } else { + range[1] = RST_LOVAL(set,idx) + range[2] = RST_HIVAL(set,idx) + nval + ndx = 1 + } + + # Save tail of set and truncate set + + tail = rst_tail (set, idx + ndx) + RST_LAST(set) = idx - 1 + + # Add range + + call rst_addrange (set, range[1], range[2]) + + # Add tail of set, shifting rows by number of inserted rows + + call rst_concat (set, tail, nval) + call rst_notail (tail) +end + +# RST_ADDVAL -- Add a value to a set +# +# Modify the set by adding a single row. The set is modified in place. +# If this function is called more than once in succession, it will be +# most efficient to order the values before adding them. + +procedure rst_addval (set, value) + +pointer set # i: row set +int value # i:value to add +#-- +int idx +pointer tail + +int rst_findloc() +pointer rst_tail() + +begin + # Find the location of the value in the set + + idx = rst_findloc (set, value) + + # Handle values past the end of the set as a special case + + if (idx > RST_LAST(set)) { + call rst_addrange (set, value, value) + return + } + + # Return if the value is already in the set + + if (value >= RST_LOVAL(set,idx)) + return + + # Save the tail of the current set and then truncate it + + tail = rst_tail (set, idx) + RST_LAST(set) = idx - 1 + + # Add value to the set + + call rst_addrange (set, value, value) + + # Restore the tail to the set + + call rst_concat (set, tail, 0) + call rst_notail (tail) + +end + +# RST_AND -- Intersection of two row sets +# +# Do a logical AND, or intersection, of two sets producing a third set. + +pointer procedure rst_and (set1, set2) + +pointer set1 # i: first row set +pointer set2 # i: second row set +#-- +int idx1, idx2, loval3, loval4, hival3, hival4 +pointer set3 + +pointer rst_create() + +begin + # Create output row set + + set3 = rst_create (0, 0) + + # Main loop: intersection of two sets + + idx1 = 1 + idx2 = 1 + loval3 = 0 + + while (idx1 <= RST_LAST(set1) && idx2 <= RST_LAST(set2)) { + + # If the output range is not set yet, set it + # Otherwise take the intesection of the input range + # with the input range that starts at the lower + # value. Add the intersection to the output set. + # When the output range is disjoint with both + # input ranges, discard it. + + if (loval3 == 0) { + if (RST_LOVAL(set1,idx1) <= RST_LOVAL(set2,idx2)) { + loval3 = RST_LOVAL(set1,idx1) + hival3 = RST_HIVAL(set1,idx1) + idx1 = idx1 + 1 + + } else { + loval3 = RST_LOVAL(set2,idx2) + hival3 = RST_HIVAL(set2,idx2) + idx2 = idx2 + 1 + } + + } else if (RST_LOVAL(set1,idx1) <= RST_LOVAL(set2,idx2)) { + if (RST_LOVAL(set1,idx1) <= hival3) { + loval4 = max (loval3, RST_LOVAL(set1,idx1)) + hival4 = min (hival3, RST_HIVAL(set1,idx1)) + + call rst_addrange (set3, loval4, hival4) + + if (RST_HIVAL(set1,idx1) <= hival3) { + idx1 = idx1 + 1 + } else { + loval3 = RST_LOVAL(set2,idx2) + hival3 = RST_HIVAL(set2,idx2) + idx2 = idx2 + 1 + } + + } else { + loval3 = 0 + } + + } else { + if (RST_LOVAL(set2,idx2) <= hival3) { + loval4 = max (loval3, RST_LOVAL(set2,idx2)) + hival4 = min (hival3, RST_HIVAL(set2,idx2)) + + call rst_addrange (set3, loval4, hival4) + + if (RST_HIVAL(set2,idx2) <= hival3) { + idx2 = idx2 + 1 + } else { + loval3 = RST_LOVAL(set1,idx1) + hival3 = RST_HIVAL(set1,idx1) + idx1 = idx1 + 1 + } + + } else { + loval3 = 0 + } + } + } + + # Take the intersection of the output range + # with the remaining input range + + while (idx1 <= RST_LAST(set1)) { + if (loval3 == 0 || RST_LOVAL(set1,idx1) > hival3) { + loval3 = 0 + break + } + + if (loval3 <= RST_HIVAL(set1,idx1)) { + loval4 = max (loval3, RST_LOVAL(set1,idx1)) + hival4 = min (hival3, RST_HIVAL(set1,idx1)) + call rst_addrange (set3, loval4, hival4) + } + + idx1 = idx1 + 1 + } + + while (idx2 <= RST_LAST(set2)) { + if (loval3 == 0 || RST_LOVAL(set2,idx2) > hival3) { + loval3 = 0 + break + } + + if (loval3 <= RST_HIVAL(set2,idx2)) { + loval4 = max (loval3, RST_LOVAL(set2,idx2)) + hival4 = min (hival3, RST_HIVAL(set2,idx2)) + call rst_addrange (set3, loval4, hival4) + } + + idx2 = idx2 + 1 + } + + return (set3) +end + +# RST_COPY -- Create a copy of an existing row set + +pointer procedure rst_copy (set1) + +pointer set1 # i: row set +#-- +int last, max +pointer set2 + +begin + call malloc (set2, LEN_RST, TY_INT) + + last = RST_LAST(set1) + max = RST_MAX(set1) + + call malloc (RST_LOARY(set2), max, TY_INT) + call malloc (RST_HIARY(set2), max, TY_INT) + call malloc (RST_NUMARY(set2), max, TY_INT) + + RST_LAST(set2) = last + RST_MAX(set2) = max + RST_CURRENT(set2) = 0 + + call amovi (RST_LOVAL(set1,1), RST_LOVAL(set2,1), last) + call amovi (RST_HIVAL(set1,1), RST_HIVAL(set2,1), last) + call amovi (RST_NROW(set1,1), RST_NROW(set2,1), last) + + return (set2) +end + +# RST_CREATE -- Create and initialize a new row set +# +# Create a new set containg a single range. To create an empty set, +# make the range (0,0). If the range limits are out of order, the +# procedure will swap them. + +pointer procedure rst_create (loval, hival) + +int loval # i: low end of range +int hival # i: high end of range +#-- +int temp +pointer set + +begin + call malloc (set, LEN_RST, TY_INT) + + call malloc (RST_LOARY(set), 1, TY_INT) + call malloc (RST_HIARY(set), 1, TY_INT) + call malloc (RST_NUMARY(set), 1, TY_INT) + + RST_MAX(set) = 1 + RST_CURRENT(set) = 0 + + if (loval > hival) { + temp = loval + loval = hival + hival = temp + } + + if (loval == 0) { + RST_LAST(set) = 0 + + } else { + RST_LAST(set) = 1 + RST_LOVAL(set,1) = loval + RST_HIVAL(set,1) = hival + RST_NROW(set,1) = hival - loval + 1 + } + + return (set) +end + +# RST_DELTAB -- Update set to reflect deleted rows in underlying table +# +# Update a set after rows have been deleted from the underlying table. +# All values within the deleted range are removed and values above the +# range are decreased by the number of rows in the range. + +procedure rst_deltab (set, loval, nval) + +pointer set # u: row set +int loval # i: first row deleted in underlying table +int nval # i: number of rows deleted in underlying table +#-- +int idx, jdx, ndx, hival, range[2,2] +pointer tail + +int rst_findloc() +pointer rst_tail() + +begin + # Find lower end of intersection of deleted rows with row set + + idx = rst_findloc (set, loval) + + if (idx > RST_LAST(set)) + return + + # If deleted rows intesect a range in the set, take the intersection + + ndx = 0 + if (loval > RST_LOVAL(set,idx)) { + ndx = 1 + range[1,1] = RST_LOVAL(set,idx) + range[2,1] = loval - 1 + } + + # Find the upper end of intersection of deleted rows with the row set + # hival is the first element past the deleted range + + hival = loval + nval + jdx = rst_findloc (set, hival) + + # If deleted rows intesect a range in the set, take the intersection + # Shift row numbers to account for deleted rows + + if (jdx <= RST_LAST(set)) { + if (hival > RST_LOVAL(set,jdx)) { + ndx = ndx + 1 + range[1,ndx] = hival - nval + range[2,ndx] = RST_HIVAL(set,jdx) - nval + jdx = jdx + 1 + } + } + + # Save the tail of the row set and truncate the set + + tail = rst_tail (set, jdx) + RST_LAST(set) = idx - 1 + + # Add the modified ranges to the table + + do jdx = 1, ndx + call rst_addrange (set, range[1,jdx], range[2,jdx]) + + # Add the ranges past the deleted range to the table, + # shifting row number to account for deleted rows + + call rst_concat (set, tail, - nval) + call rst_notail (tail) + +end + +# RST_DELVAL -- Delete a value from a set +# +# Remove a single value from the set. The set is updated in place. If +# this procedure is called several times, it is most effcient to order +# the values before deleting them. + +procedure rst_delval (set, value) + +pointer set # u: row set +int value # i:value to add +#-- +int idx, jdx, ndx, range[2,2] +pointer tail + +int rst_findloc() +pointer rst_tail() + +begin + # Find the location of the value in the set + + idx = rst_findloc (set, value) + + # Return if the value is not in the set + + if (idx < 1 || idx > RST_LAST(set)) + return + + if (value < RST_LOVAL(set,idx)) + return + + # Modify the range containing the element, + # which may split the range in two + + if (RST_LOVAL(set,idx) == RST_HIVAL(set, idx)) { + ndx = 0 + + } else if (value == RST_LOVAL(set,idx)) { + range[1,1] = value + 1 + range[2,1] = RST_HIVAL(set,idx) + ndx = 1 + + } else if (value == RST_HIVAL(set,idx)) { + range[1,1] = RST_LOVAL(set,idx) + range[2,1] = value - 1 + ndx = 1 + + } else { + range[1,1] = RST_LOVAL(set,idx) + range[2,1] = value - 1 + + range[1,2] = value + 1 + range[2,2] = RST_HIVAL(set,idx) + ndx = 2 + } + + # Save the tail of the current set and then truncate it + + tail = rst_tail (set, idx + 1) + RST_LAST(set) = idx - 1 + + # Add the modified ranges to the set + + do jdx = 1, ndx + call rst_addrange (set, range[1,jdx], range[2,jdx]) + + # Restore the tail to the set + + call rst_concat (set, tail, 0) + call rst_notail (tail) + +end + +# RST_FREE -- Free row set structure +# +# Release memory used by the row set + +procedure rst_free (set) + +pointer set # i: row set +#-- + +begin + call mfree (RST_NUMARY(set), TY_INT) + call mfree (RST_HIARY(set), TY_INT) + call mfree (RST_LOARY(set), TY_INT) + + call mfree (set, TY_INT) +end + +# RST_INSET -- Return true if value is in set + +bool procedure rst_inset (set, value) + +pointer set # i: row set +int value # i: value to be checked +#-- +bool result +int idx + +int rst_findloc() + +begin + idx = rst_findloc (set, value) + + if (idx > RST_LAST(set)) { + result = false + } else { + result = value >= RST_LOVAL(set,idx) + } + + return (result) +end + +# RST_NELEM -- Number of elements in a set + +int procedure rst_nelem (set) + +pointer set # i: row set +#-- +int nelem + +begin + if (RST_LAST(set) == 0) { + nelem = 0 + } else { + nelem = RST_NROW(set,RST_LAST(set)) + } + + return (nelem) +end + +# RST_NOT -- Complement of a row set +# +# Do a logical NOT, or complement of a set, producing a second set. +# the procedure requires the number of rows in the underlying table to +# know where to stop adding rows. This is the only procedure in this +# file where information about the underlying table is required. + +pointer procedure rst_not (nrow, set1) + +int nrow # i: largest possible value in set +pointer set1 # i: set to be negated +#-- +int idx1, loval2, hival2 +pointer set2 + +pointer rst_create() + +begin + set2 = rst_create (0,0) + + loval2 = 1 + do idx1 = 1, RST_LAST(set1) { + if (loval2 < RST_LOVAL(set1,idx1)) { + hival2 = RST_LOVAL(set1,idx1) - 1 + call rst_addrange (set2, loval2, hival2) + } + + loval2 = RST_HIVAL(set1,idx1) + 1 + } + + if (loval2 <= nrow) { + hival2 = nrow + call rst_addrange (set2, loval2, hival2) + } + + return (set2) +end + +# RST_OR -- Union of two row sets +# +# Do the logical OR, or union,of two sets, producing a third set. + +pointer procedure rst_or (set1, set2) + +pointer set1 # i: first row set +pointer set2 # i: second row set +#-- +int idx1, idx2, loval3, hival3 +pointer set3 + +pointer rst_create() + +begin + # Create output row set + + set3 = rst_create (0, 0) + + # Main loop: union of two sets + + idx1 = 1 + idx2 = 1 + loval3 = 0 + + while (idx1 <= RST_LAST(set1) && idx2 <= RST_LAST(set2)) { + + # Set the output range if not yet set, otherwise + # take the union of it with the set range that starts + # at the lowest value. If the output range is disjoint + # with the lower input range, add the output range to + # the output set and push back the input range + + if (loval3 == 0) { + if (RST_LOVAL(set1,idx1) <= RST_LOVAL(set2,idx2)) { + loval3 = RST_LOVAL(set1,idx1) + hival3 = RST_HIVAL(set1,idx1) + idx1 = idx1 + 1 + + } else { + loval3 = RST_LOVAL(set2,idx2) + hival3 = RST_HIVAL(set2,idx2) + idx2 = idx2 + 1 + } + + } else if (RST_LOVAL(set1,idx1) <= RST_LOVAL(set2,idx2)) { + if (RST_LOVAL(set1,idx1) <= hival3) { + loval3 = min (loval3, RST_LOVAL(set1,idx1)) + hival3 = max (hival3, RST_HIVAL(set1,idx1)) + idx1 = idx1 + 1 + + } else { + call rst_addrange (set3, loval3, hival3) + loval3 = 0 + } + + } else { + if (RST_LOVAL(set2,idx2) <= hival3) { + loval3 = min (loval3, RST_LOVAL(set2,idx2)) + hival3 = max (hival3, RST_HIVAL(set2,idx2)) + idx2 = idx2 + 1 + + } else { + call rst_addrange (set3, loval3, hival3) + loval3 = 0 + } + } + } + + # After comparison of two sets is finished, take union + # of output range with remaining input set. + + while (loval3 != 0 && idx1 <= RST_LAST(set1)) { + if (RST_LOVAL(set1,idx1) <= hival3) { + loval3 = min (loval3, RST_LOVAL(set1,idx1)) + hival3 = max (hival3, RST_HIVAL(set1,idx1)) + idx1 = idx1 + 1 + + } else { + call rst_addrange (set3, loval3, hival3) + loval3 = 0 + } + } + + while (loval3 != 0 && idx2 <= RST_LAST(set2)) { + if (RST_LOVAL(set2,idx2) <= hival3) { + loval3 = min (loval3, RST_LOVAL(set2,idx2)) + hival3 = max (hival3, RST_HIVAL(set2,idx2)) + idx2 = idx2 + 1 + + } else { + call rst_addrange (set3, loval3, hival3) + loval3 = 0 + } + } + + if (loval3 != 0) + call rst_addrange (set3, loval3, hival3) + + # When the two are disjoint, copy the remainder of the input set + # to the output set. + + while (idx1 <= RST_LAST(set1)) { + call rst_addrange(set3, RST_LOVAL(set1,idx1), RST_HIVAL(set1,idx1)) + idx1 = idx1 + 1 + } + + while (idx2 <= RST_LAST(set2)) { + call rst_addrange(set3, RST_LOVAL(set2,idx2), RST_HIVAL(set2,idx2)) + idx2 = idx2 + 1 + } + + return (set3) +end + +# RST_ROWNUM -- Convert an index into the set into a row number +# +# The row number is returned as the function value. If the index is not +# in the set, the row number is set to zero. The search method used is +# a compromise between sequential and binary search. The procedure uses +# the current row pointer as hint on where to locate the new row. + +int procedure rst_rownum (set, index) + +pointer set # i: row set +int index # i: index into the set +#-- +int inc, hi, lo, mid, irow + +begin + # Search for a bracket containing the element + # we are looking for + + if (RST_CURRENT(set) < 1 || RST_CURRENT(set) > RST_LAST(set)) { + # If range is undefined, set the bracket to the entire array + + lo = 0 + hi = RST_LAST(set) + 1 + + } else { + # Do we have the low end of the bracket or the high end? + + inc = 1 + if (index <= RST_NROW(set,RST_CURRENT(set))) { + # Have high end, search for low end + + hi = RST_CURRENT(set) + repeat { + lo = hi - inc + if (lo < 1) { + lo = 0 + break + } + + if (index > RST_NROW(set,lo)) + break + + hi = lo + inc = 2 * inc + } + + } else { + # Have low, end, search for high end + lo = RST_CURRENT(set) + repeat { + hi = lo + inc + if (hi > RST_LAST(set)) { + hi = RST_LAST(set) + 1 + break + } + + if (index <= RST_NROW(set,hi)) + break + + lo = hi + inc = 2 * inc + } + } + } + + # Now that we have a bracket, do a binary search + # to locate the range within the bracket + + while (hi > lo + 1) { + mid = (lo + hi) / 2 + if (index > RST_NROW(set,mid)) { + lo = mid + } else { + hi = mid + } + } + + # Find the row within the range + + if (hi < 1 || hi > RST_LAST(set)) { + irow = 0 + + } else { + irow = RST_HIVAL(set,hi) - (RST_NROW(set,hi) - index) + if (irow < 1) { + irow = 0 + hi = 0 + } + } + + RST_CURRENT(set) = hi + return (irow) +end + +# RST_SHOW -- Produce a string representation of the set +# +# Ranges are separated by commas and ranges with more than one value +# are represented by their endpoints separated by a colon. The notation +# is meant to match that used by trseval. + +procedure rst_show (set, str, maxch) + +pointer set # i: row set +char str[ARB] # o: string representation of set +int maxch # i: maximum length of string +#-- +int ic, idx +int itoc() + +begin + ic = 1 + do idx = 1, RST_LAST(set) { + ic = ic + itoc (RST_LOVAL(set,idx), str[ic], maxch-ic) + + if (RST_LOVAL(set,idx) != RST_HIVAL(set,idx)) { + str[ic] = ':' + ic = ic + 1 + + ic = ic + itoc (RST_HIVAL(set,idx), str[ic], maxch-ic) + } + + str[ic] = ',' + ic = ic + 1 + } + + if (ic > 1) + ic = ic - 1 + + str[ic] = EOS +end + +# ---------------------------------------------------------------------- +# Functions below this line are internal and not part of the public +# interface +# ---------------------------------------------------------------------- + +# RST_ADDRANGE -- Add a range at the end of a row set (low level) + +procedure rst_addrange (set, loval, hival) + +pointer set # u: row set +int loval # i: low end of range +int hival # i: high end of range +#-- +int last, nrow + +begin + + last = RST_LAST(set) + + if (last == 0) { + nrow = 0 + + } else { + nrow = RST_NROW(set,last) + + # Check for union with previous range + + if (RST_HIVAL(set,last) + 1 == loval) { + + RST_HIVAL(set,last) = hival + RST_NROW(set,last) = nrow + hival - loval + 1 + return + } + } + + # Increment number of values in arrays + + last = last + 1 + RST_LAST(set) = last + + # Allocate more space if arrays are full + + if (last > RST_MAX(set)) { + RST_MAX(set) = 2 * RST_MAX(set) + + call realloc (RST_LOARY(set), RST_MAX(set), TY_INT) + call realloc (RST_HIARY(set), RST_MAX(set), TY_INT) + call realloc (RST_NUMARY(set), RST_MAX(set), TY_INT) + } + + # Set array values + + RST_LOVAL(set,last) = loval + RST_HIVAL(set,last) = hival + RST_NROW(set,last) = nrow + hival - loval + 1 +end + +# RST_CONCAT -- Concatenate a tail structure onto a row set (low level) + +procedure rst_concat (set, tail, shift) + +pointer set # u: row set +pointer tail # i: tail structure +int shift # i: Amount to shift each value by +#-- +int idx + +begin + do idx = 1, RST_LAST(tail) + call rst_addrange (set, RST_LOVAL(tail,idx) + shift, + RST_HIVAL(tail,idx) + shift) + +end + +# RST_FINDLOC -- Find the location of an element within the set (low level) + +int procedure rst_findloc (set, value) + +pointer set # i: row set +int value # i: value whose location is sought +#-- +int inc, hi, lo, mid + +begin + # Search for a bracket containing the element + # we are looking for + + if (RST_CURRENT(set) < 1 || RST_CURRENT(set) > RST_LAST(set)) { + # If range is undefined, set the bracket to the entire array + + lo = 0 + hi = RST_LAST(set) + 1 + + } else { + # Do we have the low end of the bracket or the high end? + + inc = 1 + if (value <= RST_HIVAL(set,RST_CURRENT(set))) { + # Have high end, search for low end + + hi = RST_CURRENT(set) + repeat { + lo = hi - inc + if (lo < 1) { + lo = 0 + break + } + + if (value > RST_HIVAL(set,lo)) + break + + hi = lo + inc = 2 * inc + } + + } else { + # Have low, end, search for high end + lo = RST_CURRENT(set) + repeat { + hi = lo + inc + if (hi > RST_LAST(set)) { + hi = RST_LAST(set) + 1 + break + } + + if (value <= RST_HIVAL(set,hi)) + break + + lo = hi + inc = 2 * inc + } + } + } + + # Now that we have a bracket, do a binary search + # to locate the range within the bracket + + while (hi > lo + 1) { + mid = (lo + hi) / 2 + if (value > RST_HIVAL(set,mid)) { + lo = mid + } else { + hi = mid + } + } + + RST_CURRENT(set) = hi + return (hi) +end + +# RST_NOTAIL -- Free structure allocated to hold tail (low level) + +procedure rst_notail (tail) + +pointer tail # u: tail structure +#-- + +begin + if (RST_HIARY(tail) != NULL) + call mfree (RST_HIARY(tail), TY_INT) + + if (RST_LOARY(tail) != NULL) + call mfree (RST_LOARY(tail), TY_INT) + + call mfree (tail, TY_INT) +end + +# RST_TAIL -- Copy the tail of a row set into another structure (low level) + +pointer procedure rst_tail (set, idx) + +pointer set # i: row set +int idx # i: index of where copy starts +#-- +pointer tail + +begin + # Allocate and initialize structure + + call malloc (tail, LEN_TAIL, TY_INT) + + RST_LAST(tail) = max (RST_LAST(set) - idx + 1, 0) + RST_MAX(tail) = RST_LAST(tail) + RST_CURRENT(tail) = 0 + + if (RST_LAST(tail) == 0) { + # Tail is zero length, don't bother to allocate arrays + + RST_LOARY(tail) = NULL + RST_HIARY(tail) = NULL + + } else { + # Allocate memory for data arrays + + call malloc (RST_LOARY(tail), RST_LAST(tail), TY_INT) + call malloc (RST_HIARY(tail), RST_LAST(tail), TY_INT) + + # Copy data from old structure to data arrays + + call amovi (RST_LOVAL(set,idx), RST_LOVAL(tail,1), RST_LAST(tail)) + call amovi (RST_HIVAL(set,idx), RST_HIVAL(tail,1), RST_LAST(tail)) + } + + # Return + return (tail) +end diff --git a/pkg/tbtables/selector/selrows.x b/pkg/tbtables/selector/selrows.x new file mode 100644 index 00000000..2a82e9e7 --- /dev/null +++ b/pkg/tbtables/selector/selrows.x @@ -0,0 +1,30 @@ +#* HISTORY * +#* 17-Mar-97 I.Busko created +#* 15-Jan-97 B.Simon modified to call trsrows + +# SELROWS -- Count how many rows are selected by an expression + +int procedure selrows (tp, expr) + +pointer tp # i: table descriptor +char expr[ARB] # i: expression to be evaluated +#-- +int nrow +pointer set + +int rst_nelem() +pointer trsrows() +errchk trsrows + +begin + # Compute set of rows matching expression + + set = trsrows (tp, expr) + + # Count number of rows in set + + nrow = rst_nelem (set) + + call rst_free (set) + return (nrow) +end diff --git a/pkg/tbtables/selector/tbcga.x b/pkg/tbtables/selector/tbcga.x new file mode 100644 index 00000000..3076539e --- /dev/null +++ b/pkg/tbtables/selector/tbcga.x @@ -0,0 +1,110 @@ +include <tbset.h> + +# tbcga[] -- get an array of elements +# This routine gets an array of values, all elements from all selected rows. +# The number of elements in one row may have been reduced by the use of an +# array section, however, in which case only elements in the section will +# be copied to output. +# +# The function value will be the actual number of elements returned +# in the output buffer. It is an error if the output buffer is not +# large enough to contain all of the values. +# +# Phil Hodge, 5-Mar-1998 Function created. +# Phil Hodge, 18-Jun-1998 Error check the subroutines. + +int procedure tbcgad (tp, cp, buffer, nelem) + +pointer tp # i: pointer to table descriptor +pointer cp # i: pointer to column descriptor +double buffer[ARB] # o: values read from table +int nelem # i: maximum number of elements to read +#-- +pointer descrip # column selector descriptor +int nrows # number of selected rows +int row # loop index for selected row number +int nvals # number of elements in one cell +int nret # number returned, should be the same as nvals +int i +int tbagtd() +errchk tbagtd(), tbegtd(), tcs_rdaryd() + +begin + # Get descrip, nvals, and nrows. + call tbcnel1 (tp, cp, descrip, nvals, nrows) + + # Set nret because tbegtd doesn't return it. + if (nvals == 1) + nret = 1 + + if (nvals * nrows > nelem) + call error (1, "tbcgad: output buffer is too small") + + i = 1 + do row = 1, nrows { + + if (descrip == NULL) { + if (nvals == 1) + call tbegtd (tp, cp, row, buffer[i]) + else + nret = tbagtd (tp, cp, row, buffer[i], 1, nvals) + } else { + call tcs_rdaryd (tp, descrip, row, nelem-i+1, nret, buffer[i]) + } + + if (nret != nvals) + call error (1, "tbcgad: not all elements read from column") + + i = i + nvals + } + + return (i - 1) +end + +int procedure tbcgar (tp, cp, buffer, nelem) + +pointer tp # i: pointer to table descriptor +pointer cp # i: pointer to column descriptor +real buffer[ARB] # o: values read from table +int nelem # i: maximum number of elements to read +#-- +pointer descrip # column selector descriptor +int nrows # number of selected rows +int row # loop index for selected row number +int nvals # number of elements in one cell +int nret # number returned, should be the same as nvals +int i +int tbagtr() +errchk tbagtr(), tbegtr(), tcs_rdaryr() + +begin + # Get descrip, nvals, and nrows. + call tbcnel1 (tp, cp, descrip, nvals, nrows) + + # Set nret because tbegtd doesn't return it. + if (nvals == 1) + nret = 1 + + if (nvals * nrows > nelem) + call error (1, "tbcgar: output buffer is too small") + + i = 1 + do row = 1, nrows { + + if (descrip == NULL) { + if (nvals == 1) + call tbegtr (tp, cp, row, buffer[i]) + else + nret = tbagtr (tp, cp, row, buffer[i], 1, nvals) + } else { + call tcs_rdaryr (tp, descrip, row, nelem-i+1, nret, buffer[i]) + } + + if (nret != nvals) + call error (1, "tbcgar: not all elements read from column") + + i = i + nvals + } + + return (i - 1) +end diff --git a/pkg/tbtables/selector/tbcnel.x b/pkg/tbtables/selector/tbcnel.x new file mode 100644 index 00000000..9173a1ff --- /dev/null +++ b/pkg/tbtables/selector/tbcnel.x @@ -0,0 +1,52 @@ +include <tbset.h> + +# This file contains tbcnel and tbcnel1. + +# tbcnel -- get the total number of elements for a column +# This function multiplies the number of selected rows by the number of +# elements in one row, for the specified column. The column may contain +# scalars or arrays. +# +# If the column was listed in a column selector string, and if this +# included an array section, the number of elements for one row will be +# the number in the array section. +# +# Phil Hodge, 5-Mar-1998 Function created. + +int procedure tbcnel (tp, cp) + +pointer tp # i: pointer to table descriptor +pointer cp # i: pointer to column descriptor +#-- +pointer descrip # column selector descriptor (ignored) +int nrows # number of selected rows +int nelem # number of elements in one cell + +begin + call tbcnel1 (tp, cp, descrip, nelem, nrows) + + return (nrows * nelem) +end + +procedure tbcnel1 (tp, cp, descrip, nelem, nrows) + +pointer tp # i: pointer to table descriptor +pointer cp # i: pointer to column descriptor +pointer descrip # o: column selector descriptor +int nelem # o: number of elements in one cell +int nrows # o: number of selected rows +#-- +pointer tbcdes() +int tcs_totsize() +int tbpsta(), tbalen() + +begin + descrip = tbcdes (tp, cp) + + if (descrip == NULL) + nelem = tbalen (cp) # cp is not a selected column + else + nelem = tcs_totsize (descrip) + + nrows = tbpsta (tp, TBL_NROWS) # number of selected rows +end diff --git a/pkg/tbtables/selector/tcs.h b/pkg/tbtables/selector/tcs.h new file mode 100644 index 00000000..884cf716 --- /dev/null +++ b/pkg/tbtables/selector/tcs.h @@ -0,0 +1,12 @@ +# TCS.H --Descriptor for a table column array selector + +define MAXDIM 7 # max dimensions in table array + +define TCS_COLUMN Memi[$1] # table column pointer +define TCS_DIMEN Memi[$1+1] # dimensionality of array, + # zero for scalars +define TCS_FIRST Memi[3*($2)+$1-1] # first value in array +define TCS_LAST Memi[3*($2)+$1] # last value in array +define TCS_INC Memi[3*($2)+$1+1] # increment between values + +define TCS_LENGTH (3*($1)+2) diff --git a/pkg/tbtables/selector/tcsaddcol.x b/pkg/tbtables/selector/tcsaddcol.x new file mode 100644 index 00000000..c17f2cb9 --- /dev/null +++ b/pkg/tbtables/selector/tcsaddcol.x @@ -0,0 +1,26 @@ +# TCS_ADDCOL -- Add a single column to the list of descriptors + +procedure tcs_addcol (tp, cp, descrip, ndescrip, maxdescrip) + +pointer tp # i: table descriptor +pointer cp # i: column descriptor +pointer descrip[ARB] # u: list of column array selectors +int ndescrip # u: number of column array selectors +int maxdescrip # i: length of descrip array +#-- +string toomany "Overflow in descriptor array" + +begin + # Check for descriptor array overflow + + if (ndescrip >= maxdescrip) + call error (1, toomany) + + # Convert the column pointer to a table column descriptor + # Function tcs_fillstruct can be found in tcs_open + + ndescrip = ndescrip + 1 + call tcs_fillstruct (tp, cp, "", descrip[ndescrip]) + +end + diff --git a/pkg/tbtables/selector/tcsclose.x b/pkg/tbtables/selector/tcsclose.x new file mode 100644 index 00000000..3aa934ea --- /dev/null +++ b/pkg/tbtables/selector/tcsclose.x @@ -0,0 +1,14 @@ +# TCS_CLOSE -- Free memory associated with column selectors + +procedure tcs_close (descrip, ndescrip) + +pointer descrip[ARB] # i: column selectors +int ndescrip # i: number of descriptors +#-- +int id + +begin + do id = 1, ndescrip + call mfree (descrip[id], TY_INT) + +end diff --git a/pkg/tbtables/selector/tcscolumn.x b/pkg/tbtables/selector/tcscolumn.x new file mode 100644 index 00000000..4038cc8d --- /dev/null +++ b/pkg/tbtables/selector/tcscolumn.x @@ -0,0 +1,12 @@ +include "tcs.h" + +# TCS_COLUMN -- Get column pointer from column selector + +pointer procedure tcs_column (descrip) + +pointer descrip # i: column descriptor +#-- + +begin + return (TCS_COLUMN(descrip)) +end diff --git a/pkg/tbtables/selector/tcsintinfo.x b/pkg/tbtables/selector/tcsintinfo.x new file mode 100644 index 00000000..f6a62c74 --- /dev/null +++ b/pkg/tbtables/selector/tcsintinfo.x @@ -0,0 +1,14 @@ +include "tcs.h" + +# TCS_INTINFO -- Integer information about a column + +int procedure tcs_intinfo (descrip, what) + +pointer descrip # i: column selector +int what # i: parameter +#-- +int tbcigi() + +begin + return (tbcigi (TCS_COLUMN(descrip), what)) +end diff --git a/pkg/tbtables/selector/tcslinesize.x b/pkg/tbtables/selector/tcslinesize.x new file mode 100644 index 00000000..80d8309f --- /dev/null +++ b/pkg/tbtables/selector/tcslinesize.x @@ -0,0 +1,26 @@ +include "tcs.h" + +# TCS_LINESIZE -- Size of a single line in a column array + +int procedure tcs_linesize (descrip) + +pointer descrip # i: column selector +#-- +int size, ndim +pointer sp, length + +begin + call smark (sp) + call salloc (length, MAXDIM, TY_INT) + + # Get length of each axis + + call tcs_shape (descrip, Memi[length], ndim, MAXDIM) + + # Return length of first + + size = Memi[length] + call sfree (sp) + + return (size) +end diff --git a/pkg/tbtables/selector/tcsopen.x b/pkg/tbtables/selector/tcsopen.x new file mode 100644 index 00000000..f50ba282 --- /dev/null +++ b/pkg/tbtables/selector/tcsopen.x @@ -0,0 +1,818 @@ +include <tbset.h> +include "tcs.h" + +define MAX_STACK 8 # max file depth in column list +define DELIM ',' # column name separator +define COMMENT '#' # comment character +define ESCAPE '\\' # escape character +define SQUOTE '\'' # single quote +define DQUOTE '"' # double quote +define LPAREN '(' # left parenthesis +define RPAREN ')' # right parenthesis +define NEWLINE '\n' # end of line character +define NOTWHITE ($1 > ' ') # private definition of white space + +.help tcs_open +.nf___________________________________________________________________________ +Table column selector + +This file contains procedures to expand a list of column names into an +array of column descriptors which match the list. The list is a list +of column patterns separated by commas. The column pattern is either +a column name, a file name containing a list of column names, or a +pattern using the usual IRAF pattern matching syntax. For example, the +string + + a[1-9], b, time*, @column.lis + +would be expanded as the column names a1 through a9, b, any column +name beginning with "time", and all the column names in the file +column.lis. If the column list is entirely whitespace, the array of +column descriptors will include all the columns in the table, as this +seems the most reasonable default. If the first non-white character is +the negation character (either ~ or !), the array of column descriptors +will include all columns not matched by the list. The negation character +only has this meaning at the beginning of the list. + +Column names may also contain array sections having the same format +as image sections. The sections are surrounded by parentheses. For example + + spec(1:200:2) image(*,30) spec (20:*) + +are valid array sections. + +.endhelp______________________________________________________________________ + +# TCS_OPEN -- Convert a list of column names to a list of descriptors + +procedure tcs_open (tp, columns, descrip, ndescrip, maxdescrip) + +pointer tp # i: table descriptor +char columns[ARB] # i: list of column names +pointer descrip[ARB] # o: list of column array selectors +int ndescrip # o: number of column array selectors +int maxdescrip # i: length of descrip array +#-- +bool negate, file +int ncols, top, fd_stack[MAX_STACK] +pointer sp, token, pattern, section, errmsg + +string overflow "Column list has too many nested files" + +bool tcs_hasmeta() +int tcs_token(), strlen(), stropen(), open() + +errchk tcs_patmatch + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (token, SZ_FNAME, TY_CHAR) + call salloc (pattern, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Keep track of the number of column patterns and the negation + # pattern. At the end of the procedure, if no patterns were read, + # the list is blank, which signifies all columns should be used. + # If the negation character is encountered, the list of columns + # to use is inverted. + + ncols = 0 + negate = false + + # Initialize the number of columns matched to zero + + ndescrip = 0 + + # Since the column list may contain filenames, which in turn will + # contain other lists, we use a stack of file descriptors to keep + # track of the current file. The column list is also opened as a + # file, for the sake of generality in the code. + + top = 1 + file = false + fd_stack[1] = stropen (columns, strlen(columns), READ_ONLY) + + while (top > 0) { + # The tokenizer either returns a negation character (! or ~) + # a filename (preceded by a @) or a column name. Tokens, + # except for the negation character, are separated by commas. + + while (tcs_token (fd_stack[top], file, Memc[token], SZ_FNAME) > 0){ + ncols = ncols + 1 + + if (Memc[token] == '!') { + # Negation character. Only is significant as first + # character in the column list. + + negate = (ncols == 1) + ncols = ncols - 1 + + } else if (Memc[token] == '@') { + # Filename. Open the file and push it on the stack. + + if (top == MAX_STACK) + call error (1, overflow) + + top = top + 1 + fd_stack[top] = open (Memc[token+1], READ_ONLY, TEXT_FILE) + + ncols = ncols - 1 + + } else { + # Column pattern. Remove the section from the pattern + + call tcs_breakname (Memc[token], Memc[pattern], + Memc[section]) + + # Look for metacode characters. If found, call the + # pattern matching routine, otherwise call the string + # matching routine. The division between the routines + # is for reasons of efficiency. + + call strlwr (Memc[pattern]) + + if (tcs_hasmeta (Memc[pattern], SZ_FNAME)) { + call tcs_patmatch (tp, Memc[pattern], Memc[section], + descrip, ndescrip, maxdescrip) + } else { + call tcs_strmatch (tp, Memc[pattern], Memc[section], + descrip, ndescrip, maxdescrip) + } + } + + file = top > 1 + } + + # All columns have been read from this file, + # so pop it from the stack + + call close (fd_stack[top]) + top = top - 1 + } + + # A blank list signifies select all columns from the table + + if (ncols == 0) + call tcs_allcols (tp, descrip, ndescrip, maxdescrip) + + # The negation character signifies those columns not in the list + # should be selected + + if (negate) + call tcs_invert (tp, descrip, ndescrip, maxdescrip) + + call sfree (sp) +end + +# TCS_TOKEN -- Extract the next token from a column list + +int procedure tcs_token (fd, file, token, maxch) + +int fd # i: descriptor of file containing column list +bool file # i: is the read coming from a file? +char token[ARB] # o: token string +int maxch # i: declared length of token string +#-- +char ch +int nc, endch, paren + +char getc() + +begin + # Eat leading whitespace and delimeters + + repeat { + ch = getc (fd, ch) + + # Eat comment if we are reading from a file + + if (ch == COMMENT && file) { + repeat { + ch = getc (fd, ch) + } until (ch == EOF || ch == NEWLINE) + } + + } until (ch == EOF || (NOTWHITE(ch) && ch != DELIM)) + + + # Leading character determines rest of processing + + if (ch == EOF) { + # End of file. Return null string + token[1] = EOS + return (0) + + } else if (ch == '!' || ch == '~') { # ~ added on 1999 Jan 29 + # Negation character. Return the character. + + token[1] = '!' # same token for both negation characters + token[2] = EOS + return (1) + + } else if (ch == '@') { + # A filename. Return all characters up to whitespace or + # the next delimeter. + + nc = 1 + while (NOTWHITE(ch) && ch != DELIM) { + if (nc <= maxch) { + token[nc] = ch + nc = nc + 1 + } + + ch = getc (fd, ch) + } + + token[nc] = EOS + return (nc - 1) + + } else if (ch == SQUOTE || ch == DQUOTE){ + # A quoted string. Return all characters up to and including + # the closing quote. + + endch = ch + + nc = 1 + repeat { + if (nc < maxch) { + token[nc] = ch + nc = nc + 1 + } + + ch = getc (fd, ch) + } until (ch == EOF || ch == endch) + + token[nc] = endch + token[nc+1] = EOS + return (nc) + + } else { + # An ordinary column name. Return all characters up to the next + # whitespace or delimeter. Delimeters inside parentheses + # are part of the column section and are not treated as delimeters. + + nc = 1 + paren = 0 + while (NOTWHITE(ch) && (paren > 0 || ch != DELIM)) { + if (nc <= maxch) { + token[nc] = ch + nc = nc + 1 + } + + if (ch == LPAREN) { + paren = paren + 1 + } else if (ch == RPAREN) { + paren = paren - 1 + } + + ch = getc (fd, ch) + } + + token[nc] = EOS + return (nc - 1) + } + +end + +# TCS_BREAKNAME -- Break a column name into root and section + +procedure tcs_breakname (name, root, section) + +char name[ARB] # i: column name +char root[ARB] # o: root (everything up to the parentheses) +char section[ARB] # o: section (everything in the parentheses) +#-- +int ic, jc, kc, paren, state + +begin + jc = 1 + kc = 1 + paren = 0 + state = 1 + + # There are three states: Before the first parenthesis + # where characters are copied to the root, inside the + # parentheses where characters are copied to the section + # and after the parentheses where characters are again + # copied to the root. The variable paren keeps track of + # parentheses so we can transition between the second and + # third state at the parenthesis that matches the first. + + for (ic = 1; name[ic] != EOS; ic = ic + 1) { + if (state == 1) { + if (name[ic] == LPAREN) { + section[kc] = name[ic] + kc = kc + 1 + + state = 2 + paren = 1 + } else { + root[jc] = name[ic] + jc = jc + 1 + } + + } else if (state == 2) { + if (paren == 0) { + state = 3 + } else { + # Whitespace is not copied to the section + + if (NOTWHITE(name[ic])) { + section[kc] = name[ic] + kc = kc + 1 + } + + if (name[ic] == LPAREN) { + paren = paren + 1 + } else if (name[ic] == RPAREN) { + paren = paren - 1 + } + } + } else if (state == 3) { + root[jc] = name[ic] + jc = jc +1 + } + } + + root[jc] = EOS + section[kc] = EOS + +end + +# TCS_HASMETA -- Check for presence of metacharacters + +bool procedure tcs_hasmeta (pattern, maxch) + +char pattern[ARB] # u: character string +int maxch # i: declared length of pattern +#-- +bool meta +int ic, jc +pointer sp, buffer + +int stridx() + +begin + # If the pattern is enclosed in quotes, all characters are + # interpreted as literals. Strip quotes from the pattern and + # return false. + + if (pattern[1] == SQUOTE || pattern[1] == DQUOTE) { + for (ic = 1; pattern[ic] != EOS; ic = ic + 1) + pattern[ic] = pattern[ic+1] + + pattern[ic-2] = EOS + return (false) + } + + # Copy the pattern to a temporary buffer + + call smark (sp) + call salloc (buffer, maxch, TY_CHAR) + + jc = 0 + meta = false + for (ic = 1; pattern[ic] != EOS; ic = ic + 1) { + + if (pattern[ic] == ESCAPE && pattern[ic+1] != EOS) { + # Copy escape sequences but do not count as metacharacters + + ic = ic + 1 + if (jc <= maxch) { + Memc[buffer+jc] = ESCAPE + jc = jc + 1 + } + + } else if (pattern[ic] == '*') { + # Convert '*' to '?*', count as metacharacter + + meta = true + if (jc <= maxch) { + Memc[buffer+jc] = '?' + jc = jc + 1 + } + + } else if (stridx (pattern[ic], "[?{") > 0) { + # Check for other metacharacters + + meta = true + } + + if (jc <= maxch) { + Memc[buffer+jc] = pattern[ic] + jc = jc + 1 + } + } + + Memc[buffer+jc] = EOS + + if (meta) { + # Enclose pattern in "^pattern$" to force match + # of entire column name + + call sprintf (pattern, maxch, "^%s$") + call pargstr (Memc[buffer]) + + } else { + # Remove escape characters from pattern + # if there are no metacharacters + + jc = 1 + for (ic = 0; Memc[buffer+ic] != EOS; ic = ic + 1) { + if (Memc[buffer+ic] == ESCAPE && Memc[buffer+ic+1] != EOS) + ic = ic + 1 + + pattern[jc] = Memc[buffer+ic] + jc = jc + 1 + } + + pattern[jc] = EOS + } + + call sfree (sp) + return (meta) +end + +# TCS_PATMATCH -- Match column names containing metacharacters + +procedure tcs_patmatch (tp, pattern, section, descrip, ndescrip, maxdescrip) + +pointer tp # i: table descriptor +char pattern[ARB] # i: pattern to match +char section[ARB] # i: array section +pointer descrip[ARB] # u: list of column array selectors +int ndescrip # u: number of column array selectors +int maxdescrip # i: length of descrip array +#-- +int icol, ncols, id +pointer sp, buffer, colname, errmsg, cp + +string badpattern "Syntax error in wildcard pattern (%s)" + +int tbpsta(), patmake(), patmatch() +pointer tbcnum() + +errchk tcs_fillstruct + +begin + # Allocate temporary strings + + call smark (sp) + call salloc (buffer, SZ_LINE, TY_CHAR) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Compile the pattern + + if (patmake (pattern, Memc[buffer], SZ_LINE) == ERR) { + call sprintf (Memc[errmsg], SZ_LINE, badpattern) + call pargstr (pattern) + call error (1, Memc[errmsg]) + } + + # Look at each column name to see if it matches the pattern. + # If the pattern matches, add it to the list if the column + # has not already been matched. + + ncols = tbpsta (tp, TBL_NCOLS) + + do icol = 1, ncols { + # Get column name from column number + + cp = tbcnum (tp, icol) + call tbcigt (cp, TBL_COL_NAME, Memc[colname], SZ_COLNAME) + call strlwr (Memc[colname]) + + # Pattern matching test + + if (patmatch (Memc[colname], Memc[buffer]) > 0) { + # Check to see if already matched + + for (id = 1; id <= ndescrip; id = id + 1) { + if (cp == TCS_COLUMN(descrip[id])) + break + } + + # Add to array if not already matched and array not full + + if (id > ndescrip && ndescrip < maxdescrip) { + ndescrip = ndescrip + 1 + call tcs_fillstruct (tp, cp, section, descrip[ndescrip]) + } + } + } + + call sfree (sp) +end + +# TCS_STRMATCH -- Match column names to table columns + +procedure tcs_strmatch (tp, pattern, section, descrip, ndescrip, maxdescrip) + +pointer tp # i: table descriptor +char pattern[ARB] # i: pattern to match +char section[ARB] # i: array section +pointer descrip[ARB] # u: list of column array selectors +int ndescrip # u: number of column array selectors +int maxdescrip # i: length of descrip array +#-- +int id +pointer cp + +errchk tcs_fillstruct + +begin + # Find column pointer corresponding to column name + + call tbcfnd (tp, pattern, cp, 1) + + if (cp == NULL) + return + + # Check to see if already matched + + for (id = 1; id <= ndescrip; id = id + 1) { + if (cp == TCS_COLUMN(descrip[id])) + break + } + + # Add to array if not already matched and array not full + + if (id > ndescrip && ndescrip < maxdescrip) { + ndescrip = ndescrip + 1 + call tcs_fillstruct (tp, cp, section, descrip[ndescrip]) + } +end + +# TCS_FILLSTRUCT -- Fill structure with info about the column + +procedure tcs_fillstruct (tp, cp, section, descrip) + +pointer tp # i: table descriptor +pointer cp # i: column descriptor +char section[ARB] # i: column array section +pointer descrip # i: column array selector +#-- +int ic, idim, ndim, first, last, inc, axlen[MAXDIM] + +string baddimen "Dimension of section does not match column" + +int tcs_getsect() +errchk tcs_getsect + +begin + # Get dimension of array and length of each axis + + call tbciga (tp, cp, ndim, axlen, MAXDIM) + + # Allocate column selector descriptor + + call malloc (descrip, TCS_LENGTH(ndim), TY_INT) + + if (section[1] == EOS) { + # If there is no section, copy the array dimensions + # to the descriptor + + + do idim = 1, ndim { + TCS_FIRST(descrip,idim) = 1 + TCS_LAST(descrip,idim) = axlen[idim] + TCS_INC(descrip,idim) = 1 + } + + } else { + # If there is a section, parse it and copy it to descriptor + + ic = 2 + do idim = 1, ndim { + if (tcs_getsect (section, ic, first, last, inc) <= 0){ + # Not enough dimensions in section + + call mfree (descrip, TY_INT) + call error (1, baddimen) + } + + TCS_FIRST(descrip,idim) = first + TCS_INC(descrip,idim) = inc + + # Indef indicates an asterisk in the section, for which + # we substitute the actual array dimension + + if (IS_INDEFI (last)) { + TCS_LAST(descrip,idim) = axlen[idim] + } else { + TCS_LAST(descrip,idim) = last + } + } + + # It is an error if the section has more dimensions than the array + + if (section[ic] != EOS) { + call mfree (descrip, TY_INT) + call error (1, baddimen) + } + } + + # Eliminate spurious dimensions from the array + + for (idim = ndim; idim > 0; idim = idim - 1) { + if (axlen[idim] > 1) + break + } + + ndim = idim + + # Save the column pointer and number of dimensions in the descriptor + + TCS_COLUMN(descrip) = cp + TCS_DIMEN(descrip) = ndim + +end + +# TCS_GETSECT -- Parse the array section string + +int procedure tcs_getsect (section, ic, first, last, inc) + +char section[ARB] # i: section string +int ic # u: starting character in string +int first # o: first element in array +int last # o: last element in array +int inc # o: array increment +#-- +bool done +int jc, nc, ival, old_ic, value +pointer sp, number + +bool streq() +int stridx(), ctoi() + +string badsect "Syntax error in array section" + +begin + # Temporary string to hold numeric token + + call smark (sp) + call salloc (number, SZ_FNAME, TY_CHAR) + + # Set defaults for outputs + + first = 1 + last = 1 + inc = 1 + + # Read charcaters from section until a delimeter is found. + # Then check to see if it is a wildcard. If not, convert it + # to a number and set the appropriate output. + + jc = 0 + ival = 1 + old_ic = ic + done = false + + while (! done && section[ic] != EOS) { + if (stridx (section[ic], "(),:") == 0) { + # Copy characters until delimeter + + Memc[number+jc] = section[ic] + jc = jc + 1 + + } else { + Memc[number+jc] = EOS + + if (streq (Memc[number], "*")) { + last = INDEFI + + } else { + # Convert string to number + + jc = 1 + nc = ctoi (Memc[number], jc, value) + + # Check for trailing non-numeric chars + + if (Memc[number+nc] != EOS) + call error (1, badsect) + + # Set appropriate output + + switch (ival) { + case 1: + first = value + case 2: + last = value + if (last < first) + call error (1, badsect) + case 3: + inc = value + default: + call error (1, badsect) + } + + ival = ival + 1 + } + + # Reset to read next string + + jc = 0 + + # Exit loop when delimeter or closing parenthesis seen + + done = (section[ic] == DELIM || section[ic] == RPAREN) + } + + ic = ic + 1 + } + + # A single number indicates one element in the array + + if (last == 1 && first > 1) + last = first + + call sfree (sp) + return (ic - old_ic) + +end + +# TCS_ALLCOLS -- Get descriptors for all columns in the table + +procedure tcs_allcols (tp, descrip, ndescrip, maxdescrip) + +pointer tp # i: table descriptor +pointer descrip[ARB] # o: list of column array selectors +int ndescrip # o: number of column array selectors +int maxdescrip # i: length of descrip array +#-- +int icol, ncols +pointer cp + +int tbpsta() +pointer tbcnum() + +begin + ncols = tbpsta (tp, TBL_NCOLS) + ncols = min (ncols, maxdescrip) + + do icol = 1, ncols { + cp = tbcnum (tp, icol) + + ndescrip = ndescrip + 1 + call tcs_fillstruct (tp, cp, "", descrip[ndescrip]) + } + +end + +# TCS_INVERT -- Get descriptors for all columns not currently in list + +procedure tcs_invert (tp, descrip, ndescrip, maxdescrip) + +pointer tp # i: table descriptor +pointer descrip[ARB] # o: list of column array selectors +int ndescrip # o: number of column array selectors +int maxdescrip # i: length of descrip array +#-- +int id, icol, jcol, ncols +pointer cp, sp, clist + +int tbpsta() +pointer tbcnum() + +begin + # Allocate temporary array for column list + + ncols = tbpsta (tp, TBL_NCOLS) + + call smark (sp) + call salloc (clist, ncols, TY_INT) + + # Get each column pointer and search column selectors for a match + # If none is, found, copy the pointer to the column list + + jcol = 0 + do icol = 1, ncols { + cp = tbcnum (tp, icol) + for (id = 1; id <= ndescrip; id = id + 1) { + if (TCS_COLUMN(descrip[id]) == cp) + break + } + + if (id > ndescrip) { + Memi[clist+jcol] = cp + jcol = jcol + 1 + } + } + + # Free the old descriptors + + call tcs_close (descrip, ndescrip) + + # Get the column descriptors for the columns in the list + + ndescrip = min (jcol, maxdescrip) + do id = 1, ndescrip + call tcs_fillstruct (tp, Memi[clist+id-1], "", descrip[id]) + + call sfree (sp) +end diff --git a/pkg/tbtables/selector/tcsrdary.gx b/pkg/tbtables/selector/tcsrdary.gx new file mode 100644 index 00000000..324e96aa --- /dev/null +++ b/pkg/tbtables/selector/tcsrdary.gx @@ -0,0 +1,140 @@ +include "../tcs.h" + +# TCS_RDARY -- Read an array using the column selector + +$if (datatype == c) +procedure tcs_rdaryt (tp, descrip, irow, maxch, maxbuf, nbuf, buffer) +$else +procedure tcs_rdary$t (tp, descrip, irow, maxbuf, nbuf, buffer) +$endif + +pointer tp # i: table descriptor +pointer descrip # i: column selector +int irow # i: table row number +$if (datatype == c) +int maxch # i: max length of string +$endif +int maxbuf # i: declared length of buffer +int nbuf # o: length of output array +$if (datatype == c) +char buffer[maxch,ARB] # o: array of values +$else +PIXEL buffer[ARB] # o: array of values +$endif +#-- +int idim, ndim, pdim, plen, psize, off +int axsize, axlen[MAXDIM], axpos[MAXDIM] + +$if (datatype == c) +int tbagtt() +$else +int tbagt$t() +$endif + +begin + if (TCS_DIMEN(descrip) == 0) { + # Column is a scalar, use a scalar read routine + + if (maxbuf > 0) { + nbuf = 1 + $if (datatype == c) + call tbegtt (tp, TCS_COLUMN(descrip), irow, buffer, maxch) + $else + call tbegt$t (tp, TCS_COLUMN(descrip), irow, buffer) + $endif + } else { + nbuf = 0 + } + + } else { + # Compute size and dimensionality of the largest contigous + # piece that can be read from the array + + call tbciga (tp, TCS_COLUMN(descrip), ndim, axlen, MAXDIM) + + pdim = 0 + psize = 1 + do idim = 1, TCS_DIMEN(descrip) { + if (TCS_INC(descrip,idim) > 1) + break + + pdim = pdim + 1 + plen = (TCS_LAST(descrip,idim) - TCS_FIRST(descrip,idim) + 1) + psize = psize * plen + + if (plen < axlen[idim]) + break + } + + # Compute offset to first element to be read into array + + off = 0 + do idim = ndim-1, 1, -1 + off = (off + TCS_FIRST(descrip,idim+1) - 1) * axlen[idim] + + off = off + TCS_FIRST(descrip,1) + + # Save position of first element to be read in array + + do idim = 1 , ndim + axpos[idim] = TCS_FIRST(descrip,idim) + + nbuf = 1 + + repeat { + + # Adjust piece size for possible overflow + + if (nbuf + psize > maxbuf) + psize = maxbuf - (nbuf - 1) + + # Read chunk from array + + $if (datatype == c) + psize = tbagtt (tp, TCS_COLUMN(descrip), irow, + buffer[1,nbuf], maxch, off, psize) + $else + psize = tbagt$t (tp, TCS_COLUMN(descrip), irow, + buffer[nbuf], off, psize) + $endif + + # Exit if array is full + + nbuf = nbuf + psize + if (nbuf > maxbuf) + break + + # Compute offset to next piece to read into array + + axsize = 1 + for (idim = 1; idim <= ndim; idim = idim + 1) { + if (idim > pdim) { + axpos[idim] = axpos[idim] + TCS_INC(descrip,idim) + + if (axpos[idim] + TCS_INC(descrip,idim) <= + TCS_LAST(descrip,idim)) { + + off = off + axsize * TCS_INC(descrip,idim) + break + + } else { + axpos[idim] = TCS_FIRST(descrip,idim) + + off = off - axsize * (TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) + } + } + + axsize = axsize * axlen[idim] + } + + # Exit if array has been traversed + + if (idim > ndim) + break + } + + nbuf = nbuf - 1 + } +end + diff --git a/pkg/tbtables/selector/tcsshape.x b/pkg/tbtables/selector/tcsshape.x new file mode 100644 index 00000000..0a25ce2b --- /dev/null +++ b/pkg/tbtables/selector/tcsshape.x @@ -0,0 +1,24 @@ +include "tcs.h" + +# TCS_SHAPE -- Shape of column array + +procedure tcs_shape (descrip, length, ndim, maxdimen) + +pointer descrip # i: column selector +int length[ARB] # o: dimension lengths +int ndim # o: number of dimensions +int maxdimen # i: max number of dimensions +#-- +int idim + +begin + ndim = TCS_DIMEN(descrip) + do idim = 1, ndim { + if (idim > maxdimen) + break + + length[idim] = (((TCS_LAST(descrip,idim) - + TCS_FIRST(descrip,idim)) / + TCS_INC(descrip,idim)) + 1) + } +end diff --git a/pkg/tbtables/selector/tcstotsize.x b/pkg/tbtables/selector/tcstotsize.x new file mode 100644 index 00000000..e20c1b67 --- /dev/null +++ b/pkg/tbtables/selector/tcstotsize.x @@ -0,0 +1,28 @@ +include "tcs.h" + +# TCS_TOTSIZE -- Get total length of array from column selector + +int procedure tcs_totsize (descrip) + +pointer descrip #i: column selector +#-- +int size, idim, ndim +pointer sp, length + +begin + call smark (sp) + call salloc (length, MAXDIM, TY_INT) + + # Get length of each axis + + call tcs_shape (descrip, Memi[length], ndim, MAXDIM) + + # Multiply lengths together for total length + + size = 1 + do idim = 1, ndim + size = size * Memi[length+idim-1] + + call sfree (sp) + return (size) +end diff --git a/pkg/tbtables/selector/tcstxtinfo.x b/pkg/tbtables/selector/tcstxtinfo.x new file mode 100644 index 00000000..585bf78e --- /dev/null +++ b/pkg/tbtables/selector/tcstxtinfo.x @@ -0,0 +1,15 @@ +include "tcs.h" + +# TCS_TXTINFO -- Get text information about a column + +procedure tcs_txtinfo (descrip, what, str, maxch) + +pointer descrip # i: column selector +int what # i: parameter +char str[ARB] # o: text information +int maxch # i: length of string +#-- + +begin + call tbcigt (TCS_COLUMN(descrip), what, str, maxch) +end diff --git a/pkg/tbtables/selector/trs.h b/pkg/tbtables/selector/trs.h new file mode 100644 index 00000000..325b967f --- /dev/null +++ b/pkg/tbtables/selector/trs.h @@ -0,0 +1,55 @@ +# TRS.H -- Constants used by trs procedures + +define TRS_MAGIC 5526099 + +define MAXDEPTH 32 +define MAXSTACK 8 + +define SZ_BUFFER 600 +define SZ_INSTR 6 +define SZ_NODE 5 +define SZ_TOKEN 32 + +define LEN_TRSBUF 4 + +define TRS_IDENT Memi[$1] # Structure identifier +define TRS_CODE Memi[$1+1] # Code buffer +define TRS_VALUE Memi[$1+2] # Value buffer +define TRS_ROWS Memi[$1+3] # Row set + +define OCODE 0 +define OCOLUMN 1 +define OTJUMP 2 +define OFJUMP 3 +define OLOVAL 4 +define OHIVAL 5 + +define CODE Memi[$1+OCODE] +define COLUMN Memi[$1+OCOLUMN] +define TJUMP Memi[$1+OTJUMP] +define FJUMP Memi[$1+OFJUMP] +define LOVAL Memi[$1+OLOVAL] +define HIVAL Memi[$1+OHIVAL] + +define TREE_OPER Memi[$1] # operation to be performed +define TREE_INST Memi[$1+1] # index of op in code buffer +define TREE_LEFT Memi[$1+2] # first argument of op +define TREE_RIGHT Memi[$1+3] # second argument of op +define TREE_UP Memi[$1+4] # back link in tree + +define YDONE 1 +define YRANGE 2 +define YAND 3 +define YOR 4 +define YNOT 5 +define YEQN 6 +define YEQS 7 +define YLEN 8 +define YLES 9 +define YINN 10 +define YINS 11 +define YGEN 12 +define YGES 13 +define YMSK 14 + +define YLOGICAL ($1 <= YNOT) diff --git a/pkg/tbtables/selector/trsclose.x b/pkg/tbtables/selector/trsclose.x new file mode 100644 index 00000000..4a6ae000 --- /dev/null +++ b/pkg/tbtables/selector/trsclose.x @@ -0,0 +1,25 @@ +include "trs.h" + +#* HISTORY * +#* B.Simon 04-Nov-94 original + +# TRSCLOSE - Free table row selector code buffer + +procedure trsclose (trs) + +pointer trs # i: Pseudocode structure +#-- +string notcode "trsclose: not pointer to code" + +begin + if (TRS_IDENT(trs) != TRS_MAGIC) + call error (1, notcode) + + call rst_free (TRS_ROWS(trs)) + + call mfree (TRS_VALUE(trs), TY_DOUBLE) + call mfree (TRS_CODE(trs), TY_INT) + call mfree (trs, TY_INT) +end + + diff --git a/pkg/tbtables/selector/trseval.x b/pkg/tbtables/selector/trseval.x new file mode 100644 index 00000000..eae7db8e --- /dev/null +++ b/pkg/tbtables/selector/trseval.x @@ -0,0 +1,292 @@ +include "trs.h" + +#* HISTORY * +#* B.Simon 04-Nov-94 original +#* B.Simon 29-Dec-97 revised to use row set + +.help trseval +.nf______________________________________________________________________ + +This is one of a set of three procedures to select rows of a table +according to a qpoe filter. This procedure evaluates the filter, i.e., +determines whether it is true or false for a specified row of the +table. The other two procedures are trsopen(), which compiles the +qpoe filter into the pseudocode used by trseval() and trsclose() which +frees the memory held by the pseudocode arrays. Here is an typical +example of the use of these three routines: + + tp = tbtopn (table, READ_ONLY, NULL) + numrow = tbpsta (tp, TBL_NROWS) + pcode = trsopen (tp, filter) + do irow = 1, numrow { + if (trseval (tp, irow, pcode)) { + # Do something neat here + } + } + call trsclose (pcode) + call tbtclo (tp) + +For sake of an example, suppose we have a star catalog with the +columns Name, Ra, Dec, V, B-V, and U-B. The simplest sort of filter is +the equality test. The name of the column appears on the left of an +equals sign and the column value appears on the right. For example, +[name=eta_uma]. (The brackets in this and the following example are +not actually part of the filter.) Column numbers can be used in place +of the column name. This is especially useful for ascii +tables. Values can be either numbers or strings. It is usually not +necessary to place strings in quotes. However, any string (including +a column name) contains embedded blanks or characters significant to +the qpoe filter, such a equal signs, commas, or colons, it should be +placed in quotes. + +Ranges of values can be specified by giving the endpoints of the +ranges separated by a colon. For example, [v=10:15] selects all rows +with visual magnitude between 10 and 15. Ranges include their +endpoints. Ranges can also be used with strings as well as +numbers. Ranges can also be one sided. The filter [dec=80:] selects +all rows with declination greater than or equal to eighty degress and +the filter [dec=:-40] selects all declinations less than or equal to +forty degrees south. A filter can contain a list of single values and +ranges. The values in the list should be enclosed in parentheses. For +example, [name=(eta_uma,alpha_lyr)] or [b-v=(-1:0,0.5:1)]. + +Individual values or ranges can be negated by placing a ! in front of +them. For example, [name=!eta_uma] selects every row except the star +named eta_uma and [ra=!0:6] selects all rows except those with right +ascension between zero and six hours. An entire list can be negated by +placing a ! in front of the column name or the parentheses enclosing +the list. The filters [!name=(eta_uma,alpha_lyr)] and +[name=!(eta_uma,alpha_lyr)] and [name=(!eta_uma,!alpha_lyr)] are all +equivalent. + +Filters can test more than one column in a table. The individual tests +are separated by commas or semicolons. All tests in the filter must +succeed for the filter to be accepted. For example, +[ra=1.3:1.4,dec=40:42] selects a rectangular region in the catalog. A +range of row numbers can also be selected by placing the word row on +the left side of the equals sign. For example, [row=10:20] selects +rows from ten to twenty inclusive and [row=50:] selects all rows from +fifty on. Row selection can be combined with any other test in a +filter. A filter, can also be placed in an include file, for example +[@filter.lis]. Include files can be a part of a larger expression +and include files can contain other files, up to seven levels deep. + +.endhelp _________________________________________________________________ + +# TRSEVAL -- Evaluate a table row selector on a row of a table + +bool procedure trseval (tp, irow, pcode) + +pointer tp # i: table descriptor +int irow # i: table row number +pointer pcode # i: pseudocode +#-- +string notcode "trseval: not pointer to code" + +bool rst_inset(), trscalc() +errchk trscalc + +begin + # Make sure this is a valid trs descriptor + + if (TRS_IDENT(pcode) != TRS_MAGIC) + call error (1, notcode) + + # Check to see if the row is in the set first + # if it is, calculate the result of the pseudocode + + if (rst_inset (TRS_ROWS(pcode),irow)) + if (trscalc (tp,irow, TRS_CODE(pcode))) + return (true) + + return (false) +end + +# TRSCALC -- Calculate the result of the pseudocode embedded in the descriptor + +bool procedure trscalc (tp, irow, codebuf) + +pointer tp # i: table descriptor +int irow # i: table row number +pointer codebuf # i: pseudocode + +#-- +bool jump, stack[MAXSTACK] +double val +int itop, icode,junk, mask1, mask2 +pointer sp, str + +string ovflow "trscalc: stack overflow" +string badcode "trscalc: bad instruction" + +errchk trsgetd, trsgett +bool streq(), strle(), strge() +int trstrim() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + itop = 0 + icode = 0 + jump = false + + repeat { + if (itop == MAXSTACK) + call error (1, ovflow) + + switch (CODE(codebuf+icode)) { + case YDONE: # end instruction + break + + case YRANGE: # range instruction, no-op + ; + + case YAND: # logical and + if (! jump) { + stack[itop-1] = stack[itop-1] && stack[itop] + itop = itop - 1 + } + + case YOR: # logical or + if (! jump) { + stack[itop-1] = stack[itop-1] || stack[itop] + itop = itop - 1 + } + + case YNOT: # logical not + stack[itop] = ! stack[itop] + + case YEQN: # numeric equality test + call trsgetd (tp, COLUMN(codebuf+icode), irow, val) + itop = itop + 1 + stack[itop] = val == Memd[LOVAL(codebuf+icode)] + + case YEQS: # string equality check + call trsgett (tp, COLUMN(codebuf+icode), irow, + Memc[str], SZ_LINE) + junk = trstrim (Memc[str]) + + itop = itop + 1 + stack[itop] = streq (Memc[str], Memc[LOVAL(codebuf+icode)]) + + case YLEN: # numeric less than or equal check + call trsgetd (tp, COLUMN(codebuf+icode), irow, val) + itop = itop + 1 + stack[itop] = val <= Memd[LOVAL(codebuf+icode)] + + case YLES: # string less than or equal check + call trsgett (tp, COLUMN(codebuf+icode), irow, + Memc[str], SZ_LINE) + junk = trstrim (Memc[str]) + + itop = itop + 1 + stack[itop] = strle (Memc[str], Memc[LOVAL(codebuf+icode)]) + + case YINN: # numeric inclusion check + call trsgetd (tp, COLUMN(codebuf+icode), irow, val) + itop = itop + 1 + stack[itop] = val >= Memd[LOVAL(codebuf+icode)] && + val <= Memd[HIVAL(codebuf+icode)] + + case YINS: # string inclusion check + call trsgett (tp, COLUMN(codebuf+icode), irow, + Memc[str], SZ_LINE) + junk = trstrim (Memc[str]) + + itop = itop + 1 + stack[itop] = strge (Memc[str], Memc[LOVAL(codebuf+icode)]) && + strle (Memc[str], Memc[HIVAL(codebuf+icode)]) + + case YGEN: # numeric greater than or equal check + call trsgetd (tp, COLUMN(codebuf+icode), irow, val) + itop = itop + 1 + stack[itop] = val >= Memd[LOVAL(codebuf+icode)] + + case YGES: # string greater than or equal check + call trsgett (tp, COLUMN(codebuf+icode), irow, + Memc[str], SZ_LINE) + junk = trstrim (Memc[str]) + + itop = itop + 1 + stack[itop] = strge (Memc[str], Memc[LOVAL(codebuf+icode)]) + + case YMSK: # bit mask + call trsgetd (tp, COLUMN(codebuf+icode), irow, val) + mask1 = val + mask2 = Memd[LOVAL(codebuf+icode)] + itop = itop + 1 + stack[itop] = and (mask1, mask2) == mask2 + + default: + call error (1, badcode) + } + + # Set instruction pointer. Peform a jump if the jump field + # corresponding to the result is not NULL. Otherwise, + # increment the pointer. + + if (TJUMP(codebuf+icode) != NULL && stack[itop]) { + jump = true + icode = TJUMP(codebuf+icode) + } else if (FJUMP(codebuf+icode) != NULL && ! stack[itop]) { + jump = true + icode = FJUMP(codebuf+icode) + } else { + jump = false + icode = icode + SZ_INSTR + } + } + + # This handles the case of an empty program + + if (itop == 0) + stack[1] = true + + # Return result + + call sfree (sp) + return (stack[1]) +end + +# TRSGETD -- Read double value from table + +procedure trsgetd (tp, cp, irow, val) + +pointer tp # i: table descriptor +pointer cp # i: column descriptor +int irow # i: column number +double val # o: value read from table +#-- +errchk tbegtd + +begin + if (cp == NULL) { + val = irow + } else { + call tbegtd (tp, cp, irow, val) + } +end + +# TRSGETT -- Read string value from table + +procedure trsgett (tp, cp, irow, str, maxch) + +pointer tp # i: table descriptor +pointer cp # i: column descriptor +int irow # i: column number +char str[ARB] # o: value read from table +int maxch # i: maximum string length +#-- +int junk + +errchk itoc, tbgett +int itoc() + +begin + if (cp == NULL) { + junk = itoc (irow, str, maxch) + } else { + call tbegtt (tp, cp, irow, str, maxch) + } +end diff --git a/pkg/tbtables/selector/trsgencode.x b/pkg/tbtables/selector/trsgencode.x new file mode 100644 index 00000000..4499fac8 --- /dev/null +++ b/pkg/tbtables/selector/trsgencode.x @@ -0,0 +1,414 @@ +include <tbset.h> +include "trs.h" + +#* HISTORY * +#* B.Simon 02-Jan-98 original + +# TRSGENCODE -- Generate pseudocode from binary tree + +procedure trsgencode (tp, root, pcode) + +pointer tp # i: table descriptor +int root # i: root node of binary tree +pointer pcode # u: pseudocode structure +#-- +int nrow + +bool trshasrow() +int tbpsta() +pointer trsoptimize(), rst_create() +errchk trshasrow, trsputcode, trsoptimze + +begin + nrow = tbpsta (tp, TBL_NROWS) + + if (trshasrow (root)) { + TRS_ROWS(pcode) = trsoptimize (root, nrow) + + } else { + TRS_ROWS(pcode) = rst_create (1, nrow) + } + + call trsputcode (root, pcode) + call trsputjump (root, pcode) + +end + +# TRSHASROW -- Does code contains a row expression that can be optimized? + +bool procedure trshasrow (root) + +pointer root # i: root of binary tree +#-- +bool result, hasrow +pointer node, child + +bool trs_over_tree() +pointer trs_first_tree(), trs_next_tree() +errchk trs_xcg_tree + +begin + # Expressions without row ranges cannot be optimized. Also + # expressions with YNOT outside of YRANGE cannot be optimized. + # However, if the YNOT operates on a single range, the order + # of the YRANGE and YNOT can be flipped + + result = true + hasrow = false + node = trs_first_tree (root) + + while (node != NULL) { + if (TREE_OPER(node) == YRANGE && TREE_RIGHT(node) == NULL) { + hasrow = true + + } else if (TREE_OPER(node) == YNOT) { + + # If a YNOT is found outside a YRANGE controlling a row, + # it is not optimizable unless the two can be swapped + + child = TREE_LEFT(node) + + if (TREE_OPER(child) == YRANGE) { + # YNOT and YRANGE can be swapped, so do it + call trs_xcg_tree (child) + + } else if (trs_over_tree (node)) { + # Can't be swapped and over row range, + # so not optimizable + result = false + } + } + + node = trs_next_tree (node) + } + + # No row range, so not optimizable + + if (! hasrow) + result = false + + return (result) +end + +# TRSOPTIMIZE -- Optimize an expression by evaluting its row ranges + +pointer procedure trsoptimize (root, nrow) + +pointer root # i: root of binary tree +int nrow # i: number of rows in table +#-- +int top, istack, nstack +pointer sp, eval, node, prev, set + +bool trs_under_tree() +pointer trs_first_tree(), trs_next_tree() +errchk trsroweval, trs_snip_tree + +begin + # Allocate arrays used in traversing binary tree + + call smark (sp) + call salloc (eval, MAXDEPTH, TY_INT) + + # Traverse the binary tree, looking for row expressions + # when one is found, evaluate it and remove it from the tree + + top = 0 + node = trs_first_tree (root) + + while(node != NULL) { + # Evaluate row expressions + + if (trs_under_tree (node)) + call trsroweval (TREE_OPER(node), -TREE_LEFT(node), + -TREE_RIGHT(node), nrow, Memi[eval], + top) + + prev = node + node = trs_next_tree (node) + + # After complete evaluation of the row expression + # snip it out of the binary tree. If both branches + # of a logical have been snipped, also snip it out + # of the tree. Don't have to worry about YNOT as it + # was already buried beneath YRANGE in trshasrow + + if (TREE_OPER(prev) == YRANGE && TREE_RIGHT(prev) == NULL) { + call trs_snip_tree (prev) + + } else if ((TREE_OPER(prev) == YAND || TREE_OPER(prev) == YOR) && + (TREE_RIGHT(prev) == NULL && TREE_LEFT(prev) == NULL)) { + call trs_snip_tree (prev) + } + + } + + # If there is more than one row expression, they are + # combined with ands + + nstack = top - 1 + do istack = 1, nstack + call trsroweval (YAND, NULL, NULL, nrow, Memi[eval], top) + + # Return the row set evaluated + + set = Memi[eval] + + call sfree (sp) + return (set) + +end + +# TRSPUTCODE -- Convert binary tree into pseudocode instructions + +procedure trsputcode (root, pcode) + +pointer root # i: root of binary tree +pointer pcode # u: pseudocode structure +#-- +int icode, oper +pointer codebuf, node, col, loval, hival + +string noroom "Table row selection expression too complex" + +pointer trs_first_tree(), trs_next_tree(), trs_col_tree() + +begin + icode = 0 + codebuf = TRS_CODE(pcode) + + node = trs_first_tree (root) + + while (node != NULL) { + oper = TREE_OPER(node) + + if ((oper == YAND || oper == YOR) && + (TREE_LEFT(node) == NULL || + TREE_RIGHT(node) == NULL)) { + + # Skip encoding if one branch of a logical + # has been snipped + + TREE_INST(node) = ERR + + } else { + # Check for buffer overflow + + if (icode + SZ_INSTR >= SZ_BUFFER) + call error (1, noroom) + + # Set instruction field in tree + + TREE_INST(node) = icode + + # Retrieve column value + + if (YLOGICAL(oper)) + col = NULL + else + col = trs_col_tree (node) + + # Retrieve field values + + call trsvalue (node, loval, hival) + + # Add instruction to code buffer + + Memi[codebuf+icode+OCODE] = oper + Memi[codebuf+icode+OCOLUMN] = col + Memi[codebuf+icode+OTJUMP] = NULL + Memi[codebuf+icode+OFJUMP] = NULL + Memi[codebuf+icode+OLOVAL] = loval + Memi[codebuf+icode+OHIVAL] = hival + + # Increment code buffer index + + icode = icode + SZ_INSTR + } + + node = trs_next_tree (node) + } + +end + +# TRSPUTJUMP -- Add jumps to pseudocode + +procedure trsputjump (root, pcode) + +pointer root # i: root of binary tree +pointer pcode # u: pseudocode structure +#-- +int icode, inst +pointer codebuf, node, jump, child + +pointer trs_first_tree(), trs_next_tree() + +begin + codebuf = TRS_CODE(pcode) + node = trs_first_tree (root) + + while (node != NULL) { + if (TREE_INST(node) != ERR) { + inst = TREE_OPER(node) + jump = TREE_INST(node) + + child = TREE_LEFT(node) + if (child > 0) { + icode = TREE_INST(child) + + if (inst == YOR) + Memi[codebuf+icode+OTJUMP] = jump + + if (inst == YAND) + Memi[codebuf+icode+OFJUMP] = jump + } + } + + node = trs_next_tree (node) + } + +end + +# TRSROWEVAL -- Evaluate an operation in a row expression + +procedure trsroweval (code, loval, hival, nrow, eval, top) + +int code # i: pseudocode instruction +pointer loval # i: low end of range +pointer hival # i: high end of range +int nrow # i: number of rows in table +pointer eval[MAXDEPTH] # u: stack of pending results +int top # u: index to top of stack +#-- +int narg, iarg, lo, hi + +string ovflow "trs_roweval: stack overflow" +string badcode "trs_roweval: bad instruction" + +pointer rst_create(), rst_and(), rst_or(), rst_not() + +begin + if (top == MAXDEPTH) + call error (1, ovflow) + + switch (code) { + case YRANGE: # range operation, really a no-op + narg = 0 + + case YAND: # logical and + narg = 2 + top = top + 1 + eval[top] = rst_and (eval[top-1], eval[top-2]) + + case YOR: # logical or + narg = 2 + top = top + 1 + eval[top] = rst_or (eval[top-1], eval[top-2]) + + case YNOT: # logical not + narg = 1 + top = top + 1 + eval[top] = rst_not (nrow, eval[top-1]) + + case YEQN: # numerical equality test + narg = 0 + top = top + 1 + + lo = max (1, int(Memd[loval])) + eval[top] = rst_create (lo, lo) + + case YLEN: # numeric less than or equal check + narg = 0 + top = top + 1 + + lo = max (1, int(Memd[loval])) + eval[top] = rst_create (1, lo) + + case YINN: # numeric inclusion check + narg = 0 + top = top + 1 + + lo = min (Memd[loval], Memd[hival]) + hi = max (Memd[loval], Memd[hival]) + + lo = max (1, lo) + hi = min (nrow, hi) + eval[top] = rst_create (lo, hi) + + + case YGEN: # numeric greater than or equal check + narg = 0 + top = top + 1 + + hi = min (nrow, int(Memd[loval])) + eval[top] = rst_create (hi, nrow) + + default: + call error (1, badcode) + } + + # Free used stack elements + + if (narg > 0) { + do iarg = 1, narg + call rst_free (eval[top-iarg]) + + eval[top-narg] = eval[top] + top = top - narg + } +end + +# TRSVALUE -- Extract field values from a node of a binary tree + +procedure trsvalue (node, loval, hival) + +pointer node # i: binary tree node +pointer loval # o: smaller of the two values +pointer hival # o: larger of the two values +#-- +bool strgt() + +begin + + if (TREE_RIGHT(node) == NULL) { + # Duplicate left value if right value is NULL + + loval = -TREE_LEFT(node) + hival = -TREE_LEFT(node) + + } else { + # Flip high and low values if out of order + + if (TREE_OPER(node) == YINN) { + if (Memd[-TREE_RIGHT(node)] > + Memd[-TREE_LEFT(node)]) { + + loval = -TREE_LEFT(node) + hival = -TREE_RIGHT(node) + } else { + loval = -TREE_RIGHT(node) + hival = -TREE_LEFT(node) + } + + } else if (TREE_OPER(node) == YINS) { + if (strgt (Memc[-TREE_RIGHT(node)], + Memc[-TREE_LEFT(node)])) { + + loval = -TREE_LEFT(node) + hival = -TREE_RIGHT(node) + } else { + loval = -TREE_RIGHT(node) + hival = -TREE_LEFT(node) + } + } + } + + # Set values to null if the value is actually a node address + + if (loval < 0) + loval = NULL + + if (hival < 0) + hival = NULL + +end diff --git a/pkg/tbtables/selector/trsopen.com b/pkg/tbtables/selector/trsopen.com new file mode 100644 index 00000000..44d71a50 --- /dev/null +++ b/pkg/tbtables/selector/trsopen.com @@ -0,0 +1,15 @@ +# TRSOPEN.COM -- Common block holding global variables for trsopen + +pointer tabptr # table descriptor +pointer tokbuf # buffer to hold last tokens +pointer errbuf # token to hold error message +pointer treebuf # buffer to hold intermediate tree representation +pointer pcode # pseudocode structure +int itop # top of stack index +int itok # end of token index +int ival # next available location in value buffer +int itree # next available node in tree +int stack[MAXSTACK] # stack of pending file descriptors + +common / trscom / tabptr, tokbuf, errbuf, treebuf, pcode, + itop, itok, ival, itree, stack diff --git a/pkg/tbtables/selector/trsopen.x b/pkg/tbtables/selector/trsopen.x new file mode 100644 index 00000000..7c6e22d8 --- /dev/null +++ b/pkg/tbtables/selector/trsopen.x @@ -0,0 +1,926 @@ +include "trs.h" + +#* HISTORY * +#* B.Simon 04-Nov-94 original +#* B.Simon 23-Dec-97 row optimization added +# Phil Hodge 12-Jul-2005 In trsopen, declare 'debug' to be bool rather +# than int, and add 'int trslex()' + +define YYMAXDEPTH 64 +define YYOPLEN 1 +define yyparse trsparse + +define YNIL 257 +define YBANG 258 +define YCOMMA 259 +define YCOLON 260 +define YEQUAL 261 +define YERR 262 +define YEOF 263 +define YLPAR 264 +define YINC 265 +define YNUM 266 +define YPER 267 +define YRPAR 268 +define YSEMI 269 +define YSTR 270 +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + +# line 131 "trsopen.y" + + +# TRSOPEN -- Compile a table row selection expression + +pointer procedure trsopen (tp, expr) + +pointer tp # i: table descriptor +char expr[ARB] # i: expression to be parsed +#-- +include "trsopen.com" + +char nil +int fd, jtop +bool debug +pointer sp, root + +data nil / EOS / +data debug / false / +string syntax "syntax error" + +errchk stropen, trsparse, trserr + +int trslex() +extern trslex +pointer trsinit(), trsparse() +int stropen(), strlen() + +begin + # Initialize common block used by parser + + tabptr = tp + + call smark (sp) + call salloc (tokbuf, SZ_TOKEN, TY_CHAR) + call salloc (errbuf, SZ_LINE, TY_CHAR) + call salloc (treebuf, SZ_BUFFER, TY_INT) + + call amovkc (nil, Memc[tokbuf], SZ_TOKEN) + call strcpy (syntax, Memc[errbuf], SZ_LINE) + + itree = 0 + itop = 0 + itok = 0 + ival = 0 + + # Convert expression to pseudocode + + fd = stropen (expr, strlen(expr), READ_ONLY) + pcode = trsinit () + + root = trsparse (fd, debug, trslex) + if (root != NULL) { + call trsgencode (tp, root, pcode) + + } else { + # Error exit: free memory and close open files + + do jtop = 1, itop + call close (stack[jtop]) + call close (fd) + + call trserr + } + + # Free memory and close files + + call close (fd) + call sfree (sp) + return (pcode) +end + +# TRSADDNODE -- Add a node to the binary tree + +pointer procedure trsaddnode (oper, lfield, rfield) + +int oper # i: pseudocode operation +pointer lfield # i: left field of operation +pointer rfield # i: right field of operation +#-- +include "trsopen.com" + +pointer ptr + +string noroom "Table row selection expression too complex" + +begin + if (itree >= SZ_BUFFER) + call error (1, noroom) + + ptr = treebuf + itree + + TREE_OPER(ptr) = oper + TREE_INST(ptr) = ERR + TREE_LEFT(ptr) = lfield + TREE_RIGHT(ptr) = rfield + TREE_UP(ptr) = NULL + + if (lfield > 0) + TREE_UP(lfield) = ptr + + if (rfield > 0) + TREE_UP(rfield) = ptr + + itree = itree + SZ_NODE + return (ptr) +end + +# TRSCNAME -- Retrieve a column pointer, given its name + +bool procedure trscname (cname, cptr) + +pointer cname # i: column name +pointer cptr # o: column pointer +#-- +include "trsopen.com" + +bool streq() + +begin + call tbcfnd (tabptr, Memc[cname], cptr, 1) + + # "row" is a special filter indicating column number + + if (cptr == NULL) { + return (streq (Memc[cname], "row")) + } else { + return (true) + } + +end + +# TRSCNUM -- Retrieve a column pointer, given its number + +bool procedure trscnum (cnum, cptr) + +pointer cnum # i: column number +pointer cptr # o: column pointer +#-- +include "trsopen.com" + +int col +pointer tbcnum() + +begin + col = Memd[cnum] + cptr = tbcnum (tabptr, col) + + return (cptr != NULL) +end + +# TRSERR -- Print error message from table row selector parser + +procedure trserr + +#-- +include "trsopen.com" + +int nc +pointer sp, token, errmsg + +string errfmt "Error in table row selector, %s. Last read: %s" + +begin + # Allocate memory to hold token + + call smark (sp) + call salloc (token, SZ_TOKEN, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Copy token from token buffer. Since token buffer is maintained + # as a queue, the copy is in two parts, after and before the + # queue pointer. + + nc = 0 + if (Memc[tokbuf+itok] != EOS) { + nc = SZ_TOKEN - itok + call amovc (Memc[tokbuf+itok], Memc[token], nc) + } + + itok = mod (itok - 1, SZ_TOKEN) + call amovc (Memc[tokbuf], Memc[token+nc], itok) + + nc = nc + itok + Memc[token+nc] = EOS + + # Exit with error message + + call sprintf (Memc[errmsg], SZ_LINE, errfmt) + call pargstr (Memc[errbuf]) + call pargstr (Memc[token]) + + call error (1, Memc[errmsg]) + call sfree (sp) +end + +# TRSINIT -- Allocate and intialize the trs pseudocode data structure + +pointer procedure trsinit () + +#-- +pointer buf + +begin + call malloc (buf, LEN_TRSBUF, TY_INT) + + TRS_IDENT(buf) = TRS_MAGIC + TRS_ROWS(buf) = NULL + + call malloc (TRS_CODE(buf), SZ_BUFFER, TY_INT) + call malloc (TRS_VALUE(buf), SZ_BUFFER, TY_DOUBLE) + + return (buf) +end + +# TRSLEX -- Lexical analyzer for table row selector + +int procedure trslex (fd, value) + +int fd # u: file descriptor of currently open file +pointer value # i: Pointer to current token value +#-- +include "trsopen.com" + +int type + +string badfile "bad file name" +string maxfile "files nested too deep" + +errchk open +int open() + +begin + # This procedure sits on top of the procedure that fetches + # the next token and handles file openings and closings + + type = YNIL + while (type == YNIL) { + call trstok (fd, value, type) + + if (type == YEOF) { + # End of file token. Pop deferred file off of stack + # if no deferred file, return end of file token + + if (itop != 0) { + call amovkc (EOS, Memc[tokbuf], SZ_TOKEN) + itok = 0 + + call close (fd) + fd = stack[itop] + itop = itop - 1 + type = YNIL + } + + } else if (type == YINC) { + # Include file token. Next token should be file name + # Push current file descriptor on deferred file stack + # and open new file + + call trstok (fd, value, type) + + if (type != YSTR) { + call strcpy (badfile, Memc[errbuf], SZ_LINE) + type = YERR + + } else if (itop == MAXSTACK) { + call strcpy (maxfile, Memc[errbuf], SZ_LINE) + type = YERR + + } else { + itop = itop + 1 + stack[itop] = fd + + ifnoerr { + fd = open (Memc[Memi[value]], READ_ONLY, TEXT_FILE) + } then { + call amovkc (EOS, Memc[tokbuf], SZ_TOKEN) + itok = 0 + type = YNIL + + } else { + fd = stack[itop] + itop = itop - 1 + + call strcpy (badfile, Memc[errbuf], SZ_LINE) + type = YERR + } + } + } + } + + return (type) +end + +# TRSNEXTCH -- Read next character from input stram, save in buffer + +int procedure trsnextch (fd, ch) + +int fd # i: input file descriptor +char ch # o: character read from input +#-- +include "trsopen.com" + +int getc() + +begin + Memc[tokbuf+itok] = getc (fd, ch) + itok = mod (itok+1, SZ_TOKEN) + + return (ch) +end + +# TRSTOK -- Read next token from current file + +procedure trstok (fd, value, type) + +int fd # u: file descriptor of currently open file +pointer value # i: Pointer to current token value +int type # i: Token type +#-- +include "trsopen.com" + +char ch, stop +double dval +int stoptype[10] +int nc, ic, index, delta, size + +pointer sp, token, ptr, valbuf + +string notnum "not a number" +string noroom "expression too complex" +string nostop "trailing quote not found" + +string stopset " ,;:%=!()@" + +data stoptype / YNIL, YCOMMA, YSEMI, YCOLON, YPER, + YEQUAL, YBANG, YLPAR, YRPAR, YINC / + +int trsnextch(),trstrim(), stridx(), ctod() + +begin + # Eat leading whitespace, watch for end of file + + while (trsnextch (fd, ch) <= ' ') { + if (ch == EOF) { + Memi[value] = NULL + type = YEOF + return + } + + } + + # Check if first character is a delimeter + # if so, return the corresponding token + + index = stridx (ch, stopset) + if (index > 0) { + Memi[value] = NULL + type = stoptype[index] + return + } + + # The tougher case: token is a number or string + # First, gather all characters in token + + call smark (sp) + call salloc (token, SZ_LINE, TY_CHAR) + + if (ch == '\'' || ch == '"') { + # First case: token is a quoted string + # gather characters until matching quote is found + + nc = 0 + stop = ch + + while (trsnextch (fd, ch) != EOF) { + if (ch == stop) + break + + Memc[token+nc] = ch + nc = nc + 1 + } + + # Handle situation where trailing quote is missing + + if (ch == EOF) { + call strcpy (nostop, Memc[errbuf], SZ_LINE) + Memi[value] = NULL + type = YERR + + call sfree (sp) + return + } + + } else { + # Second case: no quotes + # gather characters until delimeter or whitespace + + nc = 1 + Memc[token] = ch + stop = ' ' + + while (trsnextch (fd, ch) != EOF) { + if (ch < ' ') + ch = ' ' + + if (stridx (ch, stopset) > 0) { + itok = itok - 1 + if (itok < 0) + itok = SZ_TOKEN - 1 + + call ungetc (fd, ch) + break + } + + Memc[token+nc] = ch + nc = nc + 1 + } + } + + Memc[token+nc] = EOS + nc = trstrim (Memc[token]) + + ic = 1 + valbuf = TRS_VALUE(pcode) + + if (stop == ' ' && ctod (Memc[token], ic, dval) == nc) { + # Token is a number. Convert it to a double + # and store in the value buffer + + if (ival + 1 >= SZ_BUFFER) { + call strcpy (noroom, Memc[errbuf], SZ_LINE) + Memi[value] = NULL + type = YERR + + } else { + ptr = valbuf + ival + ival = ival + 1 + + Memd[ptr] = dval + Memi[value] = ptr + type = YNUM + } + + } else { + # Token is a string. Find how much space it will take + # and store in the value buffer + + size = nc + 1 + delta = mod (size, SZ_DOUBLE) + if (delta != 0) + size = size + (SZ_DOUBLE - delta) + size = size / SZ_DOUBLE + + if (ival + size >= SZ_BUFFER) { + call strcpy (noroom, Memc[errbuf], SZ_LINE) + Memi[value] = NULL + type = YERR + + } else { + ptr = ((valbuf + ival - 1) * SZ_DOUBLE) + 1 + ival = ival + size + + call strcpy (Memc[token], Memc[ptr], size*SZ_DOUBLE-1) + Memi[value] = ptr + type = YSTR + } + } + + call sfree (sp) +end + +define YYNPROD 22 +define YYLAST 60 +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer yysp, yypvt +short yystate, yyn +int yyxi, i +errchk salloc, yylex + + +include "trsopen.com" + +int cptr + +errchk trslex, trsaddnode +bool trscname(), trscnum() +pointer trsaddnode + +string badcol "column not found" + +short yyexca[6] +data (yyexca(i),i= 1, 6) / -1, 1, 0, -1, -2, 0/ +short yyact[60] +data (yyact(i),i= 1, 8) / 20, 37, 23, 3, 36, 5, 19, 33/ +data (yyact(i),i= 9, 16) / 21, 24, 5, 4, 22, 6, 9, 31/ +data (yyact(i),i= 17, 24) / 4, 7, 6, 32, 26, 9, 7, 17/ +data (yyact(i),i= 25, 32) / 10, 8, 14, 13, 30, 35, 29, 10/ +data (yyact(i),i= 33, 40) / 18, 2, 1, 0, 0, 0, 11, 12/ +data (yyact(i),i= 41, 48) / 0, 0, 0, 15, 16, 0, 0, 25/ +data (yyact(i),i= 49, 56) / 0, 0, 0, 0, 27, 28, 0, 0/ +data (yyact(i),i= 57, 60) / 0, 0, 0, 34/ +short yypact[38] +data (yypact(i),i= 1, 8) /-253,-1000,-238,-1000,-248,-248,-234,-235/ +data (yypact(i),i= 9, 16) /-1000,-248,-248,-245,-1000,-258,-258,-1000/ +data (yypact(i),i= 17, 24) /-1000,-1000,-1000,-258,-258,-230,-232,-251/ +data (yypact(i),i= 25, 32) /-259,-1000,-258,-239,-1000,-262,-269,-1000/ +data (yypact(i),i= 33, 38) /-1000,-1000,-1000,-1000,-1000,-1000/ +short yypgo[4] +data (yypgo(i),i= 1, 4) / 0, 34, 33, 32/ +short yyr1[22] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 2, 2, 2, 2, 2/ +data (yyr1(i),i= 9, 16) / 2, 2, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 17, 22) / 3, 3, 3, 3, 3, 3/ +short yyr2[22] +data (yyr2(i),i= 1, 8) / 0, 2, 1, 0, 3, 3, 3, 2/ +data (yyr2(i),i= 9, 16) / 3, 3, 3, 3, 2, 1, 1, 2/ +data (yyr2(i),i= 17, 22) / 2, 3, 3, 2, 2, 2/ +short yychk[38] +data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, 264, 258, 266, 270/ +data (yychk(i),i= 9, 16) / 263, 259, 269, -2, -2, 261, 261, -2/ +data (yychk(i),i= 17, 24) / -2, 268, -3, 264, 258, 266, 270, 260/ +data (yychk(i),i= 25, 32) / 267, -3, 259, -3, -3, 260, 260, 266/ +data (yychk(i),i= 33, 38) / 270, 266, -3, 268, 266, 270/ +short yydef[38] +data (yydef(i),i= 1, 8) / 3, -2, 0, 2, 3, 3, 0, 0/ +data (yydef(i),i= 9, 16) / 1, 3, 3, 0, 7, 0, 0, 5/ +data (yydef(i),i= 17, 24) / 6, 4, 8, 0, 0, 13, 14, 0/ +data (yydef(i),i= 25, 32) / 0, 9, 0, 0, 12, 19, 20, 15/ +data (yydef(i),i= 33, 38) / 16, 21, 11, 10, 17, 18/ + +begin + call smark (yysp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (yysp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (yysp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (yysp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + +case 1: +# line 34 "trsopen.y" +{ + # Normal exit. Code a stop instruction. + Memi[yyval] = trsaddnode (YDONE, Memi[yypvt-YYOPLEN], NULL) + return (Memi[yyval]) + } +case 2: +# line 39 "trsopen.y" +{ + # Parser error + return (NULL) + } +case 3: +# line 44 "trsopen.y" +{ + # Empty filter + Memi[yyval] = NULL + } +case 4: +# line 48 "trsopen.y" +{ + # Parentheses for grouping + Memi[yyval] = Memi[yypvt-YYOPLEN] + } +case 5: +# line 52 "trsopen.y" +{ + # And instruction + Memi[yyval] = trsaddnode (YAND, Memi[yypvt-2*YYOPLEN], Memi[yypvt]) + } +case 6: +# line 56 "trsopen.y" +{ + # And instruction + Memi[yyval] = trsaddnode (YAND, Memi[yypvt-2*YYOPLEN], Memi[yypvt]) + } +case 7: +# line 60 "trsopen.y" +{ + # Not instruction + Memi[yyval] = trsaddnode (YNOT, Memi[yypvt], NULL) + } +case 8: +# line 64 "trsopen.y" +{ + # Filter with singleton range + if (! trscnum (Memi[yypvt-2*YYOPLEN], cptr)) { + call strcpy (badcol, Memc[errbuf], SZ_LINE) + return (NULL) + } + + Memi[yyval] = trsaddnode (YRANGE, Memi[yypvt], -cptr) + } +case 9: +# line 73 "trsopen.y" +{ + # Filter with singleton range + if (! trscname (Memi[yypvt-2*YYOPLEN], cptr)) { + call strcpy (badcol, Memc[errbuf], SZ_LINE) + return (NULL) + } + Memi[yyval] = trsaddnode (YRANGE, Memi[yypvt], -cptr) + } +case 10: +# line 82 "trsopen.y" +{ + # Parentheses for grouping + Memi[yyval] = Memi[yypvt-YYOPLEN] + } +case 11: +# line 86 "trsopen.y" +{ + # Or instruction + Memi[yyval] = trsaddnode (YOR, Memi[yypvt-2*YYOPLEN], Memi[yypvt]) + } +case 12: +# line 90 "trsopen.y" +{ + # Not instruction + Memi[yyval] = trsaddnode (YNOT, Memi[yypvt], NULL) + } +case 13: +# line 94 "trsopen.y" +{ + # Numeric equality instruction + Memi[yyval] = trsaddnode (YEQN, -Memi[yypvt], NULL) + } +case 14: +# line 98 "trsopen.y" +{ + # String equality instruction + Memi[yyval] = trsaddnode (YEQS, -Memi[yypvt], NULL) + } +case 15: +# line 102 "trsopen.y" +{ + # Numeric less than or equal instruction + Memi[yyval] = trsaddnode (YLEN, -Memi[yypvt], NULL) + } +case 16: +# line 106 "trsopen.y" +{ + # String less than or equal instruction + Memi[yyval] = trsaddnode (YLES, -Memi[yypvt], NULL) + } +case 17: +# line 110 "trsopen.y" +{ + # Numeric inside instruction + Memi[yyval] = trsaddnode (YINN, -Memi[yypvt-2*YYOPLEN], -Memi[yypvt]) + } +case 18: +# line 114 "trsopen.y" +{ + # String inside instruction + Memi[yyval] = trsaddnode (YINS, -Memi[yypvt-2*YYOPLEN], -Memi[yypvt]) + } +case 19: +# line 118 "trsopen.y" +{ + # Numeric greater than or equal instruction + Memi[yyval] = trsaddnode (YGEN, -Memi[yypvt-YYOPLEN], NULL) + } +case 20: +# line 122 "trsopen.y" +{ + # Numeric greater than or equal instruction + Memi[yyval] = trsaddnode (YGES, -Memi[yypvt-YYOPLEN], NULL) + } +case 21: +# line 126 "trsopen.y" +{ + # Bit mask instruction + Memi[yyval] = trsaddnode (YMSK, -Memi[yypvt], NULL) + } } + + goto yystack_ # stack new state and value +end diff --git a/pkg/tbtables/selector/trsopen.y b/pkg/tbtables/selector/trsopen.y new file mode 100644 index 00000000..6e6e9c17 --- /dev/null +++ b/pkg/tbtables/selector/trsopen.y @@ -0,0 +1,601 @@ +%{ +include "trs.h" + +#* HISTORY * +#* B.Simon 04-Nov-94 original +#* B.Simon 23-Dec-97 row optimization added + +define YYMAXDEPTH 64 +define YYOPLEN 1 +define yyparse trsparse + +%L +include "trsopen.com" + +int cptr + +errchk trslex, trsaddnode +bool trscname(), trscnum() +pointer trsaddnode + +string badcol "column not found" + +%} + +%token YNIL, YBANG, YCOMMA, YCOLON, YEQUAL, YERR, YEOF +%token YLPAR, YINC, YNUM, YPER, YRPAR, YSEMI, YSTR + +%left YSEMI, YCOMMA +%nonassoc YEQUAL +%right YBANG + +%% + +expr : filter YEOF { + # Normal exit. Code a stop instruction. + Memi[$$] = trsaddnode (YDONE, Memi[$1], NULL) + return (Memi[$$]) + } + | error { + # Parser error + return (NULL) + } + ; +filter : { + # Empty filter + Memi[$$] = NULL + } + | YLPAR filter YRPAR { + # Parentheses for grouping + Memi[$$] = Memi[$2] + } + | filter YCOMMA filter { + # And instruction + Memi[$$] = trsaddnode (YAND, Memi[$1], Memi[$3]) + } + | filter YSEMI filter { + # And instruction + Memi[$$] = trsaddnode (YAND, Memi[$1], Memi[$3]) + } + | YBANG filter { + # Not instruction + Memi[$$] = trsaddnode (YNOT, Memi[$2], NULL) + } + | YNUM YEQUAL range { + # Filter with singleton range + if (! trscnum (Memi[$1], cptr)) { + call strcpy (badcol, Memc[errbuf], SZ_LINE) + return (NULL) + } + + Memi[$$] = trsaddnode (YRANGE, Memi[$3], -cptr) + } + | YSTR YEQUAL range { + # Filter with singleton range + if (! trscname (Memi[$1], cptr)) { + call strcpy (badcol, Memc[errbuf], SZ_LINE) + return (NULL) + } + Memi[$$] = trsaddnode (YRANGE, Memi[$3], -cptr) + } + ; +range : YLPAR range YRPAR { + # Parentheses for grouping + Memi[$$] = Memi[$2] + } + | range YCOMMA range { + # Or instruction + Memi[$$] = trsaddnode (YOR, Memi[$1], Memi[$3]) + } + | YBANG range { + # Not instruction + Memi[$$] = trsaddnode (YNOT, Memi[$2], NULL) + } + | YNUM { + # Numeric equality instruction + Memi[$$] = trsaddnode (YEQN, -Memi[$1], NULL) + } + | YSTR { + # String equality instruction + Memi[$$] = trsaddnode (YEQS, -Memi[$1], NULL) + } + | YCOLON YNUM { + # Numeric less than or equal instruction + Memi[$$] = trsaddnode (YLEN, -Memi[$2], NULL) + } + | YCOLON YSTR { + # String less than or equal instruction + Memi[$$] = trsaddnode (YLES, -Memi[$2], NULL) + } + | YNUM YCOLON YNUM { + # Numeric inside instruction + Memi[$$] = trsaddnode (YINN, -Memi[$1], -Memi[$3]) + } + | YSTR YCOLON YSTR { + # String inside instruction + Memi[$$] = trsaddnode (YINS, -Memi[$1], -Memi[$3]) + } + | YNUM YCOLON { + # Numeric greater than or equal instruction + Memi[$$] = trsaddnode (YGEN, -Memi[$1], NULL) + } + | YSTR YCOLON { + # Numeric greater than or equal instruction + Memi[$$] = trsaddnode (YGES, -Memi[$1], NULL) + } + | YPER YNUM { + # Bit mask instruction + Memi[$$] = trsaddnode (YMSK, -Memi[$2], NULL) + } + ; +%% + +# TRSOPEN -- Compile a table row selection expression + +pointer procedure trsopen (tp, expr) + +pointer tp # i: table descriptor +char expr[ARB] # i: expression to be parsed +#-- +include "trsopen.com" + +char nil +int fd, jtop +bool debug +pointer sp, root + +data nil / EOS / +data debug / false / +string syntax "syntax error" + +errchk stropen, trsparse, trserr, trsgencode + +int trslex() +extern trslex +pointer trsinit(), trsparse() +int stropen(), strlen() + +begin + # Initialize common block used by parser + + tabptr = tp + + call smark (sp) + call salloc (tokbuf, SZ_TOKEN, TY_CHAR) + call salloc (errbuf, SZ_LINE, TY_CHAR) + call salloc (treebuf, SZ_BUFFER, TY_INT) + + call amovkc (nil, Memc[tokbuf], SZ_TOKEN) + call strcpy (syntax, Memc[errbuf], SZ_LINE) + + itree = 0 + itop = 0 + itok = 0 + ival = 0 + + # Convert expression to pseudocode + + fd = stropen (expr, strlen(expr), READ_ONLY) + pcode = trsinit () + + root = trsparse (fd, debug, trslex) + if (root != NULL) { + call trsgencode (tp, root, pcode) + + } else { + # Error exit: free memory and close open files + + do jtop = 1, itop + call close (stack[jtop]) + call close (fd) + + call trserr + } + + # Free memory and close files + + call close (fd) + call sfree (sp) + return (pcode) +end + +# TRSADDNODE -- Add a node to the binary tree + +pointer procedure trsaddnode (oper, lfield, rfield) + +int oper # i: pseudocode operation +pointer lfield # i: left field of operation +pointer rfield # i: right field of operation +#-- +include "trsopen.com" + +pointer ptr + +string noroom "Table row selection expression too complex" + +begin + if (itree >= SZ_BUFFER) + call error (1, noroom) + + ptr = treebuf + itree + + TREE_OPER(ptr) = oper + TREE_INST(ptr) = ERR + TREE_LEFT(ptr) = lfield + TREE_RIGHT(ptr) = rfield + TREE_UP(ptr) = NULL + + if (lfield > 0) + TREE_UP(lfield) = ptr + + if (rfield > 0) + TREE_UP(rfield) = ptr + + itree = itree + SZ_NODE + return (ptr) +end + +# TRSCNAME -- Retrieve a column pointer, given its name + +bool procedure trscname (cname, cptr) + +pointer cname # i: column name +pointer cptr # o: column pointer +#-- +include "trsopen.com" + +bool streq() + +begin + call tbcfnd (tabptr, Memc[cname], cptr, 1) + + # "row" is a special filter indicating column number + + if (cptr == NULL) { + return (streq (Memc[cname], "row")) + } else { + return (true) + } + +end + +# TRSCNUM -- Retrieve a column pointer, given its number + +bool procedure trscnum (cnum, cptr) + +pointer cnum # i: column number +pointer cptr # o: column pointer +#-- +include "trsopen.com" + +int col +pointer tbcnum() + +begin + col = Memd[cnum] + cptr = tbcnum (tabptr, col) + + return (cptr != NULL) +end + +# TRSERR -- Print error message from table row selector parser + +procedure trserr + +#-- +include "trsopen.com" + +int nc +pointer sp, token, errmsg + +string errfmt "Error in table row selector, %s. Last read: %s\n" + +begin + # Allocate memory to hold token + + call smark (sp) + call salloc (token, SZ_TOKEN, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Copy token from token buffer. Since token buffer is maintained + # as a queue, the copy is in two parts, after and before the + # queue pointer. + + nc = 0 + if (Memc[tokbuf+itok] != EOS) { + nc = SZ_TOKEN - itok + call amovc (Memc[tokbuf+itok], Memc[token], nc) + } + + itok = mod (itok - 1, SZ_TOKEN) + call amovc (Memc[tokbuf], Memc[token+nc], itok) + + nc = nc + itok + Memc[token+nc] = EOS + + # Exit with error message + + call sprintf (Memc[errmsg], SZ_LINE, errfmt) + call pargstr (Memc[errbuf]) + call pargstr (Memc[token]) + + call error (1, Memc[errmsg]) + call sfree (sp) +end + +# TRSINIT -- Allocate and intialize the trs pseudocode data structure + +pointer procedure trsinit () + +#-- +pointer buf + +begin + call malloc (buf, LEN_TRSBUF, TY_INT) + + TRS_IDENT(buf) = TRS_MAGIC + TRS_ROWS(buf) = NULL + + call malloc (TRS_CODE(buf), SZ_BUFFER, TY_INT) + call malloc (TRS_VALUE(buf), SZ_BUFFER, TY_DOUBLE) + + return (buf) +end + +# TRSLEX -- Lexical analyzer for table row selector + +int procedure trslex (fd, value) + +int fd # u: file descriptor of currently open file +pointer value # i: Pointer to current token value +#-- +include "trsopen.com" + +int type + +string badfile "bad file name" +string maxfile "files nested too deep" + +errchk open +int open() + +begin + # This procedure sits on top of the procedure that fetches + # the next token and handles file openings and closings + + type = YNIL + while (type == YNIL) { + call trstok (fd, value, type) + + if (type == YEOF) { + # End of file token. Pop deferred file off of stack + # if no deferred file, return end of file token + + if (itop != 0) { + call amovkc (EOS, Memc[tokbuf], SZ_TOKEN) + itok = 0 + + call close (fd) + fd = stack[itop] + itop = itop - 1 + type = YNIL + } + + } else if (type == YINC) { + # Include file token. Next token should be file name + # Push current file descriptor on deferred file stack + # and open new file + + call trstok (fd, value, type) + + if (type != YSTR) { + call strcpy (badfile, Memc[errbuf], SZ_LINE) + type = YERR + + } else if (itop == MAXSTACK) { + call strcpy (maxfile, Memc[errbuf], SZ_LINE) + type = YERR + + } else { + itop = itop + 1 + stack[itop] = fd + + ifnoerr { + fd = open (Memc[Memi[value]], READ_ONLY, TEXT_FILE) + } then { + call amovkc (EOS, Memc[tokbuf], SZ_TOKEN) + itok = 0 + type = YNIL + + } else { + fd = stack[itop] + itop = itop - 1 + + call strcpy (badfile, Memc[errbuf], SZ_LINE) + type = YERR + } + } + } + } + + return (type) +end + +# TRSNEXTCH -- Read next character from input stram, save in buffer + +int procedure trsnextch (fd, ch) + +int fd # i: input file descriptor +char ch # o: character read from input +#-- +include "trsopen.com" + +int getc() + +begin + Memc[tokbuf+itok] = getc (fd, ch) + itok = mod (itok+1, SZ_TOKEN) + + return (ch) +end + +# TRSTOK -- Read next token from current file + +procedure trstok (fd, value, type) + +int fd # u: file descriptor of currently open file +pointer value # i: Pointer to current token value +int type # i: Token type +#-- +include "trsopen.com" + +char ch, stop +double dval +int stoptype[10] +int nc, ic, index, delta, size + +pointer sp, token, ptr, valbuf + +string notnum "not a number" +string noroom "expression too complex" +string nostop "trailing quote not found" + +string stopset " ,;:%=!()@" + +data stoptype / YNIL, YCOMMA, YSEMI, YCOLON, YPER, + YEQUAL, YBANG, YLPAR, YRPAR, YINC / + +int trsnextch(),trstrim(), stridx(), ctod() + +begin + # Eat leading whitespace, watch for end of file + + while (trsnextch (fd, ch) <= ' ') { + if (ch == EOF) { + Memi[value] = NULL + type = YEOF + return + } + + } + + # Check if first character is a delimeter + # if so, return the corresponding token + + index = stridx (ch, stopset) + if (index > 0) { + Memi[value] = NULL + type = stoptype[index] + return + } + + # The tougher case: token is a number or string + # First, gather all characters in token + + call smark (sp) + call salloc (token, SZ_LINE, TY_CHAR) + + if (ch == '\'' || ch == '"') { + # First case: token is a quoted string + # gather characters until matching quote is found + + nc = 0 + stop = ch + + while (trsnextch (fd, ch) != EOF) { + if (ch == stop) + break + + Memc[token+nc] = ch + nc = nc + 1 + } + + # Handle situation where trailing quote is missing + + if (ch == EOF) { + call strcpy (nostop, Memc[errbuf], SZ_LINE) + Memi[value] = NULL + type = YERR + + call sfree (sp) + return + } + + } else { + # Second case: no quotes + # gather characters until delimeter or whitespace + + nc = 1 + Memc[token] = ch + stop = ' ' + + while (trsnextch (fd, ch) != EOF) { + if (ch < ' ') + ch = ' ' + + if (stridx (ch, stopset) > 0) { + itok = itok - 1 + if (itok < 0) + itok = SZ_TOKEN - 1 + + call ungetc (fd, ch) + break + } + + Memc[token+nc] = ch + nc = nc + 1 + } + } + + Memc[token+nc] = EOS + nc = trstrim (Memc[token]) + + ic = 1 + valbuf = TRS_VALUE(pcode) + + if (stop == ' ' && ctod (Memc[token], ic, dval) == nc) { + # Token is a number. Convert it to a double + # and store in the value buffer + + if (ival + 1 >= SZ_BUFFER) { + call strcpy (noroom, Memc[errbuf], SZ_LINE) + Memi[value] = NULL + type = YERR + + } else { + ptr = valbuf + ival + ival = ival + 1 + + Memd[ptr] = dval + Memi[value] = ptr + type = YNUM + } + + } else { + # Token is a string. Find how much space it will take + # and store in the value buffer + + size = nc + 1 + delta = mod (size, SZ_DOUBLE) + if (delta != 0) + size = size + (SZ_DOUBLE - delta) + size = size / SZ_DOUBLE + + if (ival + size >= SZ_BUFFER) { + call strcpy (noroom, Memc[errbuf], SZ_LINE) + Memi[value] = NULL + type = YERR + + } else { + ptr = ((valbuf + ival - 1) * SZ_DOUBLE) + 1 + ival = ival + size + + call strcpy (Memc[token], Memc[ptr], size*SZ_DOUBLE-1) + Memi[value] = ptr + type = YSTR + } + } + + call sfree (sp) +end + diff --git a/pkg/tbtables/selector/trsrows.x b/pkg/tbtables/selector/trsrows.x new file mode 100644 index 00000000..64fc9395 --- /dev/null +++ b/pkg/tbtables/selector/trsrows.x @@ -0,0 +1,99 @@ +include "trs.h" + +.help --------------------------------------------------------------------- + +TRSROWS -- Return a set of rows for which an expression is true + +This procedure evalutes a row selection expression and returns a set +containing the row numbers for which the expression is true. The set +can be accessed and maniputlauted using the functions in rst.x, which +are further described in the help block in that file. One example of +how to use this function is: + +.nf + set = trsrows (tp, expr) + nset = rst_nelem (set) + do iset = 1, nset { + irow = rst_rownum (set, iset) + # do something with the row here + } + call rst_free (set) +.fi + +In the above example, we create the set, query to get the number of +rows in the set, and then access the rows in sequential order. This +approach is useful when it is necessary to determine the number of +rows matched before doing any processing, so that one can allocate +arrays or take error actions based on the number of rows returned. If +neither of these is necessary, one can alternatively use a repeat +loop. + +.nf + set = trsrows (tp, expr) + iset = 1 + repeat { + irow = rst_rownum (set, iset) + if (irow == 0) + break + # do something with the row here + iset = iset + 1 + } + call rst_free (set) +.fi + +The loop ends because rst_rownum returns zero when asked for an +element less than one or greater than the number of rows in the set. +While both of these examples access the set sequentially, rst_rownum +also supports random access. + +.endhelp ------------------------------------------------------------------ + +pointer procedure trsrows (tp, expr) + +pointer tp # i: table descriptor +char expr[ARB] # i: expression to be evaluated +#-- +int iset, irow +pointer pcode, code, set + +bool trscalc() +int rst_rownum() +pointer trsopen(), rst_copy(), rst_create() +errchk trsopen, trscalc, trsclose + +begin + # Compile the expression into pseudocode + + pcode = trsopen (tp, expr) + + # If the code is a null program, just return the set, otherwise + # calculate the result for each element in the set + + code = TRS_CODE (pcode) + if (Memi[code] == YDONE) { + set = rst_copy (TRS_ROWS(pcode)) + + } else { + # Start with an empty set. Calculate the result for each + # element in the row set and if true, add it to the output set + + set = rst_create (0, 0) + + iset = 1 + repeat { + irow = rst_rownum (TRS_ROWS(pcode), iset) + if (irow == 0) + break + + if (trscalc (tp, irow, code)) + call rst_addval (set, irow) + + iset = iset + 1 + } + } + + # Release the pseudocode structure, return the set + + call trsclose (pcode) + return (set) +end diff --git a/pkg/tbtables/selector/trstree.x b/pkg/tbtables/selector/trstree.x new file mode 100644 index 00000000..d52b08e4 --- /dev/null +++ b/pkg/tbtables/selector/trstree.x @@ -0,0 +1,211 @@ +include "trs.h" + +#* HISTORY * +#* B.Simon 02-Jan-98 original + +# This tree traversal code assumes the tree has links to the left and right +# subtrees, as well as a link to the parent node. The parent node of the root +# node is NULL. Leaf nodes contain pointers to other information. To +# distinguish these pointers from tree links, the pointers are negative +# numbers. All procedures are non-recursive as SPP does not support recursion. +# The tree contains information parsed from the row selection expression. +# It is used as an intermediate data structure for optimization before +# the information is converted to pseudocode instructions. + +# TRS_COL_TREE -- Retrieve column pointer from range node above it in the tree + +pointer procedure trs_col_tree (current) + +pointer current # i: current node in tree +#-- +pointer col, node + +begin + col = NULL + node = current + + while (node != NULL) { + if (TREE_OPER(node) == YRANGE) { + col = - TREE_RIGHT(node) + break + } + + node = TREE_UP(node) + } + + return (col) +end + +# TRS_FIRST_TREE -- Get first (deepest leftmost) node in binary tree + +pointer procedure trs_first_tree (root) + +pointer root # i: root of binary tree +#-- +pointer node + +begin + node = root + + repeat { + while (TREE_LEFT(node) > 0) + node = TREE_LEFT(node) + + if (TREE_RIGHT(node) <= 0) + break + + node = TREE_RIGHT(node) + } + + return (node) +end + +# TRS_NEXT_TREE -- Get next node in binary tree in postfix order + +# After looking at the left subtree, look at the leftmost node of the right +# subtree. After looking at the right subtree, look at its immediate parent +# The root node has an UP node of NULL, which signals an end to the traverse + +pointer procedure trs_next_tree (current) + +pointer current # i: currently visited node +#-- +pointer node + +begin + node = TREE_UP(current) + + if (node > 0) { + # right nodes only need to back up one + # left nodes need to get right subtree + + if (current == TREE_LEFT(node)) { + if (TREE_RIGHT(node) > 0) { + + # Get right node of parent + node = TREE_RIGHT(node) + + # Get deepest leftmost subtree + repeat { + while (TREE_LEFT(node) > 0) + node = TREE_LEFT(node) + + if (TREE_RIGHT(node) <= 0) + break + + node = TREE_RIGHT(node) + } + } + } + } + + return (node) +end + +# TRS_OVER_TREE -- Determine if current node is over a row range node + +bool procedure trs_over_tree (current) + +pointer current # i: node to be checked +#-- +bool over +pointer node + +pointer trs_first_tree(), trs_next_tree() + +begin + over = false + node = trs_first_tree (current) + + while (node != TREE_UP(current)) { + if (TREE_OPER(node) == YRANGE && TREE_RIGHT(node) == NULL) { + over = true + break + } + + node = trs_next_tree (node) + } + + return (over) +end + +# TRS_SNIP_TREE -- Remove node and its children from the binary tree + +procedure trs_snip_tree (current) + +pointer current # i: currently visited node +#-- +pointer node + +string badlink "trs_snip_tree: bad links in binary tree" + +begin + node = TREE_UP(current) + TREE_UP(current) = NULL + + if (TREE_LEFT(node) == current) { + TREE_LEFT(node) = NULL + } else if (TREE_RIGHT(node) == current) { + TREE_RIGHT(node) = NULL + } else { + call error (1, badlink) + } + +end + +# TRS_UNDER_TREE -- Determine if current node is under a row range node + +bool procedure trs_under_tree (current) + +pointer current # i: node to be checked +#-- +bool under +pointer node + +begin + under = false + node = TREE_UP(current) + + while (node != NULL) { + if (TREE_OPER(node) == YRANGE && TREE_RIGHT(node) == NULL) { + under = true + break + } + + node = TREE_UP(node) + } + + return (under) +end + +# TRS_XCG_TREE -- Exchange position of node with its parent in binary tree + +procedure trs_xcg_tree (current) + +pointer current # i: node to be exchanged +#-- +pointer child, parent, grandparent + +string badlink "trs_xcg_tree: bad links in binary tree" + +begin + child = TREE_LEFT(current) + parent = TREE_UP(current) + grandparent = TREE_UP(parent) + + if (TREE_LEFT(grandparent) == parent) { + TREE_LEFT(grandparent) = current + } else if (TREE_RIGHT(grandparent) == parent) { + TREE_RIGHT(grandparent) = current + } else { + call error (1, badlink) + } + + TREE_LEFT(parent) = TREE_LEFT(current) + TREE_UP(parent) = current + + TREE_LEFT(current) = parent + TREE_UP(current) = grandparent + + TREE_UP(child) = parent +end diff --git a/pkg/tbtables/selector/trstrim.x b/pkg/tbtables/selector/trstrim.x new file mode 100644 index 00000000..dfcf9d55 --- /dev/null +++ b/pkg/tbtables/selector/trstrim.x @@ -0,0 +1,54 @@ +define BLANK ' ' + +#* HISTORY * +#* B.Simon 24-Jul-92 Original +#* B.Simon 17-Dec-97 Copied from old cdbs for use in row selector + +# This procedure removes leading and trailing whitespace and compresses +# interior whitepace to a single blank. Whitespace is defined to be any +# character with an ascii value less than or equal to that of the blank. +# + +# TRSTRIM -- Remove non-significant whitespace from string + +int procedure trstrim (str) + +char str[ARB] # u: String to be modified +#-- +bool flag +int ic, jc + +begin + # Initialize flag to true so that leading blanks are skipped + + jc = 1 + flag = true + + # Convert control characters to blanks, skip multiple blanks + + for (ic = 1; str[ic] != EOS; ic = ic + 1) { + + if (str[ic] > BLANK) { + flag = false + if (jc < ic) + str[jc] = str[ic] + jc = jc + 1 + + } else { + if (! flag) { + flag = true + str[jc] = ' ' + jc = jc + 1 + } + } + } + + # Remove trailing blanks + + if (flag && jc > 1) + jc = jc - 1 + + str[jc] = EOS + return (jc - 1) + +end diff --git a/pkg/tbtables/selector/whatfile.h b/pkg/tbtables/selector/whatfile.h new file mode 100644 index 00000000..b8691739 --- /dev/null +++ b/pkg/tbtables/selector/whatfile.h @@ -0,0 +1,6 @@ +# WHATFILE.H -- Symbolic constants representing file types + +define IS_UNKNOWN 0 +define IS_IMAGE 1 +define IS_TABLE 2 + diff --git a/pkg/tbtables/selector/whatfile.x b/pkg/tbtables/selector/whatfile.x new file mode 100644 index 00000000..cc03cd77 --- /dev/null +++ b/pkg/tbtables/selector/whatfile.x @@ -0,0 +1,63 @@ +include <imhdr.h> +include "whatfile.h" + +# WHATFILE -- Return integer code indicating type of image +# +# B. Simon, Original. +# Phil Hodge, 22-Feb-2002 Use tbtacc instead of tbtopn to test for a table. +# Phil Hodge, 19-Sep-2002 Simplify is_image(), just use tbtacc or imaccess. + + +int procedure whatfile (file) + +char file[ARB] # i: file name +#-- +int flag + +int is_image() + +begin + # This function exists mostly for backwards compatibility. + # The recommended function to use is is_image, as it does + # not need special macros + + switch (is_image(file)) { + case ERR: + flag = IS_UNKNOWN + case NO: + flag = IS_TABLE + case YES: + flag = IS_IMAGE + } + + return (flag) +end + +# IS_IMAGE -- Return YES if file is image, NO if table, and ERR if can't decide +# +# Note that a function value of NO does not just mean that the file is not +# an image, it means that it _is_ a table. Note also that while a FITS +# primary header or IMAGE extension can be opened as a table (for access +# to the header), tbtacc will return NO for such an extension. +# +# The 'file' argument to this function should be the complete image or +# table name, i.e. including FITS extension number or name, or STF group +# number. + +int procedure is_image (file) + +char file[ARB] # i: file name +#-- +int image +int imaccess(), tbtacc() + +begin + if (tbtacc (file) == YES) + image = NO + else if (imaccess (file, READ_ONLY) == YES) + image = YES + else + image = ERR + + return image +end |