lemon-project-template-glpk: 33de93886c88 deps/glpk/src/glpmpl01.c

lemon-project-template-glpk

view deps/glpk/src/glpmpl01.c @ 9:33de93886c88

Import GLPK 4.47

author	Alpar Juttner <alpar@cs.elte.hu>
date	Sun, 06 Nov 2011 20:59:10 +0100
parents
children

line source

1 /* glpmpl01.c */

3 /***********************************************************************

4 * This code is part of GLPK (GNU Linear Programming Kit).

5 *

7 * 2009, 2010, 2011 Andrew Makhorin, Department for Applied Informatics,

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 ***********************************************************************/

25 #define _GLPSTD_STDIO

26 #include "glpmpl.h"

27 #define dmp_get_atomv dmp_get_atom

29 /**********************************************************************/

30 /* * * PROCESSING MODEL SECTION * * */

31 /**********************************************************************/

33 /*----------------------------------------------------------------------

34 -- enter_context - enter current token into context queue.

35 --

36 -- This routine enters the current token into the context queue. */

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 }

56 /*----------------------------------------------------------------------

57 -- print_context - print current content of context queue.

58 --

59 -- This routine prints current content of the context queue. */

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 }

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. */

80 void get_char(MPL *mpl)

81 { int c;

82 if (mpl->c == EOF) goto done;

83 if (mpl->c == '\n') mpl->line++;

84 c = read_char(mpl);

85 if (c == EOF)

86 { if (mpl->c == '\n')

87 mpl->line--;

88 else

89 warning(mpl, "final NL missing before end of file");

90 }

91 else if (c == '\n')

92 ;

93 else if (isspace(c))

94 c = ' ';

95 else if (iscntrl(c))

96 { enter_context(mpl);

97 error(mpl, "control character 0x%02X not allowed", c);

98 }

99 mpl->c = c;

100 done: return;

101 }

102

103 /*----------------------------------------------------------------------

104 -- append_char - append character to current token.

105 --

106 -- This routine appends the current character to the current token and

107 -- then scans a next character. */

108

109 void append_char(MPL *mpl)

110 { xassert(0 <= mpl->imlen && mpl->imlen <= MAX_LENGTH);

111 if (mpl->imlen == MAX_LENGTH)

112 { switch (mpl->token)

113 { case T_NAME:

114 enter_context(mpl);

115 error(mpl, "symbolic name %s... too long", mpl->image);

116 case T_SYMBOL:

117 enter_context(mpl);

118 error(mpl, "symbol %s... too long", mpl->image);

119 case T_NUMBER:

120 enter_context(mpl);

121 error(mpl, "numeric literal %s... too long", mpl->image);

122 case T_STRING:

123 enter_context(mpl);

124 error(mpl, "string literal too long");

125 default:

126 xassert(mpl != mpl);

127 }

128 }

129 mpl->image[mpl->imlen++] = (char)mpl->c;

130 mpl->image[mpl->imlen] = '\0';

131 get_char(mpl);

132 return;

133 }

134

135 /*----------------------------------------------------------------------

136 -- get_token - scan next token from input text file.

137 --

138 -- This routine scans a next token from the input text file using the

139 -- standard finite automation technique. */

140

141 void get_token(MPL *mpl)

142 { /* save the current token */

143 mpl->b_token = mpl->token;

144 mpl->b_imlen = mpl->imlen;

145 strcpy(mpl->b_image, mpl->image);

146 mpl->b_value = mpl->value;

147 /* if the next token is already scanned, make it current */

148 if (mpl->f_scan)

149 { mpl->f_scan = 0;

150 mpl->token = mpl->f_token;

151 mpl->imlen = mpl->f_imlen;

152 strcpy(mpl->image, mpl->f_image);

153 mpl->value = mpl->f_value;

154 goto done;

155 }

156 loop: /* nothing has been scanned so far */

157 mpl->token = 0;

158 mpl->imlen = 0;

159 mpl->image[0] = '\0';

160 mpl->value = 0.0;

161 /* skip any uninteresting characters */

162 while (mpl->c == ' ' || mpl->c == '\n') get_char(mpl);

163 /* recognize and construct the token */

164 if (mpl->c == EOF)

165 { /* end-of-file reached */

166 mpl->token = T_EOF;

167 }

168 else if (mpl->c == '#')

169 { /* comment; skip anything until end-of-line */

170 while (mpl->c != '\n' && mpl->c != EOF) get_char(mpl);

171 goto loop;

172 }

173 else if (!mpl->flag_d && (isalpha(mpl->c) || mpl->c == '_'))

174 { /* symbolic name or reserved keyword */

175 mpl->token = T_NAME;

176 while (isalnum(mpl->c) || mpl->c == '_') append_char(mpl);

177 if (strcmp(mpl->image, "and") == 0)

178 mpl->token = T_AND;

179 else if (strcmp(mpl->image, "by") == 0)

180 mpl->token = T_BY;

181 else if (strcmp(mpl->image, "cross") == 0)

182 mpl->token = T_CROSS;

183 else if (strcmp(mpl->image, "diff") == 0)

184 mpl->token = T_DIFF;

185 else if (strcmp(mpl->image, "div") == 0)

186 mpl->token = T_DIV;

187 else if (strcmp(mpl->image, "else") == 0)

188 mpl->token = T_ELSE;

189 else if (strcmp(mpl->image, "if") == 0)

190 mpl->token = T_IF;

191 else if (strcmp(mpl->image, "in") == 0)

192 mpl->token = T_IN;

193 #if 1 /* 21/VII-2006 */

194 else if (strcmp(mpl->image, "Infinity") == 0)

195 mpl->token = T_INFINITY;

196 #endif

197 else if (strcmp(mpl->image, "inter") == 0)

198 mpl->token = T_INTER;

199 else if (strcmp(mpl->image, "less") == 0)

200 mpl->token = T_LESS;

201 else if (strcmp(mpl->image, "mod") == 0)

202 mpl->token = T_MOD;

203 else if (strcmp(mpl->image, "not") == 0)

204 mpl->token = T_NOT;

205 else if (strcmp(mpl->image, "or") == 0)

206 mpl->token = T_OR;

207 else if (strcmp(mpl->image, "s") == 0 && mpl->c == '.')

208 { mpl->token = T_SPTP;

209 append_char(mpl);

210 if (mpl->c != 't')

211 sptp: { enter_context(mpl);

212 error(mpl, "keyword s.t. incomplete");

213 }

214 append_char(mpl);

215 if (mpl->c != '.') goto sptp;

216 append_char(mpl);

217 }

218 else if (strcmp(mpl->image, "symdiff") == 0)

219 mpl->token = T_SYMDIFF;

220 else if (strcmp(mpl->image, "then") == 0)

221 mpl->token = T_THEN;

222 else if (strcmp(mpl->image, "union") == 0)

223 mpl->token = T_UNION;

224 else if (strcmp(mpl->image, "within") == 0)

225 mpl->token = T_WITHIN;

226 }

227 else if (!mpl->flag_d && isdigit(mpl->c))

228 { /* numeric literal */

229 mpl->token = T_NUMBER;

230 /* scan integer part */

231 while (isdigit(mpl->c)) append_char(mpl);

232 /* scan optional fractional part */

233 if (mpl->c == '.')

234 { append_char(mpl);

235 if (mpl->c == '.')

236 { /* hmm, it is not the fractional part, it is dots that

237 follow the integer part */

238 mpl->imlen--;

239 mpl->image[mpl->imlen] = '\0';

240 mpl->f_dots = 1;

241 goto conv;

242 }

243 frac: while (isdigit(mpl->c)) append_char(mpl);

244 }

245 /* scan optional decimal exponent */

246 if (mpl->c == 'e' || mpl->c == 'E')

247 { append_char(mpl);

248 if (mpl->c == '+' || mpl->c == '-') append_char(mpl);

249 if (!isdigit(mpl->c))

250 { enter_context(mpl);

251 error(mpl, "numeric literal %s incomplete", mpl->image);

252 }

253 while (isdigit(mpl->c)) append_char(mpl);

254 }

255 /* there must be no letter following the numeric literal */

256 if (isalpha(mpl->c) || mpl->c == '_')

257 { enter_context(mpl);

258 error(mpl, "symbol %s%c... should be enclosed in quotes",

259 mpl->image, mpl->c);

260 }

261 conv: /* convert numeric literal to floating-point */

262 if (str2num(mpl->image, &mpl->value))

263 err: { enter_context(mpl);

264 error(mpl, "cannot convert numeric literal %s to floating-p"

265 "oint number", mpl->image);

266 }

267 }

268 else if (mpl->c == '\'' || mpl->c == '"')

269 { /* character string */

270 int quote = mpl->c;

271 mpl->token = T_STRING;

272 get_char(mpl);

273 for (;;)

274 { if (mpl->c == '\n' || mpl->c == EOF)

275 { enter_context(mpl);

276 error(mpl, "unexpected end of line; string literal incom"

277 "plete");

278 }

279 if (mpl->c == quote)

280 { get_char(mpl);

281 if (mpl->c != quote) break;

282 }

283 append_char(mpl);

284 }

285 }

286 else if (!mpl->flag_d && mpl->c == '+')

287 mpl->token = T_PLUS, append_char(mpl);

288 else if (!mpl->flag_d && mpl->c == '-')

289 mpl->token = T_MINUS, append_char(mpl);

290 else if (mpl->c == '*')

291 { mpl->token = T_ASTERISK, append_char(mpl);

292 if (mpl->c == '*')

293 mpl->token = T_POWER, append_char(mpl);

294 }

295 else if (mpl->c == '/')

296 { mpl->token = T_SLASH, append_char(mpl);

297 if (mpl->c == '*')

298 { /* comment sequence */

299 get_char(mpl);

300 for (;;)

301 { if (mpl->c == EOF)

302 { /* do not call enter_context at this point */

303 error(mpl, "unexpected end of file; comment sequence "

304 "incomplete");

305 }

306 else if (mpl->c == '*')

307 { get_char(mpl);

308 if (mpl->c == '/') break;

309 }

310 else

311 get_char(mpl);

312 }

313 get_char(mpl);

314 goto loop;

315 }

316 }

317 else if (mpl->c == '^')

318 mpl->token = T_POWER, append_char(mpl);

319 else if (mpl->c == '<')

320 { mpl->token = T_LT, append_char(mpl);

321 if (mpl->c == '=')

322 mpl->token = T_LE, append_char(mpl);

323 else if (mpl->c == '>')

324 mpl->token = T_NE, append_char(mpl);

325 #if 1 /* 11/II-2008 */

326 else if (mpl->c == '-')

327 mpl->token = T_INPUT, append_char(mpl);

328 #endif

329 }

330 else if (mpl->c == '=')

331 { mpl->token = T_EQ, append_char(mpl);

332 if (mpl->c == '=') append_char(mpl);

333 }

334 else if (mpl->c == '>')

335 { mpl->token = T_GT, append_char(mpl);

336 if (mpl->c == '=')

337 mpl->token = T_GE, append_char(mpl);

338 #if 1 /* 14/VII-2006 */

339 else if (mpl->c == '>')

340 mpl->token = T_APPEND, append_char(mpl);

341 #endif

342 }

343 else if (mpl->c == '!')

344 { mpl->token = T_NOT, append_char(mpl);

345 if (mpl->c == '=')

346 mpl->token = T_NE, append_char(mpl);

347 }

348 else if (mpl->c == '&')

349 { mpl->token = T_CONCAT, append_char(mpl);

350 if (mpl->c == '&')

351 mpl->token = T_AND, append_char(mpl);

352 }

353 else if (mpl->c == '|')

354 { mpl->token = T_BAR, append_char(mpl);

355 if (mpl->c == '|')

356 mpl->token = T_OR, append_char(mpl);

357 }

358 else if (!mpl->flag_d && mpl->c == '.')

359 { mpl->token = T_POINT, append_char(mpl);

360 if (mpl->f_dots)

361 { /* dots; the first dot was read on the previous call to the

362 scanner, so the current character is the second dot */

363 mpl->token = T_DOTS;

364 mpl->imlen = 2;

365 strcpy(mpl->image, "..");

366 mpl->f_dots = 0;

367 }

368 else if (mpl->c == '.')

369 mpl->token = T_DOTS, append_char(mpl);

370 else if (isdigit(mpl->c))

371 { /* numeric literal that begins with the decimal point */

372 mpl->token = T_NUMBER, append_char(mpl);

373 goto frac;

374 }

375 }

376 else if (mpl->c == ',')

377 mpl->token = T_COMMA, append_char(mpl);

378 else if (mpl->c == ':')

379 { mpl->token = T_COLON, append_char(mpl);

380 if (mpl->c == '=')

381 mpl->token = T_ASSIGN, append_char(mpl);

382 }

383 else if (mpl->c == ';')

384 mpl->token = T_SEMICOLON, append_char(mpl);

385 else if (mpl->c == '(')

386 mpl->token = T_LEFT, append_char(mpl);

387 else if (mpl->c == ')')

388 mpl->token = T_RIGHT, append_char(mpl);

389 else if (mpl->c == '[')

390 mpl->token = T_LBRACKET, append_char(mpl);

391 else if (mpl->c == ']')

392 mpl->token = T_RBRACKET, append_char(mpl);

393 else if (mpl->c == '{')

394 mpl->token = T_LBRACE, append_char(mpl);

395 else if (mpl->c == '}')

396 mpl->token = T_RBRACE, append_char(mpl);

397 #if 1 /* 11/II-2008 */

398 else if (mpl->c == '~')

399 mpl->token = T_TILDE, append_char(mpl);

400 #endif

401 else if (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL)

402 { /* symbol */

403 xassert(mpl->flag_d);

404 mpl->token = T_SYMBOL;

405 while (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL)

406 append_char(mpl);

407 switch (str2num(mpl->image, &mpl->value))

408 { case 0:

409 mpl->token = T_NUMBER;

410 break;

411 case 1:

412 goto err;

413 case 2:

414 break;

415 default:

416 xassert(mpl != mpl);

417 }

418 }

419 else

420 { enter_context(mpl);

421 error(mpl, "character %c not allowed", mpl->c);

422 }

423 /* enter the current token into the context queue */

424 enter_context(mpl);

425 /* reset the flag, which may be set by indexing_expression() and

426 is used by expression_list() */

427 mpl->flag_x = 0;

428 done: return;

429 }

430

431 /*----------------------------------------------------------------------

432 -- unget_token - return current token back to input stream.

433 --

434 -- This routine returns the current token back to the input stream, so

435 -- the previously scanned token becomes the current one. */

436

437 void unget_token(MPL *mpl)

438 { /* save the current token, which becomes the next one */

439 xassert(!mpl->f_scan);

440 mpl->f_scan = 1;

441 mpl->f_token = mpl->token;

442 mpl->f_imlen = mpl->imlen;

443 strcpy(mpl->f_image, mpl->image);

444 mpl->f_value = mpl->value;

445 /* restore the previous token, which becomes the current one */

446 mpl->token = mpl->b_token;

447 mpl->imlen = mpl->b_imlen;

448 strcpy(mpl->image, mpl->b_image);

449 mpl->value = mpl->b_value;

450 return;

451 }

452

453 /*----------------------------------------------------------------------

454 -- is_keyword - check if current token is given non-reserved keyword.

455 --

456 -- If the current token is given (non-reserved) keyword, this routine

457 -- returns non-zero. Otherwise zero is returned. */

458

459 int is_keyword(MPL *mpl, char *keyword)

460 { return

461 mpl->token == T_NAME && strcmp(mpl->image, keyword) == 0;

462 }

463

464 /*----------------------------------------------------------------------

465 -- is_reserved - check if current token is reserved keyword.

466 --

467 -- If the current token is a reserved keyword, this routine returns

468 -- non-zero. Otherwise zero is returned. */

469

470 int is_reserved(MPL *mpl)

471 { return

472 mpl->token == T_AND && mpl->image[0] == 'a' ||

473 mpl->token == T_BY ||

474 mpl->token == T_CROSS ||

475 mpl->token == T_DIFF ||

476 mpl->token == T_DIV ||

477 mpl->token == T_ELSE ||

478 mpl->token == T_IF ||

479 mpl->token == T_IN ||

480 mpl->token == T_INTER ||

481 mpl->token == T_LESS ||

482 mpl->token == T_MOD ||

483 mpl->token == T_NOT && mpl->image[0] == 'n' ||

484 mpl->token == T_OR && mpl->image[0] == 'o' ||

485 mpl->token == T_SYMDIFF ||

486 mpl->token == T_THEN ||

487 mpl->token == T_UNION ||

488 mpl->token == T_WITHIN;

489 }

490

491 /*----------------------------------------------------------------------

492 -- make_code - generate pseudo-code (basic routine).

493 --

494 -- This routine generates specified pseudo-code. It is assumed that all

495 -- other translator routines use this basic routine. */

496

497 CODE *make_code(MPL *mpl, int op, OPERANDS *arg, int type, int dim)

498 { CODE *code;

499 DOMAIN *domain;

500 DOMAIN_BLOCK *block;

501 ARG_LIST *e;

502 /* generate pseudo-code */

503 code = alloc(CODE);

504 code->op = op;

505 code->vflag = 0; /* is inherited from operand(s) */

506 /* copy operands and also make them referring to the pseudo-code

507 being generated, because the latter becomes the parent for all

508 its operands */

509 memset(&code->arg, '?', sizeof(OPERANDS));

510 switch (op)

511 { case O_NUMBER:

512 code->arg.num = arg->num;

513 break;

514 case O_STRING:

515 code->arg.str = arg->str;

516 break;

517 case O_INDEX:

518 code->arg.index.slot = arg->index.slot;

519 code->arg.index.next = arg->index.next;

520 break;

521 case O_MEMNUM:

522 case O_MEMSYM:

523 for (e = arg->par.list; e != NULL; e = e->next)

524 { xassert(e->x != NULL);

525 xassert(e->x->up == NULL);

526 e->x->up = code;

527 code->vflag |= e->x->vflag;

528 }

529 code->arg.par.par = arg->par.par;

530 code->arg.par.list = arg->par.list;

531 break;

532 case O_MEMSET:

533 for (e = arg->set.list; e != NULL; e = e->next)

534 { xassert(e->x != NULL);

535 xassert(e->x->up == NULL);

536 e->x->up = code;

537 code->vflag |= e->x->vflag;

538 }

539 code->arg.set.set = arg->set.set;

540 code->arg.set.list = arg->set.list;

541 break;

542 case O_MEMVAR:

543 for (e = arg->var.list; e != NULL; e = e->next)

544 { xassert(e->x != NULL);

545 xassert(e->x->up == NULL);

546 e->x->up = code;

547 code->vflag |= e->x->vflag;

548 }

549 code->arg.var.var = arg->var.var;

550 code->arg.var.list = arg->var.list;

551 #if 1 /* 15/V-2010 */

552 code->arg.var.suff = arg->var.suff;

553 #endif

554 break;

555 #if 1 /* 15/V-2010 */

556 case O_MEMCON:

557 for (e = arg->con.list; e != NULL; e = e->next)

558 { xassert(e->x != NULL);

559 xassert(e->x->up == NULL);

560 e->x->up = code;

561 code->vflag |= e->x->vflag;

562 }

563 code->arg.con.con = arg->con.con;

564 code->arg.con.list = arg->con.list;

565 code->arg.con.suff = arg->con.suff;

566 break;

567 #endif

568 case O_TUPLE:

569 case O_MAKE:

570 for (e = arg->list; e != NULL; e = e->next)

571 { xassert(e->x != NULL);

572 xassert(e->x->up == NULL);

573 e->x->up = code;

574 code->vflag |= e->x->vflag;

575 }

576 code->arg.list = arg->list;

577 break;

578 case O_SLICE:

579 xassert(arg->slice != NULL);

580 code->arg.slice = arg->slice;

581 break;

582 case O_IRAND224:

583 case O_UNIFORM01:

584 case O_NORMAL01:

585 case O_GMTIME:

586 code->vflag = 1;

587 break;

588 case O_CVTNUM:

589 case O_CVTSYM:

590 case O_CVTLOG:

591 case O_CVTTUP:

592 case O_CVTLFM:

593 case O_PLUS:

594 case O_MINUS:

595 case O_NOT:

596 case O_ABS:

597 case O_CEIL:

598 case O_FLOOR:

599 case O_EXP:

600 case O_LOG:

601 case O_LOG10:

602 case O_SQRT:

603 case O_SIN:

604 case O_COS:

605 case O_ATAN:

606 case O_ROUND:

607 case O_TRUNC:

608 case O_CARD:

609 case O_LENGTH:

610 /* unary operation */

611 xassert(arg->arg.x != NULL);

612 xassert(arg->arg.x->up == NULL);

613 arg->arg.x->up = code;

614 code->vflag |= arg->arg.x->vflag;

615 code->arg.arg.x = arg->arg.x;

616 break;

617 case O_ADD:

618 case O_SUB:

619 case O_LESS:

620 case O_MUL:

621 case O_DIV:

622 case O_IDIV:

623 case O_MOD:

624 case O_POWER:

625 case O_ATAN2:

626 case O_ROUND2:

627 case O_TRUNC2:

628 case O_UNIFORM:

629 if (op == O_UNIFORM) code->vflag = 1;

630 case O_NORMAL:

631 if (op == O_NORMAL) code->vflag = 1;

632 case O_CONCAT:

633 case O_LT:

634 case O_LE:

635 case O_EQ:

636 case O_GE:

637 case O_GT:

638 case O_NE:

639 case O_AND:

640 case O_OR:

641 case O_UNION:

642 case O_DIFF:

643 case O_SYMDIFF:

644 case O_INTER:

645 case O_CROSS:

646 case O_IN:

647 case O_NOTIN:

648 case O_WITHIN:

649 case O_NOTWITHIN:

650 case O_SUBSTR:

651 case O_STR2TIME:

652 case O_TIME2STR:

653 /* binary operation */

654 xassert(arg->arg.x != NULL);

655 xassert(arg->arg.x->up == NULL);

656 arg->arg.x->up = code;

657 code->vflag |= arg->arg.x->vflag;

658 xassert(arg->arg.y != NULL);

659 xassert(arg->arg.y->up == NULL);

660 arg->arg.y->up = code;

661 code->vflag |= arg->arg.y->vflag;

662 code->arg.arg.x = arg->arg.x;

663 code->arg.arg.y = arg->arg.y;

664 break;

665 case O_DOTS:

666 case O_FORK:

667 case O_SUBSTR3:

668 /* ternary operation */

669 xassert(arg->arg.x != NULL);

670 xassert(arg->arg.x->up == NULL);

671 arg->arg.x->up = code;

672 code->vflag |= arg->arg.x->vflag;

673 xassert(arg->arg.y != NULL);

674 xassert(arg->arg.y->up == NULL);

675 arg->arg.y->up = code;

676 code->vflag |= arg->arg.y->vflag;

677 if (arg->arg.z != NULL)

678 { xassert(arg->arg.z->up == NULL);

679 arg->arg.z->up = code;

680 code->vflag |= arg->arg.z->vflag;

681 }

682 code->arg.arg.x = arg->arg.x;

683 code->arg.arg.y = arg->arg.y;

684 code->arg.arg.z = arg->arg.z;

685 break;

686 case O_MIN:

687 case O_MAX:

688 /* n-ary operation */

689 for (e = arg->list; e != NULL; e = e->next)

690 { xassert(e->x != NULL);

691 xassert(e->x->up == NULL);

692 e->x->up = code;

693 code->vflag |= e->x->vflag;

694 }

695 code->arg.list = arg->list;

696 break;

697 case O_SUM:

698 case O_PROD:

699 case O_MINIMUM:

700 case O_MAXIMUM:

701 case O_FORALL:

702 case O_EXISTS:

703 case O_SETOF:

704 case O_BUILD:

705 /* iterated operation */

706 domain = arg->loop.domain;

707 xassert(domain != NULL);

708 if (domain->code != NULL)

709 { xassert(domain->code->up == NULL);

710 domain->code->up = code;

711 code->vflag |= domain->code->vflag;

712 }

713 for (block = domain->list; block != NULL; block =

714 block->next)

715 { xassert(block->code != NULL);

716 xassert(block->code->up == NULL);

717 block->code->up = code;

718 code->vflag |= block->code->vflag;

719 }

720 if (arg->loop.x != NULL)

721 { xassert(arg->loop.x->up == NULL);

722 arg->loop.x->up = code;

723 code->vflag |= arg->loop.x->vflag;

724 }

725 code->arg.loop.domain = arg->loop.domain;

726 code->arg.loop.x = arg->loop.x;

727 break;

728 default:

729 xassert(op != op);

730 }

731 /* set other attributes of the pseudo-code */

732 code->type = type;

733 code->dim = dim;

734 code->up = NULL;

735 code->valid = 0;

736 memset(&code->value, '?', sizeof(VALUE));

737 return code;

738 }

