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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
include <tbset.h>
include "tbtables.h"
include "tblerr.h"
# tbrcsc -- copy selected columns
# This procedure copies specific columns in a row from one table to another
# or to another row within the same table. Elements are copied one at a
# time, and the pointers to descriptors of input and output columns are
# passed in the calling sequence, so the restrictions on similarity of
# input and output tables in tbrcpy do not apply to this routine.
#
# For each column to be copied from the input row, the element is read
# using a "get element" routine (tbegt[]), and then the element is put
# in the output row using a "put element" routine (tbept[]).
#
# Phil Hodge, 1-Oct-1987 Subroutine created.
# Phil Hodge, 30-Jan-1992 Use tbegt? instead of tbegp?.
# Phil Hodge, 1-Apr-1993 Include short datatype.
# Phil Hodge, 23-Aug-1994 Also copy array entries.
# Phil Hodge, 30-Nov-1994 When copying arrays of char, copy one at a time.
# Phil Hodge, 3-Apr-1995 Set TB_MODIFIED to true.
# Phil Hodge, 11-Dec-1995 Allocate cbuf only if needed.
# Phil Hodge, 2-Jun-1997 Replace INDEFD with TBL_INDEFD.
# Phil Hodge, 30-Sep-1997 Delete check on irow being beyond end of file,
# because it's checked in tbegt[] or tbagt[], and
# to allow for a row selector.
# Phil Hodge, 18-Jan-1999 Get & put boolean as short, to preserve indef values.
# Phil Hodge, 5-Aug-1999 Use COL_NELEM instead of tbalen to get array length.
procedure tbrcsc (itp, otp, icp, ocp, irow, orow, ncols)
pointer itp # i: pointer to descriptor of input table
pointer otp # i: pointer to descriptor of output table
pointer icp[ncols] # i: array of pointers for input columns
pointer ocp[ncols] # i: array of pointers for output columns
int irow # i: row number in input table
int orow # i: row number in output table
int ncols # i: number of columns to be copied
#--
pointer sp
int k # loop index for column number
int i # loop index for array element
int nget, nput # number of elements in input & output arrays
int dtype # data type of column
# buffers for copying elements of various data types
pointer gbuf # pointer to array of any data type
pointer cbuf # for copying character elements
double dbuf
real rbuf
int ibuf
short sbuf
int tbagtd(), tbagtr(), tbagti(), tbagts(), tbagtt()
errchk tbegtd, tbegtr, tbegti, tbegts, tbegtt,
tbeptd, tbeptr, tbepti, tbepts, tbeptt,
tbagtd, tbagtr, tbagti, tbagts, tbagtt,
tbaptd, tbaptr, tbapti, tbapts, tbaptt
string BAD_DATATYPE "tbrcsc: bad data type; table or memory corrupted?"
string ERR_READ_ARRAY "tbrcsc: can't read array entry"
begin
if (TB_READONLY(otp))
call error (ER_TBREADONLY, "can't write to table; it's readonly")
call smark (sp)
cbuf = NULL # allocated below
do k = 1, ncols {
dtype = COL_DTYPE(icp[k])
nget = COL_NELEM(icp[k])
if (nget == 1) {
# Copy a single element.
switch (dtype) {
case TBL_TY_REAL:
call tbegtr (itp, icp[k], irow, rbuf)
call tbeptr (otp, ocp[k], orow, rbuf)
case TBL_TY_DOUBLE:
call tbegtd (itp, icp[k], irow, dbuf)
call tbeptd (otp, ocp[k], orow, dbuf)
case TBL_TY_INT:
call tbegti (itp, icp[k], irow, ibuf)
call tbepti (otp, ocp[k], orow, ibuf)
case TBL_TY_SHORT,TBL_TY_BOOL:
call tbegts (itp, icp[k], irow, sbuf)
call tbepts (otp, ocp[k], orow, sbuf)
default:
if (dtype < 0 || dtype == TBL_TY_CHAR) {
if (cbuf == NULL)
call salloc (cbuf, SZ_LINE, TY_CHAR)
call tbegtt (itp, icp[k], irow, Memc[cbuf], SZ_LINE)
call tbeptt (otp, ocp[k], orow, Memc[cbuf])
} else {
call error (ER_TBCOLBADTYP, BAD_DATATYPE)
}
}
} else { # Copy an array.
if (TB_TYPE(otp) == TBL_TYPE_TEXT ||
TB_TYPE(otp) == TBL_TYPE_S_COL)
call error (1,
"Output table type does not support columns of arrays.")
nput = COL_NELEM(ocp[k])
if (nget > nput)
call error (1,
"tbrcsc: output array is shorter than input array")
switch (dtype) {
case TBL_TY_REAL:
call malloc (gbuf, max (nget, nput), TY_REAL)
do i = nget+1, nput
Memr[gbuf+i-1] = INDEFR
if (tbagtr (itp, icp[k], irow, Memr[gbuf], 1, nget) < nget)
call error (1, ERR_READ_ARRAY)
call tbaptr (otp, ocp[k], orow, Memr[gbuf], 1, nput)
call mfree (gbuf, TY_REAL)
case TBL_TY_DOUBLE:
call malloc (gbuf, max (nget, nput), TY_DOUBLE)
do i = nget+1, nput
Memd[gbuf+i-1] = TBL_INDEFD
if (tbagtd (itp, icp[k], irow, Memd[gbuf], 1, nget) < nget)
call error (1, ERR_READ_ARRAY)
call tbaptd (otp, ocp[k], orow, Memd[gbuf], 1, nput)
call mfree (gbuf, TY_DOUBLE)
case TBL_TY_INT:
call malloc (gbuf, max (nget, nput), TY_INT)
do i = nget+1, nput
Memi[gbuf+i-1] = INDEFI
if (tbagti (itp, icp[k], irow, Memi[gbuf], 1, nget) < nget)
call error (1, ERR_READ_ARRAY)
call tbapti (otp, ocp[k], orow, Memi[gbuf], 1, nput)
call mfree (gbuf, TY_INT)
case TBL_TY_SHORT,TBL_TY_BOOL:
call malloc (gbuf, max (nget, nput), TY_SHORT)
do i = nget+1, nput
Mems[gbuf+i-1] = INDEFS
if (tbagts (itp, icp[k], irow, Mems[gbuf], 1, nget) < nget)
call error (1, ERR_READ_ARRAY)
call tbapts (otp, ocp[k], orow, Mems[gbuf], 1, nput)
call mfree (gbuf, TY_SHORT)
default:
if (dtype < 0) {
if (cbuf == NULL)
call salloc (cbuf, SZ_LINE, TY_CHAR)
do i = 1, nget {
if (tbagtt (itp, icp[k], irow,
Memc[cbuf], SZ_LINE, i, 1) < 1)
call error (1, ERR_READ_ARRAY)
call tbaptt (otp, ocp[k], orow,
Memc[cbuf], SZ_LINE, i, 1)
}
do i = nget+1, nput
call tbaptt (otp, ocp[k], orow, "", SZ_LINE, i, 1)
} else {
call error (ER_TBCOLBADTYP, BAD_DATATYPE)
}
}
}
}
TB_MODIFIED(otp) = true
call sfree (sp)
end
|
