From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001
From: Joseph Hunkeler <jhunkeler@gmail.com>
Date: Wed, 8 Jul 2015 20:46:52 -0400
Subject: Initial commit

---
 sys/qpoe/qpppar.x | 136 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 136 insertions(+)
 create mode 100644 sys/qpoe/qpppar.x

(limited to 'sys/qpoe/qpppar.x')

diff --git a/sys/qpoe/qpppar.x b/sys/qpoe/qpppar.x
new file mode 100644
index 00000000..17d9496d
--- /dev/null
+++ b/sys/qpoe/qpppar.x
@@ -0,0 +1,136 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	"qpoe.h"
+
+# QP_PUTPARAM -- Lookup the named parameter in the symbol table and return
+# a pointer to a buffer into which the scalar parameter value is to be
+# placed.  A subsequent call to QPOE_FLUSHPAR updates the parameter value
+# in the datafile.  A NULL pointer is returned if the parameter exists but
+# does not currently have a value.  The parameter datatype code is returned
+# as the function value.
+
+int procedure qp_putparam (qp, param, o_pp)
+
+pointer	qp			#I QPOE descriptor
+char	param[ARB]		#I parameter name
+pointer	o_pp			#O pointer to parameter value
+
+bool	first_time
+pointer	sp, key, fm, op
+int	loc_pval, loc_Mem, ip, ch, sz_elem
+data	first_time /true/
+
+int	elem
+pointer	pp, sym
+bool	put_value
+double	pval[LEN_PVAL+1]
+common	/qppval/ pval, sym, elem, pp, put_value
+
+pointer	qp_gpsym()
+int	ctoi(), qp_sizeof()
+errchk	qp_bind, syserrs
+
+begin
+	call smark (sp)
+	call salloc (key, SZ_FNAME, TY_CHAR)
+
+	if (QP_ACTIVE(qp) == NO)
+	    call qp_bind (qp)
+
+	fm = QP_FM(qp)
+
+        # Compute pointer (Memc index) to the static pval buffer.
+	# Make sure that the computed pointer is double aligned.
+
+	if (first_time) {
+	    call zlocva (pval, loc_pval)
+	    call zlocva (Memc, loc_Mem)
+	    pp = (loc_pval+SZ_DOUBLE - loc_Mem) / SZ_DOUBLE * SZ_DOUBLE + 1
+	    put_value = false
+	    first_time = false
+	} else if (put_value)
+	    call qp_flushpar (qp)
+
+	# Extract the primary parameter name, minus any whitespace and
+	# subscript (e.g., "param[elem]").
+
+	op = key
+	do ip = 1, SZ_FNAME {
+	    ch = param[ip]
+	    if (IS_WHITE(ch))
+		next
+	    else if (ch == '[')
+		break
+	    Memc[op] = ch
+	    op = op + 1
+	}
+	Memc[op] = EOS
+
+	# Determine the array element (default [1]).
+	elem = 1
+	if (param[ip] == '[') {
+	    ip = ip + 1
+	    if (ctoi (param, ip, elem) <= 0)
+		elem = 1
+	}
+
+	# Lookup the symbol in the symbol table.
+	sym = qp_gpsym (qp, Memc[key])
+	if (sym == NULL)
+	    call syserrs (SYS_QPUKNPAR, param)
+
+	# Check to make sure storage for the parameter value exists, and
+	# set the parameter buffer pointer for the indicated datatype.
+
+	sz_elem = qp_sizeof (qp, S_DTYPE(sym), sym, INSTANCEOF)
+	if (sz_elem > LEN_PVAL * SZ_DOUBLE)
+	    call syserrs (SYS_QPPVALOVF, QP_DFNAME(qp))
+
+	if (elem < 1 || elem > S_MAXELEM(sym))
+	    o_pp = NULL
+	else if (S_DTYPE(sym) == TY_USER)
+	    o_pp = (pp - 1) / SZ_STRUCT + 1
+	else
+	    o_pp = (pp - 1) / sz_elem + 1
+
+	# Set a flag to flush the value after the user has entered it.
+	put_value = true
+
+	call sfree (sp)
+	return (S_DTYPE(sym))
+end
+
+
+# QP_FLUSHPAR -- Update the saved parameter value in the indicated lfile.
+# Repeated calls are harmless.
+
+procedure qp_flushpar (qp)
+
+pointer	qp			#I QPOE descriptor
+
+int	sz_elem, fd
+int	qp_sizeof(), fm_getfd()
+errchk	fm_getfd, seek, write
+
+int	elem
+pointer	pp, sym
+bool	put_value
+double	pval[LEN_PVAL+1]
+common	/qppval/ pval, sym, elem, pp, put_value
+
+begin
+	if (put_value) {
+	    sz_elem = qp_sizeof (qp, S_DTYPE(sym), S_DSYM(sym), INSTANCEOF)
+	    fd = fm_getfd (QP_FM(qp), S_LFILE(sym), READ_WRITE, 0)
+
+	    call seek (fd, S_OFFSET(sym) + (elem - 1) * sz_elem)
+	    call write (fd, Memc[pp], sz_elem)
+	    S_NELEM(sym) = max (S_NELEM(sym), elem)
+	    QP_MODIFIED(qp) = YES
+
+	    call fm_retfd (QP_FM(qp), S_LFILE(sym))
+	    put_value = false
+	}
+end
-- 
cgit