739

740 /*----------------------------------------------------------------------

741 -- make_unary - generate pseudo-code for unary operation.

742 --

743 -- This routine generates pseudo-code for unary operation. */

744

745 CODE *make_unary(MPL *mpl, int op, CODE *x, int type, int dim)

746 { CODE *code;

747 OPERANDS arg;

748 xassert(x != NULL);

749 arg.arg.x = x;

750 code = make_code(mpl, op, &arg, type, dim);

751 return code;

752 }

753

754 /*----------------------------------------------------------------------

755 -- make_binary - generate pseudo-code for binary operation.

756 --

757 -- This routine generates pseudo-code for binary operation. */

758

759 CODE *make_binary(MPL *mpl, int op, CODE *x, CODE *y, int type,

760 int dim)

761 { CODE *code;

762 OPERANDS arg;

763 xassert(x != NULL);

764 xassert(y != NULL);

765 arg.arg.x = x;

766 arg.arg.y = y;

767 code = make_code(mpl, op, &arg, type, dim);

768 return code;

769 }

770

771 /*----------------------------------------------------------------------

772 -- make_ternary - generate pseudo-code for ternary operation.

773 --

774 -- This routine generates pseudo-code for ternary operation. */

775

776 CODE *make_ternary(MPL *mpl, int op, CODE *x, CODE *y, CODE *z,

777 int type, int dim)

778 { CODE *code;

779 OPERANDS arg;

780 xassert(x != NULL);

781 xassert(y != NULL);

782 /* third operand can be NULL */

783 arg.arg.x = x;

784 arg.arg.y = y;

785 arg.arg.z = z;

786 code = make_code(mpl, op, &arg, type, dim);

787 return code;

788 }

789

790 /*----------------------------------------------------------------------

791 -- numeric_literal - parse reference to numeric literal.

792 --

793 -- This routine parses primary expression using the syntax:

794 --

795 -- <primary expression> ::= <numeric literal> */

796

797 CODE *numeric_literal(MPL *mpl)

798 { CODE *code;

799 OPERANDS arg;

800 xassert(mpl->token == T_NUMBER);

801 arg.num = mpl->value;

802 code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0);

803 get_token(mpl /* <numeric literal> */);

804 return code;

805 }

806

807 /*----------------------------------------------------------------------

808 -- string_literal - parse reference to string literal.

809 --

810 -- This routine parses primary expression using the syntax:

811 --

812 -- <primary expression> ::= <string literal> */

813

814 CODE *string_literal(MPL *mpl)

815 { CODE *code;

816 OPERANDS arg;

817 xassert(mpl->token == T_STRING);

818 arg.str = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

819 strcpy(arg.str, mpl->image);

820 code = make_code(mpl, O_STRING, &arg, A_SYMBOLIC, 0);

821 get_token(mpl /* <string literal> */);

822 return code;

823 }

824

825 /*----------------------------------------------------------------------

826 -- create_arg_list - create empty operands list.

827 --

828 -- This routine creates operands list, which is initially empty. */

829

830 ARG_LIST *create_arg_list(MPL *mpl)

831 { ARG_LIST *list;

832 xassert(mpl == mpl);

833 list = NULL;

834 return list;

835 }

836

837 /*----------------------------------------------------------------------

838 -- expand_arg_list - append operand to operands list.

839 --

840 -- This routine appends new operand to specified operands list. */

841

842 ARG_LIST *expand_arg_list(MPL *mpl, ARG_LIST *list, CODE *x)

843 { ARG_LIST *tail, *temp;

844 xassert(x != NULL);

845 /* create new operands list entry */

846 tail = alloc(ARG_LIST);

847 tail->x = x;

848 tail->next = NULL;

849 /* and append it to the operands list */

850 if (list == NULL)

851 list = tail;

852 else

853 { for (temp = list; temp->next != NULL; temp = temp->next);

854 temp->next = tail;

855 }

856 return list;

857 }

858

859 /*----------------------------------------------------------------------

860 -- arg_list_len - determine length of operands list.

861 --

862 -- This routine returns the number of operands in operands list. */

863

864 int arg_list_len(MPL *mpl, ARG_LIST *list)

865 { ARG_LIST *temp;

866 int len;

867 xassert(mpl == mpl);

868 len = 0;

869 for (temp = list; temp != NULL; temp = temp->next) len++;

870 return len;

871 }

872

873 /*----------------------------------------------------------------------

874 -- subscript_list - parse subscript list.

875 --

876 -- This routine parses subscript list using the syntax:

877 --

878 -- <subscript list> ::= <subscript>

879 -- <subscript list> ::= <subscript list> , <subscript>

880 -- <subscript> ::= <expression 5> */

881

882 ARG_LIST *subscript_list(MPL *mpl)

883 { ARG_LIST *list;

884 CODE *x;

885 list = create_arg_list(mpl);

886 for (;;)

887 { /* parse subscript expression */

888 x = expression_5(mpl);

889 /* convert it to symbolic type, if necessary */

890 if (x->type == A_NUMERIC)

891 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

892 /* check that now the expression is of symbolic type */

893 if (x->type != A_SYMBOLIC)

894 error(mpl, "subscript expression has invalid type");

895 xassert(x->dim == 0);

896 /* and append it to the subscript list */

897 list = expand_arg_list(mpl, list, x);

898 /* check a token that follows the subscript expression */

899 if (mpl->token == T_COMMA)

900 get_token(mpl /* , */);

901 else if (mpl->token == T_RBRACKET)

902 break;

903 else

904 error(mpl, "syntax error in subscript list");

905 }

906 return list;

907 }

908

909 #if 1 /* 15/V-2010 */

910 /*----------------------------------------------------------------------

911 -- object_reference - parse reference to named object.

912 --

913 -- This routine parses primary expression using the syntax:

914 --

915 -- <primary expression> ::= <dummy index>

916 -- <primary expression> ::= <set name>

917 -- <primary expression> ::= <set name> [ <subscript list> ]

918 -- <primary expression> ::= <parameter name>

919 -- <primary expression> ::= <parameter name> [ <subscript list> ]

920 -- <primary expression> ::= <variable name> <suffix>

921 -- <primary expression> ::= <variable name> [ <subscript list> ]

922 -- <suffix>

923 -- <primary expression> ::= <constraint name> <suffix>

924 -- <primary expression> ::= <constraint name> [ <subscript list> ]

925 -- <suffix>

926 -- <dummy index> ::= <symbolic name>

927 -- <set name> ::= <symbolic name>

928 -- <parameter name> ::= <symbolic name>

929 -- <variable name> ::= <symbolic name>

930 -- <constraint name> ::= <symbolic name>

931 -- <suffix> ::= <empty> | .lb | .ub | .status | .val | .dual */

932

933 CODE *object_reference(MPL *mpl)

934 { AVLNODE *node;

935 DOMAIN_SLOT *slot;

936 SET *set;

937 PARAMETER *par;

938 VARIABLE *var;

939 CONSTRAINT *con;

940 ARG_LIST *list;

941 OPERANDS arg;

942 CODE *code;

943 char *name;

944 int dim, suff;

945 /* find the object in the symbolic name table */

946 xassert(mpl->token == T_NAME);

947 node = avl_find_node(mpl->tree, mpl->image);

948 if (node == NULL)

949 error(mpl, "%s not defined", mpl->image);

950 /* check the object type and obtain its dimension */

951 switch (avl_get_node_type(node))

952 { case A_INDEX:

953 /* dummy index */

954 slot = (DOMAIN_SLOT *)avl_get_node_link(node);

955 name = slot->name;

956 dim = 0;

957 break;

958 case A_SET:

959 /* model set */

960 set = (SET *)avl_get_node_link(node);

961 name = set->name;

962 dim = set->dim;

963 /* if a set object is referenced in its own declaration and

964 the dimen attribute is not specified yet, use dimen 1 by

965 default */

966 if (set->dimen == 0) set->dimen = 1;

967 break;

968 case A_PARAMETER:

969 /* model parameter */

970 par = (PARAMETER *)avl_get_node_link(node);

971 name = par->name;

972 dim = par->dim;

973 break;

974 case A_VARIABLE:

975 /* model variable */

976 var = (VARIABLE *)avl_get_node_link(node);

977 name = var->name;

978 dim = var->dim;

979 break;

980 case A_CONSTRAINT:

981 /* model constraint or objective */

982 con = (CONSTRAINT *)avl_get_node_link(node);

983 name = con->name;

984 dim = con->dim;

985 break;

986 default:

987 xassert(node != node);

988 }

989 get_token(mpl /* <symbolic name> */);

990 /* parse optional subscript list */

991 if (mpl->token == T_LBRACKET)

992 { /* subscript list is specified */

993 if (dim == 0)

994 error(mpl, "%s cannot be subscripted", name);

995 get_token(mpl /* [ */);

996 list = subscript_list(mpl);

997 if (dim != arg_list_len(mpl, list))

998 error(mpl, "%s must have %d subscript%s rather than %d",

999 name, dim, dim == 1 ? "" : "s", arg_list_len(mpl, list));

1000 xassert(mpl->token == T_RBRACKET);

1001 get_token(mpl /* ] */);

1002 }

1003 else

1004 { /* subscript list is not specified */

1005 if (dim != 0)

1006 error(mpl, "%s must be subscripted", name);

1007 list = create_arg_list(mpl);

1008 }

1009 /* parse optional suffix */

1010 if (!mpl->flag_s && avl_get_node_type(node) == A_VARIABLE)

1011 suff = DOT_NONE;

1012 else

1013 suff = DOT_VAL;

1014 if (mpl->token == T_POINT)

1015 { get_token(mpl /* . */);

1016 if (mpl->token != T_NAME)

1017 error(mpl, "invalid use of period");

1018 if (!(avl_get_node_type(node) == A_VARIABLE ||

1019 avl_get_node_type(node) == A_CONSTRAINT))

1020 error(mpl, "%s cannot have a suffix", name);

1021 if (strcmp(mpl->image, "lb") == 0)

1022 suff = DOT_LB;

1023 else if (strcmp(mpl->image, "ub") == 0)

1024 suff = DOT_UB;

1025 else if (strcmp(mpl->image, "status") == 0)

1026 suff = DOT_STATUS;

1027 else if (strcmp(mpl->image, "val") == 0)

1028 suff = DOT_VAL;

1029 else if (strcmp(mpl->image, "dual") == 0)

1030 suff = DOT_DUAL;

1031 else

1032 error(mpl, "suffix .%s invalid", mpl->image);

1033 get_token(mpl /* suffix */);

1034 }

1035 /* generate pseudo-code to take value of the object */

1036 switch (avl_get_node_type(node))

1037 { case A_INDEX:

1038 arg.index.slot = slot;

1039 arg.index.next = slot->list;

1040 code = make_code(mpl, O_INDEX, &arg, A_SYMBOLIC, 0);

1041 slot->list = code;

1042 break;

1043 case A_SET:

1044 arg.set.set = set;

1045 arg.set.list = list;

1046 code = make_code(mpl, O_MEMSET, &arg, A_ELEMSET,

1047 set->dimen);

1048 break;

1049 case A_PARAMETER:

1050 arg.par.par = par;

1051 arg.par.list = list;

1052 if (par->type == A_SYMBOLIC)

1053 code = make_code(mpl, O_MEMSYM, &arg, A_SYMBOLIC, 0);

1054 else

1055 code = make_code(mpl, O_MEMNUM, &arg, A_NUMERIC, 0);

1056 break;

1057 case A_VARIABLE:

1058 if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL

1059 || suff == DOT_DUAL))

1060 error(mpl, "invalid reference to status, primal value, o"

1061 "r dual value of variable %s above solve statement",

1062 var->name);

1063 arg.var.var = var;

1064 arg.var.list = list;

1065 arg.var.suff = suff;

1066 code = make_code(mpl, O_MEMVAR, &arg, suff == DOT_NONE ?

1067 A_FORMULA : A_NUMERIC, 0);

1068 break;

1069 case A_CONSTRAINT:

1070 if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL

1071 || suff == DOT_DUAL))

1072 error(mpl, "invalid reference to status, primal value, o"

1073 "r dual value of %s %s above solve statement",

1074 con->type == A_CONSTRAINT ? "constraint" : "objective"

1075 , con->name);

1076 arg.con.con = con;

1077 arg.con.list = list;

1078 arg.con.suff = suff;

1079 code = make_code(mpl, O_MEMCON, &arg, A_NUMERIC, 0);

1080 break;

1081 default:

1082 xassert(node != node);

1083 }

1084 return code;

1085 }

1086 #endif

1087

1088 /*----------------------------------------------------------------------

1089 -- numeric_argument - parse argument passed to built-in function.

1090 --

1091 -- This routine parses an argument passed to numeric built-in function

1092 -- using the syntax:

1093 --

1094 -- <arg> ::= <expression 5> */

1095

1096 CODE *numeric_argument(MPL *mpl, char *func)

1097 { CODE *x;

1098 x = expression_5(mpl);

1099 /* convert the argument to numeric type, if necessary */

1100 if (x->type == A_SYMBOLIC)

1101 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

1102 /* check that now the argument is of numeric type */

1103 if (x->type != A_NUMERIC)

1104 error(mpl, "argument for %s has invalid type", func);

1105 xassert(x->dim == 0);

1106 return x;

1107 }

1108

1109 #if 1 /* 15/VII-2006 */

1110 CODE *symbolic_argument(MPL *mpl, char *func)

1111 { CODE *x;

1112 x = expression_5(mpl);

1113 /* convert the argument to symbolic type, if necessary */

1114 if (x->type == A_NUMERIC)

1115 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

1116 /* check that now the argument is of symbolic type */

1117 if (x->type != A_SYMBOLIC)

1118 error(mpl, "argument for %s has invalid type", func);

1119 xassert(x->dim == 0);

1120 return x;

1121 }

1122 #endif

1123

1124 #if 1 /* 15/VII-2006 */

1125 CODE *elemset_argument(MPL *mpl, char *func)

1126 { CODE *x;

1127 x = expression_9(mpl);

1128 if (x->type != A_ELEMSET)

1129 error(mpl, "argument for %s has invalid type", func);

1130 xassert(x->dim > 0);

1131 return x;

1132 }

1133 #endif

1134

1135 /*----------------------------------------------------------------------

1136 -- function_reference - parse reference to built-in function.

1137 --

1138 -- This routine parses primary expression using the syntax:

1139 --

1140 -- <primary expression> ::= abs ( <arg> )

1141 -- <primary expression> ::= ceil ( <arg> )

1142 -- <primary expression> ::= floor ( <arg> )

1143 -- <primary expression> ::= exp ( <arg> )

1144 -- <primary expression> ::= log ( <arg> )

1145 -- <primary expression> ::= log10 ( <arg> )

1146 -- <primary expression> ::= max ( <arg list> )

1147 -- <primary expression> ::= min ( <arg list> )

1148 -- <primary expression> ::= sqrt ( <arg> )

1149 -- <primary expression> ::= sin ( <arg> )

1150 -- <primary expression> ::= cos ( <arg> )

1151 -- <primary expression> ::= atan ( <arg> )

1152 -- <primary expression> ::= atan2 ( <arg> , <arg> )

1153 -- <primary expression> ::= round ( <arg> )

1154 -- <primary expression> ::= round ( <arg> , <arg> )

1155 -- <primary expression> ::= trunc ( <arg> )

1156 -- <primary expression> ::= trunc ( <arg> , <arg> )

1157 -- <primary expression> ::= Irand224 ( )

1158 -- <primary expression> ::= Uniform01 ( )

1159 -- <primary expression> ::= Uniform ( <arg> , <arg> )

1160 -- <primary expression> ::= Normal01 ( )

1161 -- <primary expression> ::= Normal ( <arg> , <arg> )

1162 -- <primary expression> ::= card ( <arg> )

1163 -- <primary expression> ::= length ( <arg> )

1164 -- <primary expression> ::= substr ( <arg> , <arg> )

1165 -- <primary expression> ::= substr ( <arg> , <arg> , <arg> )

1166 -- <primary expression> ::= str2time ( <arg> , <arg> )

1167 -- <primary expression> ::= time2str ( <arg> , <arg> )

1168 -- <primary expression> ::= gmtime ( )

1169 -- <arg list> ::= <arg>

1170 -- <arg list> ::= <arg list> , <arg> */

1171

1172 CODE *function_reference(MPL *mpl)

