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