Repatch (from linux) of OSX IRAF

1 files changed, 486 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/tprint/tdump.x b/pkg/utilities/nttools/tprint/tdump.x
new file mode 100644
index 00000000..54658d58
--- /dev/null
+++ b/pkg/utilities/nttools/tprint/tdump.x
@@ -0,0 +1,486 @@
+include <tbset.h>
+
+# tdump -- Program to dump a table.
+# This differs from tprint in several ways:  column names and row numbers
+# are not printed, and all columns for a given row are printed (possibly on
+# several lines) before moving on to the next row.  Also, g format is used
+# for floating-point numbers (%15.7g for real, %24.16g for double) regardless
+# of the format specification for the column.  This is to prevent loss of
+# precision.
+#
+# Phil Hodge, 31-Jul-1987  Task created
+# Phil Hodge, 11-Aug-1987  Modify d_gt_col_ptr for datatype=-n for char string.
+# Phil Hodge, 30-Dec-1987  Use tctexp for column names.
+# Phil Hodge,  7-Sep-1988  Change parameter name for table.
+# Phil Hodge, 21-Dec-1988  Also print column descrip; use g format for data.
+# Phil Hodge,  9-Mar-1989  Change type of dtype in tbhgnp from char to int.
+# Phil Hodge,  9-Jul-1991  Rename parameter pagwidth to pwidth.
+# Phil Hodge,  2-Apr-1993  Include short datatype in td_col_def.
+# Phil Hodge,  2-Jun-1994  In td_col_ptr, include newline in warning message.
+# Phil Hodge, 12-Dec-1994  Include array size in column definitions;
+#			increase SZ_DTYPE from 9 to 29;
+#			dump all elements if column is an array.
+# Phil Hodge, 15-Dec-1994  Increase size of file names from SZ_FNAME to SZ_LINE.
+# Phil Hodge, 13-Jan-1995  Change calling sequence of inquotes.
+# Phil Hodge, 19-Jul-1995  Add tp to calling sequence of tl_dtype in td_col_def.
+# Phil Hodge,  4-Apr-1996  In td_p_data, start each array at beginning of line;
+#			change formats for real & double to %13.7g, %22.16g.
+# Phil Hodge,  5-Jun-1997  If keywords are to be printed, also print comments.
+# Phil Hodge, 20-Jul-1998  Print '' instead of blank for null keywords.
+# Phil Hodge, 22-Jul-1998  Left justify strings and boolean elements.
+# Phil Hodge,  2-Nov-2000  Use pwidth < 1 to disable the test on page width.
+# Phil Hodge, 15-May-2002  Use a specific format for int and short columns;
+#			this was needed because for x or o format the printed
+#			values could be misleading.
+
+define  SZ_FMT    	16	# size of string containing print format
+define	FMT_REAL    "%13.7g"	# format for printing a real
+define	SPACE_REAL	13	# space required for printing a real
+define	FMT_DBL     "%22.16g"	# format for printing a double
+define	SPACE_DBL	22	# space required for printing a double
+define	FMT_INT     "%11d"	# format for printing an int
+define	SPACE_INT	11	# space required for printing an int
+define	FMT_SHORT   "%5d"	# format for printing a short
+define	SPACE_SHORT	 5	# space required for printing a short
+define	MAX_RANGES (SZ_LINE/2)	# max number of ranges of row numbers
+define  SZ_DTYPE  	29	# size of string containing column data type
+define	SZ_LBUF   2 * SZ_LINE + 1
+
+procedure tdump()
+#--
+pointer tp			# pointer to input table descr
+pointer cptr			# scratch for array of column pointers
+pointer tname			# scratch for table name
+pointer cname, pname, dname	# scratch for names of output files
+pointer upar			# scratch for header keyword value
+pointer comment			# scratch for header keyword comment
+pointer datatype		# scr for array of data types of columns
+pointer nelem			# scr for array of array lengths of columns
+pointer len_fmt			# scr for array of lengths of print formats
+pointer pformat			# scratch for array of print formats
+pointer columns			# list of columns to be dumped
+pointer r_str			# string which gives ranges of row numbers
+char	keyword[SZ_KEYWORD]	# buffer for user parameter keyword
+char	char_type		# data type as a letter (t, b, i, r, d)
+pointer sp			# stack pointer
+int	fd			# file descr for output user param, data
+int	n			# loop index for user parameters
+int	dtype			# data type (TY_CHAR, etc)
+int	npar			# number of user parameters
+int	nrows, ncols		# number of rows and columns in table
+int	nprint			# number of columns to print (may be < ncols)
+int	pagewidth		# page width
+bool	prcoldef		# print column definitions?
+bool	prparam, prdata		# print user parameters? data?
+pointer tbtopn()
+int	open(), clgeti(), tbpsta()
+
+begin
+	call smark (sp)
+	call salloc (tname, SZ_LINE, TY_CHAR)
+	call salloc (cname, SZ_LINE, TY_CHAR)
+	call salloc (pname, SZ_LINE, TY_CHAR)
+	call salloc (dname, SZ_LINE, TY_CHAR)
+	call clgstr ("table", Memc[tname], SZ_LINE)
+
+	# Get the names of the output files.  If a name is null, don't
+	# write the corresponding portion of the table.
+	call clgstr ("cdfile", Memc[cname], SZ_LINE)
+	call clgstr ("pfile", Memc[pname], SZ_LINE)
+	call clgstr ("datafile", Memc[dname], SZ_LINE)
+	prcoldef = (Memc[cname] != EOS)
+	prparam = (Memc[pname] != EOS)
+	prdata = (Memc[dname] != EOS)
+	if (!prcoldef && !prparam && !prdata) {
+	    call sfree (sp)			# nothing to do
+	    return
+	}
+
+	tp = tbtopn (Memc[tname], READ_ONLY, 0)
+
+	if (prcoldef || prdata) {
+
+	    # If we are to print column definitions and/or data,
+	    # allocate memory and get list of columns.
+
+	    call salloc (columns, SZ_LINE, TY_CHAR)
+	    call clgstr ("columns", Memc[columns], SZ_LINE)
+	    ncols = tbpsta (tp, TBL_NCOLS)
+
+	    # Allocate enough scratch space for printing all columns.
+	    call salloc (cptr, ncols, TY_POINTER)
+	    call salloc (len_fmt, ncols, TY_INT)
+	    call salloc (datatype, ncols, TY_INT)
+	    call salloc (nelem, ncols, TY_INT)
+	}
+
+	if (prcoldef) {
+
+	    # Open the output file for the column definitions.
+	    fd = open (Memc[cname], NEW_FILE, TEXT_FILE)
+
+	    # Print column definitions.
+	    call td_col_def (tp, fd, Memc[columns], Memi[cptr])
+
+	    call close (fd)		# column definitions have been written
+	}
+
+	if (prparam) {
+
+	    # Print header parameters.
+	    npar = tbpsta (tp, TBL_NPAR)
+	    if (npar > 0) {
+		fd = open (Memc[pname], NEW_FILE, TEXT_FILE)
+		call salloc (upar, SZ_PARREC, TY_CHAR)
+		call salloc (comment, SZ_PARREC, TY_CHAR)
+		do n = 1, npar {
+		    # Get the Nth user parameter, and print it.
+		    call tbhgnp (tp, n, keyword, dtype, Memc[upar])
+		    call tbhgcm (tp, keyword, Memc[comment], SZ_PARREC)
+		    switch (dtype) {
+		    case TY_REAL:
+			char_type = 'r'
+		    case TY_INT:
+			char_type = 'i'
+		    case TY_DOUBLE:
+			char_type = 'd'
+		    case TY_BOOL:
+			char_type = 'b'
+		    default:
+			char_type = 't'
+		    }
+		    if (keyword[1] == EOS) {
+			call fprintf (fd, "''      ")
+		    } else {
+			call fprintf (fd, "%-8s")
+			    call pargstr (keyword)
+		    }
+		    call fprintf (fd, " %c")
+			call pargc (char_type)
+		    if (Memc[comment] == EOS) {
+			call fprintf (fd, " %s\n")
+			    call pargstr (Memc[upar])
+		    } else {				# also print comment
+			if (char_type == 't') {
+			    call fprintf (fd, " '%s'")	# enclose text in quotes
+				call pargstr (Memc[upar])
+			} else {
+			    call fprintf (fd, " %s")	# no quotes needed
+				call pargstr (Memc[upar])
+			}
+			call fprintf (fd, "  %s\n")
+			    call pargstr (Memc[comment])
+		    }
+		}
+		call close (fd)		# header parameters have been written
+	    }
+	}
+
+	if (prdata) {
+
+	    # Print data portion of table.
+	    nrows = tbpsta (tp, TBL_NROWS)
+
+	    if ((nrows < 1) || (ncols < 1)) {
+		call eprintf ("table is empty\n")
+		call tbtclo (tp)
+		call sfree (sp)
+	        return				# nothing more to do
+	    }
+	    # Open the output file for the table data.
+	    fd = open (Memc[dname], NEW_FILE, TEXT_FILE)
+
+	    call salloc (r_str, SZ_LINE, TY_CHAR)
+	    call clgstr ("rows", Memc[r_str], SZ_LINE)
+
+	    pagewidth = clgeti ("pwidth")
+	    if (IS_INDEF(pagewidth))
+		pagewidth = -1		# no limit on page width
+
+	    # Get column pointers, formats, etc for all columns that are
+	    # to be printed.
+	    call td_col_ptr (tp, Memc[columns], pagewidth, Memi[cptr],
+		Memi[len_fmt], Memi[datatype], Memi[nelem], nprint)
+
+	    if (nprint > 0) {
+		# Allocate scratch space for print format.  (one char for EOS)
+		call salloc (pformat, (SZ_FMT+1)*nprint, TY_CHAR)
+		# Print the values in the table.
+		call td_p_data (tp, fd, Memi[cptr], Memc[r_str],
+			Memi[len_fmt], Memi[datatype], Memi[nelem],
+			Memc[pformat], pagewidth, nprint)
+	    }
+	    call close (fd)		# data values have been printed
+	}
+	call tbtclo (tp)
+	call sfree (sp)
+end
+
+
+
+# td_col_def -- print column definitions
+# This routine prints the column name, data type, print format, and units
+# for all columns that were specified by the user.
+
+procedure td_col_def (tp, fd, columns, cptr)
+
+pointer tp			# i: pointer to table descriptor
+int	fd			# i: fd for output file
+char	columns[ARB]		# i: list of columns to be dumped
+pointer cptr[ARB]		# o: array of pointers to column descriptors
+#--
+pointer sp
+pointer cname, cunits, cfmt	# pointers to scratch space for column info
+char	chartyp[SZ_DTYPE]	# data type expressed as a string
+int	ncols			# the total number of columns in the table
+int	nprint			# number of columns to print
+int	dtype			# data type of a column
+int	nelem			# array length
+int	lenformat		# (ignored)
+int	colnum			# column number (ignored)
+int	k			# loop index
+int	tbpsta()
+
+begin
+	call smark (sp)
+	call salloc (cname, SZ_FNAME, TY_CHAR)
+	call salloc (cunits, SZ_FNAME, TY_CHAR)
+	call salloc (cfmt, SZ_COLFMT, TY_CHAR)
+
+	ncols = tbpsta (tp, TBL_NCOLS)
+
+	# Get column pointers for all columns that are to be dumped.
+	call tctexp (tp, columns, ncols, nprint, cptr)
+
+	# Do for each column that is to be printed.
+	do k = 1, nprint {
+	    call tbcinf (cptr[k],
+			colnum, Memc[cname], Memc[cunits], Memc[cfmt],
+			dtype, nelem, lenformat)
+
+	    # Enclose column name in quotes if it contains embedded
+	    # or trailing blanks.
+	    call inquotes (Memc[cname], Memc[cname], SZ_FNAME, YES)
+	    call fprintf (fd, "%-16s")		# but name can be longer
+		call pargstr (Memc[cname])
+
+	    # Print data type.  First convert integer data type code to a
+	    # character string, and append info about array size if > 1.
+	    call tl_dtype (tp, cptr[k], dtype, nelem, chartyp, SZ_DTYPE)
+	    call fprintf (fd, " %-8s")
+		call pargstr (chartyp)
+
+	    # Print the format for display.
+	    call fprintf (fd, " %8s")
+		call pargstr (Memc[cfmt])
+
+	    # Print column units.  Ignore trailing blanks.
+	    call inquotes (Memc[cunits], Memc[cunits], SZ_FNAME, NO)
+	    call fprintf (fd, "  %s")
+		call pargstr (Memc[cunits])
+	    call fprintf (fd, "\n")		# end of line for each column
+	}
+	call sfree (sp)
+end
+
+
+# td_col_ptr -- get column pointers
+# This routine gets an array of pointers to the descriptors of those
+# columns that are to be printed, plus other info.
+
+procedure td_col_ptr (tp, columns, pagewidth,
+		cptr, len_fmt, datatype, nelem, nprint)
+
+pointer tp			# i: pointer to table descriptor
+char	columns[ARB]		# i: list of columns to be dumped
+int	pagewidth		# i: page width (to make sure it's wide enough)
+pointer cptr[ARB]		# o: array of pointers to column descriptors
+int	len_fmt[ARB]		# o: length of print format for each column
+int	datatype[ARB]		# o: data type for each column
+int	nelem[ARB]		# o: array length of each column
+int	nprint			# o: number of columns to print
+#--
+char	colname[SZ_COLNAME]	# column name for possible error message
+int	ncols			# total number of columns in the table
+int	k			# loop index
+int	tbpsta(), tbcigi()
+
+begin
+	ncols = tbpsta (tp, TBL_NCOLS)
+
+	# Get column pointers for all columns that are to be dumped.
+	call tctexp (tp, columns, ncols, nprint, cptr)
+
+	# For each column that is to be printed, get the length of the print
+	# format, and if the column type is string then increase the length
+	# of the print format by two for possible enclosing quotes.
+	do k = 1, nprint {
+
+	    datatype[k] = tbcigi (cptr[k], TBL_COL_DATATYPE)
+	    nelem[k] = tbcigi (cptr[k], TBL_COL_LENDATA)
+
+	    if (datatype[k] == TY_REAL)
+		len_fmt[k] = SPACE_REAL
+	    else if (datatype[k] == TY_DOUBLE)
+		len_fmt[k] = SPACE_DBL
+	    else if (datatype[k] == TY_INT)
+		len_fmt[k] = SPACE_INT
+	    else if (datatype[k] == TY_SHORT)
+		len_fmt[k] = SPACE_SHORT
+	    else
+		len_fmt[k] = tbcigi (cptr[k], TBL_COL_FMTLEN)
+
+	    if (datatype[k] < 0)			# char string column
+		len_fmt[k] = len_fmt[k] + 2
+
+	    if (pagewidth > 0 && len_fmt[k] > pagewidth) {
+		call tbcigt (cptr[k], TBL_COL_NAME, colname, SZ_COLNAME)
+		call eprintf ("Page width is too small for column `%s'.\n")
+		    call pargstr (colname)
+	    }
+	}
+end
+
+
+# td_p_data -- print the contents of the table
+# The data in the table are printed one row at a time.
+
+procedure td_p_data (tp, fd, cptr, range_string,
+	len_fmt, datatype, nelem,
+	pformat, pagewidth, nprint)
+
+pointer tp			# i: pointer to table descriptor
+int	fd			# i: fd for output file
+pointer cptr[nprint]		# i: array of pointers to column descriptors
+char	range_string[ARB]	# i: string which gives ranges of row numbers
+int	datatype[nprint]	# i: array of flags:  true if column is a string
+int	nelem[ARB]		# i: array length of each column
+int	len_fmt[nprint]		# i: array of lengths of print formats
+char	pformat[SZ_FMT,nprint]	# io: scratch space for print formats
+int	pagewidth		# i: page width
+int	nprint			# i: number of columns to print
+#--
+pointer sp
+pointer lbuf			# scratch space for line buffer
+double	dbuf			# buffer for double-precision value
+real	rbuf			# buffer for single-precision value
+int	ibuf			# buffer for integer value
+short	sbuf			# buffer for short value
+int	nrows			# number of rows in the table
+int	rownum, k		# loop indices for row, column
+int	j			# loop index for array element
+int	line_len		# current line length
+int	ranges[3,MAX_RANGES]	# ranges of row numbers
+int	nvalues			# returned by decode_ranges and ignored
+int	stat			# returned by get_next_number
+bool	done			# flag for terminating loop
+int	decode_ranges(), get_next_number()
+int	tbpsta(), tbagtr(), tbagtd(), tbagti(), tbagts(), tbagtt()
+string	MISSING "error reading data from table"
+
+begin
+	nrows = tbpsta (tp, TBL_NROWS)
+
+	if (decode_ranges (range_string, ranges, MAX_RANGES, nvalues) != 0) {
+	    call eprintf ("bad range of row numbers\n")
+	    return
+	}
+
+	call smark (sp)
+	call salloc (lbuf, SZ_LBUF, TY_CHAR)
+
+	# This section gets the print format for each column.  The
+	# format is just "%Ns" or "%-Ns".
+	do k = 1, nprint {
+	    pformat[1,k] = '%'
+	    if (datatype[k] < 0 || datatype[k] == TY_BOOL) {
+		call sprintf (pformat[2,k], SZ_FMT-1, "-%ds")	# left justify
+		    call pargi (len_fmt[k])
+	    } else {
+		call sprintf (pformat[2,k], SZ_FMT-1, "%ds")
+		    call pargi (len_fmt[k])
+	    }
+	}
+
+	# This section prints the data.
+	rownum = 0				# initialize get_next_number
+	line_len = 0
+	done = false
+	while ( !done ) {
+
+	    stat = get_next_number (ranges, rownum)
+	    if ((stat == EOF) || (rownum > nrows)) {
+		done = true
+
+	    } else {
+
+		# Print values in current row.  The loop on k is for each
+		# column that is to be printed.
+		do k = 1, nprint {
+
+		    # If the current column contains arrays, print each
+		    # element, and start at the beginning of the line.
+		    if (nelem[k] > 1 && line_len > 0) {
+			call fprintf (fd, "\n")
+			line_len = 0		# reset after newline
+		    }
+		    do j = 1, nelem[k] {
+
+			# If we have previously printed something on the
+			# current line, print either a space or newline,
+			# depending on how close we are to the end of the line.
+			if (line_len > 1) {
+			    if (pagewidth > 0 &&
+					line_len + len_fmt[k] >= pagewidth) {
+				# need to start a new line
+				call fprintf (fd, "\n")
+				line_len = 0
+			    } else {
+				# continue on current line
+				call fprintf (fd, " ")
+				line_len = line_len + 1
+			    }
+			}
+
+			if (datatype[k] == TY_REAL) {
+			    if (tbagtr (tp, cptr[k], rownum, rbuf, j, 1) < 1)
+				call error (1, MISSING)
+			    call sprintf (Memc[lbuf], SZ_LBUF, FMT_REAL)
+				call pargr (rbuf)
+			} else if (datatype[k] == TY_DOUBLE) {
+			    if (tbagtd (tp, cptr[k], rownum, dbuf, j, 1) < 1)
+				call error (1, MISSING)
+			    call sprintf (Memc[lbuf], SZ_LBUF, FMT_DBL)
+				call pargd (dbuf)
+			} else if (datatype[k] == TY_INT) {
+			    if (tbagti (tp, cptr[k], rownum, ibuf, j, 1) < 1)
+				call error (1, MISSING)
+			    call sprintf (Memc[lbuf], SZ_LBUF, FMT_INT)
+				call pargi (ibuf)
+			} else if (datatype[k] == TY_SHORT) {
+			    if (tbagts (tp, cptr[k], rownum, sbuf, j, 1) < 1)
+				call error (1, MISSING)
+			    call sprintf (Memc[lbuf], SZ_LBUF, FMT_SHORT)
+				call pargs (sbuf)
+			} else {
+			    if (tbagtt (tp, cptr[k], rownum,
+					Memc[lbuf], SZ_LBUF, j, 1) < 1)
+				call error (1, MISSING)
+			}
+			# If the value is a string, enclose in quotes if
+			# there are embedded blanks (ignore trailing blanks).
+			if (datatype[k] < 0)
+			    call inquotes (Memc[lbuf], Memc[lbuf], SZ_LINE, NO)
+			call fprintf (fd, pformat[1,k])
+			    call pargstr (Memc[lbuf])
+
+			# Add width of current column.
+			line_len = line_len + len_fmt[k]
+		    }
+		}
+		call fprintf (fd, "\n")		# end of current row
+		line_len = 0
+	    }
+	}
+	call sfree (sp)
+end