1173 { CODE *code;

1174 OPERANDS arg;

1175 int op;

1176 char func[15+1];

1177 /* determine operation code */

1178 xassert(mpl->token == T_NAME);

1179 if (strcmp(mpl->image, "abs") == 0)

1180 op = O_ABS;

1181 else if (strcmp(mpl->image, "ceil") == 0)

1182 op = O_CEIL;

1183 else if (strcmp(mpl->image, "floor") == 0)

1184 op = O_FLOOR;

1185 else if (strcmp(mpl->image, "exp") == 0)

1186 op = O_EXP;

1187 else if (strcmp(mpl->image, "log") == 0)

1188 op = O_LOG;

1189 else if (strcmp(mpl->image, "log10") == 0)

1190 op = O_LOG10;

1191 else if (strcmp(mpl->image, "sqrt") == 0)

1192 op = O_SQRT;

1193 else if (strcmp(mpl->image, "sin") == 0)

1194 op = O_SIN;

1195 else if (strcmp(mpl->image, "cos") == 0)

1196 op = O_COS;

1197 else if (strcmp(mpl->image, "atan") == 0)

1198 op = O_ATAN;

1199 else if (strcmp(mpl->image, "min") == 0)

1200 op = O_MIN;

1201 else if (strcmp(mpl->image, "max") == 0)

1202 op = O_MAX;

1203 else if (strcmp(mpl->image, "round") == 0)

1204 op = O_ROUND;

1205 else if (strcmp(mpl->image, "trunc") == 0)

1206 op = O_TRUNC;

1207 else if (strcmp(mpl->image, "Irand224") == 0)

1208 op = O_IRAND224;

1209 else if (strcmp(mpl->image, "Uniform01") == 0)

1210 op = O_UNIFORM01;

1211 else if (strcmp(mpl->image, "Uniform") == 0)

1212 op = O_UNIFORM;

1213 else if (strcmp(mpl->image, "Normal01") == 0)

1214 op = O_NORMAL01;

1215 else if (strcmp(mpl->image, "Normal") == 0)

1216 op = O_NORMAL;

1217 else if (strcmp(mpl->image, "card") == 0)

1218 op = O_CARD;

1219 else if (strcmp(mpl->image, "length") == 0)

1220 op = O_LENGTH;

1221 else if (strcmp(mpl->image, "substr") == 0)

1222 op = O_SUBSTR;

1223 else if (strcmp(mpl->image, "str2time") == 0)

1224 op = O_STR2TIME;

1225 else if (strcmp(mpl->image, "time2str") == 0)

1226 op = O_TIME2STR;

1227 else if (strcmp(mpl->image, "gmtime") == 0)

1228 op = O_GMTIME;

1229 else

1230 error(mpl, "function %s unknown", mpl->image);

1231 /* save symbolic name of the function */

1232 strcpy(func, mpl->image);

1233 xassert(strlen(func) < sizeof(func));

1234 get_token(mpl /* <symbolic name> */);

1235 /* check the left parenthesis that follows the function name */

1236 xassert(mpl->token == T_LEFT);

1237 get_token(mpl /* ( */);

1238 /* parse argument list */

1239 if (op == O_MIN || op == O_MAX)

1240 { /* min and max allow arbitrary number of arguments */

1241 arg.list = create_arg_list(mpl);

1242 /* parse argument list */

1243 for (;;)

1244 { /* parse argument and append it to the operands list */

1245 arg.list = expand_arg_list(mpl, arg.list,

1246 numeric_argument(mpl, func));

1247 /* check a token that follows the argument */

1248 if (mpl->token == T_COMMA)

1249 get_token(mpl /* , */);

1250 else if (mpl->token == T_RIGHT)

1251 break;

1252 else

1253 error(mpl, "syntax error in argument list for %s", func);

1254 }

1255 }

1256 else if (op == O_IRAND224 || op == O_UNIFORM01 || op ==

1257 O_NORMAL01 || op == O_GMTIME)

1258 { /* Irand224, Uniform01, Normal01, gmtime need no arguments */

1259 if (mpl->token != T_RIGHT)

1260 error(mpl, "%s needs no arguments", func);

1261 }

1262 else if (op == O_UNIFORM || op == O_NORMAL)

1263 { /* Uniform and Normal need two arguments */

1264 /* parse the first argument */

1265 arg.arg.x = numeric_argument(mpl, func);

1266 /* check a token that follows the first argument */

1267 if (mpl->token == T_COMMA)

1268 ;

1269 else if (mpl->token == T_RIGHT)

1270 error(mpl, "%s needs two arguments", func);

1271 else

1272 error(mpl, "syntax error in argument for %s", func);

1273 get_token(mpl /* , */);

1274 /* parse the second argument */

1275 arg.arg.y = numeric_argument(mpl, func);

1276 /* check a token that follows the second argument */

1277 if (mpl->token == T_COMMA)

1278 error(mpl, "%s needs two argument", func);

1279 else if (mpl->token == T_RIGHT)

1280 ;

1281 else

1282 error(mpl, "syntax error in argument for %s", func);

1283 }

1284 else if (op == O_ATAN || op == O_ROUND || op == O_TRUNC)

1285 { /* atan, round, and trunc need one or two arguments */

1286 /* parse the first argument */

1287 arg.arg.x = numeric_argument(mpl, func);

1288 /* parse the second argument, if specified */

1289 if (mpl->token == T_COMMA)

1290 { switch (op)

1291 { case O_ATAN: op = O_ATAN2; break;

1292 case O_ROUND: op = O_ROUND2; break;

1293 case O_TRUNC: op = O_TRUNC2; break;

1294 default: xassert(op != op);

1295 }

1296 get_token(mpl /* , */);

1297 arg.arg.y = numeric_argument(mpl, func);

1298 }

1299 /* check a token that follows the last argument */

1300 if (mpl->token == T_COMMA)

1301 error(mpl, "%s needs one or two arguments", func);

1302 else if (mpl->token == T_RIGHT)

1303 ;

1304 else

1305 error(mpl, "syntax error in argument for %s", func);

1306 }

1307 else if (op == O_SUBSTR)

1308 { /* substr needs two or three arguments */

1309 /* parse the first argument */

1310 arg.arg.x = symbolic_argument(mpl, func);

1311 /* check a token that follows the first argument */

1312 if (mpl->token == T_COMMA)

1313 ;

1314 else if (mpl->token == T_RIGHT)

1315 error(mpl, "%s needs two or three arguments", func);

1316 else

1317 error(mpl, "syntax error in argument for %s", func);

1318 get_token(mpl /* , */);

1319 /* parse the second argument */

1320 arg.arg.y = numeric_argument(mpl, func);

1321 /* parse the third argument, if specified */

1322 if (mpl->token == T_COMMA)

1323 { op = O_SUBSTR3;

1324 get_token(mpl /* , */);

1325 arg.arg.z = numeric_argument(mpl, func);

1326 }

1327 /* check a token that follows the last argument */

1328 if (mpl->token == T_COMMA)

1329 error(mpl, "%s needs two or three arguments", func);

1330 else if (mpl->token == T_RIGHT)

1331 ;

1332 else

1333 error(mpl, "syntax error in argument for %s", func);

1334 }

1335 else if (op == O_STR2TIME)

1336 { /* str2time needs two arguments, both symbolic */

1337 /* parse the first argument */

1338 arg.arg.x = symbolic_argument(mpl, func);

1339 /* check a token that follows the first argument */

1340 if (mpl->token == T_COMMA)

1341 ;

1342 else if (mpl->token == T_RIGHT)

1343 error(mpl, "%s needs two arguments", func);

1344 else

1345 error(mpl, "syntax error in argument for %s", func);

1346 get_token(mpl /* , */);

1347 /* parse the second argument */

1348 arg.arg.y = symbolic_argument(mpl, func);

1349 /* check a token that follows the second argument */

1350 if (mpl->token == T_COMMA)

1351 error(mpl, "%s needs two argument", func);

1352 else if (mpl->token == T_RIGHT)

1353 ;

1354 else

1355 error(mpl, "syntax error in argument for %s", func);

1356 }

1357 else if (op == O_TIME2STR)

1358 { /* time2str needs two arguments, numeric and symbolic */

1359 /* parse the first argument */

1360 arg.arg.x = numeric_argument(mpl, func);

1361 /* check a token that follows the first argument */

1362 if (mpl->token == T_COMMA)

1363 ;

1364 else if (mpl->token == T_RIGHT)

1365 error(mpl, "%s needs two arguments", func);

1366 else

1367 error(mpl, "syntax error in argument for %s", func);

1368 get_token(mpl /* , */);

1369 /* parse the second argument */

1370 arg.arg.y = symbolic_argument(mpl, func);

1371 /* check a token that follows the second argument */

1372 if (mpl->token == T_COMMA)

1373 error(mpl, "%s needs two argument", func);

1374 else if (mpl->token == T_RIGHT)

1375 ;

1376 else

1377 error(mpl, "syntax error in argument for %s", func);

1378 }

1379 else

1380 { /* other functions need one argument */

1381 if (op == O_CARD)

1382 arg.arg.x = elemset_argument(mpl, func);

1383 else if (op == O_LENGTH)

1384 arg.arg.x = symbolic_argument(mpl, func);

1385 else

1386 arg.arg.x = numeric_argument(mpl, func);

1387 /* check a token that follows the argument */

1388 if (mpl->token == T_COMMA)

1389 error(mpl, "%s needs one argument", func);

1390 else if (mpl->token == T_RIGHT)

1391 ;

1392 else

1393 error(mpl, "syntax error in argument for %s", func);

1394 }

1395 /* make pseudo-code to call the built-in function */

1396 if (op == O_SUBSTR || op == O_SUBSTR3 || op == O_TIME2STR)

1397 code = make_code(mpl, op, &arg, A_SYMBOLIC, 0);

1398 else

1399 code = make_code(mpl, op, &arg, A_NUMERIC, 0);

1400 /* the reference ends with the right parenthesis */

1401 xassert(mpl->token == T_RIGHT);

1402 get_token(mpl /* ) */);

1403 return code;

1404 }

1405

1406 /*----------------------------------------------------------------------

1407 -- create_domain - create empty domain.

1408 --

1409 -- This routine creates empty domain, which is initially empty, i.e.

1410 -- has no domain blocks. */

1411

1412 DOMAIN *create_domain(MPL *mpl)

1413 { DOMAIN *domain;

1414 domain = alloc(DOMAIN);

1415 domain->list = NULL;

1416 domain->code = NULL;

1417 return domain;

1418 }

1419

1420 /*----------------------------------------------------------------------

1421 -- create_block - create empty domain block.

1422 --

1423 -- This routine creates empty domain block, which is initially empty,

1424 -- i.e. has no domain slots. */

1425

1426 DOMAIN_BLOCK *create_block(MPL *mpl)

1427 { DOMAIN_BLOCK *block;

1428 block = alloc(DOMAIN_BLOCK);

1429 block->list = NULL;

1430 block->code = NULL;

1431 block->backup = NULL;

1432 block->next = NULL;

1433 return block;

1434 }

1435

1436 /*----------------------------------------------------------------------

1437 -- append_block - append domain block to specified domain.

1438 --

1439 -- This routine adds given domain block to the end of the block list of

1440 -- specified domain. */

1441

1442 void append_block(MPL *mpl, DOMAIN *domain, DOMAIN_BLOCK *block)

1443 { DOMAIN_BLOCK *temp;

1444 xassert(mpl == mpl);

1445 xassert(domain != NULL);

1446 xassert(block != NULL);

1447 xassert(block->next == NULL);

1448 if (domain->list == NULL)

1449 domain->list = block;

1450 else

1451 { for (temp = domain->list; temp->next != NULL; temp =

1452 temp->next);

1453 temp->next = block;

1454 }

1455 return;

1456 }

1457

1458 /*----------------------------------------------------------------------

1459 -- append_slot - create and append new slot to domain block.

1460 --

1461 -- This routine creates new domain slot and adds it to the end of slot

1462 -- list of specified domain block.

1463 --

1464 -- The parameter name is symbolic name of the dummy index associated

1465 -- with the slot (the character string must be allocated). NULL means

1466 -- the dummy index is not explicitly specified.

1467 --

1468 -- The parameter code is pseudo-code for computing symbolic value, at

1469 -- which the dummy index is bounded. NULL means the dummy index is free

1470 -- in the domain scope. */

1471

1472 DOMAIN_SLOT *append_slot(MPL *mpl, DOMAIN_BLOCK *block, char *name,

1473 CODE *code)

1474 { DOMAIN_SLOT *slot, *temp;

1475 xassert(block != NULL);

1476 slot = alloc(DOMAIN_SLOT);

1477 slot->name = name;

1478 slot->code = code;

1479 slot->value = NULL;

1480 slot->list = NULL;

1481 slot->next = NULL;

1482 if (block->list == NULL)

1483 block->list = slot;

1484 else

1485 { for (temp = block->list; temp->next != NULL; temp =

1486 temp->next);

1487 temp->next = slot;

1488 }

1489 return slot;

1490 }

1491

1492 /*----------------------------------------------------------------------

1493 -- expression_list - parse expression list.

1494 --

1495 -- This routine parses a list of one or more expressions enclosed into

1496 -- the parentheses using the syntax:

1497 --

1498 -- <primary expression> ::= ( <expression list> )

1499 -- <expression list> ::= <expression 13>

1500 -- <expression list> ::= <expression 13> , <expression list>

1501 --

1502 -- Note that this construction may have three different meanings:

1503 --

1504 -- 1. If <expression list> consists of only one expression, <primary

1505 -- expression> is a parenthesized expression, which may be of any

1506 -- valid type (not necessarily 1-tuple).

1507 --

1508 -- 2. If <expression list> consists of several expressions separated by

1509 -- commae, where no expression is undeclared symbolic name, <primary

1510 -- expression> is a n-tuple.

1511 --

1512 -- 3. If <expression list> consists of several expressions separated by

1513 -- commae, where at least one expression is undeclared symbolic name

1514 -- (that denotes a dummy index), <primary expression> is a slice and

1515 -- can be only used as constituent of indexing expression. */

1516

1517 #define max_dim 20

1518 /* maximal number of components allowed within parentheses */

1519

1520 CODE *expression_list(MPL *mpl)

1521 { CODE *code;

1522 OPERANDS arg;

1523 struct { char *name; CODE *code; } list[1+max_dim];

1524 int flag_x, next_token, dim, j, slice = 0;

1525 xassert(mpl->token == T_LEFT);

1526 /* the flag, which allows recognizing undeclared symbolic names

1527 as dummy indices, will be automatically reset by get_token(),

1528 so save it before scanning the next token */

1529 flag_x = mpl->flag_x;

1530 get_token(mpl /* ( */);

1531 /* parse <expression list> */

1532 for (dim = 1; ; dim++)

1533 { if (dim > max_dim)

1534 error(mpl, "too many components within parentheses");

1535 /* current component of <expression list> can be either dummy

1536 index or expression */

1537 if (mpl->token == T_NAME)

1538 { /* symbolic name is recognized as dummy index only if:

1539 the flag, which allows that, is set, and

1540 the name is followed by comma or right parenthesis, and

1541 the name is undeclared */

1542 get_token(mpl /* <symbolic name> */);

1543 next_token = mpl->token;

1544 unget_token(mpl);

1545 if (!(flag_x &&

1546 (next_token == T_COMMA || next_token == T_RIGHT) &&

1547 avl_find_node(mpl->tree, mpl->image) == NULL))

1548 { /* this is not dummy index */

1549 goto expr;

1550 }

1551 /* all dummy indices within the same slice must have unique

1552 symbolic names */

1553 for (j = 1; j < dim; j++)

1554 { if (list[j].name != NULL && strcmp(list[j].name,

1555 mpl->image) == 0)

1556 error(mpl, "duplicate dummy index %s not allowed",

1557 mpl->image);

1558 }

1559 /* current component of <expression list> is dummy index */

1560 list[dim].name

1561 = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

1562 strcpy(list[dim].name, mpl->image);

1563 list[dim].code = NULL;

1564 get_token(mpl /* <symbolic name> */);

1565 /* <expression list> is a slice, because at least one dummy

1566 index has appeared */

1567 slice = 1;

1568 /* note that the context ( <dummy index> ) is not allowed,

1569 i.e. in this case <primary expression> is considered as

1570 a parenthesized expression */

1571 if (dim == 1 && mpl->token == T_RIGHT)

1572 error(mpl, "%s not defined", list[dim].name);

1573 }

1574 else

1575 expr: { /* current component of <expression list> is expression */

1576 code = expression_13(mpl);

1577 /* if the current expression is followed by comma or it is

1578 not the very first expression, entire <expression list>

1579 is n-tuple or slice, in which case the current expression

1580 should be converted to symbolic type, if necessary */

1581 if (mpl->token == T_COMMA || dim > 1)

1582 { if (code->type == A_NUMERIC)

1583 code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0);

1584 /* now the expression must be of symbolic type */

1585 if (code->type != A_SYMBOLIC)

1586 error(mpl, "component expression has invalid type");

1587 xassert(code->dim == 0);

1588 }

1589 list[dim].name = NULL;

1590 list[dim].code = code;

1591 }

1592 /* check a token that follows the current component */

1593 if (mpl->token == T_COMMA)

1594 get_token(mpl /* , */);

1595 else if (mpl->token == T_RIGHT)

1596 break;

1597 else

1598 error(mpl, "right parenthesis missing where expected");

1599 }

1600 /* generate pseudo-code for <primary expression> */

1601 if (dim == 1 && !slice)

1602 { /* <primary expression> is a parenthesized expression */

1603 code = list[1].code;

1604 }

1605 else if (!slice)

1606 { /* <primary expression> is a n-tuple */

1607 arg.list = create_arg_list(mpl);

1608 for (j = 1; j <= dim; j++)

1609 arg.list = expand_arg_list(mpl, arg.list, list[j].code);

1610 code = make_code(mpl, O_TUPLE, &arg, A_TUPLE, dim);

1611 }

1612 else

1613 { /* <primary expression> is a slice */

1614 arg.slice = create_block(mpl);

1615 for (j = 1; j <= dim; j++)

1616 append_slot(mpl, arg.slice, list[j].name, list[j].code);

1617 /* note that actually pseudo-codes with op = O_SLICE are never

1618 evaluated */

1619 code = make_code(mpl, O_SLICE, &arg, A_TUPLE, dim);

1620 }

1621 get_token(mpl /* ) */);

1622 /* if <primary expression> is a slice, there must be the keyword

1623 'in', which follows the right parenthesis */

1624 if (slice && mpl->token != T_IN)

1625 error(mpl, "keyword in missing where expected");

1626 /* if the slice flag is set and there is the keyword 'in', which

1627 follows <primary expression>, the latter must be a slice */

1628 if (flag_x && mpl->token == T_IN && !slice)

1629 { if (dim == 1)

1630 error(mpl, "syntax error in indexing expression");

1631 else

1632 error(mpl, "0-ary slice not allowed");

1633 }

1634 return code;

1635 }

1636

1637 /*----------------------------------------------------------------------

1638 -- literal set - parse literal set.

1639 --

1640 -- This routine parses literal set using the syntax:

1641 --

1642 -- <literal set> ::= { <member list> }

1643 -- <member list> ::= <member expression>

1644 -- <member list> ::= <member list> , <member expression>

1645 -- <member expression> ::= <expression 5>

1646 --

1647 -- It is assumed that the left curly brace and the very first member

1648 -- expression that follows it are already parsed. The right curly brace

1649 -- remains unscanned on exit. */

1650

1651 CODE *literal_set(MPL *mpl, CODE *code)

1652 { OPERANDS arg;

1653 int j;

1654 xassert(code != NULL);

1655 arg.list = create_arg_list(mpl);

1656 /* parse <member list> */

1657 for (j = 1; ; j++)

1658 { /* all member expressions must be n-tuples; so, if the current

1659 expression is not n-tuple, convert it to 1-tuple */

1660 if (code->type == A_NUMERIC)

1661 code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0);

1662 if (code->type == A_SYMBOLIC)

1663 code = make_unary(mpl, O_CVTTUP, code, A_TUPLE, 1);

1664 /* now the expression must be n-tuple */

1665 if (code->type != A_TUPLE)

1666 error(mpl, "member expression has invalid type");

1667 /* all member expressions must have identical dimension */

1668 if (arg.list != NULL && arg.list->x->dim != code->dim)

1669 error(mpl, "member %d has %d component%s while member %d ha"

1670 "s %d component%s",

1671 j-1, arg.list->x->dim, arg.list->x->dim == 1 ? "" : "s",

1672 j, code->dim, code->dim == 1 ? "" : "s");

1673 /* append the current expression to the member list */

1674 arg.list = expand_arg_list(mpl, arg.list, code);

1675 /* check a token that follows the current expression */

1676 if (mpl->token == T_COMMA)

1677 get_token(mpl /* , */);

1678 else if (mpl->token == T_RBRACE)

1679 break;

1680 else

1681 error(mpl, "syntax error in literal set");

1682 /* parse the next expression that follows the comma */

1683 code = expression_5(mpl);

1684 }

1685 /* generate pseudo-code for <literal set> */

1686 code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, arg.list->x->dim);

1687 return code;

1688 }

1689

1690 /*----------------------------------------------------------------------

1691 -- indexing_expression - parse indexing expression.

1692 --

1693 -- This routine parses indexing expression using the syntax:

1694 --

1695 -- <indexing expression> ::= <literal set>

1696 -- <indexing expression> ::= { <indexing list> }

1697 -- <indexing expression> ::= { <indexing list> : <logical expression> }

1698 -- <indexing list> ::= <indexing element>

1699 -- <indexing list> ::= <indexing list> , <indexing element>

1700 -- <indexing element> ::= <basic expression>

1701 -- <indexing element> ::= <dummy index> in <basic expression>

1702 -- <indexing element> ::= <slice> in <basic expression>

1703 -- <dummy index> ::= <symbolic name>

1704 -- <slice> ::= ( <expression list> )

1705 -- <basic expression> ::= <expression 9>

1706 -- <logical expression> ::= <expression 13>

1707 --

1708 -- This routine creates domain for <indexing expression>, where each

1709 -- domain block corresponds to <indexing element>, and each domain slot

1710 -- corresponds to individual indexing position. */

1711

1712 DOMAIN *indexing_expression(MPL *mpl)

1713 { DOMAIN *domain;

1714 DOMAIN_BLOCK *block;

1715 DOMAIN_SLOT *slot;

1716 CODE *code;

1717 xassert(mpl->token == T_LBRACE);

1718 get_token(mpl /* { */);

1719 if (mpl->token == T_RBRACE)

1720 error(mpl, "empty indexing expression not allowed");

1721 /* create domain to be constructed */

1722 domain = create_domain(mpl);

1723 /* parse either <member list> or <indexing list> that follows the

1724 left brace */

1725 for (;;)

1726 { /* domain block for <indexing element> is not created yet */

1727 block = NULL;

1728 /* pseudo-code for <basic expression> is not generated yet */

1729 code = NULL;

1730 /* check a token, which <indexing element> begins with */

1731 if (mpl->token == T_NAME)

1732 { /* it is a symbolic name */

1733 int next_token;

1734 char *name;

1735 /* symbolic name is recognized as dummy index only if it is

1736 followed by the keyword 'in' and not declared */

1737 get_token(mpl /* <symbolic name> */);

1738 next_token = mpl->token;

1739 unget_token(mpl);

1740 if (!(next_token == T_IN &&

1741 avl_find_node(mpl->tree, mpl->image) == NULL))

1742 { /* this is not dummy index; the symbolic name begins an

1743 expression, which is either <basic expression> or the

1744 very first <member expression> in <literal set> */

1745 goto expr;

1746 }

1747 /* create domain block with one slot, which is assigned the

1748 dummy index */

1749 block = create_block(mpl);

1750 name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

1751 strcpy(name, mpl->image);

1752 append_slot(mpl, block, name, NULL);

1753 get_token(mpl /* <symbolic name> */);

1754 /* the keyword 'in' is already checked above */

1755 xassert(mpl->token == T_IN);

1756 get_token(mpl /* in */);

1757 /* <basic expression> that follows the keyword 'in' will be

1758 parsed below */

1759 }

1760 else if (mpl->token == T_LEFT)

1761 { /* it is the left parenthesis; parse expression that begins

1762 with this parenthesis (the flag is set in order to allow

1763 recognizing slices; see the routine expression_list) */

1764 mpl->flag_x = 1;

1765 code = expression_9(mpl);

1766 if (code->op != O_SLICE)

1767 { /* this is either <basic expression> or the very first

1768 <member expression> in <literal set> */

1769 goto expr;

1770 }

1771 /* this is a slice; besides the corresponding domain block

1772 is already created by expression_list() */

1773 block = code->arg.slice;

1774 code = NULL; /* <basic expression> is not parsed yet */

1775 /* the keyword 'in' following the slice is already checked

1776 by expression_list() */

1777 xassert(mpl->token == T_IN);

1778 get_token(mpl /* in */);

1779 /* <basic expression> that follows the keyword 'in' will be

1780 parsed below */

1781 }

1782 expr: /* parse expression that follows either the keyword 'in' (in

1783 which case it can be <basic expression) or the left brace

1784 (in which case it can be <basic expression> as well as the

1785 very first <member expression> in <literal set>); note that

1786 this expression can be already parsed above */

1787 if (code == NULL) code = expression_9(mpl);

1788 /* check the type of the expression just parsed */

1789 if (code->type != A_ELEMSET)

1790 { /* it is not <basic expression> and therefore it can only

1791 be the very first <member expression> in <literal set>;

1792 however, then there must be no dummy index neither slice

1793 between the left brace and this expression */

1794 if (block != NULL)

1795 error(mpl, "domain expression has invalid type");

1796 /* parse the rest part of <literal set> and make this set

1797 be <basic expression>, i.e. the construction {a, b, c}

1798 is parsed as it were written as {A}, where A = {a, b, c}

1799 is a temporary elemental set */

1800 code = literal_set(mpl, code);

1801 }

1802 /* now pseudo-code for <basic set> has been built */

1803 xassert(code != NULL);

1804 xassert(code->type == A_ELEMSET);

1805 xassert(code->dim > 0);

1806 /* if domain block for the current <indexing element> is still

1807 not created, create it for fake slice of the same dimension

1808 as <basic set> */

1809 if (block == NULL)

1810 { int j;

1811 block = create_block(mpl);

1812 for (j = 1; j <= code->dim; j++)

1813 append_slot(mpl, block, NULL, NULL);

1814 }

1815 /* number of indexing positions in <indexing element> must be

1816 the same as dimension of n-tuples in basic set */

1817 { int dim = 0;

1818 for (slot = block->list; slot != NULL; slot = slot->next)

1819 dim++;

1820 if (dim != code->dim)

1821 error(mpl,"%d %s specified for set of dimension %d",

1822 dim, dim == 1 ? "index" : "indices", code->dim);

1823 }

1824 /* store pseudo-code for <basic set> in the domain block */

1825 xassert(block->code == NULL);

1826 block->code = code;

1827 /* and append the domain block to the domain */

1828 append_block(mpl, domain, block);

1829 /* the current <indexing element> has been completely parsed;

1830 include all its dummy indices into the symbolic name table

1831 to make them available for referencing from expressions;

1832 implicit declarations of dummy indices remain valid while

1833 the corresponding domain scope is valid */

1834 for (slot = block->list; slot != NULL; slot = slot->next)

1835 if (slot->name != NULL)

1836 { AVLNODE *node;

1837 xassert(avl_find_node(mpl->tree, slot->name) == NULL);

1838 node = avl_insert_node(mpl->tree, slot->name);

1839 avl_set_node_type(node, A_INDEX);

1840 avl_set_node_link(node, (void *)slot);

1841 }

1842 /* check a token that follows <indexing element> */

1843 if (mpl->token == T_COMMA)

1844 get_token(mpl /* , */);

1845 else if (mpl->token == T_COLON || mpl->token == T_RBRACE)

1846 break;

1847 else

1848 error(mpl, "syntax error in indexing expression");

1849 }

1850 /* parse <logical expression> that follows the colon */

1851 if (mpl->token == T_COLON)

1852 { get_token(mpl /* : */);

1853 code = expression_13(mpl);

1854 /* convert the expression to logical type, if necessary */

1855 if (code->type == A_SYMBOLIC)

1856 code = make_unary(mpl, O_CVTNUM, code, A_NUMERIC, 0);

1857 if (code->type == A_NUMERIC)

1858 code = make_unary(mpl, O_CVTLOG, code, A_LOGICAL, 0);

1859 /* now the expression must be of logical type */

1860 if (code->type != A_LOGICAL)

1861 error(mpl, "expression following colon has invalid type");

1862 xassert(code->dim == 0);

1863 domain->code = code;

1864 /* the right brace must follow the logical expression */

1865 if (mpl->token != T_RBRACE)

1866 error(mpl, "syntax error in indexing expression");

1867 }

1868 get_token(mpl /* } */);

1869 return domain;

1870 }

