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
|
include <config.h>
include <error.h>
include <evexpr.h>
include <xwhen.h>
include "reloperr.h"
# TBL_EVAL -- Evaluate an arbitrary expression over table columns
#
# This procedure receives as input a table descriptor, an index array, and
# a character string containing an algebraic expression. The terms in the
# expression are column names. The expression is evaluated for each row in
# the index array using the values from the indicated columns and the results
# stored in the output array (aryptr). The array pointed to by nulptr
# contains null flags. A null flag is set to true if any of the table elements
# in the expression is null or an arithmetic error ocurs during the
# evaluation of the expression. Otherwise the null flag is set to false.
# The type of the output array is determined by the type of the expression
# unless all the elements are null, in which case the type input by the
# calling routine is used. The two arrays pointed to by aryptr and nulptr
# must be deallocated by the calling routine.
#
# B.Simon 29-Sept-87 First Code
# B.Simon 16-Dec-87 Changed to handle table subsets
# B.Simon 13-Apr-88 tbl_term, tbl_func moved to separate file
procedure tbl_eval (tp, nindex, index, expr, dtype, aryptr, nulptr)
pointer tp # i: Table descriptor
int nindex # i: Number of elements in index array
int index[ARB] # i: Array of row indices
char expr[ARB] # i: Expression to be evaluated
int dtype # io: Type of output array
pointer aryptr # o: Array of output values
pointer nulptr # o: Array of null flags
#--
include "tblterm.com"
int iary, status, junk
int old_handler, tbl_term_adr, tbl_func_adr
pointer op
string badtype "Character expressions not allowed"
int locpr(), errcode()
pointer evexpr()
extern tbl_handler(), tbl_term(), tbl_func()
begin
# Initialize output variables
aryptr = NULL
call malloc (nulptr, nindex, TY_BOOL)
# Set up error handler to catch arithmetic errors
call xwhen (X_ARITH, locpr(tbl_handler), old_handler)
table = tp
nterm = 0
constant = true
tbl_term_adr = locpr (tbl_term)
tbl_func_adr = locpr (tbl_func)
# Loop over all rows of the table
do iary = 1, nindex {
irow = index[iary]
iterm = 0
# Execution will resume here when an arithmetic error occurs
call zsvjmp (jumpbuf, status)
if (status != OK) {
Memb[nulptr+iary-1] = true
# Special case to speed up the evaluation of constant expressions
} else if (constant && (iary != 1)) {
Memb[nulptr+iary-1] = false
switch (dtype) {
case TY_BOOL:
Memb[aryptr+iary-1] = Memb[aryptr]
case TY_INT:
Memi[aryptr+iary-1] = Memi[aryptr]
case TY_REAL:
Memr[aryptr+iary-1] = Memr[aryptr]
}
# Evaluate the expression using the values in the current row
} else {
iferr {
op = evexpr (expr, tbl_term_adr, tbl_func_adr)
} then {
# Catch the error sent when a table element is null
if (errcode() == PUTNULL)
Memb[nulptr+iary-1] = true
else {
call mfree (nulptr, TY_BOOL)
call xwhen (X_ARITH, old_handler, junk)
call erract (EA_ERROR)
}
# Usual case
} else {
Memb[nulptr+iary-1] = false
# Determine array type from type of expression
if (aryptr == NULL) {
if (O_TYPE(op) == TY_CHAR) {
call mfree (nulptr, TY_BOOL)
call xwhen (X_ARITH, old_handler, junk)
call error (SYNTAX, badtype)
}
dtype = O_TYPE(op)
call calloc (aryptr, nindex, dtype)
}
# Assign the result of the expression to the output
# array
switch (dtype) {
case TY_BOOL:
Memb[aryptr+iary-1] = O_VALB(op)
case TY_INT:
Memi[aryptr+iary-1] = O_VALI(op)
case TY_REAL:
Memr[aryptr+iary-1] = O_VALR(op)
}
call mfree (op, TY_STRUCT) # Bug fix (BPS 04.20.93)
}
}
}
# Allocate array when all results are null
if (aryptr == NULL) {
if (dtype == TY_CHAR) {
call mfree (nulptr, TY_BOOL)
call xwhen (X_ARITH, old_handler, junk)
call error (SYNTAX, badtype)
}
call calloc (aryptr, nindex, dtype)
}
# Restore old error handler
call xwhen (X_ARITH, old_handler, junk)
end
|
