Context Navigation

glpmpl01.c @ 2:4c8956a7bdf4

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: glpk-cmake/src/glpmpl01.c @ 2:4c8956a7bdf4

Download in other formats: