diff options
Diffstat (limited to 'pkg/tbtables/tbycp.x')
| -rw-r--r-- | pkg/tbtables/tbycp.x | 594 |
1 files changed, 594 insertions, 0 deletions
diff --git a/pkg/tbtables/tbycp.x b/pkg/tbtables/tbycp.x new file mode 100644 index 00000000..23c81711 --- /dev/null +++ b/pkg/tbtables/tbycp.x @@ -0,0 +1,594 @@ +include <mach.h> # for MAX_INT and MAX_SHORT +include "tbtables.h" +include "tblerr.h" + +# tbycpb -- Y putcol Boolean +# Write values for one column to a range of rows. This is for data type +# Boolean and column-ordered SDAS tables. +# +# Phil Hodge, 28-Dec-1987 Different data types combined into one file. +# Phil Hodge, 6-Mar-1989 Allow COL_DTYPE < 0 for character columns. +# Phil Hodge, 4-Nov-1993 tbycpt: call sscan as a subroutine, not a function. +# Phil Hodge, 2-Jun-1997 Replace INDEFD with TBL_INDEFD. +# Phil Hodge, 5-Mar-1998 Remove nrows from tbycpd and tbycpt; +# remove calls to tbytsz, and don't update TB_NROWS, +# as these are taken care of at a higher level. + +procedure tbycpb (tp, colptr, buffer, firstrow, lastrow) + +pointer tp # Pointer to table descriptor +pointer colptr # Pointer to descriptor of the column +bool buffer[ARB] # Buffer for values +int firstrow # Number of first row into which to put values +int lastrow # Number of last row into which to put values +#-- +long offset # Location (chars) for reading in table +int k # Index in output array buffer +int nrows # Number of rows to write +int datatype # Data type of element in table +int dlen # Number of char for one element in table +# buffers for copying elements of various types +double dblbuf +real realbuf +int intbuf +short shortbuf +char charbuf[SZ_LINE] +long tbyoff() +errchk seek, write, sprintf + +begin + nrows = lastrow - firstrow + 1 + datatype = COL_DTYPE(colptr) + dlen = COL_LEN(colptr) + offset = tbyoff (tp, colptr, firstrow) + + switch (datatype) { + case TY_REAL: + do k = 1, lastrow-firstrow+1 { + if (buffer[k]) + realbuf = real(YES) + else + realbuf = real(NO) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), realbuf, SZ_REAL) + offset = offset + dlen + } + case TY_DOUBLE: + do k = 1, lastrow-firstrow+1 { + if (buffer[k]) + dblbuf = double(YES) + else + dblbuf = double(NO) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), dblbuf, SZ_DOUBLE) + offset = offset + dlen + } + case TY_INT: + do k = 1, lastrow-firstrow+1 { + if (buffer[k]) + intbuf = YES + else + intbuf = NO + call seek (TB_FILE(tp), offset) + if (SZ_INT != SZ_INT32) + call ipak32 (intbuf, intbuf, 1) + call write (TB_FILE(tp), intbuf, SZ_INT32) + offset = offset + dlen + } + case TY_SHORT: + do k = 1, lastrow-firstrow+1 { + if (buffer[k]) + shortbuf = YES + else + shortbuf = NO + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), shortbuf, SZ_SHORT) + offset = offset + dlen + } + case TY_BOOL: + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), buffer, nrows*SZ_BOOL) + default: + if (datatype < 0 || datatype == TY_CHAR) { + do k = 1, lastrow-firstrow+1 { + call sprintf (charbuf, SZ_LINE, "%-3b") + call pargb (buffer[k]) + call strpak (charbuf, charbuf, SZ_LINE) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), charbuf, dlen) + offset = offset + dlen + } + } else { + call error (ER_TBCOLBADTYP, "tbcptb: invalid data type") + } + } +end + + +# tbycpd -- Y putcol double +# Write values for one column to a range of rows. This is for data type +# double precision and column-ordered SDAS tables. + +procedure tbycpd (tp, colptr, buffer, firstrow, lastrow) + +pointer tp # Pointer to table descriptor +pointer colptr # Pointer to descriptor of the column +double buffer[ARB] # Buffer for values +int firstrow # Number of first row into which to put values +int lastrow # Number of last row into which to put values +#-- +long offset # Location (chars) for reading in table +int k # Index in output array buffer +int datatype # Data type of element in table +int dlen # Number of char for one element in table +# buffers for copying elements of various types +double dblbuf +real realbuf +int intbuf +short shortbuf +bool boolbuf +char charbuf[SZ_LINE] +long tbyoff() +errchk seek, write, sprintf + +begin + datatype = COL_DTYPE(colptr) + dlen = COL_LEN(colptr) + offset = tbyoff (tp, colptr, firstrow) + + switch (datatype) { + case TY_REAL: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFD (buffer[k])) + realbuf = INDEFR + else + realbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), realbuf, SZ_REAL) + offset = offset + dlen + } + case TY_DOUBLE: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFD (buffer[k])) + dblbuf = TBL_INDEFD + else + dblbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), dblbuf, SZ_DOUBLE) + offset = offset + dlen + } + case TY_INT: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFD (buffer[k]) || (abs (buffer[k]) > MAX_INT)) + intbuf = INDEFI + else + intbuf = nint (buffer[k]) + call seek (TB_FILE(tp), offset) + if (SZ_INT != SZ_INT32) + call ipak32 (intbuf, intbuf, 1) + call write (TB_FILE(tp), intbuf, SZ_INT32) + offset = offset + dlen + } + case TY_SHORT: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFD (buffer[k]) || (abs (buffer[k]) > MAX_SHORT)) + shortbuf = INDEFS + else + shortbuf = nint (buffer[k]) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), shortbuf, SZ_SHORT) + offset = offset + dlen + } + case TY_BOOL: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFD (buffer[k]) || (nint (buffer[k]) == NO)) + boolbuf = false + else + boolbuf = true + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), boolbuf, SZ_BOOL) + offset = offset + dlen + } + default: + if (datatype < 0 || datatype == TY_CHAR) { + do k = 1, lastrow-firstrow+1 { + call sprintf (charbuf, SZ_LINE, "%-25.17g") + call pargd (buffer[k]) + call strpak (charbuf, charbuf, SZ_LINE) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), charbuf, dlen) + offset = offset + dlen + } + } else { + call error (ER_TBCOLBADTYP, "tbcptd: invalid data type") + } + } +end + + +# tbycpr -- Y putcol real +# Write values for one column to a range of rows. This is for data type real +# and column-ordered SDAS tables. + +procedure tbycpr (tp, colptr, buffer, firstrow, lastrow) + +pointer tp # Pointer to table descriptor +pointer colptr # Pointer to descriptor of the column +real buffer[ARB] # Buffer for values +int firstrow # Number of first row into which to put values +int lastrow # Number of last row into which to put values +#-- +long offset # Location (chars) for reading in table +int k # Index in output array buffer +int nrows # Number of rows to write +int datatype # Data type of element in table +int dlen # Number of char for one element in table +# buffers for copying elements of various types +double dblbuf +int intbuf +short shortbuf +bool boolbuf +char charbuf[SZ_LINE] +long tbyoff() +errchk seek, write, sprintf + +begin + nrows = lastrow - firstrow + 1 + datatype = COL_DTYPE(colptr) + dlen = COL_LEN(colptr) + offset = tbyoff (tp, colptr, firstrow) + + switch (datatype) { + case TY_REAL: + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), buffer, nrows*SZ_REAL) + case TY_DOUBLE: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFR (buffer[k])) + dblbuf = TBL_INDEFD + else + dblbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), dblbuf, SZ_DOUBLE) + offset = offset + dlen + } + case TY_INT: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFR (buffer[k]) || (abs (buffer[k]) > MAX_INT)) + intbuf = INDEFI + else + intbuf = nint (buffer[k]) + call seek (TB_FILE(tp), offset) + if (SZ_INT != SZ_INT32) + call ipak32 (intbuf, intbuf, 1) + call write (TB_FILE(tp), intbuf, SZ_INT32) + offset = offset + dlen + } + case TY_SHORT: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFR (buffer[k]) || (abs (buffer[k]) > MAX_SHORT)) + shortbuf = INDEFS + else + shortbuf = nint (buffer[k]) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), shortbuf, SZ_SHORT) + offset = offset + dlen + } + case TY_BOOL: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFR (buffer[k]) || (nint (buffer[k]) == NO)) + boolbuf = false + else + boolbuf = true + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), boolbuf, SZ_BOOL) + offset = offset + dlen + } + default: + if (datatype < 0 || datatype == TY_CHAR) { + do k = 1, lastrow-firstrow+1 { + call sprintf (charbuf, SZ_LINE, "%-15.7g") + call pargr (buffer[k]) + call strpak (charbuf, charbuf, SZ_LINE) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), charbuf, dlen) + offset = offset + dlen + } + } else { + call error (ER_TBCOLBADTYP, "tbcptr: invalid data type") + } + } +end + + +# tbycpi -- Y putcol integer +# Write values for one column to a range of rows. This is for data type +# integer and column-ordered SDAS tables. + +procedure tbycpi (tp, colptr, buffer, firstrow, lastrow) + +pointer tp # Pointer to table descriptor +pointer colptr # Pointer to descriptor of the column +int buffer[ARB] # Buffer for values +int firstrow # Number of first row into which to put values +int lastrow # Number of last row into which to put values +#-- +long offset # Location (chars) for reading in table +int k # Index in output array buffer +int nrows # Number of rows to write +int datatype # Data type of element in table +int dlen # Number of char for one element in table +# buffers for copying elements of various types +double dblbuf +real realbuf +short shortbuf +bool boolbuf +char charbuf[SZ_LINE] +long tbyoff() +errchk seek, write, sprintf + +begin + nrows = lastrow - firstrow + 1 + datatype = COL_DTYPE(colptr) + dlen = COL_LEN(colptr) + offset = tbyoff (tp, colptr, firstrow) + + switch (datatype) { + case TY_REAL: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFI (buffer[k])) + realbuf = INDEFR + else + realbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), realbuf, SZ_REAL) + offset = offset + dlen + } + case TY_DOUBLE: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFI (buffer[k])) + dblbuf = TBL_INDEFD + else + dblbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), dblbuf, SZ_DOUBLE) + offset = offset + dlen + } + case TY_INT: + call seek (TB_FILE(tp), offset) + if (SZ_INT != SZ_INT32) + call ipak32 (buffer, buffer, nrows) + call write (TB_FILE(tp), buffer, nrows*SZ_INT32) + case TY_SHORT: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFI (buffer[k]) || (abs (buffer[k]) > MAX_SHORT)) + shortbuf = INDEFS + else + shortbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), shortbuf, SZ_SHORT) + offset = offset + dlen + } + case TY_BOOL: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFI (buffer[k]) || (buffer[k] == NO)) + boolbuf = false + else + boolbuf = true + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), boolbuf, SZ_BOOL) + offset = offset + dlen + } + default: + if (datatype < 0 || datatype == TY_CHAR) { + do k = 1, lastrow-firstrow+1 { + call sprintf (charbuf, SZ_LINE, "%-11d") + call pargi (buffer[k]) + call strpak (charbuf, charbuf, SZ_LINE) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), charbuf, dlen) + offset = offset + dlen + } + } else { + call error (ER_TBCOLBADTYP, "tbcpti: invalid data type") + } + } +end + + +# tbycps -- Y putcol short +# Write values for one column to a range of rows. This is for data type +# short integer and column-ordered SDAS tables. + +procedure tbycps (tp, colptr, buffer, firstrow, lastrow) + +pointer tp # Pointer to table descriptor +pointer colptr # Pointer to descriptor of the column +short buffer[ARB] # Buffer for values +int firstrow # Number of first row into which to put values +int lastrow # Number of last row into which to put values +#-- +long offset # Location (chars) for reading in table +int k # Index in output array buffer +int nrows # Number of rows to write +int datatype # Data type of element in table +int dlen # Number of char for one element in table +# buffers for copying elements of various types +double dblbuf +real realbuf +int intbuf +bool boolbuf +char charbuf[SZ_LINE] +long tbyoff() +errchk seek, write, sprintf + +begin + nrows = lastrow - firstrow + 1 + datatype = COL_DTYPE(colptr) + dlen = COL_LEN(colptr) + offset = tbyoff (tp, colptr, firstrow) + + switch (datatype) { + case TY_REAL: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFS (buffer[k])) + realbuf = INDEFR + else + realbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), realbuf, SZ_REAL) + offset = offset + dlen + } + case TY_DOUBLE: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFS (buffer[k])) + dblbuf = TBL_INDEFD + else + dblbuf = buffer[k] + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), dblbuf, SZ_DOUBLE) + offset = offset + dlen + } + case TY_INT: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFS (buffer[k])) + intbuf = INDEFI + else + intbuf = buffer[k] + call seek (TB_FILE(tp), offset) + if (SZ_INT != SZ_INT32) + call ipak32 (intbuf, intbuf, 1) + call write (TB_FILE(tp), intbuf, SZ_INT32) + offset = offset + dlen + } + case TY_SHORT: + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), buffer, nrows*SZ_SHORT) + case TY_BOOL: + do k = 1, lastrow-firstrow+1 { + if (IS_INDEFS (buffer[k]) || (buffer[k] == NO)) + boolbuf = false + else + boolbuf = true + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), boolbuf, SZ_BOOL) + offset = offset + dlen + } + default: + if (datatype < 0 || datatype == TY_CHAR) { + do k = 1, lastrow-firstrow+1 { + call sprintf (charbuf, SZ_LINE, "%-11d") + call pargs (buffer[k]) + call strpak (charbuf, charbuf, SZ_LINE) + call seek (TB_FILE(tp), offset) + call write (TB_FILE(tp), charbuf, dlen) + offset = offset + dlen + } + } else { + call error (ER_TBCOLBADTYP, "tbcpts: invalid data type") + } + } +end + + +# tbycpt -- Y putcol text +# Write values for one column to a range of rows. This is for character +# strings and column-ordered SDAS tables. + +procedure tbycpt (tp, colptr, buffer, lenstring, firstrow, lastrow) + +pointer tp # Pointer to table descriptor +pointer colptr # Pointer to descriptor of the column +char buffer[lenstring,ARB] # Buffer for values +int lenstring # The number of char in each element of buffer +int firstrow # Number of first row into which to put values +int lastrow # Number of last row into which to put values +#-- +long offset # Location (chars) for reading in table +int k # Index in output array buffer +int datatype # Data type of element in table +int dlen # Number of char for one element in table +# buffers for copying elements of various types +double dblbuf +real realbuf +int intbuf +short shortbuf +bool boolbuf +char charbuf[SZ_LINE] +long tbyoff() +int nscan() +errchk seek, write + +begin + datatype = COL_DTYPE(colptr) + dlen = COL_LEN(colptr) + offset = tbyoff (tp, colptr, firstrow) + + switch (datatype) { + case TY_REAL: + do k = 1, lastrow-firstrow+1 { + call seek (TB_FILE(tp), offset) + call sscan (buffer[1,k]) + call gargr (realbuf) + if (nscan() < 1) + realbuf = INDEFR + call write (TB_FILE(tp), realbuf, SZ_REAL) + offset = offset + dlen + } + case TY_DOUBLE: + do k = 1, lastrow-firstrow+1 { + call seek (TB_FILE(tp), offset) + call sscan (buffer[1,k]) + call gargd (dblbuf) + if (nscan() < 1) + dblbuf = TBL_INDEFD + else if (IS_INDEFD (dblbuf)) + dblbuf = TBL_INDEFD + call write (TB_FILE(tp), dblbuf, SZ_DOUBLE) + offset = offset + dlen + } + case TY_INT: + do k = 1, lastrow-firstrow+1 { + call seek (TB_FILE(tp), offset) + call sscan (buffer[1,k]) + call gargi (intbuf) + if (nscan() < 1) + intbuf = INDEFI + if (SZ_INT != SZ_INT32) + call ipak32 (intbuf, intbuf, 1) + call write (TB_FILE(tp), intbuf, SZ_INT32) + offset = offset + dlen + } + case TY_SHORT: + do k = 1, lastrow-firstrow+1 { + call seek (TB_FILE(tp), offset) + call sscan (buffer[1,k]) + call gargs (shortbuf) + if (nscan() < 1) + shortbuf = INDEFS + call write (TB_FILE(tp), shortbuf, SZ_SHORT) + offset = offset + dlen + } + case TY_BOOL: + do k = 1, lastrow-firstrow+1 { + call seek (TB_FILE(tp), offset) + call sscan (buffer[1,k]) + call gargb (boolbuf) + if (nscan() < 1) + boolbuf = false + call write (TB_FILE(tp), boolbuf, SZ_BOOL) + offset = offset + dlen + } + default: + if (datatype < 0 || datatype == TY_CHAR) { + do k = 1, lastrow-firstrow+1 { + call seek (TB_FILE(tp), offset) + call strpak (buffer[1,k], charbuf, lenstring) + call write (TB_FILE(tp), charbuf, dlen) + offset = offset + dlen + } + } else { + call error (ER_TBCOLBADTYP, "tbcptt: invalid data type") + } + } +end |