1871

1872 /*----------------------------------------------------------------------

1873 -- close_scope - close scope of indexing expression.

1874 --

1875 -- The routine closes the scope of indexing expression specified by its

1876 -- domain and thereby makes all dummy indices introduced in the indexing

1877 -- expression no longer available for referencing. */

1878

1879 void close_scope(MPL *mpl, DOMAIN *domain)

1880 { DOMAIN_BLOCK *block;

1881 DOMAIN_SLOT *slot;

1882 AVLNODE *node;

1883 xassert(domain != NULL);

1884 /* remove all dummy indices from the symbolic names table */

1885 for (block = domain->list; block != NULL; block = block->next)

1886 { for (slot = block->list; slot != NULL; slot = slot->next)

1887 { if (slot->name != NULL)

1888 { node = avl_find_node(mpl->tree, slot->name);

1889 xassert(node != NULL);

1890 xassert(avl_get_node_type(node) == A_INDEX);

1891 avl_delete_node(mpl->tree, node);

1892 }

1893 }

1894 }

1895 return;

1896 }

1897

1898 /*----------------------------------------------------------------------

1899 -- iterated_expression - parse iterated expression.

1900 --

1901 -- This routine parses primary expression using the syntax:

1902 --

1903 -- <primary expression> ::= <iterated expression>

1904 -- <iterated expression> ::= sum <indexing expression> <expression 3>

1905 -- <iterated expression> ::= prod <indexing expression> <expression 3>

1906 -- <iterated expression> ::= min <indexing expression> <expression 3>

1907 -- <iterated expression> ::= max <indexing expression> <expression 3>

1908 -- <iterated expression> ::= exists <indexing expression>

1909 -- <expression 12>

1910 -- <iterated expression> ::= forall <indexing expression>

1911 -- <expression 12>

1912 -- <iterated expression> ::= setof <indexing expression> <expression 5>

1913 --

1914 -- Note that parsing "integrand" depends on the iterated operator. */

1915

1916 #if 1 /* 07/IX-2008 */

1917 static void link_up(CODE *code)

1918 { /* if we have something like sum{(i+1,j,k-1) in E} x[i,j,k],

1919 where i and k are dummy indices defined out of the iterated

1920 expression, we should link up pseudo-code for computing i+1

1921 and k-1 to pseudo-code for computing the iterated expression;

1922 this is needed to invalidate current value of the iterated

1923 expression once i or k have been changed */

1924 DOMAIN_BLOCK *block;

1925 DOMAIN_SLOT *slot;

1926 for (block = code->arg.loop.domain->list; block != NULL;

1927 block = block->next)

1928 { for (slot = block->list; slot != NULL; slot = slot->next)

1929 { if (slot->code != NULL)

1930 { xassert(slot->code->up == NULL);

1931 slot->code->up = code;

1932 }

1933 }

1934 }

1935 return;

1936 }

1937 #endif

1938

1939 CODE *iterated_expression(MPL *mpl)

1940 { CODE *code;

1941 OPERANDS arg;

1942 int op;

1943 char opstr[8];

1944 /* determine operation code */

1945 xassert(mpl->token == T_NAME);

1946 if (strcmp(mpl->image, "sum") == 0)

1947 op = O_SUM;

1948 else if (strcmp(mpl->image, "prod") == 0)

1949 op = O_PROD;

1950 else if (strcmp(mpl->image, "min") == 0)

1951 op = O_MINIMUM;

1952 else if (strcmp(mpl->image, "max") == 0)

1953 op = O_MAXIMUM;

1954 else if (strcmp(mpl->image, "forall") == 0)

1955 op = O_FORALL;

1956 else if (strcmp(mpl->image, "exists") == 0)

1957 op = O_EXISTS;

1958 else if (strcmp(mpl->image, "setof") == 0)

1959 op = O_SETOF;

1960 else

1961 error(mpl, "operator %s unknown", mpl->image);

1962 strcpy(opstr, mpl->image);

1963 xassert(strlen(opstr) < sizeof(opstr));

1964 get_token(mpl /* <symbolic name> */);

1965 /* check the left brace that follows the operator name */

1966 xassert(mpl->token == T_LBRACE);

1967 /* parse indexing expression that controls iterating */

1968 arg.loop.domain = indexing_expression(mpl);

1969 /* parse "integrand" expression and generate pseudo-code */

1970 switch (op)

1971 { case O_SUM:

1972 case O_PROD:

1973 case O_MINIMUM:

1974 case O_MAXIMUM:

1975 arg.loop.x = expression_3(mpl);

1976 /* convert the integrand to numeric type, if necessary */

1977 if (arg.loop.x->type == A_SYMBOLIC)

1978 arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x,

1979 A_NUMERIC, 0);

1980 /* now the integrand must be of numeric type or linear form

1981 (the latter is only allowed for the sum operator) */

1982 if (!(arg.loop.x->type == A_NUMERIC ||

1983 op == O_SUM && arg.loop.x->type == A_FORMULA))

1984 err: error(mpl, "integrand following %s{...} has invalid type"

1985 , opstr);

1986 xassert(arg.loop.x->dim == 0);

1987 /* generate pseudo-code */

1988 code = make_code(mpl, op, &arg, arg.loop.x->type, 0);

1989 break;

1990 case O_FORALL:

1991 case O_EXISTS:

1992 arg.loop.x = expression_12(mpl);

1993 /* convert the integrand to logical type, if necessary */

1994 if (arg.loop.x->type == A_SYMBOLIC)

1995 arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x,

1996 A_NUMERIC, 0);

1997 if (arg.loop.x->type == A_NUMERIC)

1998 arg.loop.x = make_unary(mpl, O_CVTLOG, arg.loop.x,

1999 A_LOGICAL, 0);

2000 /* now the integrand must be of logical type */

2001 if (arg.loop.x->type != A_LOGICAL) goto err;

2002 xassert(arg.loop.x->dim == 0);

2003 /* generate pseudo-code */

2004 code = make_code(mpl, op, &arg, A_LOGICAL, 0);

2005 break;

2006 case O_SETOF:

2007 arg.loop.x = expression_5(mpl);

2008 /* convert the integrand to 1-tuple, if necessary */

2009 if (arg.loop.x->type == A_NUMERIC)

2010 arg.loop.x = make_unary(mpl, O_CVTSYM, arg.loop.x,

2011 A_SYMBOLIC, 0);

2012 if (arg.loop.x->type == A_SYMBOLIC)

2013 arg.loop.x = make_unary(mpl, O_CVTTUP, arg.loop.x,

2014 A_TUPLE, 1);

2015 /* now the integrand must be n-tuple */

2016 if (arg.loop.x->type != A_TUPLE) goto err;

2017 xassert(arg.loop.x->dim > 0);

2018 /* generate pseudo-code */

2019 code = make_code(mpl, op, &arg, A_ELEMSET, arg.loop.x->dim);

2020 break;

2021 default:

2022 xassert(op != op);

2023 }

2024 /* close the scope of the indexing expression */

2025 close_scope(mpl, arg.loop.domain);

2026 #if 1 /* 07/IX-2008 */

2027 link_up(code);

2028 #endif

2029 return code;

2030 }

2031

2032 /*----------------------------------------------------------------------

2033 -- domain_arity - determine arity of domain.

2034 --

2035 -- This routine returns arity of specified domain, which is number of

2036 -- its free dummy indices. */

2037

2038 int domain_arity(MPL *mpl, DOMAIN *domain)

2039 { DOMAIN_BLOCK *block;

2040 DOMAIN_SLOT *slot;

2041 int arity;

2042 xassert(mpl == mpl);

2043 arity = 0;

2044 for (block = domain->list; block != NULL; block = block->next)

2045 for (slot = block->list; slot != NULL; slot = slot->next)

2046 if (slot->code == NULL) arity++;

2047 return arity;

2048 }

2049

2050 /*----------------------------------------------------------------------

2051 -- set_expression - parse set expression.

2052 --

2053 -- This routine parses primary expression using the syntax:

2054 --

2055 -- <primary expression> ::= { }

2056 -- <primary expression> ::= <indexing expression> */

2057

2058 CODE *set_expression(MPL *mpl)

2059 { CODE *code;

2060 OPERANDS arg;

2061 xassert(mpl->token == T_LBRACE);

2062 get_token(mpl /* { */);

2063 /* check a token that follows the left brace */

2064 if (mpl->token == T_RBRACE)

2065 { /* it is the right brace, so the resultant is an empty set of

2066 dimension 1 */

2067 arg.list = NULL;

2068 /* generate pseudo-code to build the resultant set */

2069 code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, 1);

2070 get_token(mpl /* } */);

2071 }

2072 else

2073 { /* the next token begins an indexing expression */

2074 unget_token(mpl);

2075 arg.loop.domain = indexing_expression(mpl);

2076 arg.loop.x = NULL; /* integrand is not used */

2077 /* close the scope of the indexing expression */

2078 close_scope(mpl, arg.loop.domain);

2079 /* generate pseudo-code to build the resultant set */

2080 code = make_code(mpl, O_BUILD, &arg, A_ELEMSET,

2081 domain_arity(mpl, arg.loop.domain));

2082 #if 1 /* 07/IX-2008 */

2083 link_up(code);

2084 #endif

2085 }

2086 return code;

2087 }

2088

2089 /*----------------------------------------------------------------------

2090 -- branched_expression - parse conditional expression.

2091 --

2092 -- This routine parses primary expression using the syntax:

2093 --

2094 -- <primary expression> ::= <branched expression>

2095 -- <branched expression> ::= if <logical expression> then <expression 9>

2096 -- <branched expression> ::= if <logical expression> then <expression 9>

2097 -- else <expression 9>

2098 -- <logical expression> ::= <expression 13> */

2099

2100 CODE *branched_expression(MPL *mpl)

2101 { CODE *code, *x, *y, *z;

2102 xassert(mpl->token == T_IF);

2103 get_token(mpl /* if */);

2104 /* parse <logical expression> that follows 'if' */

2105 x = expression_13(mpl);

2106 /* convert the expression to logical type, if necessary */

2107 if (x->type == A_SYMBOLIC)

2108 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2109 if (x->type == A_NUMERIC)

2110 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

2111 /* now the expression must be of logical type */

2112 if (x->type != A_LOGICAL)

2113 error(mpl, "expression following if has invalid type");

2114 xassert(x->dim == 0);

2115 /* the keyword 'then' must follow the logical expression */

2116 if (mpl->token != T_THEN)

2117 error(mpl, "keyword then missing where expected");

2118 get_token(mpl /* then */);

2119 /* parse <expression> that follows 'then' and check its type */

2120 y = expression_9(mpl);

2121 if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC ||

2122 y->type == A_ELEMSET || y->type == A_FORMULA))

2123 error(mpl, "expression following then has invalid type");

2124 /* if the expression that follows the keyword 'then' is elemental

2125 set, the keyword 'else' cannot be omitted; otherwise else-part

2126 is optional */

2127 if (mpl->token != T_ELSE)

2128 { if (y->type == A_ELEMSET)

2129 error(mpl, "keyword else missing where expected");

2130 z = NULL;

2131 goto skip;

2132 }

2133 get_token(mpl /* else */);

2134 /* parse <expression> that follow 'else' and check its type */

2135 z = expression_9(mpl);

2136 if (!(z->type == A_NUMERIC || z->type == A_SYMBOLIC ||

2137 z->type == A_ELEMSET || z->type == A_FORMULA))

2138 error(mpl, "expression following else has invalid type");

2139 /* convert to identical types, if necessary */

2140 if (y->type == A_FORMULA || z->type == A_FORMULA)

2141 { if (y->type == A_SYMBOLIC)

2142 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2143 if (y->type == A_NUMERIC)

2144 y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);

2145 if (z->type == A_SYMBOLIC)

2146 z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0);

2147 if (z->type == A_NUMERIC)

2148 z = make_unary(mpl, O_CVTLFM, z, A_FORMULA, 0);

2149 }

2150 if (y->type == A_SYMBOLIC || z->type == A_SYMBOLIC)

2151 { if (y->type == A_NUMERIC)

2152 y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);

2153 if (z->type == A_NUMERIC)

2154 z = make_unary(mpl, O_CVTSYM, z, A_SYMBOLIC, 0);

2155 }

2156 /* now both expressions must have identical types */

2157 if (y->type != z->type)

2158 error(mpl, "expressions following then and else have incompati"

2159 "ble types");

2160 /* and identical dimensions */

2161 if (y->dim != z->dim)

2162 error(mpl, "expressions following then and else have different"

2163 " dimensions %d and %d, respectively", y->dim, z->dim);

2164 skip: /* generate pseudo-code to perform branching */

2165 code = make_ternary(mpl, O_FORK, x, y, z, y->type, y->dim);

2166 return code;

2167 }

2168

2169 /*----------------------------------------------------------------------

2170 -- primary_expression - parse primary expression.

2171 --

2172 -- This routine parses primary expression using the syntax:

2173 --

2174 -- <primary expression> ::= <numeric literal>

2175 -- <primary expression> ::= Infinity

2176 -- <primary expression> ::= <string literal>

2177 -- <primary expression> ::= <dummy index>

2178 -- <primary expression> ::= <set name>

2179 -- <primary expression> ::= <set name> [ <subscript list> ]

2180 -- <primary expression> ::= <parameter name>

2181 -- <primary expression> ::= <parameter name> [ <subscript list> ]

2182 -- <primary expression> ::= <variable name>

2183 -- <primary expression> ::= <variable name> [ <subscript list> ]

2184 -- <primary expression> ::= <built-in function> ( <argument list> )

2185 -- <primary expression> ::= ( <expression list> )

2186 -- <primary expression> ::= <iterated expression>

2187 -- <primary expression> ::= { }

2188 -- <primary expression> ::= <indexing expression>

2189 -- <primary expression> ::= <branched expression>

2190 --

2191 -- For complete list of syntactic rules for <primary expression> see

2192 -- comments to the corresponding parsing routines. */

2193

2194 CODE *primary_expression(MPL *mpl)

2195 { CODE *code;

2196 if (mpl->token == T_NUMBER)

2197 { /* parse numeric literal */

2198 code = numeric_literal(mpl);

2199 }

2200 #if 1 /* 21/VII-2006 */

2201 else if (mpl->token == T_INFINITY)

2202 { /* parse "infinity" */

2203 OPERANDS arg;

2204 arg.num = DBL_MAX;

2205 code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0);

2206 get_token(mpl /* Infinity */);

2207 }

2208 #endif

2209 else if (mpl->token == T_STRING)

2210 { /* parse string literal */

2211 code = string_literal(mpl);

2212 }

2213 else if (mpl->token == T_NAME)

2214 { int next_token;

2215 get_token(mpl /* <symbolic name> */);

2216 next_token = mpl->token;

2217 unget_token(mpl);

2218 /* check a token that follows <symbolic name> */

2219 switch (next_token)

2220 { case T_LBRACKET:

2221 /* parse reference to subscripted object */

2222 code = object_reference(mpl);

2223 break;

2224 case T_LEFT:

2225 /* parse reference to built-in function */

2226 code = function_reference(mpl);

2227 break;

2228 case T_LBRACE:

2229 /* parse iterated expression */

2230 code = iterated_expression(mpl);

2231 break;

2232 default:

2233 /* parse reference to unsubscripted object */

2234 code = object_reference(mpl);

2235 break;

2236 }

2237 }

2238 else if (mpl->token == T_LEFT)

2239 { /* parse parenthesized expression */

2240 code = expression_list(mpl);

2241 }

2242 else if (mpl->token == T_LBRACE)

2243 { /* parse set expression */

2244 code = set_expression(mpl);

2245 }

2246 else if (mpl->token == T_IF)

2247 { /* parse conditional expression */

2248 code = branched_expression(mpl);

2249 }

2250 else if (is_reserved(mpl))

2251 { /* other reserved keywords cannot be used here */

2252 error(mpl, "invalid use of reserved keyword %s", mpl->image);

2253 }

2254 else

2255 error(mpl, "syntax error in expression");

2256 return code;

2257 }

2258

2259 /*----------------------------------------------------------------------

2260 -- error_preceding - raise error if preceding operand has wrong type.

2261 --

2262 -- This routine is called to raise error if operand that precedes some

2263 -- infix operator has invalid type. */

2264

2265 void error_preceding(MPL *mpl, char *opstr)

2266 { error(mpl, "operand preceding %s has invalid type", opstr);

2267 /* no return */

2268 }

2269

2270 /*----------------------------------------------------------------------

2271 -- error_following - raise error if following operand has wrong type.

2272 --

2273 -- This routine is called to raise error if operand that follows some

2274 -- infix operator has invalid type. */

2275

2276 void error_following(MPL *mpl, char *opstr)

2277 { error(mpl, "operand following %s has invalid type", opstr);

2278 /* no return */

2279 }

2280

2281 /*----------------------------------------------------------------------

2282 -- error_dimension - raise error if operands have different dimension.

2283 --

2284 -- This routine is called to raise error if two operands of some infix

2285 -- operator have different dimension. */

2286

2287 void error_dimension(MPL *mpl, char *opstr, int dim1, int dim2)

2288 { error(mpl, "operands preceding and following %s have different di"

2289 "mensions %d and %d, respectively", opstr, dim1, dim2);

2290 /* no return */

2291 }

2292

2293 /*----------------------------------------------------------------------

2294 -- expression_0 - parse expression of level 0.

2295 --

2296 -- This routine parses expression of level 0 using the syntax:

2297 --

2298 -- <expression 0> ::= <primary expression> */

2299

2300 CODE *expression_0(MPL *mpl)

2301 { CODE *code;

2302 code = primary_expression(mpl);

2303 return code;

2304 }

2305

2306 /*----------------------------------------------------------------------

2307 -- expression_1 - parse expression of level 1.

2308 --

2309 -- This routine parses expression of level 1 using the syntax:

2310 --

2311 -- <expression 1> ::= <expression 0>

2312 -- <expression 1> ::= <expression 0> <power> <expression 1>

2313 -- <expression 1> ::= <expression 0> <power> <expression 2>

2314 -- <power> ::= ^ | ** */

2315

2316 CODE *expression_1(MPL *mpl)

2317 { CODE *x, *y;

2318 char opstr[8];

2319 x = expression_0(mpl);

2320 if (mpl->token == T_POWER)

2321 { strcpy(opstr, mpl->image);

2322 xassert(strlen(opstr) < sizeof(opstr));

2323 if (x->type == A_SYMBOLIC)

2324 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2325 if (x->type != A_NUMERIC)

2326 error_preceding(mpl, opstr);

2327 get_token(mpl /* ^ | ** */);

2328 if (mpl->token == T_PLUS || mpl->token == T_MINUS)

2329 y = expression_2(mpl);

2330 else

2331 y = expression_1(mpl);

2332 if (y->type == A_SYMBOLIC)

2333 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2334 if (y->type != A_NUMERIC)

2335 error_following(mpl, opstr);

2336 x = make_binary(mpl, O_POWER, x, y, A_NUMERIC, 0);

2337 }

2338 return x;

2339 }

2340

2341 /*----------------------------------------------------------------------

2342 -- expression_2 - parse expression of level 2.

2343 --

2344 -- This routine parses expression of level 2 using the syntax:

2345 --

2346 -- <expression 2> ::= <expression 1>

2347 -- <expression 2> ::= + <expression 1>

2348 -- <expression 2> ::= - <expression 1> */

2349

2350 CODE *expression_2(MPL *mpl)

2351 { CODE *x;

2352 if (mpl->token == T_PLUS)

2353 { get_token(mpl /* + */);

2354 x = expression_1(mpl);

2355 if (x->type == A_SYMBOLIC)

2356 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2357 if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

2358 error_following(mpl, "+");

2359 x = make_unary(mpl, O_PLUS, x, x->type, 0);

2360 }

2361 else if (mpl->token == T_MINUS)

2362 { get_token(mpl /* - */);

2363 x = expression_1(mpl);

2364 if (x->type == A_SYMBOLIC)

2365 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2366 if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

2367 error_following(mpl, "-");

2368 x = make_unary(mpl, O_MINUS, x, x->type, 0);

2369 }

2370 else

2371 x = expression_1(mpl);

2372 return x;

2373 }

2374

2375 /*----------------------------------------------------------------------

2376 -- expression_3 - parse expression of level 3.

2377 --

2378 -- This routine parses expression of level 3 using the syntax:

2379 --

2380 -- <expression 3> ::= <expression 2>

2381 -- <expression 3> ::= <expression 3> * <expression 2>

2382 -- <expression 3> ::= <expression 3> / <expression 2>

2383 -- <expression 3> ::= <expression 3> div <expression 2>

2384 -- <expression 3> ::= <expression 3> mod <expression 2> */

2385

2386 CODE *expression_3(MPL *mpl)

