COIN-OR::LEMON - Graph Library

source: glpk-cmake/src/glpmpl01.c @ 1:c445c931472f

Last change on this file since 1:c445c931472f was 1:c445c931472f, checked in by Alpar Juttner <alpar@…>, 10 years ago

Import glpk-4.45

  • Generated files and doc/notes are removed
File size: 171.5 KB
Line 
1/* glpmpl01.c */
2
3/***********************************************************************
4*  This code is part of GLPK (GNU Linear Programming Kit).
5*
6*  Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
7*  2009, 2010 Andrew Makhorin, Department for Applied Informatics,
8*  Moscow Aviation Institute, Moscow, Russia. All rights reserved.
9*  E-mail: <mao@gnu.org>.
10*
11*  GLPK is free software: you can redistribute it and/or modify it
12*  under the terms of the GNU General Public License as published by
13*  the Free Software Foundation, either version 3 of the License, or
14*  (at your option) any later version.
15*
16*  GLPK is distributed in the hope that it will be useful, but WITHOUT
17*  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18*  or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
19*  License for more details.
20*
21*  You should have received a copy of the GNU General Public License
22*  along with GLPK. If not, see <http://www.gnu.org/licenses/>.
23***********************************************************************/
24
25#define _GLPSTD_STDIO
26#include "glpmpl.h"
27#define dmp_get_atomv dmp_get_atom
28
29/**********************************************************************/
30/* * *                  PROCESSING MODEL SECTION                  * * */
31/**********************************************************************/
32
33/*----------------------------------------------------------------------
34-- enter_context - enter current token into context queue.
35--
36-- This routine enters the current token into the context queue. */
37
38void 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
61void 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
80void 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;
100done: 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
109void 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
141void 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      }
156loop: /* 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')
211sptp:       {  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            }
243frac:       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         }
261conv:    /* convert numeric literal to floating-point */
262         if (str2num(mpl->image, &mpl->value))
263err:     {  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;
428done: 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
437void 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
459int 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
470int 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
497CODE *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
745CODE *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
759CODE *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
776CODE *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
797CODE *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
814CODE *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
830ARG_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
842ARG_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
864int 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
882ARG_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
933CODE *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
1096CODE *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 */
1110CODE *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 */
1125CODE *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
1172CODE *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
1412DOMAIN *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
1426DOMAIN_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
1442void 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
1472DOMAIN_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
1520CODE *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
1575expr:    {  /* 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
1651CODE *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
1712DOMAIN *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         }
1782expr:    /* 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
1879void 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 */
1917static 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
1939CODE *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))
1984err:           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
2038int 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
2058CODE *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
2100CODE *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);
2164skip: /* 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
2194CODE *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
2265void 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
2276void 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
2287void 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
2300CODE *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
2316CODE *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
2350CODE *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
2386CODE *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
2466CODE *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
2531CODE *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
2564CODE *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
2601CODE *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
2629CODE *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
2660CODE *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
2713CODE *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      }
2822done: 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
2834CODE *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
2864CODE *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
2903CODE *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
2952SET *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))
3060err:           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)
3113err1:          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)
3120err2:          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)
3140err3:             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
3197PARAMETER *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"))
3261bin:     {  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))
3383err:           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
3453VARIABLE *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"))
3513bin:     {  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
3632CONSTRAINT *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)
3823err:     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
3843CONSTRAINT *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
3952TABLE *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      }
4044input_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;
4168output_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);
4221end_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
4239void *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
4263CHECK *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
4318DISPLAY *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
4391expr:    {  /* 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
4429PRINTF *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
4519FOR *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
4568void 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
4605STATEMENT *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
4697void 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 */
Note: See TracBrowser for help on using the repository browser.