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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
.help pralloc
Parser Memory Allocation.
Entry points:
pr_alloc () Allocate parser tables.
pr_inalloc (ptr) Allocate input variable substructure.
pr_ftalloc (ptr) Allocate fitting parameter substructure.
pr_stalloc (ptr) Allocate set equation substructure.
pr_tralloc (ptr, npars) Allocate transf. equation substructure.
pr_free () Free parser tables.
.endhelp
include "../lib/parser.h"
include "../lib/prstruct.h"
# Number of expected symbols in the symbol table. The table is reallocated
# automatically by the SYMTAB procedures if this value is not enough.
define LEN_SYMTABLE 100
# PR_ALLOC -- Allocate space for symbol table and sequential tables
procedure pr_alloc ()
pointer stopen()
include "parser.com"
begin
# Open symbol table
symtable = stopen ("parser", 2 * LEN_SYMTABLE, LEN_SYMTABLE,
LEN_SYMTABLE * SZ_LINE)
# Allocate space for other tables
call mct_alloc (obstable, 10, 1, TY_INT)
call mct_alloc (cattable, 10, 1, TY_INT)
call mct_alloc (partable, 30, 1, TY_INT)
call mct_alloc (exttable, 10, 1, TY_INT)
call mct_alloc (trntable, 10, 1, TY_INT)
call mct_alloc (settable, 10, 1, TY_INT)
call mct_alloc (trcattable, 20, 2, TY_INT)
call mct_alloc (trobstable, 20, 2, TY_INT)
call mct_alloc (tfcattable, 20, 2, TY_INT)
call mct_alloc (tfobstable, 20, 2, TY_INT)
call mct_alloc (tpartable, 20, 1, TY_INT)
end
# PR_INALLOC -- Allocate space for input variable substructure.
procedure pr_inalloc (ptr)
pointer ptr # substructure pointer (output)
begin
# Allocate space
call malloc (ptr, LEN_PINP, TY_STRUCT)
# Initialize substructure
PINP_COL (ptr) = INDEFI
PINP_ERRCOL (ptr) = INDEFI
PINP_WTSCOL (ptr) = INDEFI
PINP_SPARE (ptr) = NO
end
# PR_FTALLOC -- Allocate space for fitting parameter substructure.
procedure pr_ftalloc (ptr)
pointer ptr # substructure pointer (output)
begin
# Allocate space
call malloc (ptr, LEN_PFIT, TY_STRUCT)
# Initialize substructure
PFIT_VALUE (ptr) = INDEFR
PFIT_DELTA (ptr) = INDEFR
end
# PR_STALLOC -- Allocate and initialize a set equation substructure.
# Initialization may not be necessary for all fields in the substructure,
# but it's safer to do it anyway.
procedure pr_stalloc (ptr)
pointer ptr # substructure pointer (output)
begin
# Allocate space
call malloc (ptr, LEN_PSEQ, TY_STRUCT)
# Initialize string offsets
PSEQ_EQ (ptr) = INDEFI
PSEQ_ERROR (ptr) = INDEFI
PSEQ_ERRMIN (ptr) = INDEFI
PSEQ_ERRMAX (ptr) = INDEFI
PSEQ_WEIGHT (ptr) = INDEFI
PSEQ_WTSMIN (ptr) = INDEFI
PSEQ_WTSMAX (ptr) = INDEFI
# Initialize code pointers
PSEQ_RPNEQ (ptr) = NULL
PSEQ_RPNERROR (ptr) = NULL
PSEQ_RPNERRMIN (ptr) = NULL
PSEQ_RPNERRMAX (ptr) = NULL
PSEQ_RPNWEIGHT (ptr) = NULL
PSEQ_RPNWTSMIN (ptr) = NULL
PSEQ_RPNWTSMAX (ptr) = NULL
end
# PR_TRALLOC -- Allocate space and initialize a transformation equation
# substructure. Initialization may not be necessary for all fields in the
# substructure, but it's safer to do it anyway.
procedure pr_tralloc (ptr, nrcat, nrobs, nfcat, nfobs, npars)
pointer ptr # substructure pointer (output)
int nrcat # number of catalog variables in reference eq.
int nrobs # number of observation variables in reference eq.
int nfcat # number of catalog variables in fit eq.
int nfobs # number of observation variables in fit eq.
int npars # number of parameters
int nvars, nrvars, nfvars
begin
# Total number of variables
nrvars = nrcat + nrobs
nfvars = nfcat + nfobs
nvars = nrvars + nfvars
# Allocate space
call malloc (ptr, LEN_PTEQ (nvars, npars), TY_STRUCT)
# Initialize counters
PTEQ_NRCAT (ptr) = nrcat
PTEQ_NROBS (ptr) = nrobs
PTEQ_NRVAR (ptr) = nrvars
PTEQ_NFCAT (ptr) = nfcat
PTEQ_NFOBS (ptr) = nfobs
PTEQ_NFVAR (ptr) = nfvars
PTEQ_NVAR (ptr) = nvars
PTEQ_NPAR (ptr) = npars
PTEQ_NFPAR (ptr) = INDEFI
# Initialize variable offsets and counters
call amovki (INDEFI, PTEQ_AREFVAR (ptr), nrvars)
call amovki (INDEFI, PTEQ_AFITVAR (ptr), nfvars)
call aclri (PTEQ_AREFCNT (ptr), nrvars)
call aclri (PTEQ_AFITCNT (ptr), nfvars)
# Initialize parameter offsets, values, and list
call amovki (INDEFI, PTEQ_APAR (ptr), npars)
call amovkr (INDEFR, PTEQ_APARVAL (ptr), npars)
call aclri (PTEQ_APLIST (ptr), npars)
# Initialize string offsets
PTEQ_FIT (ptr) = INDEFI
PTEQ_REF (ptr) = INDEFI
PTEQ_ERROR (ptr) = INDEFI
PTEQ_ERRMIN (ptr) = INDEFI
PTEQ_ERRMAX (ptr) = INDEFI
PTEQ_WEIGHT (ptr) = INDEFI
PTEQ_WTSMIN (ptr) = INDEFI
PTEQ_WTSMAX (ptr) = INDEFI
PTEQ_XPLOT (ptr) = INDEFI
PTEQ_YPLOT (ptr) = INDEFI
call amovki (INDEFI, PTEQ_ADER (ptr), npars)
# Initialize code pointers
PTEQ_RPNFIT (ptr) = NULL
PTEQ_RPNREF (ptr) = NULL
PTEQ_RPNERROR (ptr) = NULL
PTEQ_RPNERRMIN (ptr) = NULL
PTEQ_RPNERRMAX (ptr) = NULL
PTEQ_RPNWEIGHT (ptr) = NULL
PTEQ_RPNWTSMIN (ptr) = NULL
PTEQ_RPNWTSMAX (ptr) = NULL
PTEQ_RPNXPLOT (ptr) = NULL
PTEQ_RPNYPLOT (ptr) = NULL
call amovki (NULL, PTEQ_ARPNDER (ptr), npars)
end
# PR_FREE - Free parser symbol table and sequential tables.
procedure pr_free ()
int n
pointer sym, ptr
include "parser.com"
pointer sthead(), stnext()
begin
# Traverse the symbol table looking for symbol
# substructures before closing it.
sym = sthead (symtable)
while (sym != NULL) {
# Get pointer to the equation substructure,
# and free it only if not NULL
ptr = PSYM_SUB (sym)
if (ptr != NULL) {
# Free additonal buffers associated with the substructure
switch (PSYM_TYPE (sym)) {
case PTY_CATVAR, PTY_OBSVAR:
# do nothing
case PTY_FITPAR, PTY_CONST:
# do nothing
case PTY_TRNEQ:
# Free transformation equation codes
if (PTEQ_RPNFIT (ptr) != NULL)
call mfree (PTEQ_RPNFIT (ptr), TY_STRUCT)
if (PTEQ_RPNREF (ptr) != NULL)
call mfree (PTEQ_RPNREF (ptr), TY_STRUCT)
# Free error equation codes
if (PTEQ_RPNERROR (ptr) != NULL)
call mfree (PTEQ_RPNERROR (ptr), TY_STRUCT)
if (PTEQ_RPNERRMIN (ptr) != NULL)
call mfree (PTEQ_RPNERRMIN (ptr), TY_STRUCT)
if (PTEQ_RPNERRMAX (ptr) != NULL)
call mfree (PTEQ_RPNERRMAX (ptr), TY_STRUCT)
# Free weight equation codes
if (PTEQ_RPNWEIGHT (ptr) != NULL)
call mfree (PTEQ_RPNWEIGHT (ptr), TY_STRUCT)
if (PTEQ_RPNWTSMIN (ptr) != NULL)
call mfree (PTEQ_RPNWTSMIN (ptr), TY_STRUCT)
if (PTEQ_RPNWTSMAX (ptr) != NULL)
call mfree (PTEQ_RPNWTSMAX (ptr), TY_STRUCT)
# Free plot equation codes
if (PTEQ_RPNXPLOT (ptr) != NULL)
call mfree (PTEQ_RPNXPLOT (ptr), TY_STRUCT)
if (PTEQ_RPNYPLOT (ptr) != NULL)
call mfree (PTEQ_RPNYPLOT (ptr), TY_STRUCT)
do n = 1, PTEQ_NPAR (ptr)
call mfree (PTEQ_RPNDER (ptr, n), TY_STRUCT)
case PTY_SETEQ:
# Free set equation code
if (PSEQ_RPNEQ (ptr) != NULL)
call mfree (PSEQ_RPNEQ (ptr), TY_STRUCT)
# Free error equation codes
if (PSEQ_RPNERROR (ptr) != NULL)
call mfree (PSEQ_RPNERROR (ptr), TY_STRUCT)
if (PSEQ_RPNERRMIN (ptr) != NULL)
call mfree (PSEQ_RPNERRMIN (ptr), TY_STRUCT)
if (PSEQ_RPNERRMAX (ptr) != NULL)
call mfree (PSEQ_RPNERRMAX (ptr), TY_STRUCT)
# Free weight equation codes
if (PSEQ_RPNWEIGHT (ptr) != NULL)
call mfree (PSEQ_RPNWEIGHT (ptr), TY_STRUCT)
if (PSEQ_RPNWTSMIN (ptr) != NULL)
call mfree (PSEQ_RPNWTSMIN (ptr), TY_STRUCT)
if (PSEQ_RPNWTSMAX (ptr) != NULL)
call mfree (PSEQ_RPNWTSMAX (ptr), TY_STRUCT)
default:
call error (0, "pr_free: unknown equation symbol type")
}
# Free equation substructure
call mfree (ptr, TY_STRUCT)
}
# Advance to next symbol
sym = stnext (symtable, sym)
}
# Close symbol table
call stclose (symtable)
# Close other tables
call mct_free (obstable)
call mct_free (cattable)
call mct_free (partable)
call mct_free (exttable)
call mct_free (trntable)
call mct_free (settable)
call mct_free (trcattable)
call mct_free (trobstable)
call mct_free (tfcattable)
call mct_free (tfobstable)
call mct_free (tpartable)
end
|