2387 { CODE *x, *y;

2388 x = expression_2(mpl);

2389 for (;;)

2390 { if (mpl->token == T_ASTERISK)

2391 { if (x->type == A_SYMBOLIC)

2392 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2393 if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

2394 error_preceding(mpl, "*");

2395 get_token(mpl /* * */);

2396 y = expression_2(mpl);

2397 if (y->type == A_SYMBOLIC)

2398 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2399 if (!(y->type == A_NUMERIC || y->type == A_FORMULA))

2400 error_following(mpl, "*");

2401 if (x->type == A_FORMULA && y->type == A_FORMULA)

2402 error(mpl, "multiplication of linear forms not allowed");

2403 if (x->type == A_NUMERIC && y->type == A_NUMERIC)

2404 x = make_binary(mpl, O_MUL, x, y, A_NUMERIC, 0);

2405 else

2406 x = make_binary(mpl, O_MUL, x, y, A_FORMULA, 0);

2407 }

2408 else if (mpl->token == T_SLASH)

2409 { if (x->type == A_SYMBOLIC)

2410 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2411 if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

2412 error_preceding(mpl, "/");

2413 get_token(mpl /* / */);

2414 y = expression_2(mpl);

2415 if (y->type == A_SYMBOLIC)

2416 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2417 if (y->type != A_NUMERIC)

2418 error_following(mpl, "/");

2419 if (x->type == A_NUMERIC)

2420 x = make_binary(mpl, O_DIV, x, y, A_NUMERIC, 0);

2421 else

2422 x = make_binary(mpl, O_DIV, x, y, A_FORMULA, 0);

2423 }

2424 else if (mpl->token == T_DIV)

2425 { if (x->type == A_SYMBOLIC)

2426 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2427 if (x->type != A_NUMERIC)

2428 error_preceding(mpl, "div");

2429 get_token(mpl /* div */);

2430 y = expression_2(mpl);

2431 if (y->type == A_SYMBOLIC)

2432 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2433 if (y->type != A_NUMERIC)

2434 error_following(mpl, "div");

2435 x = make_binary(mpl, O_IDIV, x, y, A_NUMERIC, 0);

2436 }

2437 else if (mpl->token == T_MOD)

2438 { if (x->type == A_SYMBOLIC)

2439 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2440 if (x->type != A_NUMERIC)

2441 error_preceding(mpl, "mod");

2442 get_token(mpl /* mod */);

2443 y = expression_2(mpl);

2444 if (y->type == A_SYMBOLIC)

2445 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2446 if (y->type != A_NUMERIC)

2447 error_following(mpl, "mod");

2448 x = make_binary(mpl, O_MOD, x, y, A_NUMERIC, 0);

2449 }

2450 else

2451 break;

2452 }

2453 return x;

2454 }

2455

2456 /*----------------------------------------------------------------------

2457 -- expression_4 - parse expression of level 4.

2458 --

2459 -- This routine parses expression of level 4 using the syntax:

2460 --

2461 -- <expression 4> ::= <expression 3>

2462 -- <expression 4> ::= <expression 4> + <expression 3>

2463 -- <expression 4> ::= <expression 4> - <expression 3>

2464 -- <expression 4> ::= <expression 4> less <expression 3> */

2465

2466 CODE *expression_4(MPL *mpl)

2467 { CODE *x, *y;

2468 x = expression_3(mpl);

2469 for (;;)

2470 { if (mpl->token == T_PLUS)

2471 { if (x->type == A_SYMBOLIC)

2472 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2473 if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

2474 error_preceding(mpl, "+");

2475 get_token(mpl /* + */);

2476 y = expression_3(mpl);

2477 if (y->type == A_SYMBOLIC)

2478 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2479 if (!(y->type == A_NUMERIC || y->type == A_FORMULA))

2480 error_following(mpl, "+");

2481 if (x->type == A_NUMERIC && y->type == A_FORMULA)

2482 x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0);

2483 if (x->type == A_FORMULA && y->type == A_NUMERIC)

2484 y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);

2485 x = make_binary(mpl, O_ADD, x, y, x->type, 0);

2486 }

2487 else if (mpl->token == T_MINUS)

2488 { if (x->type == A_SYMBOLIC)

2489 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2490 if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

2491 error_preceding(mpl, "-");

2492 get_token(mpl /* - */);

2493 y = expression_3(mpl);

2494 if (y->type == A_SYMBOLIC)

2495 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2496 if (!(y->type == A_NUMERIC || y->type == A_FORMULA))

2497 error_following(mpl, "-");

2498 if (x->type == A_NUMERIC && y->type == A_FORMULA)

2499 x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0);

2500 if (x->type == A_FORMULA && y->type == A_NUMERIC)

2501 y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);

2502 x = make_binary(mpl, O_SUB, x, y, x->type, 0);

2503 }

2504 else if (mpl->token == T_LESS)

2505 { if (x->type == A_SYMBOLIC)

2506 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2507 if (x->type != A_NUMERIC)

2508 error_preceding(mpl, "less");

2509 get_token(mpl /* less */);

2510 y = expression_3(mpl);

2511 if (y->type == A_SYMBOLIC)

2512 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2513 if (y->type != A_NUMERIC)

2514 error_following(mpl, "less");

2515 x = make_binary(mpl, O_LESS, x, y, A_NUMERIC, 0);

2516 }

2517 else

2518 break;

2519 }

2520 return x;

2521 }

2522

2523 /*----------------------------------------------------------------------

2524 -- expression_5 - parse expression of level 5.

2525 --

2526 -- This routine parses expression of level 5 using the syntax:

2527 --

2528 -- <expression 5> ::= <expression 4>

2529 -- <expression 5> ::= <expression 5> & <expression 4> */

2530

2531 CODE *expression_5(MPL *mpl)

2532 { CODE *x, *y;

2533 x = expression_4(mpl);

2534 for (;;)

2535 { if (mpl->token == T_CONCAT)

2536 { if (x->type == A_NUMERIC)

2537 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

2538 if (x->type != A_SYMBOLIC)

2539 error_preceding(mpl, "&");

2540 get_token(mpl /* & */);

2541 y = expression_4(mpl);

2542 if (y->type == A_NUMERIC)

2543 y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);

2544 if (y->type != A_SYMBOLIC)

2545 error_following(mpl, "&");

2546 x = make_binary(mpl, O_CONCAT, x, y, A_SYMBOLIC, 0);

2547 }

2548 else

2549 break;

2550 }

2551 return x;

2552 }

2553

2554 /*----------------------------------------------------------------------

2555 -- expression_6 - parse expression of level 6.

2556 --

2557 -- This routine parses expression of level 6 using the syntax:

2558 --

2559 -- <expression 6> ::= <expression 5>

2560 -- <expression 6> ::= <expression 5> .. <expression 5>

2561 -- <expression 6> ::= <expression 5> .. <expression 5> by

2562 -- <expression 5> */

2563

2564 CODE *expression_6(MPL *mpl)

2565 { CODE *x, *y, *z;

2566 x = expression_5(mpl);

2567 if (mpl->token == T_DOTS)

2568 { if (x->type == A_SYMBOLIC)

2569 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2570 if (x->type != A_NUMERIC)

2571 error_preceding(mpl, "..");

2572 get_token(mpl /* .. */);

2573 y = expression_5(mpl);

2574 if (y->type == A_SYMBOLIC)

2575 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2576 if (y->type != A_NUMERIC)

2577 error_following(mpl, "..");

2578 if (mpl->token == T_BY)

2579 { get_token(mpl /* by */);

2580 z = expression_5(mpl);

2581 if (z->type == A_SYMBOLIC)

2582 z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0);

2583 if (z->type != A_NUMERIC)

2584 error_following(mpl, "by");

2585 }

2586 else

2587 z = NULL;

2588 x = make_ternary(mpl, O_DOTS, x, y, z, A_ELEMSET, 1);

2589 }

2590 return x;

2591 }

2592

2593 /*----------------------------------------------------------------------

2594 -- expression_7 - parse expression of level 7.

2595 --

2596 -- This routine parses expression of level 7 using the syntax:

2597 --

2598 -- <expression 7> ::= <expression 6>

2599 -- <expression 7> ::= <expression 7> cross <expression 6> */

2600

2601 CODE *expression_7(MPL *mpl)

2602 { CODE *x, *y;

2603 x = expression_6(mpl);

2604 for (;;)

2605 { if (mpl->token == T_CROSS)

2606 { if (x->type != A_ELEMSET)

2607 error_preceding(mpl, "cross");

2608 get_token(mpl /* cross */);

2609 y = expression_6(mpl);

2610 if (y->type != A_ELEMSET)

2611 error_following(mpl, "cross");

2612 x = make_binary(mpl, O_CROSS, x, y, A_ELEMSET,

2613 x->dim + y->dim);

2614 }

2615 else

2616 break;

2617 }

2618 return x;

2619 }

2620

2621 /*----------------------------------------------------------------------

2622 -- expression_8 - parse expression of level 8.

2623 --

2624 -- This routine parses expression of level 8 using the syntax:

2625 --

2626 -- <expression 8> ::= <expression 7>

2627 -- <expression 8> ::= <expression 8> inter <expression 7> */

2628

2629 CODE *expression_8(MPL *mpl)

2630 { CODE *x, *y;

2631 x = expression_7(mpl);

2632 for (;;)

2633 { if (mpl->token == T_INTER)

2634 { if (x->type != A_ELEMSET)

2635 error_preceding(mpl, "inter");

2636 get_token(mpl /* inter */);

2637 y = expression_7(mpl);

2638 if (y->type != A_ELEMSET)

2639 error_following(mpl, "inter");

2640 if (x->dim != y->dim)

2641 error_dimension(mpl, "inter", x->dim, y->dim);

2642 x = make_binary(mpl, O_INTER, x, y, A_ELEMSET, x->dim);

2643 }

2644 else

2645 break;

2646 }

2647 return x;

2648 }

2649

2650 /*----------------------------------------------------------------------

2651 -- expression_9 - parse expression of level 9.

2652 --

2653 -- This routine parses expression of level 9 using the syntax:

2654 --

2655 -- <expression 9> ::= <expression 8>

2656 -- <expression 9> ::= <expression 9> union <expression 8>

2657 -- <expression 9> ::= <expression 9> diff <expression 8>

2658 -- <expression 9> ::= <expression 9> symdiff <expression 8> */

2659

2660 CODE *expression_9(MPL *mpl)

2661 { CODE *x, *y;

2662 x = expression_8(mpl);

2663 for (;;)

2664 { if (mpl->token == T_UNION)

2665 { if (x->type != A_ELEMSET)

2666 error_preceding(mpl, "union");

2667 get_token(mpl /* union */);

2668 y = expression_8(mpl);

2669 if (y->type != A_ELEMSET)

2670 error_following(mpl, "union");

2671 if (x->dim != y->dim)

2672 error_dimension(mpl, "union", x->dim, y->dim);

2673 x = make_binary(mpl, O_UNION, x, y, A_ELEMSET, x->dim);

2674 }

2675 else if (mpl->token == T_DIFF)

2676 { if (x->type != A_ELEMSET)

2677 error_preceding(mpl, "diff");

2678 get_token(mpl /* diff */);

2679 y = expression_8(mpl);

2680 if (y->type != A_ELEMSET)

2681 error_following(mpl, "diff");

2682 if (x->dim != y->dim)

2683 error_dimension(mpl, "diff", x->dim, y->dim);

2684 x = make_binary(mpl, O_DIFF, x, y, A_ELEMSET, x->dim);

2685 }

2686 else if (mpl->token == T_SYMDIFF)

2687 { if (x->type != A_ELEMSET)

2688 error_preceding(mpl, "symdiff");

2689 get_token(mpl /* symdiff */);

2690 y = expression_8(mpl);

2691 if (y->type != A_ELEMSET)

2692 error_following(mpl, "symdiff");

2693 if (x->dim != y->dim)

2694 error_dimension(mpl, "symdiff", x->dim, y->dim);

2695 x = make_binary(mpl, O_SYMDIFF, x, y, A_ELEMSET, x->dim);

2696 }

2697 else

2698 break;

2699 }

2700 return x;

2701 }

2702

2703 /*----------------------------------------------------------------------

2704 -- expression_10 - parse expression of level 10.

2705 --

2706 -- This routine parses expression of level 10 using the syntax:

2707 --

2708 -- <expression 10> ::= <expression 9>

2709 -- <expression 10> ::= <expression 9> <rho> <expression 9>

2710 -- <rho> ::= < | <= | = | == | >= | > | <> | != | in | not in | ! in |

2711 -- within | not within | ! within */

2712

2713 CODE *expression_10(MPL *mpl)

2714 { CODE *x, *y;

2715 int op = -1;

2716 char opstr[16];

2717 x = expression_9(mpl);

2718 strcpy(opstr, "");

2719 switch (mpl->token)

2720 { case T_LT:

2721 op = O_LT; break;

2722 case T_LE:

2723 op = O_LE; break;

2724 case T_EQ:

2725 op = O_EQ; break;

2726 case T_GE:

2727 op = O_GE; break;

2728 case T_GT:

2729 op = O_GT; break;

2730 case T_NE:

2731 op = O_NE; break;

2732 case T_IN:

2733 op = O_IN; break;

2734 case T_WITHIN:

2735 op = O_WITHIN; break;

2736 case T_NOT:

2737 strcpy(opstr, mpl->image);

2738 get_token(mpl /* not | ! */);

2739 if (mpl->token == T_IN)

2740 op = O_NOTIN;

2741 else if (mpl->token == T_WITHIN)

2742 op = O_NOTWITHIN;

2743 else

2744 error(mpl, "invalid use of %s", opstr);

2745 strcat(opstr, " ");

2746 break;

2747 default:

2748 goto done;

2749 }

2750 strcat(opstr, mpl->image);

2751 xassert(strlen(opstr) < sizeof(opstr));

2752 switch (op)

2753 { case O_EQ:

2754 case O_NE:

2755 #if 1 /* 02/VIII-2008 */

2756 case O_LT:

2757 case O_LE:

2758 case O_GT:

2759 case O_GE:

2760 #endif

2761 if (!(x->type == A_NUMERIC || x->type == A_SYMBOLIC))

2762 error_preceding(mpl, opstr);

2763 get_token(mpl /* <rho> */);

2764 y = expression_9(mpl);

2765 if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC))

2766 error_following(mpl, opstr);

2767 if (x->type == A_NUMERIC && y->type == A_SYMBOLIC)

2768 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

2769 if (x->type == A_SYMBOLIC && y->type == A_NUMERIC)

2770 y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);

2771 x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

2772 break;

2773 #if 0 /* 02/VIII-2008 */

2774 case O_LT:

2775 case O_LE:

2776 case O_GT:

2777 case O_GE:

2778 if (x->type == A_SYMBOLIC)

2779 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2780 if (x->type != A_NUMERIC)

2781 error_preceding(mpl, opstr);

2782 get_token(mpl /* <rho> */);

2783 y = expression_9(mpl);

2784 if (y->type == A_SYMBOLIC)

2785 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2786 if (y->type != A_NUMERIC)

2787 error_following(mpl, opstr);

2788 x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

2789 break;

2790 #endif

2791 case O_IN:

2792 case O_NOTIN:

2793 if (x->type == A_NUMERIC)

2794 x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

2795 if (x->type == A_SYMBOLIC)

2796 x = make_unary(mpl, O_CVTTUP, x, A_TUPLE, 1);

2797 if (x->type != A_TUPLE)

2798 error_preceding(mpl, opstr);

2799 get_token(mpl /* <rho> */);

2800 y = expression_9(mpl);

2801 if (y->type != A_ELEMSET)

2802 error_following(mpl, opstr);

2803 if (x->dim != y->dim)

2804 error_dimension(mpl, opstr, x->dim, y->dim);

2805 x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

2806 break;

2807 case O_WITHIN:

2808 case O_NOTWITHIN:

2809 if (x->type != A_ELEMSET)

2810 error_preceding(mpl, opstr);

2811 get_token(mpl /* <rho> */);

2812 y = expression_9(mpl);

2813 if (y->type != A_ELEMSET)

2814 error_following(mpl, opstr);

2815 if (x->dim != y->dim)

2816 error_dimension(mpl, opstr, x->dim, y->dim);

2817 x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

2818 break;

2819 default:

2820 xassert(op != op);

2821 }

2822 done: return x;

2823 }

2824

2825 /*----------------------------------------------------------------------

2826 -- expression_11 - parse expression of level 11.

2827 --

2828 -- This routine parses expression of level 11 using the syntax:

2829 --

2830 -- <expression 11> ::= <expression 10>

2831 -- <expression 11> ::= not <expression 10>

2832 -- <expression 11> ::= ! <expression 10> */

2833

2834 CODE *expression_11(MPL *mpl)

2835 { CODE *x;

2836 char opstr[8];

2837 if (mpl->token == T_NOT)

2838 { strcpy(opstr, mpl->image);

2839 xassert(strlen(opstr) < sizeof(opstr));

2840 get_token(mpl /* not | ! */);

2841 x = expression_10(mpl);

2842 if (x->type == A_SYMBOLIC)

2843 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2844 if (x->type == A_NUMERIC)

2845 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

2846 if (x->type != A_LOGICAL)

2847 error_following(mpl, opstr);

2848 x = make_unary(mpl, O_NOT, x, A_LOGICAL, 0);

2849 }

2850 else

2851 x = expression_10(mpl);

2852 return x;

2853 }

2854

2855 /*----------------------------------------------------------------------

2856 -- expression_12 - parse expression of level 12.

2857 --

2858 -- This routine parses expression of level 12 using the syntax:

2859 --

2860 -- <expression 12> ::= <expression 11>

2861 -- <expression 12> ::= <expression 12> and <expression 11>

2862 -- <expression 12> ::= <expression 12> && <expression 11> */

2863

2864 CODE *expression_12(MPL *mpl)

2865 { CODE *x, *y;

2866 char opstr[8];

2867 x = expression_11(mpl);

2868 for (;;)

2869 { if (mpl->token == T_AND)

2870 { strcpy(opstr, mpl->image);

2871 xassert(strlen(opstr) < sizeof(opstr));

2872 if (x->type == A_SYMBOLIC)

2873 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2874 if (x->type == A_NUMERIC)

2875 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

2876 if (x->type != A_LOGICAL)

2877 error_preceding(mpl, opstr);

2878 get_token(mpl /* and | && */);

2879 y = expression_11(mpl);

2880 if (y->type == A_SYMBOLIC)

2881 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2882 if (y->type == A_NUMERIC)

2883 y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0);

2884 if (y->type != A_LOGICAL)

2885 error_following(mpl, opstr);

2886 x = make_binary(mpl, O_AND, x, y, A_LOGICAL, 0);

2887 }

2888 else

2889 break;

2890 }

2891 return x;

2892 }

2893

2894 /*----------------------------------------------------------------------

2895 -- expression_13 - parse expression of level 13.

2896 --

2897 -- This routine parses expression of level 13 using the syntax:

2898 --

2899 -- <expression 13> ::= <expression 12>

2900 -- <expression 13> ::= <expression 13> or <expression 12>

2901 -- <expression 13> ::= <expression 13> || <expression 12> */

2902

2903 CODE *expression_13(MPL *mpl)

2904 { CODE *x, *y;

2905 char opstr[8];

2906 x = expression_12(mpl);

2907 for (;;)

2908 { if (mpl->token == T_OR)

2909 { strcpy(opstr, mpl->image);

2910 xassert(strlen(opstr) < sizeof(opstr));

2911 if (x->type == A_SYMBOLIC)

2912 x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

2913 if (x->type == A_NUMERIC)

2914 x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

2915 if (x->type != A_LOGICAL)

2916 error_preceding(mpl, opstr);

2917 get_token(mpl /* or | || */);

2918 y = expression_12(mpl);

2919 if (y->type == A_SYMBOLIC)

2920 y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

2921 if (y->type == A_NUMERIC)

2922 y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0);

2923 if (y->type != A_LOGICAL)

2924 error_following(mpl, opstr);

2925 x = make_binary(mpl, O_OR, x, y, A_LOGICAL, 0);

2926 }

2927 else

2928 break;

2929 }

2930 return x;

2931 }

2932

2933 /*----------------------------------------------------------------------

2934 -- set_statement - parse set statement.

2935 --

2936 -- This routine parses set statement using the syntax:

2937 --

2938 -- <set statement> ::= set <symbolic name> <alias> <domain>

2939 -- <attributes> ;

2940 -- <alias> ::= <empty>

2941 -- <alias> ::= <string literal>

2942 -- <domain> ::= <empty>

2943 -- <domain> ::= <indexing expression>

2944 -- <attributes> ::= <empty>

2945 -- <attributes> ::= <attributes> , dimen <numeric literal>

2946 -- <attributes> ::= <attributes> , within <expression 9>

2947 -- <attributes> ::= <attributes> , := <expression 9>

2948 -- <attributes> ::= <attributes> , default <expression 9>

2949 --

2950 -- Commae in <attributes> are optional and may be omitted anywhere. */

2951

2952 SET *set_statement(MPL *mpl)

