/* mpl1.c */ /*********************************************************************** * This code is part of GLPK (GNU Linear Programming Kit). * Copyright (C) 2003-2016 Free Software Foundation, Inc. * Written by Andrew Makhorin . * * GLPK is free software: you can redistribute it and/or modify it * under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * GLPK is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * License for more details. * * You should have received a copy of the GNU General Public License * along with GLPK. If not, see . ***********************************************************************/ #include "mpl.h" #define dmp_get_atomv dmp_get_atom /**********************************************************************/ /* * * PROCESSING MODEL SECTION * * */ /**********************************************************************/ /*---------------------------------------------------------------------- -- enter_context - enter current token into context queue. -- -- This routine enters the current token into the context queue. */ void enter_context(MPL *mpl) { char *image, *s; if (mpl->token == T_EOF) image = "_|_"; else if (mpl->token == T_STRING) image = "'...'"; else image = mpl->image; xassert(0 <= mpl->c_ptr && mpl->c_ptr < CONTEXT_SIZE); mpl->context[mpl->c_ptr++] = ' '; if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0; for (s = image; *s != '\0'; s++) { mpl->context[mpl->c_ptr++] = *s; if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0; } return; } /*---------------------------------------------------------------------- -- print_context - print current content of context queue. -- -- This routine prints current content of the context queue. */ void print_context(MPL *mpl) { int c; while (mpl->c_ptr > 0) { mpl->c_ptr--; c = mpl->context[0]; memmove(mpl->context, mpl->context+1, CONTEXT_SIZE-1); mpl->context[CONTEXT_SIZE-1] = (char)c; } xprintf("Context: %s%.*s\n", mpl->context[0] == ' ' ? "" : "...", CONTEXT_SIZE, mpl->context); return; } /*---------------------------------------------------------------------- -- get_char - scan next character from input text file. -- -- This routine scans a next ASCII character from the input text file. -- In case of end-of-file, the character is assigned EOF. */ void get_char(MPL *mpl) { int c; if (mpl->c == EOF) goto done; if (mpl->c == '\n') mpl->line++; c = read_char(mpl); if (c == EOF) { if (mpl->c == '\n') mpl->line--; else warning(mpl, "final NL missing before end of file"); } else if (c == '\n') ; else if (isspace(c)) c = ' '; else if (iscntrl(c)) { enter_context(mpl); error(mpl, "control character 0x%02X not allowed", c); } mpl->c = c; done: return; } /*---------------------------------------------------------------------- -- append_char - append character to current token. -- -- This routine appends the current character to the current token and -- then scans a next character. */ void append_char(MPL *mpl) { xassert(0 <= mpl->imlen && mpl->imlen <= MAX_LENGTH); if (mpl->imlen == MAX_LENGTH) { switch (mpl->token) { case T_NAME: enter_context(mpl); error(mpl, "symbolic name %s... too long", mpl->image); case T_SYMBOL: enter_context(mpl); error(mpl, "symbol %s... too long", mpl->image); case T_NUMBER: enter_context(mpl); error(mpl, "numeric literal %s... too long", mpl->image); case T_STRING: enter_context(mpl); error(mpl, "string literal too long"); default: xassert(mpl != mpl); } } mpl->image[mpl->imlen++] = (char)mpl->c; mpl->image[mpl->imlen] = '\0'; get_char(mpl); return; } /*---------------------------------------------------------------------- -- get_token - scan next token from input text file. -- -- This routine scans a next token from the input text file using the -- standard finite automation technique. */ void get_token(MPL *mpl) { /* save the current token */ mpl->b_token = mpl->token; mpl->b_imlen = mpl->imlen; strcpy(mpl->b_image, mpl->image); mpl->b_value = mpl->value; /* if the next token is already scanned, make it current */ if (mpl->f_scan) { mpl->f_scan = 0; mpl->token = mpl->f_token; mpl->imlen = mpl->f_imlen; strcpy(mpl->image, mpl->f_image); mpl->value = mpl->f_value; goto done; } loop: /* nothing has been scanned so far */ mpl->token = 0; mpl->imlen = 0; mpl->image[0] = '\0'; mpl->value = 0.0; /* skip any uninteresting characters */ while (mpl->c == ' ' || mpl->c == '\n') get_char(mpl); /* recognize and construct the token */ if (mpl->c == EOF) { /* end-of-file reached */ mpl->token = T_EOF; } else if (mpl->c == '#') { /* comment; skip anything until end-of-line */ while (mpl->c != '\n' && mpl->c != EOF) get_char(mpl); goto loop; } else if (!mpl->flag_d && (isalpha(mpl->c) || mpl->c == '_')) { /* symbolic name or reserved keyword */ mpl->token = T_NAME; while (isalnum(mpl->c) || mpl->c == '_') append_char(mpl); if (strcmp(mpl->image, "and") == 0) mpl->token = T_AND; else if (strcmp(mpl->image, "by") == 0) mpl->token = T_BY; else if (strcmp(mpl->image, "cross") == 0) mpl->token = T_CROSS; else if (strcmp(mpl->image, "diff") == 0) mpl->token = T_DIFF; else if (strcmp(mpl->image, "div") == 0) mpl->token = T_DIV; else if (strcmp(mpl->image, "else") == 0) mpl->token = T_ELSE; else if (strcmp(mpl->image, "if") == 0) mpl->token = T_IF; else if (strcmp(mpl->image, "in") == 0) mpl->token = T_IN; #if 1 /* 21/VII-2006 */ else if (strcmp(mpl->image, "Infinity") == 0) mpl->token = T_INFINITY; #endif else if (strcmp(mpl->image, "inter") == 0) mpl->token = T_INTER; else if (strcmp(mpl->image, "less") == 0) mpl->token = T_LESS; else if (strcmp(mpl->image, "mod") == 0) mpl->token = T_MOD; else if (strcmp(mpl->image, "not") == 0) mpl->token = T_NOT; else if (strcmp(mpl->image, "or") == 0) mpl->token = T_OR; else if (strcmp(mpl->image, "s") == 0 && mpl->c == '.') { mpl->token = T_SPTP; append_char(mpl); if (mpl->c != 't') sptp: { enter_context(mpl); error(mpl, "keyword s.t. incomplete"); } append_char(mpl); if (mpl->c != '.') goto sptp; append_char(mpl); } else if (strcmp(mpl->image, "symdiff") == 0) mpl->token = T_SYMDIFF; else if (strcmp(mpl->image, "then") == 0) mpl->token = T_THEN; else if (strcmp(mpl->image, "union") == 0) mpl->token = T_UNION; else if (strcmp(mpl->image, "within") == 0) mpl->token = T_WITHIN; } else if (!mpl->flag_d && isdigit(mpl->c)) { /* numeric literal */ mpl->token = T_NUMBER; /* scan integer part */ while (isdigit(mpl->c)) append_char(mpl); /* scan optional fractional part */ if (mpl->c == '.') { append_char(mpl); if (mpl->c == '.') { /* hmm, it is not the fractional part, it is dots that follow the integer part */ mpl->imlen--; mpl->image[mpl->imlen] = '\0'; mpl->f_dots = 1; goto conv; } frac: while (isdigit(mpl->c)) append_char(mpl); } /* scan optional decimal exponent */ if (mpl->c == 'e' || mpl->c == 'E') { append_char(mpl); if (mpl->c == '+' || mpl->c == '-') append_char(mpl); if (!isdigit(mpl->c)) { enter_context(mpl); error(mpl, "numeric literal %s incomplete", mpl->image); } while (isdigit(mpl->c)) append_char(mpl); } /* there must be no letter following the numeric literal */ if (isalpha(mpl->c) || mpl->c == '_') { enter_context(mpl); error(mpl, "symbol %s%c... should be enclosed in quotes", mpl->image, mpl->c); } conv: /* convert numeric literal to floating-point */ if (str2num(mpl->image, &mpl->value)) err: { enter_context(mpl); error(mpl, "cannot convert numeric literal %s to floating-p" "oint number", mpl->image); } } else if (mpl->c == '\'' || mpl->c == '"') { /* character string */ int quote = mpl->c; mpl->token = T_STRING; get_char(mpl); for (;;) { if (mpl->c == '\n' || mpl->c == EOF) { enter_context(mpl); error(mpl, "unexpected end of line; string literal incom" "plete"); } if (mpl->c == quote) { get_char(mpl); if (mpl->c != quote) break; } append_char(mpl); } } else if (!mpl->flag_d && mpl->c == '+') mpl->token = T_PLUS, append_char(mpl); else if (!mpl->flag_d && mpl->c == '-') mpl->token = T_MINUS, append_char(mpl); else if (mpl->c == '*') { mpl->token = T_ASTERISK, append_char(mpl); if (mpl->c == '*') mpl->token = T_POWER, append_char(mpl); } else if (mpl->c == '/') { mpl->token = T_SLASH, append_char(mpl); if (mpl->c == '*') { /* comment sequence */ get_char(mpl); for (;;) { if (mpl->c == EOF) { /* do not call enter_context at this point */ error(mpl, "unexpected end of file; comment sequence " "incomplete"); } else if (mpl->c == '*') { get_char(mpl); if (mpl->c == '/') break; } else get_char(mpl); } get_char(mpl); goto loop; } } else if (mpl->c == '^') mpl->token = T_POWER, append_char(mpl); else if (mpl->c == '<') { mpl->token = T_LT, append_char(mpl); if (mpl->c == '=') mpl->token = T_LE, append_char(mpl); else if (mpl->c == '>') mpl->token = T_NE, append_char(mpl); #if 1 /* 11/II-2008 */ else if (mpl->c == '-') mpl->token = T_INPUT, append_char(mpl); #endif } else if (mpl->c == '=') { mpl->token = T_EQ, append_char(mpl); if (mpl->c == '=') append_char(mpl); } else if (mpl->c == '>') { mpl->token = T_GT, append_char(mpl); if (mpl->c == '=') mpl->token = T_GE, append_char(mpl); #if 1 /* 14/VII-2006 */ else if (mpl->c == '>') mpl->token = T_APPEND, append_char(mpl); #endif } else if (mpl->c == '!') { mpl->token = T_NOT, append_char(mpl); if (mpl->c == '=') mpl->token = T_NE, append_char(mpl); } else if (mpl->c == '&') { mpl->token = T_CONCAT, append_char(mpl); if (mpl->c == '&') mpl->token = T_AND, append_char(mpl); } else if (mpl->c == '|') { mpl->token = T_BAR, append_char(mpl); if (mpl->c == '|') mpl->token = T_OR, append_char(mpl); } else if (!mpl->flag_d && mpl->c == '.') { mpl->token = T_POINT, append_char(mpl); if (mpl->f_dots) { /* dots; the first dot was read on the previous call to the scanner, so the current character is the second dot */ mpl->token = T_DOTS; mpl->imlen = 2; strcpy(mpl->image, ".."); mpl->f_dots = 0; } else if (mpl->c == '.') mpl->token = T_DOTS, append_char(mpl); else if (isdigit(mpl->c)) { /* numeric literal that begins with the decimal point */ mpl->token = T_NUMBER, append_char(mpl); goto frac; } } else if (mpl->c == ',') mpl->token = T_COMMA, append_char(mpl); else if (mpl->c == ':') { mpl->token = T_COLON, append_char(mpl); if (mpl->c == '=') mpl->token = T_ASSIGN, append_char(mpl); } else if (mpl->c == ';') mpl->token = T_SEMICOLON, append_char(mpl); else if (mpl->c == '(') mpl->token = T_LEFT, append_char(mpl); else if (mpl->c == ')') mpl->token = T_RIGHT, append_char(mpl); else if (mpl->c == '[') mpl->token = T_LBRACKET, append_char(mpl); else if (mpl->c == ']') mpl->token = T_RBRACKET, append_char(mpl); else if (mpl->c == '{') mpl->token = T_LBRACE, append_char(mpl); else if (mpl->c == '}') mpl->token = T_RBRACE, append_char(mpl); #if 1 /* 11/II-2008 */ else if (mpl->c == '~') mpl->token = T_TILDE, append_char(mpl); #endif else if (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL) { /* symbol */ xassert(mpl->flag_d); mpl->token = T_SYMBOL; while (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL) append_char(mpl); switch (str2num(mpl->image, &mpl->value)) { case 0: mpl->token = T_NUMBER; break; case 1: goto err; case 2: break; default: xassert(mpl != mpl); } } else { enter_context(mpl); error(mpl, "character %c not allowed", mpl->c); } /* enter the current token into the context queue */ enter_context(mpl); /* reset the flag, which may be set by indexing_expression() and is used by expression_list() */ mpl->flag_x = 0; done: return; } /*---------------------------------------------------------------------- -- unget_token - return current token back to input stream. -- -- This routine returns the current token back to the input stream, so -- the previously scanned token becomes the current one. */ void unget_token(MPL *mpl) { /* save the current token, which becomes the next one */ xassert(!mpl->f_scan); mpl->f_scan = 1; mpl->f_token = mpl->token; mpl->f_imlen = mpl->imlen; strcpy(mpl->f_image, mpl->image); mpl->f_value = mpl->value; /* restore the previous token, which becomes the current one */ mpl->token = mpl->b_token; mpl->imlen = mpl->b_imlen; strcpy(mpl->image, mpl->b_image); mpl->value = mpl->b_value; return; } /*---------------------------------------------------------------------- -- is_keyword - check if current token is given non-reserved keyword. -- -- If the current token is given (non-reserved) keyword, this routine -- returns non-zero. Otherwise zero is returned. */ int is_keyword(MPL *mpl, char *keyword) { return mpl->token == T_NAME && strcmp(mpl->image, keyword) == 0; } /*---------------------------------------------------------------------- -- is_reserved - check if current token is reserved keyword. -- -- If the current token is a reserved keyword, this routine returns -- non-zero. Otherwise zero is returned. */ int is_reserved(MPL *mpl) { return mpl->token == T_AND && mpl->image[0] == 'a' || mpl->token == T_BY || mpl->token == T_CROSS || mpl->token == T_DIFF || mpl->token == T_DIV || mpl->token == T_ELSE || mpl->token == T_IF || mpl->token == T_IN || mpl->token == T_INTER || mpl->token == T_LESS || mpl->token == T_MOD || mpl->token == T_NOT && mpl->image[0] == 'n' || mpl->token == T_OR && mpl->image[0] == 'o' || mpl->token == T_SYMDIFF || mpl->token == T_THEN || mpl->token == T_UNION || mpl->token == T_WITHIN; } /*---------------------------------------------------------------------- -- make_code - generate pseudo-code (basic routine). -- -- This routine generates specified pseudo-code. It is assumed that all -- other translator routines use this basic routine. */ CODE *make_code(MPL *mpl, int op, OPERANDS *arg, int type, int dim) { CODE *code; DOMAIN *domain; DOMAIN_BLOCK *block; ARG_LIST *e; /* generate pseudo-code */ code = alloc(CODE); code->op = op; code->vflag = 0; /* is inherited from operand(s) */ /* copy operands and also make them referring to the pseudo-code being generated, because the latter becomes the parent for all its operands */ memset(&code->arg, '?', sizeof(OPERANDS)); switch (op) { case O_NUMBER: code->arg.num = arg->num; break; case O_STRING: code->arg.str = arg->str; break; case O_INDEX: code->arg.index.slot = arg->index.slot; code->arg.index.next = arg->index.next; break; case O_MEMNUM: case O_MEMSYM: for (e = arg->par.list; e != NULL; e = e->next) { xassert(e->x != NULL); xassert(e->x->up == NULL); e->x->up = code; code->vflag |= e->x->vflag; } code->arg.par.par = arg->par.par; code->arg.par.list = arg->par.list; break; case O_MEMSET: for (e = arg->set.list; e != NULL; e = e->next) { xassert(e->x != NULL); xassert(e->x->up == NULL); e->x->up = code; code->vflag |= e->x->vflag; } code->arg.set.set = arg->set.set; code->arg.set.list = arg->set.list; break; case O_MEMVAR: for (e = arg->var.list; e != NULL; e = e->next) { xassert(e->x != NULL); xassert(e->x->up == NULL); e->x->up = code; code->vflag |= e->x->vflag; } code->arg.var.var = arg->var.var; code->arg.var.list = arg->var.list; #if 1 /* 15/V-2010 */ code->arg.var.suff = arg->var.suff; #endif break; #if 1 /* 15/V-2010 */ case O_MEMCON: for (e = arg->con.list; e != NULL; e = e->next) { xassert(e->x != NULL); xassert(e->x->up == NULL); e->x->up = code; code->vflag |= e->x->vflag; } code->arg.con.con = arg->con.con; code->arg.con.list = arg->con.list; code->arg.con.suff = arg->con.suff; break; #endif case O_TUPLE: case O_MAKE: for (e = arg->list; e != NULL; e = e->next) { xassert(e->x != NULL); xassert(e->x->up == NULL); e->x->up = code; code->vflag |= e->x->vflag; } code->arg.list = arg->list; break; case O_SLICE: xassert(arg->slice != NULL); code->arg.slice = arg->slice; break; case O_IRAND224: case O_UNIFORM01: case O_NORMAL01: case O_GMTIME: code->vflag = 1; break; case O_CVTNUM: case O_CVTSYM: case O_CVTLOG: case O_CVTTUP: case O_CVTLFM: case O_PLUS: case O_MINUS: case O_NOT: case O_ABS: case O_CEIL: case O_FLOOR: case O_EXP: case O_LOG: case O_LOG10: case O_SQRT: case O_SIN: case O_COS: case O_TAN: case O_ATAN: case O_ROUND: case O_TRUNC: case O_CARD: case O_LENGTH: /* unary operation */ xassert(arg->arg.x != NULL); xassert(arg->arg.x->up == NULL); arg->arg.x->up = code; code->vflag |= arg->arg.x->vflag; code->arg.arg.x = arg->arg.x; break; case O_ADD: case O_SUB: case O_LESS: case O_MUL: case O_DIV: case O_IDIV: case O_MOD: case O_POWER: case O_ATAN2: case O_ROUND2: case O_TRUNC2: case O_UNIFORM: if (op == O_UNIFORM) code->vflag = 1; case O_NORMAL: if (op == O_NORMAL) code->vflag = 1; case O_CONCAT: case O_LT: case O_LE: case O_EQ: case O_GE: case O_GT: case O_NE: case O_AND: case O_OR: case O_UNION: case O_DIFF: case O_SYMDIFF: case O_INTER: case O_CROSS: case O_IN: case O_NOTIN: case O_WITHIN: case O_NOTWITHIN: case O_SUBSTR: case O_STR2TIME: case O_TIME2STR: /* binary operation */ xassert(arg->arg.x != NULL); xassert(arg->arg.x->up == NULL); arg->arg.x->up = code; code->vflag |= arg->arg.x->vflag; xassert(arg->arg.y != NULL); xassert(arg->arg.y->up == NULL); arg->arg.y->up = code; code->vflag |= arg->arg.y->vflag; code->arg.arg.x = arg->arg.x; code->arg.arg.y = arg->arg.y; break; case O_DOTS: case O_FORK: case O_SUBSTR3: /* ternary operation */ xassert(arg->arg.x != NULL); xassert(arg->arg.x->up == NULL); arg->arg.x->up = code; code->vflag |= arg->arg.x->vflag; xassert(arg->arg.y != NULL); xassert(arg->arg.y->up == NULL); arg->arg.y->up = code; code->vflag |= arg->arg.y->vflag; if (arg->arg.z != NULL) { xassert(arg->arg.z->up == NULL); arg->arg.z->up = code; code->vflag |= arg->arg.z->vflag; } code->arg.arg.x = arg->arg.x; code->arg.arg.y = arg->arg.y; code->arg.arg.z = arg->arg.z; break; case O_MIN: case O_MAX: /* n-ary operation */ for (e = arg->list; e != NULL; e = e->next) { xassert(e->x != NULL); xassert(e->x->up == NULL); e->x->up = code; code->vflag |= e->x->vflag; } code->arg.list = arg->list; break; case O_SUM: case O_PROD: case O_MINIMUM: case O_MAXIMUM: case O_FORALL: case O_EXISTS: case O_SETOF: case O_BUILD: /* iterated operation */ domain = arg->loop.domain; xassert(domain != NULL); if (domain->code != NULL) { xassert(domain->code->up == NULL); domain->code->up = code; code->vflag |= domain->code->vflag; } for (block = domain->list; block != NULL; block = block->next) { xassert(block->code != NULL); xassert(block->code->up == NULL); block->code->up = code; code->vflag |= block->code->vflag; } if (arg->loop.x != NULL) { xassert(arg->loop.x->up == NULL); arg->loop.x->up = code; code->vflag |= arg->loop.x->vflag; } code->arg.loop.domain = arg->loop.domain; code->arg.loop.x = arg->loop.x; break; default: xassert(op != op); } /* set other attributes of the pseudo-code */ code->type = type; code->dim = dim; code->up = NULL; code->valid = 0; memset(&code->value, '?', sizeof(VALUE)); return code; } /*---------------------------------------------------------------------- -- make_unary - generate pseudo-code for unary operation. -- -- This routine generates pseudo-code for unary operation. */ CODE *make_unary(MPL *mpl, int op, CODE *x, int type, int dim) { CODE *code; OPERANDS arg; xassert(x != NULL); arg.arg.x = x; code = make_code(mpl, op, &arg, type, dim); return code; } /*---------------------------------------------------------------------- -- make_binary - generate pseudo-code for binary operation. -- -- This routine generates pseudo-code for binary operation. */ CODE *make_binary(MPL *mpl, int op, CODE *x, CODE *y, int type, int dim) { CODE *code; OPERANDS arg; xassert(x != NULL); xassert(y != NULL); arg.arg.x = x; arg.arg.y = y; code = make_code(mpl, op, &arg, type, dim); return code; } /*---------------------------------------------------------------------- -- make_ternary - generate pseudo-code for ternary operation. -- -- This routine generates pseudo-code for ternary operation. */ CODE *make_ternary(MPL *mpl, int op, CODE *x, CODE *y, CODE *z, int type, int dim) { CODE *code; OPERANDS arg; xassert(x != NULL); xassert(y != NULL); /* third operand can be NULL */ arg.arg.x = x; arg.arg.y = y; arg.arg.z = z; code = make_code(mpl, op, &arg, type, dim); return code; } /*---------------------------------------------------------------------- -- numeric_literal - parse reference to numeric literal. -- -- This routine parses primary expression using the syntax: -- -- ::= */ CODE *numeric_literal(MPL *mpl) { CODE *code; OPERANDS arg; xassert(mpl->token == T_NUMBER); arg.num = mpl->value; code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0); get_token(mpl /* */); return code; } /*---------------------------------------------------------------------- -- string_literal - parse reference to string literal. -- -- This routine parses primary expression using the syntax: -- -- ::= */ CODE *string_literal(MPL *mpl) { CODE *code; OPERANDS arg; xassert(mpl->token == T_STRING); arg.str = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(arg.str, mpl->image); code = make_code(mpl, O_STRING, &arg, A_SYMBOLIC, 0); get_token(mpl /* */); return code; } /*---------------------------------------------------------------------- -- create_arg_list - create empty operands list. -- -- This routine creates operands list, which is initially empty. */ ARG_LIST *create_arg_list(MPL *mpl) { ARG_LIST *list; xassert(mpl == mpl); list = NULL; return list; } /*---------------------------------------------------------------------- -- expand_arg_list - append operand to operands list. -- -- This routine appends new operand to specified operands list. */ ARG_LIST *expand_arg_list(MPL *mpl, ARG_LIST *list, CODE *x) { ARG_LIST *tail, *temp; xassert(x != NULL); /* create new operands list entry */ tail = alloc(ARG_LIST); tail->x = x; tail->next = NULL; /* and append it to the operands list */ if (list == NULL) list = tail; else { for (temp = list; temp->next != NULL; temp = temp->next); temp->next = tail; } return list; } /*---------------------------------------------------------------------- -- arg_list_len - determine length of operands list. -- -- This routine returns the number of operands in operands list. */ int arg_list_len(MPL *mpl, ARG_LIST *list) { ARG_LIST *temp; int len; xassert(mpl == mpl); len = 0; for (temp = list; temp != NULL; temp = temp->next) len++; return len; } /*---------------------------------------------------------------------- -- subscript_list - parse subscript list. -- -- This routine parses subscript list using the syntax: -- -- ::= -- ::= , -- ::= */ ARG_LIST *subscript_list(MPL *mpl) { ARG_LIST *list; CODE *x; list = create_arg_list(mpl); for (;;) { /* parse subscript expression */ x = expression_5(mpl); /* convert it to symbolic type, if necessary */ if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); /* check that now the expression is of symbolic type */ if (x->type != A_SYMBOLIC) error(mpl, "subscript expression has invalid type"); xassert(x->dim == 0); /* and append it to the subscript list */ list = expand_arg_list(mpl, list, x); /* check a token that follows the subscript expression */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_RBRACKET) break; else error(mpl, "syntax error in subscript list"); } return list; } #if 1 /* 15/V-2010 */ /*---------------------------------------------------------------------- -- object_reference - parse reference to named object. -- -- This routine parses primary expression using the syntax: -- -- ::= -- ::= -- ::= [ ] -- ::= -- ::= [ ] -- ::= -- ::= [ ] -- -- ::= -- ::= [ ] -- -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= | .lb | .ub | .status | .val | .dual */ CODE *object_reference(MPL *mpl) { AVLNODE *node; DOMAIN_SLOT *slot; SET *set; PARAMETER *par; VARIABLE *var; CONSTRAINT *con; ARG_LIST *list; OPERANDS arg; CODE *code; char *name; int dim, suff; /* find the object in the symbolic name table */ xassert(mpl->token == T_NAME); node = avl_find_node(mpl->tree, mpl->image); if (node == NULL) error(mpl, "%s not defined", mpl->image); /* check the object type and obtain its dimension */ switch (avl_get_node_type(node)) { case A_INDEX: /* dummy index */ slot = (DOMAIN_SLOT *)avl_get_node_link(node); name = slot->name; dim = 0; break; case A_SET: /* model set */ set = (SET *)avl_get_node_link(node); name = set->name; dim = set->dim; /* if a set object is referenced in its own declaration and the dimen attribute is not specified yet, use dimen 1 by default */ if (set->dimen == 0) set->dimen = 1; break; case A_PARAMETER: /* model parameter */ par = (PARAMETER *)avl_get_node_link(node); name = par->name; dim = par->dim; break; case A_VARIABLE: /* model variable */ var = (VARIABLE *)avl_get_node_link(node); name = var->name; dim = var->dim; break; case A_CONSTRAINT: /* model constraint or objective */ con = (CONSTRAINT *)avl_get_node_link(node); name = con->name; dim = con->dim; break; default: xassert(node != node); } get_token(mpl /* */); /* parse optional subscript list */ if (mpl->token == T_LBRACKET) { /* subscript list is specified */ if (dim == 0) error(mpl, "%s cannot be subscripted", name); get_token(mpl /* [ */); list = subscript_list(mpl); if (dim != arg_list_len(mpl, list)) error(mpl, "%s must have %d subscript%s rather than %d", name, dim, dim == 1 ? "" : "s", arg_list_len(mpl, list)); xassert(mpl->token == T_RBRACKET); get_token(mpl /* ] */); } else { /* subscript list is not specified */ if (dim != 0) error(mpl, "%s must be subscripted", name); list = create_arg_list(mpl); } /* parse optional suffix */ if (!mpl->flag_s && avl_get_node_type(node) == A_VARIABLE) suff = DOT_NONE; else suff = DOT_VAL; if (mpl->token == T_POINT) { get_token(mpl /* . */); if (mpl->token != T_NAME) error(mpl, "invalid use of period"); if (!(avl_get_node_type(node) == A_VARIABLE || avl_get_node_type(node) == A_CONSTRAINT)) error(mpl, "%s cannot have a suffix", name); if (strcmp(mpl->image, "lb") == 0) suff = DOT_LB; else if (strcmp(mpl->image, "ub") == 0) suff = DOT_UB; else if (strcmp(mpl->image, "status") == 0) suff = DOT_STATUS; else if (strcmp(mpl->image, "val") == 0) suff = DOT_VAL; else if (strcmp(mpl->image, "dual") == 0) suff = DOT_DUAL; else error(mpl, "suffix .%s invalid", mpl->image); get_token(mpl /* suffix */); } /* generate pseudo-code to take value of the object */ switch (avl_get_node_type(node)) { case A_INDEX: arg.index.slot = slot; arg.index.next = slot->list; code = make_code(mpl, O_INDEX, &arg, A_SYMBOLIC, 0); slot->list = code; break; case A_SET: arg.set.set = set; arg.set.list = list; code = make_code(mpl, O_MEMSET, &arg, A_ELEMSET, set->dimen); break; case A_PARAMETER: arg.par.par = par; arg.par.list = list; if (par->type == A_SYMBOLIC) code = make_code(mpl, O_MEMSYM, &arg, A_SYMBOLIC, 0); else code = make_code(mpl, O_MEMNUM, &arg, A_NUMERIC, 0); break; case A_VARIABLE: if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL || suff == DOT_DUAL)) error(mpl, "invalid reference to status, primal value, o" "r dual value of variable %s above solve statement", var->name); arg.var.var = var; arg.var.list = list; arg.var.suff = suff; code = make_code(mpl, O_MEMVAR, &arg, suff == DOT_NONE ? A_FORMULA : A_NUMERIC, 0); break; case A_CONSTRAINT: if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL || suff == DOT_DUAL)) error(mpl, "invalid reference to status, primal value, o" "r dual value of %s %s above solve statement", con->type == A_CONSTRAINT ? "constraint" : "objective" , con->name); arg.con.con = con; arg.con.list = list; arg.con.suff = suff; code = make_code(mpl, O_MEMCON, &arg, A_NUMERIC, 0); break; default: xassert(node != node); } return code; } #endif /*---------------------------------------------------------------------- -- numeric_argument - parse argument passed to built-in function. -- -- This routine parses an argument passed to numeric built-in function -- using the syntax: -- -- ::= */ CODE *numeric_argument(MPL *mpl, char *func) { CODE *x; x = expression_5(mpl); /* convert the argument to numeric type, if necessary */ if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); /* check that now the argument is of numeric type */ if (x->type != A_NUMERIC) error(mpl, "argument for %s has invalid type", func); xassert(x->dim == 0); return x; } #if 1 /* 15/VII-2006 */ CODE *symbolic_argument(MPL *mpl, char *func) { CODE *x; x = expression_5(mpl); /* convert the argument to symbolic type, if necessary */ if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); /* check that now the argument is of symbolic type */ if (x->type != A_SYMBOLIC) error(mpl, "argument for %s has invalid type", func); xassert(x->dim == 0); return x; } #endif #if 1 /* 15/VII-2006 */ CODE *elemset_argument(MPL *mpl, char *func) { CODE *x; x = expression_9(mpl); if (x->type != A_ELEMSET) error(mpl, "argument for %s has invalid type", func); xassert(x->dim > 0); return x; } #endif /*---------------------------------------------------------------------- -- function_reference - parse reference to built-in function. -- -- This routine parses primary expression using the syntax: -- -- ::= abs ( ) -- ::= ceil ( ) -- ::= floor ( ) -- ::= exp ( ) -- ::= log ( ) -- ::= log10 ( ) -- ::= max ( ) -- ::= min ( ) -- ::= sqrt ( ) -- ::= sin ( ) -- ::= cos ( ) -- ::= tan ( ) -- ::= atan ( ) -- ::= atan2 ( , ) -- ::= round ( ) -- ::= round ( , ) -- ::= trunc ( ) -- ::= trunc ( , ) -- ::= Irand224 ( ) -- ::= Uniform01 ( ) -- ::= Uniform ( , ) -- ::= Normal01 ( ) -- ::= Normal ( , ) -- ::= card ( ) -- ::= length ( ) -- ::= substr ( , ) -- ::= substr ( , , ) -- ::= str2time ( , ) -- ::= time2str ( , ) -- ::= gmtime ( ) -- ::= -- ::= , */ CODE *function_reference(MPL *mpl) { CODE *code; OPERANDS arg; int op; char func[15+1]; /* determine operation code */ xassert(mpl->token == T_NAME); if (strcmp(mpl->image, "abs") == 0) op = O_ABS; else if (strcmp(mpl->image, "ceil") == 0) op = O_CEIL; else if (strcmp(mpl->image, "floor") == 0) op = O_FLOOR; else if (strcmp(mpl->image, "exp") == 0) op = O_EXP; else if (strcmp(mpl->image, "log") == 0) op = O_LOG; else if (strcmp(mpl->image, "log10") == 0) op = O_LOG10; else if (strcmp(mpl->image, "sqrt") == 0) op = O_SQRT; else if (strcmp(mpl->image, "sin") == 0) op = O_SIN; else if (strcmp(mpl->image, "cos") == 0) op = O_COS; else if (strcmp(mpl->image, "tan") == 0) op = O_TAN; else if (strcmp(mpl->image, "atan") == 0) op = O_ATAN; else if (strcmp(mpl->image, "min") == 0) op = O_MIN; else if (strcmp(mpl->image, "max") == 0) op = O_MAX; else if (strcmp(mpl->image, "round") == 0) op = O_ROUND; else if (strcmp(mpl->image, "trunc") == 0) op = O_TRUNC; else if (strcmp(mpl->image, "Irand224") == 0) op = O_IRAND224; else if (strcmp(mpl->image, "Uniform01") == 0) op = O_UNIFORM01; else if (strcmp(mpl->image, "Uniform") == 0) op = O_UNIFORM; else if (strcmp(mpl->image, "Normal01") == 0) op = O_NORMAL01; else if (strcmp(mpl->image, "Normal") == 0) op = O_NORMAL; else if (strcmp(mpl->image, "card") == 0) op = O_CARD; else if (strcmp(mpl->image, "length") == 0) op = O_LENGTH; else if (strcmp(mpl->image, "substr") == 0) op = O_SUBSTR; else if (strcmp(mpl->image, "str2time") == 0) op = O_STR2TIME; else if (strcmp(mpl->image, "time2str") == 0) op = O_TIME2STR; else if (strcmp(mpl->image, "gmtime") == 0) op = O_GMTIME; else error(mpl, "function %s unknown", mpl->image); /* save symbolic name of the function */ strcpy(func, mpl->image); xassert(strlen(func) < sizeof(func)); get_token(mpl /* */); /* check the left parenthesis that follows the function name */ xassert(mpl->token == T_LEFT); get_token(mpl /* ( */); /* parse argument list */ if (op == O_MIN || op == O_MAX) { /* min and max allow arbitrary number of arguments */ arg.list = create_arg_list(mpl); /* parse argument list */ for (;;) { /* parse argument and append it to the operands list */ arg.list = expand_arg_list(mpl, arg.list, numeric_argument(mpl, func)); /* check a token that follows the argument */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_RIGHT) break; else error(mpl, "syntax error in argument list for %s", func); } } else if (op == O_IRAND224 || op == O_UNIFORM01 || op == O_NORMAL01 || op == O_GMTIME) { /* Irand224, Uniform01, Normal01, gmtime need no arguments */ if (mpl->token != T_RIGHT) error(mpl, "%s needs no arguments", func); } else if (op == O_UNIFORM || op == O_NORMAL) { /* Uniform and Normal need two arguments */ /* parse the first argument */ arg.arg.x = numeric_argument(mpl, func); /* check a token that follows the first argument */ if (mpl->token == T_COMMA) ; else if (mpl->token == T_RIGHT) error(mpl, "%s needs two arguments", func); else error(mpl, "syntax error in argument for %s", func); get_token(mpl /* , */); /* parse the second argument */ arg.arg.y = numeric_argument(mpl, func); /* check a token that follows the second argument */ if (mpl->token == T_COMMA) error(mpl, "%s needs two argument", func); else if (mpl->token == T_RIGHT) ; else error(mpl, "syntax error in argument for %s", func); } else if (op == O_ATAN || op == O_ROUND || op == O_TRUNC) { /* atan, round, and trunc need one or two arguments */ /* parse the first argument */ arg.arg.x = numeric_argument(mpl, func); /* parse the second argument, if specified */ if (mpl->token == T_COMMA) { switch (op) { case O_ATAN: op = O_ATAN2; break; case O_ROUND: op = O_ROUND2; break; case O_TRUNC: op = O_TRUNC2; break; default: xassert(op != op); } get_token(mpl /* , */); arg.arg.y = numeric_argument(mpl, func); } /* check a token that follows the last argument */ if (mpl->token == T_COMMA) error(mpl, "%s needs one or two arguments", func); else if (mpl->token == T_RIGHT) ; else error(mpl, "syntax error in argument for %s", func); } else if (op == O_SUBSTR) { /* substr needs two or three arguments */ /* parse the first argument */ arg.arg.x = symbolic_argument(mpl, func); /* check a token that follows the first argument */ if (mpl->token == T_COMMA) ; else if (mpl->token == T_RIGHT) error(mpl, "%s needs two or three arguments", func); else error(mpl, "syntax error in argument for %s", func); get_token(mpl /* , */); /* parse the second argument */ arg.arg.y = numeric_argument(mpl, func); /* parse the third argument, if specified */ if (mpl->token == T_COMMA) { op = O_SUBSTR3; get_token(mpl /* , */); arg.arg.z = numeric_argument(mpl, func); } /* check a token that follows the last argument */ if (mpl->token == T_COMMA) error(mpl, "%s needs two or three arguments", func); else if (mpl->token == T_RIGHT) ; else error(mpl, "syntax error in argument for %s", func); } else if (op == O_STR2TIME) { /* str2time needs two arguments, both symbolic */ /* parse the first argument */ arg.arg.x = symbolic_argument(mpl, func); /* check a token that follows the first argument */ if (mpl->token == T_COMMA) ; else if (mpl->token == T_RIGHT) error(mpl, "%s needs two arguments", func); else error(mpl, "syntax error in argument for %s", func); get_token(mpl /* , */); /* parse the second argument */ arg.arg.y = symbolic_argument(mpl, func); /* check a token that follows the second argument */ if (mpl->token == T_COMMA) error(mpl, "%s needs two argument", func); else if (mpl->token == T_RIGHT) ; else error(mpl, "syntax error in argument for %s", func); } else if (op == O_TIME2STR) { /* time2str needs two arguments, numeric and symbolic */ /* parse the first argument */ arg.arg.x = numeric_argument(mpl, func); /* check a token that follows the first argument */ if (mpl->token == T_COMMA) ; else if (mpl->token == T_RIGHT) error(mpl, "%s needs two arguments", func); else error(mpl, "syntax error in argument for %s", func); get_token(mpl /* , */); /* parse the second argument */ arg.arg.y = symbolic_argument(mpl, func); /* check a token that follows the second argument */ if (mpl->token == T_COMMA) error(mpl, "%s needs two argument", func); else if (mpl->token == T_RIGHT) ; else error(mpl, "syntax error in argument for %s", func); } else { /* other functions need one argument */ if (op == O_CARD) arg.arg.x = elemset_argument(mpl, func); else if (op == O_LENGTH) arg.arg.x = symbolic_argument(mpl, func); else arg.arg.x = numeric_argument(mpl, func); /* check a token that follows the argument */ if (mpl->token == T_COMMA) error(mpl, "%s needs one argument", func); else if (mpl->token == T_RIGHT) ; else error(mpl, "syntax error in argument for %s", func); } /* make pseudo-code to call the built-in function */ if (op == O_SUBSTR || op == O_SUBSTR3 || op == O_TIME2STR) code = make_code(mpl, op, &arg, A_SYMBOLIC, 0); else code = make_code(mpl, op, &arg, A_NUMERIC, 0); /* the reference ends with the right parenthesis */ xassert(mpl->token == T_RIGHT); get_token(mpl /* ) */); return code; } /*---------------------------------------------------------------------- -- create_domain - create empty domain. -- -- This routine creates empty domain, which is initially empty, i.e. -- has no domain blocks. */ DOMAIN *create_domain(MPL *mpl) { DOMAIN *domain; domain = alloc(DOMAIN); domain->list = NULL; domain->code = NULL; return domain; } /*---------------------------------------------------------------------- -- create_block - create empty domain block. -- -- This routine creates empty domain block, which is initially empty, -- i.e. has no domain slots. */ DOMAIN_BLOCK *create_block(MPL *mpl) { DOMAIN_BLOCK *block; block = alloc(DOMAIN_BLOCK); block->list = NULL; block->code = NULL; block->backup = NULL; block->next = NULL; return block; } /*---------------------------------------------------------------------- -- append_block - append domain block to specified domain. -- -- This routine adds given domain block to the end of the block list of -- specified domain. */ void append_block(MPL *mpl, DOMAIN *domain, DOMAIN_BLOCK *block) { DOMAIN_BLOCK *temp; xassert(mpl == mpl); xassert(domain != NULL); xassert(block != NULL); xassert(block->next == NULL); if (domain->list == NULL) domain->list = block; else { for (temp = domain->list; temp->next != NULL; temp = temp->next); temp->next = block; } return; } /*---------------------------------------------------------------------- -- append_slot - create and append new slot to domain block. -- -- This routine creates new domain slot and adds it to the end of slot -- list of specified domain block. -- -- The parameter name is symbolic name of the dummy index associated -- with the slot (the character string must be allocated). NULL means -- the dummy index is not explicitly specified. -- -- The parameter code is pseudo-code for computing symbolic value, at -- which the dummy index is bounded. NULL means the dummy index is free -- in the domain scope. */ DOMAIN_SLOT *append_slot(MPL *mpl, DOMAIN_BLOCK *block, char *name, CODE *code) { DOMAIN_SLOT *slot, *temp; xassert(block != NULL); slot = alloc(DOMAIN_SLOT); slot->name = name; slot->code = code; slot->value = NULL; slot->list = NULL; slot->next = NULL; if (block->list == NULL) block->list = slot; else { for (temp = block->list; temp->next != NULL; temp = temp->next); temp->next = slot; } return slot; } /*---------------------------------------------------------------------- -- expression_list - parse expression list. -- -- This routine parses a list of one or more expressions enclosed into -- the parentheses using the syntax: -- -- ::= ( ) -- ::= -- ::= , -- -- Note that this construction may have three different meanings: -- -- 1. If consists of only one expression, is a parenthesized expression, which may be of any -- valid type (not necessarily 1-tuple). -- -- 2. If consists of several expressions separated by -- commae, where no expression is undeclared symbolic name, is a n-tuple. -- -- 3. If consists of several expressions separated by -- commae, where at least one expression is undeclared symbolic name -- (that denotes a dummy index), is a slice and -- can be only used as constituent of indexing expression. */ #define max_dim 20 /* maximal number of components allowed within parentheses */ CODE *expression_list(MPL *mpl) { CODE *code; OPERANDS arg; struct { char *name; CODE *code; } list[1+max_dim]; int flag_x, next_token, dim, j, slice = 0; xassert(mpl->token == T_LEFT); /* the flag, which allows recognizing undeclared symbolic names as dummy indices, will be automatically reset by get_token(), so save it before scanning the next token */ flag_x = mpl->flag_x; get_token(mpl /* ( */); /* parse */ for (dim = 1; ; dim++) { if (dim > max_dim) error(mpl, "too many components within parentheses"); /* current component of can be either dummy index or expression */ if (mpl->token == T_NAME) { /* symbolic name is recognized as dummy index only if: the flag, which allows that, is set, and the name is followed by comma or right parenthesis, and the name is undeclared */ get_token(mpl /* */); next_token = mpl->token; unget_token(mpl); if (!(flag_x && (next_token == T_COMMA || next_token == T_RIGHT) && avl_find_node(mpl->tree, mpl->image) == NULL)) { /* this is not dummy index */ goto expr; } /* all dummy indices within the same slice must have unique symbolic names */ for (j = 1; j < dim; j++) { if (list[j].name != NULL && strcmp(list[j].name, mpl->image) == 0) error(mpl, "duplicate dummy index %s not allowed", mpl->image); } /* current component of is dummy index */ list[dim].name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(list[dim].name, mpl->image); list[dim].code = NULL; get_token(mpl /* */); /* is a slice, because at least one dummy index has appeared */ slice = 1; /* note that the context ( ) is not allowed, i.e. in this case is considered as a parenthesized expression */ if (dim == 1 && mpl->token == T_RIGHT) error(mpl, "%s not defined", list[dim].name); } else expr: { /* current component of is expression */ code = expression_13(mpl); /* if the current expression is followed by comma or it is not the very first expression, entire is n-tuple or slice, in which case the current expression should be converted to symbolic type, if necessary */ if (mpl->token == T_COMMA || dim > 1) { if (code->type == A_NUMERIC) code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0); /* now the expression must be of symbolic type */ if (code->type != A_SYMBOLIC) error(mpl, "component expression has invalid type"); xassert(code->dim == 0); } list[dim].name = NULL; list[dim].code = code; } /* check a token that follows the current component */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_RIGHT) break; else error(mpl, "right parenthesis missing where expected"); } /* generate pseudo-code for */ if (dim == 1 && !slice) { /* is a parenthesized expression */ code = list[1].code; } else if (!slice) { /* is a n-tuple */ arg.list = create_arg_list(mpl); for (j = 1; j <= dim; j++) arg.list = expand_arg_list(mpl, arg.list, list[j].code); code = make_code(mpl, O_TUPLE, &arg, A_TUPLE, dim); } else { /* is a slice */ arg.slice = create_block(mpl); for (j = 1; j <= dim; j++) append_slot(mpl, arg.slice, list[j].name, list[j].code); /* note that actually pseudo-codes with op = O_SLICE are never evaluated */ code = make_code(mpl, O_SLICE, &arg, A_TUPLE, dim); } get_token(mpl /* ) */); /* if is a slice, there must be the keyword 'in', which follows the right parenthesis */ if (slice && mpl->token != T_IN) error(mpl, "keyword in missing where expected"); /* if the slice flag is set and there is the keyword 'in', which follows , the latter must be a slice */ if (flag_x && mpl->token == T_IN && !slice) { if (dim == 1) error(mpl, "syntax error in indexing expression"); else error(mpl, "0-ary slice not allowed"); } return code; } /*---------------------------------------------------------------------- -- literal set - parse literal set. -- -- This routine parses literal set using the syntax: -- -- ::= { } -- ::= -- ::= , -- ::= -- -- It is assumed that the left curly brace and the very first member -- expression that follows it are already parsed. The right curly brace -- remains unscanned on exit. */ CODE *literal_set(MPL *mpl, CODE *code) { OPERANDS arg; int j; xassert(code != NULL); arg.list = create_arg_list(mpl); /* parse */ for (j = 1; ; j++) { /* all member expressions must be n-tuples; so, if the current expression is not n-tuple, convert it to 1-tuple */ if (code->type == A_NUMERIC) code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0); if (code->type == A_SYMBOLIC) code = make_unary(mpl, O_CVTTUP, code, A_TUPLE, 1); /* now the expression must be n-tuple */ if (code->type != A_TUPLE) error(mpl, "member expression has invalid type"); /* all member expressions must have identical dimension */ if (arg.list != NULL && arg.list->x->dim != code->dim) error(mpl, "member %d has %d component%s while member %d ha" "s %d component%s", j-1, arg.list->x->dim, arg.list->x->dim == 1 ? "" : "s", j, code->dim, code->dim == 1 ? "" : "s"); /* append the current expression to the member list */ arg.list = expand_arg_list(mpl, arg.list, code); /* check a token that follows the current expression */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_RBRACE) break; else error(mpl, "syntax error in literal set"); /* parse the next expression that follows the comma */ code = expression_5(mpl); } /* generate pseudo-code for */ code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, arg.list->x->dim); return code; } /*---------------------------------------------------------------------- -- indexing_expression - parse indexing expression. -- -- This routine parses indexing expression using the syntax: -- -- ::= -- ::= { } -- ::= { : } -- ::= -- ::= , -- ::= -- ::= in -- ::= in -- ::= -- ::= ( ) -- ::= -- ::= -- -- This routine creates domain for , where each -- domain block corresponds to , and each domain slot -- corresponds to individual indexing position. */ DOMAIN *indexing_expression(MPL *mpl) { DOMAIN *domain; DOMAIN_BLOCK *block; DOMAIN_SLOT *slot; CODE *code; xassert(mpl->token == T_LBRACE); get_token(mpl /* { */); if (mpl->token == T_RBRACE) error(mpl, "empty indexing expression not allowed"); /* create domain to be constructed */ domain = create_domain(mpl); /* parse either or that follows the left brace */ for (;;) { /* domain block for is not created yet */ block = NULL; /* pseudo-code for is not generated yet */ code = NULL; /* check a token, which begins with */ if (mpl->token == T_NAME) { /* it is a symbolic name */ int next_token; char *name; /* symbolic name is recognized as dummy index only if it is followed by the keyword 'in' and not declared */ get_token(mpl /* */); next_token = mpl->token; unget_token(mpl); if (!(next_token == T_IN && avl_find_node(mpl->tree, mpl->image) == NULL)) { /* this is not dummy index; the symbolic name begins an expression, which is either or the very first in */ goto expr; } /* create domain block with one slot, which is assigned the dummy index */ block = create_block(mpl); name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(name, mpl->image); append_slot(mpl, block, name, NULL); get_token(mpl /* */); /* the keyword 'in' is already checked above */ xassert(mpl->token == T_IN); get_token(mpl /* in */); /* that follows the keyword 'in' will be parsed below */ } else if (mpl->token == T_LEFT) { /* it is the left parenthesis; parse expression that begins with this parenthesis (the flag is set in order to allow recognizing slices; see the routine expression_list) */ mpl->flag_x = 1; code = expression_9(mpl); if (code->op != O_SLICE) { /* this is either or the very first in */ goto expr; } /* this is a slice; besides the corresponding domain block is already created by expression_list() */ block = code->arg.slice; code = NULL; /* is not parsed yet */ /* the keyword 'in' following the slice is already checked by expression_list() */ xassert(mpl->token == T_IN); get_token(mpl /* in */); /* that follows the keyword 'in' will be parsed below */ } expr: /* parse expression that follows either the keyword 'in' (in which case it can be as well as the very first in ); note that this expression can be already parsed above */ if (code == NULL) code = expression_9(mpl); /* check the type of the expression just parsed */ if (code->type != A_ELEMSET) { /* it is not and therefore it can only be the very first in ; however, then there must be no dummy index neither slice between the left brace and this expression */ if (block != NULL) error(mpl, "domain expression has invalid type"); /* parse the rest part of and make this set be , i.e. the construction {a, b, c} is parsed as it were written as {A}, where A = {a, b, c} is a temporary elemental set */ code = literal_set(mpl, code); } /* now pseudo-code for has been built */ xassert(code != NULL); xassert(code->type == A_ELEMSET); xassert(code->dim > 0); /* if domain block for the current is still not created, create it for fake slice of the same dimension as */ if (block == NULL) { int j; block = create_block(mpl); for (j = 1; j <= code->dim; j++) append_slot(mpl, block, NULL, NULL); } /* number of indexing positions in must be the same as dimension of n-tuples in basic set */ { int dim = 0; for (slot = block->list; slot != NULL; slot = slot->next) dim++; if (dim != code->dim) error(mpl,"%d %s specified for set of dimension %d", dim, dim == 1 ? "index" : "indices", code->dim); } /* store pseudo-code for in the domain block */ xassert(block->code == NULL); block->code = code; /* and append the domain block to the domain */ append_block(mpl, domain, block); /* the current has been completely parsed; include all its dummy indices into the symbolic name table to make them available for referencing from expressions; implicit declarations of dummy indices remain valid while the corresponding domain scope is valid */ for (slot = block->list; slot != NULL; slot = slot->next) if (slot->name != NULL) { AVLNODE *node; xassert(avl_find_node(mpl->tree, slot->name) == NULL); node = avl_insert_node(mpl->tree, slot->name); avl_set_node_type(node, A_INDEX); avl_set_node_link(node, (void *)slot); } /* check a token that follows */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_COLON || mpl->token == T_RBRACE) break; else error(mpl, "syntax error in indexing expression"); } /* parse that follows the colon */ if (mpl->token == T_COLON) { get_token(mpl /* : */); code = expression_13(mpl); /* convert the expression to logical type, if necessary */ if (code->type == A_SYMBOLIC) code = make_unary(mpl, O_CVTNUM, code, A_NUMERIC, 0); if (code->type == A_NUMERIC) code = make_unary(mpl, O_CVTLOG, code, A_LOGICAL, 0); /* now the expression must be of logical type */ if (code->type != A_LOGICAL) error(mpl, "expression following colon has invalid type"); xassert(code->dim == 0); domain->code = code; /* the right brace must follow the logical expression */ if (mpl->token != T_RBRACE) error(mpl, "syntax error in indexing expression"); } get_token(mpl /* } */); return domain; } /*---------------------------------------------------------------------- -- close_scope - close scope of indexing expression. -- -- The routine closes the scope of indexing expression specified by its -- domain and thereby makes all dummy indices introduced in the indexing -- expression no longer available for referencing. */ void close_scope(MPL *mpl, DOMAIN *domain) { DOMAIN_BLOCK *block; DOMAIN_SLOT *slot; AVLNODE *node; xassert(domain != NULL); /* remove all dummy indices from the symbolic names table */ for (block = domain->list; block != NULL; block = block->next) { for (slot = block->list; slot != NULL; slot = slot->next) { if (slot->name != NULL) { node = avl_find_node(mpl->tree, slot->name); xassert(node != NULL); xassert(avl_get_node_type(node) == A_INDEX); avl_delete_node(mpl->tree, node); } } } return; } /*---------------------------------------------------------------------- -- iterated_expression - parse iterated expression. -- -- This routine parses primary expression using the syntax: -- -- ::= -- ::= sum -- ::= prod -- ::= min -- ::= max -- ::= exists -- -- ::= forall -- -- ::= setof -- -- Note that parsing "integrand" depends on the iterated operator. */ #if 1 /* 07/IX-2008 */ static void link_up(CODE *code) { /* if we have something like sum{(i+1,j,k-1) in E} x[i,j,k], where i and k are dummy indices defined out of the iterated expression, we should link up pseudo-code for computing i+1 and k-1 to pseudo-code for computing the iterated expression; this is needed to invalidate current value of the iterated expression once i or k have been changed */ DOMAIN_BLOCK *block; DOMAIN_SLOT *slot; for (block = code->arg.loop.domain->list; block != NULL; block = block->next) { for (slot = block->list; slot != NULL; slot = slot->next) { if (slot->code != NULL) { xassert(slot->code->up == NULL); slot->code->up = code; } } } return; } #endif CODE *iterated_expression(MPL *mpl) { CODE *code; OPERANDS arg; int op; char opstr[8]; /* determine operation code */ xassert(mpl->token == T_NAME); if (strcmp(mpl->image, "sum") == 0) op = O_SUM; else if (strcmp(mpl->image, "prod") == 0) op = O_PROD; else if (strcmp(mpl->image, "min") == 0) op = O_MINIMUM; else if (strcmp(mpl->image, "max") == 0) op = O_MAXIMUM; else if (strcmp(mpl->image, "forall") == 0) op = O_FORALL; else if (strcmp(mpl->image, "exists") == 0) op = O_EXISTS; else if (strcmp(mpl->image, "setof") == 0) op = O_SETOF; else error(mpl, "operator %s unknown", mpl->image); strcpy(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); get_token(mpl /* */); /* check the left brace that follows the operator name */ xassert(mpl->token == T_LBRACE); /* parse indexing expression that controls iterating */ arg.loop.domain = indexing_expression(mpl); /* parse "integrand" expression and generate pseudo-code */ switch (op) { case O_SUM: case O_PROD: case O_MINIMUM: case O_MAXIMUM: arg.loop.x = expression_3(mpl); /* convert the integrand to numeric type, if necessary */ if (arg.loop.x->type == A_SYMBOLIC) arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x, A_NUMERIC, 0); /* now the integrand must be of numeric type or linear form (the latter is only allowed for the sum operator) */ if (!(arg.loop.x->type == A_NUMERIC || op == O_SUM && arg.loop.x->type == A_FORMULA)) err: error(mpl, "integrand following %s{...} has invalid type" , opstr); xassert(arg.loop.x->dim == 0); /* generate pseudo-code */ code = make_code(mpl, op, &arg, arg.loop.x->type, 0); break; case O_FORALL: case O_EXISTS: arg.loop.x = expression_12(mpl); /* convert the integrand to logical type, if necessary */ if (arg.loop.x->type == A_SYMBOLIC) arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x, A_NUMERIC, 0); if (arg.loop.x->type == A_NUMERIC) arg.loop.x = make_unary(mpl, O_CVTLOG, arg.loop.x, A_LOGICAL, 0); /* now the integrand must be of logical type */ if (arg.loop.x->type != A_LOGICAL) goto err; xassert(arg.loop.x->dim == 0); /* generate pseudo-code */ code = make_code(mpl, op, &arg, A_LOGICAL, 0); break; case O_SETOF: arg.loop.x = expression_5(mpl); /* convert the integrand to 1-tuple, if necessary */ if (arg.loop.x->type == A_NUMERIC) arg.loop.x = make_unary(mpl, O_CVTSYM, arg.loop.x, A_SYMBOLIC, 0); if (arg.loop.x->type == A_SYMBOLIC) arg.loop.x = make_unary(mpl, O_CVTTUP, arg.loop.x, A_TUPLE, 1); /* now the integrand must be n-tuple */ if (arg.loop.x->type != A_TUPLE) goto err; xassert(arg.loop.x->dim > 0); /* generate pseudo-code */ code = make_code(mpl, op, &arg, A_ELEMSET, arg.loop.x->dim); break; default: xassert(op != op); } /* close the scope of the indexing expression */ close_scope(mpl, arg.loop.domain); #if 1 /* 07/IX-2008 */ link_up(code); #endif return code; } /*---------------------------------------------------------------------- -- domain_arity - determine arity of domain. -- -- This routine returns arity of specified domain, which is number of -- its free dummy indices. */ int domain_arity(MPL *mpl, DOMAIN *domain) { DOMAIN_BLOCK *block; DOMAIN_SLOT *slot; int arity; xassert(mpl == mpl); arity = 0; for (block = domain->list; block != NULL; block = block->next) for (slot = block->list; slot != NULL; slot = slot->next) if (slot->code == NULL) arity++; return arity; } /*---------------------------------------------------------------------- -- set_expression - parse set expression. -- -- This routine parses primary expression using the syntax: -- -- ::= { } -- ::= */ CODE *set_expression(MPL *mpl) { CODE *code; OPERANDS arg; xassert(mpl->token == T_LBRACE); get_token(mpl /* { */); /* check a token that follows the left brace */ if (mpl->token == T_RBRACE) { /* it is the right brace, so the resultant is an empty set of dimension 1 */ arg.list = NULL; /* generate pseudo-code to build the resultant set */ code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, 1); get_token(mpl /* } */); } else { /* the next token begins an indexing expression */ unget_token(mpl); arg.loop.domain = indexing_expression(mpl); arg.loop.x = NULL; /* integrand is not used */ /* close the scope of the indexing expression */ close_scope(mpl, arg.loop.domain); /* generate pseudo-code to build the resultant set */ code = make_code(mpl, O_BUILD, &arg, A_ELEMSET, domain_arity(mpl, arg.loop.domain)); #if 1 /* 07/IX-2008 */ link_up(code); #endif } return code; } /*---------------------------------------------------------------------- -- branched_expression - parse conditional expression. -- -- This routine parses primary expression using the syntax: -- -- ::= -- ::= if then -- ::= if then -- else -- ::= */ CODE *branched_expression(MPL *mpl) { CODE *code, *x, *y, *z; xassert(mpl->token == T_IF); get_token(mpl /* if */); /* parse that follows 'if' */ x = expression_13(mpl); /* convert the expression to logical type, if necessary */ if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); /* now the expression must be of logical type */ if (x->type != A_LOGICAL) error(mpl, "expression following if has invalid type"); xassert(x->dim == 0); /* the keyword 'then' must follow the logical expression */ if (mpl->token != T_THEN) error(mpl, "keyword then missing where expected"); get_token(mpl /* then */); /* parse that follows 'then' and check its type */ y = expression_9(mpl); if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC || y->type == A_ELEMSET || y->type == A_FORMULA)) error(mpl, "expression following then has invalid type"); /* if the expression that follows the keyword 'then' is elemental set, the keyword 'else' cannot be omitted; otherwise else-part is optional */ if (mpl->token != T_ELSE) { if (y->type == A_ELEMSET) error(mpl, "keyword else missing where expected"); z = NULL; goto skip; } get_token(mpl /* else */); /* parse that follow 'else' and check its type */ z = expression_9(mpl); if (!(z->type == A_NUMERIC || z->type == A_SYMBOLIC || z->type == A_ELEMSET || z->type == A_FORMULA)) error(mpl, "expression following else has invalid type"); /* convert to identical types, if necessary */ if (y->type == A_FORMULA || z->type == A_FORMULA) { if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type == A_NUMERIC) y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0); if (z->type == A_SYMBOLIC) z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0); if (z->type == A_NUMERIC) z = make_unary(mpl, O_CVTLFM, z, A_FORMULA, 0); } if (y->type == A_SYMBOLIC || z->type == A_SYMBOLIC) { if (y->type == A_NUMERIC) y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0); if (z->type == A_NUMERIC) z = make_unary(mpl, O_CVTSYM, z, A_SYMBOLIC, 0); } /* now both expressions must have identical types */ if (y->type != z->type) error(mpl, "expressions following then and else have incompati" "ble types"); /* and identical dimensions */ if (y->dim != z->dim) error(mpl, "expressions following then and else have different" " dimensions %d and %d, respectively", y->dim, z->dim); skip: /* generate pseudo-code to perform branching */ code = make_ternary(mpl, O_FORK, x, y, z, y->type, y->dim); return code; } /*---------------------------------------------------------------------- -- primary_expression - parse primary expression. -- -- This routine parses primary expression using the syntax: -- -- ::= -- ::= Infinity -- ::= -- ::= -- ::= -- ::= [ ] -- ::= -- ::= [ ] -- ::= -- ::= [ ] -- ::= ( ) -- ::= ( ) -- ::= -- ::= { } -- ::= -- ::= -- -- For complete list of syntactic rules for see -- comments to the corresponding parsing routines. */ CODE *primary_expression(MPL *mpl) { CODE *code; if (mpl->token == T_NUMBER) { /* parse numeric literal */ code = numeric_literal(mpl); } #if 1 /* 21/VII-2006 */ else if (mpl->token == T_INFINITY) { /* parse "infinity" */ OPERANDS arg; arg.num = DBL_MAX; code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0); get_token(mpl /* Infinity */); } #endif else if (mpl->token == T_STRING) { /* parse string literal */ code = string_literal(mpl); } else if (mpl->token == T_NAME) { int next_token; get_token(mpl /* */); next_token = mpl->token; unget_token(mpl); /* check a token that follows */ switch (next_token) { case T_LBRACKET: /* parse reference to subscripted object */ code = object_reference(mpl); break; case T_LEFT: /* parse reference to built-in function */ code = function_reference(mpl); break; case T_LBRACE: /* parse iterated expression */ code = iterated_expression(mpl); break; default: /* parse reference to unsubscripted object */ code = object_reference(mpl); break; } } else if (mpl->token == T_LEFT) { /* parse parenthesized expression */ code = expression_list(mpl); } else if (mpl->token == T_LBRACE) { /* parse set expression */ code = set_expression(mpl); } else if (mpl->token == T_IF) { /* parse conditional expression */ code = branched_expression(mpl); } else if (is_reserved(mpl)) { /* other reserved keywords cannot be used here */ error(mpl, "invalid use of reserved keyword %s", mpl->image); } else error(mpl, "syntax error in expression"); return code; } /*---------------------------------------------------------------------- -- error_preceding - raise error if preceding operand has wrong type. -- -- This routine is called to raise error if operand that precedes some -- infix operator has invalid type. */ void error_preceding(MPL *mpl, char *opstr) { error(mpl, "operand preceding %s has invalid type", opstr); /* no return */ } /*---------------------------------------------------------------------- -- error_following - raise error if following operand has wrong type. -- -- This routine is called to raise error if operand that follows some -- infix operator has invalid type. */ void error_following(MPL *mpl, char *opstr) { error(mpl, "operand following %s has invalid type", opstr); /* no return */ } /*---------------------------------------------------------------------- -- error_dimension - raise error if operands have different dimension. -- -- This routine is called to raise error if two operands of some infix -- operator have different dimension. */ void error_dimension(MPL *mpl, char *opstr, int dim1, int dim2) { error(mpl, "operands preceding and following %s have different di" "mensions %d and %d, respectively", opstr, dim1, dim2); /* no return */ } /*---------------------------------------------------------------------- -- expression_0 - parse expression of level 0. -- -- This routine parses expression of level 0 using the syntax: -- -- ::= */ CODE *expression_0(MPL *mpl) { CODE *code; code = primary_expression(mpl); return code; } /*---------------------------------------------------------------------- -- expression_1 - parse expression of level 1. -- -- This routine parses expression of level 1 using the syntax: -- -- ::= -- ::= -- ::= -- ::= ^ | ** */ CODE *expression_1(MPL *mpl) { CODE *x, *y; char opstr[8]; x = expression_0(mpl); if (mpl->token == T_POWER) { strcpy(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type != A_NUMERIC) error_preceding(mpl, opstr); get_token(mpl /* ^ | ** */); if (mpl->token == T_PLUS || mpl->token == T_MINUS) y = expression_2(mpl); else y = expression_1(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type != A_NUMERIC) error_following(mpl, opstr); x = make_binary(mpl, O_POWER, x, y, A_NUMERIC, 0); } return x; } /*---------------------------------------------------------------------- -- expression_2 - parse expression of level 2. -- -- This routine parses expression of level 2 using the syntax: -- -- ::= -- ::= + -- ::= - */ CODE *expression_2(MPL *mpl) { CODE *x; if (mpl->token == T_PLUS) { get_token(mpl /* + */); x = expression_1(mpl); if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) error_following(mpl, "+"); x = make_unary(mpl, O_PLUS, x, x->type, 0); } else if (mpl->token == T_MINUS) { get_token(mpl /* - */); x = expression_1(mpl); if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) error_following(mpl, "-"); x = make_unary(mpl, O_MINUS, x, x->type, 0); } else x = expression_1(mpl); return x; } /*---------------------------------------------------------------------- -- expression_3 - parse expression of level 3. -- -- This routine parses expression of level 3 using the syntax: -- -- ::= -- ::= * -- ::= / -- ::= div -- ::= mod */ CODE *expression_3(MPL *mpl) { CODE *x, *y; x = expression_2(mpl); for (;;) { if (mpl->token == T_ASTERISK) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) error_preceding(mpl, "*"); get_token(mpl /* * */); y = expression_2(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (!(y->type == A_NUMERIC || y->type == A_FORMULA)) error_following(mpl, "*"); if (x->type == A_FORMULA && y->type == A_FORMULA) error(mpl, "multiplication of linear forms not allowed"); if (x->type == A_NUMERIC && y->type == A_NUMERIC) x = make_binary(mpl, O_MUL, x, y, A_NUMERIC, 0); else x = make_binary(mpl, O_MUL, x, y, A_FORMULA, 0); } else if (mpl->token == T_SLASH) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) error_preceding(mpl, "/"); get_token(mpl /* / */); y = expression_2(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type != A_NUMERIC) error_following(mpl, "/"); if (x->type == A_NUMERIC) x = make_binary(mpl, O_DIV, x, y, A_NUMERIC, 0); else x = make_binary(mpl, O_DIV, x, y, A_FORMULA, 0); } else if (mpl->token == T_DIV) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type != A_NUMERIC) error_preceding(mpl, "div"); get_token(mpl /* div */); y = expression_2(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type != A_NUMERIC) error_following(mpl, "div"); x = make_binary(mpl, O_IDIV, x, y, A_NUMERIC, 0); } else if (mpl->token == T_MOD) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type != A_NUMERIC) error_preceding(mpl, "mod"); get_token(mpl /* mod */); y = expression_2(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type != A_NUMERIC) error_following(mpl, "mod"); x = make_binary(mpl, O_MOD, x, y, A_NUMERIC, 0); } else break; } return x; } /*---------------------------------------------------------------------- -- expression_4 - parse expression of level 4. -- -- This routine parses expression of level 4 using the syntax: -- -- ::= -- ::= + -- ::= - -- ::= less */ CODE *expression_4(MPL *mpl) { CODE *x, *y; x = expression_3(mpl); for (;;) { if (mpl->token == T_PLUS) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) error_preceding(mpl, "+"); get_token(mpl /* + */); y = expression_3(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (!(y->type == A_NUMERIC || y->type == A_FORMULA)) error_following(mpl, "+"); if (x->type == A_NUMERIC && y->type == A_FORMULA) x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0); if (x->type == A_FORMULA && y->type == A_NUMERIC) y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0); x = make_binary(mpl, O_ADD, x, y, x->type, 0); } else if (mpl->token == T_MINUS) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (!(x->type == A_NUMERIC || x->type == A_FORMULA)) error_preceding(mpl, "-"); get_token(mpl /* - */); y = expression_3(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (!(y->type == A_NUMERIC || y->type == A_FORMULA)) error_following(mpl, "-"); if (x->type == A_NUMERIC && y->type == A_FORMULA) x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0); if (x->type == A_FORMULA && y->type == A_NUMERIC) y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0); x = make_binary(mpl, O_SUB, x, y, x->type, 0); } else if (mpl->token == T_LESS) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type != A_NUMERIC) error_preceding(mpl, "less"); get_token(mpl /* less */); y = expression_3(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type != A_NUMERIC) error_following(mpl, "less"); x = make_binary(mpl, O_LESS, x, y, A_NUMERIC, 0); } else break; } return x; } /*---------------------------------------------------------------------- -- expression_5 - parse expression of level 5. -- -- This routine parses expression of level 5 using the syntax: -- -- ::= -- ::= & */ CODE *expression_5(MPL *mpl) { CODE *x, *y; x = expression_4(mpl); for (;;) { if (mpl->token == T_CONCAT) { if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); if (x->type != A_SYMBOLIC) error_preceding(mpl, "&"); get_token(mpl /* & */); y = expression_4(mpl); if (y->type == A_NUMERIC) y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0); if (y->type != A_SYMBOLIC) error_following(mpl, "&"); x = make_binary(mpl, O_CONCAT, x, y, A_SYMBOLIC, 0); } else break; } return x; } /*---------------------------------------------------------------------- -- expression_6 - parse expression of level 6. -- -- This routine parses expression of level 6 using the syntax: -- -- ::= -- ::= .. -- ::= .. by -- */ CODE *expression_6(MPL *mpl) { CODE *x, *y, *z; x = expression_5(mpl); if (mpl->token == T_DOTS) { if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type != A_NUMERIC) error_preceding(mpl, ".."); get_token(mpl /* .. */); y = expression_5(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type != A_NUMERIC) error_following(mpl, ".."); if (mpl->token == T_BY) { get_token(mpl /* by */); z = expression_5(mpl); if (z->type == A_SYMBOLIC) z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0); if (z->type != A_NUMERIC) error_following(mpl, "by"); } else z = NULL; x = make_ternary(mpl, O_DOTS, x, y, z, A_ELEMSET, 1); } return x; } /*---------------------------------------------------------------------- -- expression_7 - parse expression of level 7. -- -- This routine parses expression of level 7 using the syntax: -- -- ::= -- ::= cross */ CODE *expression_7(MPL *mpl) { CODE *x, *y; x = expression_6(mpl); for (;;) { if (mpl->token == T_CROSS) { if (x->type != A_ELEMSET) error_preceding(mpl, "cross"); get_token(mpl /* cross */); y = expression_6(mpl); if (y->type != A_ELEMSET) error_following(mpl, "cross"); x = make_binary(mpl, O_CROSS, x, y, A_ELEMSET, x->dim + y->dim); } else break; } return x; } /*---------------------------------------------------------------------- -- expression_8 - parse expression of level 8. -- -- This routine parses expression of level 8 using the syntax: -- -- ::= -- ::= inter */ CODE *expression_8(MPL *mpl) { CODE *x, *y; x = expression_7(mpl); for (;;) { if (mpl->token == T_INTER) { if (x->type != A_ELEMSET) error_preceding(mpl, "inter"); get_token(mpl /* inter */); y = expression_7(mpl); if (y->type != A_ELEMSET) error_following(mpl, "inter"); if (x->dim != y->dim) error_dimension(mpl, "inter", x->dim, y->dim); x = make_binary(mpl, O_INTER, x, y, A_ELEMSET, x->dim); } else break; } return x; } /*---------------------------------------------------------------------- -- expression_9 - parse expression of level 9. -- -- This routine parses expression of level 9 using the syntax: -- -- ::= -- ::= union -- ::= diff -- ::= symdiff */ CODE *expression_9(MPL *mpl) { CODE *x, *y; x = expression_8(mpl); for (;;) { if (mpl->token == T_UNION) { if (x->type != A_ELEMSET) error_preceding(mpl, "union"); get_token(mpl /* union */); y = expression_8(mpl); if (y->type != A_ELEMSET) error_following(mpl, "union"); if (x->dim != y->dim) error_dimension(mpl, "union", x->dim, y->dim); x = make_binary(mpl, O_UNION, x, y, A_ELEMSET, x->dim); } else if (mpl->token == T_DIFF) { if (x->type != A_ELEMSET) error_preceding(mpl, "diff"); get_token(mpl /* diff */); y = expression_8(mpl); if (y->type != A_ELEMSET) error_following(mpl, "diff"); if (x->dim != y->dim) error_dimension(mpl, "diff", x->dim, y->dim); x = make_binary(mpl, O_DIFF, x, y, A_ELEMSET, x->dim); } else if (mpl->token == T_SYMDIFF) { if (x->type != A_ELEMSET) error_preceding(mpl, "symdiff"); get_token(mpl /* symdiff */); y = expression_8(mpl); if (y->type != A_ELEMSET) error_following(mpl, "symdiff"); if (x->dim != y->dim) error_dimension(mpl, "symdiff", x->dim, y->dim); x = make_binary(mpl, O_SYMDIFF, x, y, A_ELEMSET, x->dim); } else break; } return x; } /*---------------------------------------------------------------------- -- expression_10 - parse expression of level 10. -- -- This routine parses expression of level 10 using the syntax: -- -- ::= -- ::= -- ::= < | <= | = | == | >= | > | <> | != | in | not in | ! in | -- within | not within | ! within */ CODE *expression_10(MPL *mpl) { CODE *x, *y; int op = -1; char opstr[16]; x = expression_9(mpl); strcpy(opstr, ""); switch (mpl->token) { case T_LT: op = O_LT; break; case T_LE: op = O_LE; break; case T_EQ: op = O_EQ; break; case T_GE: op = O_GE; break; case T_GT: op = O_GT; break; case T_NE: op = O_NE; break; case T_IN: op = O_IN; break; case T_WITHIN: op = O_WITHIN; break; case T_NOT: strcpy(opstr, mpl->image); get_token(mpl /* not | ! */); if (mpl->token == T_IN) op = O_NOTIN; else if (mpl->token == T_WITHIN) op = O_NOTWITHIN; else error(mpl, "invalid use of %s", opstr); strcat(opstr, " "); break; default: goto done; } strcat(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); switch (op) { case O_EQ: case O_NE: #if 1 /* 02/VIII-2008 */ case O_LT: case O_LE: case O_GT: case O_GE: #endif if (!(x->type == A_NUMERIC || x->type == A_SYMBOLIC)) error_preceding(mpl, opstr); get_token(mpl /* */); y = expression_9(mpl); if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC)) error_following(mpl, opstr); if (x->type == A_NUMERIC && y->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); if (x->type == A_SYMBOLIC && y->type == A_NUMERIC) y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0); x = make_binary(mpl, op, x, y, A_LOGICAL, 0); break; #if 0 /* 02/VIII-2008 */ case O_LT: case O_LE: case O_GT: case O_GE: if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type != A_NUMERIC) error_preceding(mpl, opstr); get_token(mpl /* */); y = expression_9(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type != A_NUMERIC) error_following(mpl, opstr); x = make_binary(mpl, op, x, y, A_LOGICAL, 0); break; #endif case O_IN: case O_NOTIN: if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0); if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTTUP, x, A_TUPLE, 1); if (x->type != A_TUPLE) error_preceding(mpl, opstr); get_token(mpl /* */); y = expression_9(mpl); if (y->type != A_ELEMSET) error_following(mpl, opstr); if (x->dim != y->dim) error_dimension(mpl, opstr, x->dim, y->dim); x = make_binary(mpl, op, x, y, A_LOGICAL, 0); break; case O_WITHIN: case O_NOTWITHIN: if (x->type != A_ELEMSET) error_preceding(mpl, opstr); get_token(mpl /* */); y = expression_9(mpl); if (y->type != A_ELEMSET) error_following(mpl, opstr); if (x->dim != y->dim) error_dimension(mpl, opstr, x->dim, y->dim); x = make_binary(mpl, op, x, y, A_LOGICAL, 0); break; default: xassert(op != op); } done: return x; } /*---------------------------------------------------------------------- -- expression_11 - parse expression of level 11. -- -- This routine parses expression of level 11 using the syntax: -- -- ::= -- ::= not -- ::= ! */ CODE *expression_11(MPL *mpl) { CODE *x; char opstr[8]; if (mpl->token == T_NOT) { strcpy(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); get_token(mpl /* not | ! */); x = expression_10(mpl); if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); if (x->type != A_LOGICAL) error_following(mpl, opstr); x = make_unary(mpl, O_NOT, x, A_LOGICAL, 0); } else x = expression_10(mpl); return x; } /*---------------------------------------------------------------------- -- expression_12 - parse expression of level 12. -- -- This routine parses expression of level 12 using the syntax: -- -- ::= -- ::= and -- ::= && */ CODE *expression_12(MPL *mpl) { CODE *x, *y; char opstr[8]; x = expression_11(mpl); for (;;) { if (mpl->token == T_AND) { strcpy(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); if (x->type != A_LOGICAL) error_preceding(mpl, opstr); get_token(mpl /* and | && */); y = expression_11(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type == A_NUMERIC) y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0); if (y->type != A_LOGICAL) error_following(mpl, opstr); x = make_binary(mpl, O_AND, x, y, A_LOGICAL, 0); } else break; } return x; } /*---------------------------------------------------------------------- -- expression_13 - parse expression of level 13. -- -- This routine parses expression of level 13 using the syntax: -- -- ::= -- ::= or -- ::= || */ CODE *expression_13(MPL *mpl) { CODE *x, *y; char opstr[8]; x = expression_12(mpl); for (;;) { if (mpl->token == T_OR) { strcpy(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); if (x->type == A_SYMBOLIC) x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0); if (x->type == A_NUMERIC) x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0); if (x->type != A_LOGICAL) error_preceding(mpl, opstr); get_token(mpl /* or | || */); y = expression_12(mpl); if (y->type == A_SYMBOLIC) y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0); if (y->type == A_NUMERIC) y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0); if (y->type != A_LOGICAL) error_following(mpl, opstr); x = make_binary(mpl, O_OR, x, y, A_LOGICAL, 0); } else break; } return x; } /*---------------------------------------------------------------------- -- set_statement - parse set statement. -- -- This routine parses set statement using the syntax: -- -- ::= set -- ; -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= , dimen -- ::= , within -- ::= , := -- ::= , default -- -- Commae in are optional and may be omitted anywhere. */ SET *set_statement(MPL *mpl) { SET *set; int dimen_used = 0; xassert(is_keyword(mpl, "set")); get_token(mpl /* set */); /* symbolic name must follow the keyword 'set' */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "symbolic name missing where expected"); /* there must be no other object with the same name */ if (avl_find_node(mpl->tree, mpl->image) != NULL) error(mpl, "%s multiply declared", mpl->image); /* create model set */ set = alloc(SET); set->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(set->name, mpl->image); set->alias = NULL; set->dim = 0; set->domain = NULL; set->dimen = 0; set->within = NULL; set->assign = NULL; set->option = NULL; set->gadget = NULL; set->data = 0; set->array = NULL; get_token(mpl /* */); /* parse optional alias */ if (mpl->token == T_STRING) { set->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(set->alias, mpl->image); get_token(mpl /* */); } /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { set->domain = indexing_expression(mpl); set->dim = domain_arity(mpl, set->domain); } /* include the set name in the symbolic names table */ { AVLNODE *node; node = avl_insert_node(mpl->tree, set->name); avl_set_node_type(node, A_SET); avl_set_node_link(node, (void *)set); } /* parse the list of optional attributes */ for (;;) { if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_SEMICOLON) break; if (is_keyword(mpl, "dimen")) { /* dimension of set members */ int dimen; get_token(mpl /* dimen */); if (!(mpl->token == T_NUMBER && 1.0 <= mpl->value && mpl->value <= 20.0 && floor(mpl->value) == mpl->value)) error(mpl, "dimension must be integer between 1 and 20"); dimen = (int)(mpl->value + 0.5); if (dimen_used) error(mpl, "at most one dimension attribute allowed"); if (set->dimen > 0) error(mpl, "dimension %d conflicts with dimension %d alr" "eady determined", dimen, set->dimen); set->dimen = dimen; dimen_used = 1; get_token(mpl /* */); } else if (mpl->token == T_WITHIN || mpl->token == T_IN) { /* restricting superset */ WITHIN *within, *temp; if (mpl->token == T_IN && !mpl->as_within) { warning(mpl, "keyword in understood as within"); mpl->as_within = 1; } get_token(mpl /* within */); /* create new restricting superset list entry and append it to the within-list */ within = alloc(WITHIN); within->code = NULL; within->next = NULL; if (set->within == NULL) set->within = within; else { for (temp = set->within; temp->next != NULL; temp = temp->next); temp->next = within; } /* parse an expression that follows 'within' */ within->code = expression_9(mpl); if (within->code->type != A_ELEMSET) error(mpl, "expression following within has invalid type" ); xassert(within->code->dim > 0); /* check/set dimension of set members */ if (set->dimen == 0) set->dimen = within->code->dim; if (set->dimen != within->code->dim) error(mpl, "set expression following within must have di" "mension %d rather than %d", set->dimen, within->code->dim); } else if (mpl->token == T_ASSIGN) { /* assignment expression */ if (!(set->assign == NULL && set->option == NULL && set->gadget == NULL)) err: error(mpl, "at most one := or default/data allowed"); get_token(mpl /* := */); /* parse an expression that follows ':=' */ set->assign = expression_9(mpl); if (set->assign->type != A_ELEMSET) error(mpl, "expression following := has invalid type"); xassert(set->assign->dim > 0); /* check/set dimension of set members */ if (set->dimen == 0) set->dimen = set->assign->dim; if (set->dimen != set->assign->dim) error(mpl, "set expression following := must have dimens" "ion %d rather than %d", set->dimen, set->assign->dim); } else if (is_keyword(mpl, "default")) { /* expression for default value */ if (!(set->assign == NULL && set->option == NULL)) goto err; get_token(mpl /* := */); /* parse an expression that follows 'default' */ set->option = expression_9(mpl); if (set->option->type != A_ELEMSET) error(mpl, "expression following default has invalid typ" "e"); xassert(set->option->dim > 0); /* check/set dimension of set members */ if (set->dimen == 0) set->dimen = set->option->dim; if (set->dimen != set->option->dim) error(mpl, "set expression following default must have d" "imension %d rather than %d", set->dimen, set->option->dim); } #if 1 /* 12/XII-2008 */ else if (is_keyword(mpl, "data")) { /* gadget to initialize the set by data from plain set */ GADGET *gadget; AVLNODE *node; int i, k, fff[20]; if (!(set->assign == NULL && set->gadget == NULL)) goto err; get_token(mpl /* data */); set->gadget = gadget = alloc(GADGET); /* set name must follow the keyword 'data' */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "set name missing where expected"); /* find the set in the symbolic name table */ node = avl_find_node(mpl->tree, mpl->image); if (node == NULL) error(mpl, "%s not defined", mpl->image); if (avl_get_node_type(node) != A_SET) err1: error(mpl, "%s not a plain set", mpl->image); gadget->set = avl_get_node_link(node); if (gadget->set->dim != 0) goto err1; if (gadget->set == set) error(mpl, "set cannot be initialized by itself"); /* check and set dimensions */ if (set->dim >= gadget->set->dimen) err2: error(mpl, "dimension of %s too small", mpl->image); if (set->dimen == 0) set->dimen = gadget->set->dimen - set->dim; if (set->dim + set->dimen > gadget->set->dimen) goto err2; else if (set->dim + set->dimen < gadget->set->dimen) error(mpl, "dimension of %s too big", mpl->image); get_token(mpl /* set name */); /* left parenthesis must follow the set name */ if (mpl->token == T_LEFT) get_token(mpl /* ( */); else error(mpl, "left parenthesis missing where expected"); /* parse permutation of component numbers */ for (k = 0; k < gadget->set->dimen; k++) fff[k] = 0; k = 0; for (;;) { if (mpl->token != T_NUMBER) error(mpl, "component number missing where expected"); if (str2int(mpl->image, &i) != 0) err3: error(mpl, "component number must be integer between " "1 and %d", gadget->set->dimen); if (!(1 <= i && i <= gadget->set->dimen)) goto err3; if (fff[i-1] != 0) error(mpl, "component %d multiply specified", i); gadget->ind[k++] = i, fff[i-1] = 1; xassert(k <= gadget->set->dimen); get_token(mpl /* number */); if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_RIGHT) break; else error(mpl, "syntax error in data attribute"); } if (k < gadget->set->dimen) error(mpl, "there are must be %d components rather than " "%d", gadget->set->dimen, k); get_token(mpl /* ) */); } #endif else error(mpl, "syntax error in set statement"); } /* close the domain scope */ if (set->domain != NULL) close_scope(mpl, set->domain); /* if dimension of set members is still unknown, set it to 1 */ if (set->dimen == 0) set->dimen = 1; /* the set statement has been completely parsed */ xassert(mpl->token == T_SEMICOLON); get_token(mpl /* ; */); return set; } /*---------------------------------------------------------------------- -- parameter_statement - parse parameter statement. -- -- This routine parses parameter statement using the syntax: -- -- ::= param -- ; -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= , integer -- ::= , binary -- ::= , symbolic -- ::= , -- ::= , in -- ::= , := -- ::= , default -- ::= < | <= | = | == | >= | > | <> | != -- -- Commae in are optional and may be omitted anywhere. */ PARAMETER *parameter_statement(MPL *mpl) { PARAMETER *par; int integer_used = 0, binary_used = 0, symbolic_used = 0; xassert(is_keyword(mpl, "param")); get_token(mpl /* param */); /* symbolic name must follow the keyword 'param' */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "symbolic name missing where expected"); /* there must be no other object with the same name */ if (avl_find_node(mpl->tree, mpl->image) != NULL) error(mpl, "%s multiply declared", mpl->image); /* create model parameter */ par = alloc(PARAMETER); par->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(par->name, mpl->image); par->alias = NULL; par->dim = 0; par->domain = NULL; par->type = A_NUMERIC; par->cond = NULL; par->in = NULL; par->assign = NULL; par->option = NULL; par->data = 0; par->defval = NULL; par->array = NULL; get_token(mpl /* */); /* parse optional alias */ if (mpl->token == T_STRING) { par->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(par->alias, mpl->image); get_token(mpl /* */); } /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { par->domain = indexing_expression(mpl); par->dim = domain_arity(mpl, par->domain); } /* include the parameter name in the symbolic names table */ { AVLNODE *node; node = avl_insert_node(mpl->tree, par->name); avl_set_node_type(node, A_PARAMETER); avl_set_node_link(node, (void *)par); } /* parse the list of optional attributes */ for (;;) { if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_SEMICOLON) break; if (is_keyword(mpl, "integer")) { if (integer_used) error(mpl, "at most one integer allowed"); if (par->type == A_SYMBOLIC) error(mpl, "symbolic parameter cannot be integer"); if (par->type != A_BINARY) par->type = A_INTEGER; integer_used = 1; get_token(mpl /* integer */); } else if (is_keyword(mpl, "binary")) bin: { if (binary_used) error(mpl, "at most one binary allowed"); if (par->type == A_SYMBOLIC) error(mpl, "symbolic parameter cannot be binary"); par->type = A_BINARY; binary_used = 1; get_token(mpl /* binary */); } else if (is_keyword(mpl, "logical")) { if (!mpl->as_binary) { warning(mpl, "keyword logical understood as binary"); mpl->as_binary = 1; } goto bin; } else if (is_keyword(mpl, "symbolic")) { if (symbolic_used) error(mpl, "at most one symbolic allowed"); if (par->type != A_NUMERIC) error(mpl, "integer or binary parameter cannot be symbol" "ic"); /* the parameter may be referenced from expressions given in the same parameter declaration, so its type must be completed before parsing that expressions */ if (!(par->cond == NULL && par->in == NULL && par->assign == NULL && par->option == NULL)) error(mpl, "keyword symbolic must precede any other para" "meter attributes"); par->type = A_SYMBOLIC; symbolic_used = 1; get_token(mpl /* symbolic */); } else if (mpl->token == T_LT || mpl->token == T_LE || mpl->token == T_EQ || mpl->token == T_GE || mpl->token == T_GT || mpl->token == T_NE) { /* restricting condition */ CONDITION *cond, *temp; char opstr[8]; /* create new restricting condition list entry and append it to the conditions list */ cond = alloc(CONDITION); switch (mpl->token) { case T_LT: cond->rho = O_LT, strcpy(opstr, mpl->image); break; case T_LE: cond->rho = O_LE, strcpy(opstr, mpl->image); break; case T_EQ: cond->rho = O_EQ, strcpy(opstr, mpl->image); break; case T_GE: cond->rho = O_GE, strcpy(opstr, mpl->image); break; case T_GT: cond->rho = O_GT, strcpy(opstr, mpl->image); break; case T_NE: cond->rho = O_NE, strcpy(opstr, mpl->image); break; default: xassert(mpl->token != mpl->token); } xassert(strlen(opstr) < sizeof(opstr)); cond->code = NULL; cond->next = NULL; if (par->cond == NULL) par->cond = cond; else { for (temp = par->cond; temp->next != NULL; temp = temp->next); temp->next = cond; } #if 0 /* 13/VIII-2008 */ if (par->type == A_SYMBOLIC && !(cond->rho == O_EQ || cond->rho == O_NE)) error(mpl, "inequality restriction not allowed"); #endif get_token(mpl /* rho */); /* parse an expression that follows relational operator */ cond->code = expression_5(mpl); if (!(cond->code->type == A_NUMERIC || cond->code->type == A_SYMBOLIC)) error(mpl, "expression following %s has invalid type", opstr); xassert(cond->code->dim == 0); /* convert to the parameter type, if necessary */ if (par->type != A_SYMBOLIC && cond->code->type == A_SYMBOLIC) cond->code = make_unary(mpl, O_CVTNUM, cond->code, A_NUMERIC, 0); if (par->type == A_SYMBOLIC && cond->code->type != A_SYMBOLIC) cond->code = make_unary(mpl, O_CVTSYM, cond->code, A_SYMBOLIC, 0); } else if (mpl->token == T_IN || mpl->token == T_WITHIN) { /* restricting superset */ WITHIN *in, *temp; if (mpl->token == T_WITHIN && !mpl->as_in) { warning(mpl, "keyword within understood as in"); mpl->as_in = 1; } get_token(mpl /* in */); /* create new restricting superset list entry and append it to the in-list */ in = alloc(WITHIN); in->code = NULL; in->next = NULL; if (par->in == NULL) par->in = in; else { for (temp = par->in; temp->next != NULL; temp = temp->next); temp->next = in; } /* parse an expression that follows 'in' */ in->code = expression_9(mpl); if (in->code->type != A_ELEMSET) error(mpl, "expression following in has invalid type"); xassert(in->code->dim > 0); if (in->code->dim != 1) error(mpl, "set expression following in must have dimens" "ion 1 rather than %d", in->code->dim); } else if (mpl->token == T_ASSIGN) { /* assignment expression */ if (!(par->assign == NULL && par->option == NULL)) err: error(mpl, "at most one := or default allowed"); get_token(mpl /* := */); /* parse an expression that follows ':=' */ par->assign = expression_5(mpl); /* the expression must be of numeric/symbolic type */ if (!(par->assign->type == A_NUMERIC || par->assign->type == A_SYMBOLIC)) error(mpl, "expression following := has invalid type"); xassert(par->assign->dim == 0); /* convert to the parameter type, if necessary */ if (par->type != A_SYMBOLIC && par->assign->type == A_SYMBOLIC) par->assign = make_unary(mpl, O_CVTNUM, par->assign, A_NUMERIC, 0); if (par->type == A_SYMBOLIC && par->assign->type != A_SYMBOLIC) par->assign = make_unary(mpl, O_CVTSYM, par->assign, A_SYMBOLIC, 0); } else if (is_keyword(mpl, "default")) { /* expression for default value */ if (!(par->assign == NULL && par->option == NULL)) goto err; get_token(mpl /* default */); /* parse an expression that follows 'default' */ par->option = expression_5(mpl); if (!(par->option->type == A_NUMERIC || par->option->type == A_SYMBOLIC)) error(mpl, "expression following default has invalid typ" "e"); xassert(par->option->dim == 0); /* convert to the parameter type, if necessary */ if (par->type != A_SYMBOLIC && par->option->type == A_SYMBOLIC) par->option = make_unary(mpl, O_CVTNUM, par->option, A_NUMERIC, 0); if (par->type == A_SYMBOLIC && par->option->type != A_SYMBOLIC) par->option = make_unary(mpl, O_CVTSYM, par->option, A_SYMBOLIC, 0); } else error(mpl, "syntax error in parameter statement"); } /* close the domain scope */ if (par->domain != NULL) close_scope(mpl, par->domain); /* the parameter statement has been completely parsed */ xassert(mpl->token == T_SEMICOLON); get_token(mpl /* ; */); return par; } /*---------------------------------------------------------------------- -- variable_statement - parse variable statement. -- -- This routine parses variable statement using the syntax: -- -- ::= var -- ; -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= , integer -- ::= , binary -- ::= , -- ::= >= | <= | = | == -- -- Commae in are optional and may be omitted anywhere. */ VARIABLE *variable_statement(MPL *mpl) { VARIABLE *var; int integer_used = 0, binary_used = 0; xassert(is_keyword(mpl, "var")); if (mpl->flag_s) error(mpl, "variable statement must precede solve statement"); get_token(mpl /* var */); /* symbolic name must follow the keyword 'var' */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "symbolic name missing where expected"); /* there must be no other object with the same name */ if (avl_find_node(mpl->tree, mpl->image) != NULL) error(mpl, "%s multiply declared", mpl->image); /* create model variable */ var = alloc(VARIABLE); var->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(var->name, mpl->image); var->alias = NULL; var->dim = 0; var->domain = NULL; var->type = A_NUMERIC; var->lbnd = NULL; var->ubnd = NULL; var->array = NULL; get_token(mpl /* */); /* parse optional alias */ if (mpl->token == T_STRING) { var->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(var->alias, mpl->image); get_token(mpl /* */); } /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { var->domain = indexing_expression(mpl); var->dim = domain_arity(mpl, var->domain); } /* include the variable name in the symbolic names table */ { AVLNODE *node; node = avl_insert_node(mpl->tree, var->name); avl_set_node_type(node, A_VARIABLE); avl_set_node_link(node, (void *)var); } /* parse the list of optional attributes */ for (;;) { if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_SEMICOLON) break; if (is_keyword(mpl, "integer")) { if (integer_used) error(mpl, "at most one integer allowed"); if (var->type != A_BINARY) var->type = A_INTEGER; integer_used = 1; get_token(mpl /* integer */); } else if (is_keyword(mpl, "binary")) bin: { if (binary_used) error(mpl, "at most one binary allowed"); var->type = A_BINARY; binary_used = 1; get_token(mpl /* binary */); } else if (is_keyword(mpl, "logical")) { if (!mpl->as_binary) { warning(mpl, "keyword logical understood as binary"); mpl->as_binary = 1; } goto bin; } else if (is_keyword(mpl, "symbolic")) error(mpl, "variable cannot be symbolic"); else if (mpl->token == T_GE) { /* lower bound */ if (var->lbnd != NULL) { if (var->lbnd == var->ubnd) error(mpl, "both fixed value and lower bound not allo" "wed"); else error(mpl, "at most one lower bound allowed"); } get_token(mpl /* >= */); /* parse an expression that specifies the lower bound */ var->lbnd = expression_5(mpl); if (var->lbnd->type == A_SYMBOLIC) var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd, A_NUMERIC, 0); if (var->lbnd->type != A_NUMERIC) error(mpl, "expression following >= has invalid type"); xassert(var->lbnd->dim == 0); } else if (mpl->token == T_LE) { /* upper bound */ if (var->ubnd != NULL) { if (var->ubnd == var->lbnd) error(mpl, "both fixed value and upper bound not allo" "wed"); else error(mpl, "at most one upper bound allowed"); } get_token(mpl /* <= */); /* parse an expression that specifies the upper bound */ var->ubnd = expression_5(mpl); if (var->ubnd->type == A_SYMBOLIC) var->ubnd = make_unary(mpl, O_CVTNUM, var->ubnd, A_NUMERIC, 0); if (var->ubnd->type != A_NUMERIC) error(mpl, "expression following <= has invalid type"); xassert(var->ubnd->dim == 0); } else if (mpl->token == T_EQ) { /* fixed value */ char opstr[8]; if (!(var->lbnd == NULL && var->ubnd == NULL)) { if (var->lbnd == var->ubnd) error(mpl, "at most one fixed value allowed"); else if (var->lbnd != NULL) error(mpl, "both lower bound and fixed value not allo" "wed"); else error(mpl, "both upper bound and fixed value not allo" "wed"); } strcpy(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); get_token(mpl /* = | == */); /* parse an expression that specifies the fixed value */ var->lbnd = expression_5(mpl); if (var->lbnd->type == A_SYMBOLIC) var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd, A_NUMERIC, 0); if (var->lbnd->type != A_NUMERIC) error(mpl, "expression following %s has invalid type", opstr); xassert(var->lbnd->dim == 0); /* indicate that the variable is fixed, not bounded */ var->ubnd = var->lbnd; } else if (mpl->token == T_LT || mpl->token == T_GT || mpl->token == T_NE) error(mpl, "strict bound not allowed"); else error(mpl, "syntax error in variable statement"); } /* close the domain scope */ if (var->domain != NULL) close_scope(mpl, var->domain); /* the variable statement has been completely parsed */ xassert(mpl->token == T_SEMICOLON); get_token(mpl /* ; */); return var; } /*---------------------------------------------------------------------- -- constraint_statement - parse constraint statement. -- -- This routine parses constraint statement using the syntax: -- -- ::= -- : ; -- ::= -- ::= subject to -- ::= subj to -- ::= s.t. -- ::= -- ::= -- ::= -- ::= -- ::= , >= -- ::= , <= -- ::= , = -- ::= , <= , <= -- ::= , >= , >= -- ::= -- -- Commae in are optional and may be omitted anywhere. */ CONSTRAINT *constraint_statement(MPL *mpl) { CONSTRAINT *con; CODE *first, *second, *third; int rho; char opstr[8]; if (mpl->flag_s) error(mpl, "constraint statement must precede solve statement") ; if (is_keyword(mpl, "subject")) { get_token(mpl /* subject */); if (!is_keyword(mpl, "to")) error(mpl, "keyword subject to incomplete"); get_token(mpl /* to */); } else if (is_keyword(mpl, "subj")) { get_token(mpl /* subj */); if (!is_keyword(mpl, "to")) error(mpl, "keyword subj to incomplete"); get_token(mpl /* to */); } else if (mpl->token == T_SPTP) get_token(mpl /* s.t. */); /* the current token must be symbolic name of constraint */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "symbolic name missing where expected"); /* there must be no other object with the same name */ if (avl_find_node(mpl->tree, mpl->image) != NULL) error(mpl, "%s multiply declared", mpl->image); /* create model constraint */ con = alloc(CONSTRAINT); con->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(con->name, mpl->image); con->alias = NULL; con->dim = 0; con->domain = NULL; con->type = A_CONSTRAINT; con->code = NULL; con->lbnd = NULL; con->ubnd = NULL; con->array = NULL; get_token(mpl /* */); /* parse optional alias */ if (mpl->token == T_STRING) { con->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(con->alias, mpl->image); get_token(mpl /* */); } /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { con->domain = indexing_expression(mpl); con->dim = domain_arity(mpl, con->domain); } /* include the constraint name in the symbolic names table */ { AVLNODE *node; node = avl_insert_node(mpl->tree, con->name); avl_set_node_type(node, A_CONSTRAINT); avl_set_node_link(node, (void *)con); } /* the colon must precede the first expression */ if (mpl->token != T_COLON) error(mpl, "colon missing where expected"); get_token(mpl /* : */); /* parse the first expression */ first = expression_5(mpl); if (first->type == A_SYMBOLIC) first = make_unary(mpl, O_CVTNUM, first, A_NUMERIC, 0); if (!(first->type == A_NUMERIC || first->type == A_FORMULA)) error(mpl, "expression following colon has invalid type"); xassert(first->dim == 0); /* relational operator must follow the first expression */ if (mpl->token == T_COMMA) get_token(mpl /* , */); switch (mpl->token) { case T_LE: case T_GE: case T_EQ: break; case T_LT: case T_GT: case T_NE: error(mpl, "strict inequality not allowed"); case T_SEMICOLON: error(mpl, "constraint must be equality or inequality"); default: goto err; } rho = mpl->token; strcpy(opstr, mpl->image); xassert(strlen(opstr) < sizeof(opstr)); get_token(mpl /* rho */); /* parse the second expression */ second = expression_5(mpl); if (second->type == A_SYMBOLIC) second = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0); if (!(second->type == A_NUMERIC || second->type == A_FORMULA)) error(mpl, "expression following %s has invalid type", opstr); xassert(second->dim == 0); /* check a token that follow the second expression */ if (mpl->token == T_COMMA) { get_token(mpl /* , */); if (mpl->token == T_SEMICOLON) goto err; } if (mpl->token == T_LT || mpl->token == T_LE || mpl->token == T_EQ || mpl->token == T_GE || mpl->token == T_GT || mpl->token == T_NE) { /* it is another relational operator, therefore the constraint is double inequality */ if (rho == T_EQ || mpl->token != rho) error(mpl, "double inequality must be ... <= ... <= ... or " "... >= ... >= ..."); /* the first expression cannot be linear form */ if (first->type == A_FORMULA) error(mpl, "leftmost expression in double inequality cannot" " be linear form"); get_token(mpl /* rho */); /* parse the third expression */ third = expression_5(mpl); if (third->type == A_SYMBOLIC) third = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0); if (!(third->type == A_NUMERIC || third->type == A_FORMULA)) error(mpl, "rightmost expression in double inequality const" "raint has invalid type"); xassert(third->dim == 0); /* the third expression also cannot be linear form */ if (third->type == A_FORMULA) error(mpl, "rightmost expression in double inequality canno" "t be linear form"); } else { /* the constraint is equality or single inequality */ third = NULL; } /* close the domain scope */ if (con->domain != NULL) close_scope(mpl, con->domain); /* convert all expressions to linear form, if necessary */ if (first->type != A_FORMULA) first = make_unary(mpl, O_CVTLFM, first, A_FORMULA, 0); if (second->type != A_FORMULA) second = make_unary(mpl, O_CVTLFM, second, A_FORMULA, 0); if (third != NULL) third = make_unary(mpl, O_CVTLFM, third, A_FORMULA, 0); /* arrange expressions in the constraint */ if (third == NULL) { /* the constraint is equality or single inequality */ switch (rho) { case T_LE: /* first <= second */ con->code = first; con->lbnd = NULL; con->ubnd = second; break; case T_GE: /* first >= second */ con->code = first; con->lbnd = second; con->ubnd = NULL; break; case T_EQ: /* first = second */ con->code = first; con->lbnd = second; con->ubnd = second; break; default: xassert(rho != rho); } } else { /* the constraint is double inequality */ switch (rho) { case T_LE: /* first <= second <= third */ con->code = second; con->lbnd = first; con->ubnd = third; break; case T_GE: /* first >= second >= third */ con->code = second; con->lbnd = third; con->ubnd = first; break; default: xassert(rho != rho); } } /* the constraint statement has been completely parsed */ if (mpl->token != T_SEMICOLON) err: error(mpl, "syntax error in constraint statement"); get_token(mpl /* ; */); return con; } /*---------------------------------------------------------------------- -- objective_statement - parse objective statement. -- -- This routine parses objective statement using the syntax: -- -- ::= : -- ; -- ::= minimize -- ::= maximize -- ::= -- ::= -- ::= -- ::= -- ::= */ CONSTRAINT *objective_statement(MPL *mpl) { CONSTRAINT *obj; int type; if (is_keyword(mpl, "minimize")) type = A_MINIMIZE; else if (is_keyword(mpl, "maximize")) type = A_MAXIMIZE; else xassert(mpl != mpl); if (mpl->flag_s) error(mpl, "objective statement must precede solve statement"); get_token(mpl /* minimize | maximize */); /* symbolic name must follow the verb 'minimize' or 'maximize' */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "symbolic name missing where expected"); /* there must be no other object with the same name */ if (avl_find_node(mpl->tree, mpl->image) != NULL) error(mpl, "%s multiply declared", mpl->image); /* create model objective */ obj = alloc(CONSTRAINT); obj->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(obj->name, mpl->image); obj->alias = NULL; obj->dim = 0; obj->domain = NULL; obj->type = type; obj->code = NULL; obj->lbnd = NULL; obj->ubnd = NULL; obj->array = NULL; get_token(mpl /* */); /* parse optional alias */ if (mpl->token == T_STRING) { obj->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(obj->alias, mpl->image); get_token(mpl /* */); } /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { obj->domain = indexing_expression(mpl); obj->dim = domain_arity(mpl, obj->domain); } /* include the constraint name in the symbolic names table */ { AVLNODE *node; node = avl_insert_node(mpl->tree, obj->name); avl_set_node_type(node, A_CONSTRAINT); avl_set_node_link(node, (void *)obj); } /* the colon must precede the objective expression */ if (mpl->token != T_COLON) error(mpl, "colon missing where expected"); get_token(mpl /* : */); /* parse the objective expression */ obj->code = expression_5(mpl); if (obj->code->type == A_SYMBOLIC) obj->code = make_unary(mpl, O_CVTNUM, obj->code, A_NUMERIC, 0); if (obj->code->type == A_NUMERIC) obj->code = make_unary(mpl, O_CVTLFM, obj->code, A_FORMULA, 0); if (obj->code->type != A_FORMULA) error(mpl, "expression following colon has invalid type"); xassert(obj->code->dim == 0); /* close the domain scope */ if (obj->domain != NULL) close_scope(mpl, obj->domain); /* the objective statement has been completely parsed */ if (mpl->token != T_SEMICOLON) error(mpl, "syntax error in objective statement"); get_token(mpl /* ; */); return obj; } #if 1 /* 11/II-2008 */ /*********************************************************************** * table_statement - parse table statement * * This routine parses table statement using the syntax: * * ::= *
::= * * ::= * table
IN : * [ ] , ; * ::= * ::= * ::= * ::= * ::= , * ::= * ::= <- * ::= * ::= , * ::= * ::= , * ::= * ::= ~ * * ::= * table
OUT : * ; * ::= * ::= * ::= , * ::= * ::= ~ */ TABLE *table_statement(MPL *mpl) { TABLE *tab; TABARG *last_arg, *arg; TABFLD *last_fld, *fld; TABIN *last_in, *in; TABOUT *last_out, *out; AVLNODE *node; int nflds; char name[MAX_LENGTH+1]; xassert(is_keyword(mpl, "table")); get_token(mpl /* solve */); /* symbolic name must follow the keyword table */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "symbolic name missing where expected"); /* there must be no other object with the same name */ if (avl_find_node(mpl->tree, mpl->image) != NULL) error(mpl, "%s multiply declared", mpl->image); /* create data table */ tab = alloc(TABLE); tab->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(tab->name, mpl->image); get_token(mpl /* */); /* parse optional alias */ if (mpl->token == T_STRING) { tab->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(tab->alias, mpl->image); get_token(mpl /* */); } else tab->alias = NULL; /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { /* this is output table */ tab->type = A_OUTPUT; tab->u.out.domain = indexing_expression(mpl); if (!is_keyword(mpl, "OUT")) error(mpl, "keyword OUT missing where expected"); get_token(mpl /* OUT */); } else { /* this is input table */ tab->type = A_INPUT; if (!is_keyword(mpl, "IN")) error(mpl, "keyword IN missing where expected"); get_token(mpl /* IN */); } /* parse argument list */ tab->arg = last_arg = NULL; for (;;) { /* create argument list entry */ arg = alloc(TABARG); /* parse argument expression */ if (mpl->token == T_COMMA || mpl->token == T_COLON || mpl->token == T_SEMICOLON) error(mpl, "argument expression missing where expected"); arg->code = expression_5(mpl); /* convert the result to symbolic type, if necessary */ if (arg->code->type == A_NUMERIC) arg->code = make_unary(mpl, O_CVTSYM, arg->code, A_SYMBOLIC, 0); /* check that now the result is of symbolic type */ if (arg->code->type != A_SYMBOLIC) error(mpl, "argument expression has invalid type"); /* add the entry to the end of the list */ arg->next = NULL; if (last_arg == NULL) tab->arg = arg; else last_arg->next = arg; last_arg = arg; /* argument expression has been parsed */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_COLON || mpl->token == T_SEMICOLON) break; } xassert(tab->arg != NULL); /* argument list must end with colon */ if (mpl->token == T_COLON) get_token(mpl /* : */); else error(mpl, "colon missing where expected"); /* parse specific part of the table statement */ switch (tab->type) { case A_INPUT: goto input_table; case A_OUTPUT: goto output_table; default: xassert(tab != tab); } input_table: /* parse optional set name */ if (mpl->token == T_NAME) { node = avl_find_node(mpl->tree, mpl->image); if (node == NULL) error(mpl, "%s not defined", mpl->image); if (avl_get_node_type(node) != A_SET) error(mpl, "%s not a set", mpl->image); tab->u.in.set = (SET *)avl_get_node_link(node); if (tab->u.in.set->assign != NULL) error(mpl, "%s needs no data", mpl->image); if (tab->u.in.set->dim != 0) error(mpl, "%s must be a simple set", mpl->image); get_token(mpl /* */); if (mpl->token == T_INPUT) get_token(mpl /* <- */); else error(mpl, "delimiter <- missing where expected"); } else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else tab->u.in.set = NULL; /* parse field list */ tab->u.in.fld = last_fld = NULL; nflds = 0; if (mpl->token == T_LBRACKET) get_token(mpl /* [ */); else error(mpl, "field list missing where expected"); for (;;) { /* create field list entry */ fld = alloc(TABFLD); /* parse field name */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "field name missing where expected"); fld->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1); strcpy(fld->name, mpl->image); get_token(mpl /* */); /* add the entry to the end of the list */ fld->next = NULL; if (last_fld == NULL) tab->u.in.fld = fld; else last_fld->next = fld; last_fld = fld; nflds++; /* field name has been parsed */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_RBRACKET) break; else error(mpl, "syntax error in field list"); } /* check that the set dimen is equal to the number of fields */ if (tab->u.in.set != NULL && tab->u.in.set->dimen != nflds) error(mpl, "there must be %d field%s rather than %d", tab->u.in.set->dimen, tab->u.in.set->dimen == 1 ? "" : "s", nflds); get_token(mpl /* ] */); /* parse optional input list */ tab->u.in.list = last_in = NULL; while (mpl->token == T_COMMA) { get_token(mpl /* , */); /* create input list entry */ in = alloc(TABIN); /* parse parameter name */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "parameter name missing where expected"); node = avl_find_node(mpl->tree, mpl->image); if (node == NULL) error(mpl, "%s not defined", mpl->image); if (avl_get_node_type(node) != A_PARAMETER) error(mpl, "%s not a parameter", mpl->image); in->par = (PARAMETER *)avl_get_node_link(node); if (in->par->dim != nflds) error(mpl, "%s must have %d subscript%s rather than %d", mpl->image, nflds, nflds == 1 ? "" : "s", in->par->dim); if (in->par->assign != NULL) error(mpl, "%s needs no data", mpl->image); get_token(mpl /* */); /* parse optional field name */ if (mpl->token == T_TILDE) { get_token(mpl /* ~ */); /* parse field name */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "field name missing where expected"); xassert(strlen(mpl->image) < sizeof(name)); strcpy(name, mpl->image); get_token(mpl /* */); } else { /* field name is the same as the parameter name */ xassert(strlen(in->par->name) < sizeof(name)); strcpy(name, in->par->name); } /* assign field name */ in->name = dmp_get_atomv(mpl->pool, strlen(name)+1); strcpy(in->name, name); /* add the entry to the end of the list */ in->next = NULL; if (last_in == NULL) tab->u.in.list = in; else last_in->next = in; last_in = in; } goto end_of_table; output_table: /* parse output list */ tab->u.out.list = last_out = NULL; for (;;) { /* create output list entry */ out = alloc(TABOUT); /* parse expression */ if (mpl->token == T_COMMA || mpl->token == T_SEMICOLON) error(mpl, "expression missing where expected"); if (mpl->token == T_NAME) { xassert(strlen(mpl->image) < sizeof(name)); strcpy(name, mpl->image); } else name[0] = '\0'; out->code = expression_5(mpl); /* parse optional field name */ if (mpl->token == T_TILDE) { get_token(mpl /* ~ */); /* parse field name */ if (mpl->token == T_NAME) ; else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "field name missing where expected"); xassert(strlen(mpl->image) < sizeof(name)); strcpy(name, mpl->image); get_token(mpl /* */); } /* assign field name */ if (name[0] == '\0') error(mpl, "field name required"); out->name = dmp_get_atomv(mpl->pool, strlen(name)+1); strcpy(out->name, name); /* add the entry to the end of the list */ out->next = NULL; if (last_out == NULL) tab->u.out.list = out; else last_out->next = out; last_out = out; /* output item has been parsed */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else if (mpl->token == T_SEMICOLON) break; else error(mpl, "syntax error in output list"); } /* close the domain scope */ close_scope(mpl,tab->u.out.domain); end_of_table: /* the table statement must end with semicolon */ if (mpl->token != T_SEMICOLON) error(mpl, "syntax error in table statement"); get_token(mpl /* ; */); return tab; } #endif /*---------------------------------------------------------------------- -- solve_statement - parse solve statement. -- -- This routine parses solve statement using the syntax: -- -- ::= solve ; -- -- The solve statement can be used at most once. */ void *solve_statement(MPL *mpl) { xassert(is_keyword(mpl, "solve")); if (mpl->flag_s) error(mpl, "at most one solve statement allowed"); mpl->flag_s = 1; get_token(mpl /* solve */); /* semicolon must follow solve statement */ if (mpl->token != T_SEMICOLON) error(mpl, "syntax error in solve statement"); get_token(mpl /* ; */); return NULL; } /*---------------------------------------------------------------------- -- check_statement - parse check statement. -- -- This routine parses check statement using the syntax: -- -- ::= check : ; -- ::= -- ::= -- -- If is omitted, colon following it may also be omitted. */ CHECK *check_statement(MPL *mpl) { CHECK *chk; xassert(is_keyword(mpl, "check")); /* create check descriptor */ chk = alloc(CHECK); chk->domain = NULL; chk->code = NULL; get_token(mpl /* check */); /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { chk->domain = indexing_expression(mpl); #if 0 if (mpl->token != T_COLON) error(mpl, "colon missing where expected"); #endif } /* skip optional colon */ if (mpl->token == T_COLON) get_token(mpl /* : */); /* parse logical expression */ chk->code = expression_13(mpl); if (chk->code->type != A_LOGICAL) error(mpl, "expression has invalid type"); xassert(chk->code->dim == 0); /* close the domain scope */ if (chk->domain != NULL) close_scope(mpl, chk->domain); /* the check statement has been completely parsed */ if (mpl->token != T_SEMICOLON) error(mpl, "syntax error in check statement"); get_token(mpl /* ; */); return chk; } #if 1 /* 15/V-2010 */ /*---------------------------------------------------------------------- -- display_statement - parse display statement. -- -- This routine parses display statement using the syntax: -- -- ::= display : ; -- ::= display ; -- ::= -- ::= -- ::= -- ::= , -- ::= -- ::= -- ::= [ ] -- ::= -- ::= [ ] -- ::= -- ::= [ ] -- ::= -- ::= [ ] -- ::= */ DISPLAY *display_statement(MPL *mpl) { DISPLAY *dpy; DISPLAY1 *entry, *last_entry; xassert(is_keyword(mpl, "display")); /* create display descriptor */ dpy = alloc(DISPLAY); dpy->domain = NULL; dpy->list = last_entry = NULL; get_token(mpl /* display */); /* parse optional indexing expression */ if (mpl->token == T_LBRACE) dpy->domain = indexing_expression(mpl); /* skip optional colon */ if (mpl->token == T_COLON) get_token(mpl /* : */); /* parse display list */ for (;;) { /* create new display entry */ entry = alloc(DISPLAY1); entry->type = 0; entry->next = NULL; /* and append it to the display list */ if (dpy->list == NULL) dpy->list = entry; else last_entry->next = entry; last_entry = entry; /* parse display entry */ if (mpl->token == T_NAME) { AVLNODE *node; int next_token; get_token(mpl /* */); next_token = mpl->token; unget_token(mpl); if (!(next_token == T_COMMA || next_token == T_SEMICOLON)) { /* symbolic name begins expression */ goto expr; } /* display entry is dummy index or model object */ node = avl_find_node(mpl->tree, mpl->image); if (node == NULL) error(mpl, "%s not defined", mpl->image); entry->type = avl_get_node_type(node); switch (avl_get_node_type(node)) { case A_INDEX: entry->u.slot = (DOMAIN_SLOT *)avl_get_node_link(node); break; case A_SET: entry->u.set = (SET *)avl_get_node_link(node); break; case A_PARAMETER: entry->u.par = (PARAMETER *)avl_get_node_link(node); break; case A_VARIABLE: entry->u.var = (VARIABLE *)avl_get_node_link(node); if (!mpl->flag_s) error(mpl, "invalid reference to variable %s above" " solve statement", entry->u.var->name); break; case A_CONSTRAINT: entry->u.con = (CONSTRAINT *)avl_get_node_link(node); if (!mpl->flag_s) error(mpl, "invalid reference to %s %s above solve" " statement", entry->u.con->type == A_CONSTRAINT ? "constraint" : "objective", entry->u.con->name); break; default: xassert(node != node); } get_token(mpl /* */); } else expr: { /* display entry is expression */ entry->type = A_EXPRESSION; entry->u.code = expression_13(mpl); } /* check a token that follows the entry parsed */ if (mpl->token == T_COMMA) get_token(mpl /* , */); else break; } /* close the domain scope */ if (dpy->domain != NULL) close_scope(mpl, dpy->domain); /* the display statement has been completely parsed */ if (mpl->token != T_SEMICOLON) error(mpl, "syntax error in display statement"); get_token(mpl /* ; */); return dpy; } #endif /*---------------------------------------------------------------------- -- printf_statement - parse printf statement. -- -- This routine parses print statement using the syntax: -- -- ::= ; -- ::= > ; -- ::= >> ; -- ::= printf : -- ::= printf -- ::= -- ::= -- ::= -- ::= -- ::= , -- ::= -- ::= */ PRINTF *printf_statement(MPL *mpl) { PRINTF *prt; PRINTF1 *entry, *last_entry; xassert(is_keyword(mpl, "printf")); /* create printf descriptor */ prt = alloc(PRINTF); prt->domain = NULL; prt->fmt = NULL; prt->list = last_entry = NULL; get_token(mpl /* printf */); /* parse optional indexing expression */ if (mpl->token == T_LBRACE) { prt->domain = indexing_expression(mpl); #if 0 if (mpl->token != T_COLON) error(mpl, "colon missing where expected"); #endif } /* skip optional colon */ if (mpl->token == T_COLON) get_token(mpl /* : */); /* parse expression for format string */ prt->fmt = expression_5(mpl); /* convert it to symbolic type, if necessary */ if (prt->fmt->type == A_NUMERIC) prt->fmt = make_unary(mpl, O_CVTSYM, prt->fmt, A_SYMBOLIC, 0); /* check that now the expression is of symbolic type */ if (prt->fmt->type != A_SYMBOLIC) error(mpl, "format expression has invalid type"); /* parse printf list */ while (mpl->token == T_COMMA) { get_token(mpl /* , */); /* create new printf entry */ entry = alloc(PRINTF1); entry->code = NULL; entry->next = NULL; /* and append it to the printf list */ if (prt->list == NULL) prt->list = entry; else last_entry->next = entry; last_entry = entry; /* parse printf entry */ entry->code = expression_9(mpl); if (!(entry->code->type == A_NUMERIC || entry->code->type == A_SYMBOLIC || entry->code->type == A_LOGICAL)) error(mpl, "only numeric, symbolic, or logical expression a" "llowed"); } /* close the domain scope */ if (prt->domain != NULL) close_scope(mpl, prt->domain); #if 1 /* 14/VII-2006 */ /* parse optional redirection */ prt->fname = NULL, prt->app = 0; if (mpl->token == T_GT || mpl->token == T_APPEND) { prt->app = (mpl->token == T_APPEND); get_token(mpl /* > or >> */); /* parse expression for file name string */ prt->fname = expression_5(mpl); /* convert it to symbolic type, if necessary */ if (prt->fname->type == A_NUMERIC) prt->fname = make_unary(mpl, O_CVTSYM, prt->fname, A_SYMBOLIC, 0); /* check that now the expression is of symbolic type */ if (prt->fname->type != A_SYMBOLIC) error(mpl, "file name expression has invalid type"); } #endif /* the printf statement has been completely parsed */ if (mpl->token != T_SEMICOLON) error(mpl, "syntax error in printf statement"); get_token(mpl /* ; */); return prt; } /*---------------------------------------------------------------------- -- for_statement - parse for statement. -- -- This routine parses for statement using the syntax: -- -- ::= for -- ::= for { } -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= */ FOR *for_statement(MPL *mpl) { FOR *fur; STATEMENT *stmt, *last_stmt; xassert(is_keyword(mpl, "for")); /* create for descriptor */ fur = alloc(FOR); fur->domain = NULL; fur->list = last_stmt = NULL; get_token(mpl /* for */); /* parse indexing expression */ if (mpl->token != T_LBRACE) error(mpl, "indexing expression missing where expected"); fur->domain = indexing_expression(mpl); /* skip optional colon */ if (mpl->token == T_COLON) get_token(mpl /* : */); /* parse for statement body */ if (mpl->token != T_LBRACE) { /* parse simple statement */ fur->list = simple_statement(mpl, 1); } else { /* parse compound statement */ get_token(mpl /* { */); while (mpl->token != T_RBRACE) { /* parse statement */ stmt = simple_statement(mpl, 1); /* and append it to the end of the statement list */ if (last_stmt == NULL) fur->list = stmt; else last_stmt->next = stmt; last_stmt = stmt; } get_token(mpl /* } */); } /* close the domain scope */ xassert(fur->domain != NULL); close_scope(mpl, fur->domain); /* the for statement has been completely parsed */ return fur; } /*---------------------------------------------------------------------- -- end_statement - parse end statement. -- -- This routine parses end statement using the syntax: -- -- ::= end ; */ void end_statement(MPL *mpl) { if (!mpl->flag_d && is_keyword(mpl, "end") || mpl->flag_d && is_literal(mpl, "end")) { get_token(mpl /* end */); if (mpl->token == T_SEMICOLON) get_token(mpl /* ; */); else warning(mpl, "no semicolon following end statement; missing" " semicolon inserted"); } else warning(mpl, "unexpected end of file; missing end statement in" "serted"); if (mpl->token != T_EOF) warning(mpl, "some text detected beyond end statement; text ig" "nored"); return; } /*---------------------------------------------------------------------- -- simple_statement - parse simple statement. -- -- This routine parses simple statement using the syntax: -- -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= -- ::= -- -- If the flag spec is set, some statements cannot be used. */ STATEMENT *simple_statement(MPL *mpl, int spec) { STATEMENT *stmt; stmt = alloc(STATEMENT); stmt->line = mpl->line; stmt->next = NULL; if (is_keyword(mpl, "set")) { if (spec) error(mpl, "set statement not allowed here"); stmt->type = A_SET; stmt->u.set = set_statement(mpl); } else if (is_keyword(mpl, "param")) { if (spec) error(mpl, "parameter statement not allowed here"); stmt->type = A_PARAMETER; stmt->u.par = parameter_statement(mpl); } else if (is_keyword(mpl, "var")) { if (spec) error(mpl, "variable statement not allowed here"); stmt->type = A_VARIABLE; stmt->u.var = variable_statement(mpl); } else if (is_keyword(mpl, "subject") || is_keyword(mpl, "subj") || mpl->token == T_SPTP) { if (spec) error(mpl, "constraint statement not allowed here"); stmt->type = A_CONSTRAINT; stmt->u.con = constraint_statement(mpl); } else if (is_keyword(mpl, "minimize") || is_keyword(mpl, "maximize")) { if (spec) error(mpl, "objective statement not allowed here"); stmt->type = A_CONSTRAINT; stmt->u.con = objective_statement(mpl); } #if 1 /* 11/II-2008 */ else if (is_keyword(mpl, "table")) { if (spec) error(mpl, "table statement not allowed here"); stmt->type = A_TABLE; stmt->u.tab = table_statement(mpl); } #endif else if (is_keyword(mpl, "solve")) { if (spec) error(mpl, "solve statement not allowed here"); stmt->type = A_SOLVE; stmt->u.slv = solve_statement(mpl); } else if (is_keyword(mpl, "check")) { stmt->type = A_CHECK; stmt->u.chk = check_statement(mpl); } else if (is_keyword(mpl, "display")) { stmt->type = A_DISPLAY; stmt->u.dpy = display_statement(mpl); } else if (is_keyword(mpl, "printf")) { stmt->type = A_PRINTF; stmt->u.prt = printf_statement(mpl); } else if (is_keyword(mpl, "for")) { stmt->type = A_FOR; stmt->u.fur = for_statement(mpl); } else if (mpl->token == T_NAME) { if (spec) error(mpl, "constraint statement not allowed here"); stmt->type = A_CONSTRAINT; stmt->u.con = constraint_statement(mpl); } else if (is_reserved(mpl)) error(mpl, "invalid use of reserved keyword %s", mpl->image); else error(mpl, "syntax error in model section"); return stmt; } /*---------------------------------------------------------------------- -- model_section - parse model section. -- -- This routine parses model section using the syntax: -- -- ::= -- ::= -- -- Parsing model section is terminated by either the keyword 'data', or -- the keyword 'end', or the end of file. */ void model_section(MPL *mpl) { STATEMENT *stmt, *last_stmt; xassert(mpl->model == NULL); last_stmt = NULL; while (!(mpl->token == T_EOF || is_keyword(mpl, "data") || is_keyword(mpl, "end"))) { /* parse statement */ stmt = simple_statement(mpl, 0); /* and append it to the end of the statement list */ if (last_stmt == NULL) mpl->model = stmt; else last_stmt->next = stmt; last_stmt = stmt; } return; } /* eof */