Repatch (from linux) of OSX IRAF

1 files changed, 173 insertions, 0 deletions

diff --git a/sys/qpoe/qpaddf.x b/sys/qpoe/qpaddf.x
new file mode 100644
index 00000000..e72c2cc1
--- /dev/null
+++ b/sys/qpoe/qpaddf.x
@@ -0,0 +1,173 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<error.h>
+include	<qpset.h>
+include	"qpoe.h"
+
+# QP_ADDF -- Add a new field (header parameter) to the datafile.  It is an
+# error if the parameter redefines an existing symbol.  For variable array
+# parameters the initial size is zero, and a new lfile is allocated for the
+# parameter value.  For static parameters storage is initialized to all zeros.
+
+procedure qp_addf (qp, param, datatype, maxelem, comment, flags)
+
+pointer	qp			#I QPOE descriptor
+char	param[ARB]		#I parameter name
+char	datatype[ARB]		#I parameter data type
+int	maxelem			#I allocated length of parameter
+char	comment[ARB]		#I comment describing parameter
+int	flags			#I parameter flags
+
+bool	newtype
+pointer	sp, text, st, fm, sym, pval, dsym, dd
+int	fd, sz_elem, type, nchars, dtype, nfields, i
+
+long	note()
+pointer	qp_gpsym(), stenter(), strefstab()
+int	stpstr(), qp_dtype(), qp_parsefl(), gstrcpy
+int	fm_nextlfile(), fm_getfd(), qp_elementsize(), fm_fopen()
+errchk	qp_bind, qp_gpsym, stenter, stpstr, fm_nextlfile, fm_fopen
+errchk	fm_getfd, note, write, syserrs
+define	fixed_ 91
+
+begin
+	call smark (sp)
+	call salloc (text, SZ_TEXTBUF, TY_CHAR)
+
+	if (QP_ACTIVE(qp) == NO)
+	    call qp_bind (qp)
+
+	st = QP_ST(qp)
+	fm = QP_FM(qp)
+
+	# Resolve any macro references in the 'datatype' text.
+	# (Disabled - not sure this is a good idea here).
+
+	# nchars = qp_expandtext (qp, datatype, Memc[text], SZ_TEXTBUF)
+	nchars = gstrcpy (datatype, Memc[text], SZ_TEXTBUF)
+
+	if (QP_DEBUG(qp) > 1) {
+	    call eprintf ("qp_addf: `%s' typ=`%s' nel=%d com=`%s' flg=%oB\n")
+		call pargstr (param)
+		call pargstr (Memc[text])
+		call pargi (maxelem)
+		call pargstr (comment)
+		call pargi (flags)
+	}
+
+	# Check for a redefinition.
+	sym = qp_gpsym (qp, param)
+	if (sym != NULL)
+	    call syserrs (SYS_QPREDEF, param)
+
+	# Add the symbol.
+	sym = stenter (st, param, LEN_SYMBOL)
+
+	# Determine symbol type.
+	dtype = qp_dtype (qp, Memc[text], dsym)
+	newtype = (dtype == TY_USER && dsym == NULL)
+	sz_elem = qp_elementsize (qp, Memc[text], INSTANCEOF)
+
+	S_DTYPE(sym) = dtype
+	S_SZELEM(sym) = 0
+	if (dsym != NULL)
+	    S_DSYM(sym) = dsym - strefstab(st,0)
+	else
+	    S_DSYM(sym) = 0
+
+	# If defining a new user datatype (domain), SZELEM is the size of
+	# a structure element in chars, and MAXELEM is the length of the
+	# field list string, which becomes the value of the domain definition
+	# parameter.
+
+	if (newtype) {
+	    S_MAXELEM(sym) = nchars
+	    call salloc (dd, LEN_DDDES, TY_STRUCT)
+	    iferr (nfields = qp_parsefl (qp, Memc[text], dd))
+		call erract (EA_WARN)
+	    else
+		S_SZELEM(sym) = DD_STRUCTLEN(dd) * SZ_STRUCT
+	} else
+	    S_MAXELEM(sym) = maxelem
+
+	# If no flags are specified, set SF_INHERIT for fixed length params.
+	if (flags == 0 && S_MAXELEM(sym) > 0)
+	    S_FLAGS(sym) = SF_INHERIT
+	else if (flags == QPF_NONE)
+	    S_FLAGS(sym) = 0
+	else
+	    S_FLAGS(sym) = flags
+
+	# Comments are stored in the symbol table and cannot be modified.
+	if (comment[1] != EOS)
+	    S_COMMENT(sym) = stpstr (st, comment, 0)
+	else
+	    S_COMMENT(sym) = NULL
+
+	# Initialize data storage for the parameter.
+	if (S_MAXELEM(sym) == 0) {
+	    # A variable length parameter; store in it's own lfile.  The
+	    # initial length is zero, hence initialization is not needed.
+
+	    S_NELEM(sym) = 0
+	    S_OFFSET(sym) = 1
+
+	    # If we run out of lfiles, try to make do by allocating a fixed
+	    # amount of static storage.
+
+	    iferr (S_LFILE(sym) = fm_nextlfile(fm)) {
+		S_MAXELEM(sym) = (QP_FMPAGESIZE(qp) + sz_elem-1) / sz_elem
+		call erract (EA_WARN)
+		goto fixed_
+	    }
+
+	    if (dtype == TY_CHAR)
+		type = TEXT_FILE
+	    else
+		type = BINARY_FILE
+
+	    fd = fm_fopen (fm, S_LFILE(sym), NEW_FILE, type)
+	    call close (fd)
+
+	} else {
+	    # A fixed length parameter; allocate and initialize storage in
+	    # LF_STATICPARS.
+fixed_
+	    fd = fm_getfd (fm, LF_STATICPARS, APPEND, 0)
+
+	    S_NELEM(sym) = 0
+	    S_OFFSET(sym) = note (fd)
+	    S_LFILE(sym) = LF_STATICPARS
+	    nchars = S_MAXELEM(sym) * sz_elem
+
+	    # The param value is the field list (datatype parameter) for a
+	    # domain definition; otherwise we do not have a value yet, so we
+	    # merely allocate the storage and initialize to zero.
+
+	    if (newtype) {
+		call write (fd, Memc[text], nchars)
+		S_NELEM(sym) = S_MAXELEM(sym)
+	    } else {
+		call salloc (pval, nchars, TY_CHAR)
+		call aclrc (Memc[pval], nchars)
+		call write (fd, Memc[pval], nchars)
+	    }
+
+	    call fm_retfd (fm, S_LFILE(sym))
+	}
+
+	if (QP_DEBUG(qp) > 2) {
+	    # Dump symbol.
+	    call eprintf ("%s: FLG=%oB TYP=%d DSY=%xX NEL=%d ")
+		call pargstr (param)
+		do i = 1, 4
+		    call pargi (Memi[sym+i-1])
+	    call eprintf ("MEL=%d SZE=%d COM=%xX LFN=%d OFF=%d\n")
+		do i = 5, 9
+		    call pargi (Memi[sym+i-1])
+	}
+
+	QP_MODIFIED(qp) = YES
+	call sfree (sp)
+end