lemon-project-template-glpk

comparison deps/glpk/src/glpmpl01.c @ 11:4fc6ad2fb8a6

find changesets by author, revision, files, or words in the commit message
Test GLPK in src/main.cc
author Alpar Juttner <alpar@cs.elte.hu>
date Sun, 06 Nov 2011 21:43:29 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:3976d2c29275
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, 2011 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 */