Initial commit

1 files changed, 173 insertions, 0 deletions

diff --git a/pkg/tbtables/tbrcsc.x b/pkg/tbtables/tbrcsc.x
new file mode 100644
index 00000000..91ed2cda
--- /dev/null
+++ b/pkg/tbtables/tbrcsc.x
@@ -0,0 +1,173 @@
+include <tbset.h>
+include "tbtables.h"
+include "tblerr.h"
+
+# tbrcsc -- copy selected columns
+# This procedure copies specific columns in a row from one table to another
+# or to another row within the same table.  Elements are copied one at a
+# time, and the pointers to descriptors of input and output columns are
+# passed in the calling sequence, so the restrictions on similarity of
+# input and output tables in tbrcpy do not apply to this routine.
+#
+# For each column to be copied from the input row, the element is read
+# using a "get element" routine (tbegt[]), and then the element is put
+# in the output row using a "put element" routine (tbept[]).
+#
+# Phil Hodge,  1-Oct-1987  Subroutine created.
+# Phil Hodge, 30-Jan-1992  Use tbegt? instead of tbegp?.
+# Phil Hodge,  1-Apr-1993  Include short datatype.
+# Phil Hodge, 23-Aug-1994  Also copy array entries.
+# Phil Hodge, 30-Nov-1994  When copying arrays of char, copy one at a time.
+# Phil Hodge,  3-Apr-1995  Set TB_MODIFIED to true.
+# Phil Hodge, 11-Dec-1995  Allocate cbuf only if needed.
+# Phil Hodge,  2-Jun-1997  Replace INDEFD with TBL_INDEFD.
+# Phil Hodge, 30-Sep-1997  Delete check on irow being beyond end of file,
+#			because it's checked in tbegt[] or tbagt[], and
+#			to allow for a row selector.
+# Phil Hodge, 18-Jan-1999  Get & put boolean as short, to preserve indef values.
+# Phil Hodge,  5-Aug-1999  Use COL_NELEM instead of tbalen to get array length.
+
+procedure tbrcsc (itp, otp, icp, ocp, irow, orow, ncols)
+
+pointer itp		# i: pointer to descriptor of input table
+pointer otp		# i: pointer to descriptor of output table
+pointer icp[ncols]	# i: array of pointers for input columns
+pointer ocp[ncols]	# i: array of pointers for output columns
+int	irow		# i: row number in input table
+int	orow		# i: row number in output table
+int	ncols		# i: number of columns to be copied
+#--
+pointer sp
+int	k		# loop index for column number
+int	i		# loop index for array element
+int	nget, nput	# number of elements in input & output arrays
+int	dtype		# data type of column
+# buffers for copying elements of various data types
+pointer gbuf		# pointer to array of any data type
+pointer cbuf		# for copying character elements
+double	dbuf
+real	rbuf
+int	ibuf
+short	sbuf
+int	tbagtd(), tbagtr(), tbagti(), tbagts(), tbagtt()
+errchk	tbegtd, tbegtr, tbegti, tbegts, tbegtt,
+	tbeptd, tbeptr, tbepti, tbepts, tbeptt,
+	tbagtd, tbagtr, tbagti, tbagts, tbagtt,
+	tbaptd, tbaptr, tbapti, tbapts, tbaptt
+string	BAD_DATATYPE	"tbrcsc:  bad data type; table or memory corrupted?"
+string	ERR_READ_ARRAY	"tbrcsc:  can't read array entry"
+
+begin
+	if (TB_READONLY(otp))
+	    call error (ER_TBREADONLY, "can't write to table; it's readonly")
+
+	call smark (sp)
+	cbuf = NULL				# allocated below
+
+	do k = 1, ncols {
+	    dtype = COL_DTYPE(icp[k])
+	    nget = COL_NELEM(icp[k])
+
+	    if (nget == 1) {
+
+		# Copy a single element.
+		switch (dtype) {
+		case TBL_TY_REAL:
+		    call tbegtr (itp, icp[k], irow, rbuf)
+		    call tbeptr (otp, ocp[k], orow, rbuf)
+		case TBL_TY_DOUBLE:
+		    call tbegtd (itp, icp[k], irow, dbuf)
+		    call tbeptd (otp, ocp[k], orow, dbuf)
+		case TBL_TY_INT:
+		    call tbegti (itp, icp[k], irow, ibuf)
+		    call tbepti (otp, ocp[k], orow, ibuf)
+		case TBL_TY_SHORT,TBL_TY_BOOL:
+		    call tbegts (itp, icp[k], irow, sbuf)
+		    call tbepts (otp, ocp[k], orow, sbuf)
+		default:
+		    if (dtype < 0 || dtype == TBL_TY_CHAR) {
+			if (cbuf == NULL)
+			    call salloc (cbuf, SZ_LINE, TY_CHAR)
+			call tbegtt (itp, icp[k], irow, Memc[cbuf], SZ_LINE)
+			call tbeptt (otp, ocp[k], orow, Memc[cbuf])
+		    } else {
+			call error (ER_TBCOLBADTYP, BAD_DATATYPE)
+		    }
+		}
+
+	    } else {			# Copy an array.
+
+		if (TB_TYPE(otp) == TBL_TYPE_TEXT ||
+		    TB_TYPE(otp) == TBL_TYPE_S_COL)
+		    call error (1,
+		"Output table type does not support columns of arrays.")
+
+		nput = COL_NELEM(ocp[k])
+		if (nget > nput)
+		    call error (1,
+		"tbrcsc:  output array is shorter than input array")
+
+		switch (dtype) {
+		case TBL_TY_REAL:
+
+		    call malloc (gbuf, max (nget, nput), TY_REAL)
+		    do i = nget+1, nput
+			Memr[gbuf+i-1] = INDEFR
+		    if (tbagtr (itp, icp[k], irow, Memr[gbuf], 1, nget) < nget)
+			call error (1, ERR_READ_ARRAY)
+		    call tbaptr (otp, ocp[k], orow, Memr[gbuf], 1, nput)
+		    call mfree (gbuf, TY_REAL)
+
+		case TBL_TY_DOUBLE:
+
+		    call malloc (gbuf, max (nget, nput), TY_DOUBLE)
+		    do i = nget+1, nput
+			Memd[gbuf+i-1] = TBL_INDEFD
+		    if (tbagtd (itp, icp[k], irow, Memd[gbuf], 1, nget) < nget)
+			call error (1, ERR_READ_ARRAY)
+		    call tbaptd (otp, ocp[k], orow, Memd[gbuf], 1, nput)
+		    call mfree (gbuf, TY_DOUBLE)
+
+		case TBL_TY_INT:
+
+		    call malloc (gbuf, max (nget, nput), TY_INT)
+		    do i = nget+1, nput
+			Memi[gbuf+i-1] = INDEFI
+		    if (tbagti (itp, icp[k], irow, Memi[gbuf], 1, nget) < nget)
+			call error (1, ERR_READ_ARRAY)
+		    call tbapti (otp, ocp[k], orow, Memi[gbuf], 1, nput)
+		    call mfree (gbuf, TY_INT)
+
+		case TBL_TY_SHORT,TBL_TY_BOOL:
+
+		    call malloc (gbuf, max (nget, nput), TY_SHORT)
+		    do i = nget+1, nput
+			Mems[gbuf+i-1] = INDEFS
+		    if (tbagts (itp, icp[k], irow, Mems[gbuf], 1, nget) < nget)
+			call error (1, ERR_READ_ARRAY)
+		    call tbapts (otp, ocp[k], orow, Mems[gbuf], 1, nput)
+		    call mfree (gbuf, TY_SHORT)
+
+		default:
+		    if (dtype < 0) {
+			if (cbuf == NULL)
+			    call salloc (cbuf, SZ_LINE, TY_CHAR)
+			do i = 1, nget {
+			    if (tbagtt  (itp, icp[k], irow,
+				Memc[cbuf], SZ_LINE, i, 1) < 1)
+				    call error (1, ERR_READ_ARRAY)
+			    call tbaptt (otp, ocp[k], orow,
+				Memc[cbuf], SZ_LINE, i, 1)
+			}
+			do i = nget+1, nput
+			    call tbaptt (otp, ocp[k], orow, "", SZ_LINE, i, 1)
+		    } else {
+			call error (ER_TBCOLBADTYP, BAD_DATATYPE)
+		    }
+		}
+	    }
+	}
+	TB_MODIFIED(otp) = true
+
+	call sfree (sp)
+end