2953 { SET *set;

2954 int dimen_used = 0;

2955 xassert(is_keyword(mpl, "set"));

2956 get_token(mpl /* set */);

2957 /* symbolic name must follow the keyword 'set' */

2958 if (mpl->token == T_NAME)

2959 ;

2960 else if (is_reserved(mpl))

2961 error(mpl, "invalid use of reserved keyword %s", mpl->image);

2962 else

2963 error(mpl, "symbolic name missing where expected");

2964 /* there must be no other object with the same name */

2965 if (avl_find_node(mpl->tree, mpl->image) != NULL)

2966 error(mpl, "%s multiply declared", mpl->image);

2967 /* create model set */

2968 set = alloc(SET);

2969 set->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

2970 strcpy(set->name, mpl->image);

2971 set->alias = NULL;

2972 set->dim = 0;

2973 set->domain = NULL;

2974 set->dimen = 0;

2975 set->within = NULL;

2976 set->assign = NULL;

2977 set->option = NULL;

2978 set->gadget = NULL;

2979 set->data = 0;

2980 set->array = NULL;

2981 get_token(mpl /* <symbolic name> */);

2982 /* parse optional alias */

2983 if (mpl->token == T_STRING)

2984 { set->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

2985 strcpy(set->alias, mpl->image);

2986 get_token(mpl /* <string literal> */);

2987 }

2988 /* parse optional indexing expression */

2989 if (mpl->token == T_LBRACE)

2990 { set->domain = indexing_expression(mpl);

2991 set->dim = domain_arity(mpl, set->domain);

2992 }

2993 /* include the set name in the symbolic names table */

2994 { AVLNODE *node;

2995 node = avl_insert_node(mpl->tree, set->name);

2996 avl_set_node_type(node, A_SET);

2997 avl_set_node_link(node, (void *)set);

2998 }

2999 /* parse the list of optional attributes */

3000 for (;;)

3001 { if (mpl->token == T_COMMA)

3002 get_token(mpl /* , */);

3003 else if (mpl->token == T_SEMICOLON)

3004 break;

3005 if (is_keyword(mpl, "dimen"))

3006 { /* dimension of set members */

3007 int dimen;

3008 get_token(mpl /* dimen */);

3009 if (!(mpl->token == T_NUMBER &&

3010 1.0 <= mpl->value && mpl->value <= 20.0 &&

3011 floor(mpl->value) == mpl->value))

3012 error(mpl, "dimension must be integer between 1 and 20");

3013 dimen = (int)(mpl->value + 0.5);

3014 if (dimen_used)

3015 error(mpl, "at most one dimension attribute allowed");

3016 if (set->dimen > 0)

3017 error(mpl, "dimension %d conflicts with dimension %d alr"

3018 "eady determined", dimen, set->dimen);

3019 set->dimen = dimen;

3020 dimen_used = 1;

3021 get_token(mpl /* <numeric literal> */);

3022 }

3023 else if (mpl->token == T_WITHIN || mpl->token == T_IN)

3024 { /* restricting superset */

3025 WITHIN *within, *temp;

3026 if (mpl->token == T_IN && !mpl->as_within)

3027 { warning(mpl, "keyword in understood as within");

3028 mpl->as_within = 1;

3029 }

3030 get_token(mpl /* within */);

3031 /* create new restricting superset list entry and append it

3032 to the within-list */

3033 within = alloc(WITHIN);

3034 within->code = NULL;

3035 within->next = NULL;

3036 if (set->within == NULL)

3037 set->within = within;

3038 else

3039 { for (temp = set->within; temp->next != NULL; temp =

3040 temp->next);

3041 temp->next = within;

3042 }

3043 /* parse an expression that follows 'within' */

3044 within->code = expression_9(mpl);

3045 if (within->code->type != A_ELEMSET)

3046 error(mpl, "expression following within has invalid type"

3047 );

3048 xassert(within->code->dim > 0);

3049 /* check/set dimension of set members */

3050 if (set->dimen == 0) set->dimen = within->code->dim;

3051 if (set->dimen != within->code->dim)

3052 error(mpl, "set expression following within must have di"

3053 "mension %d rather than %d",

3054 set->dimen, within->code->dim);

3055 }

3056 else if (mpl->token == T_ASSIGN)

3057 { /* assignment expression */

3058 if (!(set->assign == NULL && set->option == NULL &&

3059 set->gadget == NULL))

3060 err: error(mpl, "at most one := or default/data allowed");

3061 get_token(mpl /* := */);

3062 /* parse an expression that follows ':=' */

3063 set->assign = expression_9(mpl);

3064 if (set->assign->type != A_ELEMSET)

3065 error(mpl, "expression following := has invalid type");

3066 xassert(set->assign->dim > 0);

3067 /* check/set dimension of set members */

3068 if (set->dimen == 0) set->dimen = set->assign->dim;

3069 if (set->dimen != set->assign->dim)

3070 error(mpl, "set expression following := must have dimens"

3071 "ion %d rather than %d",

3072 set->dimen, set->assign->dim);

3073 }

3074 else if (is_keyword(mpl, "default"))

3075 { /* expression for default value */

3076 if (!(set->assign == NULL && set->option == NULL)) goto err;

3077 get_token(mpl /* := */);

3078 /* parse an expression that follows 'default' */

3079 set->option = expression_9(mpl);

3080 if (set->option->type != A_ELEMSET)

3081 error(mpl, "expression following default has invalid typ"

3082 "e");

3083 xassert(set->option->dim > 0);

3084 /* check/set dimension of set members */

3085 if (set->dimen == 0) set->dimen = set->option->dim;

3086 if (set->dimen != set->option->dim)

3087 error(mpl, "set expression following default must have d"

3088 "imension %d rather than %d",

3089 set->dimen, set->option->dim);

3090 }

3091 #if 1 /* 12/XII-2008 */

3092 else if (is_keyword(mpl, "data"))

3093 { /* gadget to initialize the set by data from plain set */

3094 GADGET *gadget;

3095 AVLNODE *node;

3096 int i, k, fff[20];

3097 if (!(set->assign == NULL && set->gadget == NULL)) goto err;

3098 get_token(mpl /* data */);

3099 set->gadget = gadget = alloc(GADGET);

3100 /* set name must follow the keyword 'data' */

3101 if (mpl->token == T_NAME)

3102 ;

3103 else if (is_reserved(mpl))

3104 error(mpl, "invalid use of reserved keyword %s",

3105 mpl->image);

3106 else

3107 error(mpl, "set name missing where expected");

3108 /* find the set in the symbolic name table */

3109 node = avl_find_node(mpl->tree, mpl->image);

3110 if (node == NULL)

3111 error(mpl, "%s not defined", mpl->image);

3112 if (avl_get_node_type(node) != A_SET)

3113 err1: error(mpl, "%s not a plain set", mpl->image);

3114 gadget->set = avl_get_node_link(node);

3115 if (gadget->set->dim != 0) goto err1;

3116 if (gadget->set == set)

3117 error(mpl, "set cannot be initialized by itself");

3118 /* check and set dimensions */

3119 if (set->dim >= gadget->set->dimen)

3120 err2: error(mpl, "dimension of %s too small", mpl->image);

3121 if (set->dimen == 0)

3122 set->dimen = gadget->set->dimen - set->dim;

3123 if (set->dim + set->dimen > gadget->set->dimen)

3124 goto err2;

3125 else if (set->dim + set->dimen < gadget->set->dimen)

3126 error(mpl, "dimension of %s too big", mpl->image);

3127 get_token(mpl /* set name */);

3128 /* left parenthesis must follow the set name */

3129 if (mpl->token == T_LEFT)

3130 get_token(mpl /* ( */);

3131 else

3132 error(mpl, "left parenthesis missing where expected");

3133 /* parse permutation of component numbers */

3134 for (k = 0; k < gadget->set->dimen; k++) fff[k] = 0;

3135 k = 0;

3136 for (;;)

3137 { if (mpl->token != T_NUMBER)

3138 error(mpl, "component number missing where expected");

3139 if (str2int(mpl->image, &i) != 0)

3140 err3: error(mpl, "component number must be integer between "

3141 "1 and %d", gadget->set->dimen);

3142 if (!(1 <= i && i <= gadget->set->dimen)) goto err3;

3143 if (fff[i-1] != 0)

3144 error(mpl, "component %d multiply specified", i);

3145 gadget->ind[k++] = i, fff[i-1] = 1;

3146 xassert(k <= gadget->set->dimen);

3147 get_token(mpl /* number */);

3148 if (mpl->token == T_COMMA)

3149 get_token(mpl /* , */);

3150 else if (mpl->token == T_RIGHT)

3151 break;

3152 else

3153 error(mpl, "syntax error in data attribute");

3154 }

3155 if (k < gadget->set->dimen)

3156 error(mpl, "there are must be %d components rather than "

3157 "%d", gadget->set->dimen, k);

3158 get_token(mpl /* ) */);

3159 }

3160 #endif

3161 else

3162 error(mpl, "syntax error in set statement");

3163 }

3164 /* close the domain scope */

3165 if (set->domain != NULL) close_scope(mpl, set->domain);

3166 /* if dimension of set members is still unknown, set it to 1 */

3167 if (set->dimen == 0) set->dimen = 1;

3168 /* the set statement has been completely parsed */

3169 xassert(mpl->token == T_SEMICOLON);

3170 get_token(mpl /* ; */);

3171 return set;

3172 }

3173

3174 /*----------------------------------------------------------------------

3175 -- parameter_statement - parse parameter statement.

3176 --

3177 -- This routine parses parameter statement using the syntax:

3178 --

3179 -- <parameter statement> ::= param <symbolic name> <alias> <domain>

3180 -- <attributes> ;

3181 -- <alias> ::= <empty>

3182 -- <alias> ::= <string literal>

3183 -- <domain> ::= <empty>

3184 -- <domain> ::= <indexing expression>

3185 -- <attributes> ::= <empty>

3186 -- <attributes> ::= <attributes> , integer

3187 -- <attributes> ::= <attributes> , binary

3188 -- <attributes> ::= <attributes> , symbolic

3189 -- <attributes> ::= <attributes> , <rho> <expression 5>

3190 -- <attributes> ::= <attributes> , in <expression 9>

3191 -- <attributes> ::= <attributes> , := <expression 5>

3192 -- <attributes> ::= <attributes> , default <expression 5>

3193 -- <rho> ::= < | <= | = | == | >= | > | <> | !=

3194 --

3195 -- Commae in <attributes> are optional and may be omitted anywhere. */

3196

3197 PARAMETER *parameter_statement(MPL *mpl)

3198 { PARAMETER *par;

3199 int integer_used = 0, binary_used = 0, symbolic_used = 0;

3200 xassert(is_keyword(mpl, "param"));

3201 get_token(mpl /* param */);

3202 /* symbolic name must follow the keyword 'param' */

3203 if (mpl->token == T_NAME)

3204 ;

3205 else if (is_reserved(mpl))

3206 error(mpl, "invalid use of reserved keyword %s", mpl->image);

3207 else

3208 error(mpl, "symbolic name missing where expected");

3209 /* there must be no other object with the same name */

3210 if (avl_find_node(mpl->tree, mpl->image) != NULL)

3211 error(mpl, "%s multiply declared", mpl->image);

3212 /* create model parameter */

3213 par = alloc(PARAMETER);

3214 par->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3215 strcpy(par->name, mpl->image);

3216 par->alias = NULL;

3217 par->dim = 0;

3218 par->domain = NULL;

3219 par->type = A_NUMERIC;

3220 par->cond = NULL;

3221 par->in = NULL;

3222 par->assign = NULL;

3223 par->option = NULL;

3224 par->data = 0;

3225 par->defval = NULL;

3226 par->array = NULL;

3227 get_token(mpl /* <symbolic name> */);

3228 /* parse optional alias */

3229 if (mpl->token == T_STRING)

3230 { par->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3231 strcpy(par->alias, mpl->image);

3232 get_token(mpl /* <string literal> */);

3233 }

3234 /* parse optional indexing expression */

3235 if (mpl->token == T_LBRACE)

3236 { par->domain = indexing_expression(mpl);

3237 par->dim = domain_arity(mpl, par->domain);

3238 }

3239 /* include the parameter name in the symbolic names table */

3240 { AVLNODE *node;

3241 node = avl_insert_node(mpl->tree, par->name);

3242 avl_set_node_type(node, A_PARAMETER);

3243 avl_set_node_link(node, (void *)par);

3244 }

3245 /* parse the list of optional attributes */

3246 for (;;)

3247 { if (mpl->token == T_COMMA)

3248 get_token(mpl /* , */);

3249 else if (mpl->token == T_SEMICOLON)

3250 break;

3251 if (is_keyword(mpl, "integer"))

3252 { if (integer_used)

3253 error(mpl, "at most one integer allowed");

3254 if (par->type == A_SYMBOLIC)

3255 error(mpl, "symbolic parameter cannot be integer");

3256 if (par->type != A_BINARY) par->type = A_INTEGER;

3257 integer_used = 1;

3258 get_token(mpl /* integer */);

3259 }

3260 else if (is_keyword(mpl, "binary"))

3261 bin: { if (binary_used)

3262 error(mpl, "at most one binary allowed");

3263 if (par->type == A_SYMBOLIC)

3264 error(mpl, "symbolic parameter cannot be binary");

3265 par->type = A_BINARY;

3266 binary_used = 1;

3267 get_token(mpl /* binary */);

3268 }

3269 else if (is_keyword(mpl, "logical"))

3270 { if (!mpl->as_binary)

3271 { warning(mpl, "keyword logical understood as binary");

3272 mpl->as_binary = 1;

3273 }

3274 goto bin;

3275 }

3276 else if (is_keyword(mpl, "symbolic"))

3277 { if (symbolic_used)

3278 error(mpl, "at most one symbolic allowed");

3279 if (par->type != A_NUMERIC)

3280 error(mpl, "integer or binary parameter cannot be symbol"

3281 "ic");

3282 /* the parameter may be referenced from expressions given

3283 in the same parameter declaration, so its type must be

3284 completed before parsing that expressions */

3285 if (!(par->cond == NULL && par->in == NULL &&

3286 par->assign == NULL && par->option == NULL))

3287 error(mpl, "keyword symbolic must precede any other para"

3288 "meter attributes");

3289 par->type = A_SYMBOLIC;

3290 symbolic_used = 1;

3291 get_token(mpl /* symbolic */);

3292 }

3293 else if (mpl->token == T_LT || mpl->token == T_LE ||

3294 mpl->token == T_EQ || mpl->token == T_GE ||

3295 mpl->token == T_GT || mpl->token == T_NE)

3296 { /* restricting condition */

3297 CONDITION *cond, *temp;

3298 char opstr[8];

3299 /* create new restricting condition list entry and append

3300 it to the conditions list */

3301 cond = alloc(CONDITION);

3302 switch (mpl->token)

3303 { case T_LT:

3304 cond->rho = O_LT, strcpy(opstr, mpl->image); break;

3305 case T_LE:

3306 cond->rho = O_LE, strcpy(opstr, mpl->image); break;

3307 case T_EQ:

3308 cond->rho = O_EQ, strcpy(opstr, mpl->image); break;

3309 case T_GE:

3310 cond->rho = O_GE, strcpy(opstr, mpl->image); break;

3311 case T_GT:

3312 cond->rho = O_GT, strcpy(opstr, mpl->image); break;

3313 case T_NE:

3314 cond->rho = O_NE, strcpy(opstr, mpl->image); break;

3315 default:

3316 xassert(mpl->token != mpl->token);

3317 }

3318 xassert(strlen(opstr) < sizeof(opstr));

3319 cond->code = NULL;

3320 cond->next = NULL;

3321 if (par->cond == NULL)

3322 par->cond = cond;

3323 else

3324 { for (temp = par->cond; temp->next != NULL; temp =

3325 temp->next);

3326 temp->next = cond;

3327 }

3328 #if 0 /* 13/VIII-2008 */

3329 if (par->type == A_SYMBOLIC &&

3330 !(cond->rho == O_EQ || cond->rho == O_NE))

3331 error(mpl, "inequality restriction not allowed");

3332 #endif

3333 get_token(mpl /* rho */);

3334 /* parse an expression that follows relational operator */

3335 cond->code = expression_5(mpl);

3336 if (!(cond->code->type == A_NUMERIC ||

3337 cond->code->type == A_SYMBOLIC))

3338 error(mpl, "expression following %s has invalid type",

3339 opstr);

3340 xassert(cond->code->dim == 0);

3341 /* convert to the parameter type, if necessary */

3342 if (par->type != A_SYMBOLIC && cond->code->type ==

3343 A_SYMBOLIC)

3344 cond->code = make_unary(mpl, O_CVTNUM, cond->code,

3345 A_NUMERIC, 0);

3346 if (par->type == A_SYMBOLIC && cond->code->type !=

3347 A_SYMBOLIC)

3348 cond->code = make_unary(mpl, O_CVTSYM, cond->code,

3349 A_SYMBOLIC, 0);

3350 }

3351 else if (mpl->token == T_IN || mpl->token == T_WITHIN)

3352 { /* restricting superset */

3353 WITHIN *in, *temp;

3354 if (mpl->token == T_WITHIN && !mpl->as_in)

3355 { warning(mpl, "keyword within understood as in");

3356 mpl->as_in = 1;

3357 }

3358 get_token(mpl /* in */);

3359 /* create new restricting superset list entry and append it

3360 to the in-list */

3361 in = alloc(WITHIN);

3362 in->code = NULL;

3363 in->next = NULL;

3364 if (par->in == NULL)

3365 par->in = in;

3366 else

3367 { for (temp = par->in; temp->next != NULL; temp =

3368 temp->next);

3369 temp->next = in;

3370 }

3371 /* parse an expression that follows 'in' */

3372 in->code = expression_9(mpl);

3373 if (in->code->type != A_ELEMSET)

3374 error(mpl, "expression following in has invalid type");

3375 xassert(in->code->dim > 0);

3376 if (in->code->dim != 1)

3377 error(mpl, "set expression following in must have dimens"

3378 "ion 1 rather than %d", in->code->dim);

3379 }

3380 else if (mpl->token == T_ASSIGN)

3381 { /* assignment expression */

3382 if (!(par->assign == NULL && par->option == NULL))

3383 err: error(mpl, "at most one := or default allowed");

3384 get_token(mpl /* := */);

3385 /* parse an expression that follows ':=' */

3386 par->assign = expression_5(mpl);

3387 /* the expression must be of numeric/symbolic type */

3388 if (!(par->assign->type == A_NUMERIC ||

3389 par->assign->type == A_SYMBOLIC))

3390 error(mpl, "expression following := has invalid type");

3391 xassert(par->assign->dim == 0);

3392 /* convert to the parameter type, if necessary */

3393 if (par->type != A_SYMBOLIC && par->assign->type ==

3394 A_SYMBOLIC)

3395 par->assign = make_unary(mpl, O_CVTNUM, par->assign,

3396 A_NUMERIC, 0);

3397 if (par->type == A_SYMBOLIC && par->assign->type !=

3398 A_SYMBOLIC)

3399 par->assign = make_unary(mpl, O_CVTSYM, par->assign,

3400 A_SYMBOLIC, 0);

3401 }

3402 else if (is_keyword(mpl, "default"))

3403 { /* expression for default value */

3404 if (!(par->assign == NULL && par->option == NULL)) goto err;

3405 get_token(mpl /* default */);

3406 /* parse an expression that follows 'default' */

3407 par->option = expression_5(mpl);

3408 if (!(par->option->type == A_NUMERIC ||

3409 par->option->type == A_SYMBOLIC))

3410 error(mpl, "expression following default has invalid typ"

3411 "e");

3412 xassert(par->option->dim == 0);

3413 /* convert to the parameter type, if necessary */

3414 if (par->type != A_SYMBOLIC && par->option->type ==

3415 A_SYMBOLIC)

3416 par->option = make_unary(mpl, O_CVTNUM, par->option,

3417 A_NUMERIC, 0);

3418 if (par->type == A_SYMBOLIC && par->option->type !=

3419 A_SYMBOLIC)

3420 par->option = make_unary(mpl, O_CVTSYM, par->option,

3421 A_SYMBOLIC, 0);

3422 }

3423 else

3424 error(mpl, "syntax error in parameter statement");

3425 }

3426 /* close the domain scope */

3427 if (par->domain != NULL) close_scope(mpl, par->domain);

3428 /* the parameter statement has been completely parsed */

3429 xassert(mpl->token == T_SEMICOLON);

3430 get_token(mpl /* ; */);

3431 return par;

3432 }

3433

3434 /*----------------------------------------------------------------------

3435 -- variable_statement - parse variable statement.

3436 --

3437 -- This routine parses variable statement using the syntax:

3438 --

3439 -- <variable statement> ::= var <symbolic name> <alias> <domain>

3440 -- <attributes> ;

3441 -- <alias> ::= <empty>

3442 -- <alias> ::= <string literal>

3443 -- <domain> ::= <empty>

3444 -- <domain> ::= <indexing expression>

3445 -- <attributes> ::= <empty>

3446 -- <attributes> ::= <attributes> , integer

3447 -- <attributes> ::= <attributes> , binary

3448 -- <attributes> ::= <attributes> , <rho> <expression 5>

3449 -- <rho> ::= >= | <= | = | ==

3450 --

3451 -- Commae in <attributes> are optional and may be omitted anywhere. */

3452

3453 VARIABLE *variable_statement(MPL *mpl)

3454 { VARIABLE *var;

3455 int integer_used = 0, binary_used = 0;

3456 xassert(is_keyword(mpl, "var"));

3457 if (mpl->flag_s)

3458 error(mpl, "variable statement must precede solve statement");

3459 get_token(mpl /* var */);

3460 /* symbolic name must follow the keyword 'var' */

3461 if (mpl->token == T_NAME)

3462 ;

3463 else if (is_reserved(mpl))

3464 error(mpl, "invalid use of reserved keyword %s", mpl->image);

3465 else

3466 error(mpl, "symbolic name missing where expected");

3467 /* there must be no other object with the same name */

3468 if (avl_find_node(mpl->tree, mpl->image) != NULL)

3469 error(mpl, "%s multiply declared", mpl->image);

3470 /* create model variable */

3471 var = alloc(VARIABLE);

3472 var->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3473 strcpy(var->name, mpl->image);

3474 var->alias = NULL;

3475 var->dim = 0;

3476 var->domain = NULL;

3477 var->type = A_NUMERIC;

3478 var->lbnd = NULL;

3479 var->ubnd = NULL;

3480 var->array = NULL;

3481 get_token(mpl /* <symbolic name> */);

3482 /* parse optional alias */

3483 if (mpl->token == T_STRING)

3484 { var->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3485 strcpy(var->alias, mpl->image);

3486 get_token(mpl /* <string literal> */);

3487 }

3488 /* parse optional indexing expression */

3489 if (mpl->token == T_LBRACE)

3490 { var->domain = indexing_expression(mpl);

3491 var->dim = domain_arity(mpl, var->domain);

3492 }

3493 /* include the variable name in the symbolic names table */

3494 { AVLNODE *node;

3495 node = avl_insert_node(mpl->tree, var->name);

3496 avl_set_node_type(node, A_VARIABLE);

3497 avl_set_node_link(node, (void *)var);

3498 }

3499 /* parse the list of optional attributes */

3500 for (;;)

3501 { if (mpl->token == T_COMMA)

3502 get_token(mpl /* , */);

3503 else if (mpl->token == T_SEMICOLON)

3504 break;

3505 if (is_keyword(mpl, "integer"))

3506 { if (integer_used)

3507 error(mpl, "at most one integer allowed");

3508 if (var->type != A_BINARY) var->type = A_INTEGER;

3509 integer_used = 1;

3510 get_token(mpl /* integer */);

3511 }

3512 else if (is_keyword(mpl, "binary"))

3513 bin: { if (binary_used)

3514 error(mpl, "at most one binary allowed");

3515 var->type = A_BINARY;

3516 binary_used = 1;

3517 get_token(mpl /* binary */);

3518 }

3519 else if (is_keyword(mpl, "logical"))

3520 { if (!mpl->as_binary)

3521 { warning(mpl, "keyword logical understood as binary");

3522 mpl->as_binary = 1;

3523 }

3524 goto bin;

3525 }

3526 else if (is_keyword(mpl, "symbolic"))

3527 error(mpl, "variable cannot be symbolic");

3528 else if (mpl->token == T_GE)

3529 { /* lower bound */

3530 if (var->lbnd != NULL)

3531 { if (var->lbnd == var->ubnd)

3532 error(mpl, "both fixed value and lower bound not allo"

3533 "wed");

3534 else

3535 error(mpl, "at most one lower bound allowed");

3536 }

3537 get_token(mpl /* >= */);

3538 /* parse an expression that specifies the lower bound */

3539 var->lbnd = expression_5(mpl);

3540 if (var->lbnd->type == A_SYMBOLIC)

3541 var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd,

3542 A_NUMERIC, 0);

3543 if (var->lbnd->type != A_NUMERIC)

3544 error(mpl, "expression following >= has invalid type");

3545 xassert(var->lbnd->dim == 0);

3546 }

3547 else if (mpl->token == T_LE)

3548 { /* upper bound */

3549 if (var->ubnd != NULL)

3550 { if (var->ubnd == var->lbnd)

3551 error(mpl, "both fixed value and upper bound not allo"

3552 "wed");

3553 else

3554 error(mpl, "at most one upper bound allowed");

3555 }

3556 get_token(mpl /* <= */);

3557 /* parse an expression that specifies the upper bound */

3558 var->ubnd = expression_5(mpl);

3559 if (var->ubnd->type == A_SYMBOLIC)

3560 var->ubnd = make_unary(mpl, O_CVTNUM, var->ubnd,

3561 A_NUMERIC, 0);

3562 if (var->ubnd->type != A_NUMERIC)

3563 error(mpl, "expression following <= has invalid type");

3564 xassert(var->ubnd->dim == 0);

3565 }

3566 else if (mpl->token == T_EQ)

3567 { /* fixed value */

3568 char opstr[8];

3569 if (!(var->lbnd == NULL && var->ubnd == NULL))

3570 { if (var->lbnd == var->ubnd)

3571 error(mpl, "at most one fixed value allowed");

3572 else if (var->lbnd != NULL)

3573 error(mpl, "both lower bound and fixed value not allo"

3574 "wed");

3575 else

3576 error(mpl, "both upper bound and fixed value not allo"

3577 "wed");

3578 }

3579 strcpy(opstr, mpl->image);

3580 xassert(strlen(opstr) < sizeof(opstr));

3581 get_token(mpl /* = | == */);

3582 /* parse an expression that specifies the fixed value */

3583 var->lbnd = expression_5(mpl);

3584 if (var->lbnd->type == A_SYMBOLIC)

3585 var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd,

3586 A_NUMERIC, 0);

3587 if (var->lbnd->type != A_NUMERIC)

3588 error(mpl, "expression following %s has invalid type",

3589 opstr);

3590 xassert(var->lbnd->dim == 0);

3591 /* indicate that the variable is fixed, not bounded */

3592 var->ubnd = var->lbnd;

3593 }

