diff options
Diffstat (limited to 'pkg/utilities/nttools/lib')
31 files changed, 3423 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/lib/allcols.x b/pkg/utilities/nttools/lib/allcols.x new file mode 100644 index 00000000..64e49786 --- /dev/null +++ b/pkg/utilities/nttools/lib/allcols.x @@ -0,0 +1,29 @@ +include <tbset.h> + +# ALLCOLS -- Return a pointer to an array containing the indices of all +# the columns in a table. The calling procedure must free the array when it +# is through with it. +# +# B.Simon 11-Dec-87 First Code + +procedure allcolumns (tp, numcol, colptr) + +pointer tp # i: Table descriptor +int numcol # o: Number of columns in the table +pointer colptr # o: Pointer to array of indices + +int icol + +int tbpsta(), tbcnum() + +errchk tbpsta, malloc + +begin + + numcol = tbpsta (tp, TBL_NCOLS) + call malloc (colptr, numcol, TY_INT) + + do icol = 1, numcol + Memi[colptr+icol-1] = tbcnum (tp, icol) + +end diff --git a/pkg/utilities/nttools/lib/allrows.x b/pkg/utilities/nttools/lib/allrows.x new file mode 100644 index 00000000..086e6a4a --- /dev/null +++ b/pkg/utilities/nttools/lib/allrows.x @@ -0,0 +1,29 @@ +include <tbset.h> + +# ALLROWS -- Return a pointer to an array containing the indices of all +# the rows in a table. The calling procedure must free the array when it +# is through with it. +# +# B.Simon 11-Dec-87 First Code + +procedure allrows (tp, numrow, rowptr) + +pointer tp # i: Table descriptor +int numrow # o: Number of rows in the table +pointer rowptr # o: Pointer to array of indices + +int irow + +int tbpsta() + +errchk tbpsta, malloc + +begin + + numrow = tbpsta (tp, TBL_NROWS) + call malloc (rowptr, numrow, TY_INT) + + do irow = 1, numrow + Memi[rowptr+irow-1] = irow + +end diff --git a/pkg/utilities/nttools/lib/compare.com b/pkg/utilities/nttools/lib/compare.com new file mode 100644 index 00000000..546e7222 --- /dev/null +++ b/pkg/utilities/nttools/lib/compare.com @@ -0,0 +1,7 @@ +# Variables needed by comparison routines used by the sort routines + +int lendata # length of a data element in units of its type +pointer dataptr # pointer to the beginning of array holding + # data to be sorted + +common /compare/ lendata, dataptr diff --git a/pkg/utilities/nttools/lib/compare.x b/pkg/utilities/nttools/lib/compare.x new file mode 100644 index 00000000..b05a50c1 --- /dev/null +++ b/pkg/utilities/nttools/lib/compare.x @@ -0,0 +1,258 @@ +.help compare +.nf___________________________________________________________________________ + +Comparison routines used to sort table columns. There are two sets of routines, +compasc[bdirt] for sorting in ascending order and compdsc[bdirt] for sorting in +descending order. The last letter indicates the type of data compared in the +sort. All routines return an integer that indicates the results of comparison. +The value of the integer is set according to the following scheme: + + Ascending Descending + + if mem[i] < mem[j], order = -1 if mem[i] > mem[j], order = -1 + if mem[i] == mem[j], order = 0 if mem[i] == mem[j], order = 0 + if mem[i] > mem[j], order = 1 if mem[i] < mem[j], order = 1 + +.endhelp_______________________________________________________________________ + +# B.Simon 16-Sept-87 First Code + +# COMPASCB -- Boolean comparison routine used for sort in ascending order + +int procedure compascb (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + # false < true + + if (! Memb[dataptr+i-1] && Memb[dataptr+j-1]) + order = -1 + else if (Memb[dataptr+i-1] && ! Memb[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCD -- Double comparison routine used for sort in ascending order + +int procedure compascd (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memd[dataptr+i-1] < Memd[dataptr+j-1]) + order = -1 + else if (Memd[dataptr+i-1] > Memd[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCI -- Integer comparison routine used for sort in ascending order + +int procedure compasci (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memi[dataptr+i-1] < Memi[dataptr+j-1]) + order = -1 + else if (Memi[dataptr+i-1] > Memi[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCR -- Real comparison routine used for sort in ascending order + +int procedure compascr (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memr[dataptr+i-1] < Memr[dataptr+j-1]) + order = -1 + else if (Memr[dataptr+i-1] > Memr[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCT -- Text comparison routine used for sort in ascending order + +int procedure compasct (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +bool strlt(), strgt() + +begin + + if (strlt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = -1 + else if (strgt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCB -- Boolean comparison routine used for sort in descending order + +int procedure compdscb (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + # true > false + + if (Memb[dataptr+i-1] && ! Memb[dataptr+j-1]) + order = -1 + else if (! Memb[dataptr+i-1] && Memb[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCD -- Double comparison routine used for sort in descending order + +int procedure compdscd (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memd[dataptr+i-1] > Memd[dataptr+j-1]) + order = -1 + else if (Memd[dataptr+i-1] < Memd[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCI -- Integer comparison routine used for sort in descending order + +int procedure compdsci (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memi[dataptr+i-1] > Memi[dataptr+j-1]) + order = -1 + else if (Memi[dataptr+i-1] < Memi[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCR -- Real comparison routine used for sort in descending order + +int procedure compdscr (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memr[dataptr+i-1] > Memr[dataptr+j-1]) + order = -1 + else if (Memr[dataptr+i-1] < Memr[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCT -- Text comparison routine used for sort in descending order + +int procedure compdsct (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +bool strgt(), strlt() + +begin + + if (strgt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = -1 + else if (strlt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = 1 + else + order = 0 + + return (order) +end diff --git a/pkg/utilities/nttools/lib/ftnexpr.x b/pkg/utilities/nttools/lib/ftnexpr.x new file mode 100644 index 00000000..a8472bdb --- /dev/null +++ b/pkg/utilities/nttools/lib/ftnexpr.x @@ -0,0 +1,127 @@ +include <ctype.h> +define DOT '.' +define SQUOTE '\'' +define DQUOTE '"' +define BSLASH '\\' + +#* HISTORY * +#* B.Simon 04-Jan-93 Original +#* B.Simon 01-Dec-93 No longer removes backslashes + + +# FTNEXPR -- Convert a Fortran boolean expression to SPP + +procedure ftnexpr (oldexpr, newexpr, maxch) + +char oldexpr[ARB] # i: Fortran expression +char newexpr[ARB] # o: SPP expression +int maxch # i: Maximum length of SPP expression +#-- +char ch, term +int ic, jc, kc, iw +pointer sp, dotbuf + +string ftnlist ".eq. .and. .or. .gt. .ge. .lt. .le. .not. .ne." +string spplist " == && || > >= < <= ! !=" + +int gstrcpy(), word_match(), word_find() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (dotbuf, SZ_LINE, TY_CHAR) + + # Loop over each character in the old expression + # Characters between quote marks or dots are treated specially + # To indicate this, term is set to the leading character + + ic = 1 + jc = 1 + kc = 0 + term = EOS + + while (oldexpr[ic] != EOS) { + ch = oldexpr[ic] + + if (ch != term) { + if (term == EOS) { + if (ch == DOT) { + kc = 1 + term = ch + Memc[dotbuf] = ch + } else { + if (ch == SQUOTE || ch == DQUOTE) + term = ch + + newexpr[jc] = ch + jc = jc + 1 + } + + } else if (term == DOT) { + if (IS_ALPHA(ch)) { + if (kc < SZ_LINE) { + Memc[dotbuf+kc] = ch + kc = kc + 1 + } + } else { + Memc[dotbuf+kc] = ch + Memc[dotbuf+kc+1] = EOS + jc = jc + gstrcpy (Memc[dotbuf], newexpr[jc], + maxch-jc+1) + + kc = 0 + term = EOS + } + + } else { + newexpr[jc] = ch + jc = jc + 1 + + if (ch == BSLASH) { + ic = ic + 1 + newexpr[jc] = oldexpr[ic] + jc = jc + 1 + } + } + + } else { + term = EOS + + if (ch != DOT) { + newexpr[jc] = ch + jc = jc + 1 + + } else { + Memc[dotbuf+kc] = ch + Memc[dotbuf+kc+1] = EOS + call strlwr (Memc[dotbuf]) + + iw = word_match (Memc[dotbuf], ftnlist) + if (iw == 0) { + jc = jc + gstrcpy (Memc[dotbuf], newexpr[jc], + maxch-jc+1) + } else { + jc = jc + word_find (iw, spplist, newexpr[jc], + maxch-jc+1) + } + + kc = 0 + } + } + + ic = ic + 1 + } + + # If there is anything left in the dot buffer copy it unchanged + # to the output string + + newexpr[jc] = EOS + + if (kc > 0) { + Memc[dotbuf+kc] = EOS + call strcat (Memc[dotbuf], newexpr, maxch) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/gettabcol.x b/pkg/utilities/nttools/lib/gettabcol.x new file mode 100644 index 00000000..154aff4f --- /dev/null +++ b/pkg/utilities/nttools/lib/gettabcol.x @@ -0,0 +1,67 @@ +include <tbset.h> + +# GETTABCOL -- Read in a table column of any data type +# +# This procedure produces an array of table column values and an array of +# null flags given an input table descriptor, column descriptor, and data +# type. If the data type is set to zero, the column data type is queried +# and returned to the calling program. The arrays are put in dynamic memory +# and pointers to these arrays are returned to the calling program, which must +# free the arrays when it is done with them. +# +# B.Simon 15-Dec-87 First Code + +procedure gettabcol (tp, cp, dtype, nary, aryptr, nulptr) + +pointer tp # i: Table descriptor +pointer cp # i: Column descriptor +int dtype # io: Data type of column (strings are -length) +int nary # o: Length of output arrays +pointer aryptr # o: Pointer to array of values +pointer nulptr # o: Pointer to array of null flags +#-- +int lendata, spptype +int tbpsta(), tbcigi() + +errchk malloc, tbpsta + +begin + # Allocate storage for null flags + + nary = tbpsta (tp, TBL_NROWS) + call malloc (nulptr, nary, TY_BOOL) + if (dtype == 0) + dtype = tbcigi (cp, TBL_COL_DATATYPE) + + # Break down data type into spp type and length + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + } else { + lendata = 1 + spptype = dtype + } + + # Read in the column of table values + + switch (spptype) { + case TY_BOOL: + call malloc (aryptr, nary, TY_BOOL) + call tbcgtb (tp, cp, Memb[aryptr], Memb[nulptr], 1, nary) + case TY_CHAR: + call malloc (aryptr, nary*(lendata+1), TY_CHAR) + call tbcgtt (tp, cp, Memc[aryptr], Memb[nulptr], lendata, + 1, nary) + case TY_SHORT,TY_INT,TY_LONG: + call malloc (aryptr, nary, TY_INT) + call tbcgti (tp, cp, Memi[aryptr], Memb[nulptr], 1, nary) + case TY_REAL: + call malloc (aryptr, nary, TY_REAL) + call tbcgtr (tp, cp, Memr[aryptr], Memb[nulptr], 1, nary) + case TY_DOUBLE: + call malloc (aryptr, nary, TY_DOUBLE) + call tbcgtd (tp, cp, Memd[aryptr], Memb[nulptr], 1, nary) + } + +end diff --git a/pkg/utilities/nttools/lib/inquotes.x b/pkg/utilities/nttools/lib/inquotes.x new file mode 100644 index 00000000..2cc0d8ce --- /dev/null +++ b/pkg/utilities/nttools/lib/inquotes.x @@ -0,0 +1,121 @@ +include <chars.h> + +# inquotes -- Put quotes around string +# This procedure examines the input/output string for blanks, tabs and +# double quotes. If any of these is found, the string will be enclosed in +# double quotes (unless it already begins with "), and embedded quotes will +# be escaped with the '\' character. If the input string is null then it +# will be replaced with a pair of adjacent double quotes. If maxch is not +# large enough to include the extra characters, however, the string will not +# be modified. The input and output strings may be the same. +# +# If there are trailing blanks but no embedded blanks, tabs or quotes, +# then the input will be copied unmodified to the output. (6/17/92) +# +# The reason for enclosing a string in quotes is so that it may be read +# later using ctowrd, and the entire string will be taken as one "word". +# +# Phil Hodge, 21-Jul-1987 Subroutine created. +# Phil Hodge, 11-Aug-1987 Add outstr to calling sequence. +# Phil Hodge, 17-Jun-1992 Also check for tabs; ignore trailing whitespace. +# Phil Hodge, 13-Jan-1995 Include show_trailing argument in calling sequence. + +procedure inquotes (instr, outstr, maxch, show_trailing) + +char instr[ARB] # i: the string to be enclosed in quotes +char outstr[ARB] # o: copy of instr, possibly enclosed in quotes +int maxch # i: maximum length of string outstr +int show_trailing # i: YES means show trailing blanks +#-- +bool must_fix # true if str contains blanks and/or quotes +int non_blank_len # length of instr up to last non-blank char +int inlen # same as non_blank_len +int outlen # length of outstr on output +int numquotes # a count of the number of embedded quotes +int ip, op # counters for input & output locations +int strlen() + +begin + # Find the length of the string ... + if (show_trailing == YES) { + # ... including trailing blanks. + non_blank_len = strlen (instr) + } else { + # ... up to the last non-blank character. + non_blank_len = 0 # initial value + do ip = 1, maxch { + if (instr[ip] == EOS) + break + if (instr[ip] != BLANK) # else ignore blank + non_blank_len = ip + } + } + + # Replace a null or completely blank string with "". + if (instr[1] == EOS || non_blank_len < 1) { + if (maxch >= 2) + call strcpy ("\"\"", outstr, maxch) + else # can't fix it + call strcpy (instr, outstr, maxch) + return + } + + inlen = non_blank_len + numquotes = 0 # initial values + must_fix = false + + # Run through the input string, but only go as far as the last + # non-blank character so we don't include trailing blanks. + do ip = 1, non_blank_len { + if (instr[ip] == EOS) { + break + } else if (instr[ip] == BLANK) { + must_fix = true + } else if (instr[ip] == TAB) { + must_fix = true + } else if (instr[ip] == DQUOTE) { + if (ip == 1) { + call strcpy (instr, outstr, maxch) + return # begins with ", so don't "fix" it + } + if (instr[ip-1] != ESCAPE) { + must_fix = true + numquotes = numquotes + 1 + } + } + } + + outlen = inlen + numquotes + 2 + if (outlen > maxch || !must_fix) { + call strcpy (instr, outstr, maxch) + return # can't fix it or don't need to + } + + # Work from the end toward the beginning in case instr = outstr. + outstr[outlen+1] = EOS + outstr[outlen] = DQUOTE + op = outlen - 1 + + if (numquotes > 0) { + # There are quotes within the string. + do ip = inlen, 1, -1 { + outstr[op] = instr[ip] + if (instr[ip] == DQUOTE) { + if (instr[ip-1] != ESCAPE) { + op = op - 1 + outstr[op] = ESCAPE + } + } + op = op - 1 + } + } else { + # No embedded quotes. + do ip = inlen, 1, -1 { + outstr[op] = instr[ip] + op = op - 1 + } + } + outstr[1] = DQUOTE + if (op != 1) + call error (1, "miscount in inquotes") +end diff --git a/pkg/utilities/nttools/lib/invert.x b/pkg/utilities/nttools/lib/invert.x new file mode 100644 index 00000000..f8a36675 --- /dev/null +++ b/pkg/utilities/nttools/lib/invert.x @@ -0,0 +1,55 @@ + +include <tbset.h> + +# INVERT -- Create the complement (inverse) of an array of column pointers +# +# B.Simon 20-Oct-87 First Code + +procedure invert (tp, numptr, colptr) + +pointer tp # i: Table descriptor +int numptr # io: Number of column pointers +pointer colptr[ARB] # io: Array of column pointers + +bool match +int numcol, icol, iptr, jptr +pointer newptr, cp + +int tbpsta(), tbcnum() + +begin + # Create a temporary array to hold the pointers + + numcol = tbpsta (tp, TBL_NCOLS) + call malloc (newptr, numcol, TY_INT) + + jptr = 0 + do icol = 1, numcol { + + # Get each pointer in the table and + # see if it is in the original array + + cp = tbcnum (tp, icol) + match = false + do iptr = 1, numptr { + if (cp == colptr[iptr]) { + match = true + break + } + } + + # If not, add it to the temporary array + + if (! match) { + Memi[newptr+jptr] = cp + jptr = jptr + 1 + } + } + +# Copy the temporary array to the output array + + numptr = jptr + call amovi (Memi[newptr], colptr, numptr) + call mfree (newptr, TY_INT) + +end diff --git a/pkg/utilities/nttools/lib/mjd.x b/pkg/utilities/nttools/lib/mjd.x new file mode 100644 index 00000000..601cf546 --- /dev/null +++ b/pkg/utilities/nttools/lib/mjd.x @@ -0,0 +1,94 @@ +include <ctype.h> +include "reloperr.h" + +define TFIELDS 7 +define REQFIELD 3 + +# MJD -- Compute the modified julian date of a time expressed as a string +# +# Dates are of the form YYYYMMDD:HHMMSSCC (fields after the colon are optional). +# If an optional field is not present, its value is considered to be zero. +# Dates must be between 1 Jan 1858 and 31 Dec 2099 +# +# B.Simon 7-Oct-87 First Code +# Phil Hodge 20-Feb-91 Move the data statements. + +double procedure mjd (date) + +char date[ARB] # i: String in the form YYYYMMDD:HHMMSSCC +#-- +int jd, datelen, it, ic +int time[TFIELDS], tpos[2,TFIELDS], tlim[2,TFIELDS] +pointer sp, errtxt +double df + +int strlen() + +string badfmt "Date has incorrect format (%s)" + +data tpos / 1, 4, 5, 6, 7, 8, 10, 11, 12, 13, 14, 15, 16, 17 / +data tlim / 1858, 2099, 1, 12, 1, 31, 0, 23, 0, 59, 0, 59, 0, 99 / + +begin + # Allocate dynamic memory for error string + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + datelen = strlen (date) + call aclri (time, TFIELDS) + + # Convert the date string into integer fields + + do it = 1, TFIELDS { + + # Check for absence of optional fields + + if (tpos[1,it] > datelen) { + if (it > REQFIELD) + break + else { + call sprintf (Memc[errtxt], SZ_LINE, badfmt) + call pargstr (date) + call error (SYNTAX, Memc[errtxt]) + } + } + + # Convert a field in the date string to an integer + + do ic = tpos[1,it], tpos[2,it] { + if (IS_DIGIT(date[ic])) + time[it] = 10 * time[it] + TO_INTEG(date[ic]) + else { + call sprintf (Memc[errtxt], SZ_LINE, badfmt) + call pargstr (date) + call error (SYNTAX, Memc[errtxt]) + } + } + + # Do bounds checking on the field + # Some errors can slip thru, e.g., Feb 30 + + if ((time[it] < tlim[1,it]) || (time[it] > tlim[2,it])) { + call sprintf (Memc[errtxt], SZ_LINE, badfmt) + call pargstr (date) + call error (SYNTAX, Memc[errtxt]) + } + } + + # Compute integer part of modified julian date + # From Van Flandern & Pulkkinen ApJ Sup 41:391-411 Nov 79 + + jd = 367 * time[1] - 7 * (time[1] + (time[2] + 9) / 12) / 4 - + 3 * ((time[1] + (time[2] - 9) / 7) / 100 + 1) / 4 + + 275 * time[2] / 9 + time[3] - 678971 + + # Compute fractional part of modified julian date + # N.B. julian date begins at noon, modified julian date at midnight + + df = double (time[7] + 100 * (time[6] + 60 * + (time[5] + 60 * time[4]))) / 8640000.0 + + call sfree (sp) + return (jd + df) +end diff --git a/pkg/utilities/nttools/lib/mkpkg b/pkg/utilities/nttools/lib/mkpkg new file mode 100644 index 00000000..3644f8e3 --- /dev/null +++ b/pkg/utilities/nttools/lib/mkpkg @@ -0,0 +1,33 @@ +# Update the library application code in the ttools package library +# Author: B.Simon, 21-Dec-87 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + allcols.x <tbset.h> + allrows.x <tbset.h> + ftnexpr.x <ctype.h> + gettabcol.x <tbset.h> + inquotes.x <chars.h> + invert.x <tbset.h> + mjd.x <ctype.h> reloperr.h + newcolnam.x <ctype.h> <tbset.h> reloperr.h + reorder.x <tbset.h> + select.x reloperr.h + tabvar.x <tbset.h> "../tabvar.com" + tbfile.x <ctype.h> + tuopen.x + tbleval.x <config.h> <error.h> <evexpr.h> \ + <xwhen.h> reloperr.h tblterm.com + tblsearch.x <config.h> <evexpr.h> <xwhen.h> \ + reloperr.h tblterm.com + tblsort.x + tblterm.x <config.h> <evexpr.h> <tbset.h> \ + <xwhen.h> reloperr.h tblterm.com + tctexp.x <tbset.h> <ctype.h> reloperr.h + tldtype.x + unique.x + ; diff --git a/pkg/utilities/nttools/lib/movenulls.x b/pkg/utilities/nttools/lib/movenulls.x new file mode 100644 index 00000000..5e961d20 --- /dev/null +++ b/pkg/utilities/nttools/lib/movenulls.x @@ -0,0 +1,35 @@ +# MOVENULLS -- Move all null elements to the end of the index array +# +# This procedure rearranges an array of row indices so that all rows with +# nulls in a particular column are moved to the end of the index array. +# The position of the nulls in the column is indicated by an array of null +# flags, whose length might be greater than the length of the array of +# indices, i.e., only a subset of the rows in a table might be in the index +# array. +# +# B.Simon 15-Dec-87 First Code + +int procedure movenulls (nindex, nulflg, index) + +int nindex # i: Number of indices +bool nulflg[ARB] # i: Array of null flags +int index[ARB] # io: Array of row indices +#-- +int nelem, idx, jdx + +begin + nelem = nindex + + do idx = nindex, 1, -1 { + jdx = index[idx] + if (nulflg[jdx]) { + if (nelem != idx) { + index[idx] = index[nelem] + index[nelem] = jdx + } + nelem = nelem - 1 + } + } + + return (nelem) +end diff --git a/pkg/utilities/nttools/lib/msort.x b/pkg/utilities/nttools/lib/msort.x new file mode 100644 index 00000000..2731351f --- /dev/null +++ b/pkg/utilities/nttools/lib/msort.x @@ -0,0 +1,113 @@ +include "reloperr.h" + +# MSORT -- General merge sort for arbitrary objects. X is an integer array +# indexing the array to be sorted. The user supplied COMPARE function is used +# to compare objects indexed by X: +# +# -1,0,1 = compare (x1, x2) +# +# where the value returned by COMPARE has the following significance: +# +# -1 obj[x1] < obj[x2] +# 0 obj[x1] == obj[x2] +# 1 obj[x1] > obj[x2] +# +# MSORT reorders the elements of the X array, which must be of type integer. +# +# B.Simon 28-Sept-87 First Code + +procedure msort (x, nx, nelem, compare) + +int x[ARB] # array to be sorted +int nx # length of array x (Must be >= 2 * nelem) +int nelem # number of elements to be sorted +extern compare() # function to be called to compare elements +#-- +bool up +int ielem, jelem, kelem, melem +int runlen, ilen, jlen + +int compare() + +begin + if (2 * nelem > nx) + call error (BOUNDS, "Index array too small") + + # Merging two sorted runs creates a new sorted run twice the length + # of the original run. Continue this process until the sorted run + # length is equal to the array length. + + up = false + for (runlen = 1; runlen < nelem; runlen = 2 * runlen) { + + # The runs are stored in one of two halves of the x array. + # Set the array pointers according to the half the runs are + # located in now. + + if (! up) { + ielem = 1 + jelem = runlen + 1 + kelem = nx - nelem + 1 + melem = nelem + } else { + ielem = nx - nelem + 1 + jelem = runlen + ielem + kelem = 1 + melem = nx + } + + # Loop over each pair of runs in the array + + while (ielem <= melem) { + ilen = min (runlen, melem-ielem+1) + jlen = min (runlen, melem-jelem+1) + + # Merge the pair of runs into the other half of the x array + + while (ilen > 0 && jlen > 0) { + if (compare (x[ielem], x[jelem]) <= 0) { + x[kelem] = x[ielem] + ielem = ielem + 1 + kelem = kelem + 1 + ilen = ilen - 1 + } else { + x[kelem] = x[jelem] + jelem = jelem + 1 + kelem = kelem + 1 + jlen = jlen - 1 + } + } + + # Copy the remaining elements from i when j is exhausted + + while (ilen > 0) { + x[kelem] = x[ielem] + ielem = ielem + 1 + kelem = kelem + 1 + ilen = ilen - 1 + } + + # Copy the remaining elements from j when i is exhausted + + while (jlen > 0) { + x[kelem] = x[jelem] + jelem = jelem + 1 + kelem = kelem + 1 + jlen = jlen - 1 + } + + # Set array pointers to next set of runs + + ielem = ielem + runlen + jelem = jelem + runlen + } + up = ! up + } + + # If result is in the upper end of x array, move it to the lower + # end + + if (up) + call amovi (x[nx-nelem+1], x[1], nelem) + + end diff --git a/pkg/utilities/nttools/lib/newcolnam.x b/pkg/utilities/nttools/lib/newcolnam.x new file mode 100644 index 00000000..4179383d --- /dev/null +++ b/pkg/utilities/nttools/lib/newcolnam.x @@ -0,0 +1,97 @@ +include <ctype.h> +include <tbset.h> +include "reloperr.h" + +# NEWCOLNAM -- Create a new, unique column name +# +# This procedure receives as input an array of column pointers from two or +# more tables and an index into that array. If the name of the column pointed +# to by that index is unique, it is output as the new name. If it is not +# unique, a suffix of the form "_i" is appended to the name, where i is +# a digit which (hopefully) makes the name unique. +# +# B.Simon 3-Nov-87 first code +# B.Simon 4-Sep-90 Replaced call to strncmp with streq + +procedure newcolnam (numcol, colptr, colidx, newnam, maxch) + +int numcol # i: Number of column pointers +pointer colptr[ARB] # i: Array of column pointers +int colidx # i: Index to column to be renamed +char newnam[ARB] # o: New column name +int maxch # i: Maximum characters in new name +#-- +int olen, nmatch, nbefore, icol +pointer sp, oldnam, colnam, errtxt + +string notuniq "Cannot create a unique column name (%s)" + +bool streq() +int strlen() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (oldnam, SZ_COLNAME, TY_CHAR) + call salloc (colnam, SZ_COLNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read column name pointed to by index + + call tbcigt (colptr[colidx], TBL_COL_NAME, Memc[oldnam], SZ_COLNAME) + call strupr (Memc[oldnam]) + + # See if the name is unique, and if not, how many columns with + # the same name precede this one + + nmatch = 0 + nbefore = 0 + do icol = 1, numcol { + call tbcigt (colptr[icol], TBL_COL_NAME, Memc[colnam], SZ_COLNAME) + call strupr (Memc[colnam]) + + if (streq (Memc[colnam], Memc[oldnam])) { + nmatch = nmatch + 1 + if (icol <= colidx) + nbefore = nbefore + 1 + } + } + + # If the name is not unique, add a suffix of the form "_i" + + if (nmatch > 1) { + + # Check for ridiculous values of maxch + + olen = min (maxch-2, strlen(Memc[oldnam])) + if (olen < 1) { + call sprintf (Memc[errtxt], SZ_LINE, notuniq) + call pargstr (Memc[oldnam]) + call error (SYNTAX, Memc[errtxt]) + } + + # Add the suffix + + Memc[oldnam+olen] = '_' + Memc[oldnam+olen+1] = TO_DIGIT (nbefore) + Memc[oldnam+olen+2] = EOS + + # Make sure it is unique + + do icol = 1, numcol { + call tbcigt (colptr[icol], TBL_COL_NAME, Memc[colnam], + SZ_COLNAME) + if (streq (Memc[oldnam], Memc[colnam])) { + call sprintf (Memc[errtxt], SZ_LINE, notuniq) + call pargstr (Memc[oldnam]) + call error (SYNTAX, Memc[errtxt]) + } + } + } + + # Copy to the output string + + call strcpy (Memc[oldnam], newnam, maxch) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/reloperr.h b/pkg/utilities/nttools/lib/reloperr.h new file mode 100644 index 00000000..6dff85c7 --- /dev/null +++ b/pkg/utilities/nttools/lib/reloperr.h @@ -0,0 +1,3 @@ +define SYNTAX 1 +define BOUNDS 2 +define PUTNULL 11 diff --git a/pkg/utilities/nttools/lib/reorder.x b/pkg/utilities/nttools/lib/reorder.x new file mode 100644 index 00000000..cacd98e2 --- /dev/null +++ b/pkg/utilities/nttools/lib/reorder.x @@ -0,0 +1,60 @@ +include <tbset.h> + +# REORDER -- Reorder table rows according to an index array +# +# This procedure rearranges the rows of a table according to the contents +# of an index array. The index array is produced by one of the two table +# sort routines, tsort1 or tsortm. The algorithm used is taken from Knuth's +# Sorting and Searching p.595. +# +# B.Simon 17-Sept-87 First Code +# B.Simon 15-Jul-88 Rewritten +# Phil Hodge 12-Sep-88 Don't include tbtables.h + +procedure reorder (tp, nindex, index) + +pointer tp # i: Table descriptor +int nindex # i: Number of indices +int index[ARB] # io: Array of row indices +#-- +int idx, jdx, kdx, ndx +int tbpsta() + +errchk tbrcpy + +begin + # Use the row after the end of the table for temporary storage + + ndx = tbpsta (tp, TBL_NROWS) + 1 + + # Loop over all rows of the table, moving them into their proper + # order + + do idx = 1, nindex { + + # The index array forms one or more cycles. Move the first + # row in the cycle to the temporary location. Repeatedly + # move the remaining rows in the cycle until the final + # location of the first row is found. Move the first row + # from its temporary location to its final location. Update + # the index array to indicate which rows have been moved. + + if (index[idx] != idx) { + call tbrcpy (tp, tp, idx, ndx) + jdx = idx + while (index[jdx] != idx) { + kdx = index[jdx] + call tbrcpy (tp, tp, kdx, jdx) + index[jdx] = jdx + jdx = kdx + } + call tbrcpy (tp, tp, ndx, jdx) + index[jdx] = jdx + } + + } + + # Remove the temporary row + + call tbrdel (tp, ndx, ndx) +end diff --git a/pkg/utilities/nttools/lib/select.x b/pkg/utilities/nttools/lib/select.x new file mode 100644 index 00000000..02cc73f8 --- /dev/null +++ b/pkg/utilities/nttools/lib/select.x @@ -0,0 +1,99 @@ +include "reloperr.h" + +# SELECT -- Select table rows according to expression +# +# This procedure evaluates a boolean expession for selected rows in a table. +# If the expression is true and does not involve null elements, the index +# of that row is kept in the index array. +# +# B.Simon 7-Oct-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 06-Jan-93 Changed to use ftnexpr + +procedure select (tp, expr, nindex, index) + +pointer tp # i: Table descriptor +char expr[ARB] # i: Algebraic expression used in selection +int nindex # io: Number of rows selected +int index[ARB] # io: Indices of selected rows +#-- +char ch +pointer sp, oldexp, newexp, ic, aryptr, nulptr +int fd, sd, jc, dtype, nary, iary + +int open(), stropen(), stridx() + +errchk open, stropen, tbl_eval + +string badtype "Expression is not boolean" + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (oldexp, SZ_COMMAND, TY_CHAR) + call salloc (newexp, SZ_COMMAND, TY_CHAR) + + # Check to see if the expression is a file name + + if (expr[1] == '@') { + + # Copy the file into a string + + fd = open (expr[2], READ_ONLY, TEXT_FILE) + sd = stropen (Memc[oldexp], SZ_COMMAND, WRITE_ONLY) + call fcopyo (fd, sd) + call close (fd) + call strclose (sd) + + # Replace the newlines with blanks + + ic = oldexp + ch = '\n' + repeat { + jc = stridx (ch, Memc[ic]) + if (jc == 0) + break + ic = ic + jc + Memc[ic-1] = ' ' + } + + # Convert Fortran relational operators to SPP + + call ftnexpr (Memc[oldexp], Memc[newexp], SZ_COMMAND) + + } else { + + # Convert Fortran relational operators to SPP + + call ftnexpr (expr, Memc[newexp], SZ_COMMAND) + } + + # Evaluate the expression + + dtype = TY_BOOL + call tbl_eval (tp, nindex, index, Memc[newexp], dtype, aryptr, nulptr) + + # Check to see if result is boolean + + if (dtype != TY_BOOL) { + call mfree (aryptr, dtype) + call mfree (nulptr, TY_BOOL) + call error (SYNTAX, badtype) + } + + # Put indices of true, non-null rows in index array + + nary = nindex + nindex = 0 + do iary = 1, nary + + if (Memb[aryptr+iary-1] && ! Memb[nulptr+iary-1]) { + nindex = nindex + 1 + index[nindex] = index[iary] + } + + call mfree (aryptr, dtype) + call mfree (nulptr, TY_BOOL) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/tabvar.x b/pkg/utilities/nttools/lib/tabvar.x new file mode 100644 index 00000000..339f2d95 --- /dev/null +++ b/pkg/utilities/nttools/lib/tabvar.x @@ -0,0 +1,118 @@ +include <tbset.h> + +# TABVAR -- Retrieve a table column given its name +# +# B.Simon 03-May-91 Original +# B.Simon 23-Jun-97 Peicewise evaluation of column + +procedure tabvar (stack, colname) + +pointer stack # u: Expression stack pointer +char colname[ARB] # i: Column name +#-- +include "../tabvar.com" + +int i, coltype, nrows +pointer sp, nullbuf, buffer, errmsg, cp + +string badcolnam "Column name not found (%s)" + +bool streq() +int tbcigi() +pointer stk_alloc() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Get column pointer from name + + call tbcfnd (tabptr, colname, cp, 1) + if (cp == NULL) { + if (streq (colname, "rownum")) { + call rowvar (stack) + return + } else { + call sprintf (Memc[errmsg], SZ_LINE, badcolnam) + call pargstr (colname) + call error (1, Memc[errmsg]) + } + } + + # Get column type + + coltype = tbcigi (cp, TBL_COL_DATATYPE) + if (coltype == TY_BOOL || coltype == TY_SHORT || coltype == TY_LONG) { + coltype = TY_INT + } else if (coltype < 0) { + coltype = TY_DOUBLE + } + + # Allocate a buffer on the expression evaluator stack + + nrows = (lastrow - firstrow) + 1 + call malloc (nullbuf, nrows, TY_BOOL) + buffer = stk_alloc (stack, nrows, coltype) + + # Copy the table column into the buffer + # Substitute the user supplied vales for nulls + + switch (coltype) { + case TY_SHORT, TY_INT, TY_LONG: + call tbcgti (tabptr, cp, Memi[buffer], Memb[nullbuf], + firstrow, lastrow) + do i = 0, nrows-1 { + if (Memb[nullbuf+i]) + Memi[buffer+i] = nullval + } + + case TY_REAL: + call tbcgtr (tabptr, cp, Memr[buffer], Memb[nullbuf], + firstrow, lastrow) + do i = 0, nrows-1 { + if (Memb[nullbuf+i]) + Memr[buffer+i] = nullval + } + case TY_DOUBLE: + call tbcgtd (tabptr, cp, Memd[buffer], Memb[nullbuf], + firstrow, lastrow) + do i = 0, nrows-1 { + if (Memb[nullbuf+i]) + Memd[buffer+i] = nullval + } + } + + # Update the null array + call stk_ornull (stack, Memb[nullbuf], nrows) + + call mfree (nullbuf, TY_BOOL) + call sfree (sp) + +end + +# ROWVAR -- Handle the variable "rownum" + +procedure rowvar (stack) + +pointer stack # u: Expression stack pointer +#-- +include "../tabvar.com" + +int irow, nrows +pointer buffer + +pointer stk_alloc() + +begin + # Allocate a buffer on the expression evaluator stack + + nrows = (lastrow - firstrow) + 1 + buffer = stk_alloc (stack, nrows, TY_INT) + + # Fill the buffer with the row number + do irow = 0, nrows-1 + Memi[buffer+irow] = firstrow + irow +end + diff --git a/pkg/utilities/nttools/lib/tbfile.x b/pkg/utilities/nttools/lib/tbfile.x new file mode 100644 index 00000000..d11e1720 --- /dev/null +++ b/pkg/utilities/nttools/lib/tbfile.x @@ -0,0 +1,85 @@ +include <ctype.h> # for IS_ALNUM + +# tbfile -- get table and file name +# This routine takes a table name as specified by a user and returns +# the full table name, the full file name, and the filename extension +# (including the dot; e.g. ".tab"). The filename extension may be the +# null string if the file is a text table. The file name will be a +# subset of the table name, as the table name may include a bracketed +# expression giving EXTNAME or HDU number or table name in CDF file. +# +# Phil Hodge, 27-Jun-1995 Subroutine created. +# Phil Hodge, 29-Sep-1997 No longer necessary to enclose extname expression +# in brackets, as the brackets are now included. +# Phil hodge, 16-Apr-1999 Remove ttype from calling sequence of tbparse. + +procedure tbfile (input, tabname, filename, extn, maxch) + +char input[ARB] # i: input table name +char tabname[maxch] # o: full table name +char filename[maxch] # o: name of file containing table +char extn[maxch] # o: filename extension, including '.' +int maxch # i: size of strings +#-- +pointer sp +pointer fname # full file name +pointer brackets # for CDF or HDU name or number, and/or selectors +int hdu # returned by tbparse and ignored +int dotloc # location of last '.' in file name +int i +int strlen(), access() +int tbparse() +bool strne() +errchk tbparse, tbtext + +begin + call smark (sp) + call salloc (fname, SZ_LINE, TY_CHAR) + call salloc (brackets, SZ_LINE, TY_CHAR) + + # Separate filename from any bracketed expression (such as + # EXTNAME or HDU number) that may be present. + if (tbparse (input, Memc[fname], Memc[brackets], SZ_LINE, hdu) < 1) { + tabname[1] = EOS + filename[1] = EOS + extn[1] = EOS + call sfree (sp) + return + } + + # Append default extension (if appropriate) to get full file name. + # A text table need not have an extension, so first check whether + # a file of the given name exists. If not, then append extension. + if (access (Memc[fname], 0, 0) == NO && + strne (input, "STDIN") && strne (input, "STDOUT")) + call tbtext (Memc[fname], Memc[fname], SZ_LINE) + + # At this point we have the full file name; copy it to output. + call strcpy (Memc[fname], filename, maxch) + + # Append bracketed expression (if present) to get full table name, + # and copy it to output. + call strcpy (Memc[fname], tabname, maxch) + if (Memc[brackets] != EOS) + call strcat (Memc[brackets], tabname, maxch) + + # Search for a filename extension. Look for a dot that is not + # followed by any special character. + dotloc = 0 # initial value + do i = strlen (Memc[fname]), 1, -1 { + if (Memc[fname+i-1] == '.') { # found it + dotloc = i + break + } + if (!IS_ALNUM(Memc[fname+i-1])) # stop at first special char + break + } + + # If the file name includes an extension, copy it to output. + if (dotloc > 0) + call strcpy (Memc[fname+dotloc-1], extn, maxch) + else + extn[1] = EOS + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/tbleval.x b/pkg/utilities/nttools/lib/tbleval.x new file mode 100644 index 00000000..c9382699 --- /dev/null +++ b/pkg/utilities/nttools/lib/tbleval.x @@ -0,0 +1,159 @@ +include <config.h> +include <error.h> +include <evexpr.h> +include <xwhen.h> +include "reloperr.h" + +# TBL_EVAL -- Evaluate an arbitrary expression over table columns +# +# This procedure receives as input a table descriptor, an index array, and +# a character string containing an algebraic expression. The terms in the +# expression are column names. The expression is evaluated for each row in +# the index array using the values from the indicated columns and the results +# stored in the output array (aryptr). The array pointed to by nulptr +# contains null flags. A null flag is set to true if any of the table elements +# in the expression is null or an arithmetic error ocurs during the +# evaluation of the expression. Otherwise the null flag is set to false. +# The type of the output array is determined by the type of the expression +# unless all the elements are null, in which case the type input by the +# calling routine is used. The two arrays pointed to by aryptr and nulptr +# must be deallocated by the calling routine. +# +# B.Simon 29-Sept-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 13-Apr-88 tbl_term, tbl_func moved to separate file + +procedure tbl_eval (tp, nindex, index, expr, dtype, aryptr, nulptr) + +pointer tp # i: Table descriptor +int nindex # i: Number of elements in index array +int index[ARB] # i: Array of row indices +char expr[ARB] # i: Expression to be evaluated +int dtype # io: Type of output array +pointer aryptr # o: Array of output values +pointer nulptr # o: Array of null flags +#-- +include "tblterm.com" + +int iary, status, junk +int old_handler, tbl_term_adr, tbl_func_adr +pointer op + +string badtype "Character expressions not allowed" + +int locpr(), errcode() +pointer evexpr() + +extern tbl_handler(), tbl_term(), tbl_func() + +begin + # Initialize output variables + + aryptr = NULL + call malloc (nulptr, nindex, TY_BOOL) + + # Set up error handler to catch arithmetic errors + + call xwhen (X_ARITH, locpr(tbl_handler), old_handler) + + table = tp + nterm = 0 + constant = true + + tbl_term_adr = locpr (tbl_term) + tbl_func_adr = locpr (tbl_func) + + # Loop over all rows of the table + + do iary = 1, nindex { + + irow = index[iary] + iterm = 0 + + # Execution will resume here when an arithmetic error occurs + + call zsvjmp (jumpbuf, status) + + if (status != OK) { + Memb[nulptr+iary-1] = true + + # Special case to speed up the evaluation of constant expressions + + } else if (constant && (iary != 1)) { + Memb[nulptr+iary-1] = false + switch (dtype) { + case TY_BOOL: + Memb[aryptr+iary-1] = Memb[aryptr] + case TY_INT: + Memi[aryptr+iary-1] = Memi[aryptr] + case TY_REAL: + Memr[aryptr+iary-1] = Memr[aryptr] + } + + # Evaluate the expression using the values in the current row + + } else { + iferr { + op = evexpr (expr, tbl_term_adr, tbl_func_adr) + } then { + + # Catch the error sent when a table element is null + + if (errcode() == PUTNULL) + Memb[nulptr+iary-1] = true + else { + call mfree (nulptr, TY_BOOL) + call xwhen (X_ARITH, old_handler, junk) + call erract (EA_ERROR) + } + + # Usual case + + } else { + + Memb[nulptr+iary-1] = false + + # Determine array type from type of expression + + if (aryptr == NULL) { + if (O_TYPE(op) == TY_CHAR) { + call mfree (nulptr, TY_BOOL) + call xwhen (X_ARITH, old_handler, junk) + call error (SYNTAX, badtype) + } + dtype = O_TYPE(op) + call calloc (aryptr, nindex, dtype) + } + + # Assign the result of the expression to the output + # array + + switch (dtype) { + case TY_BOOL: + Memb[aryptr+iary-1] = O_VALB(op) + case TY_INT: + Memi[aryptr+iary-1] = O_VALI(op) + case TY_REAL: + Memr[aryptr+iary-1] = O_VALR(op) + } + + call mfree (op, TY_STRUCT) # Bug fix (BPS 04.20.93) + } + } + } + + # Allocate array when all results are null + + if (aryptr == NULL) { + if (dtype == TY_CHAR) { + call mfree (nulptr, TY_BOOL) + call xwhen (X_ARITH, old_handler, junk) + call error (SYNTAX, badtype) + } + call calloc (aryptr, nindex, dtype) + } + # Restore old error handler + + call xwhen (X_ARITH, old_handler, junk) + +end diff --git a/pkg/utilities/nttools/lib/tbljoin.x b/pkg/utilities/nttools/lib/tbljoin.x new file mode 100644 index 00000000..c2a26fd6 --- /dev/null +++ b/pkg/utilities/nttools/lib/tbljoin.x @@ -0,0 +1,168 @@ +include <tbset.h> +define MAXPRI 7 + +# TBL_JOIN -- Relational join of two tables +# +# This procedure peforms a relational join by sorting the two tables on +# the column to be joined and then merging the tables on the basis of the +# common column. An input tolerance is used to control the test for equality +# in the merge. The variables which describe the two tables are the table +# descriptors (tp1 & tp2), column descriptors (cp1 & cp2), row index arrays +# (index1 & index2), and index array lengths (nindex1 & nindex2). The merged +# output table is described by two index arrays which contain the row indices +# from the respective input tables (index3 & index4) and the index array +# lengths (nindex3 & nindex4). On input these lengths are the declared length +# of the output index arrays, on output, they are the number of rows in +# the merged output table. The total number of merged rows is output as +# njoin. The output index arrays may not be large enough to hold the merged +# table indices. In this case, the output index arrays will be filled as much +# as possible. So if njoin is greater than nindex3 or nindex4, an error has +# occured, but this error can be recovered from by reallocating the output +# index arrays so that the can hold njoin elements and calling this procedure +# again. +# +# B.Simon 03-Nov-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 06-Feb-90 Changed to use tbtsrt + +procedure tbl_join (tol, casesens, tp1, tp2, cp1, cp2, nindex1, nindex2, + index1, index2, nindex3, nindex4, index3, index4, njoin) + +double tol # i: Tolerance used in testing for equality +bool casesens # i: Join is case sensitive +pointer tp1 # i: Table descriptor of first table +pointer tp2 # i: Table descriptor of second table +pointer cp1 # i: Column descriptor of merged column in first table +pointer cp2 # i: Column descriptor of merged column in second table +int nindex1 # i: Number of indices in first input array +int nindex2 # i: Number of indices in second input array +int index1 # i: Array of row indices for first input table +int index2 # i: Array of row indices for second input table +int nindex3 # io: Number of indices in first output array +int nindex4 # io: Number of indices in second output array +int index3 # o: Array of row indices for first output table +int index4 # o: Array of row indices for second output table +int njoin # o: Number of joined rows +#-- +bool fold +int dtype[2], spptype[2], lendata[2], colpri[2], nary[2], nidx[2] +int itab, iary, nmax + +pointer nulptr, temptr, curptr +pointer tp[2], cp[2], idxptr[2], aryptr[2] + +int priority[MAXPRI] +data priority / TY_DOUBLE, TY_REAL, TY_LONG, TY_INT, TY_SHORT, + TY_CHAR, TY_BOOL / +double mjd() +int tbcigi() + +begin + # Move input variables into arrays + + fold = ! casesens + + tp[1] = tp1 + tp[2] = tp2 + + cp[1] = cp1 + cp[2] = cp2 + + nmax = min (nindex3, nindex4) + + nidx[1] = nindex1 + nidx[2] = nindex2 + + call malloc (idxptr[1], nindex1, TY_INT) + call amovi (index1, Memi[idxptr[1]], nindex1) + + call malloc (idxptr[2], nindex2, TY_INT) + call amovi (index2, Memi[idxptr[2]], nindex2) + + # Determine the data type of the merged column + + do itab = 1, 2 { + + dtype[itab] = tbcigi (cp[itab], TBL_COL_DATATYPE) + + if (dtype[itab] < 0) { + lendata[itab] = - dtype[itab] + spptype[itab] = TY_CHAR + } else { + lendata[itab] = 1 + spptype[itab] = dtype[itab] + } + + for (colpri[itab] = 1; + spptype[itab] != priority[colpri[itab]]; + colpri[itab] = colpri[itab] + 1 + ) ; + + } + + if (colpri[1] < colpri[2]) { + spptype[2] = spptype[1] + lendata[2] = lendata[1] + } else if (colpri[2] < colpri[1]) { + spptype[1] = spptype[2] + lendata[1] = lendata[2] + } + + # Read common columns into arrays and sort + + do itab = 1, 2 { + + # Sort the index array on the common column + + call tbtsrt (tp[itab], 1, cp[itab], fold, + nidx[itab], Memi[idxptr[itab]]) + + # Read in the common column + + if (spptype[itab] == TY_CHAR) + dtype[itab] = - lendata[itab] + else + dtype[itab] = spptype[itab] + + call gettabcol (tp[itab], cp[itab], dtype[itab], + nary[itab], aryptr[itab], nulptr) + + # If the tolerance of a string column is non-zero, + # interpret the column as a date + + if (dtype[itab] < 0 && tol > 0.0) { + + call malloc (temptr, nary[itab], TY_DOUBLE) + curptr = aryptr[itab] + do iary = 1, nary[itab] { + if (Memb[nulptr+iary-1]) + Memd[temptr+iary-1] = INDEFD + else + Memd[temptr+iary-1] = mjd (Memc[curptr]) + curptr = curptr + lendata[itab] + 1 + } + call mfree (aryptr[itab], TY_CHAR) + dtype[itab] = TY_DOUBLE + spptype[itab] = TY_DOUBLE + lendata[itab] = 1 + aryptr[itab] = temptr + } + } + + # Merge the two tables + + call tbl_merge (tol, dtype, nary, aryptr, nidx, idxptr, + nmax, njoin, index3, index4) + + nindex3 = min (nmax, njoin) + nindex4 = min (nmax, njoin) + + # Free dynamic memory + + call mfree (nulptr, TY_BOOL) + do itab = 1, 2 { + call mfree (idxptr[itab], TY_INT) + call mfree (aryptr[itab], spptype[itab]) + } + +end diff --git a/pkg/utilities/nttools/lib/tblmerge.x b/pkg/utilities/nttools/lib/tblmerge.x new file mode 100644 index 00000000..ead8cbe6 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblmerge.x @@ -0,0 +1,162 @@ +include "reloperr.h" + +# TBL_MERGE -- Merge two tables on the basis of a common column +# +# This procedure creates an array of row indices from two tables where the +# row indices point to a pair of rows where the values stored in the two +# columns are equal within an input tolerance. The column values are stored in +# the two arrays pointed to by aryptr. The two columns must already be sorted +# in ascending order with the row indices of the two columns stored in the +# arrays pointed to by idxptr. This procedure keeps on going even when an +# output array overflow condition is detected so that the caller knows how +# large the output array must be. +# +# B.Simon 1-Nov-87 First code +# B.Simon 16-Dec-87 Changed to handle table subsets + +procedure tbl_merge (tol, dtype, nary, aryptr, nidx, idxptr, nmax, + nmerge, index1, index2) + +double tol # i: Tolerance used in test for equality +int dtype[2] # i: Data types of columns +int nary[2] # i: Size of arrays containing columns +pointer aryptr[2] # i: Pointers to column arrays +int nidx[2] # i: Size of arrays containing row indices +pointer idxptr[2] # i: Pointers to index arrays +int nmax # i: Max size of arrays containing merged row indices +int nmerge # o: Number of merged row indices +int index1[ARB] # o: Array of merged row indices for first table +int index2[ARB] # o: Array of merged row indices for second table +#-- +double dbl_tol +int itab, int_tol, idx, jdx, kdx, order, lendata[2], spptype[2] +pointer ptr1, ptr2 +real real_tol + +bool strlt(), strgt() + +string badtype "Data types of the two columns to be merged must be equal" +string badtol "Tolerance for boolean or character columns must be zero" + +begin + # Get data type and length from dtype + + do itab = 1, 2 { + if (dtype[itab] < 0) { + lendata[itab] = 1 - dtype[itab] + spptype[itab] = TY_CHAR + } else { + lendata[itab] = 1 + spptype[itab] = dtype[itab] + } + } + + if (spptype[1] != spptype[2]) + call error (SYNTAX, badtype) + + # Convert tolerance to the same type as the data + + switch (spptype[1]) { + case TY_BOOL, TY_CHAR: + if (tol > 0.0) + call error (SYNTAX, badtol) + case TY_SHORT, TY_INT, TY_LONG: + int_tol = tol + case TY_REAL: + real_tol = tol + case TY_DOUBLE: + dbl_tol = tol + } + + idx = 1 + jdx = 1 + kdx = 1 + + nmerge = 0 + while (idx <= nidx[1] && jdx <= nidx[2]) { + + # Calculate addresses of array elements + + ptr1 = aryptr[1] + lendata[1] * (Memi[idxptr[1]+idx-1] - 1) + ptr2 = aryptr[2] + lendata[2] * (Memi[idxptr[2]+jdx-1] - 1) + + # Determine relative order of the two elements + # If mem[ptr1] < mem[ptr2], order = -1 + # If mem[ptr1] == mem[ptr2], order = 0 + # If mem[ptr1] > mem[ptr2], order = 1 + + switch (spptype[1]) { + case TY_BOOL: + # false < true + + if (! Memb[ptr1] && Memb[ptr2]) + order = -1 + else if (Memb[ptr1] && ! Memb[ptr2]) + order = 1 + else + order = 0 + case TY_CHAR: + if (strlt (Memc[ptr1], Memc[ptr2])) + order = -1 + else if (strgt (Memc[ptr1], Memc[ptr2])) + order = 1 + else + order = 0 + case TY_SHORT,TY_INT, TY_LONG: + if (Memi[ptr1] + int_tol < Memi[ptr2]) + order = -1 + else if (Memi[ptr1] > Memi[ptr2] + int_tol) + order = 1 + else + order = 0 + case TY_REAL: + if (Memr[ptr1] + real_tol < Memr[ptr2]) + order = -1 + else if (Memr[ptr1] > Memr[ptr2] + real_tol) + order = 1 + else + order = 0 + case TY_DOUBLE: + if (Memd[ptr1] + dbl_tol < Memd[ptr2]) + order = -1 + else if (Memd[ptr1] > Memd[ptr2] + dbl_tol) + order = 1 + else + order = 0 + } + + # Increment the indices to the two arrays and if a match is + # found, add it to the index array. + + # The third index, kdx, tells where to fall back to when the + # value in the first array exceeds the value in the second array. + # Because the arrays are sorted in ascending order, the array + # element pointed to by idx exceeds all those previous to the + # element pointed to by kdx, so there is no use checking them. + + switch (order) { + case -1: + idx = idx + 1 + jdx = kdx + case 0: + nmerge = nmerge + 1 + if (nmerge <= nmax) { + index1[nmerge] = Memi[idxptr[1]+idx-1] + index2[nmerge] = Memi[idxptr[2]+jdx-1] + } + + # Keep fron reading past the end of the array + + if (jdx < nidx[2]) { + jdx = jdx + 1 + } else { + idx = idx + 1 + jdx = kdx + } + case 1: + jdx = jdx + 1 + kdx = jdx + } + } + +end diff --git a/pkg/utilities/nttools/lib/tblsearch.x b/pkg/utilities/nttools/lib/tblsearch.x new file mode 100644 index 00000000..87e17106 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsearch.x @@ -0,0 +1,104 @@ +include <config.h> +include <evexpr.h> +include <xwhen.h> +include "reloperr.h" + +# TBL_SEARCH -- Search table for a row which makes an expression true +# +# This procedure evaluates a boolean expession for the indicated rows in a +# table. When it finds a row which makes the expression true, it returns +# the row number. If it does not find any such row, it returns zero. If +# there is a syntax error in the expression, it returns ERR. +# +# B.Simon 13-Apr-1988 First Code +# Phil Hodge 4-Mar-2002 Free memory allocated by evexpr. +# Phil Hodge 23-Apr-2002 Move xev_freeop and mfree. + +int procedure tbl_search (tp, expr, first, last) + +pointer tp # i: Table descriptor +char expr[ARB] # i: Boolean expression used in search +int first # i: First row to look at +int last # i: Last row to look at +#-- +include "tblterm.com" + +int old_handler, tbl_term_adr, tbl_func_adr +int status, found, dir, iary, junk +pointer sp, op, newexp +bool done + +int locpr(), errcode() +pointer evexpr() + +extern tbl_handler(), tbl_term(), tbl_func() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (newexp, SZ_COMMAND, TY_CHAR) + + # Convert Fortran relational operators to SPP + + call ftnexpr (expr, Memc[newexp], SZ_COMMAND) + + # Set up error handler to catch arithmetic errors + + call xwhen (X_ARITH, locpr(tbl_handler), old_handler) + + table = tp + nterm = 0 + constant = false + + tbl_term_adr = locpr (tbl_term) + tbl_func_adr = locpr (tbl_func) + + found = 0 + done = false + + dir = sign (1, last - first) + do iary = first, last, dir { + + irow = iary + iterm = 0 + + # Execution will resume here when an arithmetic error occurs + + call zsvjmp (jumpbuf, status) + + if (status != OK) + next + + # Evaluate expression. Check if result is true + + ifnoerr { + op = evexpr (Memc[newexp], tbl_term_adr, tbl_func_adr) + } then { + + if (O_TYPE(op) != TY_BOOL) { + found = ERR + done = true + } else if (O_VALB(op)) { + found = irow + done = true + } + call xev_freeop (op) + call mfree (op, TY_STRUCT) + + } else if (errcode() != PUTNULL) { + # Ignore errors caused by nulls + found = ERR + done = true + } + if (done) + break + } + + # Restore old error handler + + call xwhen (X_ARITH, old_handler, junk) + call sfree (sp) + + return (found) +end diff --git a/pkg/utilities/nttools/lib/tblsort.x b/pkg/utilities/nttools/lib/tblsort.x new file mode 100644 index 00000000..9af87bf6 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsort.x @@ -0,0 +1,39 @@ +# TBL_SORT -- Sort a table on selected table columns +# +# B.Simon 06-Fab-90 First Code + +procedure tbl_sort (ascend, casesens, tp, numptr, colptr, nindex, index) + +bool ascend # i: Sort in ascending order +bool casesens # i: Sort is case sensitive +pointer tp # i: Table descriptor +int numptr # i: Number of columns to sort on +pointer colptr[ARB] # i: Array of column descriptors +int nindex # i: Number of elements in index array +int index[ARB] # io: Array of row indices to sort +#-- +bool fold +int idx, jdx, temp + +begin + # Call the sort routine in the table library + + fold = ! casesens + call tbtsrt (tp, numptr, colptr, fold, nindex, index) + + # Reorder the index array if ascend is false + + if (! ascend) { + idx = 1 + jdx = nindex + while (idx < jdx) { + temp = index[idx] + index[idx] = index[jdx] + index[jdx] = temp + idx = idx + 1 + jdx = jdx - 1 + } + } + + +end diff --git a/pkg/utilities/nttools/lib/tblsort1.x b/pkg/utilities/nttools/lib/tblsort1.x new file mode 100644 index 00000000..5d68751b --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsort1.x @@ -0,0 +1,157 @@ +include "reloperr.h" + +.help tbl_sort1 +.nf____________________________________________________________________________ + +This file contains two routines that sort a table on a single column. Both +routines put an existing array of row indices into sorted order. The first +routine, tbl_sort1 has a simpler interface and is the routine to be used in +a majority of cases. The second routine, tbl_qsort, requires that the calling +routine read the table column into an array and handle null elements by +itself. This routine should be used if the table column requires some +special preprocessing before it can be sorted. One example of required +preprocessing is conversion of dates from character strings to julian dates. +Both routines use quick sort to sort the data. Quick is one of the fastest +sorting routines, but it cannot be used to sort several table columns because +it is not stable. This means that one sort destroys the ordering of a previous +sort on a different column. + +.endhelp_______________________________________________________________________ + +# TBL_SORT1 -- Sort a table on a single column +# +# This procedure rearranges an array of row indices into sorted order. The +# order is from smallest to largest value if ascend is true, if ascend is +# false, the order is from largest to smallest. In either case undefined +# elements will be last in the array. For purposes of this routine boolean +# false is considered to be less than true. If character strings are being +# sorted, case can be ignored by setting casesens to false. The array of row +# indices must be created before calling this procedure. +# +# B.Simon 16-Sept-87 First Code +# B.Simon 15-Dec-87 Changed to handle table subsets + +procedure tbl_sort1 (ascend, casesens, tp, cp, nindex, index) + +bool ascend # i: Sort in ascending order +bool casesens # i: Sort is case sensitive +pointer tp # i: Table descriptor +pointer cp # i: Column descriptor +int nindex # io: Number of rows +int index[ARB] # io: Array of row pointers in sorted order +#-- +int dtype, spptype, lendata +int nary, iary, nelem +pointer idxptr, nulptr, aryptr, curptr + +int movenulls() + +begin + # Allocate storage for index array + + call malloc (idxptr, nindex, TY_INT) + + # Initialize the array of row indices + + call amovi (index, Memi[idxptr], nindex) + + # Read in the column of table values. Setting dtype to + # zero gets the actual data type of the column + + dtype = 0 + call gettabcol (tp, cp, dtype, nary, aryptr, nulptr) + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + + if (! casesens) { + curptr = aryptr + do iary = 1, nary { + call strupr (Memc[curptr]) + curptr = curptr + lendata + 1 + } + } + } else { + lendata = 1 + spptype = dtype + } + + # Move all null elements to the end of the array + + nelem = movenulls (nindex, Memb[nulptr], Memi[idxptr]) + + # Perform an indirect sort on the row indices using quicksort + + call tbl_qsort (ascend, dtype, aryptr, nelem, idxptr) + + # Move the row indices into the output array + + call amovi (Memi[idxptr], index, nindex) + + call mfree (idxptr, TY_INT) + call mfree (nulptr, TY_BOOL) + call mfree (aryptr, spptype) + +end + +# TBL_QSORT -- Indirect quick sort of a table column using an index array + +procedure tbl_qsort (ascend, dtype, aryptr, nelem, idxptr) + +bool ascend # i: Sort array in ascending order +int dtype # i: Data type of array to be sorted +pointer aryptr # i: Pointer to array to be sorted +int nelem # i: Number of elements to be sorted +pointer idxptr # o: Pointer to array of indices + +include "compare.com" + +int spptype + +extern compascb, compascd, compasci, compascr, compasct +extern compdscb, compdscd, compdsci, compdscr, compdsct + +begin + dataptr = aryptr + + # Convert the type to the SPP format + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + } else { + lendata = 1 + spptype = dtype + } + + # Call the quick sort procedure with the proper comparison routine + + switch (spptype) { + case TY_BOOL: + if (ascend) + call qsort (Memi[idxptr], nelem, compascb) + else + call qsort (Memi[idxptr], nelem, compdscb) + case TY_CHAR: + if (ascend) + call qsort (Memi[idxptr], nelem, compasct) + else + call qsort (Memi[idxptr], nelem, compdsct) + case TY_SHORT,TY_INT,TY_LONG: + if (ascend) + call qsort (Memi[idxptr], nelem, compasci) + else + call qsort (Memi[idxptr], nelem, compdsci) + case TY_REAL: + if (ascend) + call qsort (Memi[idxptr], nelem, compascr) + else + call qsort (Memi[idxptr], nelem, compdscr) + case TY_DOUBLE: + if (ascend) + call qsort (Memi[idxptr], nelem, compascd) + else + call qsort (Memi[idxptr], nelem, compdscd) + } +end diff --git a/pkg/utilities/nttools/lib/tblsortm.x b/pkg/utilities/nttools/lib/tblsortm.x new file mode 100644 index 00000000..1ece995d --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsortm.x @@ -0,0 +1,168 @@ +include "reloperr.h" + +.help tbl_sortm +.nf____________________________________________________________________________ + +This file contains two routines that sort a table on multiple columns. Both +routines put an existing array of row indices into sorted order. The first +routine, tbl_sortm has a simpler interface and is the routine to be used in +a majority of cases. The second routine, tbl_msort, requires that the calling +routine read the table column into an array and handle null elements by +itself. This routine should be used if the table column requires some +special preprocessing before it can be sorted. One example of required +preprocessing is conversion of dates from character strings to julian dates. +Both routines use merge sort to sort the data. Merge sort is fast, though not +as fast as quick sort, and stable, so it can be used to sort on multiple +columns. Its disadvantage is that it requires additional work space to run. + +.endhelp_______________________________________________________________________ + +# TBL_SORTM -- Sort a table on multiple columns +# +# This procedure rearranges an array of row indices into sorted order. The +# order is from smallest to largest value if ascend is true, if ascend is +# false, the order is from largest to smallest. In either case undefined +# elements will be last in the array. For purposes of this routine boolean +# false is considered to be less than true. If character strings are being +# sorted, case can be ignored by setting casesens to false. The array of row +# indices must be created before calling this procedure. +# +# B.Simon 28-Sept-87 First Code +# B.Simon 15-Dec-87 Changed to handle table subsets + +procedure tbl_sortm (ascend, casesens, tp, numptr, colptr, nindex, index) + +bool ascend # i: Sort in ascending order +bool casesens # i: Sort is case sensitive +pointer tp # i: Table descriptor +int numptr # i: Number of columns to sort on +pointer colptr[ARB] # i: Array of column descriptors +int nindex # io: Number of rows +int index[ARB] # io: Array of row indices in sorted order +#-- +int dtype, spptype, lendata +int iptr, nary, iary, nelem, nidx +pointer cp, idxptr, nulptr, aryptr, curptr + +int movenulls() + +begin + # Allocate storage for index array + + nidx = 2 * nindex + call malloc (idxptr, nidx, TY_INT) + + # Initialize the array of row indices + + call amovi (index, Memi[idxptr], nindex) + + # Loop over all columns to be sorted + + do iptr = numptr, 1, -1 { + + cp = colptr(iptr) + + # Read in the column of table values. Setting dtype to zero + # gets the actual column type. + + dtype = 0 + call gettabcol (tp, cp, dtype, nary, aryptr, nulptr) + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + + if (! casesens) { + curptr = aryptr + do iary = 1, nary { + call strupr (Memc[curptr]) + curptr = curptr + lendata + 1 + } + } + } else { + lendata = 1 + spptype = dtype + } + + # Move all null elements to the end of the array + + nelem = movenulls (nindex, Memb[nulptr], Memi[idxptr]) + + # Perform an indirect sort on the row indices using merge sort + + call tbl_msort (ascend, dtype, aryptr, nelem, nidx, idxptr) + + # Free memory used to hold table column and null flags + + call mfree (aryptr, spptype) + call mfree (nulptr, TY_BOOL) + } + + # Move the row indices into the output array + + call amovi (Memi[idxptr], index, nindex) + call mfree (idxptr, TY_INT) + +end + +# TBL_MSORT -- Indirect merge sort of a table column using an index array + +procedure tbl_msort (ascend, dtype, aryptr, nelem, nidx, idxptr) + +bool ascend # i: Sort array in ascending order +int dtype # i: Data type of array to be sorted +pointer aryptr # i: Pointer to array to be sorted +int nelem # i: Number of array elements to be sorted +int nidx # i: Size of index array +pointer idxptr # o: Pointer to array of indices + +include "compare.com" + +int spptype + +extern compascb, compascd, compasci, compascr, compasct +extern compdscb, compdscd, compdsci, compdscr, compdsct + +begin + dataptr = aryptr + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + } else { + lendata = 1 + spptype = dtype + } + + # Convert the type to the SPP format + + # Call the merge sort procedure with the proper comparison routine + + switch (spptype) { + case TY_BOOL: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compascb) + else + call msort (Memi[idxptr], nidx, nelem, compdscb) + case TY_CHAR: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compasct) + else + call msort (Memi[idxptr], nidx, nelem, compdsct) + case TY_SHORT,TY_INT,TY_LONG: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compasci) + else + call msort (Memi[idxptr], nidx, nelem, compdsci) + case TY_REAL: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compascr) + else + call msort (Memi[idxptr], nidx, nelem, compdscr) + case TY_DOUBLE: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compascd) + else + call msort (Memi[idxptr], nidx, nelem, compdscd) + } +end diff --git a/pkg/utilities/nttools/lib/tblterm.com b/pkg/utilities/nttools/lib/tblterm.com new file mode 100644 index 00000000..56d6c564 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblterm.com @@ -0,0 +1,7 @@ +int jumpbuf[LEN_JUMPBUF] +common /jmpcom/ jumpbuf + +bool constant +int nterm, irow, iterm +pointer table +common /opcom/ constant, nterm, irow, iterm, table diff --git a/pkg/utilities/nttools/lib/tblterm.x b/pkg/utilities/nttools/lib/tblterm.x new file mode 100644 index 00000000..65904221 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblterm.x @@ -0,0 +1,256 @@ +include <config.h> +include <evexpr.h> +include <tbset.h> +include <xwhen.h> +include "reloperr.h" + +define MAXTERM 64 + +# TBL_TERM -- Return the value of the term in the expression +# +# B.Simon 13-Apr-88 Separated from tbl_eval + +procedure tbl_term (term, op) + +char term[ARB] # i: The name of the term +pointer op # o: A structure holding the term value and type +#-- +include "tblterm.com" + +bool isnull +int datalen[MAXTERM], datatype[MAXTERM], dtype +pointer colptr[MAXTERM] +pointer sp, errtxt + +string badname "Column name not found (%s)" +string badnum "Too many terms in expression" +string nulvalue "Null found in table element" + +int tbcigi() + +errchk tbcfnd, tbcigi, tbegtb, tbegtt, tbegti, tbegtr + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + constant = false + iterm = iterm + 1 + if (iterm > MAXTERM) + call error (BOUNDS, badnum) + + # If this is a new term, get its column pointer, type, and length + + if (iterm > nterm) { + nterm = iterm + call tbcfnd (table, term, colptr[iterm], 1) + + if (colptr[iterm] == NULL) { + call sprintf (Memc[errtxt], SZ_LINE, badname) + call pargstr (term) + call error (SYNTAX, Memc[errtxt]) + } + + dtype = tbcigi (colptr[iterm], TBL_COL_DATATYPE) + switch (dtype) { + case TY_BOOL: + datalen[iterm] = 0 + datatype[iterm] = TY_BOOL + case TY_CHAR: + datalen[iterm] = 1 + datatype[iterm] = TY_CHAR + case TY_SHORT,TY_INT,TY_LONG: + datalen[iterm] = 0 + datatype[iterm] = TY_INT + case TY_REAL,TY_DOUBLE: + datalen[iterm] = 0 + datatype[iterm] = TY_REAL + default: + datalen[iterm] = - dtype + datatype[iterm] = TY_CHAR + } + } + + # Read the table to get the value of term + + call xev_initop (op, datalen[iterm], datatype[iterm]) + + switch (datatype[iterm]) { + case TY_BOOL: + call tbegtb (table, colptr[iterm], irow, O_VALB(op)) + isnull = false + case TY_CHAR: + call tbegtt (table, colptr[iterm], irow, O_VALC(op), + datalen[iterm]) + isnull = O_VALC(op) == EOS + case TY_SHORT,TY_INT,TY_LONG: + call tbegti (table, colptr[iterm], irow, O_VALI(op)) + isnull = IS_INDEFI (O_VALI(op)) + case TY_REAL,TY_DOUBLE: + call tbegtr (table, colptr[iterm], irow, O_VALR(op)) + isnull = IS_INDEFR (O_VALR(op)) + } + + # Error exit if table element is null + + if (isnull) + call error (PUTNULL, nulvalue) + + call sfree (sp) +end + +# TBL_FUNC -- Return the value of a nonstandard function in the expression + +procedure tbl_func (func_name, arg_ptr, nargs, op) + +char func_name[ARB] # i: String containing function name +pointer arg_ptr[ARB] # i: Pointers to function arguments +int nargs # i: Number of function arguments +pointer op # o: Pointer to output structure +#-- +include "tblterm.com" + +bool valflag +int type, iarg +pointer sp, errtxt + +string badtyp "Invalid argument type in %s" +string badarg "Incorrect number of arguments for %s" +string badfun "Unknown function named %s" + +bool streq() +double mjd() + +errchk mjd() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Call appropriate function according to name + + if (streq (func_name, "row")) { + + # Table row number function: row() + + constant = false + if (nargs != 0) { + call sprintf (Memc[errtxt], SZ_LINE, badarg) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + call xev_initop (op, 0, TY_INT) + O_VALI(op) = irow + + } else if (streq (func_name, "delta")) { + + # Difference between two Julian dates: mjd(date1) - mjd(date2) + + if (nargs != 2) { + call sprintf (Memc[errtxt], SZ_LINE, badarg) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + if (O_TYPE(arg_ptr[1]) != TY_CHAR || + O_TYPE(arg_ptr[2]) != TY_CHAR ) { + call sprintf (Memc[errtxt], SZ_LINE, badtyp) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + call xev_initop (op, 0, TY_REAL) + O_VALR(op) = mjd (O_VALC(arg_ptr[1])) - mjd (O_VALC(arg_ptr[2])) + + } else if (streq (func_name, "match")) { + if (nargs < 2) { + call sprintf (Memc[errtxt], SZ_LINE, badarg) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + + type = O_TYPE(arg_ptr[1]) + do iarg = 2, nargs { + if (type != O_TYPE(arg_ptr[iarg])) { + call sprintf (Memc[errtxt], SZ_LINE, badtyp) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + } + + valflag = false + call xev_initop (op, 0, TY_BOOL) + + switch (type) { + case TY_BOOL: + if (O_VALB(arg_ptr[1])) { + do iarg = 2, nargs { + if (O_VALB(arg_ptr[iarg])) { + valflag = true + break + } + } + } else { + do iarg = 2, nargs { + if (! O_VALB(arg_ptr[iarg])) { + valflag = true + break + } + } + } + case TY_CHAR: + do iarg = 2, nargs { + if (streq (O_VALC(arg_ptr[1]), O_VALC(arg_ptr[iarg]))) { + valflag = true + break + } + } + case TY_SHORT,TY_INT,TY_LONG: + do iarg = 2, nargs { + if (O_VALI(arg_ptr[1]) == O_VALI(arg_ptr[iarg])) { + valflag = true + break + } + } + case TY_REAL: + do iarg = 2, nargs { + if (O_VALR(arg_ptr[1]) == O_VALR(arg_ptr[iarg])) { + valflag = true + break + } + } + } + O_VALB(op) = valflag + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, badfun) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + + } + + call sfree (sp) +end + +# TBL_HANDLER -- Error handler to catch arithmetic errors + +procedure tbl_handler (code, nxt_handler) + +int code # i: error code which trigerred this exception +int nxt_handler # o: handler called after this handler exits +#-- +include "tblterm.com" + +bool junk +bool xerpop() + +begin + # Resume execution at zsvjmp + + nxt_handler = X_IGNORE + junk = xerpop() + call zdojmp (jumpbuf, code) +end diff --git a/pkg/utilities/nttools/lib/tctexp.x b/pkg/utilities/nttools/lib/tctexp.x new file mode 100644 index 00000000..263b18bc --- /dev/null +++ b/pkg/utilities/nttools/lib/tctexp.x @@ -0,0 +1,442 @@ +include <tbset.h> +include <ctype.h> +include "reloperr.h" + +define MAX_STACK 8 +define BLANK ' ' +define DELIM ',' +define ESCAPE '\\' +define NEGCHAR '~' # negation character +define ALT_NEGCHAR '!' # alternate negation character + +.help tctexp +.nf___________________________________________________________________________ +Column template package + +This package contains subroutines to expand a column name template into +an array of column pointers which match the template. The template is a +list of column patterns separated by commas or whitespace. 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 template is entirely whitespace, the array of column pointers +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 (~), +the array of column pointers will include all columns not matched by the +template. The negation character only has this meaning as the first character +in the column template, and is interpreted as part of a column name if +found later in the template or in a file. + +.endhelp______________________________________________________________________ + +# TCTEXP -- Expand a column template into an array of column pointers +# +# Given a table pointed to by a table descriptor and a column name template, +# return an array of column pointers. The size of the column pointer array +# is given by numcol and should be greater than or equal to the number of +# columns in the table. The actual number of columns found that match the +# template is returned as numptr. +# +# B.Simon 24-Jul-1987 First Code +# Phil Hodge 1-Jun-1989 make search for columns case insensitive +# Phil Hodge 28-Jan-1999 add ! as an alternate negation character + +procedure tctexp (tp, template, numcol, numptr, colptr) + +pointer tp # i: pointer to table descriptor +char template[ARB] # i: column template +int numcol # i: size of column pointer array +int numptr # o: number of columns matched +pointer colptr[ARB] # o: array of column pointers +#-- + +bool nometa # true if pattern does not contain metacharacters +bool negate # true if template starts with negation character + +int fd_ptr # pointer to stack of open list file descriptors +int ic # first non-white character in template + +pointer fd_stack[MAX_STACK] + # stack of file descriptors for open list files + +pointer sp, colpat, pattern, auxcol, fd + +string stkovflerr "List files are nested too deeply, stack overflow" + +int strlen(), tctgetpat() +pointer stropen(), open() + +errchk salloc, stropen, open, close +errchk tctgetpat, tctmakpat, tctstrmatch, tctpatmatch + +begin + numptr = 0 + negate = false + + call smark (sp) + call salloc (colpat, SZ_FNAME, TY_CHAR) + call salloc (pattern, SZ_FNAME, TY_CHAR) + + # Check the column name template to find the first non-white character. + + for (ic = 1; IS_WHITE (template[ic]); ic = ic + 1) + ; + + if (template[ic] == EOS) { + + # If the template is blank, include all columns in the array + + call allcolumns (tp, numptr, auxcol) + call amovi (Memi[auxcol], colptr, numptr) + call mfree (auxcol, TY_INT) + fd_ptr = 0 + + } else { + + # If the first non-white character is the negation character + # (either ~ or !), the meaning of the column name template is + # negated, that is, the array of column pointers will include + # those columns whose names were not matched by the column template + + if (template[ic] == NEGCHAR || template[ic] == ALT_NEGCHAR) { + negate = true + ic = ic + 1 + } + + # Open the column name template as a file and push on + # the list file stack + + fd_ptr = 1 + fd_stack[1] = + stropen (template[ic], strlen(template[ic]), READ_ONLY) + + } + + while (fd_ptr > 0) { + + # Pop file descriptor off of the list file stack + + fd = fd_stack[fd_ptr] + fd_ptr = fd_ptr - 1 + + # Loop over all column patterns in the file + + while (tctgetpat (fd, Memc[colpat], SZ_FNAME) > 0) { + + if (Memc[colpat] == '@') { + + # If this pattern is a list file name, push the + # current descriptor on the stack and open the file + + if (fd_ptr == MAX_STACK) + call error (BOUNDS, stkovflerr) + fd_ptr = fd_ptr + 1 + fd_stack[fd_ptr] = fd + fd = open (Memc[colpat+1], READ_ONLY, TEXT_FILE) + + } else { + + # Otherwise, encode the pattern and search the table + # for matching column names. To speed the search, use + # a special routine if the pattern does not include + # metacharacters + + call strlwr (Memc[colpat]) # for case insensitivity + call tctmakpat (Memc[colpat], Memc[pattern], SZ_FNAME, + nometa) + if (nometa) + call tctstrmatch (tp, Memc[pattern], numcol, + numptr, colptr) + else + call tctpatmatch (tp, Memc[pattern], numcol, + numptr, colptr) + } + } + call close (fd) + } + + if (negate) + call invert (tp, numptr, colptr) + + call sfree (sp) +end + +# TCTGETPAT -- Get next comma or whitespace delimeted pattern from file +# +# Copy characters into colpat until a field delimeter or the maximum number of +# characters is reached. The number of characters in colpat is returned as the +# value of the function, so the procedure which calls this one can test for +# the last field in the template. +# +# B. Simon 24-Jul-87 First Code + +int procedure tctgetpat (fd, colpat, maxch) + +pointer fd # i: template file descriptor +char colpat[ARB] # o: pattern from column name template +int maxch # i: maximum number of characters in field +#-- +char ch # next character from template +int iq # pointer to character in colpat + +char getc() + +begin + # Skip leading whitespace or commas + + ch = getc (fd, ch) + while (IS_CNTRL(ch) || ch == BLANK || ch == DELIM) + ch = getc (fd, ch) + + # Copy characters to colpat. End when maxch is reached, or + # when comma, whitespace, or EOF is found + + for (iq = 1; iq <= maxch; iq = iq + 1) { + + if (IS_CNTRL(ch) || ch == BLANK || ch == DELIM || ch == EOF) + break + + colpat[iq] = ch + ch = getc (fd, ch) + } + colpat[iq] = EOS + + # If loop is terminated because of maxch, eat remaining characters + # in field + + while (! IS_CNTRL(ch) && ch != BLANK && ch != DELIM && ch != EOF) + ch = getc (fd, ch) + + # Return number of characters in colpat + + return (iq-1) +end + +# TCTMAKPAT -- Encode the column pattern +# +# Create the pattern used by the matching routines. Check for metacharacters +# (unescaped pattern matching characters) to see if the faster constant +# pattern routine can be used. +# +# B.Simon 24-Jul-87 First Code + +procedure tctmakpat (colpat, pattern, maxch, nometa) + +char colpat[ARB] # i: Column pattern string +char pattern[ARB] # o: Encoded pattern string +int maxch # i: Maximum length of encoded pattern string +bool nometa # o: True if no metacharacters in string +#-- +int ic, ip +pointer sp, buffer, buffer2, errtxt, ib + +int stridx(), strlen(), patmake() + +string patovflerr "Column pattern too long (%s)" +string badpaterr "Column pattern has bad syntax (%s)" + +begin + call smark (sp) + call salloc (buffer, maxch, TY_CHAR) + call salloc (buffer2, maxch, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + nometa = true + ib = buffer + + # Copy the column pattern to a temporary buffer + + for (ic = 1; colpat[ic] != EOS ; ic = ic + 1) { + + # Copy escape sequences, but do not count as metacharacters + + if (colpat[ic] == ESCAPE && colpat[ic+1] != EOS) { + Memc[ib] = ESCAPE + ib = ib + 1 + ic = ic + 1 + + # Covert '*' to '?*', count as a metacharacter + + } else if (colpat[ic] == '*') { + nometa = false + Memc[ib] = '?' + ib = ib + 1 + + # Check for the other metacharacters + + } else if (stridx (colpat[ic], "[?{") > 0) + nometa = false + + Memc[ib] = colpat[ic] + ib = ib + 1 + } + Memc[ib] = EOS + + # Check the buffer length against maximum pattern length + + if (strlen (Memc[buffer]) > maxch) { + call sprintf (Memc[errtxt], SZ_LINE, patovflerr) + call pargstr (colpat) + call error (BOUNDS, Memc[errtxt]) + } + + # If no metacharacters, strip escape sequences + + if (nometa) { + ip = 1 + for (ib = buffer; Memc[ib] != EOS; ib = ib + 1) { + if (Memc[ib] == ESCAPE && Memc[ib+1] != EOS) + ib = ib + 1 + pattern[ip] = Memc[ib] + ip = ip + 1 + } + pattern[ip] = EOS + + # Otherwise, encode with patmake + + } else { + call sprintf (Memc[buffer2], maxch, "^%s$") + call pargstr (Memc[buffer]) + + if (patmake (Memc[buffer2], pattern, SZ_LINE) == ERR) { + call sprintf (Memc[errtxt], SZ_LINE, badpaterr) + call pargstr (colpat) + call error (SYNTAX, Memc[errtxt]) + } + } + + call sfree (sp) +end + +# TCTSTRMATCH -- Add a column pointer for a column name to the array +# +# Used to match column names when the column pattern contains no +# metacharacters. +# +# B. Simon 24-Jul-87 First Code + +procedure tctstrmatch (tp, pattern, numcol, numptr, colptr) + +pointer tp # i: pointer to table descriptor +char pattern[ARB] # i: column pattern +int numcol # i: size of column pointer array +int numptr # o: number of columns matched +pointer colptr[ARB] # o: array of column pointers +#-- +int iptr +pointer sp, errtxt, cp + +string maxcolerr "Maximum number of columns in table exceeded (%d)" + +errchk tbcfnd + +begin + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Find the column pointer corresponding to the column name + + call tbcfnd (tp, pattern, cp, 1) + + # Pointer is null if column not found in table + + if (cp == NULL) + return + + # See if the column name has already been matched + + for (iptr = 1; iptr <= numptr; iptr = iptr +1) { + if (cp == colptr[iptr]) + break + } + + # If not, add its pointer in the array of pointers + # after checking for array overflow + + if (iptr > numptr) { + if (numptr >= numcol) { + call sprintf (Memc[errtxt], SZ_LINE, maxcolerr) + call pargi (numcol) + call error (BOUNDS, Memc[errtxt]) + } + numptr = numptr + 1 + colptr[numptr] = cp + } + + call sfree (sp) +end + +# TCTPATMATCH -- Find column pointers for columns matching a pattern +# +# This routine is called when the column pattern contains metacharacters. +# +# B.Simon 27-Jul-87 First Code + +procedure tctpatmatch (tp, pattern, numcol, numptr, colptr) + +pointer tp # i: pointer to table descriptor +char pattern[ARB] # i: column pattern +int numcol # i: size of column pointer array +int numptr # o: number of columns matched +pointer colptr[ARB] # o: array of column pointers +#-- +int maxcol, icol, iptr +pointer sp, errtxt, cp +pointer colname + +string maxcolerr "Maximum number of columns in table exceeded (%d)" + +int tbpsta(), tbcnum(), patmatch() + +errchk tbpsta, tbcnum, tbcinf, patmatch + +begin + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + maxcol = tbpsta (tp, TBL_NCOLS) + + # Compare the column pattern to each column name in the table + + do icol = 1, maxcol { + + # Get the next column name in the table + + cp = tbcnum (tp, icol) + call tbcigt (cp, TBL_COL_NAME, Memc[colname], SZ_COLNAME) + call strlwr (Memc[colname]) # for case insensitivity + + # Check the column name for a match + + if (patmatch (Memc[colname], pattern) > 0) { + # See if the column name has already been matched + + for (iptr = 1; iptr <= numptr; iptr = iptr +1) { + if (cp == colptr[iptr]) + break + } + + # If not, add its pointer in the array of pointers + # after checking for array overflow + + if (iptr > numptr) { + if (numptr >= numcol) { + call sprintf (Memc[errtxt], SZ_LINE, maxcolerr) + call pargi (numcol) + call error (BOUNDS, Memc[errtxt]) + } + numptr = numptr + 1 + colptr[numptr] = cp + } + } + } + + call sfree (sp) + +end diff --git a/pkg/utilities/nttools/lib/tldtype.x b/pkg/utilities/nttools/lib/tldtype.x new file mode 100644 index 00000000..52e35960 --- /dev/null +++ b/pkg/utilities/nttools/lib/tldtype.x @@ -0,0 +1,70 @@ +define T_MAXDIM 7 # maximum dimension of array + +# tl_dtype -- data type and array size +# Convert integer data type code to a character string. If the column +# contains arrays, append the length of each axis, e.g. R[25,75]. +# +# Phil Hodge, 9-Dec-1994 Moved from tlcol.x to ttools$lib/. +# Phil Hodge, 19-Jul-1995 Add tp to calling sequence (needed for tbciga). + +procedure tl_dtype (tp, cp, datatype, nelem, chartyp, maxch) + +pointer tp # i: pointer to table descriptor +pointer cp # i: pointer to column descriptor +int datatype # i: integer code for data type +int nelem # i: total array size +char chartyp[maxch] # o: data type, possibly with array size +int maxch # i: maximum size of chartyp string +#-- +int nchar # number of characters +int i # loop index +int ndim # dimension of array +int axlen[T_MAXDIM] # length of each axis +int ip, itoc() +int strlen() +errchk tbciga + +begin + if (datatype > 0) { # numeric or Boolean + + switch (datatype) { + case TY_REAL: + call strcpy ("R", chartyp, maxch) + case TY_DOUBLE: + call strcpy ("D", chartyp, maxch) + case TY_INT: + call strcpy ("I", chartyp, maxch) + case TY_SHORT: + call strcpy ("S", chartyp, maxch) + case TY_BOOL: + call strcpy ("B", chartyp, maxch) + default: + call error (1, "bad data type in table") + } + + } else { # < 0 ==> char string + + nchar = -datatype # length of string + call sprintf (chartyp, maxch, "CH*%d") + call pargi (nchar) + } + + if (nelem > 1) { + + # Get the dimension of array and size of each axis. + call tbciga (tp, cp, ndim, axlen, T_MAXDIM) + + call strcat ("[", chartyp, maxch) + + ip = strlen (chartyp) + 1 # points to EOS + + do i = 1, ndim-1 { + nchar = itoc (axlen[i], chartyp[ip], maxch-ip+1) + call strcat (",", chartyp, maxch) + ip = ip + nchar + 1 + } + + nchar = itoc (axlen[ndim], chartyp[ip], maxch-ip+1) + call strcat ("]", chartyp, maxch) + } +end diff --git a/pkg/utilities/nttools/lib/tuopen.x b/pkg/utilities/nttools/lib/tuopen.x new file mode 100644 index 00000000..7434a72b --- /dev/null +++ b/pkg/utilities/nttools/lib/tuopen.x @@ -0,0 +1,197 @@ +# This file contains tu_open and tu_close, which are used to open +# and close a temporary table. +# +# Phil Hodge, 28-Jun-1995 Subroutines created based on Bernie's tedit code. +# Phil hodge, 16-Apr-1999 Remove ttype from calling sequence of tbparse. + +# tu_open -- open a temporary table +# If the table is to be opened in-place, then it's just opened. +# Otherwise, a copy of the table is made, and that table is opened +# read-write. The name of the original table will be returned as +# 'tabname' so it can be passed to tu_close, which needs the name of +# the original file. If the filename extension is ".tab", then 'table' +# might not include the extension. This is the reason we need a +# separate output argument 'tabname'. Note, however, that text tables +# need not have an extension. If 'table' does not include an extension, +# and a file of that name exists, then ".tab" will not be appended when +# copying to 'tabname'. 'tabname' can differ from the actual file name +# by including a name or number in brackets after the file name. +# +# Note that it is an error if readonly=true but inplace=false. + +procedure tu_open (table, root, readonly, inplace, tp, tabname, maxch) + +char table[ARB] # i: name of table +char root[ARB] # i: beginning of name for scratch file +bool readonly # i: true if the table is to be opened read-only +bool inplace # i: true if the table is to be opened in-place +pointer tp # o: pointer to table struct +char tabname[maxch] # o: full name of original table (incl extension, etc) +int maxch # i: size of filename string +#-- +pointer sp +pointer temp # name of temporary table +pointer tname, fname # full table and file names +pointer extn # file extension, or EOS +pointer tempdir # name of directory for temporary copy +pointer errmess # scratch for error message +int tlen, flen # length of table and file names +int try # loop index +int junk, fnldir() +pointer tbtopn() +int strlen() +errchk tbtopn, tbtnam, tbfile, fcopy + +begin + if (readonly && !inplace) + call error (1, "readonly = yes, but inplace = no") + + if (inplace) { + + if (readonly) { + tp = tbtopn (table, READ_ONLY, NULL) + } else { + tp = tbtopn (table, READ_WRITE, NULL) + } + + call tbtnam (tp, tabname, maxch) # get the full table name + + } else { + + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + call salloc (tname, SZ_LINE, TY_CHAR) + call salloc (fname, SZ_LINE, TY_CHAR) + call salloc (extn, SZ_LINE, TY_CHAR) + call salloc (tempdir, SZ_LINE, TY_CHAR) + + # Get the full table name, full file name, and extension (if any) + # of the original file. Copy the table name to output. + call tbfile (table, Memc[tname], Memc[fname], Memc[extn], SZ_LINE) + call strcpy (Memc[tname], tabname, maxch) + + # Get the name of the directory containing the original file. + junk = fnldir (Memc[fname], Memc[tempdir], SZ_LINE) + + # Copy the original file to a temporary file. First try to + # make the copy in the directory containing the original file. + # If that fails then copy the file to tmp$. + do try = 1, 2 { + + # Construct the name of a temporary file by concatenating + # the directory, root, a random number, and the extension + # of the original file name. + call strcat (root, Memc[tempdir], SZ_LINE) + call mktemp (Memc[tempdir], Memc[temp], SZ_LINE) + call strcat (Memc[extn], Memc[temp], SZ_LINE) + + # Copy the file. + ifnoerr (call fcopy (Memc[fname], Memc[temp])) + break + + if (try == 1) { + # The first try failed. Copy the file to tmp$. + call strcpy ("tmp$", Memc[tempdir], SZ_LINE) + } else { + # The second try failed as well. + call salloc (errmess, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmess], SZ_LINE, + "unable to make a temporary copy of %s") + call pargstr (Memc[fname]) + call error (1, Memc[errmess]) + } + } + + # If there was a bracketed expression (e.g. EXTNAME) in the + # input table name, append it to the name of the temp file + # to convert the file name to a complete table name. + tlen = strlen (Memc[tname]) + flen = strlen (Memc[fname]) + if (tlen > flen) + call strcat (Memc[tname+flen], Memc[temp], SZ_LINE) + + tp = tbtopn (Memc[temp], READ_WRITE, NULL) + + call sfree (sp) + } +end + +# tu_close -- close a temporary table +# This routine first closes the table that was edited. If it was opened +# inplace, then we have nothing further to do. Otherwise, we were editing +# a temporary copy of the original. If the command was to quit without +# saving changes, we delete the temporary file. If the command was to +# exit, saving changes, we rename the copy back to the original. +# The quit and tabname arguments will be ignored if inplace is true. + +procedure tu_close (tp, inplace, quit, tabname) + +pointer tp # i: pointer to table struct for edited table +bool inplace # i: true if the table was edited inplace +bool quit # i: true if we should quit without saving changes +char tabname[ARB] # i: name of original table (not temp copy) +#-- +pointer sp +pointer temp # name of temporary file +pointer tname # name of temporary table +pointer filename # name of original file +pointer cdfname # scratch +pointer errmess # for error message +int hdu # ignored +int junk +int errget() +int tbparse() +errchk tbparse, delete, rename + +begin + if (tp == NULL) + return + + call smark (sp) + call salloc (tname, SZ_LINE, TY_CHAR) + + # Get the name of the table that we edited, then close it. + call tbtnam (tp, Memc[tname], SZ_LINE) + call tbtclo (tp) + + if (!inplace) { + + call salloc (temp, SZ_LINE, TY_CHAR) + call salloc (filename, SZ_LINE, TY_CHAR) + call salloc (cdfname, SZ_LINE, TY_CHAR) + + # Strip off brackets (if present) to get the file name + # for the table that we edited. + junk = tbparse (Memc[tname], Memc[temp], + Memc[cdfname], SZ_LINE, hdu) + + # Strip off brackets (if present) to get the file name + # of the original table. + junk = tbparse (tabname, Memc[filename], + Memc[cdfname], SZ_LINE, hdu) + + if (quit) { + + call delete (Memc[temp]) # delete temp copy + + } else { + + iferr { + call delete (Memc[filename]) # delete original file + call rename (Memc[temp], Memc[filename]) + } then { + call salloc (errmess, SZ_LINE, TY_CHAR) + junk = errget (Memc[errmess], SZ_LINE) + call eprintf ("%s\n") + call pargstr (Memc[errmess]) + call sprintf (Memc[errmess], SZ_LINE, + "couldn't rename edited file %s to original %s\n") + call pargstr (Memc[temp]) + call pargstr (Memc[filename]) + call error (1, Memc[errmess]) + } + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/unique.x b/pkg/utilities/nttools/lib/unique.x new file mode 100644 index 00000000..ca54f840 --- /dev/null +++ b/pkg/utilities/nttools/lib/unique.x @@ -0,0 +1,64 @@ +# UNIQUE -- Find unique rows in a table +# +# First, the table is sorted on columns input in the colptr array. The +# results are stored in the index array. Then each row in the index array +# is compared to the most recent unique row in the index array, column by +# column. If any column differs, the row is also considered to be unique. +# The index array is updated to reflect the new unique row and the number of +# unique rows is incremented. +# +# B.Simon 19-Oct-87 First Code +# B.Simon 14-Dec-87 Changed to handle table subsets +# B.Simon 06-Feb-90 Changed to use tbtsrt and tbrcmp + +procedure unique (tp, numptr, colptr, nindex, index) + +pointer tp # i: Table descriptor +int numptr # i: Number of column pointers +pointer colptr[ARB] # i: Array of column pointers +int nindex # io: Number of unique row indices returned +int index[ARB] # io: Array of unique indices +#-- +bool fold +int order, idx, jdx, n, i + +int tbrcmp() + +begin + + # Sort the array on the selected columns. The sort is in ascending + # order and case sensitive + + fold = false + call tbtsrt (tp, numptr, colptr, fold, nindex, index) + + # Search for unique rows + + jdx = 0 + n = nindex + nindex = 0 + + do i = 1, n { + idx = index[i] + + # First row is always unique + + if (i == 1) + order = 1 + else + order = tbrcmp (tp, numptr, colptr, fold, idx, jdx) + + # Update pointer to most recent unique row and modify index + # array in place + + if (order != 0) { + jdx = idx + nindex = nindex + 1 + index[nindex] = idx + } + } + + do i = nindex+1, n + index[i] = 0 + +end |