|
1 /* glpmpl01.c */ |
|
2 |
|
3 /*********************************************************************** |
|
4 * This code is part of GLPK (GNU Linear Programming Kit). |
|
5 * |
|
6 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, |
|
7 * 2009, 2010 Andrew Makhorin, Department for Applied Informatics, |
|
8 * Moscow Aviation Institute, Moscow, Russia. All rights reserved. |
|
9 * E-mail: <mao@gnu.org>. |
|
10 * |
|
11 * GLPK is free software: you can redistribute it and/or modify it |
|
12 * under the terms of the GNU General Public License as published by |
|
13 * the Free Software Foundation, either version 3 of the License, or |
|
14 * (at your option) any later version. |
|
15 * |
|
16 * GLPK is distributed in the hope that it will be useful, but WITHOUT |
|
17 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY |
|
18 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public |
|
19 * License for more details. |
|
20 * |
|
21 * You should have received a copy of the GNU General Public License |
|
22 * along with GLPK. If not, see <http://www.gnu.org/licenses/>. |
|
23 ***********************************************************************/ |
|
24 |
|
25 #define _GLPSTD_STDIO |
|
26 #include "glpmpl.h" |
|
27 #define dmp_get_atomv dmp_get_atom |
|
28 |
|
29 /**********************************************************************/ |
|
30 /* * * PROCESSING MODEL SECTION * * */ |
|
31 /**********************************************************************/ |
|
32 |
|
33 /*---------------------------------------------------------------------- |
|
34 -- enter_context - enter current token into context queue. |
|
35 -- |
|
36 -- This routine enters the current token into the context queue. */ |
|
37 |
|
38 void enter_context(MPL *mpl) |
|
39 { char *image, *s; |
|
40 if (mpl->token == T_EOF) |
|
41 image = "_|_"; |
|
42 else if (mpl->token == T_STRING) |
|
43 image = "'...'"; |
|
44 else |
|
45 image = mpl->image; |
|
46 xassert(0 <= mpl->c_ptr && mpl->c_ptr < CONTEXT_SIZE); |
|
47 mpl->context[mpl->c_ptr++] = ' '; |
|
48 if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0; |
|
49 for (s = image; *s != '\0'; s++) |
|
50 { mpl->context[mpl->c_ptr++] = *s; |
|
51 if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0; |
|
52 } |
|
53 return; |
|
54 } |
|
55 |
|
56 /*---------------------------------------------------------------------- |
|
57 -- print_context - print current content of context queue. |
|
58 -- |
|
59 -- This routine prints current content of the context queue. */ |
|
60 |
|
61 void print_context(MPL *mpl) |
|
62 { int c; |
|
63 while (mpl->c_ptr > 0) |
|
64 { mpl->c_ptr--; |
|
65 c = mpl->context[0]; |
|
66 memmove(mpl->context, mpl->context+1, CONTEXT_SIZE-1); |
|
67 mpl->context[CONTEXT_SIZE-1] = (char)c; |
|
68 } |
|
69 xprintf("Context: %s%.*s\n", mpl->context[0] == ' ' ? "" : "...", |
|
70 CONTEXT_SIZE, mpl->context); |
|
71 return; |
|
72 } |
|
73 |
|
74 /*---------------------------------------------------------------------- |
|
75 -- get_char - scan next character from input text file. |
|
76 -- |
|
77 -- This routine scans a next ASCII character from the input text file. |
|
78 -- In case of end-of-file, the character is assigned EOF. */ |
|
79 |
|
80 void get_char(MPL *mpl) |
|
81 { int c; |
|
82 if (mpl->c == EOF) goto done; |
|
83 if (mpl->c == '\n') mpl->line++; |
|
84 c = read_char(mpl); |
|
85 if (c == EOF) |
|
86 { if (mpl->c == '\n') |
|
87 mpl->line--; |
|
88 else |
|
89 warning(mpl, "final NL missing before end of file"); |
|
90 } |
|
91 else if (c == '\n') |
|
92 ; |
|
93 else if (isspace(c)) |
|
94 c = ' '; |
|
95 else if (iscntrl(c)) |
|
96 { enter_context(mpl); |
|
97 error(mpl, "control character 0x%02X not allowed", c); |
|
98 } |
|
99 mpl->c = c; |
|
100 done: return; |
|
101 } |
|
102 |
|
103 /*---------------------------------------------------------------------- |
|
104 -- append_char - append character to current token. |
|
105 -- |
|
106 -- This routine appends the current character to the current token and |
|
107 -- then scans a next character. */ |
|
108 |
|
109 void append_char(MPL *mpl) |
|
110 { xassert(0 <= mpl->imlen && mpl->imlen <= MAX_LENGTH); |
|
111 if (mpl->imlen == MAX_LENGTH) |
|
112 { switch (mpl->token) |
|
113 { case T_NAME: |
|
114 enter_context(mpl); |
|
115 error(mpl, "symbolic name %s... too long", mpl->image); |
|
116 case T_SYMBOL: |
|
117 enter_context(mpl); |
|
118 error(mpl, "symbol %s... too long", mpl->image); |
|
119 case T_NUMBER: |
|
120 enter_context(mpl); |
|
121 error(mpl, "numeric literal %s... too long", mpl->image); |
|
122 case T_STRING: |
|
123 enter_context(mpl); |
|
124 error(mpl, "string literal too long"); |
|
125 default: |
|
126 xassert(mpl != mpl); |
|
127 } |
|
128 } |
|
129 mpl->image[mpl->imlen++] = (char)mpl->c; |
|
130 mpl->image[mpl->imlen] = '\0'; |
|
131 get_char(mpl); |
|
132 return; |
|
133 } |
|
134 |
|
135 /*---------------------------------------------------------------------- |
|
136 -- get_token - scan next token from input text file. |
|
137 -- |
|
138 -- This routine scans a next token from the input text file using the |
|
139 -- standard finite automation technique. */ |
|
140 |
|
141 void get_token(MPL *mpl) |
|
142 { /* save the current token */ |
|
143 mpl->b_token = mpl->token; |
|
144 mpl->b_imlen = mpl->imlen; |
|
145 strcpy(mpl->b_image, mpl->image); |
|
146 mpl->b_value = mpl->value; |
|
147 /* if the next token is already scanned, make it current */ |
|
148 if (mpl->f_scan) |
|
149 { mpl->f_scan = 0; |
|
150 mpl->token = mpl->f_token; |
|
151 mpl->imlen = mpl->f_imlen; |
|
152 strcpy(mpl->image, mpl->f_image); |
|
153 mpl->value = mpl->f_value; |
|
154 goto done; |
|
155 } |
|
156 loop: /* nothing has been scanned so far */ |
|
157 mpl->token = 0; |
|
158 mpl->imlen = 0; |
|
159 mpl->image[0] = '\0'; |
|
160 mpl->value = 0.0; |
|
161 /* skip any uninteresting characters */ |
|
162 while (mpl->c == ' ' || mpl->c == '\n') get_char(mpl); |
|
163 /* recognize and construct the token */ |
|
164 if (mpl->c == EOF) |
|
165 { /* end-of-file reached */ |
|
166 mpl->token = T_EOF; |
|
167 } |
|
168 else if (mpl->c == '#') |
|
169 { /* comment; skip anything until end-of-line */ |
|
170 while (mpl->c != '\n' && mpl->c != EOF) get_char(mpl); |
|
171 goto loop; |
|
172 } |
|
173 else if (!mpl->flag_d && (isalpha(mpl->c) || mpl->c == '_')) |
|
174 { /* symbolic name or reserved keyword */ |
|
175 mpl->token = T_NAME; |
|
176 while (isalnum(mpl->c) || mpl->c == '_') append_char(mpl); |
|
177 if (strcmp(mpl->image, "and") == 0) |
|
178 mpl->token = T_AND; |
|
179 else if (strcmp(mpl->image, "by") == 0) |
|
180 mpl->token = T_BY; |
|
181 else if (strcmp(mpl->image, "cross") == 0) |
|
182 mpl->token = T_CROSS; |
|
183 else if (strcmp(mpl->image, "diff") == 0) |
|
184 mpl->token = T_DIFF; |
|
185 else if (strcmp(mpl->image, "div") == 0) |
|
186 mpl->token = T_DIV; |
|
187 else if (strcmp(mpl->image, "else") == 0) |
|
188 mpl->token = T_ELSE; |
|
189 else if (strcmp(mpl->image, "if") == 0) |
|
190 mpl->token = T_IF; |
|
191 else if (strcmp(mpl->image, "in") == 0) |
|
192 mpl->token = T_IN; |
|
193 #if 1 /* 21/VII-2006 */ |
|
194 else if (strcmp(mpl->image, "Infinity") == 0) |
|
195 mpl->token = T_INFINITY; |
|
196 #endif |
|
197 else if (strcmp(mpl->image, "inter") == 0) |
|
198 mpl->token = T_INTER; |
|
199 else if (strcmp(mpl->image, "less") == 0) |
|
200 mpl->token = T_LESS; |
|
201 else if (strcmp(mpl->image, "mod") == 0) |
|
202 mpl->token = T_MOD; |
|
203 else if (strcmp(mpl->image, "not") == 0) |
|
204 mpl->token = T_NOT; |
|
205 else if (strcmp(mpl->image, "or") == 0) |
|
206 mpl->token = T_OR; |
|
207 else if (strcmp(mpl->image, "s") == 0 && mpl->c == '.') |
|
208 { mpl->token = T_SPTP; |
|
209 append_char(mpl); |
|
210 if (mpl->c != 't') |
|
211 sptp: { enter_context(mpl); |
|
212 error(mpl, "keyword s.t. incomplete"); |
|
213 } |
|
214 append_char(mpl); |
|
215 if (mpl->c != '.') goto sptp; |
|
216 append_char(mpl); |
|
217 } |
|
218 else if (strcmp(mpl->image, "symdiff") == 0) |
|
219 mpl->token = T_SYMDIFF; |
|
220 else if (strcmp(mpl->image, "then") == 0) |
|
221 mpl->token = T_THEN; |
|
222 else if (strcmp(mpl->image, "union") == 0) |
|
223 mpl->token = T_UNION; |
|
224 else if (strcmp(mpl->image, "within") == 0) |
|
225 mpl->token = T_WITHIN; |
|
226 } |
|
227 else if (!mpl->flag_d && isdigit(mpl->c)) |
|
228 { /* numeric literal */ |
|
229 mpl->token = T_NUMBER; |
|
230 /* scan integer part */ |
|
231 while (isdigit(mpl->c)) append_char(mpl); |
|
232 /* scan optional fractional part */ |
|
233 if (mpl->c == '.') |
|
234 { append_char(mpl); |
|
235 if (mpl->c == '.') |
|
236 { /* hmm, it is not the fractional part, it is dots that |
|
237 follow the integer part */ |
|
238 mpl->imlen--; |
|
239 mpl->image[mpl->imlen] = '\0'; |
|
240 mpl->f_dots = 1; |
|
241 goto conv; |
|
242 } |
|
243 frac: while (isdigit(mpl->c)) append_char(mpl); |
|
244 } |
|
245 /* scan optional decimal exponent */ |
|
246 if (mpl->c == 'e' || mpl->c == 'E') |
|
247 { append_char(mpl); |
|
248 if (mpl->c == '+' || mpl->c == '-') append_char(mpl); |
|
249 if (!isdigit(mpl->c)) |
|
250 { enter_context(mpl); |
|
251 error(mpl, "numeric literal %s incomplete", mpl->image); |
|
252 } |
|
253 while (isdigit(mpl->c)) append_char(mpl); |
|
254 } |
|
255 /* there must be no letter following the numeric literal */ |
|
256 if (isalpha(mpl->c) || mpl->c == '_') |
|
257 { enter_context(mpl); |
|
258 error(mpl, "symbol %s%c... should be enclosed in quotes", |
|
259 mpl->image, mpl->c); |
|
260 } |
|
261 conv: /* convert numeric literal to floating-point */ |
|
262 if (str2num(mpl->image, &mpl->value)) |
|
263 err: { enter_context(mpl); |
|
264 error(mpl, "cannot convert numeric literal %s to floating-p" |
|
265 "oint number", mpl->image); |
|
266 } |
|
267 } |
|
268 else if (mpl->c == '\'' || mpl->c == '"') |
|
269 { /* character string */ |
|
270 int quote = mpl->c; |
|
271 mpl->token = T_STRING; |
|
272 get_char(mpl); |
|
273 for (;;) |
|
274 { if (mpl->c == '\n' || mpl->c == EOF) |
|
275 { enter_context(mpl); |
|
276 error(mpl, "unexpected end of line; string literal incom" |
|
277 "plete"); |
|
278 } |
|
279 if (mpl->c == quote) |
|
280 { get_char(mpl); |
|
281 if (mpl->c != quote) break; |
|
282 } |
|
283 append_char(mpl); |
|
284 } |
|
285 } |
|
286 else if (!mpl->flag_d && mpl->c == '+') |
|
287 mpl->token = T_PLUS, append_char(mpl); |
|
288 else if (!mpl->flag_d && mpl->c == '-') |
|
289 mpl->token = T_MINUS, append_char(mpl); |
|
290 else if (mpl->c == '*') |
|
291 { mpl->token = T_ASTERISK, append_char(mpl); |
|
292 if (mpl->c == '*') |
|
293 mpl->token = T_POWER, append_char(mpl); |
|
294 } |
|
295 else if (mpl->c == '/') |
|
296 { mpl->token = T_SLASH, append_char(mpl); |
|
297 if (mpl->c == '*') |
|
298 { /* comment sequence */ |
|
299 get_char(mpl); |
|
300 for (;;) |
|
301 { if (mpl->c == EOF) |
|
302 { /* do not call enter_context at this point */ |
|
303 error(mpl, "unexpected end of file; comment sequence " |
|
304 "incomplete"); |
|
305 } |
|
306 else if (mpl->c == '*') |
|
307 { get_char(mpl); |
|
308 if (mpl->c == '/') break; |
|
309 } |
|
310 else |
|
311 get_char(mpl); |
|
312 } |
|
313 get_char(mpl); |
|
314 goto loop; |
|
315 } |
|
316 } |
|
317 else if (mpl->c == '^') |
|
318 mpl->token = T_POWER, append_char(mpl); |
|
319 else if (mpl->c == '<') |
|
320 { mpl->token = T_LT, append_char(mpl); |
|
321 if (mpl->c == '=') |
|
322 mpl->token = T_LE, append_char(mpl); |
|
323 else if (mpl->c == '>') |
|
324 mpl->token = T_NE, append_char(mpl); |
|
325 #if 1 /* 11/II-2008 */ |
|
326 else if (mpl->c == '-') |
|
327 mpl->token = T_INPUT, append_char(mpl); |
|
328 #endif |
|
329 } |
|
330 else if (mpl->c == '=') |
|
331 { mpl->token = T_EQ, append_char(mpl); |
|
332 if (mpl->c == '=') append_char(mpl); |
|
333 } |
|
334 else if (mpl->c == '>') |
|
335 { mpl->token = T_GT, append_char(mpl); |
|
336 if (mpl->c == '=') |
|
337 mpl->token = T_GE, append_char(mpl); |
|
338 #if 1 /* 14/VII-2006 */ |
|
339 else if (mpl->c == '>') |
|
340 mpl->token = T_APPEND, append_char(mpl); |
|
341 #endif |
|
342 } |
|
343 else if (mpl->c == '!') |
|
344 { mpl->token = T_NOT, append_char(mpl); |
|
345 if (mpl->c == '=') |
|
346 mpl->token = T_NE, append_char(mpl); |
|
347 } |
|
348 else if (mpl->c == '&') |
|
349 { mpl->token = T_CONCAT, append_char(mpl); |
|
350 if (mpl->c == '&') |
|
351 mpl->token = T_AND, append_char(mpl); |
|
352 } |
|
353 else if (mpl->c == '|') |
|
354 { mpl->token = T_BAR, append_char(mpl); |
|
355 if (mpl->c == '|') |
|
356 mpl->token = T_OR, append_char(mpl); |
|
357 } |
|
358 else if (!mpl->flag_d && mpl->c == '.') |
|
359 { mpl->token = T_POINT, append_char(mpl); |
|
360 if (mpl->f_dots) |
|
361 { /* dots; the first dot was read on the previous call to the |
|
362 scanner, so the current character is the second dot */ |
|
363 mpl->token = T_DOTS; |
|
364 mpl->imlen = 2; |
|
365 strcpy(mpl->image, ".."); |
|
366 mpl->f_dots = 0; |
|
367 } |
|
368 else if (mpl->c == '.') |
|
369 mpl->token = T_DOTS, append_char(mpl); |
|
370 else if (isdigit(mpl->c)) |
|
371 { /* numeric literal that begins with the decimal point */ |
|
372 mpl->token = T_NUMBER, append_char(mpl); |
|
373 goto frac; |
|
374 } |
|
375 } |
|
376 else if (mpl->c == ',') |
|
377 mpl->token = T_COMMA, append_char(mpl); |
|
378 else if (mpl->c == ':') |
|
379 { mpl->token = T_COLON, append_char(mpl); |
|
380 if (mpl->c == '=') |
|
381 mpl->token = T_ASSIGN, append_char(mpl); |
|
382 } |
|
383 else if (mpl->c == ';') |
|
384 mpl->token = T_SEMICOLON, append_char(mpl); |
|
385 else if (mpl->c == '(') |
|
386 mpl->token = T_LEFT, append_char(mpl); |
|
387 else if (mpl->c == ')') |
|
388 mpl->token = T_RIGHT, append_char(mpl); |
|
389 else if (mpl->c == '[') |
|
390 mpl->token = T_LBRACKET, append_char(mpl); |
|
391 else if (mpl->c == ']') |
|
392 mpl->token = T_RBRACKET, append_char(mpl); |
|
393 else if (mpl->c == '{') |
|
394 mpl->token = T_LBRACE, append_char(mpl); |
|
395 else if (mpl->c == '}') |
|
396 mpl->token = T_RBRACE, append_char(mpl); |
|
397 #if 1 /* 11/II-2008 */ |
|
398 else if (mpl->c == '~') |
|
399 mpl->token = T_TILDE, append_char(mpl); |
|
400 #endif |
|
401 else if (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL) |
|
402 { /* symbol */ |
|
403 xassert(mpl->flag_d); |
|
404 mpl->token = T_SYMBOL; |
|
405 while (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL) |
|
406 append_char(mpl); |
|
407 switch (str2num(mpl->image, &mpl->value)) |
|
408 { case 0: |
|
409 mpl->token = T_NUMBER; |
|
410 break; |
|
411 case 1: |
|
412 goto err; |
|
413 case 2: |
|
414 break; |
|
415 default: |
|
416 xassert(mpl != mpl); |
|
417 } |
|
418 } |
|
419 else |
|
420 { enter_context(mpl); |
|
421 error(mpl, "character %c not allowed", mpl->c); |
|
422 } |
|
423 /* enter the current token into the context queue */ |
|
424 enter_context(mpl); |
|
425 /* reset the flag, which may be set by indexing_expression() and |
|
426 is used by expression_list() */ |
|
427 mpl->flag_x = 0; |
|
428 done: return; |
|
429 } |
|
430 |
|
431 /*---------------------------------------------------------------------- |
|
432 -- unget_token - return current token back to input stream. |
|
433 -- |
|
434 -- This routine returns the current token back to the input stream, so |
|
435 -- the previously scanned token becomes the current one. */ |
|
436 |
|
437 void unget_token(MPL *mpl) |
|
438 { /* save the current token, which becomes the next one */ |
|
439 xassert(!mpl->f_scan); |
|
440 mpl->f_scan = 1; |
|
441 mpl->f_token = mpl->token; |
|
442 mpl->f_imlen = mpl->imlen; |
|
443 strcpy(mpl->f_image, mpl->image); |
|
444 mpl->f_value = mpl->value; |
|
445 /* restore the previous token, which becomes the current one */ |
|
446 mpl->token = mpl->b_token; |
|
447 mpl->imlen = mpl->b_imlen; |
|
448 strcpy(mpl->image, mpl->b_image); |
|
449 mpl->value = mpl->b_value; |
|
450 return; |
|
451 } |
|
452 |
|
453 /*---------------------------------------------------------------------- |
|
454 -- is_keyword - check if current token is given non-reserved keyword. |
|
455 -- |
|
456 -- If the current token is given (non-reserved) keyword, this routine |
|
457 -- returns non-zero. Otherwise zero is returned. */ |
|
458 |
|
459 int is_keyword(MPL *mpl, char *keyword) |
|
460 { return |
|
461 mpl->token == T_NAME && strcmp(mpl->image, keyword) == 0; |
|
462 } |
|
463 |
|
464 /*---------------------------------------------------------------------- |
|
465 -- is_reserved - check if current token is reserved keyword. |
|
466 -- |
|
467 -- If the current token is a reserved keyword, this routine returns |
|
468 -- non-zero. Otherwise zero is returned. */ |
|
469 |
|
470 int is_reserved(MPL *mpl) |
|
471 { return |
|
472 mpl->token == T_AND && mpl->image[0] == 'a' || |
|
473 mpl->token == T_BY || |
|
474 mpl->token == T_CROSS || |
|
475 mpl->token == T_DIFF || |
|
476 mpl->token == T_DIV || |
|
477 mpl->token == T_ELSE || |
|
478 mpl->token == T_IF || |
|
479 mpl->token == T_IN || |
|
480 mpl->token == T_INTER || |
|
481 mpl->token == T_LESS || |
|
482 mpl->token == T_MOD || |
|
483 mpl->token == T_NOT && mpl->image[0] == 'n' || |
|
484 mpl->token == T_OR && mpl->image[0] == 'o' || |
|
485 mpl->token == T_SYMDIFF || |
|
486 mpl->token == T_THEN || |
|
487 mpl->token == T_UNION || |
|
488 mpl->token == T_WITHIN; |
|
489 } |
|
490 |
|
491 /*---------------------------------------------------------------------- |
|
492 -- make_code - generate pseudo-code (basic routine). |
|
493 -- |
|
494 -- This routine generates specified pseudo-code. It is assumed that all |
|
495 -- other translator routines use this basic routine. */ |
|
496 |
|
497 CODE *make_code(MPL *mpl, int op, OPERANDS *arg, int type, int dim) |
|
498 { CODE *code; |
|
499 DOMAIN *domain; |
|
500 DOMAIN_BLOCK *block; |
|
501 ARG_LIST *e; |
|
502 /* generate pseudo-code */ |
|
503 code = alloc(CODE); |
|
504 code->op = op; |
|
505 code->vflag = 0; /* is inherited from operand(s) */ |
|
506 /* copy operands and also make them referring to the pseudo-code |
|
507 being generated, because the latter becomes the parent for all |
|
508 its operands */ |
|
509 memset(&code->arg, '?', sizeof(OPERANDS)); |
|
510 switch (op) |
|
511 { case O_NUMBER: |
|
512 code->arg.num = arg->num; |
|
513 break; |
|
514 case O_STRING: |
|
515 code->arg.str = arg->str; |
|
516 break; |
|
517 case O_INDEX: |
|
518 code->arg.index.slot = arg->index.slot; |
|
519 code->arg.index.next = arg->index.next; |
|
520 break; |
|
521 case O_MEMNUM: |
|
522 case O_MEMSYM: |
|
523 for (e = arg->par.list; e != NULL; e = e->next) |
|
524 { xassert(e->x != NULL); |
|
525 xassert(e->x->up == NULL); |
|
526 e->x->up = code; |
|
527 code->vflag |= e->x->vflag; |
|
528 } |
|
529 code->arg.par.par = arg->par.par; |
|
530 code->arg.par.list = arg->par.list; |
|
531 break; |
|
532 case O_MEMSET: |
|
533 for (e = arg->set.list; e != NULL; e = e->next) |
|
534 { xassert(e->x != NULL); |
|
535 xassert(e->x->up == NULL); |
|
536 e->x->up = code; |
|
537 code->vflag |= e->x->vflag; |
|
538 } |
|
539 code->arg.set.set = arg->set.set; |
|
540 code->arg.set.list = arg->set.list; |
|
541 break; |
|
542 case O_MEMVAR: |
|
543 for (e = arg->var.list; e != NULL; e = e->next) |
|
544 { xassert(e->x != NULL); |
|
545 xassert(e->x->up == NULL); |
|
546 e->x->up = code; |
|
547 code->vflag |= e->x->vflag; |
|
548 } |
|
549 code->arg.var.var = arg->var.var; |
|
550 code->arg.var.list = arg->var.list; |
|
551 #if 1 /* 15/V-2010 */ |
|
552 code->arg.var.suff = arg->var.suff; |
|
553 #endif |
|
554 break; |
|
555 #if 1 /* 15/V-2010 */ |
|
556 case O_MEMCON: |
|
557 for (e = arg->con.list; e != NULL; e = e->next) |
|
558 { xassert(e->x != NULL); |
|
559 xassert(e->x->up == NULL); |
|
560 e->x->up = code; |
|
561 code->vflag |= e->x->vflag; |
|
562 } |
|
563 code->arg.con.con = arg->con.con; |
|
564 code->arg.con.list = arg->con.list; |
|
565 code->arg.con.suff = arg->con.suff; |
|
566 break; |
|
567 #endif |
|
568 case O_TUPLE: |
|
569 case O_MAKE: |
|
570 for (e = arg->list; e != NULL; e = e->next) |
|
571 { xassert(e->x != NULL); |
|
572 xassert(e->x->up == NULL); |
|
573 e->x->up = code; |
|
574 code->vflag |= e->x->vflag; |
|
575 } |
|
576 code->arg.list = arg->list; |
|
577 break; |
|
578 case O_SLICE: |
|
579 xassert(arg->slice != NULL); |
|
580 code->arg.slice = arg->slice; |
|
581 break; |
|
582 case O_IRAND224: |
|
583 case O_UNIFORM01: |
|
584 case O_NORMAL01: |
|
585 case O_GMTIME: |
|
586 code->vflag = 1; |
|
587 break; |
|
588 case O_CVTNUM: |
|
589 case O_CVTSYM: |
|
590 case O_CVTLOG: |
|
591 case O_CVTTUP: |
|
592 case O_CVTLFM: |
|
593 case O_PLUS: |
|
594 case O_MINUS: |
|
595 case O_NOT: |
|
596 case O_ABS: |
|
597 case O_CEIL: |
|
598 case O_FLOOR: |
|
599 case O_EXP: |
|
600 case O_LOG: |
|
601 case O_LOG10: |
|
602 case O_SQRT: |
|
603 case O_SIN: |
|
604 case O_COS: |
|
605 case O_ATAN: |
|
606 case O_ROUND: |
|
607 case O_TRUNC: |
|
608 case O_CARD: |
|
609 case O_LENGTH: |
|
610 /* unary operation */ |
|
611 xassert(arg->arg.x != NULL); |
|
612 xassert(arg->arg.x->up == NULL); |
|
613 arg->arg.x->up = code; |
|
614 code->vflag |= arg->arg.x->vflag; |
|
615 code->arg.arg.x = arg->arg.x; |
|
616 break; |
|
617 case O_ADD: |
|
618 case O_SUB: |
|
619 case O_LESS: |
|
620 case O_MUL: |
|
621 case O_DIV: |
|
622 case O_IDIV: |
|
623 case O_MOD: |
|
624 case O_POWER: |
|
625 case O_ATAN2: |
|
626 case O_ROUND2: |
|
627 case O_TRUNC2: |
|
628 case O_UNIFORM: |
|
629 if (op == O_UNIFORM) code->vflag = 1; |
|
630 case O_NORMAL: |
|
631 if (op == O_NORMAL) code->vflag = 1; |
|
632 case O_CONCAT: |
|
633 case O_LT: |
|
634 case O_LE: |
|
635 case O_EQ: |
|
636 case O_GE: |
|
637 case O_GT: |
|
638 case O_NE: |
|
639 case O_AND: |
|
640 case O_OR: |
|
641 case O_UNION: |
|
642 case O_DIFF: |
|
643 case O_SYMDIFF: |
|
644 case O_INTER: |
|
645 case O_CROSS: |
|
646 case O_IN: |
|
647 case O_NOTIN: |
|
648 case O_WITHIN: |
|
649 case O_NOTWITHIN: |
|
650 case O_SUBSTR: |
|
651 case O_STR2TIME: |
|
652 case O_TIME2STR: |
|
653 /* binary operation */ |
|
654 xassert(arg->arg.x != NULL); |
|
655 xassert(arg->arg.x->up == NULL); |
|
656 arg->arg.x->up = code; |
|
657 code->vflag |= arg->arg.x->vflag; |
|
658 xassert(arg->arg.y != NULL); |
|
659 xassert(arg->arg.y->up == NULL); |
|
660 arg->arg.y->up = code; |
|
661 code->vflag |= arg->arg.y->vflag; |
|
662 code->arg.arg.x = arg->arg.x; |
|
663 code->arg.arg.y = arg->arg.y; |
|
664 break; |
|
665 case O_DOTS: |
|
666 case O_FORK: |
|
667 case O_SUBSTR3: |
|
668 /* ternary operation */ |
|
669 xassert(arg->arg.x != NULL); |
|
670 xassert(arg->arg.x->up == NULL); |
|
671 arg->arg.x->up = code; |
|
672 code->vflag |= arg->arg.x->vflag; |
|
673 xassert(arg->arg.y != NULL); |
|
674 xassert(arg->arg.y->up == NULL); |
|
675 arg->arg.y->up = code; |
|
676 code->vflag |= arg->arg.y->vflag; |
|
677 if (arg->arg.z != NULL) |
|
678 { xassert(arg->arg.z->up == NULL); |
|
679 arg->arg.z->up = code; |
|
680 code->vflag |= arg->arg.z->vflag; |
|
681 } |
|
682 code->arg.arg.x = arg->arg.x; |
|
683 code->arg.arg.y = arg->arg.y; |
|
684 code->arg.arg.z = arg->arg.z; |
|
685 break; |
|
686 case O_MIN: |
|
687 case O_MAX: |
|
688 /* n-ary operation */ |
|
689 for (e = arg->list; e != NULL; e = e->next) |
|
690 { xassert(e->x != NULL); |
|
691 xassert(e->x->up == NULL); |
|
692 e->x->up = code; |
|
693 code->vflag |= e->x->vflag; |
|
694 } |
|
695 code->arg.list = arg->list; |
|
696 break; |
|
697 case O_SUM: |
|
698 case O_PROD: |
|
699 case O_MINIMUM: |
|
700 case O_MAXIMUM: |
|
701 case O_FORALL: |
|
702 case O_EXISTS: |
|
703 case O_SETOF: |
|
704 case O_BUILD: |
|
705 /* iterated operation */ |
|
706 domain = arg->loop.domain; |
|
707 xassert(domain != NULL); |
|
708 if (domain->code != NULL) |
|
709 { xassert(domain->code->up == NULL); |
|
710 domain->code->up = code; |
|
711 code->vflag |= domain->code->vflag; |
|
712 } |
|
713 for (block = domain->list; block != NULL; block = |
|
714 block->next) |
|
715 { xassert(block->code != NULL); |
|
716 xassert(block->code->up == NULL); |
|
717 block->code->up = code; |
|
718 code->vflag |= block->code->vflag; |
|
719 } |
|
720 if (arg->loop.x != NULL) |
|
721 { xassert(arg->loop.x->up == NULL); |
|
722 arg->loop.x->up = code; |
|
723 code->vflag |= arg->loop.x->vflag; |
|
724 } |
|
725 code->arg.loop.domain = arg->loop.domain; |
|
726 code->arg.loop.x = arg->loop.x; |
|
727 break; |
|
728 default: |
|
729 xassert(op != op); |
|
730 } |
|
731 /* set other attributes of the pseudo-code */ |
|
732 code->type = type; |
|
733 code->dim = dim; |
|
734 code->up = NULL; |
|
735 code->valid = 0; |
|
736 memset(&code->value, '?', sizeof(VALUE)); |
|
737 return code; |
|
738 } |
|
739 |
|
740 /*---------------------------------------------------------------------- |
|
741 -- make_unary - generate pseudo-code for unary operation. |
|
742 -- |
|
743 -- This routine generates pseudo-code for unary operation. */ |
|
744 |
|
745 CODE *make_unary(MPL *mpl, int op, CODE *x, int type, int dim) |
|
746 { CODE *code; |
|
747 OPERANDS arg; |
|
748 xassert(x != NULL); |
|
749 arg.arg.x = x; |
|
750 code = make_code(mpl, op, &arg, type, dim); |
|
751 return code; |
|
752 } |
|
753 |
|
754 /*---------------------------------------------------------------------- |
|
755 -- make_binary - generate pseudo-code for binary operation. |
|
756 -- |
|
757 -- This routine generates pseudo-code for binary operation. */ |
|
758 |
|
759 CODE *make_binary(MPL *mpl, int op, CODE *x, CODE *y, int type, |
|
760 int dim) |
|
761 { CODE *code; |
|
762 OPERANDS arg; |
|
763 xassert(x != NULL); |
|
764 xassert(y != NULL); |
|
765 arg.arg.x = x; |
|
766 arg.arg.y = y; |
|
767 code = make_code(mpl, op, &arg, type, dim); |
|
768 return code; |
|
769 } |
|
770 |
|
771 /*---------------------------------------------------------------------- |
|
772 -- make_ternary - generate pseudo-code for ternary operation. |
|
773 -- |
|
774 -- This routine generates pseudo-code for ternary operation. */ |
|
775 |
|
776 CODE *make_ternary(MPL *mpl, int op, CODE *x, CODE *y, CODE *z, |
|
777 int type, int dim) |
|
778 { CODE *code; |
|
779 OPERANDS arg; |
|
780 xassert(x != NULL); |
|
781 xassert(y != NULL); |
|
782 /* third operand can be NULL */ |
|
783 arg.arg.x = x; |
|
784 arg.arg.y = y; |
|
785 arg.arg.z = z; |
|
786 code = make_code(mpl, op, &arg, type, dim); |
|
787 return code; |
|
788 } |
|
789 |
|
790 /*---------------------------------------------------------------------- |
|
791 -- numeric_literal - parse reference to numeric literal. |
|
792 -- |
|
793 -- This routine parses primary expression using the syntax: |
|
794 -- |
|
795 -- <primary expression> ::= <numeric literal> */ |
|
796 |
|
797 CODE *numeric_literal(MPL *mpl) |
|
798 { CODE *code; |
|
799 OPERANDS arg; |
|
800 xassert(mpl->token == T_NUMBER); |
|
801 arg.num = mpl->value; |
|
802 code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0); |
|
803 get_token(mpl /* <numeric literal> */); |
|
804 return code; |
|
805 } |
|
806 |
|
807 /*---------------------------------------------------------------------- |
|
808 -- string_literal - parse reference to string literal. |
|
809 -- |
|
810 -- This routine parses primary expression using the syntax: |
|
811 -- |
|
812 -- <primary expression> ::= <string literal> */ |
|
813 |
|
814 CODE *string_literal(MPL *mpl) |
|
815 { CODE *code; |
|
816 OPERANDS arg; |
|
817 xassert(mpl->token == T_STRING); |
|
818 arg.str = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
819 strcpy(arg.str, mpl->image); |
|
820 code = make_code(mpl, O_STRING, &arg, A_SYMBOLIC, 0); |
|
821 get_token(mpl /* <string literal> */); |
|
822 return code; |
|
823 } |
|
824 |
|
825 /*---------------------------------------------------------------------- |
|
826 -- create_arg_list - create empty operands list. |
|
827 -- |
|
828 -- This routine creates operands list, which is initially empty. */ |
|
829 |
|
830 ARG_LIST *create_arg_list(MPL *mpl) |
|
831 { ARG_LIST *list; |
|
832 xassert(mpl == mpl); |
|
833 list = NULL; |
|
834 return list; |
|
835 } |
|
836 |
|
837 /*---------------------------------------------------------------------- |
|
838 -- expand_arg_list - append operand to operands list. |
|
839 -- |
|
840 -- This routine appends new operand to specified operands list. */ |
|
841 |
|
842 ARG_LIST *expand_arg_list(MPL *mpl, ARG_LIST *list, CODE *x) |
|
843 { ARG_LIST *tail, *temp; |
|
844 xassert(x != NULL); |
|
845 /* create new operands list entry */ |
|
846 tail = alloc(ARG_LIST); |
|
847 tail->x = x; |
|
848 tail->next = NULL; |
|
849 /* and append it to the operands list */ |
|
850 if (list == NULL) |
|
851 list = tail; |
|
852 else |
|
853 { for (temp = list; temp->next != NULL; temp = temp->next); |
|
854 temp->next = tail; |
|
855 } |
|
856 return list; |
|
857 } |
|
858 |
|
859 /*---------------------------------------------------------------------- |
|
860 -- arg_list_len - determine length of operands list. |
|
861 -- |
|
862 -- This routine returns the number of operands in operands list. */ |
|
863 |
|
864 int arg_list_len(MPL *mpl, ARG_LIST *list) |
|
865 { ARG_LIST *temp; |
|
866 int len; |
|
867 xassert(mpl == mpl); |
|
868 len = 0; |
|
869 for (temp = list; temp != NULL; temp = temp->next) len++; |
|
870 return len; |
|
871 } |
|
872 |
|
873 /*---------------------------------------------------------------------- |
|
874 -- subscript_list - parse subscript list. |
|
875 -- |
|
876 -- This routine parses subscript list using the syntax: |
|
877 -- |
|
878 -- <subscript list> ::= <subscript> |
|
879 -- <subscript list> ::= <subscript list> , <subscript> |
|
880 -- <subscript> ::= <expression 5> */ |
|
881 |
|
882 ARG_LIST *subscript_list(MPL *mpl) |
|
883 { ARG_LIST *list; |
|
884 CODE *x; |
|
885 list = create_arg_list(mpl); |
|
886 for (;;) |
|
887 { /* parse subscript expression */ |
|
888 x = expression_5(mpl); |
|
889 /* convert it to symbolic type, if necessary */ |
|
890 if (x->type == A_NUMERIC) |
|
891 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); |
|
892 /* check that now the expression is of symbolic type */ |
|
893 if (x->type != A_SYMBOLIC) |
|
894 error(mpl, "subscript expression has invalid type"); |
|
895 xassert(x->dim == 0); |
|
896 /* and append it to the subscript list */ |
|
897 list = expand_arg_list(mpl, list, x); |
|
898 /* check a token that follows the subscript expression */ |
|
899 if (mpl->token == T_COMMA) |
|
900 get_token(mpl /* , */); |
|
901 else if (mpl->token == T_RBRACKET) |
|
902 break; |
|
903 else |
|
904 error(mpl, "syntax error in subscript list"); |
|
905 } |
|
906 return list; |
|
907 } |
|
908 |
|
909 #if 1 /* 15/V-2010 */ |
|
910 /*---------------------------------------------------------------------- |
|
911 -- object_reference - parse reference to named object. |
|
912 -- |
|
913 -- This routine parses primary expression using the syntax: |
|
914 -- |
|
915 -- <primary expression> ::= <dummy index> |
|
916 -- <primary expression> ::= <set name> |
|
917 -- <primary expression> ::= <set name> [ <subscript list> ] |
|
918 -- <primary expression> ::= <parameter name> |
|
919 -- <primary expression> ::= <parameter name> [ <subscript list> ] |
|
920 -- <primary expression> ::= <variable name> <suffix> |
|
921 -- <primary expression> ::= <variable name> [ <subscript list> ] |
|
922 -- <suffix> |
|
923 -- <primary expression> ::= <constraint name> <suffix> |
|
924 -- <primary expression> ::= <constraint name> [ <subscript list> ] |
|
925 -- <suffix> |
|
926 -- <dummy index> ::= <symbolic name> |
|
927 -- <set name> ::= <symbolic name> |
|
928 -- <parameter name> ::= <symbolic name> |
|
929 -- <variable name> ::= <symbolic name> |
|
930 -- <constraint name> ::= <symbolic name> |
|
931 -- <suffix> ::= <empty> | .lb | .ub | .status | .val | .dual */ |
|
932 |
|
933 CODE *object_reference(MPL *mpl) |
|
934 { AVLNODE *node; |
|
935 DOMAIN_SLOT *slot; |
|
936 SET *set; |
|
937 PARAMETER *par; |
|
938 VARIABLE *var; |
|
939 CONSTRAINT *con; |
|
940 ARG_LIST *list; |
|
941 OPERANDS arg; |
|
942 CODE *code; |
|
943 char *name; |
|
944 int dim, suff; |
|
945 /* find the object in the symbolic name table */ |
|
946 xassert(mpl->token == T_NAME); |
|
947 node = avl_find_node(mpl->tree, mpl->image); |
|
948 if (node == NULL) |
|
949 error(mpl, "%s not defined", mpl->image); |
|
950 /* check the object type and obtain its dimension */ |
|
951 switch (avl_get_node_type(node)) |
|
952 { case A_INDEX: |
|
953 /* dummy index */ |
|
954 slot = (DOMAIN_SLOT *)avl_get_node_link(node); |
|
955 name = slot->name; |
|
956 dim = 0; |
|
957 break; |
|
958 case A_SET: |
|
959 /* model set */ |
|
960 set = (SET *)avl_get_node_link(node); |
|
961 name = set->name; |
|
962 dim = set->dim; |
|
963 /* if a set object is referenced in its own declaration and |
|
964 the dimen attribute is not specified yet, use dimen 1 by |
|
965 default */ |
|
966 if (set->dimen == 0) set->dimen = 1; |
|
967 break; |
|
968 case A_PARAMETER: |
|
969 /* model parameter */ |
|
970 par = (PARAMETER *)avl_get_node_link(node); |
|
971 name = par->name; |
|
972 dim = par->dim; |
|
973 break; |
|
974 case A_VARIABLE: |
|
975 /* model variable */ |
|
976 var = (VARIABLE *)avl_get_node_link(node); |
|
977 name = var->name; |
|
978 dim = var->dim; |
|
979 break; |
|
980 case A_CONSTRAINT: |
|
981 /* model constraint or objective */ |
|
982 con = (CONSTRAINT *)avl_get_node_link(node); |
|
983 name = con->name; |
|
984 dim = con->dim; |
|
985 break; |
|
986 default: |
|
987 xassert(node != node); |
|
988 } |
|
989 get_token(mpl /* <symbolic name> */); |
|
990 /* parse optional subscript list */ |
|
991 if (mpl->token == T_LBRACKET) |
|
992 { /* subscript list is specified */ |
|
993 if (dim == 0) |
|
994 error(mpl, "%s cannot be subscripted", name); |
|
995 get_token(mpl /* [ */); |
|
996 list = subscript_list(mpl); |
|
997 if (dim != arg_list_len(mpl, list)) |
|
998 error(mpl, "%s must have %d subscript%s rather than %d", |
|
999 name, dim, dim == 1 ? "" : "s", arg_list_len(mpl, list)); |
|
1000 xassert(mpl->token == T_RBRACKET); |
|
1001 get_token(mpl /* ] */); |
|
1002 } |
|
1003 else |
|
1004 { /* subscript list is not specified */ |
|
1005 if (dim != 0) |
|
1006 error(mpl, "%s must be subscripted", name); |
|
1007 list = create_arg_list(mpl); |
|
1008 } |
|
1009 /* parse optional suffix */ |
|
1010 if (!mpl->flag_s && avl_get_node_type(node) == A_VARIABLE) |
|
1011 suff = DOT_NONE; |
|
1012 else |
|
1013 suff = DOT_VAL; |
|
1014 if (mpl->token == T_POINT) |
|
1015 { get_token(mpl /* . */); |
|
1016 if (mpl->token != T_NAME) |
|
1017 error(mpl, "invalid use of period"); |
|
1018 if (!(avl_get_node_type(node) == A_VARIABLE || |
|
1019 avl_get_node_type(node) == A_CONSTRAINT)) |
|
1020 error(mpl, "%s cannot have a suffix", name); |
|
1021 if (strcmp(mpl->image, "lb") == 0) |
|
1022 suff = DOT_LB; |
|
1023 else if (strcmp(mpl->image, "ub") == 0) |
|
1024 suff = DOT_UB; |
|
1025 else if (strcmp(mpl->image, "status") == 0) |
|
1026 suff = DOT_STATUS; |
|
1027 else if (strcmp(mpl->image, "val") == 0) |
|
1028 suff = DOT_VAL; |
|
1029 else if (strcmp(mpl->image, "dual") == 0) |
|
1030 suff = DOT_DUAL; |
|
1031 else |
|
1032 error(mpl, "suffix .%s invalid", mpl->image); |
|
1033 get_token(mpl /* suffix */); |
|
1034 } |
|
1035 /* generate pseudo-code to take value of the object */ |
|
1036 switch (avl_get_node_type(node)) |
|
1037 { case A_INDEX: |
|
1038 arg.index.slot = slot; |
|
1039 arg.index.next = slot->list; |
|
1040 code = make_code(mpl, O_INDEX, &arg, A_SYMBOLIC, 0); |
|
1041 slot->list = code; |
|
1042 break; |
|
1043 case A_SET: |
|
1044 arg.set.set = set; |
|
1045 arg.set.list = list; |
|
1046 code = make_code(mpl, O_MEMSET, &arg, A_ELEMSET, |
|
1047 set->dimen); |
|
1048 break; |
|
1049 case A_PARAMETER: |
|
1050 arg.par.par = par; |
|
1051 arg.par.list = list; |
|
1052 if (par->type == A_SYMBOLIC) |
|
1053 code = make_code(mpl, O_MEMSYM, &arg, A_SYMBOLIC, 0); |
|
1054 else |
|
1055 code = make_code(mpl, O_MEMNUM, &arg, A_NUMERIC, 0); |
|
1056 break; |
|
1057 case A_VARIABLE: |
|
1058 if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL |
|
1059 || suff == DOT_DUAL)) |
|
1060 error(mpl, "invalid reference to status, primal value, o" |
|
1061 "r dual value of variable %s above solve statement", |
|
1062 var->name); |
|
1063 arg.var.var = var; |
|
1064 arg.var.list = list; |
|
1065 arg.var.suff = suff; |
|
1066 code = make_code(mpl, O_MEMVAR, &arg, suff == DOT_NONE ? |
|
1067 A_FORMULA : A_NUMERIC, 0); |
|
1068 break; |
|
1069 case A_CONSTRAINT: |
|
1070 if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL |
|
1071 || suff == DOT_DUAL)) |
|
1072 error(mpl, "invalid reference to status, primal value, o" |
|
1073 "r dual value of %s %s above solve statement", |
|
1074 con->type == A_CONSTRAINT ? "constraint" : "objective" |
|
1075 , con->name); |
|
1076 arg.con.con = con; |
|
1077 arg.con.list = list; |
|
1078 arg.con.suff = suff; |
|
1079 code = make_code(mpl, O_MEMCON, &arg, A_NUMERIC, 0); |
|
1080 break; |
|
1081 default: |
|
1082 xassert(node != node); |
|
1083 } |
|
1084 return code; |
|
1085 } |
|
1086 #endif |
|
1087 |
|
1088 /*---------------------------------------------------------------------- |
|
1089 -- numeric_argument - parse argument passed to built-in function. |
|
1090 -- |
|
1091 -- This routine parses an argument passed to numeric built-in function |
|
1092 -- using the syntax: |
|
1093 -- |
|
1094 -- <arg> ::= <expression 5> */ |
|
1095 |
|
1096 CODE *numeric_argument(MPL *mpl, char *func) |
|
1097 { CODE *x; |
|
1098 x = expression_5(mpl); |
|
1099 /* convert the argument to numeric type, if necessary */ |
|
1100 if (x->type == A_SYMBOLIC) |
|
1101 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
1102 /* check that now the argument is of numeric type */ |
|
1103 if (x->type != A_NUMERIC) |
|
1104 error(mpl, "argument for %s has invalid type", func); |
|
1105 xassert(x->dim == 0); |
|
1106 return x; |
|
1107 } |
|
1108 |
|
1109 #if 1 /* 15/VII-2006 */ |
|
1110 CODE *symbolic_argument(MPL *mpl, char *func) |
|
1111 { CODE *x; |
|
1112 x = expression_5(mpl); |
|
1113 /* convert the argument to symbolic type, if necessary */ |
|
1114 if (x->type == A_NUMERIC) |
|
1115 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); |
|
1116 /* check that now the argument is of symbolic type */ |
|
1117 if (x->type != A_SYMBOLIC) |
|
1118 error(mpl, "argument for %s has invalid type", func); |
|
1119 xassert(x->dim == 0); |
|
1120 return x; |
|
1121 } |
|
1122 #endif |
|
1123 |
|
1124 #if 1 /* 15/VII-2006 */ |
|
1125 CODE *elemset_argument(MPL *mpl, char *func) |
|
1126 { CODE *x; |
|
1127 x = expression_9(mpl); |
|
1128 if (x->type != A_ELEMSET) |
|
1129 error(mpl, "argument for %s has invalid type", func); |
|
1130 xassert(x->dim > 0); |
|
1131 return x; |
|
1132 } |
|
1133 #endif |
|
1134 |
|
1135 /*---------------------------------------------------------------------- |
|
1136 -- function_reference - parse reference to built-in function. |
|
1137 -- |
|
1138 -- This routine parses primary expression using the syntax: |
|
1139 -- |
|
1140 -- <primary expression> ::= abs ( <arg> ) |
|
1141 -- <primary expression> ::= ceil ( <arg> ) |
|
1142 -- <primary expression> ::= floor ( <arg> ) |
|
1143 -- <primary expression> ::= exp ( <arg> ) |
|
1144 -- <primary expression> ::= log ( <arg> ) |
|
1145 -- <primary expression> ::= log10 ( <arg> ) |
|
1146 -- <primary expression> ::= max ( <arg list> ) |
|
1147 -- <primary expression> ::= min ( <arg list> ) |
|
1148 -- <primary expression> ::= sqrt ( <arg> ) |
|
1149 -- <primary expression> ::= sin ( <arg> ) |
|
1150 -- <primary expression> ::= cos ( <arg> ) |
|
1151 -- <primary expression> ::= atan ( <arg> ) |
|
1152 -- <primary expression> ::= atan2 ( <arg> , <arg> ) |
|
1153 -- <primary expression> ::= round ( <arg> ) |
|
1154 -- <primary expression> ::= round ( <arg> , <arg> ) |
|
1155 -- <primary expression> ::= trunc ( <arg> ) |
|
1156 -- <primary expression> ::= trunc ( <arg> , <arg> ) |
|
1157 -- <primary expression> ::= Irand224 ( ) |
|
1158 -- <primary expression> ::= Uniform01 ( ) |
|
1159 -- <primary expression> ::= Uniform ( <arg> , <arg> ) |
|
1160 -- <primary expression> ::= Normal01 ( ) |
|
1161 -- <primary expression> ::= Normal ( <arg> , <arg> ) |
|
1162 -- <primary expression> ::= card ( <arg> ) |
|
1163 -- <primary expression> ::= length ( <arg> ) |
|
1164 -- <primary expression> ::= substr ( <arg> , <arg> ) |
|
1165 -- <primary expression> ::= substr ( <arg> , <arg> , <arg> ) |
|
1166 -- <primary expression> ::= str2time ( <arg> , <arg> ) |
|
1167 -- <primary expression> ::= time2str ( <arg> , <arg> ) |
|
1168 -- <primary expression> ::= gmtime ( ) |
|
1169 -- <arg list> ::= <arg> |
|
1170 -- <arg list> ::= <arg list> , <arg> */ |
|
1171 |
|
1172 CODE *function_reference(MPL *mpl) |
|
1173 { CODE *code; |
|
1174 OPERANDS arg; |
|
1175 int op; |
|
1176 char func[15+1]; |
|
1177 /* determine operation code */ |
|
1178 xassert(mpl->token == T_NAME); |
|
1179 if (strcmp(mpl->image, "abs") == 0) |
|
1180 op = O_ABS; |
|
1181 else if (strcmp(mpl->image, "ceil") == 0) |
|
1182 op = O_CEIL; |
|
1183 else if (strcmp(mpl->image, "floor") == 0) |
|
1184 op = O_FLOOR; |
|
1185 else if (strcmp(mpl->image, "exp") == 0) |
|
1186 op = O_EXP; |
|
1187 else if (strcmp(mpl->image, "log") == 0) |
|
1188 op = O_LOG; |
|
1189 else if (strcmp(mpl->image, "log10") == 0) |
|
1190 op = O_LOG10; |
|
1191 else if (strcmp(mpl->image, "sqrt") == 0) |
|
1192 op = O_SQRT; |
|
1193 else if (strcmp(mpl->image, "sin") == 0) |
|
1194 op = O_SIN; |
|
1195 else if (strcmp(mpl->image, "cos") == 0) |
|
1196 op = O_COS; |
|
1197 else if (strcmp(mpl->image, "atan") == 0) |
|
1198 op = O_ATAN; |
|
1199 else if (strcmp(mpl->image, "min") == 0) |
|
1200 op = O_MIN; |
|
1201 else if (strcmp(mpl->image, "max") == 0) |
|
1202 op = O_MAX; |
|
1203 else if (strcmp(mpl->image, "round") == 0) |
|
1204 op = O_ROUND; |
|
1205 else if (strcmp(mpl->image, "trunc") == 0) |
|
1206 op = O_TRUNC; |
|
1207 else if (strcmp(mpl->image, "Irand224") == 0) |
|
1208 op = O_IRAND224; |
|
1209 else if (strcmp(mpl->image, "Uniform01") == 0) |
|
1210 op = O_UNIFORM01; |
|
1211 else if (strcmp(mpl->image, "Uniform") == 0) |
|
1212 op = O_UNIFORM; |
|
1213 else if (strcmp(mpl->image, "Normal01") == 0) |
|
1214 op = O_NORMAL01; |
|
1215 else if (strcmp(mpl->image, "Normal") == 0) |
|
1216 op = O_NORMAL; |
|
1217 else if (strcmp(mpl->image, "card") == 0) |
|
1218 op = O_CARD; |
|
1219 else if (strcmp(mpl->image, "length") == 0) |
|
1220 op = O_LENGTH; |
|
1221 else if (strcmp(mpl->image, "substr") == 0) |
|
1222 op = O_SUBSTR; |
|
1223 else if (strcmp(mpl->image, "str2time") == 0) |
|
1224 op = O_STR2TIME; |
|
1225 else if (strcmp(mpl->image, "time2str") == 0) |
|
1226 op = O_TIME2STR; |
|
1227 else if (strcmp(mpl->image, "gmtime") == 0) |
|
1228 op = O_GMTIME; |
|
1229 else |
|
1230 error(mpl, "function %s unknown", mpl->image); |
|
1231 /* save symbolic name of the function */ |
|
1232 strcpy(func, mpl->image); |
|
1233 xassert(strlen(func) < sizeof(func)); |
|
1234 get_token(mpl /* <symbolic name> */); |
|
1235 /* check the left parenthesis that follows the function name */ |
|
1236 xassert(mpl->token == T_LEFT); |
|
1237 get_token(mpl /* ( */); |
|
1238 /* parse argument list */ |
|
1239 if (op == O_MIN || op == O_MAX) |
|
1240 { /* min and max allow arbitrary number of arguments */ |
|
1241 arg.list = create_arg_list(mpl); |
|
1242 /* parse argument list */ |
|
1243 for (;;) |
|
1244 { /* parse argument and append it to the operands list */ |
|
1245 arg.list = expand_arg_list(mpl, arg.list, |
|
1246 numeric_argument(mpl, func)); |
|
1247 /* check a token that follows the argument */ |
|
1248 if (mpl->token == T_COMMA) |
|
1249 get_token(mpl /* , */); |
|
1250 else if (mpl->token == T_RIGHT) |
|
1251 break; |
|
1252 else |
|
1253 error(mpl, "syntax error in argument list for %s", func); |
|
1254 } |
|
1255 } |
|
1256 else if (op == O_IRAND224 || op == O_UNIFORM01 || op == |
|
1257 O_NORMAL01 || op == O_GMTIME) |
|
1258 { /* Irand224, Uniform01, Normal01, gmtime need no arguments */ |
|
1259 if (mpl->token != T_RIGHT) |
|
1260 error(mpl, "%s needs no arguments", func); |
|
1261 } |
|
1262 else if (op == O_UNIFORM || op == O_NORMAL) |
|
1263 { /* Uniform and Normal need two arguments */ |
|
1264 /* parse the first argument */ |
|
1265 arg.arg.x = numeric_argument(mpl, func); |
|
1266 /* check a token that follows the first argument */ |
|
1267 if (mpl->token == T_COMMA) |
|
1268 ; |
|
1269 else if (mpl->token == T_RIGHT) |
|
1270 error(mpl, "%s needs two arguments", func); |
|
1271 else |
|
1272 error(mpl, "syntax error in argument for %s", func); |
|
1273 get_token(mpl /* , */); |
|
1274 /* parse the second argument */ |
|
1275 arg.arg.y = numeric_argument(mpl, func); |
|
1276 /* check a token that follows the second argument */ |
|
1277 if (mpl->token == T_COMMA) |
|
1278 error(mpl, "%s needs two argument", func); |
|
1279 else if (mpl->token == T_RIGHT) |
|
1280 ; |
|
1281 else |
|
1282 error(mpl, "syntax error in argument for %s", func); |
|
1283 } |
|
1284 else if (op == O_ATAN || op == O_ROUND || op == O_TRUNC) |
|
1285 { /* atan, round, and trunc need one or two arguments */ |
|
1286 /* parse the first argument */ |
|
1287 arg.arg.x = numeric_argument(mpl, func); |
|
1288 /* parse the second argument, if specified */ |
|
1289 if (mpl->token == T_COMMA) |
|
1290 { switch (op) |
|
1291 { case O_ATAN: op = O_ATAN2; break; |
|
1292 case O_ROUND: op = O_ROUND2; break; |
|
1293 case O_TRUNC: op = O_TRUNC2; break; |
|
1294 default: xassert(op != op); |
|
1295 } |
|
1296 get_token(mpl /* , */); |
|
1297 arg.arg.y = numeric_argument(mpl, func); |
|
1298 } |
|
1299 /* check a token that follows the last argument */ |
|
1300 if (mpl->token == T_COMMA) |
|
1301 error(mpl, "%s needs one or two arguments", func); |
|
1302 else if (mpl->token == T_RIGHT) |
|
1303 ; |
|
1304 else |
|
1305 error(mpl, "syntax error in argument for %s", func); |
|
1306 } |
|
1307 else if (op == O_SUBSTR) |
|
1308 { /* substr needs two or three arguments */ |
|
1309 /* parse the first argument */ |
|
1310 arg.arg.x = symbolic_argument(mpl, func); |
|
1311 /* check a token that follows the first argument */ |
|
1312 if (mpl->token == T_COMMA) |
|
1313 ; |
|
1314 else if (mpl->token == T_RIGHT) |
|
1315 error(mpl, "%s needs two or three arguments", func); |
|
1316 else |
|
1317 error(mpl, "syntax error in argument for %s", func); |
|
1318 get_token(mpl /* , */); |
|
1319 /* parse the second argument */ |
|
1320 arg.arg.y = numeric_argument(mpl, func); |
|
1321 /* parse the third argument, if specified */ |
|
1322 if (mpl->token == T_COMMA) |
|
1323 { op = O_SUBSTR3; |
|
1324 get_token(mpl /* , */); |
|
1325 arg.arg.z = numeric_argument(mpl, func); |
|
1326 } |
|
1327 /* check a token that follows the last argument */ |
|
1328 if (mpl->token == T_COMMA) |
|
1329 error(mpl, "%s needs two or three arguments", func); |
|
1330 else if (mpl->token == T_RIGHT) |
|
1331 ; |
|
1332 else |
|
1333 error(mpl, "syntax error in argument for %s", func); |
|
1334 } |
|
1335 else if (op == O_STR2TIME) |
|
1336 { /* str2time needs two arguments, both symbolic */ |
|
1337 /* parse the first argument */ |
|
1338 arg.arg.x = symbolic_argument(mpl, func); |
|
1339 /* check a token that follows the first argument */ |
|
1340 if (mpl->token == T_COMMA) |
|
1341 ; |
|
1342 else if (mpl->token == T_RIGHT) |
|
1343 error(mpl, "%s needs two arguments", func); |
|
1344 else |
|
1345 error(mpl, "syntax error in argument for %s", func); |
|
1346 get_token(mpl /* , */); |
|
1347 /* parse the second argument */ |
|
1348 arg.arg.y = symbolic_argument(mpl, func); |
|
1349 /* check a token that follows the second argument */ |
|
1350 if (mpl->token == T_COMMA) |
|
1351 error(mpl, "%s needs two argument", func); |
|
1352 else if (mpl->token == T_RIGHT) |
|
1353 ; |
|
1354 else |
|
1355 error(mpl, "syntax error in argument for %s", func); |
|
1356 } |
|
1357 else if (op == O_TIME2STR) |
|
1358 { /* time2str needs two arguments, numeric and symbolic */ |
|
1359 /* parse the first argument */ |
|
1360 arg.arg.x = numeric_argument(mpl, func); |
|
1361 /* check a token that follows the first argument */ |
|
1362 if (mpl->token == T_COMMA) |
|
1363 ; |
|
1364 else if (mpl->token == T_RIGHT) |
|
1365 error(mpl, "%s needs two arguments", func); |
|
1366 else |
|
1367 error(mpl, "syntax error in argument for %s", func); |
|
1368 get_token(mpl /* , */); |
|
1369 /* parse the second argument */ |
|
1370 arg.arg.y = symbolic_argument(mpl, func); |
|
1371 /* check a token that follows the second argument */ |
|
1372 if (mpl->token == T_COMMA) |
|
1373 error(mpl, "%s needs two argument", func); |
|
1374 else if (mpl->token == T_RIGHT) |
|
1375 ; |
|
1376 else |
|
1377 error(mpl, "syntax error in argument for %s", func); |
|
1378 } |
|
1379 else |
|
1380 { /* other functions need one argument */ |
|
1381 if (op == O_CARD) |
|
1382 arg.arg.x = elemset_argument(mpl, func); |
|
1383 else if (op == O_LENGTH) |
|
1384 arg.arg.x = symbolic_argument(mpl, func); |
|
1385 else |
|
1386 arg.arg.x = numeric_argument(mpl, func); |
|
1387 /* check a token that follows the argument */ |
|
1388 if (mpl->token == T_COMMA) |
|
1389 error(mpl, "%s needs one argument", func); |
|
1390 else if (mpl->token == T_RIGHT) |
|
1391 ; |
|
1392 else |
|
1393 error(mpl, "syntax error in argument for %s", func); |
|
1394 } |
|
1395 /* make pseudo-code to call the built-in function */ |
|
1396 if (op == O_SUBSTR || op == O_SUBSTR3 || op == O_TIME2STR) |
|
1397 code = make_code(mpl, op, &arg, A_SYMBOLIC, 0); |
|
1398 else |
|
1399 code = make_code(mpl, op, &arg, A_NUMERIC, 0); |
|
1400 /* the reference ends with the right parenthesis */ |
|
1401 xassert(mpl->token == T_RIGHT); |
|
1402 get_token(mpl /* ) */); |
|
1403 return code; |
|
1404 } |
|
1405 |
|
1406 /*---------------------------------------------------------------------- |
|
1407 -- create_domain - create empty domain. |
|
1408 -- |
|
1409 -- This routine creates empty domain, which is initially empty, i.e. |
|
1410 -- has no domain blocks. */ |
|
1411 |
|
1412 DOMAIN *create_domain(MPL *mpl) |
|
1413 { DOMAIN *domain; |
|
1414 domain = alloc(DOMAIN); |
|
1415 domain->list = NULL; |
|
1416 domain->code = NULL; |
|
1417 return domain; |
|
1418 } |
|
1419 |
|
1420 /*---------------------------------------------------------------------- |
|
1421 -- create_block - create empty domain block. |
|
1422 -- |
|
1423 -- This routine creates empty domain block, which is initially empty, |
|
1424 -- i.e. has no domain slots. */ |
|
1425 |
|
1426 DOMAIN_BLOCK *create_block(MPL *mpl) |
|
1427 { DOMAIN_BLOCK *block; |
|
1428 block = alloc(DOMAIN_BLOCK); |
|
1429 block->list = NULL; |
|
1430 block->code = NULL; |
|
1431 block->backup = NULL; |
|
1432 block->next = NULL; |
|
1433 return block; |
|
1434 } |
|
1435 |
|
1436 /*---------------------------------------------------------------------- |
|
1437 -- append_block - append domain block to specified domain. |
|
1438 -- |
|
1439 -- This routine adds given domain block to the end of the block list of |
|
1440 -- specified domain. */ |
|
1441 |
|
1442 void append_block(MPL *mpl, DOMAIN *domain, DOMAIN_BLOCK *block) |
|
1443 { DOMAIN_BLOCK *temp; |
|
1444 xassert(mpl == mpl); |
|
1445 xassert(domain != NULL); |
|
1446 xassert(block != NULL); |
|
1447 xassert(block->next == NULL); |
|
1448 if (domain->list == NULL) |
|
1449 domain->list = block; |
|
1450 else |
|
1451 { for (temp = domain->list; temp->next != NULL; temp = |
|
1452 temp->next); |
|
1453 temp->next = block; |
|
1454 } |
|
1455 return; |
|
1456 } |
|
1457 |
|
1458 /*---------------------------------------------------------------------- |
|
1459 -- append_slot - create and append new slot to domain block. |
|
1460 -- |
|
1461 -- This routine creates new domain slot and adds it to the end of slot |
|
1462 -- list of specified domain block. |
|
1463 -- |
|
1464 -- The parameter name is symbolic name of the dummy index associated |
|
1465 -- with the slot (the character string must be allocated). NULL means |
|
1466 -- the dummy index is not explicitly specified. |
|
1467 -- |
|
1468 -- The parameter code is pseudo-code for computing symbolic value, at |
|
1469 -- which the dummy index is bounded. NULL means the dummy index is free |
|
1470 -- in the domain scope. */ |
|
1471 |
|
1472 DOMAIN_SLOT *append_slot(MPL *mpl, DOMAIN_BLOCK *block, char *name, |
|
1473 CODE *code) |
|
1474 { DOMAIN_SLOT *slot, *temp; |
|
1475 xassert(block != NULL); |
|
1476 slot = alloc(DOMAIN_SLOT); |
|
1477 slot->name = name; |
|
1478 slot->code = code; |
|
1479 slot->value = NULL; |
|
1480 slot->list = NULL; |
|
1481 slot->next = NULL; |
|
1482 if (block->list == NULL) |
|
1483 block->list = slot; |
|
1484 else |
|
1485 { for (temp = block->list; temp->next != NULL; temp = |
|
1486 temp->next); |
|
1487 temp->next = slot; |
|
1488 } |
|
1489 return slot; |
|
1490 } |
|
1491 |
|
1492 /*---------------------------------------------------------------------- |
|
1493 -- expression_list - parse expression list. |
|
1494 -- |
|
1495 -- This routine parses a list of one or more expressions enclosed into |
|
1496 -- the parentheses using the syntax: |
|
1497 -- |
|
1498 -- <primary expression> ::= ( <expression list> ) |
|
1499 -- <expression list> ::= <expression 13> |
|
1500 -- <expression list> ::= <expression 13> , <expression list> |
|
1501 -- |
|
1502 -- Note that this construction may have three different meanings: |
|
1503 -- |
|
1504 -- 1. If <expression list> consists of only one expression, <primary |
|
1505 -- expression> is a parenthesized expression, which may be of any |
|
1506 -- valid type (not necessarily 1-tuple). |
|
1507 -- |
|
1508 -- 2. If <expression list> consists of several expressions separated by |
|
1509 -- commae, where no expression is undeclared symbolic name, <primary |
|
1510 -- expression> is a n-tuple. |
|
1511 -- |
|
1512 -- 3. If <expression list> consists of several expressions separated by |
|
1513 -- commae, where at least one expression is undeclared symbolic name |
|
1514 -- (that denotes a dummy index), <primary expression> is a slice and |
|
1515 -- can be only used as constituent of indexing expression. */ |
|
1516 |
|
1517 #define max_dim 20 |
|
1518 /* maximal number of components allowed within parentheses */ |
|
1519 |
|
1520 CODE *expression_list(MPL *mpl) |
|
1521 { CODE *code; |
|
1522 OPERANDS arg; |
|
1523 struct { char *name; CODE *code; } list[1+max_dim]; |
|
1524 int flag_x, next_token, dim, j, slice = 0; |
|
1525 xassert(mpl->token == T_LEFT); |
|
1526 /* the flag, which allows recognizing undeclared symbolic names |
|
1527 as dummy indices, will be automatically reset by get_token(), |
|
1528 so save it before scanning the next token */ |
|
1529 flag_x = mpl->flag_x; |
|
1530 get_token(mpl /* ( */); |
|
1531 /* parse <expression list> */ |
|
1532 for (dim = 1; ; dim++) |
|
1533 { if (dim > max_dim) |
|
1534 error(mpl, "too many components within parentheses"); |
|
1535 /* current component of <expression list> can be either dummy |
|
1536 index or expression */ |
|
1537 if (mpl->token == T_NAME) |
|
1538 { /* symbolic name is recognized as dummy index only if: |
|
1539 the flag, which allows that, is set, and |
|
1540 the name is followed by comma or right parenthesis, and |
|
1541 the name is undeclared */ |
|
1542 get_token(mpl /* <symbolic name> */); |
|
1543 next_token = mpl->token; |
|
1544 unget_token(mpl); |
|
1545 if (!(flag_x && |
|
1546 (next_token == T_COMMA || next_token == T_RIGHT) && |
|
1547 avl_find_node(mpl->tree, mpl->image) == NULL)) |
|
1548 { /* this is not dummy index */ |
|
1549 goto expr; |
|
1550 } |
|
1551 /* all dummy indices within the same slice must have unique |
|
1552 symbolic names */ |
|
1553 for (j = 1; j < dim; j++) |
|
1554 { if (list[j].name != NULL && strcmp(list[j].name, |
|
1555 mpl->image) == 0) |
|
1556 error(mpl, "duplicate dummy index %s not allowed", |
|
1557 mpl->image); |
|
1558 } |
|
1559 /* current component of <expression list> is dummy index */ |
|
1560 list[dim].name |
|
1561 = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
1562 strcpy(list[dim].name, mpl->image); |
|
1563 list[dim].code = NULL; |
|
1564 get_token(mpl /* <symbolic name> */); |
|
1565 /* <expression list> is a slice, because at least one dummy |
|
1566 index has appeared */ |
|
1567 slice = 1; |
|
1568 /* note that the context ( <dummy index> ) is not allowed, |
|
1569 i.e. in this case <primary expression> is considered as |
|
1570 a parenthesized expression */ |
|
1571 if (dim == 1 && mpl->token == T_RIGHT) |
|
1572 error(mpl, "%s not defined", list[dim].name); |
|
1573 } |
|
1574 else |
|
1575 expr: { /* current component of <expression list> is expression */ |
|
1576 code = expression_13(mpl); |
|
1577 /* if the current expression is followed by comma or it is |
|
1578 not the very first expression, entire <expression list> |
|
1579 is n-tuple or slice, in which case the current expression |
|
1580 should be converted to symbolic type, if necessary */ |
|
1581 if (mpl->token == T_COMMA || dim > 1) |
|
1582 { if (code->type == A_NUMERIC) |
|
1583 code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0); |
|
1584 /* now the expression must be of symbolic type */ |
|
1585 if (code->type != A_SYMBOLIC) |
|
1586 error(mpl, "component expression has invalid type"); |
|
1587 xassert(code->dim == 0); |
|
1588 } |
|
1589 list[dim].name = NULL; |
|
1590 list[dim].code = code; |
|
1591 } |
|
1592 /* check a token that follows the current component */ |
|
1593 if (mpl->token == T_COMMA) |
|
1594 get_token(mpl /* , */); |
|
1595 else if (mpl->token == T_RIGHT) |
|
1596 break; |
|
1597 else |
|
1598 error(mpl, "right parenthesis missing where expected"); |
|
1599 } |
|
1600 /* generate pseudo-code for <primary expression> */ |
|
1601 if (dim == 1 && !slice) |
|
1602 { /* <primary expression> is a parenthesized expression */ |
|
1603 code = list[1].code; |
|
1604 } |
|
1605 else if (!slice) |
|
1606 { /* <primary expression> is a n-tuple */ |
|
1607 arg.list = create_arg_list(mpl); |
|
1608 for (j = 1; j <= dim; j++) |
|
1609 arg.list = expand_arg_list(mpl, arg.list, list[j].code); |
|
1610 code = make_code(mpl, O_TUPLE, &arg, A_TUPLE, dim); |
|
1611 } |
|
1612 else |
|
1613 { /* <primary expression> is a slice */ |
|
1614 arg.slice = create_block(mpl); |
|
1615 for (j = 1; j <= dim; j++) |
|
1616 append_slot(mpl, arg.slice, list[j].name, list[j].code); |
|
1617 /* note that actually pseudo-codes with op = O_SLICE are never |
|
1618 evaluated */ |
|
1619 code = make_code(mpl, O_SLICE, &arg, A_TUPLE, dim); |
|
1620 } |
|
1621 get_token(mpl /* ) */); |
|
1622 /* if <primary expression> is a slice, there must be the keyword |
|
1623 'in', which follows the right parenthesis */ |
|
1624 if (slice && mpl->token != T_IN) |
|
1625 error(mpl, "keyword in missing where expected"); |
|
1626 /* if the slice flag is set and there is the keyword 'in', which |
|
1627 follows <primary expression>, the latter must be a slice */ |
|
1628 if (flag_x && mpl->token == T_IN && !slice) |
|
1629 { if (dim == 1) |
|
1630 error(mpl, "syntax error in indexing expression"); |
|
1631 else |
|
1632 error(mpl, "0-ary slice not allowed"); |
|
1633 } |
|
1634 return code; |
|
1635 } |
|
1636 |
|
1637 /*---------------------------------------------------------------------- |
|
1638 -- literal set - parse literal set. |
|
1639 -- |
|
1640 -- This routine parses literal set using the syntax: |
|
1641 -- |
|
1642 -- <literal set> ::= { <member list> } |
|
1643 -- <member list> ::= <member expression> |
|
1644 -- <member list> ::= <member list> , <member expression> |
|
1645 -- <member expression> ::= <expression 5> |
|
1646 -- |
|
1647 -- It is assumed that the left curly brace and the very first member |
|
1648 -- expression that follows it are already parsed. The right curly brace |
|
1649 -- remains unscanned on exit. */ |
|
1650 |
|
1651 CODE *literal_set(MPL *mpl, CODE *code) |
|
1652 { OPERANDS arg; |
|
1653 int j; |
|
1654 xassert(code != NULL); |
|
1655 arg.list = create_arg_list(mpl); |
|
1656 /* parse <member list> */ |
|
1657 for (j = 1; ; j++) |
|
1658 { /* all member expressions must be n-tuples; so, if the current |
|
1659 expression is not n-tuple, convert it to 1-tuple */ |
|
1660 if (code->type == A_NUMERIC) |
|
1661 code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0); |
|
1662 if (code->type == A_SYMBOLIC) |
|
1663 code = make_unary(mpl, O_CVTTUP, code, A_TUPLE, 1); |
|
1664 /* now the expression must be n-tuple */ |
|
1665 if (code->type != A_TUPLE) |
|
1666 error(mpl, "member expression has invalid type"); |
|
1667 /* all member expressions must have identical dimension */ |
|
1668 if (arg.list != NULL && arg.list->x->dim != code->dim) |
|
1669 error(mpl, "member %d has %d component%s while member %d ha" |
|
1670 "s %d component%s", |
|
1671 j-1, arg.list->x->dim, arg.list->x->dim == 1 ? "" : "s", |
|
1672 j, code->dim, code->dim == 1 ? "" : "s"); |
|
1673 /* append the current expression to the member list */ |
|
1674 arg.list = expand_arg_list(mpl, arg.list, code); |
|
1675 /* check a token that follows the current expression */ |
|
1676 if (mpl->token == T_COMMA) |
|
1677 get_token(mpl /* , */); |
|
1678 else if (mpl->token == T_RBRACE) |
|
1679 break; |
|
1680 else |
|
1681 error(mpl, "syntax error in literal set"); |
|
1682 /* parse the next expression that follows the comma */ |
|
1683 code = expression_5(mpl); |
|
1684 } |
|
1685 /* generate pseudo-code for <literal set> */ |
|
1686 code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, arg.list->x->dim); |
|
1687 return code; |
|
1688 } |
|
1689 |
|
1690 /*---------------------------------------------------------------------- |
|
1691 -- indexing_expression - parse indexing expression. |
|
1692 -- |
|
1693 -- This routine parses indexing expression using the syntax: |
|
1694 -- |
|
1695 -- <indexing expression> ::= <literal set> |
|
1696 -- <indexing expression> ::= { <indexing list> } |
|
1697 -- <indexing expression> ::= { <indexing list> : <logical expression> } |
|
1698 -- <indexing list> ::= <indexing element> |
|
1699 -- <indexing list> ::= <indexing list> , <indexing element> |
|
1700 -- <indexing element> ::= <basic expression> |
|
1701 -- <indexing element> ::= <dummy index> in <basic expression> |
|
1702 -- <indexing element> ::= <slice> in <basic expression> |
|
1703 -- <dummy index> ::= <symbolic name> |
|
1704 -- <slice> ::= ( <expression list> ) |
|
1705 -- <basic expression> ::= <expression 9> |
|
1706 -- <logical expression> ::= <expression 13> |
|
1707 -- |
|
1708 -- This routine creates domain for <indexing expression>, where each |
|
1709 -- domain block corresponds to <indexing element>, and each domain slot |
|
1710 -- corresponds to individual indexing position. */ |
|
1711 |
|
1712 DOMAIN *indexing_expression(MPL *mpl) |
|
1713 { DOMAIN *domain; |
|
1714 DOMAIN_BLOCK *block; |
|
1715 DOMAIN_SLOT *slot; |
|
1716 CODE *code; |
|
1717 xassert(mpl->token == T_LBRACE); |
|
1718 get_token(mpl /* { */); |
|
1719 if (mpl->token == T_RBRACE) |
|
1720 error(mpl, "empty indexing expression not allowed"); |
|
1721 /* create domain to be constructed */ |
|
1722 domain = create_domain(mpl); |
|
1723 /* parse either <member list> or <indexing list> that follows the |
|
1724 left brace */ |
|
1725 for (;;) |
|
1726 { /* domain block for <indexing element> is not created yet */ |
|
1727 block = NULL; |
|
1728 /* pseudo-code for <basic expression> is not generated yet */ |
|
1729 code = NULL; |
|
1730 /* check a token, which <indexing element> begins with */ |
|
1731 if (mpl->token == T_NAME) |
|
1732 { /* it is a symbolic name */ |
|
1733 int next_token; |
|
1734 char *name; |
|
1735 /* symbolic name is recognized as dummy index only if it is |
|
1736 followed by the keyword 'in' and not declared */ |
|
1737 get_token(mpl /* <symbolic name> */); |
|
1738 next_token = mpl->token; |
|
1739 unget_token(mpl); |
|
1740 if (!(next_token == T_IN && |
|
1741 avl_find_node(mpl->tree, mpl->image) == NULL)) |
|
1742 { /* this is not dummy index; the symbolic name begins an |
|
1743 expression, which is either <basic expression> or the |
|
1744 very first <member expression> in <literal set> */ |
|
1745 goto expr; |
|
1746 } |
|
1747 /* create domain block with one slot, which is assigned the |
|
1748 dummy index */ |
|
1749 block = create_block(mpl); |
|
1750 name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
1751 strcpy(name, mpl->image); |
|
1752 append_slot(mpl, block, name, NULL); |
|
1753 get_token(mpl /* <symbolic name> */); |
|
1754 /* the keyword 'in' is already checked above */ |
|
1755 xassert(mpl->token == T_IN); |
|
1756 get_token(mpl /* in */); |
|
1757 /* <basic expression> that follows the keyword 'in' will be |
|
1758 parsed below */ |
|
1759 } |
|
1760 else if (mpl->token == T_LEFT) |
|
1761 { /* it is the left parenthesis; parse expression that begins |
|
1762 with this parenthesis (the flag is set in order to allow |
|
1763 recognizing slices; see the routine expression_list) */ |
|
1764 mpl->flag_x = 1; |
|
1765 code = expression_9(mpl); |
|
1766 if (code->op != O_SLICE) |
|
1767 { /* this is either <basic expression> or the very first |
|
1768 <member expression> in <literal set> */ |
|
1769 goto expr; |
|
1770 } |
|
1771 /* this is a slice; besides the corresponding domain block |
|
1772 is already created by expression_list() */ |
|
1773 block = code->arg.slice; |
|
1774 code = NULL; /* <basic expression> is not parsed yet */ |
|
1775 /* the keyword 'in' following the slice is already checked |
|
1776 by expression_list() */ |
|
1777 xassert(mpl->token == T_IN); |
|
1778 get_token(mpl /* in */); |
|
1779 /* <basic expression> that follows the keyword 'in' will be |
|
1780 parsed below */ |
|
1781 } |
|
1782 expr: /* parse expression that follows either the keyword 'in' (in |
|
1783 which case it can be <basic expression) or the left brace |
|
1784 (in which case it can be <basic expression> as well as the |
|
1785 very first <member expression> in <literal set>); note that |
|
1786 this expression can be already parsed above */ |
|
1787 if (code == NULL) code = expression_9(mpl); |
|
1788 /* check the type of the expression just parsed */ |
|
1789 if (code->type != A_ELEMSET) |
|
1790 { /* it is not <basic expression> and therefore it can only |
|
1791 be the very first <member expression> in <literal set>; |
|
1792 however, then there must be no dummy index neither slice |
|
1793 between the left brace and this expression */ |
|
1794 if (block != NULL) |
|
1795 error(mpl, "domain expression has invalid type"); |
|
1796 /* parse the rest part of <literal set> and make this set |
|
1797 be <basic expression>, i.e. the construction {a, b, c} |
|
1798 is parsed as it were written as {A}, where A = {a, b, c} |
|
1799 is a temporary elemental set */ |
|
1800 code = literal_set(mpl, code); |
|
1801 } |
|
1802 /* now pseudo-code for <basic set> has been built */ |
|
1803 xassert(code != NULL); |
|
1804 xassert(code->type == A_ELEMSET); |
|
1805 xassert(code->dim > 0); |
|
1806 /* if domain block for the current <indexing element> is still |
|
1807 not created, create it for fake slice of the same dimension |
|
1808 as <basic set> */ |
|
1809 if (block == NULL) |
|
1810 { int j; |
|
1811 block = create_block(mpl); |
|
1812 for (j = 1; j <= code->dim; j++) |
|
1813 append_slot(mpl, block, NULL, NULL); |
|
1814 } |
|
1815 /* number of indexing positions in <indexing element> must be |
|
1816 the same as dimension of n-tuples in basic set */ |
|
1817 { int dim = 0; |
|
1818 for (slot = block->list; slot != NULL; slot = slot->next) |
|
1819 dim++; |
|
1820 if (dim != code->dim) |
|
1821 error(mpl,"%d %s specified for set of dimension %d", |
|
1822 dim, dim == 1 ? "index" : "indices", code->dim); |
|
1823 } |
|
1824 /* store pseudo-code for <basic set> in the domain block */ |
|
1825 xassert(block->code == NULL); |
|
1826 block->code = code; |
|
1827 /* and append the domain block to the domain */ |
|
1828 append_block(mpl, domain, block); |
|
1829 /* the current <indexing element> has been completely parsed; |
|
1830 include all its dummy indices into the symbolic name table |
|
1831 to make them available for referencing from expressions; |
|
1832 implicit declarations of dummy indices remain valid while |
|
1833 the corresponding domain scope is valid */ |
|
1834 for (slot = block->list; slot != NULL; slot = slot->next) |
|
1835 if (slot->name != NULL) |
|
1836 { AVLNODE *node; |
|
1837 xassert(avl_find_node(mpl->tree, slot->name) == NULL); |
|
1838 node = avl_insert_node(mpl->tree, slot->name); |
|
1839 avl_set_node_type(node, A_INDEX); |
|
1840 avl_set_node_link(node, (void *)slot); |
|
1841 } |
|
1842 /* check a token that follows <indexing element> */ |
|
1843 if (mpl->token == T_COMMA) |
|
1844 get_token(mpl /* , */); |
|
1845 else if (mpl->token == T_COLON || mpl->token == T_RBRACE) |
|
1846 break; |
|
1847 else |
|
1848 error(mpl, "syntax error in indexing expression"); |
|
1849 } |
|
1850 /* parse <logical expression> that follows the colon */ |
|
1851 if (mpl->token == T_COLON) |
|
1852 { get_token(mpl /* : */); |
|
1853 code = expression_13(mpl); |
|
1854 /* convert the expression to logical type, if necessary */ |
|
1855 if (code->type == A_SYMBOLIC) |
|
1856 code = make_unary(mpl, O_CVTNUM, code, A_NUMERIC, 0); |
|
1857 if (code->type == A_NUMERIC) |
|
1858 code = make_unary(mpl, O_CVTLOG, code, A_LOGICAL, 0); |
|
1859 /* now the expression must be of logical type */ |
|
1860 if (code->type != A_LOGICAL) |
|
1861 error(mpl, "expression following colon has invalid type"); |
|
1862 xassert(code->dim == 0); |
|
1863 domain->code = code; |
|
1864 /* the right brace must follow the logical expression */ |
|
1865 if (mpl->token != T_RBRACE) |
|
1866 error(mpl, "syntax error in indexing expression"); |
|
1867 } |
|
1868 get_token(mpl /* } */); |
|
1869 return domain; |
|
1870 } |
|
1871 |
|
1872 /*---------------------------------------------------------------------- |
|
1873 -- close_scope - close scope of indexing expression. |
|
1874 -- |
|
1875 -- The routine closes the scope of indexing expression specified by its |
|
1876 -- domain and thereby makes all dummy indices introduced in the indexing |
|
1877 -- expression no longer available for referencing. */ |
|
1878 |
|
1879 void close_scope(MPL *mpl, DOMAIN *domain) |
|
1880 { DOMAIN_BLOCK *block; |
|
1881 DOMAIN_SLOT *slot; |
|
1882 AVLNODE *node; |
|
1883 xassert(domain != NULL); |
|
1884 /* remove all dummy indices from the symbolic names table */ |
|
1885 for (block = domain->list; block != NULL; block = block->next) |
|
1886 { for (slot = block->list; slot != NULL; slot = slot->next) |
|
1887 { if (slot->name != NULL) |
|
1888 { node = avl_find_node(mpl->tree, slot->name); |
|
1889 xassert(node != NULL); |
|
1890 xassert(avl_get_node_type(node) == A_INDEX); |
|
1891 avl_delete_node(mpl->tree, node); |
|
1892 } |
|
1893 } |
|
1894 } |
|
1895 return; |
|
1896 } |
|
1897 |
|
1898 /*---------------------------------------------------------------------- |
|
1899 -- iterated_expression - parse iterated expression. |
|
1900 -- |
|
1901 -- This routine parses primary expression using the syntax: |
|
1902 -- |
|
1903 -- <primary expression> ::= <iterated expression> |
|
1904 -- <iterated expression> ::= sum <indexing expression> <expression 3> |
|
1905 -- <iterated expression> ::= prod <indexing expression> <expression 3> |
|
1906 -- <iterated expression> ::= min <indexing expression> <expression 3> |
|
1907 -- <iterated expression> ::= max <indexing expression> <expression 3> |
|
1908 -- <iterated expression> ::= exists <indexing expression> |
|
1909 -- <expression 12> |
|
1910 -- <iterated expression> ::= forall <indexing expression> |
|
1911 -- <expression 12> |
|
1912 -- <iterated expression> ::= setof <indexing expression> <expression 5> |
|
1913 -- |
|
1914 -- Note that parsing "integrand" depends on the iterated operator. */ |
|
1915 |
|
1916 #if 1 /* 07/IX-2008 */ |
|
1917 static void link_up(CODE *code) |
|
1918 { /* if we have something like sum{(i+1,j,k-1) in E} x[i,j,k], |
|
1919 where i and k are dummy indices defined out of the iterated |
|
1920 expression, we should link up pseudo-code for computing i+1 |
|
1921 and k-1 to pseudo-code for computing the iterated expression; |
|
1922 this is needed to invalidate current value of the iterated |
|
1923 expression once i or k have been changed */ |
|
1924 DOMAIN_BLOCK *block; |
|
1925 DOMAIN_SLOT *slot; |
|
1926 for (block = code->arg.loop.domain->list; block != NULL; |
|
1927 block = block->next) |
|
1928 { for (slot = block->list; slot != NULL; slot = slot->next) |
|
1929 { if (slot->code != NULL) |
|
1930 { xassert(slot->code->up == NULL); |
|
1931 slot->code->up = code; |
|
1932 } |
|
1933 } |
|
1934 } |
|
1935 return; |
|
1936 } |
|
1937 #endif |
|
1938 |
|
1939 CODE *iterated_expression(MPL *mpl) |
|
1940 { CODE *code; |
|
1941 OPERANDS arg; |
|
1942 int op; |
|
1943 char opstr[8]; |
|
1944 /* determine operation code */ |
|
1945 xassert(mpl->token == T_NAME); |
|
1946 if (strcmp(mpl->image, "sum") == 0) |
|
1947 op = O_SUM; |
|
1948 else if (strcmp(mpl->image, "prod") == 0) |
|
1949 op = O_PROD; |
|
1950 else if (strcmp(mpl->image, "min") == 0) |
|
1951 op = O_MINIMUM; |
|
1952 else if (strcmp(mpl->image, "max") == 0) |
|
1953 op = O_MAXIMUM; |
|
1954 else if (strcmp(mpl->image, "forall") == 0) |
|
1955 op = O_FORALL; |
|
1956 else if (strcmp(mpl->image, "exists") == 0) |
|
1957 op = O_EXISTS; |
|
1958 else if (strcmp(mpl->image, "setof") == 0) |
|
1959 op = O_SETOF; |
|
1960 else |
|
1961 error(mpl, "operator %s unknown", mpl->image); |
|
1962 strcpy(opstr, mpl->image); |
|
1963 xassert(strlen(opstr) < sizeof(opstr)); |
|
1964 get_token(mpl /* <symbolic name> */); |
|
1965 /* check the left brace that follows the operator name */ |
|
1966 xassert(mpl->token == T_LBRACE); |
|
1967 /* parse indexing expression that controls iterating */ |
|
1968 arg.loop.domain = indexing_expression(mpl); |
|
1969 /* parse "integrand" expression and generate pseudo-code */ |
|
1970 switch (op) |
|
1971 { case O_SUM: |
|
1972 case O_PROD: |
|
1973 case O_MINIMUM: |
|
1974 case O_MAXIMUM: |
|
1975 arg.loop.x = expression_3(mpl); |
|
1976 /* convert the integrand to numeric type, if necessary */ |
|
1977 if (arg.loop.x->type == A_SYMBOLIC) |
|
1978 arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x, |
|
1979 A_NUMERIC, 0); |
|
1980 /* now the integrand must be of numeric type or linear form |
|
1981 (the latter is only allowed for the sum operator) */ |
|
1982 if (!(arg.loop.x->type == A_NUMERIC || |
|
1983 op == O_SUM && arg.loop.x->type == A_FORMULA)) |
|
1984 err: error(mpl, "integrand following %s{...} has invalid type" |
|
1985 , opstr); |
|
1986 xassert(arg.loop.x->dim == 0); |
|
1987 /* generate pseudo-code */ |
|
1988 code = make_code(mpl, op, &arg, arg.loop.x->type, 0); |
|
1989 break; |
|
1990 case O_FORALL: |
|
1991 case O_EXISTS: |
|
1992 arg.loop.x = expression_12(mpl); |
|
1993 /* convert the integrand to logical type, if necessary */ |
|
1994 if (arg.loop.x->type == A_SYMBOLIC) |
|
1995 arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x, |
|
1996 A_NUMERIC, 0); |
|
1997 if (arg.loop.x->type == A_NUMERIC) |
|
1998 arg.loop.x = make_unary(mpl, O_CVTLOG, arg.loop.x, |
|
1999 A_LOGICAL, 0); |
|
2000 /* now the integrand must be of logical type */ |
|
2001 if (arg.loop.x->type != A_LOGICAL) goto err; |
|
2002 xassert(arg.loop.x->dim == 0); |
|
2003 /* generate pseudo-code */ |
|
2004 code = make_code(mpl, op, &arg, A_LOGICAL, 0); |
|
2005 break; |
|
2006 case O_SETOF: |
|
2007 arg.loop.x = expression_5(mpl); |
|
2008 /* convert the integrand to 1-tuple, if necessary */ |
|
2009 if (arg.loop.x->type == A_NUMERIC) |
|
2010 arg.loop.x = make_unary(mpl, O_CVTSYM, arg.loop.x, |
|
2011 A_SYMBOLIC, 0); |
|
2012 if (arg.loop.x->type == A_SYMBOLIC) |
|
2013 arg.loop.x = make_unary(mpl, O_CVTTUP, arg.loop.x, |
|
2014 A_TUPLE, 1); |
|
2015 /* now the integrand must be n-tuple */ |
|
2016 if (arg.loop.x->type != A_TUPLE) goto err; |
|
2017 xassert(arg.loop.x->dim > 0); |
|
2018 /* generate pseudo-code */ |
|
2019 code = make_code(mpl, op, &arg, A_ELEMSET, arg.loop.x->dim); |
|
2020 break; |
|
2021 default: |
|
2022 xassert(op != op); |
|
2023 } |
|
2024 /* close the scope of the indexing expression */ |
|
2025 close_scope(mpl, arg.loop.domain); |
|
2026 #if 1 /* 07/IX-2008 */ |
|
2027 link_up(code); |
|
2028 #endif |
|
2029 return code; |
|
2030 } |
|
2031 |
|
2032 /*---------------------------------------------------------------------- |
|
2033 -- domain_arity - determine arity of domain. |
|
2034 -- |
|
2035 -- This routine returns arity of specified domain, which is number of |
|
2036 -- its free dummy indices. */ |
|
2037 |
|
2038 int domain_arity(MPL *mpl, DOMAIN *domain) |
|
2039 { DOMAIN_BLOCK *block; |
|
2040 DOMAIN_SLOT *slot; |
|
2041 int arity; |
|
2042 xassert(mpl == mpl); |
|
2043 arity = 0; |
|
2044 for (block = domain->list; block != NULL; block = block->next) |
|
2045 for (slot = block->list; slot != NULL; slot = slot->next) |
|
2046 if (slot->code == NULL) arity++; |
|
2047 return arity; |
|
2048 } |
|
2049 |
|
2050 /*---------------------------------------------------------------------- |
|
2051 -- set_expression - parse set expression. |
|
2052 -- |
|
2053 -- This routine parses primary expression using the syntax: |
|
2054 -- |
|
2055 -- <primary expression> ::= { } |
|
2056 -- <primary expression> ::= <indexing expression> */ |
|
2057 |
|
2058 CODE *set_expression(MPL *mpl) |
|
2059 { CODE *code; |
|
2060 OPERANDS arg; |
|
2061 xassert(mpl->token == T_LBRACE); |
|
2062 get_token(mpl /* { */); |
|
2063 /* check a token that follows the left brace */ |
|
2064 if (mpl->token == T_RBRACE) |
|
2065 { /* it is the right brace, so the resultant is an empty set of |
|
2066 dimension 1 */ |
|
2067 arg.list = NULL; |
|
2068 /* generate pseudo-code to build the resultant set */ |
|
2069 code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, 1); |
|
2070 get_token(mpl /* } */); |
|
2071 } |
|
2072 else |
|
2073 { /* the next token begins an indexing expression */ |
|
2074 unget_token(mpl); |
|
2075 arg.loop.domain = indexing_expression(mpl); |
|
2076 arg.loop.x = NULL; /* integrand is not used */ |
|
2077 /* close the scope of the indexing expression */ |
|
2078 close_scope(mpl, arg.loop.domain); |
|
2079 /* generate pseudo-code to build the resultant set */ |
|
2080 code = make_code(mpl, O_BUILD, &arg, A_ELEMSET, |
|
2081 domain_arity(mpl, arg.loop.domain)); |
|
2082 #if 1 /* 07/IX-2008 */ |
|
2083 link_up(code); |
|
2084 #endif |
|
2085 } |
|
2086 return code; |
|
2087 } |
|
2088 |
|
2089 /*---------------------------------------------------------------------- |
|
2090 -- branched_expression - parse conditional expression. |
|
2091 -- |
|
2092 -- This routine parses primary expression using the syntax: |
|
2093 -- |
|
2094 -- <primary expression> ::= <branched expression> |
|
2095 -- <branched expression> ::= if <logical expression> then <expression 9> |
|
2096 -- <branched expression> ::= if <logical expression> then <expression 9> |
|
2097 -- else <expression 9> |
|
2098 -- <logical expression> ::= <expression 13> */ |
|
2099 |
|
2100 CODE *branched_expression(MPL *mpl) |
|
2101 { CODE *code, *x, *y, *z; |
|
2102 xassert(mpl->token == T_IF); |
|
2103 get_token(mpl /* if */); |
|
2104 /* parse <logical expression> that follows 'if' */ |
|
2105 x = expression_13(mpl); |
|
2106 /* convert the expression to logical type, if necessary */ |
|
2107 if (x->type == A_SYMBOLIC) |
|
2108 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2109 if (x->type == A_NUMERIC) |
|
2110 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); |
|
2111 /* now the expression must be of logical type */ |
|
2112 if (x->type != A_LOGICAL) |
|
2113 error(mpl, "expression following if has invalid type"); |
|
2114 xassert(x->dim == 0); |
|
2115 /* the keyword 'then' must follow the logical expression */ |
|
2116 if (mpl->token != T_THEN) |
|
2117 error(mpl, "keyword then missing where expected"); |
|
2118 get_token(mpl /* then */); |
|
2119 /* parse <expression> that follows 'then' and check its type */ |
|
2120 y = expression_9(mpl); |
|
2121 if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC || |
|
2122 y->type == A_ELEMSET || y->type == A_FORMULA)) |
|
2123 error(mpl, "expression following then has invalid type"); |
|
2124 /* if the expression that follows the keyword 'then' is elemental |
|
2125 set, the keyword 'else' cannot be omitted; otherwise else-part |
|
2126 is optional */ |
|
2127 if (mpl->token != T_ELSE) |
|
2128 { if (y->type == A_ELEMSET) |
|
2129 error(mpl, "keyword else missing where expected"); |
|
2130 z = NULL; |
|
2131 goto skip; |
|
2132 } |
|
2133 get_token(mpl /* else */); |
|
2134 /* parse <expression> that follow 'else' and check its type */ |
|
2135 z = expression_9(mpl); |
|
2136 if (!(z->type == A_NUMERIC || z->type == A_SYMBOLIC || |
|
2137 z->type == A_ELEMSET || z->type == A_FORMULA)) |
|
2138 error(mpl, "expression following else has invalid type"); |
|
2139 /* convert to identical types, if necessary */ |
|
2140 if (y->type == A_FORMULA || z->type == A_FORMULA) |
|
2141 { if (y->type == A_SYMBOLIC) |
|
2142 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2143 if (y->type == A_NUMERIC) |
|
2144 y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0); |
|
2145 if (z->type == A_SYMBOLIC) |
|
2146 z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0); |
|
2147 if (z->type == A_NUMERIC) |
|
2148 z = make_unary(mpl, O_CVTLFM, z, A_FORMULA, 0); |
|
2149 } |
|
2150 if (y->type == A_SYMBOLIC || z->type == A_SYMBOLIC) |
|
2151 { if (y->type == A_NUMERIC) |
|
2152 y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0); |
|
2153 if (z->type == A_NUMERIC) |
|
2154 z = make_unary(mpl, O_CVTSYM, z, A_SYMBOLIC, 0); |
|
2155 } |
|
2156 /* now both expressions must have identical types */ |
|
2157 if (y->type != z->type) |
|
2158 error(mpl, "expressions following then and else have incompati" |
|
2159 "ble types"); |
|
2160 /* and identical dimensions */ |
|
2161 if (y->dim != z->dim) |
|
2162 error(mpl, "expressions following then and else have different" |
|
2163 " dimensions %d and %d, respectively", y->dim, z->dim); |
|
2164 skip: /* generate pseudo-code to perform branching */ |
|
2165 code = make_ternary(mpl, O_FORK, x, y, z, y->type, y->dim); |
|
2166 return code; |
|
2167 } |
|
2168 |
|
2169 /*---------------------------------------------------------------------- |
|
2170 -- primary_expression - parse primary expression. |
|
2171 -- |
|
2172 -- This routine parses primary expression using the syntax: |
|
2173 -- |
|
2174 -- <primary expression> ::= <numeric literal> |
|
2175 -- <primary expression> ::= Infinity |
|
2176 -- <primary expression> ::= <string literal> |
|
2177 -- <primary expression> ::= <dummy index> |
|
2178 -- <primary expression> ::= <set name> |
|
2179 -- <primary expression> ::= <set name> [ <subscript list> ] |
|
2180 -- <primary expression> ::= <parameter name> |
|
2181 -- <primary expression> ::= <parameter name> [ <subscript list> ] |
|
2182 -- <primary expression> ::= <variable name> |
|
2183 -- <primary expression> ::= <variable name> [ <subscript list> ] |
|
2184 -- <primary expression> ::= <built-in function> ( <argument list> ) |
|
2185 -- <primary expression> ::= ( <expression list> ) |
|
2186 -- <primary expression> ::= <iterated expression> |
|
2187 -- <primary expression> ::= { } |
|
2188 -- <primary expression> ::= <indexing expression> |
|
2189 -- <primary expression> ::= <branched expression> |
|
2190 -- |
|
2191 -- For complete list of syntactic rules for <primary expression> see |
|
2192 -- comments to the corresponding parsing routines. */ |
|
2193 |
|
2194 CODE *primary_expression(MPL *mpl) |
|
2195 { CODE *code; |
|
2196 if (mpl->token == T_NUMBER) |
|
2197 { /* parse numeric literal */ |
|
2198 code = numeric_literal(mpl); |
|
2199 } |
|
2200 #if 1 /* 21/VII-2006 */ |
|
2201 else if (mpl->token == T_INFINITY) |
|
2202 { /* parse "infinity" */ |
|
2203 OPERANDS arg; |
|
2204 arg.num = DBL_MAX; |
|
2205 code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0); |
|
2206 get_token(mpl /* Infinity */); |
|
2207 } |
|
2208 #endif |
|
2209 else if (mpl->token == T_STRING) |
|
2210 { /* parse string literal */ |
|
2211 code = string_literal(mpl); |
|
2212 } |
|
2213 else if (mpl->token == T_NAME) |
|
2214 { int next_token; |
|
2215 get_token(mpl /* <symbolic name> */); |
|
2216 next_token = mpl->token; |
|
2217 unget_token(mpl); |
|
2218 /* check a token that follows <symbolic name> */ |
|
2219 switch (next_token) |
|
2220 { case T_LBRACKET: |
|
2221 /* parse reference to subscripted object */ |
|
2222 code = object_reference(mpl); |
|
2223 break; |
|
2224 case T_LEFT: |
|
2225 /* parse reference to built-in function */ |
|
2226 code = function_reference(mpl); |
|
2227 break; |
|
2228 case T_LBRACE: |
|
2229 /* parse iterated expression */ |
|
2230 code = iterated_expression(mpl); |
|
2231 break; |
|
2232 default: |
|
2233 /* parse reference to unsubscripted object */ |
|
2234 code = object_reference(mpl); |
|
2235 break; |
|
2236 } |
|
2237 } |
|
2238 else if (mpl->token == T_LEFT) |
|
2239 { /* parse parenthesized expression */ |
|
2240 code = expression_list(mpl); |
|
2241 } |
|
2242 else if (mpl->token == T_LBRACE) |
|
2243 { /* parse set expression */ |
|
2244 code = set_expression(mpl); |
|
2245 } |
|
2246 else if (mpl->token == T_IF) |
|
2247 { /* parse conditional expression */ |
|
2248 code = branched_expression(mpl); |
|
2249 } |
|
2250 else if (is_reserved(mpl)) |
|
2251 { /* other reserved keywords cannot be used here */ |
|
2252 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
2253 } |
|
2254 else |
|
2255 error(mpl, "syntax error in expression"); |
|
2256 return code; |
|
2257 } |
|
2258 |
|
2259 /*---------------------------------------------------------------------- |
|
2260 -- error_preceding - raise error if preceding operand has wrong type. |
|
2261 -- |
|
2262 -- This routine is called to raise error if operand that precedes some |
|
2263 -- infix operator has invalid type. */ |
|
2264 |
|
2265 void error_preceding(MPL *mpl, char *opstr) |
|
2266 { error(mpl, "operand preceding %s has invalid type", opstr); |
|
2267 /* no return */ |
|
2268 } |
|
2269 |
|
2270 /*---------------------------------------------------------------------- |
|
2271 -- error_following - raise error if following operand has wrong type. |
|
2272 -- |
|
2273 -- This routine is called to raise error if operand that follows some |
|
2274 -- infix operator has invalid type. */ |
|
2275 |
|
2276 void error_following(MPL *mpl, char *opstr) |
|
2277 { error(mpl, "operand following %s has invalid type", opstr); |
|
2278 /* no return */ |
|
2279 } |
|
2280 |
|
2281 /*---------------------------------------------------------------------- |
|
2282 -- error_dimension - raise error if operands have different dimension. |
|
2283 -- |
|
2284 -- This routine is called to raise error if two operands of some infix |
|
2285 -- operator have different dimension. */ |
|
2286 |
|
2287 void error_dimension(MPL *mpl, char *opstr, int dim1, int dim2) |
|
2288 { error(mpl, "operands preceding and following %s have different di" |
|
2289 "mensions %d and %d, respectively", opstr, dim1, dim2); |
|
2290 /* no return */ |
|
2291 } |
|
2292 |
|
2293 /*---------------------------------------------------------------------- |
|
2294 -- expression_0 - parse expression of level 0. |
|
2295 -- |
|
2296 -- This routine parses expression of level 0 using the syntax: |
|
2297 -- |
|
2298 -- <expression 0> ::= <primary expression> */ |
|
2299 |
|
2300 CODE *expression_0(MPL *mpl) |
|
2301 { CODE *code; |
|
2302 code = primary_expression(mpl); |
|
2303 return code; |
|
2304 } |
|
2305 |
|
2306 /*---------------------------------------------------------------------- |
|
2307 -- expression_1 - parse expression of level 1. |
|
2308 -- |
|
2309 -- This routine parses expression of level 1 using the syntax: |
|
2310 -- |
|
2311 -- <expression 1> ::= <expression 0> |
|
2312 -- <expression 1> ::= <expression 0> <power> <expression 1> |
|
2313 -- <expression 1> ::= <expression 0> <power> <expression 2> |
|
2314 -- <power> ::= ^ | ** */ |
|
2315 |
|
2316 CODE *expression_1(MPL *mpl) |
|
2317 { CODE *x, *y; |
|
2318 char opstr[8]; |
|
2319 x = expression_0(mpl); |
|
2320 if (mpl->token == T_POWER) |
|
2321 { strcpy(opstr, mpl->image); |
|
2322 xassert(strlen(opstr) < sizeof(opstr)); |
|
2323 if (x->type == A_SYMBOLIC) |
|
2324 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2325 if (x->type != A_NUMERIC) |
|
2326 error_preceding(mpl, opstr); |
|
2327 get_token(mpl /* ^ | ** */); |
|
2328 if (mpl->token == T_PLUS || mpl->token == T_MINUS) |
|
2329 y = expression_2(mpl); |
|
2330 else |
|
2331 y = expression_1(mpl); |
|
2332 if (y->type == A_SYMBOLIC) |
|
2333 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2334 if (y->type != A_NUMERIC) |
|
2335 error_following(mpl, opstr); |
|
2336 x = make_binary(mpl, O_POWER, x, y, A_NUMERIC, 0); |
|
2337 } |
|
2338 return x; |
|
2339 } |
|
2340 |
|
2341 /*---------------------------------------------------------------------- |
|
2342 -- expression_2 - parse expression of level 2. |
|
2343 -- |
|
2344 -- This routine parses expression of level 2 using the syntax: |
|
2345 -- |
|
2346 -- <expression 2> ::= <expression 1> |
|
2347 -- <expression 2> ::= + <expression 1> |
|
2348 -- <expression 2> ::= - <expression 1> */ |
|
2349 |
|
2350 CODE *expression_2(MPL *mpl) |
|
2351 { CODE *x; |
|
2352 if (mpl->token == T_PLUS) |
|
2353 { get_token(mpl /* + */); |
|
2354 x = expression_1(mpl); |
|
2355 if (x->type == A_SYMBOLIC) |
|
2356 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2357 if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) |
|
2358 error_following(mpl, "+"); |
|
2359 x = make_unary(mpl, O_PLUS, x, x->type, 0); |
|
2360 } |
|
2361 else if (mpl->token == T_MINUS) |
|
2362 { get_token(mpl /* - */); |
|
2363 x = expression_1(mpl); |
|
2364 if (x->type == A_SYMBOLIC) |
|
2365 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2366 if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) |
|
2367 error_following(mpl, "-"); |
|
2368 x = make_unary(mpl, O_MINUS, x, x->type, 0); |
|
2369 } |
|
2370 else |
|
2371 x = expression_1(mpl); |
|
2372 return x; |
|
2373 } |
|
2374 |
|
2375 /*---------------------------------------------------------------------- |
|
2376 -- expression_3 - parse expression of level 3. |
|
2377 -- |
|
2378 -- This routine parses expression of level 3 using the syntax: |
|
2379 -- |
|
2380 -- <expression 3> ::= <expression 2> |
|
2381 -- <expression 3> ::= <expression 3> * <expression 2> |
|
2382 -- <expression 3> ::= <expression 3> / <expression 2> |
|
2383 -- <expression 3> ::= <expression 3> div <expression 2> |
|
2384 -- <expression 3> ::= <expression 3> mod <expression 2> */ |
|
2385 |
|
2386 CODE *expression_3(MPL *mpl) |
|
2387 { CODE *x, *y; |
|
2388 x = expression_2(mpl); |
|
2389 for (;;) |
|
2390 { if (mpl->token == T_ASTERISK) |
|
2391 { if (x->type == A_SYMBOLIC) |
|
2392 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2393 if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) |
|
2394 error_preceding(mpl, "*"); |
|
2395 get_token(mpl /* * */); |
|
2396 y = expression_2(mpl); |
|
2397 if (y->type == A_SYMBOLIC) |
|
2398 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2399 if (!(y->type == A_NUMERIC || y->type == A_FORMULA)) |
|
2400 error_following(mpl, "*"); |
|
2401 if (x->type == A_FORMULA && y->type == A_FORMULA) |
|
2402 error(mpl, "multiplication of linear forms not allowed"); |
|
2403 if (x->type == A_NUMERIC && y->type == A_NUMERIC) |
|
2404 x = make_binary(mpl, O_MUL, x, y, A_NUMERIC, 0); |
|
2405 else |
|
2406 x = make_binary(mpl, O_MUL, x, y, A_FORMULA, 0); |
|
2407 } |
|
2408 else if (mpl->token == T_SLASH) |
|
2409 { if (x->type == A_SYMBOLIC) |
|
2410 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2411 if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) |
|
2412 error_preceding(mpl, "/"); |
|
2413 get_token(mpl /* / */); |
|
2414 y = expression_2(mpl); |
|
2415 if (y->type == A_SYMBOLIC) |
|
2416 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2417 if (y->type != A_NUMERIC) |
|
2418 error_following(mpl, "/"); |
|
2419 if (x->type == A_NUMERIC) |
|
2420 x = make_binary(mpl, O_DIV, x, y, A_NUMERIC, 0); |
|
2421 else |
|
2422 x = make_binary(mpl, O_DIV, x, y, A_FORMULA, 0); |
|
2423 } |
|
2424 else if (mpl->token == T_DIV) |
|
2425 { if (x->type == A_SYMBOLIC) |
|
2426 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2427 if (x->type != A_NUMERIC) |
|
2428 error_preceding(mpl, "div"); |
|
2429 get_token(mpl /* div */); |
|
2430 y = expression_2(mpl); |
|
2431 if (y->type == A_SYMBOLIC) |
|
2432 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2433 if (y->type != A_NUMERIC) |
|
2434 error_following(mpl, "div"); |
|
2435 x = make_binary(mpl, O_IDIV, x, y, A_NUMERIC, 0); |
|
2436 } |
|
2437 else if (mpl->token == T_MOD) |
|
2438 { if (x->type == A_SYMBOLIC) |
|
2439 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2440 if (x->type != A_NUMERIC) |
|
2441 error_preceding(mpl, "mod"); |
|
2442 get_token(mpl /* mod */); |
|
2443 y = expression_2(mpl); |
|
2444 if (y->type == A_SYMBOLIC) |
|
2445 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2446 if (y->type != A_NUMERIC) |
|
2447 error_following(mpl, "mod"); |
|
2448 x = make_binary(mpl, O_MOD, x, y, A_NUMERIC, 0); |
|
2449 } |
|
2450 else |
|
2451 break; |
|
2452 } |
|
2453 return x; |
|
2454 } |
|
2455 |
|
2456 /*---------------------------------------------------------------------- |
|
2457 -- expression_4 - parse expression of level 4. |
|
2458 -- |
|
2459 -- This routine parses expression of level 4 using the syntax: |
|
2460 -- |
|
2461 -- <expression 4> ::= <expression 3> |
|
2462 -- <expression 4> ::= <expression 4> + <expression 3> |
|
2463 -- <expression 4> ::= <expression 4> - <expression 3> |
|
2464 -- <expression 4> ::= <expression 4> less <expression 3> */ |
|
2465 |
|
2466 CODE *expression_4(MPL *mpl) |
|
2467 { CODE *x, *y; |
|
2468 x = expression_3(mpl); |
|
2469 for (;;) |
|
2470 { if (mpl->token == T_PLUS) |
|
2471 { if (x->type == A_SYMBOLIC) |
|
2472 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2473 if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) |
|
2474 error_preceding(mpl, "+"); |
|
2475 get_token(mpl /* + */); |
|
2476 y = expression_3(mpl); |
|
2477 if (y->type == A_SYMBOLIC) |
|
2478 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2479 if (!(y->type == A_NUMERIC || y->type == A_FORMULA)) |
|
2480 error_following(mpl, "+"); |
|
2481 if (x->type == A_NUMERIC && y->type == A_FORMULA) |
|
2482 x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0); |
|
2483 if (x->type == A_FORMULA && y->type == A_NUMERIC) |
|
2484 y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0); |
|
2485 x = make_binary(mpl, O_ADD, x, y, x->type, 0); |
|
2486 } |
|
2487 else if (mpl->token == T_MINUS) |
|
2488 { if (x->type == A_SYMBOLIC) |
|
2489 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2490 if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) |
|
2491 error_preceding(mpl, "-"); |
|
2492 get_token(mpl /* - */); |
|
2493 y = expression_3(mpl); |
|
2494 if (y->type == A_SYMBOLIC) |
|
2495 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2496 if (!(y->type == A_NUMERIC || y->type == A_FORMULA)) |
|
2497 error_following(mpl, "-"); |
|
2498 if (x->type == A_NUMERIC && y->type == A_FORMULA) |
|
2499 x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0); |
|
2500 if (x->type == A_FORMULA && y->type == A_NUMERIC) |
|
2501 y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0); |
|
2502 x = make_binary(mpl, O_SUB, x, y, x->type, 0); |
|
2503 } |
|
2504 else if (mpl->token == T_LESS) |
|
2505 { if (x->type == A_SYMBOLIC) |
|
2506 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2507 if (x->type != A_NUMERIC) |
|
2508 error_preceding(mpl, "less"); |
|
2509 get_token(mpl /* less */); |
|
2510 y = expression_3(mpl); |
|
2511 if (y->type == A_SYMBOLIC) |
|
2512 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2513 if (y->type != A_NUMERIC) |
|
2514 error_following(mpl, "less"); |
|
2515 x = make_binary(mpl, O_LESS, x, y, A_NUMERIC, 0); |
|
2516 } |
|
2517 else |
|
2518 break; |
|
2519 } |
|
2520 return x; |
|
2521 } |
|
2522 |
|
2523 /*---------------------------------------------------------------------- |
|
2524 -- expression_5 - parse expression of level 5. |
|
2525 -- |
|
2526 -- This routine parses expression of level 5 using the syntax: |
|
2527 -- |
|
2528 -- <expression 5> ::= <expression 4> |
|
2529 -- <expression 5> ::= <expression 5> & <expression 4> */ |
|
2530 |
|
2531 CODE *expression_5(MPL *mpl) |
|
2532 { CODE *x, *y; |
|
2533 x = expression_4(mpl); |
|
2534 for (;;) |
|
2535 { if (mpl->token == T_CONCAT) |
|
2536 { if (x->type == A_NUMERIC) |
|
2537 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); |
|
2538 if (x->type != A_SYMBOLIC) |
|
2539 error_preceding(mpl, "&"); |
|
2540 get_token(mpl /* & */); |
|
2541 y = expression_4(mpl); |
|
2542 if (y->type == A_NUMERIC) |
|
2543 y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0); |
|
2544 if (y->type != A_SYMBOLIC) |
|
2545 error_following(mpl, "&"); |
|
2546 x = make_binary(mpl, O_CONCAT, x, y, A_SYMBOLIC, 0); |
|
2547 } |
|
2548 else |
|
2549 break; |
|
2550 } |
|
2551 return x; |
|
2552 } |
|
2553 |
|
2554 /*---------------------------------------------------------------------- |
|
2555 -- expression_6 - parse expression of level 6. |
|
2556 -- |
|
2557 -- This routine parses expression of level 6 using the syntax: |
|
2558 -- |
|
2559 -- <expression 6> ::= <expression 5> |
|
2560 -- <expression 6> ::= <expression 5> .. <expression 5> |
|
2561 -- <expression 6> ::= <expression 5> .. <expression 5> by |
|
2562 -- <expression 5> */ |
|
2563 |
|
2564 CODE *expression_6(MPL *mpl) |
|
2565 { CODE *x, *y, *z; |
|
2566 x = expression_5(mpl); |
|
2567 if (mpl->token == T_DOTS) |
|
2568 { if (x->type == A_SYMBOLIC) |
|
2569 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2570 if (x->type != A_NUMERIC) |
|
2571 error_preceding(mpl, ".."); |
|
2572 get_token(mpl /* .. */); |
|
2573 y = expression_5(mpl); |
|
2574 if (y->type == A_SYMBOLIC) |
|
2575 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2576 if (y->type != A_NUMERIC) |
|
2577 error_following(mpl, ".."); |
|
2578 if (mpl->token == T_BY) |
|
2579 { get_token(mpl /* by */); |
|
2580 z = expression_5(mpl); |
|
2581 if (z->type == A_SYMBOLIC) |
|
2582 z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0); |
|
2583 if (z->type != A_NUMERIC) |
|
2584 error_following(mpl, "by"); |
|
2585 } |
|
2586 else |
|
2587 z = NULL; |
|
2588 x = make_ternary(mpl, O_DOTS, x, y, z, A_ELEMSET, 1); |
|
2589 } |
|
2590 return x; |
|
2591 } |
|
2592 |
|
2593 /*---------------------------------------------------------------------- |
|
2594 -- expression_7 - parse expression of level 7. |
|
2595 -- |
|
2596 -- This routine parses expression of level 7 using the syntax: |
|
2597 -- |
|
2598 -- <expression 7> ::= <expression 6> |
|
2599 -- <expression 7> ::= <expression 7> cross <expression 6> */ |
|
2600 |
|
2601 CODE *expression_7(MPL *mpl) |
|
2602 { CODE *x, *y; |
|
2603 x = expression_6(mpl); |
|
2604 for (;;) |
|
2605 { if (mpl->token == T_CROSS) |
|
2606 { if (x->type != A_ELEMSET) |
|
2607 error_preceding(mpl, "cross"); |
|
2608 get_token(mpl /* cross */); |
|
2609 y = expression_6(mpl); |
|
2610 if (y->type != A_ELEMSET) |
|
2611 error_following(mpl, "cross"); |
|
2612 x = make_binary(mpl, O_CROSS, x, y, A_ELEMSET, |
|
2613 x->dim + y->dim); |
|
2614 } |
|
2615 else |
|
2616 break; |
|
2617 } |
|
2618 return x; |
|
2619 } |
|
2620 |
|
2621 /*---------------------------------------------------------------------- |
|
2622 -- expression_8 - parse expression of level 8. |
|
2623 -- |
|
2624 -- This routine parses expression of level 8 using the syntax: |
|
2625 -- |
|
2626 -- <expression 8> ::= <expression 7> |
|
2627 -- <expression 8> ::= <expression 8> inter <expression 7> */ |
|
2628 |
|
2629 CODE *expression_8(MPL *mpl) |
|
2630 { CODE *x, *y; |
|
2631 x = expression_7(mpl); |
|
2632 for (;;) |
|
2633 { if (mpl->token == T_INTER) |
|
2634 { if (x->type != A_ELEMSET) |
|
2635 error_preceding(mpl, "inter"); |
|
2636 get_token(mpl /* inter */); |
|
2637 y = expression_7(mpl); |
|
2638 if (y->type != A_ELEMSET) |
|
2639 error_following(mpl, "inter"); |
|
2640 if (x->dim != y->dim) |
|
2641 error_dimension(mpl, "inter", x->dim, y->dim); |
|
2642 x = make_binary(mpl, O_INTER, x, y, A_ELEMSET, x->dim); |
|
2643 } |
|
2644 else |
|
2645 break; |
|
2646 } |
|
2647 return x; |
|
2648 } |
|
2649 |
|
2650 /*---------------------------------------------------------------------- |
|
2651 -- expression_9 - parse expression of level 9. |
|
2652 -- |
|
2653 -- This routine parses expression of level 9 using the syntax: |
|
2654 -- |
|
2655 -- <expression 9> ::= <expression 8> |
|
2656 -- <expression 9> ::= <expression 9> union <expression 8> |
|
2657 -- <expression 9> ::= <expression 9> diff <expression 8> |
|
2658 -- <expression 9> ::= <expression 9> symdiff <expression 8> */ |
|
2659 |
|
2660 CODE *expression_9(MPL *mpl) |
|
2661 { CODE *x, *y; |
|
2662 x = expression_8(mpl); |
|
2663 for (;;) |
|
2664 { if (mpl->token == T_UNION) |
|
2665 { if (x->type != A_ELEMSET) |
|
2666 error_preceding(mpl, "union"); |
|
2667 get_token(mpl /* union */); |
|
2668 y = expression_8(mpl); |
|
2669 if (y->type != A_ELEMSET) |
|
2670 error_following(mpl, "union"); |
|
2671 if (x->dim != y->dim) |
|
2672 error_dimension(mpl, "union", x->dim, y->dim); |
|
2673 x = make_binary(mpl, O_UNION, x, y, A_ELEMSET, x->dim); |
|
2674 } |
|
2675 else if (mpl->token == T_DIFF) |
|
2676 { if (x->type != A_ELEMSET) |
|
2677 error_preceding(mpl, "diff"); |
|
2678 get_token(mpl /* diff */); |
|
2679 y = expression_8(mpl); |
|
2680 if (y->type != A_ELEMSET) |
|
2681 error_following(mpl, "diff"); |
|
2682 if (x->dim != y->dim) |
|
2683 error_dimension(mpl, "diff", x->dim, y->dim); |
|
2684 x = make_binary(mpl, O_DIFF, x, y, A_ELEMSET, x->dim); |
|
2685 } |
|
2686 else if (mpl->token == T_SYMDIFF) |
|
2687 { if (x->type != A_ELEMSET) |
|
2688 error_preceding(mpl, "symdiff"); |
|
2689 get_token(mpl /* symdiff */); |
|
2690 y = expression_8(mpl); |
|
2691 if (y->type != A_ELEMSET) |
|
2692 error_following(mpl, "symdiff"); |
|
2693 if (x->dim != y->dim) |
|
2694 error_dimension(mpl, "symdiff", x->dim, y->dim); |
|
2695 x = make_binary(mpl, O_SYMDIFF, x, y, A_ELEMSET, x->dim); |
|
2696 } |
|
2697 else |
|
2698 break; |
|
2699 } |
|
2700 return x; |
|
2701 } |
|
2702 |
|
2703 /*---------------------------------------------------------------------- |
|
2704 -- expression_10 - parse expression of level 10. |
|
2705 -- |
|
2706 -- This routine parses expression of level 10 using the syntax: |
|
2707 -- |
|
2708 -- <expression 10> ::= <expression 9> |
|
2709 -- <expression 10> ::= <expression 9> <rho> <expression 9> |
|
2710 -- <rho> ::= < | <= | = | == | >= | > | <> | != | in | not in | ! in | |
|
2711 -- within | not within | ! within */ |
|
2712 |
|
2713 CODE *expression_10(MPL *mpl) |
|
2714 { CODE *x, *y; |
|
2715 int op = -1; |
|
2716 char opstr[16]; |
|
2717 x = expression_9(mpl); |
|
2718 strcpy(opstr, ""); |
|
2719 switch (mpl->token) |
|
2720 { case T_LT: |
|
2721 op = O_LT; break; |
|
2722 case T_LE: |
|
2723 op = O_LE; break; |
|
2724 case T_EQ: |
|
2725 op = O_EQ; break; |
|
2726 case T_GE: |
|
2727 op = O_GE; break; |
|
2728 case T_GT: |
|
2729 op = O_GT; break; |
|
2730 case T_NE: |
|
2731 op = O_NE; break; |
|
2732 case T_IN: |
|
2733 op = O_IN; break; |
|
2734 case T_WITHIN: |
|
2735 op = O_WITHIN; break; |
|
2736 case T_NOT: |
|
2737 strcpy(opstr, mpl->image); |
|
2738 get_token(mpl /* not | ! */); |
|
2739 if (mpl->token == T_IN) |
|
2740 op = O_NOTIN; |
|
2741 else if (mpl->token == T_WITHIN) |
|
2742 op = O_NOTWITHIN; |
|
2743 else |
|
2744 error(mpl, "invalid use of %s", opstr); |
|
2745 strcat(opstr, " "); |
|
2746 break; |
|
2747 default: |
|
2748 goto done; |
|
2749 } |
|
2750 strcat(opstr, mpl->image); |
|
2751 xassert(strlen(opstr) < sizeof(opstr)); |
|
2752 switch (op) |
|
2753 { case O_EQ: |
|
2754 case O_NE: |
|
2755 #if 1 /* 02/VIII-2008 */ |
|
2756 case O_LT: |
|
2757 case O_LE: |
|
2758 case O_GT: |
|
2759 case O_GE: |
|
2760 #endif |
|
2761 if (!(x->type == A_NUMERIC || x->type == A_SYMBOLIC)) |
|
2762 error_preceding(mpl, opstr); |
|
2763 get_token(mpl /* <rho> */); |
|
2764 y = expression_9(mpl); |
|
2765 if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC)) |
|
2766 error_following(mpl, opstr); |
|
2767 if (x->type == A_NUMERIC && y->type == A_SYMBOLIC) |
|
2768 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); |
|
2769 if (x->type == A_SYMBOLIC && y->type == A_NUMERIC) |
|
2770 y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0); |
|
2771 x = make_binary(mpl, op, x, y, A_LOGICAL, 0); |
|
2772 break; |
|
2773 #if 0 /* 02/VIII-2008 */ |
|
2774 case O_LT: |
|
2775 case O_LE: |
|
2776 case O_GT: |
|
2777 case O_GE: |
|
2778 if (x->type == A_SYMBOLIC) |
|
2779 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2780 if (x->type != A_NUMERIC) |
|
2781 error_preceding(mpl, opstr); |
|
2782 get_token(mpl /* <rho> */); |
|
2783 y = expression_9(mpl); |
|
2784 if (y->type == A_SYMBOLIC) |
|
2785 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2786 if (y->type != A_NUMERIC) |
|
2787 error_following(mpl, opstr); |
|
2788 x = make_binary(mpl, op, x, y, A_LOGICAL, 0); |
|
2789 break; |
|
2790 #endif |
|
2791 case O_IN: |
|
2792 case O_NOTIN: |
|
2793 if (x->type == A_NUMERIC) |
|
2794 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); |
|
2795 if (x->type == A_SYMBOLIC) |
|
2796 x = make_unary(mpl, O_CVTTUP, x, A_TUPLE, 1); |
|
2797 if (x->type != A_TUPLE) |
|
2798 error_preceding(mpl, opstr); |
|
2799 get_token(mpl /* <rho> */); |
|
2800 y = expression_9(mpl); |
|
2801 if (y->type != A_ELEMSET) |
|
2802 error_following(mpl, opstr); |
|
2803 if (x->dim != y->dim) |
|
2804 error_dimension(mpl, opstr, x->dim, y->dim); |
|
2805 x = make_binary(mpl, op, x, y, A_LOGICAL, 0); |
|
2806 break; |
|
2807 case O_WITHIN: |
|
2808 case O_NOTWITHIN: |
|
2809 if (x->type != A_ELEMSET) |
|
2810 error_preceding(mpl, opstr); |
|
2811 get_token(mpl /* <rho> */); |
|
2812 y = expression_9(mpl); |
|
2813 if (y->type != A_ELEMSET) |
|
2814 error_following(mpl, opstr); |
|
2815 if (x->dim != y->dim) |
|
2816 error_dimension(mpl, opstr, x->dim, y->dim); |
|
2817 x = make_binary(mpl, op, x, y, A_LOGICAL, 0); |
|
2818 break; |
|
2819 default: |
|
2820 xassert(op != op); |
|
2821 } |
|
2822 done: return x; |
|
2823 } |
|
2824 |
|
2825 /*---------------------------------------------------------------------- |
|
2826 -- expression_11 - parse expression of level 11. |
|
2827 -- |
|
2828 -- This routine parses expression of level 11 using the syntax: |
|
2829 -- |
|
2830 -- <expression 11> ::= <expression 10> |
|
2831 -- <expression 11> ::= not <expression 10> |
|
2832 -- <expression 11> ::= ! <expression 10> */ |
|
2833 |
|
2834 CODE *expression_11(MPL *mpl) |
|
2835 { CODE *x; |
|
2836 char opstr[8]; |
|
2837 if (mpl->token == T_NOT) |
|
2838 { strcpy(opstr, mpl->image); |
|
2839 xassert(strlen(opstr) < sizeof(opstr)); |
|
2840 get_token(mpl /* not | ! */); |
|
2841 x = expression_10(mpl); |
|
2842 if (x->type == A_SYMBOLIC) |
|
2843 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2844 if (x->type == A_NUMERIC) |
|
2845 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); |
|
2846 if (x->type != A_LOGICAL) |
|
2847 error_following(mpl, opstr); |
|
2848 x = make_unary(mpl, O_NOT, x, A_LOGICAL, 0); |
|
2849 } |
|
2850 else |
|
2851 x = expression_10(mpl); |
|
2852 return x; |
|
2853 } |
|
2854 |
|
2855 /*---------------------------------------------------------------------- |
|
2856 -- expression_12 - parse expression of level 12. |
|
2857 -- |
|
2858 -- This routine parses expression of level 12 using the syntax: |
|
2859 -- |
|
2860 -- <expression 12> ::= <expression 11> |
|
2861 -- <expression 12> ::= <expression 12> and <expression 11> |
|
2862 -- <expression 12> ::= <expression 12> && <expression 11> */ |
|
2863 |
|
2864 CODE *expression_12(MPL *mpl) |
|
2865 { CODE *x, *y; |
|
2866 char opstr[8]; |
|
2867 x = expression_11(mpl); |
|
2868 for (;;) |
|
2869 { if (mpl->token == T_AND) |
|
2870 { strcpy(opstr, mpl->image); |
|
2871 xassert(strlen(opstr) < sizeof(opstr)); |
|
2872 if (x->type == A_SYMBOLIC) |
|
2873 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2874 if (x->type == A_NUMERIC) |
|
2875 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); |
|
2876 if (x->type != A_LOGICAL) |
|
2877 error_preceding(mpl, opstr); |
|
2878 get_token(mpl /* and | && */); |
|
2879 y = expression_11(mpl); |
|
2880 if (y->type == A_SYMBOLIC) |
|
2881 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2882 if (y->type == A_NUMERIC) |
|
2883 y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0); |
|
2884 if (y->type != A_LOGICAL) |
|
2885 error_following(mpl, opstr); |
|
2886 x = make_binary(mpl, O_AND, x, y, A_LOGICAL, 0); |
|
2887 } |
|
2888 else |
|
2889 break; |
|
2890 } |
|
2891 return x; |
|
2892 } |
|
2893 |
|
2894 /*---------------------------------------------------------------------- |
|
2895 -- expression_13 - parse expression of level 13. |
|
2896 -- |
|
2897 -- This routine parses expression of level 13 using the syntax: |
|
2898 -- |
|
2899 -- <expression 13> ::= <expression 12> |
|
2900 -- <expression 13> ::= <expression 13> or <expression 12> |
|
2901 -- <expression 13> ::= <expression 13> || <expression 12> */ |
|
2902 |
|
2903 CODE *expression_13(MPL *mpl) |
|
2904 { CODE *x, *y; |
|
2905 char opstr[8]; |
|
2906 x = expression_12(mpl); |
|
2907 for (;;) |
|
2908 { if (mpl->token == T_OR) |
|
2909 { strcpy(opstr, mpl->image); |
|
2910 xassert(strlen(opstr) < sizeof(opstr)); |
|
2911 if (x->type == A_SYMBOLIC) |
|
2912 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); |
|
2913 if (x->type == A_NUMERIC) |
|
2914 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); |
|
2915 if (x->type != A_LOGICAL) |
|
2916 error_preceding(mpl, opstr); |
|
2917 get_token(mpl /* or | || */); |
|
2918 y = expression_12(mpl); |
|
2919 if (y->type == A_SYMBOLIC) |
|
2920 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); |
|
2921 if (y->type == A_NUMERIC) |
|
2922 y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0); |
|
2923 if (y->type != A_LOGICAL) |
|
2924 error_following(mpl, opstr); |
|
2925 x = make_binary(mpl, O_OR, x, y, A_LOGICAL, 0); |
|
2926 } |
|
2927 else |
|
2928 break; |
|
2929 } |
|
2930 return x; |
|
2931 } |
|
2932 |
|
2933 /*---------------------------------------------------------------------- |
|
2934 -- set_statement - parse set statement. |
|
2935 -- |
|
2936 -- This routine parses set statement using the syntax: |
|
2937 -- |
|
2938 -- <set statement> ::= set <symbolic name> <alias> <domain> |
|
2939 -- <attributes> ; |
|
2940 -- <alias> ::= <empty> |
|
2941 -- <alias> ::= <string literal> |
|
2942 -- <domain> ::= <empty> |
|
2943 -- <domain> ::= <indexing expression> |
|
2944 -- <attributes> ::= <empty> |
|
2945 -- <attributes> ::= <attributes> , dimen <numeric literal> |
|
2946 -- <attributes> ::= <attributes> , within <expression 9> |
|
2947 -- <attributes> ::= <attributes> , := <expression 9> |
|
2948 -- <attributes> ::= <attributes> , default <expression 9> |
|
2949 -- |
|
2950 -- Commae in <attributes> are optional and may be omitted anywhere. */ |
|
2951 |
|
2952 SET *set_statement(MPL *mpl) |
|
2953 { SET *set; |
|
2954 int dimen_used = 0; |
|
2955 xassert(is_keyword(mpl, "set")); |
|
2956 get_token(mpl /* set */); |
|
2957 /* symbolic name must follow the keyword 'set' */ |
|
2958 if (mpl->token == T_NAME) |
|
2959 ; |
|
2960 else if (is_reserved(mpl)) |
|
2961 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
2962 else |
|
2963 error(mpl, "symbolic name missing where expected"); |
|
2964 /* there must be no other object with the same name */ |
|
2965 if (avl_find_node(mpl->tree, mpl->image) != NULL) |
|
2966 error(mpl, "%s multiply declared", mpl->image); |
|
2967 /* create model set */ |
|
2968 set = alloc(SET); |
|
2969 set->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
2970 strcpy(set->name, mpl->image); |
|
2971 set->alias = NULL; |
|
2972 set->dim = 0; |
|
2973 set->domain = NULL; |
|
2974 set->dimen = 0; |
|
2975 set->within = NULL; |
|
2976 set->assign = NULL; |
|
2977 set->option = NULL; |
|
2978 set->gadget = NULL; |
|
2979 set->data = 0; |
|
2980 set->array = NULL; |
|
2981 get_token(mpl /* <symbolic name> */); |
|
2982 /* parse optional alias */ |
|
2983 if (mpl->token == T_STRING) |
|
2984 { set->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
2985 strcpy(set->alias, mpl->image); |
|
2986 get_token(mpl /* <string literal> */); |
|
2987 } |
|
2988 /* parse optional indexing expression */ |
|
2989 if (mpl->token == T_LBRACE) |
|
2990 { set->domain = indexing_expression(mpl); |
|
2991 set->dim = domain_arity(mpl, set->domain); |
|
2992 } |
|
2993 /* include the set name in the symbolic names table */ |
|
2994 { AVLNODE *node; |
|
2995 node = avl_insert_node(mpl->tree, set->name); |
|
2996 avl_set_node_type(node, A_SET); |
|
2997 avl_set_node_link(node, (void *)set); |
|
2998 } |
|
2999 /* parse the list of optional attributes */ |
|
3000 for (;;) |
|
3001 { if (mpl->token == T_COMMA) |
|
3002 get_token(mpl /* , */); |
|
3003 else if (mpl->token == T_SEMICOLON) |
|
3004 break; |
|
3005 if (is_keyword(mpl, "dimen")) |
|
3006 { /* dimension of set members */ |
|
3007 int dimen; |
|
3008 get_token(mpl /* dimen */); |
|
3009 if (!(mpl->token == T_NUMBER && |
|
3010 1.0 <= mpl->value && mpl->value <= 20.0 && |
|
3011 floor(mpl->value) == mpl->value)) |
|
3012 error(mpl, "dimension must be integer between 1 and 20"); |
|
3013 dimen = (int)(mpl->value + 0.5); |
|
3014 if (dimen_used) |
|
3015 error(mpl, "at most one dimension attribute allowed"); |
|
3016 if (set->dimen > 0) |
|
3017 error(mpl, "dimension %d conflicts with dimension %d alr" |
|
3018 "eady determined", dimen, set->dimen); |
|
3019 set->dimen = dimen; |
|
3020 dimen_used = 1; |
|
3021 get_token(mpl /* <numeric literal> */); |
|
3022 } |
|
3023 else if (mpl->token == T_WITHIN || mpl->token == T_IN) |
|
3024 { /* restricting superset */ |
|
3025 WITHIN *within, *temp; |
|
3026 if (mpl->token == T_IN && !mpl->as_within) |
|
3027 { warning(mpl, "keyword in understood as within"); |
|
3028 mpl->as_within = 1; |
|
3029 } |
|
3030 get_token(mpl /* within */); |
|
3031 /* create new restricting superset list entry and append it |
|
3032 to the within-list */ |
|
3033 within = alloc(WITHIN); |
|
3034 within->code = NULL; |
|
3035 within->next = NULL; |
|
3036 if (set->within == NULL) |
|
3037 set->within = within; |
|
3038 else |
|
3039 { for (temp = set->within; temp->next != NULL; temp = |
|
3040 temp->next); |
|
3041 temp->next = within; |
|
3042 } |
|
3043 /* parse an expression that follows 'within' */ |
|
3044 within->code = expression_9(mpl); |
|
3045 if (within->code->type != A_ELEMSET) |
|
3046 error(mpl, "expression following within has invalid type" |
|
3047 ); |
|
3048 xassert(within->code->dim > 0); |
|
3049 /* check/set dimension of set members */ |
|
3050 if (set->dimen == 0) set->dimen = within->code->dim; |
|
3051 if (set->dimen != within->code->dim) |
|
3052 error(mpl, "set expression following within must have di" |
|
3053 "mension %d rather than %d", |
|
3054 set->dimen, within->code->dim); |
|
3055 } |
|
3056 else if (mpl->token == T_ASSIGN) |
|
3057 { /* assignment expression */ |
|
3058 if (!(set->assign == NULL && set->option == NULL && |
|
3059 set->gadget == NULL)) |
|
3060 err: error(mpl, "at most one := or default/data allowed"); |
|
3061 get_token(mpl /* := */); |
|
3062 /* parse an expression that follows ':=' */ |
|
3063 set->assign = expression_9(mpl); |
|
3064 if (set->assign->type != A_ELEMSET) |
|
3065 error(mpl, "expression following := has invalid type"); |
|
3066 xassert(set->assign->dim > 0); |
|
3067 /* check/set dimension of set members */ |
|
3068 if (set->dimen == 0) set->dimen = set->assign->dim; |
|
3069 if (set->dimen != set->assign->dim) |
|
3070 error(mpl, "set expression following := must have dimens" |
|
3071 "ion %d rather than %d", |
|
3072 set->dimen, set->assign->dim); |
|
3073 } |
|
3074 else if (is_keyword(mpl, "default")) |
|
3075 { /* expression for default value */ |
|
3076 if (!(set->assign == NULL && set->option == NULL)) goto err; |
|
3077 get_token(mpl /* := */); |
|
3078 /* parse an expression that follows 'default' */ |
|
3079 set->option = expression_9(mpl); |
|
3080 if (set->option->type != A_ELEMSET) |
|
3081 error(mpl, "expression following default has invalid typ" |
|
3082 "e"); |
|
3083 xassert(set->option->dim > 0); |
|
3084 /* check/set dimension of set members */ |
|
3085 if (set->dimen == 0) set->dimen = set->option->dim; |
|
3086 if (set->dimen != set->option->dim) |
|
3087 error(mpl, "set expression following default must have d" |
|
3088 "imension %d rather than %d", |
|
3089 set->dimen, set->option->dim); |
|
3090 } |
|
3091 #if 1 /* 12/XII-2008 */ |
|
3092 else if (is_keyword(mpl, "data")) |
|
3093 { /* gadget to initialize the set by data from plain set */ |
|
3094 GADGET *gadget; |
|
3095 AVLNODE *node; |
|
3096 int i, k, fff[20]; |
|
3097 if (!(set->assign == NULL && set->gadget == NULL)) goto err; |
|
3098 get_token(mpl /* data */); |
|
3099 set->gadget = gadget = alloc(GADGET); |
|
3100 /* set name must follow the keyword 'data' */ |
|
3101 if (mpl->token == T_NAME) |
|
3102 ; |
|
3103 else if (is_reserved(mpl)) |
|
3104 error(mpl, "invalid use of reserved keyword %s", |
|
3105 mpl->image); |
|
3106 else |
|
3107 error(mpl, "set name missing where expected"); |
|
3108 /* find the set in the symbolic name table */ |
|
3109 node = avl_find_node(mpl->tree, mpl->image); |
|
3110 if (node == NULL) |
|
3111 error(mpl, "%s not defined", mpl->image); |
|
3112 if (avl_get_node_type(node) != A_SET) |
|
3113 err1: error(mpl, "%s not a plain set", mpl->image); |
|
3114 gadget->set = avl_get_node_link(node); |
|
3115 if (gadget->set->dim != 0) goto err1; |
|
3116 if (gadget->set == set) |
|
3117 error(mpl, "set cannot be initialized by itself"); |
|
3118 /* check and set dimensions */ |
|
3119 if (set->dim >= gadget->set->dimen) |
|
3120 err2: error(mpl, "dimension of %s too small", mpl->image); |
|
3121 if (set->dimen == 0) |
|
3122 set->dimen = gadget->set->dimen - set->dim; |
|
3123 if (set->dim + set->dimen > gadget->set->dimen) |
|
3124 goto err2; |
|
3125 else if (set->dim + set->dimen < gadget->set->dimen) |
|
3126 error(mpl, "dimension of %s too big", mpl->image); |
|
3127 get_token(mpl /* set name */); |
|
3128 /* left parenthesis must follow the set name */ |
|
3129 if (mpl->token == T_LEFT) |
|
3130 get_token(mpl /* ( */); |
|
3131 else |
|
3132 error(mpl, "left parenthesis missing where expected"); |
|
3133 /* parse permutation of component numbers */ |
|
3134 for (k = 0; k < gadget->set->dimen; k++) fff[k] = 0; |
|
3135 k = 0; |
|
3136 for (;;) |
|
3137 { if (mpl->token != T_NUMBER) |
|
3138 error(mpl, "component number missing where expected"); |
|
3139 if (str2int(mpl->image, &i) != 0) |
|
3140 err3: error(mpl, "component number must be integer between " |
|
3141 "1 and %d", gadget->set->dimen); |
|
3142 if (!(1 <= i && i <= gadget->set->dimen)) goto err3; |
|
3143 if (fff[i-1] != 0) |
|
3144 error(mpl, "component %d multiply specified", i); |
|
3145 gadget->ind[k++] = i, fff[i-1] = 1; |
|
3146 xassert(k <= gadget->set->dimen); |
|
3147 get_token(mpl /* number */); |
|
3148 if (mpl->token == T_COMMA) |
|
3149 get_token(mpl /* , */); |
|
3150 else if (mpl->token == T_RIGHT) |
|
3151 break; |
|
3152 else |
|
3153 error(mpl, "syntax error in data attribute"); |
|
3154 } |
|
3155 if (k < gadget->set->dimen) |
|
3156 error(mpl, "there are must be %d components rather than " |
|
3157 "%d", gadget->set->dimen, k); |
|
3158 get_token(mpl /* ) */); |
|
3159 } |
|
3160 #endif |
|
3161 else |
|
3162 error(mpl, "syntax error in set statement"); |
|
3163 } |
|
3164 /* close the domain scope */ |
|
3165 if (set->domain != NULL) close_scope(mpl, set->domain); |
|
3166 /* if dimension of set members is still unknown, set it to 1 */ |
|
3167 if (set->dimen == 0) set->dimen = 1; |
|
3168 /* the set statement has been completely parsed */ |
|
3169 xassert(mpl->token == T_SEMICOLON); |
|
3170 get_token(mpl /* ; */); |
|
3171 return set; |
|
3172 } |
|
3173 |
|
3174 /*---------------------------------------------------------------------- |
|
3175 -- parameter_statement - parse parameter statement. |
|
3176 -- |
|
3177 -- This routine parses parameter statement using the syntax: |
|
3178 -- |
|
3179 -- <parameter statement> ::= param <symbolic name> <alias> <domain> |
|
3180 -- <attributes> ; |
|
3181 -- <alias> ::= <empty> |
|
3182 -- <alias> ::= <string literal> |
|
3183 -- <domain> ::= <empty> |
|
3184 -- <domain> ::= <indexing expression> |
|
3185 -- <attributes> ::= <empty> |
|
3186 -- <attributes> ::= <attributes> , integer |
|
3187 -- <attributes> ::= <attributes> , binary |
|
3188 -- <attributes> ::= <attributes> , symbolic |
|
3189 -- <attributes> ::= <attributes> , <rho> <expression 5> |
|
3190 -- <attributes> ::= <attributes> , in <expression 9> |
|
3191 -- <attributes> ::= <attributes> , := <expression 5> |
|
3192 -- <attributes> ::= <attributes> , default <expression 5> |
|
3193 -- <rho> ::= < | <= | = | == | >= | > | <> | != |
|
3194 -- |
|
3195 -- Commae in <attributes> are optional and may be omitted anywhere. */ |
|
3196 |
|
3197 PARAMETER *parameter_statement(MPL *mpl) |
|
3198 { PARAMETER *par; |
|
3199 int integer_used = 0, binary_used = 0, symbolic_used = 0; |
|
3200 xassert(is_keyword(mpl, "param")); |
|
3201 get_token(mpl /* param */); |
|
3202 /* symbolic name must follow the keyword 'param' */ |
|
3203 if (mpl->token == T_NAME) |
|
3204 ; |
|
3205 else if (is_reserved(mpl)) |
|
3206 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
3207 else |
|
3208 error(mpl, "symbolic name missing where expected"); |
|
3209 /* there must be no other object with the same name */ |
|
3210 if (avl_find_node(mpl->tree, mpl->image) != NULL) |
|
3211 error(mpl, "%s multiply declared", mpl->image); |
|
3212 /* create model parameter */ |
|
3213 par = alloc(PARAMETER); |
|
3214 par->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3215 strcpy(par->name, mpl->image); |
|
3216 par->alias = NULL; |
|
3217 par->dim = 0; |
|
3218 par->domain = NULL; |
|
3219 par->type = A_NUMERIC; |
|
3220 par->cond = NULL; |
|
3221 par->in = NULL; |
|
3222 par->assign = NULL; |
|
3223 par->option = NULL; |
|
3224 par->data = 0; |
|
3225 par->defval = NULL; |
|
3226 par->array = NULL; |
|
3227 get_token(mpl /* <symbolic name> */); |
|
3228 /* parse optional alias */ |
|
3229 if (mpl->token == T_STRING) |
|
3230 { par->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3231 strcpy(par->alias, mpl->image); |
|
3232 get_token(mpl /* <string literal> */); |
|
3233 } |
|
3234 /* parse optional indexing expression */ |
|
3235 if (mpl->token == T_LBRACE) |
|
3236 { par->domain = indexing_expression(mpl); |
|
3237 par->dim = domain_arity(mpl, par->domain); |
|
3238 } |
|
3239 /* include the parameter name in the symbolic names table */ |
|
3240 { AVLNODE *node; |
|
3241 node = avl_insert_node(mpl->tree, par->name); |
|
3242 avl_set_node_type(node, A_PARAMETER); |
|
3243 avl_set_node_link(node, (void *)par); |
|
3244 } |
|
3245 /* parse the list of optional attributes */ |
|
3246 for (;;) |
|
3247 { if (mpl->token == T_COMMA) |
|
3248 get_token(mpl /* , */); |
|
3249 else if (mpl->token == T_SEMICOLON) |
|
3250 break; |
|
3251 if (is_keyword(mpl, "integer")) |
|
3252 { if (integer_used) |
|
3253 error(mpl, "at most one integer allowed"); |
|
3254 if (par->type == A_SYMBOLIC) |
|
3255 error(mpl, "symbolic parameter cannot be integer"); |
|
3256 if (par->type != A_BINARY) par->type = A_INTEGER; |
|
3257 integer_used = 1; |
|
3258 get_token(mpl /* integer */); |
|
3259 } |
|
3260 else if (is_keyword(mpl, "binary")) |
|
3261 bin: { if (binary_used) |
|
3262 error(mpl, "at most one binary allowed"); |
|
3263 if (par->type == A_SYMBOLIC) |
|
3264 error(mpl, "symbolic parameter cannot be binary"); |
|
3265 par->type = A_BINARY; |
|
3266 binary_used = 1; |
|
3267 get_token(mpl /* binary */); |
|
3268 } |
|
3269 else if (is_keyword(mpl, "logical")) |
|
3270 { if (!mpl->as_binary) |
|
3271 { warning(mpl, "keyword logical understood as binary"); |
|
3272 mpl->as_binary = 1; |
|
3273 } |
|
3274 goto bin; |
|
3275 } |
|
3276 else if (is_keyword(mpl, "symbolic")) |
|
3277 { if (symbolic_used) |
|
3278 error(mpl, "at most one symbolic allowed"); |
|
3279 if (par->type != A_NUMERIC) |
|
3280 error(mpl, "integer or binary parameter cannot be symbol" |
|
3281 "ic"); |
|
3282 /* the parameter may be referenced from expressions given |
|
3283 in the same parameter declaration, so its type must be |
|
3284 completed before parsing that expressions */ |
|
3285 if (!(par->cond == NULL && par->in == NULL && |
|
3286 par->assign == NULL && par->option == NULL)) |
|
3287 error(mpl, "keyword symbolic must precede any other para" |
|
3288 "meter attributes"); |
|
3289 par->type = A_SYMBOLIC; |
|
3290 symbolic_used = 1; |
|
3291 get_token(mpl /* symbolic */); |
|
3292 } |
|
3293 else if (mpl->token == T_LT || mpl->token == T_LE || |
|
3294 mpl->token == T_EQ || mpl->token == T_GE || |
|
3295 mpl->token == T_GT || mpl->token == T_NE) |
|
3296 { /* restricting condition */ |
|
3297 CONDITION *cond, *temp; |
|
3298 char opstr[8]; |
|
3299 /* create new restricting condition list entry and append |
|
3300 it to the conditions list */ |
|
3301 cond = alloc(CONDITION); |
|
3302 switch (mpl->token) |
|
3303 { case T_LT: |
|
3304 cond->rho = O_LT, strcpy(opstr, mpl->image); break; |
|
3305 case T_LE: |
|
3306 cond->rho = O_LE, strcpy(opstr, mpl->image); break; |
|
3307 case T_EQ: |
|
3308 cond->rho = O_EQ, strcpy(opstr, mpl->image); break; |
|
3309 case T_GE: |
|
3310 cond->rho = O_GE, strcpy(opstr, mpl->image); break; |
|
3311 case T_GT: |
|
3312 cond->rho = O_GT, strcpy(opstr, mpl->image); break; |
|
3313 case T_NE: |
|
3314 cond->rho = O_NE, strcpy(opstr, mpl->image); break; |
|
3315 default: |
|
3316 xassert(mpl->token != mpl->token); |
|
3317 } |
|
3318 xassert(strlen(opstr) < sizeof(opstr)); |
|
3319 cond->code = NULL; |
|
3320 cond->next = NULL; |
|
3321 if (par->cond == NULL) |
|
3322 par->cond = cond; |
|
3323 else |
|
3324 { for (temp = par->cond; temp->next != NULL; temp = |
|
3325 temp->next); |
|
3326 temp->next = cond; |
|
3327 } |
|
3328 #if 0 /* 13/VIII-2008 */ |
|
3329 if (par->type == A_SYMBOLIC && |
|
3330 !(cond->rho == O_EQ || cond->rho == O_NE)) |
|
3331 error(mpl, "inequality restriction not allowed"); |
|
3332 #endif |
|
3333 get_token(mpl /* rho */); |
|
3334 /* parse an expression that follows relational operator */ |
|
3335 cond->code = expression_5(mpl); |
|
3336 if (!(cond->code->type == A_NUMERIC || |
|
3337 cond->code->type == A_SYMBOLIC)) |
|
3338 error(mpl, "expression following %s has invalid type", |
|
3339 opstr); |
|
3340 xassert(cond->code->dim == 0); |
|
3341 /* convert to the parameter type, if necessary */ |
|
3342 if (par->type != A_SYMBOLIC && cond->code->type == |
|
3343 A_SYMBOLIC) |
|
3344 cond->code = make_unary(mpl, O_CVTNUM, cond->code, |
|
3345 A_NUMERIC, 0); |
|
3346 if (par->type == A_SYMBOLIC && cond->code->type != |
|
3347 A_SYMBOLIC) |
|
3348 cond->code = make_unary(mpl, O_CVTSYM, cond->code, |
|
3349 A_SYMBOLIC, 0); |
|
3350 } |
|
3351 else if (mpl->token == T_IN || mpl->token == T_WITHIN) |
|
3352 { /* restricting superset */ |
|
3353 WITHIN *in, *temp; |
|
3354 if (mpl->token == T_WITHIN && !mpl->as_in) |
|
3355 { warning(mpl, "keyword within understood as in"); |
|
3356 mpl->as_in = 1; |
|
3357 } |
|
3358 get_token(mpl /* in */); |
|
3359 /* create new restricting superset list entry and append it |
|
3360 to the in-list */ |
|
3361 in = alloc(WITHIN); |
|
3362 in->code = NULL; |
|
3363 in->next = NULL; |
|
3364 if (par->in == NULL) |
|
3365 par->in = in; |
|
3366 else |
|
3367 { for (temp = par->in; temp->next != NULL; temp = |
|
3368 temp->next); |
|
3369 temp->next = in; |
|
3370 } |
|
3371 /* parse an expression that follows 'in' */ |
|
3372 in->code = expression_9(mpl); |
|
3373 if (in->code->type != A_ELEMSET) |
|
3374 error(mpl, "expression following in has invalid type"); |
|
3375 xassert(in->code->dim > 0); |
|
3376 if (in->code->dim != 1) |
|
3377 error(mpl, "set expression following in must have dimens" |
|
3378 "ion 1 rather than %d", in->code->dim); |
|
3379 } |
|
3380 else if (mpl->token == T_ASSIGN) |
|
3381 { /* assignment expression */ |
|
3382 if (!(par->assign == NULL && par->option == NULL)) |
|
3383 err: error(mpl, "at most one := or default allowed"); |
|
3384 get_token(mpl /* := */); |
|
3385 /* parse an expression that follows ':=' */ |
|
3386 par->assign = expression_5(mpl); |
|
3387 /* the expression must be of numeric/symbolic type */ |
|
3388 if (!(par->assign->type == A_NUMERIC || |
|
3389 par->assign->type == A_SYMBOLIC)) |
|
3390 error(mpl, "expression following := has invalid type"); |
|
3391 xassert(par->assign->dim == 0); |
|
3392 /* convert to the parameter type, if necessary */ |
|
3393 if (par->type != A_SYMBOLIC && par->assign->type == |
|
3394 A_SYMBOLIC) |
|
3395 par->assign = make_unary(mpl, O_CVTNUM, par->assign, |
|
3396 A_NUMERIC, 0); |
|
3397 if (par->type == A_SYMBOLIC && par->assign->type != |
|
3398 A_SYMBOLIC) |
|
3399 par->assign = make_unary(mpl, O_CVTSYM, par->assign, |
|
3400 A_SYMBOLIC, 0); |
|
3401 } |
|
3402 else if (is_keyword(mpl, "default")) |
|
3403 { /* expression for default value */ |
|
3404 if (!(par->assign == NULL && par->option == NULL)) goto err; |
|
3405 get_token(mpl /* default */); |
|
3406 /* parse an expression that follows 'default' */ |
|
3407 par->option = expression_5(mpl); |
|
3408 if (!(par->option->type == A_NUMERIC || |
|
3409 par->option->type == A_SYMBOLIC)) |
|
3410 error(mpl, "expression following default has invalid typ" |
|
3411 "e"); |
|
3412 xassert(par->option->dim == 0); |
|
3413 /* convert to the parameter type, if necessary */ |
|
3414 if (par->type != A_SYMBOLIC && par->option->type == |
|
3415 A_SYMBOLIC) |
|
3416 par->option = make_unary(mpl, O_CVTNUM, par->option, |
|
3417 A_NUMERIC, 0); |
|
3418 if (par->type == A_SYMBOLIC && par->option->type != |
|
3419 A_SYMBOLIC) |
|
3420 par->option = make_unary(mpl, O_CVTSYM, par->option, |
|
3421 A_SYMBOLIC, 0); |
|
3422 } |
|
3423 else |
|
3424 error(mpl, "syntax error in parameter statement"); |
|
3425 } |
|
3426 /* close the domain scope */ |
|
3427 if (par->domain != NULL) close_scope(mpl, par->domain); |
|
3428 /* the parameter statement has been completely parsed */ |
|
3429 xassert(mpl->token == T_SEMICOLON); |
|
3430 get_token(mpl /* ; */); |
|
3431 return par; |
|
3432 } |
|
3433 |
|
3434 /*---------------------------------------------------------------------- |
|
3435 -- variable_statement - parse variable statement. |
|
3436 -- |
|
3437 -- This routine parses variable statement using the syntax: |
|
3438 -- |
|
3439 -- <variable statement> ::= var <symbolic name> <alias> <domain> |
|
3440 -- <attributes> ; |
|
3441 -- <alias> ::= <empty> |
|
3442 -- <alias> ::= <string literal> |
|
3443 -- <domain> ::= <empty> |
|
3444 -- <domain> ::= <indexing expression> |
|
3445 -- <attributes> ::= <empty> |
|
3446 -- <attributes> ::= <attributes> , integer |
|
3447 -- <attributes> ::= <attributes> , binary |
|
3448 -- <attributes> ::= <attributes> , <rho> <expression 5> |
|
3449 -- <rho> ::= >= | <= | = | == |
|
3450 -- |
|
3451 -- Commae in <attributes> are optional and may be omitted anywhere. */ |
|
3452 |
|
3453 VARIABLE *variable_statement(MPL *mpl) |
|
3454 { VARIABLE *var; |
|
3455 int integer_used = 0, binary_used = 0; |
|
3456 xassert(is_keyword(mpl, "var")); |
|
3457 if (mpl->flag_s) |
|
3458 error(mpl, "variable statement must precede solve statement"); |
|
3459 get_token(mpl /* var */); |
|
3460 /* symbolic name must follow the keyword 'var' */ |
|
3461 if (mpl->token == T_NAME) |
|
3462 ; |
|
3463 else if (is_reserved(mpl)) |
|
3464 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
3465 else |
|
3466 error(mpl, "symbolic name missing where expected"); |
|
3467 /* there must be no other object with the same name */ |
|
3468 if (avl_find_node(mpl->tree, mpl->image) != NULL) |
|
3469 error(mpl, "%s multiply declared", mpl->image); |
|
3470 /* create model variable */ |
|
3471 var = alloc(VARIABLE); |
|
3472 var->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3473 strcpy(var->name, mpl->image); |
|
3474 var->alias = NULL; |
|
3475 var->dim = 0; |
|
3476 var->domain = NULL; |
|
3477 var->type = A_NUMERIC; |
|
3478 var->lbnd = NULL; |
|
3479 var->ubnd = NULL; |
|
3480 var->array = NULL; |
|
3481 get_token(mpl /* <symbolic name> */); |
|
3482 /* parse optional alias */ |
|
3483 if (mpl->token == T_STRING) |
|
3484 { var->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3485 strcpy(var->alias, mpl->image); |
|
3486 get_token(mpl /* <string literal> */); |
|
3487 } |
|
3488 /* parse optional indexing expression */ |
|
3489 if (mpl->token == T_LBRACE) |
|
3490 { var->domain = indexing_expression(mpl); |
|
3491 var->dim = domain_arity(mpl, var->domain); |
|
3492 } |
|
3493 /* include the variable name in the symbolic names table */ |
|
3494 { AVLNODE *node; |
|
3495 node = avl_insert_node(mpl->tree, var->name); |
|
3496 avl_set_node_type(node, A_VARIABLE); |
|
3497 avl_set_node_link(node, (void *)var); |
|
3498 } |
|
3499 /* parse the list of optional attributes */ |
|
3500 for (;;) |
|
3501 { if (mpl->token == T_COMMA) |
|
3502 get_token(mpl /* , */); |
|
3503 else if (mpl->token == T_SEMICOLON) |
|
3504 break; |
|
3505 if (is_keyword(mpl, "integer")) |
|
3506 { if (integer_used) |
|
3507 error(mpl, "at most one integer allowed"); |
|
3508 if (var->type != A_BINARY) var->type = A_INTEGER; |
|
3509 integer_used = 1; |
|
3510 get_token(mpl /* integer */); |
|
3511 } |
|
3512 else if (is_keyword(mpl, "binary")) |
|
3513 bin: { if (binary_used) |
|
3514 error(mpl, "at most one binary allowed"); |
|
3515 var->type = A_BINARY; |
|
3516 binary_used = 1; |
|
3517 get_token(mpl /* binary */); |
|
3518 } |
|
3519 else if (is_keyword(mpl, "logical")) |
|
3520 { if (!mpl->as_binary) |
|
3521 { warning(mpl, "keyword logical understood as binary"); |
|
3522 mpl->as_binary = 1; |
|
3523 } |
|
3524 goto bin; |
|
3525 } |
|
3526 else if (is_keyword(mpl, "symbolic")) |
|
3527 error(mpl, "variable cannot be symbolic"); |
|
3528 else if (mpl->token == T_GE) |
|
3529 { /* lower bound */ |
|
3530 if (var->lbnd != NULL) |
|
3531 { if (var->lbnd == var->ubnd) |
|
3532 error(mpl, "both fixed value and lower bound not allo" |
|
3533 "wed"); |
|
3534 else |
|
3535 error(mpl, "at most one lower bound allowed"); |
|
3536 } |
|
3537 get_token(mpl /* >= */); |
|
3538 /* parse an expression that specifies the lower bound */ |
|
3539 var->lbnd = expression_5(mpl); |
|
3540 if (var->lbnd->type == A_SYMBOLIC) |
|
3541 var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd, |
|
3542 A_NUMERIC, 0); |
|
3543 if (var->lbnd->type != A_NUMERIC) |
|
3544 error(mpl, "expression following >= has invalid type"); |
|
3545 xassert(var->lbnd->dim == 0); |
|
3546 } |
|
3547 else if (mpl->token == T_LE) |
|
3548 { /* upper bound */ |
|
3549 if (var->ubnd != NULL) |
|
3550 { if (var->ubnd == var->lbnd) |
|
3551 error(mpl, "both fixed value and upper bound not allo" |
|
3552 "wed"); |
|
3553 else |
|
3554 error(mpl, "at most one upper bound allowed"); |
|
3555 } |
|
3556 get_token(mpl /* <= */); |
|
3557 /* parse an expression that specifies the upper bound */ |
|
3558 var->ubnd = expression_5(mpl); |
|
3559 if (var->ubnd->type == A_SYMBOLIC) |
|
3560 var->ubnd = make_unary(mpl, O_CVTNUM, var->ubnd, |
|
3561 A_NUMERIC, 0); |
|
3562 if (var->ubnd->type != A_NUMERIC) |
|
3563 error(mpl, "expression following <= has invalid type"); |
|
3564 xassert(var->ubnd->dim == 0); |
|
3565 } |
|
3566 else if (mpl->token == T_EQ) |
|
3567 { /* fixed value */ |
|
3568 char opstr[8]; |
|
3569 if (!(var->lbnd == NULL && var->ubnd == NULL)) |
|
3570 { if (var->lbnd == var->ubnd) |
|
3571 error(mpl, "at most one fixed value allowed"); |
|
3572 else if (var->lbnd != NULL) |
|
3573 error(mpl, "both lower bound and fixed value not allo" |
|
3574 "wed"); |
|
3575 else |
|
3576 error(mpl, "both upper bound and fixed value not allo" |
|
3577 "wed"); |
|
3578 } |
|
3579 strcpy(opstr, mpl->image); |
|
3580 xassert(strlen(opstr) < sizeof(opstr)); |
|
3581 get_token(mpl /* = | == */); |
|
3582 /* parse an expression that specifies the fixed value */ |
|
3583 var->lbnd = expression_5(mpl); |
|
3584 if (var->lbnd->type == A_SYMBOLIC) |
|
3585 var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd, |
|
3586 A_NUMERIC, 0); |
|
3587 if (var->lbnd->type != A_NUMERIC) |
|
3588 error(mpl, "expression following %s has invalid type", |
|
3589 opstr); |
|
3590 xassert(var->lbnd->dim == 0); |
|
3591 /* indicate that the variable is fixed, not bounded */ |
|
3592 var->ubnd = var->lbnd; |
|
3593 } |
|
3594 else if (mpl->token == T_LT || mpl->token == T_GT || |
|
3595 mpl->token == T_NE) |
|
3596 error(mpl, "strict bound not allowed"); |
|
3597 else |
|
3598 error(mpl, "syntax error in variable statement"); |
|
3599 } |
|
3600 /* close the domain scope */ |
|
3601 if (var->domain != NULL) close_scope(mpl, var->domain); |
|
3602 /* the variable statement has been completely parsed */ |
|
3603 xassert(mpl->token == T_SEMICOLON); |
|
3604 get_token(mpl /* ; */); |
|
3605 return var; |
|
3606 } |
|
3607 |
|
3608 /*---------------------------------------------------------------------- |
|
3609 -- constraint_statement - parse constraint statement. |
|
3610 -- |
|
3611 -- This routine parses constraint statement using the syntax: |
|
3612 -- |
|
3613 -- <constraint statement> ::= <subject to> <symbolic name> <alias> |
|
3614 -- <domain> : <constraint> ; |
|
3615 -- <subject to> ::= <empty> |
|
3616 -- <subject to> ::= subject to |
|
3617 -- <subject to> ::= subj to |
|
3618 -- <subject to> ::= s.t. |
|
3619 -- <alias> ::= <empty> |
|
3620 -- <alias> ::= <string literal> |
|
3621 -- <domain> ::= <empty> |
|
3622 -- <domain> ::= <indexing expression> |
|
3623 -- <constraint> ::= <formula> , >= <formula> |
|
3624 -- <constraint> ::= <formula> , <= <formula> |
|
3625 -- <constraint> ::= <formula> , = <formula> |
|
3626 -- <constraint> ::= <formula> , <= <formula> , <= <formula> |
|
3627 -- <constraint> ::= <formula> , >= <formula> , >= <formula> |
|
3628 -- <formula> ::= <expression 5> |
|
3629 -- |
|
3630 -- Commae in <constraint> are optional and may be omitted anywhere. */ |
|
3631 |
|
3632 CONSTRAINT *constraint_statement(MPL *mpl) |
|
3633 { CONSTRAINT *con; |
|
3634 CODE *first, *second, *third; |
|
3635 int rho; |
|
3636 char opstr[8]; |
|
3637 if (mpl->flag_s) |
|
3638 error(mpl, "constraint statement must precede solve statement") |
|
3639 ; |
|
3640 if (is_keyword(mpl, "subject")) |
|
3641 { get_token(mpl /* subject */); |
|
3642 if (!is_keyword(mpl, "to")) |
|
3643 error(mpl, "keyword subject to incomplete"); |
|
3644 get_token(mpl /* to */); |
|
3645 } |
|
3646 else if (is_keyword(mpl, "subj")) |
|
3647 { get_token(mpl /* subj */); |
|
3648 if (!is_keyword(mpl, "to")) |
|
3649 error(mpl, "keyword subj to incomplete"); |
|
3650 get_token(mpl /* to */); |
|
3651 } |
|
3652 else if (mpl->token == T_SPTP) |
|
3653 get_token(mpl /* s.t. */); |
|
3654 /* the current token must be symbolic name of constraint */ |
|
3655 if (mpl->token == T_NAME) |
|
3656 ; |
|
3657 else if (is_reserved(mpl)) |
|
3658 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
3659 else |
|
3660 error(mpl, "symbolic name missing where expected"); |
|
3661 /* there must be no other object with the same name */ |
|
3662 if (avl_find_node(mpl->tree, mpl->image) != NULL) |
|
3663 error(mpl, "%s multiply declared", mpl->image); |
|
3664 /* create model constraint */ |
|
3665 con = alloc(CONSTRAINT); |
|
3666 con->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3667 strcpy(con->name, mpl->image); |
|
3668 con->alias = NULL; |
|
3669 con->dim = 0; |
|
3670 con->domain = NULL; |
|
3671 con->type = A_CONSTRAINT; |
|
3672 con->code = NULL; |
|
3673 con->lbnd = NULL; |
|
3674 con->ubnd = NULL; |
|
3675 con->array = NULL; |
|
3676 get_token(mpl /* <symbolic name> */); |
|
3677 /* parse optional alias */ |
|
3678 if (mpl->token == T_STRING) |
|
3679 { con->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3680 strcpy(con->alias, mpl->image); |
|
3681 get_token(mpl /* <string literal> */); |
|
3682 } |
|
3683 /* parse optional indexing expression */ |
|
3684 if (mpl->token == T_LBRACE) |
|
3685 { con->domain = indexing_expression(mpl); |
|
3686 con->dim = domain_arity(mpl, con->domain); |
|
3687 } |
|
3688 /* include the constraint name in the symbolic names table */ |
|
3689 { AVLNODE *node; |
|
3690 node = avl_insert_node(mpl->tree, con->name); |
|
3691 avl_set_node_type(node, A_CONSTRAINT); |
|
3692 avl_set_node_link(node, (void *)con); |
|
3693 } |
|
3694 /* the colon must precede the first expression */ |
|
3695 if (mpl->token != T_COLON) |
|
3696 error(mpl, "colon missing where expected"); |
|
3697 get_token(mpl /* : */); |
|
3698 /* parse the first expression */ |
|
3699 first = expression_5(mpl); |
|
3700 if (first->type == A_SYMBOLIC) |
|
3701 first = make_unary(mpl, O_CVTNUM, first, A_NUMERIC, 0); |
|
3702 if (!(first->type == A_NUMERIC || first->type == A_FORMULA)) |
|
3703 error(mpl, "expression following colon has invalid type"); |
|
3704 xassert(first->dim == 0); |
|
3705 /* relational operator must follow the first expression */ |
|
3706 if (mpl->token == T_COMMA) get_token(mpl /* , */); |
|
3707 switch (mpl->token) |
|
3708 { case T_LE: |
|
3709 case T_GE: |
|
3710 case T_EQ: |
|
3711 break; |
|
3712 case T_LT: |
|
3713 case T_GT: |
|
3714 case T_NE: |
|
3715 error(mpl, "strict inequality not allowed"); |
|
3716 case T_SEMICOLON: |
|
3717 error(mpl, "constraint must be equality or inequality"); |
|
3718 default: |
|
3719 goto err; |
|
3720 } |
|
3721 rho = mpl->token; |
|
3722 strcpy(opstr, mpl->image); |
|
3723 xassert(strlen(opstr) < sizeof(opstr)); |
|
3724 get_token(mpl /* rho */); |
|
3725 /* parse the second expression */ |
|
3726 second = expression_5(mpl); |
|
3727 if (second->type == A_SYMBOLIC) |
|
3728 second = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0); |
|
3729 if (!(second->type == A_NUMERIC || second->type == A_FORMULA)) |
|
3730 error(mpl, "expression following %s has invalid type", opstr); |
|
3731 xassert(second->dim == 0); |
|
3732 /* check a token that follow the second expression */ |
|
3733 if (mpl->token == T_COMMA) |
|
3734 { get_token(mpl /* , */); |
|
3735 if (mpl->token == T_SEMICOLON) goto err; |
|
3736 } |
|
3737 if (mpl->token == T_LT || mpl->token == T_LE || |
|
3738 mpl->token == T_EQ || mpl->token == T_GE || |
|
3739 mpl->token == T_GT || mpl->token == T_NE) |
|
3740 { /* it is another relational operator, therefore the constraint |
|
3741 is double inequality */ |
|
3742 if (rho == T_EQ || mpl->token != rho) |
|
3743 error(mpl, "double inequality must be ... <= ... <= ... or " |
|
3744 "... >= ... >= ..."); |
|
3745 /* the first expression cannot be linear form */ |
|
3746 if (first->type == A_FORMULA) |
|
3747 error(mpl, "leftmost expression in double inequality cannot" |
|
3748 " be linear form"); |
|
3749 get_token(mpl /* rho */); |
|
3750 /* parse the third expression */ |
|
3751 third = expression_5(mpl); |
|
3752 if (third->type == A_SYMBOLIC) |
|
3753 third = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0); |
|
3754 if (!(third->type == A_NUMERIC || third->type == A_FORMULA)) |
|
3755 error(mpl, "rightmost expression in double inequality const" |
|
3756 "raint has invalid type"); |
|
3757 xassert(third->dim == 0); |
|
3758 /* the third expression also cannot be linear form */ |
|
3759 if (third->type == A_FORMULA) |
|
3760 error(mpl, "rightmost expression in double inequality canno" |
|
3761 "t be linear form"); |
|
3762 } |
|
3763 else |
|
3764 { /* the constraint is equality or single inequality */ |
|
3765 third = NULL; |
|
3766 } |
|
3767 /* close the domain scope */ |
|
3768 if (con->domain != NULL) close_scope(mpl, con->domain); |
|
3769 /* convert all expressions to linear form, if necessary */ |
|
3770 if (first->type != A_FORMULA) |
|
3771 first = make_unary(mpl, O_CVTLFM, first, A_FORMULA, 0); |
|
3772 if (second->type != A_FORMULA) |
|
3773 second = make_unary(mpl, O_CVTLFM, second, A_FORMULA, 0); |
|
3774 if (third != NULL) |
|
3775 third = make_unary(mpl, O_CVTLFM, third, A_FORMULA, 0); |
|
3776 /* arrange expressions in the constraint */ |
|
3777 if (third == NULL) |
|
3778 { /* the constraint is equality or single inequality */ |
|
3779 switch (rho) |
|
3780 { case T_LE: |
|
3781 /* first <= second */ |
|
3782 con->code = first; |
|
3783 con->lbnd = NULL; |
|
3784 con->ubnd = second; |
|
3785 break; |
|
3786 case T_GE: |
|
3787 /* first >= second */ |
|
3788 con->code = first; |
|
3789 con->lbnd = second; |
|
3790 con->ubnd = NULL; |
|
3791 break; |
|
3792 case T_EQ: |
|
3793 /* first = second */ |
|
3794 con->code = first; |
|
3795 con->lbnd = second; |
|
3796 con->ubnd = second; |
|
3797 break; |
|
3798 default: |
|
3799 xassert(rho != rho); |
|
3800 } |
|
3801 } |
|
3802 else |
|
3803 { /* the constraint is double inequality */ |
|
3804 switch (rho) |
|
3805 { case T_LE: |
|
3806 /* first <= second <= third */ |
|
3807 con->code = second; |
|
3808 con->lbnd = first; |
|
3809 con->ubnd = third; |
|
3810 break; |
|
3811 case T_GE: |
|
3812 /* first >= second >= third */ |
|
3813 con->code = second; |
|
3814 con->lbnd = third; |
|
3815 con->ubnd = first; |
|
3816 break; |
|
3817 default: |
|
3818 xassert(rho != rho); |
|
3819 } |
|
3820 } |
|
3821 /* the constraint statement has been completely parsed */ |
|
3822 if (mpl->token != T_SEMICOLON) |
|
3823 err: error(mpl, "syntax error in constraint statement"); |
|
3824 get_token(mpl /* ; */); |
|
3825 return con; |
|
3826 } |
|
3827 |
|
3828 /*---------------------------------------------------------------------- |
|
3829 -- objective_statement - parse objective statement. |
|
3830 -- |
|
3831 -- This routine parses objective statement using the syntax: |
|
3832 -- |
|
3833 -- <objective statement> ::= <verb> <symbolic name> <alias> <domain> : |
|
3834 -- <formula> ; |
|
3835 -- <verb> ::= minimize |
|
3836 -- <verb> ::= maximize |
|
3837 -- <alias> ::= <empty> |
|
3838 -- <alias> ::= <string literal> |
|
3839 -- <domain> ::= <empty> |
|
3840 -- <domain> ::= <indexing expression> |
|
3841 -- <formula> ::= <expression 5> */ |
|
3842 |
|
3843 CONSTRAINT *objective_statement(MPL *mpl) |
|
3844 { CONSTRAINT *obj; |
|
3845 int type; |
|
3846 if (is_keyword(mpl, "minimize")) |
|
3847 type = A_MINIMIZE; |
|
3848 else if (is_keyword(mpl, "maximize")) |
|
3849 type = A_MAXIMIZE; |
|
3850 else |
|
3851 xassert(mpl != mpl); |
|
3852 if (mpl->flag_s) |
|
3853 error(mpl, "objective statement must precede solve statement"); |
|
3854 get_token(mpl /* minimize | maximize */); |
|
3855 /* symbolic name must follow the verb 'minimize' or 'maximize' */ |
|
3856 if (mpl->token == T_NAME) |
|
3857 ; |
|
3858 else if (is_reserved(mpl)) |
|
3859 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
3860 else |
|
3861 error(mpl, "symbolic name missing where expected"); |
|
3862 /* there must be no other object with the same name */ |
|
3863 if (avl_find_node(mpl->tree, mpl->image) != NULL) |
|
3864 error(mpl, "%s multiply declared", mpl->image); |
|
3865 /* create model objective */ |
|
3866 obj = alloc(CONSTRAINT); |
|
3867 obj->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3868 strcpy(obj->name, mpl->image); |
|
3869 obj->alias = NULL; |
|
3870 obj->dim = 0; |
|
3871 obj->domain = NULL; |
|
3872 obj->type = type; |
|
3873 obj->code = NULL; |
|
3874 obj->lbnd = NULL; |
|
3875 obj->ubnd = NULL; |
|
3876 obj->array = NULL; |
|
3877 get_token(mpl /* <symbolic name> */); |
|
3878 /* parse optional alias */ |
|
3879 if (mpl->token == T_STRING) |
|
3880 { obj->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3881 strcpy(obj->alias, mpl->image); |
|
3882 get_token(mpl /* <string literal> */); |
|
3883 } |
|
3884 /* parse optional indexing expression */ |
|
3885 if (mpl->token == T_LBRACE) |
|
3886 { obj->domain = indexing_expression(mpl); |
|
3887 obj->dim = domain_arity(mpl, obj->domain); |
|
3888 } |
|
3889 /* include the constraint name in the symbolic names table */ |
|
3890 { AVLNODE *node; |
|
3891 node = avl_insert_node(mpl->tree, obj->name); |
|
3892 avl_set_node_type(node, A_CONSTRAINT); |
|
3893 avl_set_node_link(node, (void *)obj); |
|
3894 } |
|
3895 /* the colon must precede the objective expression */ |
|
3896 if (mpl->token != T_COLON) |
|
3897 error(mpl, "colon missing where expected"); |
|
3898 get_token(mpl /* : */); |
|
3899 /* parse the objective expression */ |
|
3900 obj->code = expression_5(mpl); |
|
3901 if (obj->code->type == A_SYMBOLIC) |
|
3902 obj->code = make_unary(mpl, O_CVTNUM, obj->code, A_NUMERIC, 0); |
|
3903 if (obj->code->type == A_NUMERIC) |
|
3904 obj->code = make_unary(mpl, O_CVTLFM, obj->code, A_FORMULA, 0); |
|
3905 if (obj->code->type != A_FORMULA) |
|
3906 error(mpl, "expression following colon has invalid type"); |
|
3907 xassert(obj->code->dim == 0); |
|
3908 /* close the domain scope */ |
|
3909 if (obj->domain != NULL) close_scope(mpl, obj->domain); |
|
3910 /* the objective statement has been completely parsed */ |
|
3911 if (mpl->token != T_SEMICOLON) |
|
3912 error(mpl, "syntax error in objective statement"); |
|
3913 get_token(mpl /* ; */); |
|
3914 return obj; |
|
3915 } |
|
3916 |
|
3917 #if 1 /* 11/II-2008 */ |
|
3918 /*********************************************************************** |
|
3919 * table_statement - parse table statement |
|
3920 * |
|
3921 * This routine parses table statement using the syntax: |
|
3922 * |
|
3923 * <table statement> ::= <input table statement> |
|
3924 * <table statement> ::= <output table statement> |
|
3925 * |
|
3926 * <input table statement> ::= |
|
3927 * table <table name> <alias> IN <argument list> : |
|
3928 * <input set> [ <field list> ] , <input list> ; |
|
3929 * <alias> ::= <empty> |
|
3930 * <alias> ::= <string literal> |
|
3931 * <argument list> ::= <expression 5> |
|
3932 * <argument list> ::= <argument list> <expression 5> |
|
3933 * <argument list> ::= <argument list> , <expression 5> |
|
3934 * <input set> ::= <empty> |
|
3935 * <input set> ::= <set name> <- |
|
3936 * <field list> ::= <field name> |
|
3937 * <field list> ::= <field list> , <field name> |
|
3938 * <input list> ::= <input item> |
|
3939 * <input list> ::= <input list> , <input item> |
|
3940 * <input item> ::= <parameter name> |
|
3941 * <input item> ::= <parameter name> ~ <field name> |
|
3942 * |
|
3943 * <output table statement> ::= |
|
3944 * table <table name> <alias> <domain> OUT <argument list> : |
|
3945 * <output list> ; |
|
3946 * <domain> ::= <indexing expression> |
|
3947 * <output list> ::= <output item> |
|
3948 * <output list> ::= <output list> , <output item> |
|
3949 * <output item> ::= <expression 5> |
|
3950 * <output item> ::= <expression 5> ~ <field name> */ |
|
3951 |
|
3952 TABLE *table_statement(MPL *mpl) |
|
3953 { TABLE *tab; |
|
3954 TABARG *last_arg, *arg; |
|
3955 TABFLD *last_fld, *fld; |
|
3956 TABIN *last_in, *in; |
|
3957 TABOUT *last_out, *out; |
|
3958 AVLNODE *node; |
|
3959 int nflds; |
|
3960 char name[MAX_LENGTH+1]; |
|
3961 xassert(is_keyword(mpl, "table")); |
|
3962 get_token(mpl /* solve */); |
|
3963 /* symbolic name must follow the keyword table */ |
|
3964 if (mpl->token == T_NAME) |
|
3965 ; |
|
3966 else if (is_reserved(mpl)) |
|
3967 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
3968 else |
|
3969 error(mpl, "symbolic name missing where expected"); |
|
3970 /* there must be no other object with the same name */ |
|
3971 if (avl_find_node(mpl->tree, mpl->image) != NULL) |
|
3972 error(mpl, "%s multiply declared", mpl->image); |
|
3973 /* create data table */ |
|
3974 tab = alloc(TABLE); |
|
3975 tab->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3976 strcpy(tab->name, mpl->image); |
|
3977 get_token(mpl /* <symbolic name> */); |
|
3978 /* parse optional alias */ |
|
3979 if (mpl->token == T_STRING) |
|
3980 { tab->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
3981 strcpy(tab->alias, mpl->image); |
|
3982 get_token(mpl /* <string literal> */); |
|
3983 } |
|
3984 else |
|
3985 tab->alias = NULL; |
|
3986 /* parse optional indexing expression */ |
|
3987 if (mpl->token == T_LBRACE) |
|
3988 { /* this is output table */ |
|
3989 tab->type = A_OUTPUT; |
|
3990 tab->u.out.domain = indexing_expression(mpl); |
|
3991 if (!is_keyword(mpl, "OUT")) |
|
3992 error(mpl, "keyword OUT missing where expected"); |
|
3993 get_token(mpl /* OUT */); |
|
3994 } |
|
3995 else |
|
3996 { /* this is input table */ |
|
3997 tab->type = A_INPUT; |
|
3998 if (!is_keyword(mpl, "IN")) |
|
3999 error(mpl, "keyword IN missing where expected"); |
|
4000 get_token(mpl /* IN */); |
|
4001 } |
|
4002 /* parse argument list */ |
|
4003 tab->arg = last_arg = NULL; |
|
4004 for (;;) |
|
4005 { /* create argument list entry */ |
|
4006 arg = alloc(TABARG); |
|
4007 /* parse argument expression */ |
|
4008 if (mpl->token == T_COMMA || mpl->token == T_COLON || |
|
4009 mpl->token == T_SEMICOLON) |
|
4010 error(mpl, "argument expression missing where expected"); |
|
4011 arg->code = expression_5(mpl); |
|
4012 /* convert the result to symbolic type, if necessary */ |
|
4013 if (arg->code->type == A_NUMERIC) |
|
4014 arg->code = |
|
4015 make_unary(mpl, O_CVTSYM, arg->code, A_SYMBOLIC, 0); |
|
4016 /* check that now the result is of symbolic type */ |
|
4017 if (arg->code->type != A_SYMBOLIC) |
|
4018 error(mpl, "argument expression has invalid type"); |
|
4019 /* add the entry to the end of the list */ |
|
4020 arg->next = NULL; |
|
4021 if (last_arg == NULL) |
|
4022 tab->arg = arg; |
|
4023 else |
|
4024 last_arg->next = arg; |
|
4025 last_arg = arg; |
|
4026 /* argument expression has been parsed */ |
|
4027 if (mpl->token == T_COMMA) |
|
4028 get_token(mpl /* , */); |
|
4029 else if (mpl->token == T_COLON || mpl->token == T_SEMICOLON) |
|
4030 break; |
|
4031 } |
|
4032 xassert(tab->arg != NULL); |
|
4033 /* argument list must end with colon */ |
|
4034 if (mpl->token == T_COLON) |
|
4035 get_token(mpl /* : */); |
|
4036 else |
|
4037 error(mpl, "colon missing where expected"); |
|
4038 /* parse specific part of the table statement */ |
|
4039 switch (tab->type) |
|
4040 { case A_INPUT: goto input_table; |
|
4041 case A_OUTPUT: goto output_table; |
|
4042 default: xassert(tab != tab); |
|
4043 } |
|
4044 input_table: |
|
4045 /* parse optional set name */ |
|
4046 if (mpl->token == T_NAME) |
|
4047 { node = avl_find_node(mpl->tree, mpl->image); |
|
4048 if (node == NULL) |
|
4049 error(mpl, "%s not defined", mpl->image); |
|
4050 if (avl_get_node_type(node) != A_SET) |
|
4051 error(mpl, "%s not a set", mpl->image); |
|
4052 tab->u.in.set = (SET *)avl_get_node_link(node); |
|
4053 if (tab->u.in.set->assign != NULL) |
|
4054 error(mpl, "%s needs no data", mpl->image); |
|
4055 if (tab->u.in.set->dim != 0) |
|
4056 error(mpl, "%s must be a simple set", mpl->image); |
|
4057 get_token(mpl /* <symbolic name> */); |
|
4058 if (mpl->token == T_INPUT) |
|
4059 get_token(mpl /* <- */); |
|
4060 else |
|
4061 error(mpl, "delimiter <- missing where expected"); |
|
4062 } |
|
4063 else if (is_reserved(mpl)) |
|
4064 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
4065 else |
|
4066 tab->u.in.set = NULL; |
|
4067 /* parse field list */ |
|
4068 tab->u.in.fld = last_fld = NULL; |
|
4069 nflds = 0; |
|
4070 if (mpl->token == T_LBRACKET) |
|
4071 get_token(mpl /* [ */); |
|
4072 else |
|
4073 error(mpl, "field list missing where expected"); |
|
4074 for (;;) |
|
4075 { /* create field list entry */ |
|
4076 fld = alloc(TABFLD); |
|
4077 /* parse field name */ |
|
4078 if (mpl->token == T_NAME) |
|
4079 ; |
|
4080 else if (is_reserved(mpl)) |
|
4081 error(mpl, |
|
4082 "invalid use of reserved keyword %s", mpl->image); |
|
4083 else |
|
4084 error(mpl, "field name missing where expected"); |
|
4085 fld->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); |
|
4086 strcpy(fld->name, mpl->image); |
|
4087 get_token(mpl /* <symbolic name> */); |
|
4088 /* add the entry to the end of the list */ |
|
4089 fld->next = NULL; |
|
4090 if (last_fld == NULL) |
|
4091 tab->u.in.fld = fld; |
|
4092 else |
|
4093 last_fld->next = fld; |
|
4094 last_fld = fld; |
|
4095 nflds++; |
|
4096 /* field name has been parsed */ |
|
4097 if (mpl->token == T_COMMA) |
|
4098 get_token(mpl /* , */); |
|
4099 else if (mpl->token == T_RBRACKET) |
|
4100 break; |
|
4101 else |
|
4102 error(mpl, "syntax error in field list"); |
|
4103 } |
|
4104 /* check that the set dimen is equal to the number of fields */ |
|
4105 if (tab->u.in.set != NULL && tab->u.in.set->dimen != nflds) |
|
4106 error(mpl, "there must be %d field%s rather than %d", |
|
4107 tab->u.in.set->dimen, tab->u.in.set->dimen == 1 ? "" : "s", |
|
4108 nflds); |
|
4109 get_token(mpl /* ] */); |
|
4110 /* parse optional input list */ |
|
4111 tab->u.in.list = last_in = NULL; |
|
4112 while (mpl->token == T_COMMA) |
|
4113 { get_token(mpl /* , */); |
|
4114 /* create input list entry */ |
|
4115 in = alloc(TABIN); |
|
4116 /* parse parameter name */ |
|
4117 if (mpl->token == T_NAME) |
|
4118 ; |
|
4119 else if (is_reserved(mpl)) |
|
4120 error(mpl, |
|
4121 "invalid use of reserved keyword %s", mpl->image); |
|
4122 else |
|
4123 error(mpl, "parameter name missing where expected"); |
|
4124 node = avl_find_node(mpl->tree, mpl->image); |
|
4125 if (node == NULL) |
|
4126 error(mpl, "%s not defined", mpl->image); |
|
4127 if (avl_get_node_type(node) != A_PARAMETER) |
|
4128 error(mpl, "%s not a parameter", mpl->image); |
|
4129 in->par = (PARAMETER *)avl_get_node_link(node); |
|
4130 if (in->par->dim != nflds) |
|
4131 error(mpl, "%s must have %d subscript%s rather than %d", |
|
4132 mpl->image, nflds, nflds == 1 ? "" : "s", in->par->dim); |
|
4133 if (in->par->assign != NULL) |
|
4134 error(mpl, "%s needs no data", mpl->image); |
|
4135 get_token(mpl /* <symbolic name> */); |
|
4136 /* parse optional field name */ |
|
4137 if (mpl->token == T_TILDE) |
|
4138 { get_token(mpl /* ~ */); |
|
4139 /* parse field name */ |
|
4140 if (mpl->token == T_NAME) |
|
4141 ; |
|
4142 else if (is_reserved(mpl)) |
|
4143 error(mpl, |
|
4144 "invalid use of reserved keyword %s", mpl->image); |
|
4145 else |
|
4146 error(mpl, "field name missing where expected"); |
|
4147 xassert(strlen(mpl->image) < sizeof(name)); |
|
4148 strcpy(name, mpl->image); |
|
4149 get_token(mpl /* <symbolic name> */); |
|
4150 } |
|
4151 else |
|
4152 { /* field name is the same as the parameter name */ |
|
4153 xassert(strlen(in->par->name) < sizeof(name)); |
|
4154 strcpy(name, in->par->name); |
|
4155 } |
|
4156 /* assign field name */ |
|
4157 in->name = dmp_get_atomv(mpl->pool, strlen(name)+1); |
|
4158 strcpy(in->name, name); |
|
4159 /* add the entry to the end of the list */ |
|
4160 in->next = NULL; |
|
4161 if (last_in == NULL) |
|
4162 tab->u.in.list = in; |
|
4163 else |
|
4164 last_in->next = in; |
|
4165 last_in = in; |
|
4166 } |
|
4167 goto end_of_table; |
|
4168 output_table: |
|
4169 /* parse output list */ |
|
4170 tab->u.out.list = last_out = NULL; |
|
4171 for (;;) |
|
4172 { /* create output list entry */ |
|
4173 out = alloc(TABOUT); |
|
4174 /* parse expression */ |
|
4175 if (mpl->token == T_COMMA || mpl->token == T_SEMICOLON) |
|
4176 error(mpl, "expression missing where expected"); |
|
4177 if (mpl->token == T_NAME) |
|
4178 { xassert(strlen(mpl->image) < sizeof(name)); |
|
4179 strcpy(name, mpl->image); |
|
4180 } |
|
4181 else |
|
4182 name[0] = '\0'; |
|
4183 out->code = expression_5(mpl); |
|
4184 /* parse optional field name */ |
|
4185 if (mpl->token == T_TILDE) |
|
4186 { get_token(mpl /* ~ */); |
|
4187 /* parse field name */ |
|
4188 if (mpl->token == T_NAME) |
|
4189 ; |
|
4190 else if (is_reserved(mpl)) |
|
4191 error(mpl, |
|
4192 "invalid use of reserved keyword %s", mpl->image); |
|
4193 else |
|
4194 error(mpl, "field name missing where expected"); |
|
4195 xassert(strlen(mpl->image) < sizeof(name)); |
|
4196 strcpy(name, mpl->image); |
|
4197 get_token(mpl /* <symbolic name> */); |
|
4198 } |
|
4199 /* assign field name */ |
|
4200 if (name[0] == '\0') |
|
4201 error(mpl, "field name required"); |
|
4202 out->name = dmp_get_atomv(mpl->pool, strlen(name)+1); |
|
4203 strcpy(out->name, name); |
|
4204 /* add the entry to the end of the list */ |
|
4205 out->next = NULL; |
|
4206 if (last_out == NULL) |
|
4207 tab->u.out.list = out; |
|
4208 else |
|
4209 last_out->next = out; |
|
4210 last_out = out; |
|
4211 /* output item has been parsed */ |
|
4212 if (mpl->token == T_COMMA) |
|
4213 get_token(mpl /* , */); |
|
4214 else if (mpl->token == T_SEMICOLON) |
|
4215 break; |
|
4216 else |
|
4217 error(mpl, "syntax error in output list"); |
|
4218 } |
|
4219 /* close the domain scope */ |
|
4220 close_scope(mpl,tab->u.out.domain); |
|
4221 end_of_table: |
|
4222 /* the table statement must end with semicolon */ |
|
4223 if (mpl->token != T_SEMICOLON) |
|
4224 error(mpl, "syntax error in table statement"); |
|
4225 get_token(mpl /* ; */); |
|
4226 return tab; |
|
4227 } |
|
4228 #endif |
|
4229 |
|
4230 /*---------------------------------------------------------------------- |
|
4231 -- solve_statement - parse solve statement. |
|
4232 -- |
|
4233 -- This routine parses solve statement using the syntax: |
|
4234 -- |
|
4235 -- <solve statement> ::= solve ; |
|
4236 -- |
|
4237 -- The solve statement can be used at most once. */ |
|
4238 |
|
4239 void *solve_statement(MPL *mpl) |
|
4240 { xassert(is_keyword(mpl, "solve")); |
|
4241 if (mpl->flag_s) |
|
4242 error(mpl, "at most one solve statement allowed"); |
|
4243 mpl->flag_s = 1; |
|
4244 get_token(mpl /* solve */); |
|
4245 /* semicolon must follow solve statement */ |
|
4246 if (mpl->token != T_SEMICOLON) |
|
4247 error(mpl, "syntax error in solve statement"); |
|
4248 get_token(mpl /* ; */); |
|
4249 return NULL; |
|
4250 } |
|
4251 |
|
4252 /*---------------------------------------------------------------------- |
|
4253 -- check_statement - parse check statement. |
|
4254 -- |
|
4255 -- This routine parses check statement using the syntax: |
|
4256 -- |
|
4257 -- <check statement> ::= check <domain> : <expression 13> ; |
|
4258 -- <domain> ::= <empty> |
|
4259 -- <domain> ::= <indexing expression> |
|
4260 -- |
|
4261 -- If <domain> is omitted, colon following it may also be omitted. */ |
|
4262 |
|
4263 CHECK *check_statement(MPL *mpl) |
|
4264 { CHECK *chk; |
|
4265 xassert(is_keyword(mpl, "check")); |
|
4266 /* create check descriptor */ |
|
4267 chk = alloc(CHECK); |
|
4268 chk->domain = NULL; |
|
4269 chk->code = NULL; |
|
4270 get_token(mpl /* check */); |
|
4271 /* parse optional indexing expression */ |
|
4272 if (mpl->token == T_LBRACE) |
|
4273 { chk->domain = indexing_expression(mpl); |
|
4274 #if 0 |
|
4275 if (mpl->token != T_COLON) |
|
4276 error(mpl, "colon missing where expected"); |
|
4277 #endif |
|
4278 } |
|
4279 /* skip optional colon */ |
|
4280 if (mpl->token == T_COLON) get_token(mpl /* : */); |
|
4281 /* parse logical expression */ |
|
4282 chk->code = expression_13(mpl); |
|
4283 if (chk->code->type != A_LOGICAL) |
|
4284 error(mpl, "expression has invalid type"); |
|
4285 xassert(chk->code->dim == 0); |
|
4286 /* close the domain scope */ |
|
4287 if (chk->domain != NULL) close_scope(mpl, chk->domain); |
|
4288 /* the check statement has been completely parsed */ |
|
4289 if (mpl->token != T_SEMICOLON) |
|
4290 error(mpl, "syntax error in check statement"); |
|
4291 get_token(mpl /* ; */); |
|
4292 return chk; |
|
4293 } |
|
4294 |
|
4295 #if 1 /* 15/V-2010 */ |
|
4296 /*---------------------------------------------------------------------- |
|
4297 -- display_statement - parse display statement. |
|
4298 -- |
|
4299 -- This routine parses display statement using the syntax: |
|
4300 -- |
|
4301 -- <display statement> ::= display <domain> : <display list> ; |
|
4302 -- <display statement> ::= display <domain> <display list> ; |
|
4303 -- <domain> ::= <empty> |
|
4304 -- <domain> ::= <indexing expression> |
|
4305 -- <display list> ::= <display entry> |
|
4306 -- <display list> ::= <display list> , <display entry> |
|
4307 -- <display entry> ::= <dummy index> |
|
4308 -- <display entry> ::= <set name> |
|
4309 -- <display entry> ::= <set name> [ <subscript list> ] |
|
4310 -- <display entry> ::= <parameter name> |
|
4311 -- <display entry> ::= <parameter name> [ <subscript list> ] |
|
4312 -- <display entry> ::= <variable name> |
|
4313 -- <display entry> ::= <variable name> [ <subscript list> ] |
|
4314 -- <display entry> ::= <constraint name> |
|
4315 -- <display entry> ::= <constraint name> [ <subscript list> ] |
|
4316 -- <display entry> ::= <expression 13> */ |
|
4317 |
|
4318 DISPLAY *display_statement(MPL *mpl) |
|
4319 { DISPLAY *dpy; |
|
4320 DISPLAY1 *entry, *last_entry; |
|
4321 xassert(is_keyword(mpl, "display")); |
|
4322 /* create display descriptor */ |
|
4323 dpy = alloc(DISPLAY); |
|
4324 dpy->domain = NULL; |
|
4325 dpy->list = last_entry = NULL; |
|
4326 get_token(mpl /* display */); |
|
4327 /* parse optional indexing expression */ |
|
4328 if (mpl->token == T_LBRACE) |
|
4329 dpy->domain = indexing_expression(mpl); |
|
4330 /* skip optional colon */ |
|
4331 if (mpl->token == T_COLON) get_token(mpl /* : */); |
|
4332 /* parse display list */ |
|
4333 for (;;) |
|
4334 { /* create new display entry */ |
|
4335 entry = alloc(DISPLAY1); |
|
4336 entry->type = 0; |
|
4337 entry->next = NULL; |
|
4338 /* and append it to the display list */ |
|
4339 if (dpy->list == NULL) |
|
4340 dpy->list = entry; |
|
4341 else |
|
4342 last_entry->next = entry; |
|
4343 last_entry = entry; |
|
4344 /* parse display entry */ |
|
4345 if (mpl->token == T_NAME) |
|
4346 { AVLNODE *node; |
|
4347 int next_token; |
|
4348 get_token(mpl /* <symbolic name> */); |
|
4349 next_token = mpl->token; |
|
4350 unget_token(mpl); |
|
4351 if (!(next_token == T_COMMA || next_token == T_SEMICOLON)) |
|
4352 { /* symbolic name begins expression */ |
|
4353 goto expr; |
|
4354 } |
|
4355 /* display entry is dummy index or model object */ |
|
4356 node = avl_find_node(mpl->tree, mpl->image); |
|
4357 if (node == NULL) |
|
4358 error(mpl, "%s not defined", mpl->image); |
|
4359 entry->type = avl_get_node_type(node); |
|
4360 switch (avl_get_node_type(node)) |
|
4361 { case A_INDEX: |
|
4362 entry->u.slot = |
|
4363 (DOMAIN_SLOT *)avl_get_node_link(node); |
|
4364 break; |
|
4365 case A_SET: |
|
4366 entry->u.set = (SET *)avl_get_node_link(node); |
|
4367 break; |
|
4368 case A_PARAMETER: |
|
4369 entry->u.par = (PARAMETER *)avl_get_node_link(node); |
|
4370 break; |
|
4371 case A_VARIABLE: |
|
4372 entry->u.var = (VARIABLE *)avl_get_node_link(node); |
|
4373 if (!mpl->flag_s) |
|
4374 error(mpl, "invalid reference to variable %s above" |
|
4375 " solve statement", entry->u.var->name); |
|
4376 break; |
|
4377 case A_CONSTRAINT: |
|
4378 entry->u.con = (CONSTRAINT *)avl_get_node_link(node); |
|
4379 if (!mpl->flag_s) |
|
4380 error(mpl, "invalid reference to %s %s above solve" |
|
4381 " statement", |
|
4382 entry->u.con->type == A_CONSTRAINT ? |
|
4383 "constraint" : "objective", entry->u.con->name); |
|
4384 break; |
|
4385 default: |
|
4386 xassert(node != node); |
|
4387 } |
|
4388 get_token(mpl /* <symbolic name> */); |
|
4389 } |
|
4390 else |
|
4391 expr: { /* display entry is expression */ |
|
4392 entry->type = A_EXPRESSION; |
|
4393 entry->u.code = expression_13(mpl); |
|
4394 } |
|
4395 /* check a token that follows the entry parsed */ |
|
4396 if (mpl->token == T_COMMA) |
|
4397 get_token(mpl /* , */); |
|
4398 else |
|
4399 break; |
|
4400 } |
|
4401 /* close the domain scope */ |
|
4402 if (dpy->domain != NULL) close_scope(mpl, dpy->domain); |
|
4403 /* the display statement has been completely parsed */ |
|
4404 if (mpl->token != T_SEMICOLON) |
|
4405 error(mpl, "syntax error in display statement"); |
|
4406 get_token(mpl /* ; */); |
|
4407 return dpy; |
|
4408 } |
|
4409 #endif |
|
4410 |
|
4411 /*---------------------------------------------------------------------- |
|
4412 -- printf_statement - parse printf statement. |
|
4413 -- |
|
4414 -- This routine parses print statement using the syntax: |
|
4415 -- |
|
4416 -- <printf statement> ::= <printf clause> ; |
|
4417 -- <printf statement> ::= <printf clause> > <file name> ; |
|
4418 -- <printf statement> ::= <printf clause> >> <file name> ; |
|
4419 -- <printf clause> ::= printf <domain> : <format> <printf list> |
|
4420 -- <printf clause> ::= printf <domain> <format> <printf list> |
|
4421 -- <domain> ::= <empty> |
|
4422 -- <domain> ::= <indexing expression> |
|
4423 -- <format> ::= <expression 5> |
|
4424 -- <printf list> ::= <empty> |
|
4425 -- <printf list> ::= <printf list> , <printf entry> |
|
4426 -- <printf entry> ::= <expression 9> |
|
4427 -- <file name> ::= <expression 5> */ |
|
4428 |
|
4429 PRINTF *printf_statement(MPL *mpl) |
|
4430 { PRINTF *prt; |
|
4431 PRINTF1 *entry, *last_entry; |
|
4432 xassert(is_keyword(mpl, "printf")); |
|
4433 /* create printf descriptor */ |
|
4434 prt = alloc(PRINTF); |
|
4435 prt->domain = NULL; |
|
4436 prt->fmt = NULL; |
|
4437 prt->list = last_entry = NULL; |
|
4438 get_token(mpl /* printf */); |
|
4439 /* parse optional indexing expression */ |
|
4440 if (mpl->token == T_LBRACE) |
|
4441 { prt->domain = indexing_expression(mpl); |
|
4442 #if 0 |
|
4443 if (mpl->token != T_COLON) |
|
4444 error(mpl, "colon missing where expected"); |
|
4445 #endif |
|
4446 } |
|
4447 /* skip optional colon */ |
|
4448 if (mpl->token == T_COLON) get_token(mpl /* : */); |
|
4449 /* parse expression for format string */ |
|
4450 prt->fmt = expression_5(mpl); |
|
4451 /* convert it to symbolic type, if necessary */ |
|
4452 if (prt->fmt->type == A_NUMERIC) |
|
4453 prt->fmt = make_unary(mpl, O_CVTSYM, prt->fmt, A_SYMBOLIC, 0); |
|
4454 /* check that now the expression is of symbolic type */ |
|
4455 if (prt->fmt->type != A_SYMBOLIC) |
|
4456 error(mpl, "format expression has invalid type"); |
|
4457 /* parse printf list */ |
|
4458 while (mpl->token == T_COMMA) |
|
4459 { get_token(mpl /* , */); |
|
4460 /* create new printf entry */ |
|
4461 entry = alloc(PRINTF1); |
|
4462 entry->code = NULL; |
|
4463 entry->next = NULL; |
|
4464 /* and append it to the printf list */ |
|
4465 if (prt->list == NULL) |
|
4466 prt->list = entry; |
|
4467 else |
|
4468 last_entry->next = entry; |
|
4469 last_entry = entry; |
|
4470 /* parse printf entry */ |
|
4471 entry->code = expression_9(mpl); |
|
4472 if (!(entry->code->type == A_NUMERIC || |
|
4473 entry->code->type == A_SYMBOLIC || |
|
4474 entry->code->type == A_LOGICAL)) |
|
4475 error(mpl, "only numeric, symbolic, or logical expression a" |
|
4476 "llowed"); |
|
4477 } |
|
4478 /* close the domain scope */ |
|
4479 if (prt->domain != NULL) close_scope(mpl, prt->domain); |
|
4480 #if 1 /* 14/VII-2006 */ |
|
4481 /* parse optional redirection */ |
|
4482 prt->fname = NULL, prt->app = 0; |
|
4483 if (mpl->token == T_GT || mpl->token == T_APPEND) |
|
4484 { prt->app = (mpl->token == T_APPEND); |
|
4485 get_token(mpl /* > or >> */); |
|
4486 /* parse expression for file name string */ |
|
4487 prt->fname = expression_5(mpl); |
|
4488 /* convert it to symbolic type, if necessary */ |
|
4489 if (prt->fname->type == A_NUMERIC) |
|
4490 prt->fname = make_unary(mpl, O_CVTSYM, prt->fname, |
|
4491 A_SYMBOLIC, 0); |
|
4492 /* check that now the expression is of symbolic type */ |
|
4493 if (prt->fname->type != A_SYMBOLIC) |
|
4494 error(mpl, "file name expression has invalid type"); |
|
4495 } |
|
4496 #endif |
|
4497 /* the printf statement has been completely parsed */ |
|
4498 if (mpl->token != T_SEMICOLON) |
|
4499 error(mpl, "syntax error in printf statement"); |
|
4500 get_token(mpl /* ; */); |
|
4501 return prt; |
|
4502 } |
|
4503 |
|
4504 /*---------------------------------------------------------------------- |
|
4505 -- for_statement - parse for statement. |
|
4506 -- |
|
4507 -- This routine parses for statement using the syntax: |
|
4508 -- |
|
4509 -- <for statement> ::= for <domain> <statement> |
|
4510 -- <for statement> ::= for <domain> { <statement list> } |
|
4511 -- <domain> ::= <indexing expression> |
|
4512 -- <statement list> ::= <empty> |
|
4513 -- <statement list> ::= <statement list> <statement> |
|
4514 -- <statement> ::= <check statement> |
|
4515 -- <statement> ::= <display statement> |
|
4516 -- <statement> ::= <printf statement> |
|
4517 -- <statement> ::= <for statement> */ |
|
4518 |
|
4519 FOR *for_statement(MPL *mpl) |
|
4520 { FOR *fur; |
|
4521 STATEMENT *stmt, *last_stmt; |
|
4522 xassert(is_keyword(mpl, "for")); |
|
4523 /* create for descriptor */ |
|
4524 fur = alloc(FOR); |
|
4525 fur->domain = NULL; |
|
4526 fur->list = last_stmt = NULL; |
|
4527 get_token(mpl /* for */); |
|
4528 /* parse indexing expression */ |
|
4529 if (mpl->token != T_LBRACE) |
|
4530 error(mpl, "indexing expression missing where expected"); |
|
4531 fur->domain = indexing_expression(mpl); |
|
4532 /* skip optional colon */ |
|
4533 if (mpl->token == T_COLON) get_token(mpl /* : */); |
|
4534 /* parse for statement body */ |
|
4535 if (mpl->token != T_LBRACE) |
|
4536 { /* parse simple statement */ |
|
4537 fur->list = simple_statement(mpl, 1); |
|
4538 } |
|
4539 else |
|
4540 { /* parse compound statement */ |
|
4541 get_token(mpl /* { */); |
|
4542 while (mpl->token != T_RBRACE) |
|
4543 { /* parse statement */ |
|
4544 stmt = simple_statement(mpl, 1); |
|
4545 /* and append it to the end of the statement list */ |
|
4546 if (last_stmt == NULL) |
|
4547 fur->list = stmt; |
|
4548 else |
|
4549 last_stmt->next = stmt; |
|
4550 last_stmt = stmt; |
|
4551 } |
|
4552 get_token(mpl /* } */); |
|
4553 } |
|
4554 /* close the domain scope */ |
|
4555 xassert(fur->domain != NULL); |
|
4556 close_scope(mpl, fur->domain); |
|
4557 /* the for statement has been completely parsed */ |
|
4558 return fur; |
|
4559 } |
|
4560 |
|
4561 /*---------------------------------------------------------------------- |
|
4562 -- end_statement - parse end statement. |
|
4563 -- |
|
4564 -- This routine parses end statement using the syntax: |
|
4565 -- |
|
4566 -- <end statement> ::= end ; <eof> */ |
|
4567 |
|
4568 void end_statement(MPL *mpl) |
|
4569 { if (!mpl->flag_d && is_keyword(mpl, "end") || |
|
4570 mpl->flag_d && is_literal(mpl, "end")) |
|
4571 { get_token(mpl /* end */); |
|
4572 if (mpl->token == T_SEMICOLON) |
|
4573 get_token(mpl /* ; */); |
|
4574 else |
|
4575 warning(mpl, "no semicolon following end statement; missing" |
|
4576 " semicolon inserted"); |
|
4577 } |
|
4578 else |
|
4579 warning(mpl, "unexpected end of file; missing end statement in" |
|
4580 "serted"); |
|
4581 if (mpl->token != T_EOF) |
|
4582 warning(mpl, "some text detected beyond end statement; text ig" |
|
4583 "nored"); |
|
4584 return; |
|
4585 } |
|
4586 |
|
4587 /*---------------------------------------------------------------------- |
|
4588 -- simple_statement - parse simple statement. |
|
4589 -- |
|
4590 -- This routine parses simple statement using the syntax: |
|
4591 -- |
|
4592 -- <statement> ::= <set statement> |
|
4593 -- <statement> ::= <parameter statement> |
|
4594 -- <statement> ::= <variable statement> |
|
4595 -- <statement> ::= <constraint statement> |
|
4596 -- <statement> ::= <objective statement> |
|
4597 -- <statement> ::= <solve statement> |
|
4598 -- <statement> ::= <check statement> |
|
4599 -- <statement> ::= <display statement> |
|
4600 -- <statement> ::= <printf statement> |
|
4601 -- <statement> ::= <for statement> |
|
4602 -- |
|
4603 -- If the flag spec is set, some statements cannot be used. */ |
|
4604 |
|
4605 STATEMENT *simple_statement(MPL *mpl, int spec) |
|
4606 { STATEMENT *stmt; |
|
4607 stmt = alloc(STATEMENT); |
|
4608 stmt->line = mpl->line; |
|
4609 stmt->next = NULL; |
|
4610 if (is_keyword(mpl, "set")) |
|
4611 { if (spec) |
|
4612 error(mpl, "set statement not allowed here"); |
|
4613 stmt->type = A_SET; |
|
4614 stmt->u.set = set_statement(mpl); |
|
4615 } |
|
4616 else if (is_keyword(mpl, "param")) |
|
4617 { if (spec) |
|
4618 error(mpl, "parameter statement not allowed here"); |
|
4619 stmt->type = A_PARAMETER; |
|
4620 stmt->u.par = parameter_statement(mpl); |
|
4621 } |
|
4622 else if (is_keyword(mpl, "var")) |
|
4623 { if (spec) |
|
4624 error(mpl, "variable statement not allowed here"); |
|
4625 stmt->type = A_VARIABLE; |
|
4626 stmt->u.var = variable_statement(mpl); |
|
4627 } |
|
4628 else if (is_keyword(mpl, "subject") || |
|
4629 is_keyword(mpl, "subj") || |
|
4630 mpl->token == T_SPTP) |
|
4631 { if (spec) |
|
4632 error(mpl, "constraint statement not allowed here"); |
|
4633 stmt->type = A_CONSTRAINT; |
|
4634 stmt->u.con = constraint_statement(mpl); |
|
4635 } |
|
4636 else if (is_keyword(mpl, "minimize") || |
|
4637 is_keyword(mpl, "maximize")) |
|
4638 { if (spec) |
|
4639 error(mpl, "objective statement not allowed here"); |
|
4640 stmt->type = A_CONSTRAINT; |
|
4641 stmt->u.con = objective_statement(mpl); |
|
4642 } |
|
4643 #if 1 /* 11/II-2008 */ |
|
4644 else if (is_keyword(mpl, "table")) |
|
4645 { if (spec) |
|
4646 error(mpl, "table statement not allowed here"); |
|
4647 stmt->type = A_TABLE; |
|
4648 stmt->u.tab = table_statement(mpl); |
|
4649 } |
|
4650 #endif |
|
4651 else if (is_keyword(mpl, "solve")) |
|
4652 { if (spec) |
|
4653 error(mpl, "solve statement not allowed here"); |
|
4654 stmt->type = A_SOLVE; |
|
4655 stmt->u.slv = solve_statement(mpl); |
|
4656 } |
|
4657 else if (is_keyword(mpl, "check")) |
|
4658 { stmt->type = A_CHECK; |
|
4659 stmt->u.chk = check_statement(mpl); |
|
4660 } |
|
4661 else if (is_keyword(mpl, "display")) |
|
4662 { stmt->type = A_DISPLAY; |
|
4663 stmt->u.dpy = display_statement(mpl); |
|
4664 } |
|
4665 else if (is_keyword(mpl, "printf")) |
|
4666 { stmt->type = A_PRINTF; |
|
4667 stmt->u.prt = printf_statement(mpl); |
|
4668 } |
|
4669 else if (is_keyword(mpl, "for")) |
|
4670 { stmt->type = A_FOR; |
|
4671 stmt->u.fur = for_statement(mpl); |
|
4672 } |
|
4673 else if (mpl->token == T_NAME) |
|
4674 { if (spec) |
|
4675 error(mpl, "constraint statement not allowed here"); |
|
4676 stmt->type = A_CONSTRAINT; |
|
4677 stmt->u.con = constraint_statement(mpl); |
|
4678 } |
|
4679 else if (is_reserved(mpl)) |
|
4680 error(mpl, "invalid use of reserved keyword %s", mpl->image); |
|
4681 else |
|
4682 error(mpl, "syntax error in model section"); |
|
4683 return stmt; |
|
4684 } |
|
4685 |
|
4686 /*---------------------------------------------------------------------- |
|
4687 -- model_section - parse model section. |
|
4688 -- |
|
4689 -- This routine parses model section using the syntax: |
|
4690 -- |
|
4691 -- <model section> ::= <empty> |
|
4692 -- <model section> ::= <model section> <statement> |
|
4693 -- |
|
4694 -- Parsing model section is terminated by either the keyword 'data', or |
|
4695 -- the keyword 'end', or the end of file. */ |
|
4696 |
|
4697 void model_section(MPL *mpl) |
|
4698 { STATEMENT *stmt, *last_stmt; |
|
4699 xassert(mpl->model == NULL); |
|
4700 last_stmt = NULL; |
|
4701 while (!(mpl->token == T_EOF || is_keyword(mpl, "data") || |
|
4702 is_keyword(mpl, "end"))) |
|
4703 { /* parse statement */ |
|
4704 stmt = simple_statement(mpl, 0); |
|
4705 /* and append it to the end of the statement list */ |
|
4706 if (last_stmt == NULL) |
|
4707 mpl->model = stmt; |
|
4708 else |
|
4709 last_stmt->next = stmt; |
|
4710 last_stmt = stmt; |
|
4711 } |
|
4712 return; |
|
4713 } |
|
4714 |
|
4715 /* eof */ |