Repatch (from linux) of OSX IRAF

1 files changed, 283 insertions, 0 deletions

diff --git a/sys/fmtio/parg.x b/sys/fmtio/parg.x
new file mode 100644
index 00000000..d65bd3ce
--- /dev/null
+++ b/sys/fmtio/parg.x
@@ -0,0 +1,283 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+include	<ctype.h>
+include	<printf.h>
+
+.help parg
+.nf ___________________________________________________________________________
+PARG[CSILRDX] -- Pass a numeric argument to printf.  Get the format spec and
+format the number on the output file.  Try to provide reasonable automatic
+type conversions.  Avoid any type coercion of indefinites.
+We try to make the operand fit in the specified field width, decreasing the
+precision if necessary, but if it cannot be made to fit we increase the field
+width until it does.  We feel that it is more important to output a readable
+number than to keep the output columns justified.
+.endhelp ______________________________________________________________________
+
+
+# PARGD -- Pass a double.
+
+procedure pargd (dval)
+
+double	dval
+
+begin
+	call pargg (dval, TY_DOUBLE)
+end
+
+
+# PARGC -- Pass a char.
+
+procedure pargc (cval)
+
+char	cval
+double	dval
+
+begin
+	dval = cval
+	call pargg (dval, TY_CHAR)
+end
+
+
+# PARGS -- Pass a short.
+
+procedure pargs (sval)
+
+short	sval
+double	dval
+
+begin
+	dval = sval
+	if (IS_INDEFS (sval))
+	    dval = INDEFD
+
+	call pargg (dval, TY_SHORT)
+end
+
+
+# PARGI -- Pass an int.
+
+procedure pargi (ival)
+
+int	ival
+double	dval
+
+begin
+	dval = ival
+	if (IS_INDEFI (ival))
+	    dval = INDEFD
+
+	call pargg (dval, TY_INT)
+end
+
+
+# PARGL -- Pass a long.
+
+procedure pargl (lval)
+
+long	lval
+double	dval
+
+begin
+	dval = lval
+	if (IS_INDEFL (lval))
+	    dval = INDEFD
+
+	call pargg (dval, TY_LONG)
+end
+
+
+# PARGR -- Pass a real.
+
+procedure pargr (rval)
+
+real	rval
+double	dval
+
+begin
+	dval = rval
+	if (IS_INDEFR (rval))
+	    dval = INDEFD
+
+	call pargg (dval, TY_REAL)
+end
+
+
+# PARGG -- Generic put argument.  Encode a value of a specific datatype passed
+# as a double precision value.
+
+procedure pargg (value, dtype)
+
+double	value
+int	dtype
+
+char	ch
+long	lnum
+complex	xnum
+int	n, precision, i, junk, ival, nchars, nbits, fmt
+int	ctocc(), gltoc(), dtoc(), xtoc(), fprfmt()
+errchk	putci, fmtstr, fpradv
+include "fmt.com"
+
+begin
+	# Read format.  If format spec contains "*" fields, VALUE is a part of
+	# the format, rather than a true operand.  In that case we return,
+	# and the next call again checks to see if the format spec is complete.
+	# Note that if VALUE is not part of the format but is instead a floating
+	# point value to be printed, it may have an exponent large enough to
+	# cause integer overflow in an INT(VALUE) operation, hence we must
+	# guard against this.  This is easy since only PARGI will be used to
+	# pass format information.
+
+	if (dtype == TY_REAL || dtype == TY_DOUBLE)
+	    ival = 0
+	else if (IS_INDEFD (value))
+	    ival = INDEFI
+	else
+	    ival = nint (value)
+
+	if (fprfmt (ival) == NOT_DONE_YET)
+	    return
+
+ 	if (format_char == USE_DEFAULT || format_char == FMT_STRING)
+	    switch (dtype) {
+	    case TY_CHAR:
+		format_char = FMT_CHAR
+	    case TY_INT:
+		format_char = FMT_DECIMAL
+	    default:
+		format_char = FMT_GENERAL
+	    }
+
+	if (dtype == TY_DOUBLE)				# supply def. precision
+	    precision = NDIGITS_DP
+	else
+	    precision = NDIGITS_RP
+
+	if (width == USE_DEFAULT)			# make as big as needed
+	    width = SZ_OBUF
+
+	# Convert number from binary into character form in OBUF, applying
+	# defaults as needed.
+
+	# Ignore case in testing format type.
+	fmt = format_char
+	if (IS_UPPER (fmt))
+	    fmt = TO_LOWER(fmt)
+
+	switch (fmt) {
+	case FMT_BOOL:
+	    if (IS_INDEFD (value))
+		call strcpy ("INDEF", obuf, SZ_OBUF)
+	    else if (int (value) == 0)
+		call strcpy ("NO", obuf, SZ_OBUF)
+	    else
+		call strcpy ("YES", obuf, SZ_OBUF)
+
+	case FMT_CHAR:
+	    if (IS_INDEFD (value))
+		call strcpy ("INDEF", obuf, SZ_OBUF)
+	    else {
+		ch = nint (value)
+		junk = ctocc (ch, obuf, SZ_OBUF)
+	    }
+
+	case FMT_DECIMAL, FMT_OCTAL, FMT_HEX, FMT_RADIX, FMT_UNSIGNED:
+	    switch (fmt) {
+	    case FMT_DECIMAL:
+		radix = DECIMAL				# signed decimal
+	    case FMT_OCTAL:
+		radix = -OCTAL				# unsigned octal
+	    case FMT_HEX:
+		radix = -HEX				# unsigned hex
+	    case FMT_UNSIGNED:
+		radix = -DECIMAL			# unsigned decimal
+	    default:
+		radix = -abs(radix)			# unsigned radix
+	    }
+
+	    if (IS_INDEFD (value)) {
+		lnum = INDEFL
+		nchars = gltoc (lnum, obuf, SZ_OBUF, radix)
+
+	    } else {
+		lnum = long (value)
+		nchars = gltoc (lnum, obuf, SZ_OBUF, radix)
+
+		# Limit sign extension if negative number, hex or octal.
+		if (lnum < 0 && (dtype == TY_SHORT || dtype == TY_CHAR)) {
+		    nbits = SZB_CHAR * NBITS_BYTE
+		    if (dtype == TY_SHORT)
+			nbits = nbits * SZ_SHORT
+		    if (fmt == FMT_OCTAL) {
+			n = nchars - (nbits + 2) / 3
+			if (n > 0) {
+			    call strcpy (obuf[n+2], obuf[2], SZ_OBUF)
+			    obuf[1] = '1'
+			}
+		    } else if (fmt == FMT_HEX) {
+			n = nchars - (nbits + 3) / 4
+			if (n > 0)
+			    call strcpy (obuf[n+1], obuf[1], SZ_OBUF)
+		    }
+		}
+	    }
+
+	case FMT_EXPON, FMT_FIXED, FMT_GENERAL, FMT_HMS, FMT_MINSEC:
+	    if (decpl == USE_DEFAULT || decpl == 0)
+		switch (fmt) {
+		case FMT_EXPON, FMT_GENERAL:
+		    decpl = precision
+		case FMT_HMS, FMT_MINSEC:
+		    if (decpl == USE_DEFAULT)
+			decpl = 1
+		default:
+		    if (decpl == USE_DEFAULT)
+			decpl = precision
+		}
+	    repeat {
+		# Need the case sensitive format char here.
+		n = dtoc (value, obuf, SZ_OBUF, decpl, format_char, width+1)
+		decpl = decpl - 1
+	    } until (n <= width || decpl <= 0)
+
+	case FMT_TOCOLUMN:				# advance to column
+	    for (i=int(value);  col < i;  col=col+1)
+		call putci (fd, ' ')
+	    call fpradv()
+	    return
+
+	case FMT_WHITESPACE:				# output whitespace
+	    for (i=0;  i < int(value);  i=i+1)
+		call putci (fd, ' ')
+	    col = col + i
+	    call fpradv()
+	    return
+
+	case FMT_COMPLEX:
+	    if (decpl == USE_DEFAULT)			# set defaults
+		decpl = precision
+	    else
+		decpl = abs (decpl)
+
+	    if (IS_INDEFD (value))
+		xnum = INDEFX
+	    else
+		xnum = complex (value)
+
+	    # Convert, decrease precision until it fits in given field width.
+	    repeat {
+		n = xtoc (xnum, obuf, SZ_OBUF, decpl, 'e', SZ_OBUF)
+		decpl = decpl - 1
+	    } until (n <= width || decpl <= 0)
+	}
+	    
+	# Move the string in OBUF to the output file, left or right justifying
+	# as specified.  Advance to the next format spec (or finish up).
+
+	if (width == SZ_OBUF)				# free format?
+	    width = 0
+	call fmtstr (fd, obuf, col, fill_char, left_justify, SZ_OBUF, width)
+	call fpradv ()
+end