lemon-project-template-glpk

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

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