3594 else if (mpl->token == T_LT || mpl->token == T_GT ||

3595 mpl->token == T_NE)

3596 error(mpl, "strict bound not allowed");

3597 else

3598 error(mpl, "syntax error in variable statement");

3599 }

3600 /* close the domain scope */

3601 if (var->domain != NULL) close_scope(mpl, var->domain);

3602 /* the variable statement has been completely parsed */

3603 xassert(mpl->token == T_SEMICOLON);

3604 get_token(mpl /* ; */);

3605 return var;

3606 }

3607

3608 /*----------------------------------------------------------------------

3609 -- constraint_statement - parse constraint statement.

3610 --

3611 -- This routine parses constraint statement using the syntax:

3612 --

3613 -- <constraint statement> ::= <subject to> <symbolic name> <alias>

3614 -- <domain> : <constraint> ;

3615 -- <subject to> ::= <empty>

3616 -- <subject to> ::= subject to

3617 -- <subject to> ::= subj to

3618 -- <subject to> ::= s.t.

3619 -- <alias> ::= <empty>

3620 -- <alias> ::= <string literal>

3621 -- <domain> ::= <empty>

3622 -- <domain> ::= <indexing expression>

3623 -- <constraint> ::= <formula> , >= <formula>

3624 -- <constraint> ::= <formula> , <= <formula>

3625 -- <constraint> ::= <formula> , = <formula>

3626 -- <constraint> ::= <formula> , <= <formula> , <= <formula>

3627 -- <constraint> ::= <formula> , >= <formula> , >= <formula>

3628 -- <formula> ::= <expression 5>

3629 --

3630 -- Commae in <constraint> are optional and may be omitted anywhere. */

3631

3632 CONSTRAINT *constraint_statement(MPL *mpl)

3633 { CONSTRAINT *con;

3634 CODE *first, *second, *third;

3635 int rho;

3636 char opstr[8];

3637 if (mpl->flag_s)

3638 error(mpl, "constraint statement must precede solve statement")

3639 ;

3640 if (is_keyword(mpl, "subject"))

3641 { get_token(mpl /* subject */);

3642 if (!is_keyword(mpl, "to"))

3643 error(mpl, "keyword subject to incomplete");

3644 get_token(mpl /* to */);

3645 }

3646 else if (is_keyword(mpl, "subj"))

3647 { get_token(mpl /* subj */);

3648 if (!is_keyword(mpl, "to"))

3649 error(mpl, "keyword subj to incomplete");

3650 get_token(mpl /* to */);

3651 }

3652 else if (mpl->token == T_SPTP)

3653 get_token(mpl /* s.t. */);

3654 /* the current token must be symbolic name of constraint */

3655 if (mpl->token == T_NAME)

3656 ;

3657 else if (is_reserved(mpl))

3658 error(mpl, "invalid use of reserved keyword %s", mpl->image);

3659 else

3660 error(mpl, "symbolic name missing where expected");

3661 /* there must be no other object with the same name */

3662 if (avl_find_node(mpl->tree, mpl->image) != NULL)

3663 error(mpl, "%s multiply declared", mpl->image);

3664 /* create model constraint */

3665 con = alloc(CONSTRAINT);

3666 con->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3667 strcpy(con->name, mpl->image);

3668 con->alias = NULL;

3669 con->dim = 0;

3670 con->domain = NULL;

3671 con->type = A_CONSTRAINT;

3672 con->code = NULL;

3673 con->lbnd = NULL;

3674 con->ubnd = NULL;

3675 con->array = NULL;

3676 get_token(mpl /* <symbolic name> */);

3677 /* parse optional alias */

3678 if (mpl->token == T_STRING)

3679 { con->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3680 strcpy(con->alias, mpl->image);

3681 get_token(mpl /* <string literal> */);

3682 }

3683 /* parse optional indexing expression */

3684 if (mpl->token == T_LBRACE)

3685 { con->domain = indexing_expression(mpl);

3686 con->dim = domain_arity(mpl, con->domain);

3687 }

3688 /* include the constraint name in the symbolic names table */

3689 { AVLNODE *node;

3690 node = avl_insert_node(mpl->tree, con->name);

3691 avl_set_node_type(node, A_CONSTRAINT);

3692 avl_set_node_link(node, (void *)con);

3693 }

3694 /* the colon must precede the first expression */

3695 if (mpl->token != T_COLON)

3696 error(mpl, "colon missing where expected");

3697 get_token(mpl /* : */);

3698 /* parse the first expression */

3699 first = expression_5(mpl);

3700 if (first->type == A_SYMBOLIC)

3701 first = make_unary(mpl, O_CVTNUM, first, A_NUMERIC, 0);

3702 if (!(first->type == A_NUMERIC || first->type == A_FORMULA))

3703 error(mpl, "expression following colon has invalid type");

3704 xassert(first->dim == 0);

3705 /* relational operator must follow the first expression */

3706 if (mpl->token == T_COMMA) get_token(mpl /* , */);

3707 switch (mpl->token)

3708 { case T_LE:

3709 case T_GE:

3710 case T_EQ:

3711 break;

3712 case T_LT:

3713 case T_GT:

3714 case T_NE:

3715 error(mpl, "strict inequality not allowed");

3716 case T_SEMICOLON:

3717 error(mpl, "constraint must be equality or inequality");

3718 default:

3719 goto err;

3720 }

3721 rho = mpl->token;

3722 strcpy(opstr, mpl->image);

3723 xassert(strlen(opstr) < sizeof(opstr));

3724 get_token(mpl /* rho */);

3725 /* parse the second expression */

3726 second = expression_5(mpl);

3727 if (second->type == A_SYMBOLIC)

3728 second = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0);

3729 if (!(second->type == A_NUMERIC || second->type == A_FORMULA))

3730 error(mpl, "expression following %s has invalid type", opstr);

3731 xassert(second->dim == 0);

3732 /* check a token that follow the second expression */

3733 if (mpl->token == T_COMMA)

3734 { get_token(mpl /* , */);

3735 if (mpl->token == T_SEMICOLON) goto err;

3736 }

3737 if (mpl->token == T_LT || mpl->token == T_LE ||

3738 mpl->token == T_EQ || mpl->token == T_GE ||

3739 mpl->token == T_GT || mpl->token == T_NE)

3740 { /* it is another relational operator, therefore the constraint

3741 is double inequality */

3742 if (rho == T_EQ || mpl->token != rho)

3743 error(mpl, "double inequality must be ... <= ... <= ... or "

3744 "... >= ... >= ...");

3745 /* the first expression cannot be linear form */

3746 if (first->type == A_FORMULA)

3747 error(mpl, "leftmost expression in double inequality cannot"

3748 " be linear form");

3749 get_token(mpl /* rho */);

3750 /* parse the third expression */

3751 third = expression_5(mpl);

3752 if (third->type == A_SYMBOLIC)

3753 third = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0);

3754 if (!(third->type == A_NUMERIC || third->type == A_FORMULA))

3755 error(mpl, "rightmost expression in double inequality const"

3756 "raint has invalid type");

3757 xassert(third->dim == 0);

3758 /* the third expression also cannot be linear form */

3759 if (third->type == A_FORMULA)

3760 error(mpl, "rightmost expression in double inequality canno"

3761 "t be linear form");

3762 }

3763 else

3764 { /* the constraint is equality or single inequality */

3765 third = NULL;

3766 }

3767 /* close the domain scope */

3768 if (con->domain != NULL) close_scope(mpl, con->domain);

3769 /* convert all expressions to linear form, if necessary */

3770 if (first->type != A_FORMULA)

3771 first = make_unary(mpl, O_CVTLFM, first, A_FORMULA, 0);

3772 if (second->type != A_FORMULA)

3773 second = make_unary(mpl, O_CVTLFM, second, A_FORMULA, 0);

3774 if (third != NULL)

3775 third = make_unary(mpl, O_CVTLFM, third, A_FORMULA, 0);

3776 /* arrange expressions in the constraint */

3777 if (third == NULL)

3778 { /* the constraint is equality or single inequality */

3779 switch (rho)

3780 { case T_LE:

3781 /* first <= second */

3782 con->code = first;

3783 con->lbnd = NULL;

3784 con->ubnd = second;

3785 break;

3786 case T_GE:

3787 /* first >= second */

3788 con->code = first;

3789 con->lbnd = second;

3790 con->ubnd = NULL;

3791 break;

3792 case T_EQ:

3793 /* first = second */

3794 con->code = first;

3795 con->lbnd = second;

3796 con->ubnd = second;

3797 break;

3798 default:

3799 xassert(rho != rho);

3800 }

3801 }

3802 else

3803 { /* the constraint is double inequality */

3804 switch (rho)

3805 { case T_LE:

3806 /* first <= second <= third */

3807 con->code = second;

3808 con->lbnd = first;

3809 con->ubnd = third;

3810 break;

3811 case T_GE:

3812 /* first >= second >= third */

3813 con->code = second;

3814 con->lbnd = third;

3815 con->ubnd = first;

3816 break;

3817 default:

3818 xassert(rho != rho);

3819 }

3820 }

3821 /* the constraint statement has been completely parsed */

3822 if (mpl->token != T_SEMICOLON)

3823 err: error(mpl, "syntax error in constraint statement");

3824 get_token(mpl /* ; */);

3825 return con;

3826 }

3827

3828 /*----------------------------------------------------------------------

3829 -- objective_statement - parse objective statement.

3830 --

3831 -- This routine parses objective statement using the syntax:

3832 --

3833 -- <objective statement> ::= <verb> <symbolic name> <alias> <domain> :

3834 -- <formula> ;

3835 -- <verb> ::= minimize

3836 -- <verb> ::= maximize

3837 -- <alias> ::= <empty>

3838 -- <alias> ::= <string literal>

3839 -- <domain> ::= <empty>

3840 -- <domain> ::= <indexing expression>

3841 -- <formula> ::= <expression 5> */

3842

3843 CONSTRAINT *objective_statement(MPL *mpl)

3844 { CONSTRAINT *obj;

3845 int type;

3846 if (is_keyword(mpl, "minimize"))

3847 type = A_MINIMIZE;

3848 else if (is_keyword(mpl, "maximize"))

3849 type = A_MAXIMIZE;

3850 else

3851 xassert(mpl != mpl);

3852 if (mpl->flag_s)

3853 error(mpl, "objective statement must precede solve statement");

3854 get_token(mpl /* minimize | maximize */);

3855 /* symbolic name must follow the verb 'minimize' or 'maximize' */

3856 if (mpl->token == T_NAME)

3857 ;

3858 else if (is_reserved(mpl))

3859 error(mpl, "invalid use of reserved keyword %s", mpl->image);

3860 else

3861 error(mpl, "symbolic name missing where expected");

3862 /* there must be no other object with the same name */

3863 if (avl_find_node(mpl->tree, mpl->image) != NULL)

3864 error(mpl, "%s multiply declared", mpl->image);

3865 /* create model objective */

3866 obj = alloc(CONSTRAINT);

3867 obj->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3868 strcpy(obj->name, mpl->image);

3869 obj->alias = NULL;

3870 obj->dim = 0;

3871 obj->domain = NULL;

3872 obj->type = type;

3873 obj->code = NULL;

3874 obj->lbnd = NULL;

3875 obj->ubnd = NULL;

3876 obj->array = NULL;

3877 get_token(mpl /* <symbolic name> */);

3878 /* parse optional alias */

3879 if (mpl->token == T_STRING)

3880 { obj->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3881 strcpy(obj->alias, mpl->image);

3882 get_token(mpl /* <string literal> */);

3883 }

3884 /* parse optional indexing expression */

3885 if (mpl->token == T_LBRACE)

3886 { obj->domain = indexing_expression(mpl);

3887 obj->dim = domain_arity(mpl, obj->domain);

3888 }

3889 /* include the constraint name in the symbolic names table */

3890 { AVLNODE *node;

3891 node = avl_insert_node(mpl->tree, obj->name);

3892 avl_set_node_type(node, A_CONSTRAINT);

3893 avl_set_node_link(node, (void *)obj);

3894 }

3895 /* the colon must precede the objective expression */

3896 if (mpl->token != T_COLON)

3897 error(mpl, "colon missing where expected");

3898 get_token(mpl /* : */);

3899 /* parse the objective expression */

3900 obj->code = expression_5(mpl);

3901 if (obj->code->type == A_SYMBOLIC)

3902 obj->code = make_unary(mpl, O_CVTNUM, obj->code, A_NUMERIC, 0);

3903 if (obj->code->type == A_NUMERIC)

3904 obj->code = make_unary(mpl, O_CVTLFM, obj->code, A_FORMULA, 0);

3905 if (obj->code->type != A_FORMULA)

3906 error(mpl, "expression following colon has invalid type");

3907 xassert(obj->code->dim == 0);

3908 /* close the domain scope */

3909 if (obj->domain != NULL) close_scope(mpl, obj->domain);

3910 /* the objective statement has been completely parsed */

3911 if (mpl->token != T_SEMICOLON)

3912 error(mpl, "syntax error in objective statement");

3913 get_token(mpl /* ; */);

3914 return obj;

3915 }

3916

3917 #if 1 /* 11/II-2008 */

3918 /***********************************************************************

3919 * table_statement - parse table statement

3920 *

3921 * This routine parses table statement using the syntax:

3922 *

3923 * <table statement> ::= <input table statement>

3924 * <table statement> ::= <output table statement>

3925 *

3926 * <input table statement> ::=

3927 * table <table name> <alias> IN <argument list> :

3928 * <input set> [ <field list> ] , <input list> ;

3929 * <alias> ::= <empty>

3930 * <alias> ::= <string literal>

3931 * <argument list> ::= <expression 5>

3932 * <argument list> ::= <argument list> <expression 5>

3933 * <argument list> ::= <argument list> , <expression 5>

3934 * <input set> ::= <empty>

3935 * <input set> ::= <set name> <-

3936 * <field list> ::= <field name>

3937 * <field list> ::= <field list> , <field name>

3938 * <input list> ::= <input item>

3939 * <input list> ::= <input list> , <input item>

3940 * <input item> ::= <parameter name>

3941 * <input item> ::= <parameter name> ~ <field name>

3942 *

3943 * <output table statement> ::=

3944 * table <table name> <alias> <domain> OUT <argument list> :

3945 * <output list> ;

3946 * <domain> ::= <indexing expression>

3947 * <output list> ::= <output item>

3948 * <output list> ::= <output list> , <output item>

3949 * <output item> ::= <expression 5>

3950 * <output item> ::= <expression 5> ~ <field name> */

3951

3952 TABLE *table_statement(MPL *mpl)

3953 { TABLE *tab;

3954 TABARG *last_arg, *arg;

3955 TABFLD *last_fld, *fld;

3956 TABIN *last_in, *in;

3957 TABOUT *last_out, *out;

3958 AVLNODE *node;

3959 int nflds;

3960 char name[MAX_LENGTH+1];

3961 xassert(is_keyword(mpl, "table"));

3962 get_token(mpl /* solve */);

3963 /* symbolic name must follow the keyword table */

3964 if (mpl->token == T_NAME)

3965 ;

3966 else if (is_reserved(mpl))

3967 error(mpl, "invalid use of reserved keyword %s", mpl->image);

3968 else

3969 error(mpl, "symbolic name missing where expected");

3970 /* there must be no other object with the same name */

3971 if (avl_find_node(mpl->tree, mpl->image) != NULL)

3972 error(mpl, "%s multiply declared", mpl->image);

3973 /* create data table */

3974 tab = alloc(TABLE);

3975 tab->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3976 strcpy(tab->name, mpl->image);

3977 get_token(mpl /* <symbolic name> */);

3978 /* parse optional alias */

3979 if (mpl->token == T_STRING)

3980 { tab->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

3981 strcpy(tab->alias, mpl->image);

3982 get_token(mpl /* <string literal> */);

3983 }

3984 else

3985 tab->alias = NULL;

3986 /* parse optional indexing expression */

3987 if (mpl->token == T_LBRACE)

3988 { /* this is output table */

3989 tab->type = A_OUTPUT;

3990 tab->u.out.domain = indexing_expression(mpl);

3991 if (!is_keyword(mpl, "OUT"))

3992 error(mpl, "keyword OUT missing where expected");

3993 get_token(mpl /* OUT */);

3994 }

3995 else

3996 { /* this is input table */

3997 tab->type = A_INPUT;

3998 if (!is_keyword(mpl, "IN"))

3999 error(mpl, "keyword IN missing where expected");

4000 get_token(mpl /* IN */);

4001 }

4002 /* parse argument list */

4003 tab->arg = last_arg = NULL;

4004 for (;;)

4005 { /* create argument list entry */

4006 arg = alloc(TABARG);

4007 /* parse argument expression */

4008 if (mpl->token == T_COMMA || mpl->token == T_COLON ||

4009 mpl->token == T_SEMICOLON)

4010 error(mpl, "argument expression missing where expected");

4011 arg->code = expression_5(mpl);

4012 /* convert the result to symbolic type, if necessary */

4013 if (arg->code->type == A_NUMERIC)

4014 arg->code =

4015 make_unary(mpl, O_CVTSYM, arg->code, A_SYMBOLIC, 0);

4016 /* check that now the result is of symbolic type */

4017 if (arg->code->type != A_SYMBOLIC)

4018 error(mpl, "argument expression has invalid type");

4019 /* add the entry to the end of the list */

4020 arg->next = NULL;

4021 if (last_arg == NULL)

4022 tab->arg = arg;

4023 else

4024 last_arg->next = arg;

4025 last_arg = arg;

4026 /* argument expression has been parsed */

4027 if (mpl->token == T_COMMA)

4028 get_token(mpl /* , */);

4029 else if (mpl->token == T_COLON || mpl->token == T_SEMICOLON)

4030 break;

4031 }

4032 xassert(tab->arg != NULL);

4033 /* argument list must end with colon */

4034 if (mpl->token == T_COLON)

4035 get_token(mpl /* : */);

4036 else

4037 error(mpl, "colon missing where expected");

4038 /* parse specific part of the table statement */

4039 switch (tab->type)

4040 { case A_INPUT: goto input_table;

4041 case A_OUTPUT: goto output_table;

4042 default: xassert(tab != tab);

4043 }

4044 input_table:

4045 /* parse optional set name */

4046 if (mpl->token == T_NAME)

4047 { node = avl_find_node(mpl->tree, mpl->image);

4048 if (node == NULL)

4049 error(mpl, "%s not defined", mpl->image);

4050 if (avl_get_node_type(node) != A_SET)

4051 error(mpl, "%s not a set", mpl->image);

4052 tab->u.in.set = (SET *)avl_get_node_link(node);

4053 if (tab->u.in.set->assign != NULL)

4054 error(mpl, "%s needs no data", mpl->image);

4055 if (tab->u.in.set->dim != 0)

4056 error(mpl, "%s must be a simple set", mpl->image);

4057 get_token(mpl /* <symbolic name> */);

4058 if (mpl->token == T_INPUT)

4059 get_token(mpl /* <- */);

4060 else

4061 error(mpl, "delimiter <- missing where expected");

4062 }

4063 else if (is_reserved(mpl))

4064 error(mpl, "invalid use of reserved keyword %s", mpl->image);

4065 else

4066 tab->u.in.set = NULL;

4067 /* parse field list */

4068 tab->u.in.fld = last_fld = NULL;

4069 nflds = 0;

4070 if (mpl->token == T_LBRACKET)

4071 get_token(mpl /* [ */);

4072 else

4073 error(mpl, "field list missing where expected");

4074 for (;;)

4075 { /* create field list entry */

4076 fld = alloc(TABFLD);

4077 /* parse field name */

4078 if (mpl->token == T_NAME)

4079 ;

4080 else if (is_reserved(mpl))

4081 error(mpl,

4082 "invalid use of reserved keyword %s", mpl->image);

4083 else

4084 error(mpl, "field name missing where expected");

4085 fld->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

4086 strcpy(fld->name, mpl->image);

4087 get_token(mpl /* <symbolic name> */);

4088 /* add the entry to the end of the list */

4089 fld->next = NULL;

4090 if (last_fld == NULL)

4091 tab->u.in.fld = fld;

4092 else

4093 last_fld->next = fld;

4094 last_fld = fld;

4095 nflds++;

4096 /* field name has been parsed */

4097 if (mpl->token == T_COMMA)

4098 get_token(mpl /* , */);

4099 else if (mpl->token == T_RBRACKET)

4100 break;

4101 else

4102 error(mpl, "syntax error in field list");

4103 }

4104 /* check that the set dimen is equal to the number of fields */

4105 if (tab->u.in.set != NULL && tab->u.in.set->dimen != nflds)

4106 error(mpl, "there must be %d field%s rather than %d",

4107 tab->u.in.set->dimen, tab->u.in.set->dimen == 1 ? "" : "s",

4108 nflds);

4109 get_token(mpl /* ] */);

4110 /* parse optional input list */

4111 tab->u.in.list = last_in = NULL;

4112 while (mpl->token == T_COMMA)

4113 { get_token(mpl /* , */);

4114 /* create input list entry */

4115 in = alloc(TABIN);

4116 /* parse parameter name */

4117 if (mpl->token == T_NAME)

4118 ;

4119 else if (is_reserved(mpl))

4120 error(mpl,

4121 "invalid use of reserved keyword %s", mpl->image);

4122 else

4123 error(mpl, "parameter name missing where expected");

4124 node = avl_find_node(mpl->tree, mpl->image);

4125 if (node == NULL)

4126 error(mpl, "%s not defined", mpl->image);

4127 if (avl_get_node_type(node) != A_PARAMETER)

4128 error(mpl, "%s not a parameter", mpl->image);

4129 in->par = (PARAMETER *)avl_get_node_link(node);

4130 if (in->par->dim != nflds)

4131 error(mpl, "%s must have %d subscript%s rather than %d",

4132 mpl->image, nflds, nflds == 1 ? "" : "s", in->par->dim);

4133 if (in->par->assign != NULL)

4134 error(mpl, "%s needs no data", mpl->image);

4135 get_token(mpl /* <symbolic name> */);

4136 /* parse optional field name */

4137 if (mpl->token == T_TILDE)

4138 { get_token(mpl /* ~ */);

4139 /* parse field name */

4140 if (mpl->token == T_NAME)

4141 ;

4142 else if (is_reserved(mpl))

4143 error(mpl,

4144 "invalid use of reserved keyword %s", mpl->image);

4145 else

4146 error(mpl, "field name missing where expected");

4147 xassert(strlen(mpl->image) < sizeof(name));

4148 strcpy(name, mpl->image);

4149 get_token(mpl /* <symbolic name> */);

4150 }

4151 else

4152 { /* field name is the same as the parameter name */

4153 xassert(strlen(in->par->name) < sizeof(name));

4154 strcpy(name, in->par->name);

4155 }

4156 /* assign field name */

4157 in->name = dmp_get_atomv(mpl->pool, strlen(name)+1);

4158 strcpy(in->name, name);

4159 /* add the entry to the end of the list */

4160 in->next = NULL;

4161 if (last_in == NULL)

4162 tab->u.in.list = in;

4163 else

4164 last_in->next = in;

4165 last_in = in;

4166 }

4167 goto end_of_table;

4168 output_table:

4169 /* parse output list */

4170 tab->u.out.list = last_out = NULL;

4171 for (;;)

4172 { /* create output list entry */

4173 out = alloc(TABOUT);

4174 /* parse expression */

4175 if (mpl->token == T_COMMA || mpl->token == T_SEMICOLON)

4176 error(mpl, "expression missing where expected");

4177 if (mpl->token == T_NAME)

4178 { xassert(strlen(mpl->image) < sizeof(name));

4179 strcpy(name, mpl->image);

4180 }

4181 else

4182 name[0] = '\0';

4183 out->code = expression_5(mpl);

4184 /* parse optional field name */

4185 if (mpl->token == T_TILDE)

4186 { get_token(mpl /* ~ */);

4187 /* parse field name */

4188 if (mpl->token == T_NAME)

4189 ;

4190 else if (is_reserved(mpl))

4191 error(mpl,

4192 "invalid use of reserved keyword %s", mpl->image);

4193 else

4194 error(mpl, "field name missing where expected");

4195 xassert(strlen(mpl->image) < sizeof(name));

4196 strcpy(name, mpl->image);

4197 get_token(mpl /* <symbolic name> */);

4198 }

4199 /* assign field name */

4200 if (name[0] == '\0')

4201 error(mpl, "field name required");

4202 out->name = dmp_get_atomv(mpl->pool, strlen(name)+1);

4203 strcpy(out->name, name);

4204 /* add the entry to the end of the list */

4205 out->next = NULL;

4206 if (last_out == NULL)

4207 tab->u.out.list = out;

4208 else

4209 last_out->next = out;

4210 last_out = out;

4211 /* output item has been parsed */

4212 if (mpl->token == T_COMMA)

4213 get_token(mpl /* , */);

4214 else if (mpl->token == T_SEMICOLON)

4215 break;

4216 else

4217 error(mpl, "syntax error in output list");

4218 }

4219 /* close the domain scope */

4220 close_scope(mpl,tab->u.out.domain);

4221 end_of_table:

4222 /* the table statement must end with semicolon */

4223 if (mpl->token != T_SEMICOLON)

4224 error(mpl, "syntax error in table statement");

4225 get_token(mpl /* ; */);

4226 return tab;

4227 }

