1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
include <syserr.h>
include "qpoe.h"
# QP_WRITE -- Write to a range of elements in a parameter. Works for any
# parameter, including scalar parameters and both static and variable
# length array valued parameters. Automatic datatype conversion is
# performed for the primitive types.
procedure qp_write (qp, param, buf, nelem, first, datatype)
pointer qp #I QPOE descriptor
char param[ARB] #I parameter name
char buf[ARB] #I user data buffer containing data
int nelem #I number of data elements to write
int first #I first data element to write to
char datatype[ARB] #I datatype of input data
pointer sp, fm, sym, tbuf, isym, osym
int fd, sz_itype, sz_otype, last, otype, itype
errchk qp_bind, qp_gpsym, fm_getfd, seek, syserrs
int fm_getfd(), qp_sizeof(), qp_dtype()
pointer qp_gpsym()
begin
if (nelem <= 0)
return
if (QP_ACTIVE(qp) == NO)
call qp_bind (qp)
itype = qp_dtype (qp, datatype, isym)
fm = QP_FM(qp)
# Lookup the symbol in the symbol table.
sym = qp_gpsym (qp, param)
if (sym == NULL)
call syserrs (SYS_QPUKNPAR, param)
else {
otype = S_DTYPE(sym)
osym = sym
}
sz_itype = qp_sizeof (qp, itype, isym, INSTANCEOF)
sz_otype = qp_sizeof (qp, otype, osym, IMMEDIATE)
last = first + nelem - 1
# Check that the write is inbounds.
if (first <= 0 || (S_MAXELEM(sym) > 0 && last > S_MAXELEM(sym)))
call syserrs (SYS_QPINDXOOR, param)
# Verify that any type conversion is legal.
if (otype != itype)
if (min(otype,itype) < TY_CHAR || max(otype,itype) > TY_DOUBLE)
call syserrs (SYS_QPBADCONV, param)
# Open the lfile and update the data segment.
fd = fm_getfd (fm, S_LFILE(sym), READ_WRITE, 0)
call seek (fd, S_OFFSET(sym) + (first - 1) * sz_otype)
# Output the data.
if (otype != itype) {
call smark (sp)
call salloc (tbuf, nelem * sz_otype, TY_CHAR)
call acht (buf, Memc[tbuf], nelem, itype, otype)
call write (fd, Memc[tbuf], nelem * sz_otype)
call sfree (sp)
} else
call write (fd, buf, nelem * sz_otype)
# Update the array size if it got bigger.
if (last > S_NELEM(sym)) {
S_NELEM(sym) = last
QP_MODIFIED(qp) = YES
}
call fm_retfd (fm, S_LFILE(sym))
end
|
