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