4228 #endif

4229

4230 /*----------------------------------------------------------------------

4231 -- solve_statement - parse solve statement.

4232 --

4233 -- This routine parses solve statement using the syntax:

4234 --

4235 -- <solve statement> ::= solve ;

4236 --

4237 -- The solve statement can be used at most once. */

4238

4239 void *solve_statement(MPL *mpl)

4240 { xassert(is_keyword(mpl, "solve"));

4241 if (mpl->flag_s)

4242 error(mpl, "at most one solve statement allowed");

4243 mpl->flag_s = 1;

4244 get_token(mpl /* solve */);

4245 /* semicolon must follow solve statement */

4246 if (mpl->token != T_SEMICOLON)

4247 error(mpl, "syntax error in solve statement");

4248 get_token(mpl /* ; */);

4249 return NULL;

4250 }

4251

4252 /*----------------------------------------------------------------------

4253 -- check_statement - parse check statement.

4254 --

4255 -- This routine parses check statement using the syntax:

4256 --

4257 -- <check statement> ::= check <domain> : <expression 13> ;

4258 -- <domain> ::= <empty>

4259 -- <domain> ::= <indexing expression>

4260 --

4261 -- If <domain> is omitted, colon following it may also be omitted. */

4262

4263 CHECK *check_statement(MPL *mpl)

4264 { CHECK *chk;

4265 xassert(is_keyword(mpl, "check"));

4266 /* create check descriptor */

4267 chk = alloc(CHECK);

4268 chk->domain = NULL;

4269 chk->code = NULL;

4270 get_token(mpl /* check */);

4271 /* parse optional indexing expression */

4272 if (mpl->token == T_LBRACE)

4273 { chk->domain = indexing_expression(mpl);

4274 #if 0

4275 if (mpl->token != T_COLON)

4276 error(mpl, "colon missing where expected");

4277 #endif

4278 }

4279 /* skip optional colon */

4280 if (mpl->token == T_COLON) get_token(mpl /* : */);

4281 /* parse logical expression */

4282 chk->code = expression_13(mpl);

4283 if (chk->code->type != A_LOGICAL)

4284 error(mpl, "expression has invalid type");

4285 xassert(chk->code->dim == 0);

4286 /* close the domain scope */

4287 if (chk->domain != NULL) close_scope(mpl, chk->domain);

4288 /* the check statement has been completely parsed */

4289 if (mpl->token != T_SEMICOLON)

4290 error(mpl, "syntax error in check statement");

4291 get_token(mpl /* ; */);

4292 return chk;

4293 }

4294

4295 #if 1 /* 15/V-2010 */

4296 /*----------------------------------------------------------------------

4297 -- display_statement - parse display statement.

4298 --

4299 -- This routine parses display statement using the syntax:

4300 --

4301 -- <display statement> ::= display <domain> : <display list> ;

4302 -- <display statement> ::= display <domain> <display list> ;

4303 -- <domain> ::= <empty>

4304 -- <domain> ::= <indexing expression>

4305 -- <display list> ::= <display entry>

4306 -- <display list> ::= <display list> , <display entry>

4307 -- <display entry> ::= <dummy index>

4308 -- <display entry> ::= <set name>

4309 -- <display entry> ::= <set name> [ <subscript list> ]

4310 -- <display entry> ::= <parameter name>

4311 -- <display entry> ::= <parameter name> [ <subscript list> ]

4312 -- <display entry> ::= <variable name>

4313 -- <display entry> ::= <variable name> [ <subscript list> ]

4314 -- <display entry> ::= <constraint name>

4315 -- <display entry> ::= <constraint name> [ <subscript list> ]

4316 -- <display entry> ::= <expression 13> */

4317

4318 DISPLAY *display_statement(MPL *mpl)

4319 { DISPLAY *dpy;

4320 DISPLAY1 *entry, *last_entry;

4321 xassert(is_keyword(mpl, "display"));

4322 /* create display descriptor */

4323 dpy = alloc(DISPLAY);

4324 dpy->domain = NULL;

4325 dpy->list = last_entry = NULL;

4326 get_token(mpl /* display */);

4327 /* parse optional indexing expression */

4328 if (mpl->token == T_LBRACE)

4329 dpy->domain = indexing_expression(mpl);

4330 /* skip optional colon */

4331 if (mpl->token == T_COLON) get_token(mpl /* : */);

4332 /* parse display list */

4333 for (;;)

4334 { /* create new display entry */

4335 entry = alloc(DISPLAY1);

4336 entry->type = 0;

4337 entry->next = NULL;

4338 /* and append it to the display list */

4339 if (dpy->list == NULL)

4340 dpy->list = entry;

4341 else

4342 last_entry->next = entry;

4343 last_entry = entry;

4344 /* parse display entry */

4345 if (mpl->token == T_NAME)

4346 { AVLNODE *node;

4347 int next_token;

4348 get_token(mpl /* <symbolic name> */);

4349 next_token = mpl->token;

4350 unget_token(mpl);

4351 if (!(next_token == T_COMMA || next_token == T_SEMICOLON))

4352 { /* symbolic name begins expression */

4353 goto expr;

4354 }

4355 /* display entry is dummy index or model object */

4356 node = avl_find_node(mpl->tree, mpl->image);

4357 if (node == NULL)

4358 error(mpl, "%s not defined", mpl->image);

4359 entry->type = avl_get_node_type(node);

4360 switch (avl_get_node_type(node))

4361 { case A_INDEX:

4362 entry->u.slot =

4363 (DOMAIN_SLOT *)avl_get_node_link(node);

4364 break;

4365 case A_SET:

4366 entry->u.set = (SET *)avl_get_node_link(node);

4367 break;

4368 case A_PARAMETER:

4369 entry->u.par = (PARAMETER *)avl_get_node_link(node);

4370 break;

4371 case A_VARIABLE:

4372 entry->u.var = (VARIABLE *)avl_get_node_link(node);

4373 if (!mpl->flag_s)

4374 error(mpl, "invalid reference to variable %s above"

4375 " solve statement", entry->u.var->name);

4376 break;

4377 case A_CONSTRAINT:

4378 entry->u.con = (CONSTRAINT *)avl_get_node_link(node);

4379 if (!mpl->flag_s)

4380 error(mpl, "invalid reference to %s %s above solve"

4381 " statement",

4382 entry->u.con->type == A_CONSTRAINT ?

4383 "constraint" : "objective", entry->u.con->name);

4384 break;

4385 default:

4386 xassert(node != node);

4387 }

4388 get_token(mpl /* <symbolic name> */);

4389 }

4390 else

4391 expr: { /* display entry is expression */

4392 entry->type = A_EXPRESSION;

4393 entry->u.code = expression_13(mpl);

4394 }

4395 /* check a token that follows the entry parsed */

4396 if (mpl->token == T_COMMA)

4397 get_token(mpl /* , */);

4398 else

4399 break;

4400 }

4401 /* close the domain scope */

4402 if (dpy->domain != NULL) close_scope(mpl, dpy->domain);

4403 /* the display statement has been completely parsed */

4404 if (mpl->token != T_SEMICOLON)

4405 error(mpl, "syntax error in display statement");

4406 get_token(mpl /* ; */);

4407 return dpy;

4408 }

4409 #endif

4410

4411 /*----------------------------------------------------------------------

4412 -- printf_statement - parse printf statement.

4413 --

4414 -- This routine parses print statement using the syntax:

4415 --

4416 -- <printf statement> ::= <printf clause> ;

4417 -- <printf statement> ::= <printf clause> > <file name> ;

4418 -- <printf statement> ::= <printf clause> >> <file name> ;

4419 -- <printf clause> ::= printf <domain> : <format> <printf list>

4420 -- <printf clause> ::= printf <domain> <format> <printf list>

4421 -- <domain> ::= <empty>

4422 -- <domain> ::= <indexing expression>

4423 -- <format> ::= <expression 5>

4424 -- <printf list> ::= <empty>

4425 -- <printf list> ::= <printf list> , <printf entry>

4426 -- <printf entry> ::= <expression 9>

4427 -- <file name> ::= <expression 5> */

4428

4429 PRINTF *printf_statement(MPL *mpl)

4430 { PRINTF *prt;

4431 PRINTF1 *entry, *last_entry;

4432 xassert(is_keyword(mpl, "printf"));

4433 /* create printf descriptor */

4434 prt = alloc(PRINTF);

4435 prt->domain = NULL;

4436 prt->fmt = NULL;

4437 prt->list = last_entry = NULL;

4438 get_token(mpl /* printf */);

4439 /* parse optional indexing expression */

4440 if (mpl->token == T_LBRACE)

4441 { prt->domain = indexing_expression(mpl);

4442 #if 0

4443 if (mpl->token != T_COLON)

4444 error(mpl, "colon missing where expected");

4445 #endif

4446 }

4447 /* skip optional colon */

4448 if (mpl->token == T_COLON) get_token(mpl /* : */);

4449 /* parse expression for format string */

4450 prt->fmt = expression_5(mpl);

4451 /* convert it to symbolic type, if necessary */

4452 if (prt->fmt->type == A_NUMERIC)

4453 prt->fmt = make_unary(mpl, O_CVTSYM, prt->fmt, A_SYMBOLIC, 0);

4454 /* check that now the expression is of symbolic type */

4455 if (prt->fmt->type != A_SYMBOLIC)

4456 error(mpl, "format expression has invalid type");

4457 /* parse printf list */

4458 while (mpl->token == T_COMMA)

4459 { get_token(mpl /* , */);

4460 /* create new printf entry */

4461 entry = alloc(PRINTF1);

4462 entry->code = NULL;

4463 entry->next = NULL;

4464 /* and append it to the printf list */

4465 if (prt->list == NULL)

4466 prt->list = entry;

4467 else

4468 last_entry->next = entry;

4469 last_entry = entry;

4470 /* parse printf entry */

4471 entry->code = expression_9(mpl);

4472 if (!(entry->code->type == A_NUMERIC ||

4473 entry->code->type == A_SYMBOLIC ||

4474 entry->code->type == A_LOGICAL))

4475 error(mpl, "only numeric, symbolic, or logical expression a"

4476 "llowed");

4477 }

4478 /* close the domain scope */

4479 if (prt->domain != NULL) close_scope(mpl, prt->domain);

4480 #if 1 /* 14/VII-2006 */

4481 /* parse optional redirection */

4482 prt->fname = NULL, prt->app = 0;

4483 if (mpl->token == T_GT || mpl->token == T_APPEND)

4484 { prt->app = (mpl->token == T_APPEND);

4485 get_token(mpl /* > or >> */);

4486 /* parse expression for file name string */

4487 prt->fname = expression_5(mpl);

4488 /* convert it to symbolic type, if necessary */

4489 if (prt->fname->type == A_NUMERIC)

4490 prt->fname = make_unary(mpl, O_CVTSYM, prt->fname,

4491 A_SYMBOLIC, 0);

4492 /* check that now the expression is of symbolic type */

4493 if (prt->fname->type != A_SYMBOLIC)

4494 error(mpl, "file name expression has invalid type");

4495 }

4496 #endif

4497 /* the printf statement has been completely parsed */

4498 if (mpl->token != T_SEMICOLON)

4499 error(mpl, "syntax error in printf statement");

4500 get_token(mpl /* ; */);

4501 return prt;

4502 }

4503

4504 /*----------------------------------------------------------------------

4505 -- for_statement - parse for statement.

4506 --

4507 -- This routine parses for statement using the syntax:

4508 --

4509 -- <for statement> ::= for <domain> <statement>

4510 -- <for statement> ::= for <domain> { <statement list> }

4511 -- <domain> ::= <indexing expression>

4512 -- <statement list> ::= <empty>

4513 -- <statement list> ::= <statement list> <statement>

4514 -- <statement> ::= <check statement>

4515 -- <statement> ::= <display statement>

4516 -- <statement> ::= <printf statement>

4517 -- <statement> ::= <for statement> */

4518

4519 FOR *for_statement(MPL *mpl)

4520 { FOR *fur;

4521 STATEMENT *stmt, *last_stmt;

4522 xassert(is_keyword(mpl, "for"));

4523 /* create for descriptor */

4524 fur = alloc(FOR);

4525 fur->domain = NULL;

4526 fur->list = last_stmt = NULL;

4527 get_token(mpl /* for */);

4528 /* parse indexing expression */

4529 if (mpl->token != T_LBRACE)

4530 error(mpl, "indexing expression missing where expected");

4531 fur->domain = indexing_expression(mpl);

4532 /* skip optional colon */

4533 if (mpl->token == T_COLON) get_token(mpl /* : */);

4534 /* parse for statement body */

4535 if (mpl->token != T_LBRACE)

4536 { /* parse simple statement */

4537 fur->list = simple_statement(mpl, 1);

4538 }

4539 else

4540 { /* parse compound statement */

4541 get_token(mpl /* { */);

4542 while (mpl->token != T_RBRACE)

4543 { /* parse statement */

4544 stmt = simple_statement(mpl, 1);

4545 /* and append it to the end of the statement list */

4546 if (last_stmt == NULL)

4547 fur->list = stmt;

4548 else

4549 last_stmt->next = stmt;

4550 last_stmt = stmt;

4551 }

4552 get_token(mpl /* } */);

4553 }

4554 /* close the domain scope */

4555 xassert(fur->domain != NULL);

4556 close_scope(mpl, fur->domain);

4557 /* the for statement has been completely parsed */

4558 return fur;

4559 }

4560

4561 /*----------------------------------------------------------------------

4562 -- end_statement - parse end statement.

4563 --

4564 -- This routine parses end statement using the syntax:

4565 --

4566 -- <end statement> ::= end ; <eof> */

4567

4568 void end_statement(MPL *mpl)

4569 { if (!mpl->flag_d && is_keyword(mpl, "end") ||

4570 mpl->flag_d && is_literal(mpl, "end"))

4571 { get_token(mpl /* end */);

4572 if (mpl->token == T_SEMICOLON)

4573 get_token(mpl /* ; */);

4574 else

4575 warning(mpl, "no semicolon following end statement; missing"

4576 " semicolon inserted");

4577 }

4578 else

4579 warning(mpl, "unexpected end of file; missing end statement in"

4580 "serted");

4581 if (mpl->token != T_EOF)

4582 warning(mpl, "some text detected beyond end statement; text ig"

4583 "nored");

4584 return;

4585 }

4586

4587 /*----------------------------------------------------------------------

4588 -- simple_statement - parse simple statement.

4589 --

4590 -- This routine parses simple statement using the syntax:

4591 --

4592 -- <statement> ::= <set statement>

4593 -- <statement> ::= <parameter statement>

4594 -- <statement> ::= <variable statement>

4595 -- <statement> ::= <constraint statement>

4596 -- <statement> ::= <objective statement>

4597 -- <statement> ::= <solve statement>

4598 -- <statement> ::= <check statement>

4599 -- <statement> ::= <display statement>

4600 -- <statement> ::= <printf statement>

4601 -- <statement> ::= <for statement>

4602 --

4603 -- If the flag spec is set, some statements cannot be used. */

4604

4605 STATEMENT *simple_statement(MPL *mpl, int spec)

4606 { STATEMENT *stmt;

4607 stmt = alloc(STATEMENT);

4608 stmt->line = mpl->line;

4609 stmt->next = NULL;

4610 if (is_keyword(mpl, "set"))

4611 { if (spec)

4612 error(mpl, "set statement not allowed here");

4613 stmt->type = A_SET;

4614 stmt->u.set = set_statement(mpl);

4615 }

4616 else if (is_keyword(mpl, "param"))

4617 { if (spec)

4618 error(mpl, "parameter statement not allowed here");

4619 stmt->type = A_PARAMETER;

4620 stmt->u.par = parameter_statement(mpl);

4621 }

4622 else if (is_keyword(mpl, "var"))

4623 { if (spec)

4624 error(mpl, "variable statement not allowed here");

4625 stmt->type = A_VARIABLE;

4626 stmt->u.var = variable_statement(mpl);

4627 }

4628 else if (is_keyword(mpl, "subject") ||

4629 is_keyword(mpl, "subj") ||

4630 mpl->token == T_SPTP)

4631 { if (spec)

4632 error(mpl, "constraint statement not allowed here");

4633 stmt->type = A_CONSTRAINT;

4634 stmt->u.con = constraint_statement(mpl);

4635 }

4636 else if (is_keyword(mpl, "minimize") ||

4637 is_keyword(mpl, "maximize"))

4638 { if (spec)

4639 error(mpl, "objective statement not allowed here");

4640 stmt->type = A_CONSTRAINT;

4641 stmt->u.con = objective_statement(mpl);

4642 }

4643 #if 1 /* 11/II-2008 */

4644 else if (is_keyword(mpl, "table"))

4645 { if (spec)

4646 error(mpl, "table statement not allowed here");

4647 stmt->type = A_TABLE;

4648 stmt->u.tab = table_statement(mpl);

4649 }

4650 #endif

4651 else if (is_keyword(mpl, "solve"))

4652 { if (spec)

4653 error(mpl, "solve statement not allowed here");

4654 stmt->type = A_SOLVE;

4655 stmt->u.slv = solve_statement(mpl);

4656 }

4657 else if (is_keyword(mpl, "check"))

4658 { stmt->type = A_CHECK;

4659 stmt->u.chk = check_statement(mpl);

4660 }

4661 else if (is_keyword(mpl, "display"))

4662 { stmt->type = A_DISPLAY;

4663 stmt->u.dpy = display_statement(mpl);

4664 }

4665 else if (is_keyword(mpl, "printf"))

4666 { stmt->type = A_PRINTF;

4667 stmt->u.prt = printf_statement(mpl);

4668 }

4669 else if (is_keyword(mpl, "for"))

4670 { stmt->type = A_FOR;

4671 stmt->u.fur = for_statement(mpl);

4672 }

4673 else if (mpl->token == T_NAME)

4674 { if (spec)

4675 error(mpl, "constraint statement not allowed here");

4676 stmt->type = A_CONSTRAINT;

4677 stmt->u.con = constraint_statement(mpl);

4678 }

4679 else if (is_reserved(mpl))

4680 error(mpl, "invalid use of reserved keyword %s", mpl->image);

4681 else

4682 error(mpl, "syntax error in model section");

4683 return stmt;

4684 }

4685

4686 /*----------------------------------------------------------------------

4687 -- model_section - parse model section.

4688 --

4689 -- This routine parses model section using the syntax:

4690 --

4691 -- <model section> ::= <empty>

4692 -- <model section> ::= <model section> <statement>

4693 --

4694 -- Parsing model section is terminated by either the keyword 'data', or

4695 -- the keyword 'end', or the end of file. */

4696

4697 void model_section(MPL *mpl)

4698 { STATEMENT *stmt, *last_stmt;

4699 xassert(mpl->model == NULL);

4700 last_stmt = NULL;

4701 while (!(mpl->token == T_EOF || is_keyword(mpl, "data") ||

4702 is_keyword(mpl, "end")))

4703 { /* parse statement */

4704 stmt = simple_statement(mpl, 0);

4705 /* and append it to the end of the statement list */

4706 if (last_stmt == NULL)

4707 mpl->model = stmt;

4708 else

4709 last_stmt->next = stmt;

4710 last_stmt = stmt;

4711 }

4712 return;

4713 }

4714

4715 /* eof */