glpk-cmake: src/glpmpl01.c@4c8956a7bdf4

     1 /* glpmpl01.c */

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

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

5 *

     6 *  Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,

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

     8 *  Moscow Aviation Institute, Moscow, Russia. All rights reserved.

     9 *  E-mail: <mao@gnu.org>.

    10 *

    11 *  GLPK is free software: you can redistribute it and/or modify it

    12 *  under the terms of the GNU General Public License as published by

    13 *  the Free Software Foundation, either version 3 of the License, or

    14 *  (at your option) any later version.

    15 *

    16 *  GLPK is distributed in the hope that it will be useful, but WITHOUT

    17 *  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY

    18 *  or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public

    19 *  License for more details.

    20 *

    21 *  You should have received a copy of the GNU General Public License

    22 *  along with GLPK. If not, see <http://www.gnu.org/licenses/>.

    23 ***********************************************************************/

    25 #define _GLPSTD_STDIO

    26 #include "glpmpl.h"

    27 #define dmp_get_atomv dmp_get_atom

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

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

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

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

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

    35 --

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

    38 void enter_context(MPL *mpl)

    39 {     char *image, *s;

    40       if (mpl->token == T_EOF)

    41          image = "_|_";

    42       else if (mpl->token == T_STRING)

    43          image = "'...'";

    44       else

    45          image = mpl->image;

    46       xassert(0 <= mpl->c_ptr && mpl->c_ptr < CONTEXT_SIZE);

    47       mpl->context[mpl->c_ptr++] = ' ';

    48       if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0;

    49       for (s = image; *s != '\0'; s++)

    50       {  mpl->context[mpl->c_ptr++] = *s;

    51          if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0;

    52       }

    53       return;

    54 }

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

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

    58 --

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

    61 void print_context(MPL *mpl)

    62 {     int c;

    63       while (mpl->c_ptr > 0)

    64       {  mpl->c_ptr--;

    65          c = mpl->context[0];

    66          memmove(mpl->context, mpl->context+1, CONTEXT_SIZE-1);

    67          mpl->context[CONTEXT_SIZE-1] = (char)c;

    68       }

    69       xprintf("Context: %s%.*s\n", mpl->context[0] == ' ' ? "" : "...",

    70          CONTEXT_SIZE, mpl->context);

    71       return;

    72 }

    74 /*----------------------------------------------------------------------

    75 -- get_char - scan next character from input text file.

    76 --

    77 -- This routine scans a next ASCII character from the input text file.

    78 -- In case of end-of-file, the character is assigned EOF. */

    80 void get_char(MPL *mpl)

    81 {     int c;

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

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

    84       c = read_char(mpl);

    85       if (c == EOF)

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

    87             mpl->line--;

    88          else

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

    90       }

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

    92          ;

    93       else if (isspace(c))

    94          c = ' ';

    95       else if (iscntrl(c))

    96       {  enter_context(mpl);

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

    98       }

    99       mpl->c = c;

   100 done: return;

   101 }

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

   104 -- append_char - append character to current token.

   105 --

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

   107 -- then scans a next character. */

   109 void append_char(MPL *mpl)

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

   111       if (mpl->imlen == MAX_LENGTH)

   112       {  switch (mpl->token)

   113          {  case T_NAME:

   114                enter_context(mpl);

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

   116             case T_SYMBOL:

   117                enter_context(mpl);

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

   119             case T_NUMBER:

   120                enter_context(mpl);

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

   122             case T_STRING:

   123                enter_context(mpl);

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

   125             default:

   126                xassert(mpl != mpl);

   127          }

   128       }

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

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

   131       get_char(mpl);

   132       return;

   133 }

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

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

   137 --

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

   139 -- standard finite automation technique. */

   141 void get_token(MPL *mpl)

   142 {     /* save the current token */

   143       mpl->b_token = mpl->token;

   144       mpl->b_imlen = mpl->imlen;

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

   146       mpl->b_value = mpl->value;

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

   148       if (mpl->f_scan)

   149       {  mpl->f_scan = 0;

   150          mpl->token = mpl->f_token;

   151          mpl->imlen = mpl->f_imlen;

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

   153          mpl->value = mpl->f_value;

   154          goto done;

   155       }

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

   157       mpl->token = 0;

   158       mpl->imlen = 0;

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

   160       mpl->value = 0.0;

   161       /* skip any uninteresting characters */

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

   163       /* recognize and construct the token */

   164       if (mpl->c == EOF)

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

   166          mpl->token = T_EOF;

   167       }

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

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

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

   171          goto loop;

   172       }

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

   174       {  /* symbolic name or reserved keyword */

   175          mpl->token = T_NAME;

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

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

   178             mpl->token = T_AND;

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

   180             mpl->token = T_BY;

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

   182             mpl->token = T_CROSS;

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

   184             mpl->token = T_DIFF;

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

   186             mpl->token = T_DIV;

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

   188             mpl->token = T_ELSE;

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

   190             mpl->token = T_IF;

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

   192             mpl->token = T_IN;

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

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

   195             mpl->token = T_INFINITY;

   196 #endif

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

   198             mpl->token = T_INTER;

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

   200             mpl->token = T_LESS;

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

   202             mpl->token = T_MOD;

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

   204             mpl->token = T_NOT;

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

   206             mpl->token = T_OR;

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

   208          {  mpl->token = T_SPTP;

   209             append_char(mpl);

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

   211 sptp:       {  enter_context(mpl);

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

   213             }

   214             append_char(mpl);

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

   216             append_char(mpl);

   217          }

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

   219             mpl->token = T_SYMDIFF;

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

   221             mpl->token = T_THEN;

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

   223             mpl->token = T_UNION;

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

   225             mpl->token = T_WITHIN;

   226       }

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

   228       {  /* numeric literal */

   229          mpl->token = T_NUMBER;

   230          /* scan integer part */

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

   232          /* scan optional fractional part */

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

   234          {  append_char(mpl);

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

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

   237                   follow the integer part */

   238                mpl->imlen--;

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

   240                mpl->f_dots = 1;

   241                goto conv;

   242             }

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

   244          }

   245          /* scan optional decimal exponent */

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

   247          {  append_char(mpl);

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

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

   250             {  enter_context(mpl);

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

   252             }

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

   254          }

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

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

   257          {  enter_context(mpl);

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

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

   260          }

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

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

   263 err:     {  enter_context(mpl);

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

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

   266          }

   267       }

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

   269       {  /* character string */

   270          int quote = mpl->c;

   271          mpl->token = T_STRING;

   272          get_char(mpl);

   273          for (;;)

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

   275             {  enter_context(mpl);

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

   277                   "plete");

   278             }

   279             if (mpl->c == quote)

   280             {  get_char(mpl);

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

   282             }

   283             append_char(mpl);

   284          }

   285       }

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

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

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

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

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

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

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

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

   294       }

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

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

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

   298          {  /* comment sequence */

   299             get_char(mpl);

   300             for (;;)

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

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

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

   304                      "incomplete");

   305                }

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

   307                {  get_char(mpl);

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

   309                }

   310                else

   311                   get_char(mpl);

   312             }

   313             get_char(mpl);

   314             goto loop;

   315          }

   316       }

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

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

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

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

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

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

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

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

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

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

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

   328 #endif

   329       }

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

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

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

   333       }

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

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

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

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

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

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

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

   341 #endif

   342       }

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

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

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

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

   347       }

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

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

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

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

   352       }

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

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

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

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

   357       }

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

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

   360          if (mpl->f_dots)

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

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

   363             mpl->token = T_DOTS;

   364             mpl->imlen = 2;

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

   366             mpl->f_dots = 0;

   367          }

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

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

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

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

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

   373             goto frac;

   374          }

   375       }

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

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

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

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

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

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

   382       }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   400 #endif

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

   402       {  /* symbol */

   403          xassert(mpl->flag_d);

   404          mpl->token = T_SYMBOL;

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

   406             append_char(mpl);

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

   408          {  case 0:

   409                mpl->token = T_NUMBER;

   410                break;

   411             case 1:

   412                goto err;

   413             case 2:

   414                break;

   415             default:

   416                xassert(mpl != mpl);

   417          }

   418       }

   419       else

   420       {  enter_context(mpl);

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

   422       }

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

   424       enter_context(mpl);

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

   426          is used by expression_list() */

   427       mpl->flag_x = 0;

   428 done: return;

   429 }

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

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

   433 --

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

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

   437 void unget_token(MPL *mpl)

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

   439       xassert(!mpl->f_scan);

   440       mpl->f_scan = 1;

   441       mpl->f_token = mpl->token;

   442       mpl->f_imlen = mpl->imlen;

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

   444       mpl->f_value = mpl->value;

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

   446       mpl->token = mpl->b_token;

   447       mpl->imlen = mpl->b_imlen;

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

   449       mpl->value = mpl->b_value;

   450       return;

   451 }

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

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

   455 --

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

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

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

   460 {     return

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

   462 }

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

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

   466 --

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

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

   470 int is_reserved(MPL *mpl)

   471 {     return

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

   473          mpl->token == T_BY ||

   474          mpl->token == T_CROSS ||

   475          mpl->token == T_DIFF ||

   476          mpl->token == T_DIV ||

   477          mpl->token == T_ELSE ||

   478          mpl->token == T_IF ||

   479          mpl->token == T_IN ||

   480          mpl->token == T_INTER ||

   481          mpl->token == T_LESS ||

   482          mpl->token == T_MOD ||

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

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

   485          mpl->token == T_SYMDIFF ||

   486          mpl->token == T_THEN ||

   487          mpl->token == T_UNION ||

   488          mpl->token == T_WITHIN;

   489 }

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

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

   493 --

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

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

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

   498 {     CODE *code;

   499       DOMAIN *domain;

   500       DOMAIN_BLOCK *block;

   501       ARG_LIST *e;

   502       /* generate pseudo-code */

   503       code = alloc(CODE);

   504       code->op = op;

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

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

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

   508          its operands */

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

   510       switch (op)

   511       {  case O_NUMBER:

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

   513             break;

   514          case O_STRING:

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

   516             break;

   517          case O_INDEX:

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

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

   520             break;

   521          case O_MEMNUM:

   522          case O_MEMSYM:

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

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

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

   526                e->x->up = code;

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

   528             }

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

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

   531             break;

   532          case O_MEMSET:

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

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

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

   536                e->x->up = code;

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

   538             }

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

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

   541             break;

   542          case O_MEMVAR:

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

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

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

   546                e->x->up = code;

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

   548             }

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

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

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

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

   553 #endif

   554             break;

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

   556          case O_MEMCON:

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

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

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

   560                e->x->up = code;

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

   562             }

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

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

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

   566             break;

   567 #endif

   568          case O_TUPLE:

   569          case O_MAKE:

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

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

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

   573                e->x->up = code;

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

   575             }

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

   577             break;

   578          case O_SLICE:

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

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

   581             break;

   582          case O_IRAND224:

   583          case O_UNIFORM01:

   584          case O_NORMAL01:

   585          case O_GMTIME:

   586             code->vflag = 1;

   587             break;

   588          case O_CVTNUM:

   589          case O_CVTSYM:

   590          case O_CVTLOG:

   591          case O_CVTTUP:

   592          case O_CVTLFM:

   593          case O_PLUS:

   594          case O_MINUS:

   595          case O_NOT:

   596          case O_ABS:

   597          case O_CEIL:

   598          case O_FLOOR:

   599          case O_EXP:

   600          case O_LOG:

   601          case O_LOG10:

   602          case O_SQRT:

   603          case O_SIN:

   604          case O_COS:

   605          case O_ATAN:

   606          case O_ROUND:

   607          case O_TRUNC:

   608          case O_CARD:

   609          case O_LENGTH:

   610             /* unary operation */

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

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

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

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

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

   616             break;

   617          case O_ADD:

   618          case O_SUB:

   619          case O_LESS:

   620          case O_MUL:

   621          case O_DIV:

   622          case O_IDIV:

   623          case O_MOD:

   624          case O_POWER:

   625          case O_ATAN2:

   626          case O_ROUND2:

   627          case O_TRUNC2:

   628          case O_UNIFORM:

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

   630          case O_NORMAL:

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

   632          case O_CONCAT:

   633          case O_LT:

   634          case O_LE:

   635          case O_EQ:

   636          case O_GE:

   637          case O_GT:

   638          case O_NE:

   639          case O_AND:

   640          case O_OR:

   641          case O_UNION:

   642          case O_DIFF:

   643          case O_SYMDIFF:

   644          case O_INTER:

   645          case O_CROSS:

   646          case O_IN:

   647          case O_NOTIN:

   648          case O_WITHIN:

   649          case O_NOTWITHIN:

   650          case O_SUBSTR:

   651          case O_STR2TIME:

   652          case O_TIME2STR:

   653             /* binary operation */

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

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

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

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

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

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

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

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

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

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

   664             break;

   665          case O_DOTS:

   666          case O_FORK:

   667          case O_SUBSTR3:

   668             /* ternary operation */

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

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

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

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

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

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

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

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

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

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

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

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

   681             }

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

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

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

   685             break;

   686          case O_MIN:

   687          case O_MAX:

   688             /* n-ary operation */

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

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

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

   692                e->x->up = code;

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

   694             }

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

   696             break;

   697          case O_SUM:

   698          case O_PROD:

   699          case O_MINIMUM:

   700          case O_MAXIMUM:

   701          case O_FORALL:

   702          case O_EXISTS:

   703          case O_SETOF:

   704          case O_BUILD:

   705             /* iterated operation */

   706             domain = arg->loop.domain;

   707             xassert(domain != NULL);

   708             if (domain->code != NULL)

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

   710                domain->code->up = code;

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

   712             }

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

   714                block->next)

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

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

   717                block->code->up = code;

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

   719             }

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

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

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

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

   724             }

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

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

   727             break;

   728          default:

   729             xassert(op != op);

   730       }

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

   732       code->type = type;

   733       code->dim = dim;

   734       code->up = NULL;

   735       code->valid = 0;

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

   737       return code;

   738 }

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

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

   742 --

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

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

   746 {     CODE *code;

   747       OPERANDS arg;

   748       xassert(x != NULL);

   749       arg.arg.x = x;

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

   751       return code;

   752 }

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

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

   756 --

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

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

   760       int dim)

   761 {     CODE *code;

   762       OPERANDS arg;

   763       xassert(x != NULL);

   764       xassert(y != NULL);

   765       arg.arg.x = x;

   766       arg.arg.y = y;

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

   768       return code;

   769 }

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

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

   773 --

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

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

   777       int type, int dim)

   778 {     CODE *code;

   779       OPERANDS arg;

   780       xassert(x != NULL);

   781       xassert(y != NULL);

   782       /* third operand can be NULL */

   783       arg.arg.x = x;

   784       arg.arg.y = y;

   785       arg.arg.z = z;

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

   787       return code;

   788 }

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

   791 -- numeric_literal - parse reference to numeric literal.

   792 --

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

   794 --

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

   797 CODE *numeric_literal(MPL *mpl)

   798 {     CODE *code;

   799       OPERANDS arg;

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

   801       arg.num = mpl->value;

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

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

   804       return code;

   805 }

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

   808 -- string_literal - parse reference to string literal.

   809 --

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

   811 --

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

   814 CODE *string_literal(MPL *mpl)

   815 {     CODE *code;

   816       OPERANDS arg;

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

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

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

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

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

   822       return code;

   823 }

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

   826 -- create_arg_list - create empty operands list.

   827 --

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

   830 ARG_LIST *create_arg_list(MPL *mpl)

   831 {     ARG_LIST *list;

   832       xassert(mpl == mpl);

   833       list = NULL;

   834       return list;

   835 }

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

   838 -- expand_arg_list - append operand to operands list.

   839 --

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

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

   843 {     ARG_LIST *tail, *temp;

   844       xassert(x != NULL);

   845       /* create new operands list entry */

   846       tail = alloc(ARG_LIST);

   847       tail->x = x;

   848       tail->next = NULL;

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

   850       if (list == NULL)

   851          list = tail;

   852       else

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

   854          temp->next = tail;

   855       }

   856       return list;

   857 }

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

   860 -- arg_list_len - determine length of operands list.

   861 --

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

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

   865 {     ARG_LIST *temp;

   866       int len;

   867       xassert(mpl == mpl);

   868       len = 0;

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

   870       return len;

   871 }

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

   874 -- subscript_list - parse subscript list.

   875 --

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

   877 --

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

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

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

   882 ARG_LIST *subscript_list(MPL *mpl)

   883 {     ARG_LIST *list;

   884       CODE *x;

   885       list = create_arg_list(mpl);

   886       for (;;)

   887       {  /* parse subscript expression */

   888          x = expression_5(mpl);

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

   890          if (x->type == A_NUMERIC)

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

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

   893          if (x->type != A_SYMBOLIC)

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

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

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

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

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

   899          if (mpl->token == T_COMMA)

   900             get_token(mpl /* , */);

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

   902             break;

   903          else

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

   905       }

   906       return list;

   907 }

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

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

   911 -- object_reference - parse reference to named object.

   912 --

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

   914 --

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

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

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

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

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

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

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

   922 --                          <suffix>

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

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

   925 --                          <suffix>

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

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

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

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

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

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

   933 CODE *object_reference(MPL *mpl)

   934 {     AVLNODE *node;

   935       DOMAIN_SLOT *slot;

   936       SET *set;

   937       PARAMETER *par;

   938       VARIABLE *var;

   939       CONSTRAINT *con;

   940       ARG_LIST *list;

   941       OPERANDS arg;

   942       CODE *code;

   943       char *name;

   944       int dim, suff;

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

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

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

   948       if (node == NULL)

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

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

   951       switch (avl_get_node_type(node))

   952       {  case A_INDEX:

   953             /* dummy index */

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

   955             name = slot->name;

   956             dim = 0;

   957             break;

   958          case A_SET:

   959             /* model set */

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

   961             name = set->name;

   962             dim = set->dim;

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

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

   965                default */

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

   967             break;

   968          case A_PARAMETER:

   969             /* model parameter */

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

   971             name = par->name;

   972             dim = par->dim;

   973             break;

   974          case A_VARIABLE:

   975             /* model variable */

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

   977             name = var->name;

   978             dim = var->dim;

   979             break;

   980          case A_CONSTRAINT:

   981             /* model constraint or objective */

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

   983             name = con->name;

   984             dim = con->dim;

   985             break;

   986          default:

   987             xassert(node != node);

   988       }

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

   990       /* parse optional subscript list */

   991       if (mpl->token == T_LBRACKET)

   992       {  /* subscript list is specified */

   993          if (dim == 0)

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

   995          get_token(mpl /* [ */);

   996          list = subscript_list(mpl);

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

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

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

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

  1001          get_token(mpl /* ] */);

  1002       }

  1003       else

  1004       {  /* subscript list is not specified */

  1005          if (dim != 0)

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

  1007          list = create_arg_list(mpl);

  1008       }

  1009       /* parse optional suffix */

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

  1011          suff = DOT_NONE;

  1012       else

  1013          suff = DOT_VAL;

  1014       if (mpl->token == T_POINT)

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

  1016          if (mpl->token != T_NAME)

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

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

  1019                avl_get_node_type(node) == A_CONSTRAINT))

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

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

  1022             suff = DOT_LB;

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

  1024             suff = DOT_UB;

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

  1026             suff = DOT_STATUS;

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

  1028             suff = DOT_VAL;

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

  1030             suff = DOT_DUAL;

  1031          else

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

  1033          get_token(mpl /* suffix */);

  1034       }

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

  1036       switch (avl_get_node_type(node))

  1037       {  case A_INDEX:

  1038             arg.index.slot = slot;

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

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

  1041             slot->list = code;

  1042             break;

  1043          case A_SET:

  1044             arg.set.set = set;

  1045             arg.set.list = list;

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

  1047                set->dimen);

  1048             break;

  1049          case A_PARAMETER:

  1050             arg.par.par = par;

  1051             arg.par.list = list;

  1052             if (par->type == A_SYMBOLIC)

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

  1054             else

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

  1056             break;

  1057          case A_VARIABLE:

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

  1059                || suff == DOT_DUAL))

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

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

  1062                   var->name);

  1063             arg.var.var = var;

  1064             arg.var.list = list;

  1065             arg.var.suff = suff;

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

  1067                A_FORMULA : A_NUMERIC, 0);

  1068             break;

  1069          case A_CONSTRAINT:

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

  1071                || suff == DOT_DUAL))

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

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

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

  1075                   , con->name);

  1076             arg.con.con = con;

  1077             arg.con.list = list;

  1078             arg.con.suff = suff;

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

  1080             break;

  1081          default:

  1082             xassert(node != node);

  1083       }

  1084       return code;

  1085 }

  1086 #endif

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

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

  1090 --

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

  1092 -- using the syntax:

  1093 --

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

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

  1097 {     CODE *x;

  1098       x = expression_5(mpl);

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

  1100       if (x->type == A_SYMBOLIC)

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

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

  1103       if (x->type != A_NUMERIC)

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

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

  1106       return x;

  1107 }

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

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

  1111 {     CODE *x;

  1112       x = expression_5(mpl);

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

  1114       if (x->type == A_NUMERIC)

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

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

  1117       if (x->type != A_SYMBOLIC)

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

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

  1120       return x;

  1121 }

  1122 #endif

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

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

  1126 {     CODE *x;

  1127       x = expression_9(mpl);

  1128       if (x->type != A_ELEMSET)

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

  1130       xassert(x->dim > 0);

  1131       return x;

  1132 }

  1133 #endif

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

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

  1137 --

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

  1139 --

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  1172 CODE *function_reference(MPL *mpl)

  1173 {     CODE *code;

  1174       OPERANDS arg;

  1175       int op;

  1176       char func[15+1];

  1177       /* determine operation code */

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

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

  1180          op = O_ABS;

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

  1182          op = O_CEIL;

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

  1184          op = O_FLOOR;

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

  1186          op = O_EXP;

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

  1188          op = O_LOG;

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

  1190          op = O_LOG10;

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

  1192          op = O_SQRT;

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

  1194          op = O_SIN;

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

  1196          op = O_COS;

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

  1198          op = O_ATAN;

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

  1200          op = O_MIN;

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

  1202          op = O_MAX;

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

  1204          op = O_ROUND;

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

  1206          op = O_TRUNC;

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

  1208          op = O_IRAND224;

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

  1210          op = O_UNIFORM01;

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

  1212          op = O_UNIFORM;

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

  1214          op = O_NORMAL01;

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

  1216          op = O_NORMAL;

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

  1218          op = O_CARD;

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

  1220          op = O_LENGTH;

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

  1222          op = O_SUBSTR;

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

  1224          op = O_STR2TIME;

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

  1226          op = O_TIME2STR;

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

  1228          op = O_GMTIME;

  1229       else

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

  1231       /* save symbolic name of the function */

  1232       strcpy(func, mpl->image);

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

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

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

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

  1237       get_token(mpl /* ( */);

  1238       /* parse argument list */

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

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

  1241          arg.list = create_arg_list(mpl);

  1242          /* parse argument list */

  1243          for (;;)

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

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

  1246                numeric_argument(mpl, func));

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

  1248             if (mpl->token == T_COMMA)

  1249                get_token(mpl /* , */);

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

  1251                break;

  1252             else

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

  1254          }

  1255       }

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

  1257          O_NORMAL01 || op == O_GMTIME)

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

  1259          if (mpl->token != T_RIGHT)

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

  1261       }

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

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

  1264          /* parse the first argument */

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

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

  1267          if (mpl->token == T_COMMA)

  1268             ;

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

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

  1271          else

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

  1273          get_token(mpl /* , */);

  1274          /* parse the second argument */

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

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

  1277          if (mpl->token == T_COMMA)

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

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

  1280             ;

  1281          else

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

  1283       }

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

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

  1286          /* parse the first argument */

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

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

  1289          if (mpl->token == T_COMMA)

  1290          {  switch (op)

  1291             {  case O_ATAN:  op = O_ATAN2;  break;

  1292                case O_ROUND: op = O_ROUND2; break;

  1293                case O_TRUNC: op = O_TRUNC2; break;

  1294                default: xassert(op != op);

  1295             }

  1296             get_token(mpl /* , */);

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

  1298          }

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

  1300          if (mpl->token == T_COMMA)

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

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

  1303             ;

  1304          else

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

  1306       }

  1307       else if (op == O_SUBSTR)

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

  1309          /* parse the first argument */

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

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

  1312          if (mpl->token == T_COMMA)

  1313             ;

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

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

  1316          else

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

  1318          get_token(mpl /* , */);

  1319          /* parse the second argument */

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

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

  1322          if (mpl->token == T_COMMA)

  1323          {  op = O_SUBSTR3;

  1324             get_token(mpl /* , */);

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

  1326          }

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

  1328          if (mpl->token == T_COMMA)

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

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

  1331             ;

  1332          else

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

  1334       }

  1335       else if (op == O_STR2TIME)

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

  1337          /* parse the first argument */

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

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

  1340          if (mpl->token == T_COMMA)

  1341             ;

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

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

  1344          else

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

  1346          get_token(mpl /* , */);

  1347          /* parse the second argument */

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

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

  1350          if (mpl->token == T_COMMA)

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

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

  1353             ;

  1354          else

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

  1356       }

  1357       else if (op == O_TIME2STR)

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

  1359          /* parse the first argument */

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

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

  1362          if (mpl->token == T_COMMA)

  1363             ;

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

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

  1366          else

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

  1368          get_token(mpl /* , */);

  1369          /* parse the second argument */

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

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

  1372          if (mpl->token == T_COMMA)

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

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

  1375             ;

  1376          else

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

  1378       }

  1379       else

  1380       {  /* other functions need one argument */

  1381          if (op == O_CARD)

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

  1383          else if (op == O_LENGTH)

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

  1385          else

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

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

  1388          if (mpl->token == T_COMMA)

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

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

  1391             ;

  1392          else

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

  1394       }

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

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

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

  1398       else

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

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

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

  1402       get_token(mpl /* ) */);

  1403       return code;

  1404 }

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

  1407 -- create_domain - create empty domain.

  1408 --

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

  1410 -- has no domain blocks. */

  1412 DOMAIN *create_domain(MPL *mpl)

  1413 {     DOMAIN *domain;

  1414       domain = alloc(DOMAIN);

  1415       domain->list = NULL;

  1416       domain->code = NULL;

  1417       return domain;

  1418 }

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

  1421 -- create_block - create empty domain block.

  1422 --

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

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

  1426 DOMAIN_BLOCK *create_block(MPL *mpl)

  1427 {     DOMAIN_BLOCK *block;

  1428       block = alloc(DOMAIN_BLOCK);

  1429       block->list = NULL;

  1430       block->code = NULL;

  1431       block->backup = NULL;

  1432       block->next = NULL;

  1433       return block;

  1434 }

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

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

  1438 --

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

  1440 -- specified domain. */

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

  1443 {     DOMAIN_BLOCK *temp;

  1444       xassert(mpl == mpl);

  1445       xassert(domain != NULL);

  1446       xassert(block != NULL);

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

  1448       if (domain->list == NULL)

  1449          domain->list = block;

  1450       else

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

  1452             temp->next);

  1453          temp->next = block;

  1454       }

  1455       return;

  1456 }

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

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

  1460 --

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

  1462 -- list of specified domain block.

  1463 --

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

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

  1466 -- the dummy index is not explicitly specified.

  1467 --

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

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

  1470 -- in the domain scope. */

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

  1473       CODE *code)

  1474 {     DOMAIN_SLOT *slot, *temp;

  1475       xassert(block != NULL);

  1476       slot = alloc(DOMAIN_SLOT);

  1477       slot->name = name;

  1478       slot->code = code;

  1479       slot->value = NULL;

  1480       slot->list = NULL;

  1481       slot->next = NULL;

  1482       if (block->list == NULL)

  1483          block->list = slot;

  1484       else

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

  1486             temp->next);

  1487          temp->next = slot;

  1488       }

  1489       return slot;

  1490 }

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

  1493 -- expression_list - parse expression list.

  1494 --

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

  1496 -- the parentheses using the syntax:

  1497 --

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

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

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

  1501 --

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

  1503 --

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

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

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

  1507 --

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

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

  1510 --    expression> is a n-tuple.

  1511 --

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

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

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

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

  1517 #define max_dim 20

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

  1520 CODE *expression_list(MPL *mpl)

  1521 {     CODE *code;

  1522       OPERANDS arg;

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

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

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

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

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

  1528          so save it before scanning the next token */

  1529       flag_x = mpl->flag_x;

  1530       get_token(mpl /* ( */);

  1531       /* parse <expression list> */

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

  1533       {  if (dim > max_dim)

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

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

  1536             index or expression */

  1537          if (mpl->token == T_NAME)

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

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

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

  1541                the name is undeclared */

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

  1543             next_token = mpl->token;

  1544             unget_token(mpl);

  1545             if (!(flag_x &&

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

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

  1548             {  /* this is not dummy index */

  1549                goto expr;

  1550             }

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

  1552                symbolic names */

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

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

  1555                   mpl->image) == 0)

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

  1557                      mpl->image);

  1558             }

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

  1560             list[dim].name

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

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

  1563             list[dim].code = NULL;

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

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

  1566                index has appeared */

  1567             slice = 1;

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

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

  1570                a parenthesized expression */

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

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

  1573          }

  1574          else

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

  1576             code = expression_13(mpl);

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

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

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

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

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

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

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

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

  1585                if (code->type != A_SYMBOLIC)

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

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

  1588             }

  1589             list[dim].name = NULL;

  1590             list[dim].code = code;

  1591          }

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

  1593          if (mpl->token == T_COMMA)

  1594             get_token(mpl /* , */);

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

  1596             break;

  1597          else

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

  1599       }

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

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

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

  1603          code = list[1].code;

  1604       }

  1605       else if (!slice)

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

  1607          arg.list = create_arg_list(mpl);

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

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

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

  1611       }

  1612       else

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

  1614          arg.slice = create_block(mpl);

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

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

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

  1618             evaluated */

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

  1620       }

  1621       get_token(mpl /* ) */);

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

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

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

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

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

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

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

  1629       {  if (dim == 1)

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

  1631          else

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

  1633       }

  1634       return code;

  1635 }

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

  1638 -- literal set - parse literal set.

  1639 --

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

  1641 --

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

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

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

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

  1646 --

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

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

  1649 -- remains unscanned on exit. */

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

  1652 {     OPERANDS arg;

  1653       int j;

  1654       xassert(code != NULL);

  1655       arg.list = create_arg_list(mpl);

  1656       /* parse <member list> */

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

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

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

  1660          if (code->type == A_NUMERIC)

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

  1662          if (code->type == A_SYMBOLIC)

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

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

  1665          if (code->type != A_TUPLE)

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

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

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

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

  1670                "s %d component%s",

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

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

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

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

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

  1676          if (mpl->token == T_COMMA)

  1677             get_token(mpl /* , */);

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

  1679             break;

  1680          else

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

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

  1683          code = expression_5(mpl);

  1684       }

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

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

  1687       return code;

  1688 }

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

  1691 -- indexing_expression - parse indexing expression.

  1692 --

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

  1694 --

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

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

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

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

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

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

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

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

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

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

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

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

  1707 --

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

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

  1710 -- corresponds to individual indexing position. */

  1712 DOMAIN *indexing_expression(MPL *mpl)

  1713 {     DOMAIN *domain;

  1714       DOMAIN_BLOCK *block;

  1715       DOMAIN_SLOT *slot;

  1716       CODE *code;

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

  1718       get_token(mpl /* { */);

  1719       if (mpl->token == T_RBRACE)

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

  1721       /* create domain to be constructed */

  1722       domain = create_domain(mpl);

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

  1724          left brace */

  1725       for (;;)

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

  1727          block = NULL;

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

  1729          code = NULL;

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

  1731          if (mpl->token == T_NAME)

  1732          {  /* it is a symbolic name */

  1733             int next_token;

  1734             char *name;

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

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

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

  1738             next_token = mpl->token;

  1739             unget_token(mpl);

  1740             if (!(next_token == T_IN &&

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

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

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

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

  1745                goto expr;

  1746             }

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

  1748                dummy index */

  1749             block = create_block(mpl);

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

  1751             strcpy(name, mpl->image);

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

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

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

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

  1756             get_token(mpl /* in */);

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

  1758                parsed below */

  1759          }

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

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

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

  1763                recognizing slices; see the routine expression_list) */

  1764             mpl->flag_x = 1;

  1765             code = expression_9(mpl);

  1766             if (code->op != O_SLICE)

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

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

  1769                goto expr;

  1770             }

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

  1772                is already created by expression_list() */

  1773             block = code->arg.slice;

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

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

  1776                by expression_list() */

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

  1778             get_token(mpl /* in */);

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

  1780                parsed below */

  1781          }

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

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

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

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

  1786             this expression can be already parsed above */

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

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

  1789          if (code->type != A_ELEMSET)

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

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

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

  1793                between the left brace and this expression */

  1794             if (block != NULL)

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

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

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

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

  1799                is a temporary elemental set */

  1800             code = literal_set(mpl, code);

  1801          }

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

  1803          xassert(code != NULL);

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

  1805          xassert(code->dim > 0);

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

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

  1808             as <basic set> */

  1809          if (block == NULL)

  1810          {  int j;

  1811             block = create_block(mpl);

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

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

  1814          }

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

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

  1817          {  int dim = 0;

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

  1819                dim++;

  1820             if (dim != code->dim)

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

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

  1823          }

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

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

  1826          block->code = code;

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

  1828          append_block(mpl, domain, block);

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

  1830             include all its dummy indices into the symbolic name table

  1831             to make them available for referencing from expressions;

  1832             implicit declarations of dummy indices remain valid while

  1833             the corresponding domain scope is valid */

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

  1835          if (slot->name != NULL)

  1836          {  AVLNODE *node;

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

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

  1839             avl_set_node_type(node, A_INDEX);

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

  1841          }

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

  1843          if (mpl->token == T_COMMA)

  1844             get_token(mpl /* , */);

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

  1846             break;

  1847          else

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

  1849       }

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

  1851       if (mpl->token == T_COLON)

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

  1853          code = expression_13(mpl);

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

  1855          if (code->type == A_SYMBOLIC)

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

  1857          if (code->type == A_NUMERIC)

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

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

  1860          if (code->type != A_LOGICAL)

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

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

  1863          domain->code = code;

  1864          /* the right brace must follow the logical expression */

  1865          if (mpl->token != T_RBRACE)

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

  1867       }

  1868       get_token(mpl /* } */);

  1869       return domain;

  1870 }

  1872 /*----------------------------------------------------------------------

  1873 -- close_scope - close scope of indexing expression.

  1874 --

  1875 -- The routine closes the scope of indexing expression specified by its

  1876 -- domain and thereby makes all dummy indices introduced in the indexing

  1877 -- expression no longer available for referencing. */

  1879 void close_scope(MPL *mpl, DOMAIN *domain)

  1880 {     DOMAIN_BLOCK *block;

  1881       DOMAIN_SLOT *slot;

  1882       AVLNODE *node;

  1883       xassert(domain != NULL);

  1884       /* remove all dummy indices from the symbolic names table */

  1885       for (block = domain->list; block != NULL; block = block->next)

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

  1887          {  if (slot->name != NULL)

  1888             {  node = avl_find_node(mpl->tree, slot->name);

  1889                xassert(node != NULL);

  1890                xassert(avl_get_node_type(node) == A_INDEX);

  1891                avl_delete_node(mpl->tree, node);

  1892             }

  1893          }

  1894       }

  1895       return;

  1896 }

  1898 /*----------------------------------------------------------------------

  1899 -- iterated_expression - parse iterated expression.

  1900 --

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

  1902 --

  1903 -- <primary expression> ::= <iterated expression>

  1904 -- <iterated expression> ::= sum <indexing expression> <expression 3>

  1905 -- <iterated expression> ::= prod <indexing expression> <expression 3>

  1906 -- <iterated expression> ::= min <indexing expression> <expression 3>

  1907 -- <iterated expression> ::= max <indexing expression> <expression 3>

  1908 -- <iterated expression> ::= exists <indexing expression>

  1909 --                           <expression 12>

  1910 -- <iterated expression> ::= forall <indexing expression>

  1911 --                           <expression 12>

  1912 -- <iterated expression> ::= setof <indexing expression> <expression 5>

  1913 --

  1914 -- Note that parsing "integrand" depends on the iterated operator. */

  1916 #if 1 /* 07/IX-2008 */

  1917 static void link_up(CODE *code)

  1918 {     /* if we have something like sum{(i+1,j,k-1) in E} x[i,j,k],

  1919          where i and k are dummy indices defined out of the iterated

  1920          expression, we should link up pseudo-code for computing i+1

  1921          and k-1 to pseudo-code for computing the iterated expression;

  1922          this is needed to invalidate current value of the iterated

  1923          expression once i or k have been changed */

  1924       DOMAIN_BLOCK *block;

  1925       DOMAIN_SLOT *slot;

  1926       for (block = code->arg.loop.domain->list; block != NULL;

  1927          block = block->next)

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

  1929          {  if (slot->code != NULL)

  1930             {  xassert(slot->code->up == NULL);

  1931                slot->code->up = code;

  1932             }

  1933          }

  1934       }

  1935       return;

  1936 }

  1937 #endif

  1939 CODE *iterated_expression(MPL *mpl)

  1940 {     CODE *code;

  1941       OPERANDS arg;

  1942       int op;

  1943       char opstr[8];

  1944       /* determine operation code */

  1945       xassert(mpl->token == T_NAME);

  1946       if (strcmp(mpl->image, "sum") == 0)

  1947          op = O_SUM;

  1948       else if (strcmp(mpl->image, "prod") == 0)

  1949          op = O_PROD;

  1950       else if (strcmp(mpl->image, "min") == 0)

  1951          op = O_MINIMUM;

  1952       else if (strcmp(mpl->image, "max") == 0)

  1953          op = O_MAXIMUM;

  1954       else if (strcmp(mpl->image, "forall") == 0)

  1955          op = O_FORALL;

  1956       else if (strcmp(mpl->image, "exists") == 0)

  1957          op = O_EXISTS;

  1958       else if (strcmp(mpl->image, "setof") == 0)

  1959          op = O_SETOF;

  1960       else

  1961          error(mpl, "operator %s unknown", mpl->image);

  1962       strcpy(opstr, mpl->image);

  1963       xassert(strlen(opstr) < sizeof(opstr));

  1964       get_token(mpl /* <symbolic name> */);

  1965       /* check the left brace that follows the operator name */

  1966       xassert(mpl->token == T_LBRACE);

  1967       /* parse indexing expression that controls iterating */

  1968       arg.loop.domain = indexing_expression(mpl);

  1969       /* parse "integrand" expression and generate pseudo-code */

  1970       switch (op)

  1971       {  case O_SUM:

  1972          case O_PROD:

  1973          case O_MINIMUM:

  1974          case O_MAXIMUM:

  1975             arg.loop.x = expression_3(mpl);

  1976             /* convert the integrand to numeric type, if necessary */

  1977             if (arg.loop.x->type == A_SYMBOLIC)

  1978                arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x,

  1979                   A_NUMERIC, 0);

  1980             /* now the integrand must be of numeric type or linear form

  1981                (the latter is only allowed for the sum operator) */

  1982             if (!(arg.loop.x->type == A_NUMERIC ||

  1983                   op == O_SUM && arg.loop.x->type == A_FORMULA))

  1984 err:           error(mpl, "integrand following %s{...} has invalid type"

  1985                   , opstr);

  1986             xassert(arg.loop.x->dim == 0);

  1987             /* generate pseudo-code */

  1988             code = make_code(mpl, op, &arg, arg.loop.x->type, 0);

  1989             break;

  1990          case O_FORALL:

  1991          case O_EXISTS:

  1992             arg.loop.x = expression_12(mpl);

  1993             /* convert the integrand to logical type, if necessary */

  1994             if (arg.loop.x->type == A_SYMBOLIC)

  1995                arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x,

  1996                   A_NUMERIC, 0);

  1997             if (arg.loop.x->type == A_NUMERIC)

  1998                arg.loop.x = make_unary(mpl, O_CVTLOG, arg.loop.x,

  1999                   A_LOGICAL, 0);

  2000             /* now the integrand must be of logical type */

  2001             if (arg.loop.x->type != A_LOGICAL) goto err;

  2002             xassert(arg.loop.x->dim == 0);

  2003             /* generate pseudo-code */

  2004             code = make_code(mpl, op, &arg, A_LOGICAL, 0);

  2005             break;

  2006          case O_SETOF:

  2007             arg.loop.x = expression_5(mpl);

  2008             /* convert the integrand to 1-tuple, if necessary */

  2009             if (arg.loop.x->type == A_NUMERIC)

  2010                arg.loop.x = make_unary(mpl, O_CVTSYM, arg.loop.x,

  2011                   A_SYMBOLIC, 0);

  2012             if (arg.loop.x->type == A_SYMBOLIC)

  2013                arg.loop.x = make_unary(mpl, O_CVTTUP, arg.loop.x,

  2014                   A_TUPLE, 1);

  2015             /* now the integrand must be n-tuple */

  2016             if (arg.loop.x->type != A_TUPLE) goto err;

  2017             xassert(arg.loop.x->dim > 0);

  2018             /* generate pseudo-code */

  2019             code = make_code(mpl, op, &arg, A_ELEMSET, arg.loop.x->dim);

  2020             break;

  2021          default:

  2022             xassert(op != op);

  2023       }

  2024       /* close the scope of the indexing expression */

  2025       close_scope(mpl, arg.loop.domain);

  2026 #if 1 /* 07/IX-2008 */

  2027       link_up(code);

  2028 #endif

  2029       return code;

  2030 }

  2032 /*----------------------------------------------------------------------

  2033 -- domain_arity - determine arity of domain.

  2034 --

  2035 -- This routine returns arity of specified domain, which is number of

  2036 -- its free dummy indices. */

  2038 int domain_arity(MPL *mpl, DOMAIN *domain)

  2039 {     DOMAIN_BLOCK *block;

  2040       DOMAIN_SLOT *slot;

  2041       int arity;

  2042       xassert(mpl == mpl);

  2043       arity = 0;

  2044       for (block = domain->list; block != NULL; block = block->next)

  2045          for (slot = block->list; slot != NULL; slot = slot->next)

  2046             if (slot->code == NULL) arity++;

  2047       return arity;

  2048 }

  2050 /*----------------------------------------------------------------------

  2051 -- set_expression - parse set expression.

  2052 --

  2053 -- This routine parses primary expression using the syntax:

  2054 --

  2055 -- <primary expression> ::= { }

  2056 -- <primary expression> ::= <indexing expression> */

  2058 CODE *set_expression(MPL *mpl)

  2059 {     CODE *code;

  2060       OPERANDS arg;

  2061       xassert(mpl->token == T_LBRACE);

  2062       get_token(mpl /* { */);

  2063       /* check a token that follows the left brace */

  2064       if (mpl->token == T_RBRACE)

  2065       {  /* it is the right brace, so the resultant is an empty set of

  2066             dimension 1 */

  2067          arg.list = NULL;

  2068          /* generate pseudo-code to build the resultant set */

  2069          code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, 1);

  2070          get_token(mpl /* } */);

  2071       }

  2072       else

  2073       {  /* the next token begins an indexing expression */

  2074          unget_token(mpl);

  2075          arg.loop.domain = indexing_expression(mpl);

  2076          arg.loop.x = NULL; /* integrand is not used */

  2077          /* close the scope of the indexing expression */

  2078          close_scope(mpl, arg.loop.domain);

  2079          /* generate pseudo-code to build the resultant set */

  2080          code = make_code(mpl, O_BUILD, &arg, A_ELEMSET,

  2081             domain_arity(mpl, arg.loop.domain));

  2082 #if 1 /* 07/IX-2008 */

  2083          link_up(code);

  2084 #endif

  2085       }

  2086       return code;

  2087 }

  2089 /*----------------------------------------------------------------------

  2090 -- branched_expression - parse conditional expression.

  2091 --

  2092 -- This routine parses primary expression using the syntax:

  2093 --

  2094 -- <primary expression> ::= <branched expression>

  2095 -- <branched expression> ::= if <logical expression> then <expression 9>

  2096 -- <branched expression> ::= if <logical expression> then <expression 9>

  2097 --                           else <expression 9>

  2098 -- <logical expression> ::= <expression 13> */

  2100 CODE *branched_expression(MPL *mpl)

  2101 {     CODE *code, *x, *y, *z;

  2102       xassert(mpl->token == T_IF);

  2103       get_token(mpl /* if */);

  2104       /* parse <logical expression> that follows 'if' */

  2105       x = expression_13(mpl);

  2106       /* convert the expression to logical type, if necessary */

  2107       if (x->type == A_SYMBOLIC)

  2108          x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2109       if (x->type == A_NUMERIC)

  2110          x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

  2111       /* now the expression must be of logical type */

  2112       if (x->type != A_LOGICAL)

  2113          error(mpl, "expression following if has invalid type");

  2114       xassert(x->dim == 0);

  2115       /* the keyword 'then' must follow the logical expression */

  2116       if (mpl->token != T_THEN)

  2117          error(mpl, "keyword then missing where expected");

  2118       get_token(mpl /* then */);

  2119       /* parse <expression> that follows 'then' and check its type */

  2120       y = expression_9(mpl);

  2121       if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC ||

  2122             y->type == A_ELEMSET || y->type == A_FORMULA))

  2123          error(mpl, "expression following then has invalid type");

  2124       /* if the expression that follows the keyword 'then' is elemental

  2125          set, the keyword 'else' cannot be omitted; otherwise else-part

  2126          is optional */

  2127       if (mpl->token != T_ELSE)

  2128       {  if (y->type == A_ELEMSET)

  2129             error(mpl, "keyword else missing where expected");

  2130          z = NULL;

  2131          goto skip;

  2132       }

  2133       get_token(mpl /* else */);

  2134       /* parse <expression> that follow 'else' and check its type */

  2135       z = expression_9(mpl);

  2136       if (!(z->type == A_NUMERIC || z->type == A_SYMBOLIC ||

  2137             z->type == A_ELEMSET || z->type == A_FORMULA))

  2138          error(mpl, "expression following else has invalid type");

  2139       /* convert to identical types, if necessary */

  2140       if (y->type == A_FORMULA || z->type == A_FORMULA)

  2141       {  if (y->type == A_SYMBOLIC)

  2142             y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2143          if (y->type == A_NUMERIC)

  2144             y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);

  2145          if (z->type == A_SYMBOLIC)

  2146             z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0);

  2147          if (z->type == A_NUMERIC)

  2148             z = make_unary(mpl, O_CVTLFM, z, A_FORMULA, 0);

  2149       }

  2150       if (y->type == A_SYMBOLIC || z->type == A_SYMBOLIC)

  2151       {  if (y->type == A_NUMERIC)

  2152             y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);

  2153          if (z->type == A_NUMERIC)

  2154             z = make_unary(mpl, O_CVTSYM, z, A_SYMBOLIC, 0);

  2155       }

  2156       /* now both expressions must have identical types */

  2157       if (y->type != z->type)

  2158          error(mpl, "expressions following then and else have incompati"

  2159             "ble types");

  2160       /* and identical dimensions */

  2161       if (y->dim != z->dim)

  2162          error(mpl, "expressions following then and else have different"

  2163             " dimensions %d and %d, respectively", y->dim, z->dim);

  2164 skip: /* generate pseudo-code to perform branching */

  2165       code = make_ternary(mpl, O_FORK, x, y, z, y->type, y->dim);

  2166       return code;

  2167 }

  2169 /*----------------------------------------------------------------------

  2170 -- primary_expression - parse primary expression.

  2171 --

  2172 -- This routine parses primary expression using the syntax:

  2173 --

  2174 -- <primary expression> ::= <numeric literal>

  2175 -- <primary expression> ::= Infinity

  2176 -- <primary expression> ::= <string literal>

  2177 -- <primary expression> ::= <dummy index>

  2178 -- <primary expression> ::= <set name>

  2179 -- <primary expression> ::= <set name> [ <subscript list> ]

  2180 -- <primary expression> ::= <parameter name>

  2181 -- <primary expression> ::= <parameter name> [ <subscript list> ]

  2182 -- <primary expression> ::= <variable name>

  2183 -- <primary expression> ::= <variable name> [ <subscript list> ]

  2184 -- <primary expression> ::= <built-in function> ( <argument list> )

  2185 -- <primary expression> ::= ( <expression list> )

  2186 -- <primary expression> ::= <iterated expression>

  2187 -- <primary expression> ::= { }

  2188 -- <primary expression> ::= <indexing expression>

  2189 -- <primary expression> ::= <branched expression>

  2190 --

  2191 -- For complete list of syntactic rules for <primary expression> see

  2192 -- comments to the corresponding parsing routines. */

  2194 CODE *primary_expression(MPL *mpl)

  2195 {     CODE *code;

  2196       if (mpl->token == T_NUMBER)

  2197       {  /* parse numeric literal */

  2198          code = numeric_literal(mpl);

  2199       }

  2200 #if 1 /* 21/VII-2006 */

  2201       else if (mpl->token == T_INFINITY)

  2202       {  /* parse "infinity" */

  2203          OPERANDS arg;

  2204          arg.num = DBL_MAX;

  2205          code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0);

  2206          get_token(mpl /* Infinity */);

  2207       }

  2208 #endif

  2209       else if (mpl->token == T_STRING)

  2210       {  /* parse string literal */

  2211          code = string_literal(mpl);

  2212       }

  2213       else if (mpl->token == T_NAME)

  2214       {  int next_token;

  2215          get_token(mpl /* <symbolic name> */);

  2216          next_token = mpl->token;

  2217          unget_token(mpl);

  2218          /* check a token that follows <symbolic name> */

  2219          switch (next_token)

  2220          {  case T_LBRACKET:

  2221                /* parse reference to subscripted object */

  2222                code = object_reference(mpl);

  2223                break;

  2224             case T_LEFT:

  2225                /* parse reference to built-in function */

  2226                code = function_reference(mpl);

  2227                break;

  2228             case T_LBRACE:

  2229                /* parse iterated expression */

  2230                code = iterated_expression(mpl);

  2231                break;

  2232             default:

  2233                /* parse reference to unsubscripted object */

  2234                code = object_reference(mpl);

  2235                break;

  2236          }

  2237       }

  2238       else if (mpl->token == T_LEFT)

  2239       {  /* parse parenthesized expression */

  2240          code = expression_list(mpl);

  2241       }

  2242       else if (mpl->token == T_LBRACE)

  2243       {  /* parse set expression */

  2244          code = set_expression(mpl);

  2245       }

  2246       else if (mpl->token == T_IF)

  2247       {  /* parse conditional expression */

  2248          code = branched_expression(mpl);

  2249       }

  2250       else if (is_reserved(mpl))

  2251       {  /* other reserved keywords cannot be used here */

  2252          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  2253       }

  2254       else

  2255          error(mpl, "syntax error in expression");

  2256       return code;

  2257 }

  2259 /*----------------------------------------------------------------------

  2260 -- error_preceding - raise error if preceding operand has wrong type.

  2261 --

  2262 -- This routine is called to raise error if operand that precedes some

  2263 -- infix operator has invalid type. */

  2265 void error_preceding(MPL *mpl, char *opstr)

  2266 {     error(mpl, "operand preceding %s has invalid type", opstr);

  2267       /* no return */

  2268 }

  2270 /*----------------------------------------------------------------------

  2271 -- error_following - raise error if following operand has wrong type.

  2272 --

  2273 -- This routine is called to raise error if operand that follows some

  2274 -- infix operator has invalid type. */

  2276 void error_following(MPL *mpl, char *opstr)

  2277 {     error(mpl, "operand following %s has invalid type", opstr);

  2278       /* no return */

  2279 }

  2281 /*----------------------------------------------------------------------

  2282 -- error_dimension - raise error if operands have different dimension.

  2283 --

  2284 -- This routine is called to raise error if two operands of some infix

  2285 -- operator have different dimension. */

  2287 void error_dimension(MPL *mpl, char *opstr, int dim1, int dim2)

  2288 {     error(mpl, "operands preceding and following %s have different di"

  2289          "mensions %d and %d, respectively", opstr, dim1, dim2);

  2290       /* no return */

  2291 }

  2293 /*----------------------------------------------------------------------

  2294 -- expression_0 - parse expression of level 0.

  2295 --

  2296 -- This routine parses expression of level 0 using the syntax:

  2297 --

  2298 -- <expression 0> ::= <primary expression> */

  2300 CODE *expression_0(MPL *mpl)

  2301 {     CODE *code;

  2302       code = primary_expression(mpl);

  2303       return code;

  2304 }

  2306 /*----------------------------------------------------------------------

  2307 -- expression_1 - parse expression of level 1.

  2308 --

  2309 -- This routine parses expression of level 1 using the syntax:

  2310 --

  2311 -- <expression 1> ::= <expression 0>

  2312 -- <expression 1> ::= <expression 0> <power> <expression 1>

  2313 -- <expression 1> ::= <expression 0> <power> <expression 2>

  2314 -- <power> ::= ^ | ** */

  2316 CODE *expression_1(MPL *mpl)

  2317 {     CODE *x, *y;

  2318       char opstr[8];

  2319       x = expression_0(mpl);

  2320       if (mpl->token == T_POWER)

  2321       {  strcpy(opstr, mpl->image);

  2322          xassert(strlen(opstr) < sizeof(opstr));

  2323          if (x->type == A_SYMBOLIC)

  2324             x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2325          if (x->type != A_NUMERIC)

  2326             error_preceding(mpl, opstr);

  2327          get_token(mpl /* ^ | ** */);

  2328          if (mpl->token == T_PLUS || mpl->token == T_MINUS)

  2329             y = expression_2(mpl);

  2330          else

  2331             y = expression_1(mpl);

  2332          if (y->type == A_SYMBOLIC)

  2333             y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2334          if (y->type != A_NUMERIC)

  2335             error_following(mpl, opstr);

  2336          x = make_binary(mpl, O_POWER, x, y, A_NUMERIC, 0);

  2337       }

  2338       return x;

  2339 }

  2341 /*----------------------------------------------------------------------

  2342 -- expression_2 - parse expression of level 2.

  2343 --

  2344 -- This routine parses expression of level 2 using the syntax:

  2345 --

  2346 -- <expression 2> ::= <expression 1>

  2347 -- <expression 2> ::= + <expression 1>

  2348 -- <expression 2> ::= - <expression 1> */

  2350 CODE *expression_2(MPL *mpl)

  2351 {     CODE *x;

  2352       if (mpl->token == T_PLUS)

  2353       {  get_token(mpl /* + */);

  2354          x = expression_1(mpl);

  2355          if (x->type == A_SYMBOLIC)

  2356             x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2357          if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

  2358             error_following(mpl, "+");

  2359          x = make_unary(mpl, O_PLUS, x, x->type, 0);

  2360       }

  2361       else if (mpl->token == T_MINUS)

  2362       {  get_token(mpl /* - */);

  2363          x = expression_1(mpl);

  2364          if (x->type == A_SYMBOLIC)

  2365             x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2366          if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

  2367             error_following(mpl, "-");

  2368          x = make_unary(mpl, O_MINUS, x, x->type, 0);

  2369       }

  2370       else

  2371          x = expression_1(mpl);

  2372       return x;

  2373 }

  2375 /*----------------------------------------------------------------------

  2376 -- expression_3 - parse expression of level 3.

  2377 --

  2378 -- This routine parses expression of level 3 using the syntax:

  2379 --

  2380 -- <expression 3> ::= <expression 2>

  2381 -- <expression 3> ::= <expression 3> * <expression 2>

  2382 -- <expression 3> ::= <expression 3> / <expression 2>

  2383 -- <expression 3> ::= <expression 3> div <expression 2>

  2384 -- <expression 3> ::= <expression 3> mod <expression 2> */

  2386 CODE *expression_3(MPL *mpl)

  2387 {     CODE *x, *y;

  2388       x = expression_2(mpl);

  2389       for (;;)

  2390       {  if (mpl->token == T_ASTERISK)

  2391          {  if (x->type == A_SYMBOLIC)

  2392                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2393             if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

  2394                error_preceding(mpl, "*");

  2395             get_token(mpl /* * */);

  2396             y = expression_2(mpl);

  2397             if (y->type == A_SYMBOLIC)

  2398                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2399             if (!(y->type == A_NUMERIC || y->type == A_FORMULA))

  2400                error_following(mpl, "*");

  2401             if (x->type == A_FORMULA && y->type == A_FORMULA)

  2402                error(mpl, "multiplication of linear forms not allowed");

  2403             if (x->type == A_NUMERIC && y->type == A_NUMERIC)

  2404                x = make_binary(mpl, O_MUL, x, y, A_NUMERIC, 0);

  2405             else

  2406                x = make_binary(mpl, O_MUL, x, y, A_FORMULA, 0);

  2407          }

  2408          else if (mpl->token == T_SLASH)

  2409          {  if (x->type == A_SYMBOLIC)

  2410                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2411             if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

  2412                error_preceding(mpl, "/");

  2413             get_token(mpl /* / */);

  2414             y = expression_2(mpl);

  2415             if (y->type == A_SYMBOLIC)

  2416                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2417             if (y->type != A_NUMERIC)

  2418                error_following(mpl, "/");

  2419             if (x->type == A_NUMERIC)

  2420                x = make_binary(mpl, O_DIV, x, y, A_NUMERIC, 0);

  2421             else

  2422                x = make_binary(mpl, O_DIV, x, y, A_FORMULA, 0);

  2423          }

  2424          else if (mpl->token == T_DIV)

  2425          {  if (x->type == A_SYMBOLIC)

  2426                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2427             if (x->type != A_NUMERIC)

  2428                error_preceding(mpl, "div");

  2429             get_token(mpl /* div */);

  2430             y = expression_2(mpl);

  2431             if (y->type == A_SYMBOLIC)

  2432                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2433             if (y->type != A_NUMERIC)

  2434                error_following(mpl, "div");

  2435             x = make_binary(mpl, O_IDIV, x, y, A_NUMERIC, 0);

  2436          }

  2437          else if (mpl->token == T_MOD)

  2438          {  if (x->type == A_SYMBOLIC)

  2439                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2440             if (x->type != A_NUMERIC)

  2441                error_preceding(mpl, "mod");

  2442             get_token(mpl /* mod */);

  2443             y = expression_2(mpl);

  2444             if (y->type == A_SYMBOLIC)

  2445                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2446             if (y->type != A_NUMERIC)

  2447                error_following(mpl, "mod");

  2448             x = make_binary(mpl, O_MOD, x, y, A_NUMERIC, 0);

  2449          }

  2450          else

  2451             break;

  2452       }

  2453       return x;

  2454 }

  2456 /*----------------------------------------------------------------------

  2457 -- expression_4 - parse expression of level 4.

  2458 --

  2459 -- This routine parses expression of level 4 using the syntax:

  2460 --

  2461 -- <expression 4> ::= <expression 3>

  2462 -- <expression 4> ::= <expression 4> + <expression 3>

  2463 -- <expression 4> ::= <expression 4> - <expression 3>

  2464 -- <expression 4> ::= <expression 4> less <expression 3> */

  2466 CODE *expression_4(MPL *mpl)

  2467 {     CODE *x, *y;

  2468       x = expression_3(mpl);

  2469       for (;;)

  2470       {  if (mpl->token == T_PLUS)

  2471          {  if (x->type == A_SYMBOLIC)

  2472                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2473             if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

  2474                error_preceding(mpl, "+");

  2475             get_token(mpl /* + */);

  2476             y = expression_3(mpl);

  2477             if (y->type == A_SYMBOLIC)

  2478                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2479             if (!(y->type == A_NUMERIC || y->type == A_FORMULA))

  2480                error_following(mpl, "+");

  2481             if (x->type == A_NUMERIC && y->type == A_FORMULA)

  2482                x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0);

  2483             if (x->type == A_FORMULA && y->type == A_NUMERIC)

  2484                y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);

  2485             x = make_binary(mpl, O_ADD, x, y, x->type, 0);

  2486          }

  2487          else if (mpl->token == T_MINUS)

  2488          {  if (x->type == A_SYMBOLIC)

  2489                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2490             if (!(x->type == A_NUMERIC || x->type == A_FORMULA))

  2491                error_preceding(mpl, "-");

  2492             get_token(mpl /* - */);

  2493             y = expression_3(mpl);

  2494             if (y->type == A_SYMBOLIC)

  2495                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2496             if (!(y->type == A_NUMERIC || y->type == A_FORMULA))

  2497                error_following(mpl, "-");

  2498             if (x->type == A_NUMERIC && y->type == A_FORMULA)

  2499                x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0);

  2500             if (x->type == A_FORMULA && y->type == A_NUMERIC)

  2501                y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);

  2502             x = make_binary(mpl, O_SUB, x, y, x->type, 0);

  2503          }

  2504          else if (mpl->token == T_LESS)

  2505          {  if (x->type == A_SYMBOLIC)

  2506                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2507             if (x->type != A_NUMERIC)

  2508                error_preceding(mpl, "less");

  2509             get_token(mpl /* less */);

  2510             y = expression_3(mpl);

  2511             if (y->type == A_SYMBOLIC)

  2512                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2513             if (y->type != A_NUMERIC)

  2514                error_following(mpl, "less");

  2515             x = make_binary(mpl, O_LESS, x, y, A_NUMERIC, 0);

  2516          }

  2517          else

  2518             break;

  2519       }

  2520       return x;

  2521 }

  2523 /*----------------------------------------------------------------------

  2524 -- expression_5 - parse expression of level 5.

  2525 --

  2526 -- This routine parses expression of level 5 using the syntax:

  2527 --

  2528 -- <expression 5> ::= <expression 4>

  2529 -- <expression 5> ::= <expression 5> & <expression 4> */

  2531 CODE *expression_5(MPL *mpl)

  2532 {     CODE *x, *y;

  2533       x = expression_4(mpl);

  2534       for (;;)

  2535       {  if (mpl->token == T_CONCAT)

  2536          {  if (x->type == A_NUMERIC)

  2537                x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

  2538             if (x->type != A_SYMBOLIC)

  2539                error_preceding(mpl, "&");

  2540             get_token(mpl /* & */);

  2541             y = expression_4(mpl);

  2542             if (y->type == A_NUMERIC)

  2543                y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);

  2544             if (y->type != A_SYMBOLIC)

  2545                error_following(mpl, "&");

  2546             x = make_binary(mpl, O_CONCAT, x, y, A_SYMBOLIC, 0);

  2547          }

  2548          else

  2549             break;

  2550       }

  2551       return x;

  2552 }

  2554 /*----------------------------------------------------------------------

  2555 -- expression_6 - parse expression of level 6.

  2556 --

  2557 -- This routine parses expression of level 6 using the syntax:

  2558 --

  2559 -- <expression 6> ::= <expression 5>

  2560 -- <expression 6> ::= <expression 5> .. <expression 5>

  2561 -- <expression 6> ::= <expression 5> .. <expression 5> by

  2562 --                    <expression 5> */

  2564 CODE *expression_6(MPL *mpl)

  2565 {     CODE *x, *y, *z;

  2566       x = expression_5(mpl);

  2567       if (mpl->token == T_DOTS)

  2568       {  if (x->type == A_SYMBOLIC)

  2569             x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2570          if (x->type != A_NUMERIC)

  2571             error_preceding(mpl, "..");

  2572          get_token(mpl /* .. */);

  2573          y = expression_5(mpl);

  2574          if (y->type == A_SYMBOLIC)

  2575             y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2576          if (y->type != A_NUMERIC)

  2577             error_following(mpl, "..");

  2578          if (mpl->token == T_BY)

  2579          {  get_token(mpl /* by */);

  2580             z = expression_5(mpl);

  2581             if (z->type == A_SYMBOLIC)

  2582                z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0);

  2583             if (z->type != A_NUMERIC)

  2584                error_following(mpl, "by");

  2585          }

  2586          else

  2587             z = NULL;

  2588          x = make_ternary(mpl, O_DOTS, x, y, z, A_ELEMSET, 1);

  2589       }

  2590       return x;

  2591 }

  2593 /*----------------------------------------------------------------------

  2594 -- expression_7 - parse expression of level 7.

  2595 --

  2596 -- This routine parses expression of level 7 using the syntax:

  2597 --

  2598 -- <expression 7> ::= <expression 6>

  2599 -- <expression 7> ::= <expression 7> cross <expression 6> */

  2601 CODE *expression_7(MPL *mpl)

  2602 {     CODE *x, *y;

  2603       x = expression_6(mpl);

  2604       for (;;)

  2605       {  if (mpl->token == T_CROSS)

  2606          {  if (x->type != A_ELEMSET)

  2607                error_preceding(mpl, "cross");

  2608             get_token(mpl /* cross */);

  2609             y = expression_6(mpl);

  2610             if (y->type != A_ELEMSET)

  2611                error_following(mpl, "cross");

  2612             x = make_binary(mpl, O_CROSS, x, y, A_ELEMSET,

  2613                x->dim + y->dim);

  2614          }

  2615          else

  2616             break;

  2617       }

  2618       return x;

  2619 }

  2621 /*----------------------------------------------------------------------

  2622 -- expression_8 - parse expression of level 8.

  2623 --

  2624 -- This routine parses expression of level 8 using the syntax:

  2625 --

  2626 -- <expression 8> ::= <expression 7>

  2627 -- <expression 8> ::= <expression 8> inter <expression 7> */

  2629 CODE *expression_8(MPL *mpl)

  2630 {     CODE *x, *y;

  2631       x = expression_7(mpl);

  2632       for (;;)

  2633       {  if (mpl->token == T_INTER)

  2634          {  if (x->type != A_ELEMSET)

  2635                error_preceding(mpl, "inter");

  2636             get_token(mpl /* inter */);

  2637             y = expression_7(mpl);

  2638             if (y->type != A_ELEMSET)

  2639                error_following(mpl, "inter");

  2640             if (x->dim != y->dim)

  2641                error_dimension(mpl, "inter", x->dim, y->dim);

  2642             x = make_binary(mpl, O_INTER, x, y, A_ELEMSET, x->dim);

  2643          }

  2644          else

  2645             break;

  2646       }

  2647       return x;

  2648 }

  2650 /*----------------------------------------------------------------------

  2651 -- expression_9 - parse expression of level 9.

  2652 --

  2653 -- This routine parses expression of level 9 using the syntax:

  2654 --

  2655 -- <expression 9> ::= <expression 8>

  2656 -- <expression 9> ::= <expression 9> union <expression 8>

  2657 -- <expression 9> ::= <expression 9> diff <expression 8>

  2658 -- <expression 9> ::= <expression 9> symdiff <expression 8> */

  2660 CODE *expression_9(MPL *mpl)

  2661 {     CODE *x, *y;

  2662       x = expression_8(mpl);

  2663       for (;;)

  2664       {  if (mpl->token == T_UNION)

  2665          {  if (x->type != A_ELEMSET)

  2666                error_preceding(mpl, "union");

  2667             get_token(mpl /* union */);

  2668             y = expression_8(mpl);

  2669             if (y->type != A_ELEMSET)

  2670                error_following(mpl, "union");

  2671             if (x->dim != y->dim)

  2672                error_dimension(mpl, "union", x->dim, y->dim);

  2673             x = make_binary(mpl, O_UNION, x, y, A_ELEMSET, x->dim);

  2674          }

  2675          else if (mpl->token == T_DIFF)

  2676          {  if (x->type != A_ELEMSET)

  2677                error_preceding(mpl, "diff");

  2678             get_token(mpl /* diff */);

  2679             y = expression_8(mpl);

  2680             if (y->type != A_ELEMSET)

  2681                error_following(mpl, "diff");

  2682             if (x->dim != y->dim)

  2683                error_dimension(mpl, "diff", x->dim, y->dim);

  2684             x = make_binary(mpl, O_DIFF, x, y, A_ELEMSET, x->dim);

  2685          }

  2686          else if (mpl->token == T_SYMDIFF)

  2687          {  if (x->type != A_ELEMSET)

  2688                error_preceding(mpl, "symdiff");

  2689             get_token(mpl /* symdiff */);

  2690             y = expression_8(mpl);

  2691             if (y->type != A_ELEMSET)

  2692                error_following(mpl, "symdiff");

  2693             if (x->dim != y->dim)

  2694                error_dimension(mpl, "symdiff", x->dim, y->dim);

  2695             x = make_binary(mpl, O_SYMDIFF, x, y, A_ELEMSET, x->dim);

  2696          }

  2697          else

  2698             break;

  2699       }

  2700       return x;

  2701 }

  2703 /*----------------------------------------------------------------------

  2704 -- expression_10 - parse expression of level 10.

  2705 --

  2706 -- This routine parses expression of level 10 using the syntax:

  2707 --

  2708 -- <expression 10> ::= <expression 9>

  2709 -- <expression 10> ::= <expression 9> <rho> <expression 9>

  2710 -- <rho> ::= < | <= | = | == | >= | > | <> | != | in | not in | ! in |

  2711 --           within | not within | ! within */

  2713 CODE *expression_10(MPL *mpl)

  2714 {     CODE *x, *y;

  2715       int op = -1;

  2716       char opstr[16];

  2717       x = expression_9(mpl);

  2718       strcpy(opstr, "");

  2719       switch (mpl->token)

  2720       {  case T_LT:

  2721             op = O_LT; break;

  2722          case T_LE:

  2723             op = O_LE; break;

  2724          case T_EQ:

  2725             op = O_EQ; break;

  2726          case T_GE:

  2727             op = O_GE; break;

  2728          case T_GT:

  2729             op = O_GT; break;

  2730          case T_NE:

  2731             op = O_NE; break;

  2732          case T_IN:

  2733             op = O_IN; break;

  2734          case T_WITHIN:

  2735             op = O_WITHIN; break;

  2736          case T_NOT:

  2737             strcpy(opstr, mpl->image);

  2738             get_token(mpl /* not | ! */);

  2739             if (mpl->token == T_IN)

  2740                op = O_NOTIN;

  2741             else if (mpl->token == T_WITHIN)

  2742                op = O_NOTWITHIN;

  2743             else

  2744                error(mpl, "invalid use of %s", opstr);

  2745             strcat(opstr, " ");

  2746             break;

  2747          default:

  2748             goto done;

  2749       }

  2750       strcat(opstr, mpl->image);

  2751       xassert(strlen(opstr) < sizeof(opstr));

  2752       switch (op)

  2753       {  case O_EQ:

  2754          case O_NE:

  2755 #if 1 /* 02/VIII-2008 */

  2756          case O_LT:

  2757          case O_LE:

  2758          case O_GT:

  2759          case O_GE:

  2760 #endif

  2761             if (!(x->type == A_NUMERIC || x->type == A_SYMBOLIC))

  2762                error_preceding(mpl, opstr);

  2763             get_token(mpl /* <rho> */);

  2764             y = expression_9(mpl);

  2765             if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC))

  2766                error_following(mpl, opstr);

  2767             if (x->type == A_NUMERIC && y->type == A_SYMBOLIC)

  2768                x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

  2769             if (x->type == A_SYMBOLIC && y->type == A_NUMERIC)

  2770                y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);

  2771             x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

  2772             break;

  2773 #if 0 /* 02/VIII-2008 */

  2774          case O_LT:

  2775          case O_LE:

  2776          case O_GT:

  2777          case O_GE:

  2778             if (x->type == A_SYMBOLIC)

  2779                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2780             if (x->type != A_NUMERIC)

  2781                error_preceding(mpl, opstr);

  2782             get_token(mpl /* <rho> */);

  2783             y = expression_9(mpl);

  2784             if (y->type == A_SYMBOLIC)

  2785                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2786             if (y->type != A_NUMERIC)

  2787                error_following(mpl, opstr);

  2788             x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

  2789             break;

  2790 #endif

  2791          case O_IN:

  2792          case O_NOTIN:

  2793             if (x->type == A_NUMERIC)

  2794                x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);

  2795             if (x->type == A_SYMBOLIC)

  2796                x = make_unary(mpl, O_CVTTUP, x, A_TUPLE, 1);

  2797             if (x->type != A_TUPLE)

  2798                error_preceding(mpl, opstr);

  2799             get_token(mpl /* <rho> */);

  2800             y = expression_9(mpl);

  2801             if (y->type != A_ELEMSET)

  2802                error_following(mpl, opstr);

  2803             if (x->dim != y->dim)

  2804                error_dimension(mpl, opstr, x->dim, y->dim);

  2805             x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

  2806             break;

  2807          case O_WITHIN:

  2808          case O_NOTWITHIN:

  2809             if (x->type != A_ELEMSET)

  2810                error_preceding(mpl, opstr);

  2811             get_token(mpl /* <rho> */);

  2812             y = expression_9(mpl);

  2813             if (y->type != A_ELEMSET)

  2814                error_following(mpl, opstr);

  2815             if (x->dim != y->dim)

  2816                error_dimension(mpl, opstr, x->dim, y->dim);

  2817             x = make_binary(mpl, op, x, y, A_LOGICAL, 0);

  2818             break;

  2819          default:

  2820             xassert(op != op);

  2821       }

  2822 done: return x;

  2823 }

  2825 /*----------------------------------------------------------------------

  2826 -- expression_11 - parse expression of level 11.

  2827 --

  2828 -- This routine parses expression of level 11 using the syntax:

  2829 --

  2830 -- <expression 11> ::= <expression 10>

  2831 -- <expression 11> ::= not <expression 10>

  2832 -- <expression 11> ::= ! <expression 10> */

  2834 CODE *expression_11(MPL *mpl)

  2835 {     CODE *x;

  2836       char opstr[8];

  2837       if (mpl->token == T_NOT)

  2838       {  strcpy(opstr, mpl->image);

  2839          xassert(strlen(opstr) < sizeof(opstr));

  2840          get_token(mpl /* not | ! */);

  2841          x = expression_10(mpl);

  2842          if (x->type == A_SYMBOLIC)

  2843             x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2844          if (x->type == A_NUMERIC)

  2845             x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

  2846          if (x->type != A_LOGICAL)

  2847             error_following(mpl, opstr);

  2848          x = make_unary(mpl, O_NOT, x, A_LOGICAL, 0);

  2849       }

  2850       else

  2851          x = expression_10(mpl);

  2852       return x;

  2853 }

  2855 /*----------------------------------------------------------------------

  2856 -- expression_12 - parse expression of level 12.

  2857 --

  2858 -- This routine parses expression of level 12 using the syntax:

  2859 --

  2860 -- <expression 12> ::= <expression 11>

  2861 -- <expression 12> ::= <expression 12> and <expression 11>

  2862 -- <expression 12> ::= <expression 12> && <expression 11> */

  2864 CODE *expression_12(MPL *mpl)

  2865 {     CODE *x, *y;

  2866       char opstr[8];

  2867       x = expression_11(mpl);

  2868       for (;;)

  2869       {  if (mpl->token == T_AND)

  2870          {  strcpy(opstr, mpl->image);

  2871             xassert(strlen(opstr) < sizeof(opstr));

  2872             if (x->type == A_SYMBOLIC)

  2873                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2874             if (x->type == A_NUMERIC)

  2875                x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

  2876             if (x->type != A_LOGICAL)

  2877                error_preceding(mpl, opstr);

  2878             get_token(mpl /* and | && */);

  2879             y = expression_11(mpl);

  2880             if (y->type == A_SYMBOLIC)

  2881                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2882             if (y->type == A_NUMERIC)

  2883                y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0);

  2884             if (y->type != A_LOGICAL)

  2885                error_following(mpl, opstr);

  2886             x = make_binary(mpl, O_AND, x, y, A_LOGICAL, 0);

  2887          }

  2888          else

  2889             break;

  2890       }

  2891       return x;

  2892 }

  2894 /*----------------------------------------------------------------------

  2895 -- expression_13 - parse expression of level 13.

  2896 --

  2897 -- This routine parses expression of level 13 using the syntax:

  2898 --

  2899 -- <expression 13> ::= <expression 12>

  2900 -- <expression 13> ::= <expression 13> or <expression 12>

  2901 -- <expression 13> ::= <expression 13> || <expression 12> */

  2903 CODE *expression_13(MPL *mpl)

  2904 {     CODE *x, *y;

  2905       char opstr[8];

  2906       x = expression_12(mpl);

  2907       for (;;)

  2908       {  if (mpl->token == T_OR)

  2909          {  strcpy(opstr, mpl->image);

  2910             xassert(strlen(opstr) < sizeof(opstr));

  2911             if (x->type == A_SYMBOLIC)

  2912                x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);

  2913             if (x->type == A_NUMERIC)

  2914                x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);

  2915             if (x->type != A_LOGICAL)

  2916                error_preceding(mpl, opstr);

  2917             get_token(mpl /* or | || */);

  2918             y = expression_12(mpl);

  2919             if (y->type == A_SYMBOLIC)

  2920                y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);

  2921             if (y->type == A_NUMERIC)

  2922                y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0);

  2923             if (y->type != A_LOGICAL)

  2924                error_following(mpl, opstr);

  2925             x = make_binary(mpl, O_OR, x, y, A_LOGICAL, 0);

  2926          }

  2927          else

  2928             break;

  2929       }

  2930       return x;

  2931 }

  2933 /*----------------------------------------------------------------------

  2934 -- set_statement - parse set statement.

  2935 --

  2936 -- This routine parses set statement using the syntax:

  2937 --

  2938 -- <set statement> ::= set <symbolic name> <alias> <domain>

  2939 --                     <attributes> ;

  2940 -- <alias> ::= <empty>

  2941 -- <alias> ::= <string literal>

  2942 -- <domain> ::= <empty>

  2943 -- <domain> ::= <indexing expression>

  2944 -- <attributes> ::= <empty>

  2945 -- <attributes> ::= <attributes> , dimen <numeric literal>

  2946 -- <attributes> ::= <attributes> , within <expression 9>

  2947 -- <attributes> ::= <attributes> , := <expression 9>

  2948 -- <attributes> ::= <attributes> , default <expression 9>

  2949 --

  2950 -- Commae in <attributes> are optional and may be omitted anywhere. */

  2952 SET *set_statement(MPL *mpl)

  2953 {     SET *set;

  2954       int dimen_used = 0;

  2955       xassert(is_keyword(mpl, "set"));

  2956       get_token(mpl /* set */);

  2957       /* symbolic name must follow the keyword 'set' */

  2958       if (mpl->token == T_NAME)

  2959          ;

  2960       else if (is_reserved(mpl))

  2961          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  2962       else

  2963          error(mpl, "symbolic name missing where expected");

  2964       /* there must be no other object with the same name */

  2965       if (avl_find_node(mpl->tree, mpl->image) != NULL)

  2966          error(mpl, "%s multiply declared", mpl->image);

  2967       /* create model set */

  2968       set = alloc(SET);

  2969       set->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  2970       strcpy(set->name, mpl->image);

  2971       set->alias = NULL;

  2972       set->dim = 0;

  2973       set->domain = NULL;

  2974       set->dimen = 0;

  2975       set->within = NULL;

  2976       set->assign = NULL;

  2977       set->option = NULL;

  2978       set->gadget = NULL;

  2979       set->data = 0;

  2980       set->array = NULL;

  2981       get_token(mpl /* <symbolic name> */);

  2982       /* parse optional alias */

  2983       if (mpl->token == T_STRING)

  2984       {  set->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  2985          strcpy(set->alias, mpl->image);

  2986          get_token(mpl /* <string literal> */);

  2987       }

  2988       /* parse optional indexing expression */

  2989       if (mpl->token == T_LBRACE)

  2990       {  set->domain = indexing_expression(mpl);

  2991          set->dim = domain_arity(mpl, set->domain);

  2992       }

  2993       /* include the set name in the symbolic names table */

  2994       {  AVLNODE *node;

  2995          node = avl_insert_node(mpl->tree, set->name);

  2996          avl_set_node_type(node, A_SET);

  2997          avl_set_node_link(node, (void *)set);

  2998       }

  2999       /* parse the list of optional attributes */

  3000       for (;;)

  3001       {  if (mpl->token == T_COMMA)

  3002             get_token(mpl /* , */);

  3003          else if (mpl->token == T_SEMICOLON)

  3004             break;

  3005          if (is_keyword(mpl, "dimen"))

  3006          {  /* dimension of set members */

  3007             int dimen;

  3008             get_token(mpl /* dimen */);

  3009             if (!(mpl->token == T_NUMBER &&

  3010                   1.0 <= mpl->value && mpl->value <= 20.0 &&

  3011                   floor(mpl->value) == mpl->value))

  3012                error(mpl, "dimension must be integer between 1 and 20");

  3013             dimen = (int)(mpl->value + 0.5);

  3014             if (dimen_used)

  3015                error(mpl, "at most one dimension attribute allowed");

  3016             if (set->dimen > 0)

  3017                error(mpl, "dimension %d conflicts with dimension %d alr"

  3018                   "eady determined", dimen, set->dimen);

  3019             set->dimen = dimen;

  3020             dimen_used = 1;

  3021             get_token(mpl /* <numeric literal> */);

  3022          }

  3023          else if (mpl->token == T_WITHIN || mpl->token == T_IN)

  3024          {  /* restricting superset */

  3025             WITHIN *within, *temp;

  3026             if (mpl->token == T_IN && !mpl->as_within)

  3027             {  warning(mpl, "keyword in understood as within");

  3028                mpl->as_within = 1;

  3029             }

  3030             get_token(mpl /* within */);

  3031             /* create new restricting superset list entry and append it

  3032                to the within-list */

  3033             within = alloc(WITHIN);

  3034             within->code = NULL;

  3035             within->next = NULL;

  3036             if (set->within == NULL)

  3037                set->within = within;

  3038             else

  3039             {  for (temp = set->within; temp->next != NULL; temp =

  3040                   temp->next);

  3041                temp->next = within;

  3042             }

  3043             /* parse an expression that follows 'within' */

  3044             within->code = expression_9(mpl);

  3045             if (within->code->type != A_ELEMSET)

  3046                error(mpl, "expression following within has invalid type"

  3047                   );

  3048             xassert(within->code->dim > 0);

  3049             /* check/set dimension of set members */

  3050             if (set->dimen == 0) set->dimen = within->code->dim;

  3051             if (set->dimen != within->code->dim)

  3052                error(mpl, "set expression following within must have di"

  3053                   "mension %d rather than %d",

  3054                   set->dimen, within->code->dim);

  3055          }

  3056          else if (mpl->token == T_ASSIGN)

  3057          {  /* assignment expression */

  3058             if (!(set->assign == NULL && set->option == NULL &&

  3059                   set->gadget == NULL))

  3060 err:           error(mpl, "at most one := or default/data allowed");

  3061             get_token(mpl /* := */);

  3062             /* parse an expression that follows ':=' */

  3063             set->assign = expression_9(mpl);

  3064             if (set->assign->type != A_ELEMSET)

  3065                error(mpl, "expression following := has invalid type");

  3066             xassert(set->assign->dim > 0);

  3067             /* check/set dimension of set members */

  3068             if (set->dimen == 0) set->dimen = set->assign->dim;

  3069             if (set->dimen != set->assign->dim)

  3070                error(mpl, "set expression following := must have dimens"

  3071                   "ion %d rather than %d",

  3072                   set->dimen, set->assign->dim);

  3073          }

  3074          else if (is_keyword(mpl, "default"))

  3075          {  /* expression for default value */

  3076             if (!(set->assign == NULL && set->option == NULL)) goto err;

  3077             get_token(mpl /* := */);

  3078             /* parse an expression that follows 'default' */

  3079             set->option = expression_9(mpl);

  3080             if (set->option->type != A_ELEMSET)

  3081                error(mpl, "expression following default has invalid typ"

  3082                   "e");

  3083             xassert(set->option->dim > 0);

  3084             /* check/set dimension of set members */

  3085             if (set->dimen == 0) set->dimen = set->option->dim;

  3086             if (set->dimen != set->option->dim)

  3087                error(mpl, "set expression following default must have d"

  3088                   "imension %d rather than %d",

  3089                   set->dimen, set->option->dim);

  3090          }

  3091 #if 1 /* 12/XII-2008 */

  3092          else if (is_keyword(mpl, "data"))

  3093          {  /* gadget to initialize the set by data from plain set */

  3094             GADGET *gadget;

  3095             AVLNODE *node;

  3096             int i, k, fff[20];

  3097             if (!(set->assign == NULL && set->gadget == NULL)) goto err;

  3098             get_token(mpl /* data */);

  3099             set->gadget = gadget = alloc(GADGET);

  3100             /* set name must follow the keyword 'data' */

  3101             if (mpl->token == T_NAME)

  3102                ;

  3103             else if (is_reserved(mpl))

  3104                error(mpl, "invalid use of reserved keyword %s",

  3105                   mpl->image);

  3106             else

  3107                error(mpl, "set name missing where expected");

  3108             /* find the set in the symbolic name table */

  3109             node = avl_find_node(mpl->tree, mpl->image);

  3110             if (node == NULL)

  3111                error(mpl, "%s not defined", mpl->image);

  3112             if (avl_get_node_type(node) != A_SET)

  3113 err1:          error(mpl, "%s not a plain set", mpl->image);

  3114             gadget->set = avl_get_node_link(node);

  3115             if (gadget->set->dim != 0) goto err1;

  3116             if (gadget->set == set)

  3117                error(mpl, "set cannot be initialized by itself");

  3118             /* check and set dimensions */

  3119             if (set->dim >= gadget->set->dimen)

  3120 err2:          error(mpl, "dimension of %s too small", mpl->image);

  3121             if (set->dimen == 0)

  3122                set->dimen = gadget->set->dimen - set->dim;

  3123             if (set->dim + set->dimen > gadget->set->dimen)

  3124                goto err2;

  3125             else if (set->dim + set->dimen < gadget->set->dimen)

  3126                error(mpl, "dimension of %s too big", mpl->image);

  3127             get_token(mpl /* set name */);

  3128             /* left parenthesis must follow the set name */

  3129             if (mpl->token == T_LEFT)

  3130                get_token(mpl /* ( */);

  3131             else

  3132                error(mpl, "left parenthesis missing where expected");

  3133             /* parse permutation of component numbers */

  3134             for (k = 0; k < gadget->set->dimen; k++) fff[k] = 0;

  3135             k = 0;

  3136             for (;;)

  3137             {  if (mpl->token != T_NUMBER)

  3138                   error(mpl, "component number missing where expected");

  3139                if (str2int(mpl->image, &i) != 0)

  3140 err3:             error(mpl, "component number must be integer between "

  3141                      "1 and %d", gadget->set->dimen);

  3142                if (!(1 <= i && i <= gadget->set->dimen)) goto err3;

  3143                if (fff[i-1] != 0)

  3144                   error(mpl, "component %d multiply specified", i);

  3145                gadget->ind[k++] = i, fff[i-1] = 1;

  3146                xassert(k <= gadget->set->dimen);

  3147                get_token(mpl /* number */);

  3148                if (mpl->token == T_COMMA)

  3149                   get_token(mpl /* , */);

  3150                else if (mpl->token == T_RIGHT)

  3151                   break;

  3152                else

  3153                   error(mpl, "syntax error in data attribute");

  3154             }

  3155             if (k < gadget->set->dimen)

  3156                error(mpl, "there are must be %d components rather than "

  3157                   "%d", gadget->set->dimen, k);

  3158             get_token(mpl /* ) */);

  3159          }

  3160 #endif

  3161          else

  3162             error(mpl, "syntax error in set statement");

  3163       }

  3164       /* close the domain scope */

  3165       if (set->domain != NULL) close_scope(mpl, set->domain);

  3166       /* if dimension of set members is still unknown, set it to 1 */

  3167       if (set->dimen == 0) set->dimen = 1;

  3168       /* the set statement has been completely parsed */

  3169       xassert(mpl->token == T_SEMICOLON);

  3170       get_token(mpl /* ; */);

  3171       return set;

  3172 }

  3174 /*----------------------------------------------------------------------

  3175 -- parameter_statement - parse parameter statement.

  3176 --

  3177 -- This routine parses parameter statement using the syntax:

  3178 --

  3179 -- <parameter statement> ::= param <symbolic name> <alias> <domain>

  3180 --                           <attributes> ;

  3181 -- <alias> ::= <empty>

  3182 -- <alias> ::= <string literal>

  3183 -- <domain> ::= <empty>

  3184 -- <domain> ::= <indexing expression>

  3185 -- <attributes> ::= <empty>

  3186 -- <attributes> ::= <attributes> , integer

  3187 -- <attributes> ::= <attributes> , binary

  3188 -- <attributes> ::= <attributes> , symbolic

  3189 -- <attributes> ::= <attributes> , <rho> <expression 5>

  3190 -- <attributes> ::= <attributes> , in <expression 9>

  3191 -- <attributes> ::= <attributes> , := <expression 5>

  3192 -- <attributes> ::= <attributes> , default <expression 5>

  3193 -- <rho> ::= < | <= | = | == | >= | > | <> | !=

  3194 --

  3195 -- Commae in <attributes> are optional and may be omitted anywhere. */

  3197 PARAMETER *parameter_statement(MPL *mpl)

  3198 {     PARAMETER *par;

  3199       int integer_used = 0, binary_used = 0, symbolic_used = 0;

  3200       xassert(is_keyword(mpl, "param"));

  3201       get_token(mpl /* param */);

  3202       /* symbolic name must follow the keyword 'param' */

  3203       if (mpl->token == T_NAME)

  3204          ;

  3205       else if (is_reserved(mpl))

  3206          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  3207       else

  3208          error(mpl, "symbolic name missing where expected");

  3209       /* there must be no other object with the same name */

  3210       if (avl_find_node(mpl->tree, mpl->image) != NULL)

  3211          error(mpl, "%s multiply declared", mpl->image);

  3212       /* create model parameter */

  3213       par = alloc(PARAMETER);

  3214       par->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3215       strcpy(par->name, mpl->image);

  3216       par->alias = NULL;

  3217       par->dim = 0;

  3218       par->domain = NULL;

  3219       par->type = A_NUMERIC;

  3220       par->cond = NULL;

  3221       par->in = NULL;

  3222       par->assign = NULL;

  3223       par->option = NULL;

  3224       par->data = 0;

  3225       par->defval = NULL;

  3226       par->array = NULL;

  3227       get_token(mpl /* <symbolic name> */);

  3228       /* parse optional alias */

  3229       if (mpl->token == T_STRING)

  3230       {  par->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3231          strcpy(par->alias, mpl->image);

  3232          get_token(mpl /* <string literal> */);

  3233       }

  3234       /* parse optional indexing expression */

  3235       if (mpl->token == T_LBRACE)

  3236       {  par->domain = indexing_expression(mpl);

  3237          par->dim = domain_arity(mpl, par->domain);

  3238       }

  3239       /* include the parameter name in the symbolic names table */

  3240       {  AVLNODE *node;

  3241          node = avl_insert_node(mpl->tree, par->name);

  3242          avl_set_node_type(node, A_PARAMETER);

  3243          avl_set_node_link(node, (void *)par);

  3244       }

  3245       /* parse the list of optional attributes */

  3246       for (;;)

  3247       {  if (mpl->token == T_COMMA)

  3248             get_token(mpl /* , */);

  3249          else if (mpl->token == T_SEMICOLON)

  3250             break;

  3251          if (is_keyword(mpl, "integer"))

  3252          {  if (integer_used)

  3253                error(mpl, "at most one integer allowed");

  3254             if (par->type == A_SYMBOLIC)

  3255                error(mpl, "symbolic parameter cannot be integer");

  3256             if (par->type != A_BINARY) par->type = A_INTEGER;

  3257             integer_used = 1;

  3258             get_token(mpl /* integer */);

  3259          }

  3260          else if (is_keyword(mpl, "binary"))

  3261 bin:     {  if (binary_used)

  3262                error(mpl, "at most one binary allowed");

  3263             if (par->type == A_SYMBOLIC)

  3264                error(mpl, "symbolic parameter cannot be binary");

  3265             par->type = A_BINARY;

  3266             binary_used = 1;

  3267             get_token(mpl /* binary */);

  3268          }

  3269          else if (is_keyword(mpl, "logical"))

  3270          {  if (!mpl->as_binary)

  3271             {  warning(mpl, "keyword logical understood as binary");

  3272                mpl->as_binary = 1;

  3273             }

  3274             goto bin;

  3275          }

  3276          else if (is_keyword(mpl, "symbolic"))

  3277          {  if (symbolic_used)

  3278                error(mpl, "at most one symbolic allowed");

  3279             if (par->type != A_NUMERIC)

  3280                error(mpl, "integer or binary parameter cannot be symbol"

  3281                   "ic");

  3282             /* the parameter may be referenced from expressions given

  3283                in the same parameter declaration, so its type must be

  3284                completed before parsing that expressions */

  3285             if (!(par->cond == NULL && par->in == NULL &&

  3286                   par->assign == NULL && par->option == NULL))

  3287                error(mpl, "keyword symbolic must precede any other para"

  3288                   "meter attributes");

  3289             par->type = A_SYMBOLIC;

  3290             symbolic_used = 1;

  3291             get_token(mpl /* symbolic */);

  3292          }

  3293          else if (mpl->token == T_LT || mpl->token == T_LE ||

  3294                   mpl->token == T_EQ || mpl->token == T_GE ||

  3295                   mpl->token == T_GT || mpl->token == T_NE)

  3296          {  /* restricting condition */

  3297             CONDITION *cond, *temp;

  3298             char opstr[8];

  3299             /* create new restricting condition list entry and append

  3300                it to the conditions list */

  3301             cond = alloc(CONDITION);

  3302             switch (mpl->token)

  3303             {  case T_LT:

  3304                   cond->rho = O_LT, strcpy(opstr, mpl->image); break;

  3305                case T_LE:

  3306                   cond->rho = O_LE, strcpy(opstr, mpl->image); break;

  3307                case T_EQ:

  3308                   cond->rho = O_EQ, strcpy(opstr, mpl->image); break;

  3309                case T_GE:

  3310                   cond->rho = O_GE, strcpy(opstr, mpl->image); break;

  3311                case T_GT:

  3312                   cond->rho = O_GT, strcpy(opstr, mpl->image); break;

  3313                case T_NE:

  3314                   cond->rho = O_NE, strcpy(opstr, mpl->image); break;

  3315                default:

  3316                   xassert(mpl->token != mpl->token);

  3317             }

  3318             xassert(strlen(opstr) < sizeof(opstr));

  3319             cond->code = NULL;

  3320             cond->next = NULL;

  3321             if (par->cond == NULL)

  3322                par->cond = cond;

  3323             else

  3324             {  for (temp = par->cond; temp->next != NULL; temp =

  3325                   temp->next);

  3326                temp->next = cond;

  3327             }

  3328 #if 0 /* 13/VIII-2008 */

  3329             if (par->type == A_SYMBOLIC &&

  3330                !(cond->rho == O_EQ || cond->rho == O_NE))

  3331                error(mpl, "inequality restriction not allowed");

  3332 #endif

  3333             get_token(mpl /* rho */);

  3334             /* parse an expression that follows relational operator */

  3335             cond->code = expression_5(mpl);

  3336             if (!(cond->code->type == A_NUMERIC ||

  3337                   cond->code->type == A_SYMBOLIC))

  3338                error(mpl, "expression following %s has invalid type",

  3339                   opstr);

  3340             xassert(cond->code->dim == 0);

  3341             /* convert to the parameter type, if necessary */

  3342             if (par->type != A_SYMBOLIC && cond->code->type ==

  3343                A_SYMBOLIC)

  3344                cond->code = make_unary(mpl, O_CVTNUM, cond->code,

  3345                   A_NUMERIC, 0);

  3346             if (par->type == A_SYMBOLIC && cond->code->type !=

  3347                A_SYMBOLIC)

  3348                cond->code = make_unary(mpl, O_CVTSYM, cond->code,

  3349                   A_SYMBOLIC, 0);

  3350          }

  3351          else if (mpl->token == T_IN || mpl->token == T_WITHIN)

  3352          {  /* restricting superset */

  3353             WITHIN *in, *temp;

  3354             if (mpl->token == T_WITHIN && !mpl->as_in)

  3355             {  warning(mpl, "keyword within understood as in");

  3356                mpl->as_in = 1;

  3357             }

  3358             get_token(mpl /* in */);

  3359             /* create new restricting superset list entry and append it

  3360                to the in-list */

  3361             in = alloc(WITHIN);

  3362             in->code = NULL;

  3363             in->next = NULL;

  3364             if (par->in == NULL)

  3365                par->in = in;

  3366             else

  3367             {  for (temp = par->in; temp->next != NULL; temp =

  3368                   temp->next);

  3369                temp->next = in;

  3370             }

  3371             /* parse an expression that follows 'in' */

  3372             in->code = expression_9(mpl);

  3373             if (in->code->type != A_ELEMSET)

  3374                error(mpl, "expression following in has invalid type");

  3375             xassert(in->code->dim > 0);

  3376             if (in->code->dim != 1)

  3377                error(mpl, "set expression following in must have dimens"

  3378                   "ion 1 rather than %d", in->code->dim);

  3379          }

  3380          else if (mpl->token == T_ASSIGN)

  3381          {  /* assignment expression */

  3382             if (!(par->assign == NULL && par->option == NULL))

  3383 err:           error(mpl, "at most one := or default allowed");

  3384             get_token(mpl /* := */);

  3385             /* parse an expression that follows ':=' */

  3386             par->assign = expression_5(mpl);

  3387             /* the expression must be of numeric/symbolic type */

  3388             if (!(par->assign->type == A_NUMERIC ||

  3389                   par->assign->type == A_SYMBOLIC))

  3390                error(mpl, "expression following := has invalid type");

  3391             xassert(par->assign->dim == 0);

  3392             /* convert to the parameter type, if necessary */

  3393             if (par->type != A_SYMBOLIC && par->assign->type ==

  3394                A_SYMBOLIC)

  3395                par->assign = make_unary(mpl, O_CVTNUM, par->assign,

  3396                   A_NUMERIC, 0);

  3397             if (par->type == A_SYMBOLIC && par->assign->type !=

  3398                A_SYMBOLIC)

  3399                par->assign = make_unary(mpl, O_CVTSYM, par->assign,

  3400                   A_SYMBOLIC, 0);

  3401          }

  3402          else if (is_keyword(mpl, "default"))

  3403          {  /* expression for default value */

  3404             if (!(par->assign == NULL && par->option == NULL)) goto err;

  3405             get_token(mpl /* default */);

  3406             /* parse an expression that follows 'default' */

  3407             par->option = expression_5(mpl);

  3408             if (!(par->option->type == A_NUMERIC ||

  3409                   par->option->type == A_SYMBOLIC))

  3410                error(mpl, "expression following default has invalid typ"

  3411                   "e");

  3412             xassert(par->option->dim == 0);

  3413             /* convert to the parameter type, if necessary */

  3414             if (par->type != A_SYMBOLIC && par->option->type ==

  3415                A_SYMBOLIC)

  3416                par->option = make_unary(mpl, O_CVTNUM, par->option,

  3417                   A_NUMERIC, 0);

  3418             if (par->type == A_SYMBOLIC && par->option->type !=

  3419                A_SYMBOLIC)

  3420                par->option = make_unary(mpl, O_CVTSYM, par->option,

  3421                   A_SYMBOLIC, 0);

  3422          }

  3423          else

  3424             error(mpl, "syntax error in parameter statement");

  3425       }

  3426       /* close the domain scope */

  3427       if (par->domain != NULL) close_scope(mpl, par->domain);

  3428       /* the parameter statement has been completely parsed */

  3429       xassert(mpl->token == T_SEMICOLON);

  3430       get_token(mpl /* ; */);

  3431       return par;

  3432 }

  3434 /*----------------------------------------------------------------------

  3435 -- variable_statement - parse variable statement.

  3436 --

  3437 -- This routine parses variable statement using the syntax:

  3438 --

  3439 -- <variable statement> ::= var <symbolic name> <alias> <domain>

  3440 --                          <attributes> ;

  3441 -- <alias> ::= <empty>

  3442 -- <alias> ::= <string literal>

  3443 -- <domain> ::= <empty>

  3444 -- <domain> ::= <indexing expression>

  3445 -- <attributes> ::= <empty>

  3446 -- <attributes> ::= <attributes> , integer

  3447 -- <attributes> ::= <attributes> , binary

  3448 -- <attributes> ::= <attributes> , <rho> <expression 5>

  3449 -- <rho> ::= >= | <= | = | ==

  3450 --

  3451 -- Commae in <attributes> are optional and may be omitted anywhere. */

  3453 VARIABLE *variable_statement(MPL *mpl)

  3454 {     VARIABLE *var;

  3455       int integer_used = 0, binary_used = 0;

  3456       xassert(is_keyword(mpl, "var"));

  3457       if (mpl->flag_s)

  3458          error(mpl, "variable statement must precede solve statement");

  3459       get_token(mpl /* var */);

  3460       /* symbolic name must follow the keyword 'var' */

  3461       if (mpl->token == T_NAME)

  3462          ;

  3463       else if (is_reserved(mpl))

  3464          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  3465       else

  3466          error(mpl, "symbolic name missing where expected");

  3467       /* there must be no other object with the same name */

  3468       if (avl_find_node(mpl->tree, mpl->image) != NULL)

  3469          error(mpl, "%s multiply declared", mpl->image);

  3470       /* create model variable */

  3471       var = alloc(VARIABLE);

  3472       var->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3473       strcpy(var->name, mpl->image);

  3474       var->alias = NULL;

  3475       var->dim = 0;

  3476       var->domain = NULL;

  3477       var->type = A_NUMERIC;

  3478       var->lbnd = NULL;

  3479       var->ubnd = NULL;

  3480       var->array = NULL;

  3481       get_token(mpl /* <symbolic name> */);

  3482       /* parse optional alias */

  3483       if (mpl->token == T_STRING)

  3484       {  var->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3485          strcpy(var->alias, mpl->image);

  3486          get_token(mpl /* <string literal> */);

  3487       }

  3488       /* parse optional indexing expression */

  3489       if (mpl->token == T_LBRACE)

  3490       {  var->domain = indexing_expression(mpl);

  3491          var->dim = domain_arity(mpl, var->domain);

  3492       }

  3493       /* include the variable name in the symbolic names table */

  3494       {  AVLNODE *node;

  3495          node = avl_insert_node(mpl->tree, var->name);

  3496          avl_set_node_type(node, A_VARIABLE);

  3497          avl_set_node_link(node, (void *)var);

  3498       }

  3499       /* parse the list of optional attributes */

  3500       for (;;)

  3501       {  if (mpl->token == T_COMMA)

  3502             get_token(mpl /* , */);

  3503          else if (mpl->token == T_SEMICOLON)

  3504             break;

  3505          if (is_keyword(mpl, "integer"))

  3506          {  if (integer_used)

  3507                error(mpl, "at most one integer allowed");

  3508             if (var->type != A_BINARY) var->type = A_INTEGER;

  3509             integer_used = 1;

  3510             get_token(mpl /* integer */);

  3511          }

  3512          else if (is_keyword(mpl, "binary"))

  3513 bin:     {  if (binary_used)

  3514                error(mpl, "at most one binary allowed");

  3515             var->type = A_BINARY;

  3516             binary_used = 1;

  3517             get_token(mpl /* binary */);

  3518          }

  3519          else if (is_keyword(mpl, "logical"))

  3520          {  if (!mpl->as_binary)

  3521             {  warning(mpl, "keyword logical understood as binary");

  3522                mpl->as_binary = 1;

  3523             }

  3524             goto bin;

  3525          }

  3526          else if (is_keyword(mpl, "symbolic"))

  3527             error(mpl, "variable cannot be symbolic");

  3528          else if (mpl->token == T_GE)

  3529          {  /* lower bound */

  3530             if (var->lbnd != NULL)

  3531             {  if (var->lbnd == var->ubnd)

  3532                   error(mpl, "both fixed value and lower bound not allo"

  3533                      "wed");

  3534                else

  3535                   error(mpl, "at most one lower bound allowed");

  3536             }

  3537             get_token(mpl /* >= */);

  3538             /* parse an expression that specifies the lower bound */

  3539             var->lbnd = expression_5(mpl);

  3540             if (var->lbnd->type == A_SYMBOLIC)

  3541                var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd,

  3542                   A_NUMERIC, 0);

  3543             if (var->lbnd->type != A_NUMERIC)

  3544                error(mpl, "expression following >= has invalid type");

  3545             xassert(var->lbnd->dim == 0);

  3546          }

  3547          else if (mpl->token == T_LE)

  3548          {  /* upper bound */

  3549             if (var->ubnd != NULL)

  3550             {  if (var->ubnd == var->lbnd)

  3551                   error(mpl, "both fixed value and upper bound not allo"

  3552                      "wed");

  3553                else

  3554                   error(mpl, "at most one upper bound allowed");

  3555             }

  3556             get_token(mpl /* <= */);

  3557             /* parse an expression that specifies the upper bound */

  3558             var->ubnd = expression_5(mpl);

  3559             if (var->ubnd->type == A_SYMBOLIC)

  3560                var->ubnd = make_unary(mpl, O_CVTNUM, var->ubnd,

  3561                   A_NUMERIC, 0);

  3562             if (var->ubnd->type != A_NUMERIC)

  3563                error(mpl, "expression following <= has invalid type");

  3564             xassert(var->ubnd->dim == 0);

  3565          }

  3566          else if (mpl->token == T_EQ)

  3567          {  /* fixed value */

  3568             char opstr[8];

  3569             if (!(var->lbnd == NULL && var->ubnd == NULL))

  3570             {  if (var->lbnd == var->ubnd)

  3571                   error(mpl, "at most one fixed value allowed");

  3572                else if (var->lbnd != NULL)

  3573                   error(mpl, "both lower bound and fixed value not allo"

  3574                      "wed");

  3575                else

  3576                   error(mpl, "both upper bound and fixed value not allo"

  3577                      "wed");

  3578             }

  3579             strcpy(opstr, mpl->image);

  3580             xassert(strlen(opstr) < sizeof(opstr));

  3581             get_token(mpl /* = | == */);

  3582             /* parse an expression that specifies the fixed value */

  3583             var->lbnd = expression_5(mpl);

  3584             if (var->lbnd->type == A_SYMBOLIC)

  3585                var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd,

  3586                   A_NUMERIC, 0);

  3587             if (var->lbnd->type != A_NUMERIC)

  3588                error(mpl, "expression following %s has invalid type",

  3589                   opstr);

  3590             xassert(var->lbnd->dim == 0);

  3591             /* indicate that the variable is fixed, not bounded */

  3592             var->ubnd = var->lbnd;

  3593          }

  3594          else if (mpl->token == T_LT || mpl->token == T_GT ||

  3595                   mpl->token == T_NE)

  3596             error(mpl, "strict bound not allowed");

  3597          else

  3598             error(mpl, "syntax error in variable statement");

  3599       }

  3600       /* close the domain scope */

  3601       if (var->domain != NULL) close_scope(mpl, var->domain);

  3602       /* the variable statement has been completely parsed */

  3603       xassert(mpl->token == T_SEMICOLON);

  3604       get_token(mpl /* ; */);

  3605       return var;

  3606 }

  3608 /*----------------------------------------------------------------------

  3609 -- constraint_statement - parse constraint statement.

  3610 --

  3611 -- This routine parses constraint statement using the syntax:

  3612 --

  3613 -- <constraint statement> ::= <subject to> <symbolic name> <alias>

  3614 --                            <domain> : <constraint> ;

  3615 -- <subject to> ::= <empty>

  3616 -- <subject to> ::= subject to

  3617 -- <subject to> ::= subj to

  3618 -- <subject to> ::= s.t.

  3619 -- <alias> ::= <empty>

  3620 -- <alias> ::= <string literal>

  3621 -- <domain> ::= <empty>

  3622 -- <domain> ::= <indexing expression>

  3623 -- <constraint> ::= <formula> , >= <formula>

  3624 -- <constraint> ::= <formula> , <= <formula>

  3625 -- <constraint> ::= <formula> , = <formula>

  3626 -- <constraint> ::= <formula> , <= <formula> , <= <formula>

  3627 -- <constraint> ::= <formula> , >= <formula> , >= <formula>

  3628 -- <formula> ::= <expression 5>

  3629 --

  3630 -- Commae in <constraint> are optional and may be omitted anywhere. */

  3632 CONSTRAINT *constraint_statement(MPL *mpl)

  3633 {     CONSTRAINT *con;

  3634       CODE *first, *second, *third;

  3635       int rho;

  3636       char opstr[8];

  3637       if (mpl->flag_s)

  3638          error(mpl, "constraint statement must precede solve statement")

  3639             ;

  3640       if (is_keyword(mpl, "subject"))

  3641       {  get_token(mpl /* subject */);

  3642          if (!is_keyword(mpl, "to"))

  3643             error(mpl, "keyword subject to incomplete");

  3644          get_token(mpl /* to */);

  3645       }

  3646       else if (is_keyword(mpl, "subj"))

  3647       {  get_token(mpl /* subj */);

  3648          if (!is_keyword(mpl, "to"))

  3649             error(mpl, "keyword subj to incomplete");

  3650          get_token(mpl /* to */);

  3651       }

  3652       else if (mpl->token == T_SPTP)

  3653          get_token(mpl /* s.t. */);

  3654       /* the current token must be symbolic name of constraint */

  3655       if (mpl->token == T_NAME)

  3656          ;

  3657       else if (is_reserved(mpl))

  3658          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  3659       else

  3660          error(mpl, "symbolic name missing where expected");

  3661       /* there must be no other object with the same name */

  3662       if (avl_find_node(mpl->tree, mpl->image) != NULL)

  3663          error(mpl, "%s multiply declared", mpl->image);

  3664       /* create model constraint */

  3665       con = alloc(CONSTRAINT);

  3666       con->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3667       strcpy(con->name, mpl->image);

  3668       con->alias = NULL;

  3669       con->dim = 0;

  3670       con->domain = NULL;

  3671       con->type = A_CONSTRAINT;

  3672       con->code = NULL;

  3673       con->lbnd = NULL;

  3674       con->ubnd = NULL;

  3675       con->array = NULL;

  3676       get_token(mpl /* <symbolic name> */);

  3677       /* parse optional alias */

  3678       if (mpl->token == T_STRING)

  3679       {  con->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3680          strcpy(con->alias, mpl->image);

  3681          get_token(mpl /* <string literal> */);

  3682       }

  3683       /* parse optional indexing expression */

  3684       if (mpl->token == T_LBRACE)

  3685       {  con->domain = indexing_expression(mpl);

  3686          con->dim = domain_arity(mpl, con->domain);

  3687       }

  3688       /* include the constraint name in the symbolic names table */

  3689       {  AVLNODE *node;

  3690          node = avl_insert_node(mpl->tree, con->name);

  3691          avl_set_node_type(node, A_CONSTRAINT);

  3692          avl_set_node_link(node, (void *)con);

  3693       }

  3694       /* the colon must precede the first expression */

  3695       if (mpl->token != T_COLON)

  3696          error(mpl, "colon missing where expected");

  3697       get_token(mpl /* : */);

  3698       /* parse the first expression */

  3699       first = expression_5(mpl);

  3700       if (first->type == A_SYMBOLIC)

  3701          first = make_unary(mpl, O_CVTNUM, first, A_NUMERIC, 0);

  3702       if (!(first->type == A_NUMERIC || first->type == A_FORMULA))

  3703          error(mpl, "expression following colon has invalid type");

  3704       xassert(first->dim == 0);

  3705       /* relational operator must follow the first expression */

  3706       if (mpl->token == T_COMMA) get_token(mpl /* , */);

  3707       switch (mpl->token)

  3708       {  case T_LE:

  3709          case T_GE:

  3710          case T_EQ:

  3711             break;

  3712          case T_LT:

  3713          case T_GT:

  3714          case T_NE:

  3715             error(mpl, "strict inequality not allowed");

  3716          case T_SEMICOLON:

  3717             error(mpl, "constraint must be equality or inequality");

  3718          default:

  3719             goto err;

  3720       }

  3721       rho = mpl->token;

  3722       strcpy(opstr, mpl->image);

  3723       xassert(strlen(opstr) < sizeof(opstr));

  3724       get_token(mpl /* rho */);

  3725       /* parse the second expression */

  3726       second = expression_5(mpl);

  3727       if (second->type == A_SYMBOLIC)

  3728          second = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0);

  3729       if (!(second->type == A_NUMERIC || second->type == A_FORMULA))

  3730          error(mpl, "expression following %s has invalid type", opstr);

  3731       xassert(second->dim == 0);

  3732       /* check a token that follow the second expression */

  3733       if (mpl->token == T_COMMA)

  3734       {  get_token(mpl /* , */);

  3735          if (mpl->token == T_SEMICOLON) goto err;

  3736       }

  3737       if (mpl->token == T_LT || mpl->token == T_LE ||

  3738           mpl->token == T_EQ || mpl->token == T_GE ||

  3739           mpl->token == T_GT || mpl->token == T_NE)

  3740       {  /* it is another relational operator, therefore the constraint

  3741             is double inequality */

  3742          if (rho == T_EQ || mpl->token != rho)

  3743             error(mpl, "double inequality must be ... <= ... <= ... or "

  3744                "... >= ... >= ...");

  3745          /* the first expression cannot be linear form */

  3746          if (first->type == A_FORMULA)

  3747             error(mpl, "leftmost expression in double inequality cannot"

  3748                " be linear form");

  3749          get_token(mpl /* rho */);

  3750          /* parse the third expression */

  3751          third = expression_5(mpl);

  3752          if (third->type == A_SYMBOLIC)

  3753             third = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0);

  3754          if (!(third->type == A_NUMERIC || third->type == A_FORMULA))

  3755             error(mpl, "rightmost expression in double inequality const"

  3756                "raint has invalid type");

  3757          xassert(third->dim == 0);

  3758          /* the third expression also cannot be linear form */

  3759          if (third->type == A_FORMULA)

  3760             error(mpl, "rightmost expression in double inequality canno"

  3761                "t be linear form");

  3762       }

  3763       else

  3764       {  /* the constraint is equality or single inequality */

  3765          third = NULL;

  3766       }

  3767       /* close the domain scope */

  3768       if (con->domain != NULL) close_scope(mpl, con->domain);

  3769       /* convert all expressions to linear form, if necessary */

  3770       if (first->type != A_FORMULA)

  3771          first = make_unary(mpl, O_CVTLFM, first, A_FORMULA, 0);

  3772       if (second->type != A_FORMULA)

  3773          second = make_unary(mpl, O_CVTLFM, second, A_FORMULA, 0);

  3774       if (third != NULL)

  3775          third = make_unary(mpl, O_CVTLFM, third, A_FORMULA, 0);

  3776       /* arrange expressions in the constraint */

  3777       if (third == NULL)

  3778       {  /* the constraint is equality or single inequality */

  3779          switch (rho)

  3780          {  case T_LE:

  3781                /* first <= second */

  3782                con->code = first;

  3783                con->lbnd = NULL;

  3784                con->ubnd = second;

  3785                break;

  3786             case T_GE:

  3787                /* first >= second */

  3788                con->code = first;

  3789                con->lbnd = second;

  3790                con->ubnd = NULL;

  3791                break;

  3792             case T_EQ:

  3793                /* first = second */

  3794                con->code = first;

  3795                con->lbnd = second;

  3796                con->ubnd = second;

  3797                break;

  3798             default:

  3799                xassert(rho != rho);

  3800          }

  3801       }

  3802       else

  3803       {  /* the constraint is double inequality */

  3804          switch (rho)

  3805          {  case T_LE:

  3806                /* first <= second <= third */

  3807                con->code = second;

  3808                con->lbnd = first;

  3809                con->ubnd = third;

  3810                break;

  3811             case T_GE:

  3812                /* first >= second >= third */

  3813                con->code = second;

  3814                con->lbnd = third;

  3815                con->ubnd = first;

  3816                break;

  3817             default:

  3818                xassert(rho != rho);

  3819          }

  3820       }

  3821       /* the constraint statement has been completely parsed */

  3822       if (mpl->token != T_SEMICOLON)

  3823 err:     error(mpl, "syntax error in constraint statement");

  3824       get_token(mpl /* ; */);

  3825       return con;

  3826 }

  3828 /*----------------------------------------------------------------------

  3829 -- objective_statement - parse objective statement.

  3830 --

  3831 -- This routine parses objective statement using the syntax:

  3832 --

  3833 -- <objective statement> ::= <verb> <symbolic name> <alias> <domain> :

  3834 --                           <formula> ;

  3835 -- <verb> ::= minimize

  3836 -- <verb> ::= maximize

  3837 -- <alias> ::= <empty>

  3838 -- <alias> ::= <string literal>

  3839 -- <domain> ::= <empty>

  3840 -- <domain> ::= <indexing expression>

  3841 -- <formula> ::= <expression 5> */

  3843 CONSTRAINT *objective_statement(MPL *mpl)

  3844 {     CONSTRAINT *obj;

  3845       int type;

  3846       if (is_keyword(mpl, "minimize"))

  3847          type = A_MINIMIZE;

  3848       else if (is_keyword(mpl, "maximize"))

  3849          type = A_MAXIMIZE;

  3850       else

  3851          xassert(mpl != mpl);

  3852       if (mpl->flag_s)

  3853          error(mpl, "objective statement must precede solve statement");

  3854       get_token(mpl /* minimize | maximize */);

  3855       /* symbolic name must follow the verb 'minimize' or 'maximize' */

  3856       if (mpl->token == T_NAME)

  3857          ;

  3858       else if (is_reserved(mpl))

  3859          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  3860       else

  3861          error(mpl, "symbolic name missing where expected");

  3862       /* there must be no other object with the same name */

  3863       if (avl_find_node(mpl->tree, mpl->image) != NULL)

  3864          error(mpl, "%s multiply declared", mpl->image);

  3865       /* create model objective */

  3866       obj = alloc(CONSTRAINT);

  3867       obj->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3868       strcpy(obj->name, mpl->image);

  3869       obj->alias = NULL;

  3870       obj->dim = 0;

  3871       obj->domain = NULL;

  3872       obj->type = type;

  3873       obj->code = NULL;

  3874       obj->lbnd = NULL;

  3875       obj->ubnd = NULL;

  3876       obj->array = NULL;

  3877       get_token(mpl /* <symbolic name> */);

  3878       /* parse optional alias */

  3879       if (mpl->token == T_STRING)

  3880       {  obj->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3881          strcpy(obj->alias, mpl->image);

  3882          get_token(mpl /* <string literal> */);

  3883       }

  3884       /* parse optional indexing expression */

  3885       if (mpl->token == T_LBRACE)

  3886       {  obj->domain = indexing_expression(mpl);

  3887          obj->dim = domain_arity(mpl, obj->domain);

  3888       }

  3889       /* include the constraint name in the symbolic names table */

  3890       {  AVLNODE *node;

  3891          node = avl_insert_node(mpl->tree, obj->name);

  3892          avl_set_node_type(node, A_CONSTRAINT);

  3893          avl_set_node_link(node, (void *)obj);

  3894       }

  3895       /* the colon must precede the objective expression */

  3896       if (mpl->token != T_COLON)

  3897          error(mpl, "colon missing where expected");

  3898       get_token(mpl /* : */);

  3899       /* parse the objective expression */

  3900       obj->code = expression_5(mpl);

  3901       if (obj->code->type == A_SYMBOLIC)

  3902          obj->code = make_unary(mpl, O_CVTNUM, obj->code, A_NUMERIC, 0);

  3903       if (obj->code->type == A_NUMERIC)

  3904          obj->code = make_unary(mpl, O_CVTLFM, obj->code, A_FORMULA, 0);

  3905       if (obj->code->type != A_FORMULA)

  3906          error(mpl, "expression following colon has invalid type");

  3907       xassert(obj->code->dim == 0);

  3908       /* close the domain scope */

  3909       if (obj->domain != NULL) close_scope(mpl, obj->domain);

  3910       /* the objective statement has been completely parsed */

  3911       if (mpl->token != T_SEMICOLON)

  3912          error(mpl, "syntax error in objective statement");

  3913       get_token(mpl /* ; */);

  3914       return obj;

  3915 }

  3917 #if 1 /* 11/II-2008 */

  3918 /***********************************************************************

  3919 *  table_statement - parse table statement

  3920 *

  3921 *  This routine parses table statement using the syntax:

  3922 *

  3923 *  <table statement> ::= <input table statement>

  3924 *  <table statement> ::= <output table statement>

  3925 *

  3926 *  <input table statement> ::=

  3927 *        table <table name> <alias> IN <argument list> :

  3928 *        <input set> [ <field list> ] , <input list> ;

  3929 *  <alias> ::= <empty>

  3930 *  <alias> ::= <string literal>

  3931 *  <argument list> ::= <expression 5>

  3932 *  <argument list> ::= <argument list> <expression 5>

  3933 *  <argument list> ::= <argument list> , <expression 5>

  3934 *  <input set> ::= <empty>

  3935 *  <input set> ::= <set name> <-

  3936 *  <field list> ::= <field name>

  3937 *  <field list> ::= <field list> , <field name>

  3938 *  <input list> ::= <input item>

  3939 *  <input list> ::= <input list> , <input item>

  3940 *  <input item> ::= <parameter name>

  3941 *  <input item> ::= <parameter name> ~ <field name>

  3942 *

  3943 *  <output table statement> ::=

  3944 *        table <table name> <alias> <domain> OUT <argument list> :

  3945 *        <output list> ;

  3946 *  <domain> ::= <indexing expression>

  3947 *  <output list> ::= <output item>

  3948 *  <output list> ::= <output list> , <output item>

  3949 *  <output item> ::= <expression 5>

  3950 *  <output item> ::= <expression 5> ~ <field name> */

  3952 TABLE *table_statement(MPL *mpl)

  3953 {     TABLE *tab;

  3954       TABARG *last_arg, *arg;

  3955       TABFLD *last_fld, *fld;

  3956       TABIN *last_in, *in;

  3957       TABOUT *last_out, *out;

  3958       AVLNODE *node;

  3959       int nflds;

  3960       char name[MAX_LENGTH+1];

  3961       xassert(is_keyword(mpl, "table"));

  3962       get_token(mpl /* solve */);

  3963       /* symbolic name must follow the keyword table */

  3964       if (mpl->token == T_NAME)

  3965          ;

  3966       else if (is_reserved(mpl))

  3967          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  3968       else

  3969          error(mpl, "symbolic name missing where expected");

  3970       /* there must be no other object with the same name */

  3971       if (avl_find_node(mpl->tree, mpl->image) != NULL)

  3972          error(mpl, "%s multiply declared", mpl->image);

  3973       /* create data table */

  3974       tab = alloc(TABLE);

  3975       tab->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3976       strcpy(tab->name, mpl->image);

  3977       get_token(mpl /* <symbolic name> */);

  3978       /* parse optional alias */

  3979       if (mpl->token == T_STRING)

  3980       {  tab->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  3981          strcpy(tab->alias, mpl->image);

  3982          get_token(mpl /* <string literal> */);

  3983       }

  3984       else

  3985          tab->alias = NULL;

  3986       /* parse optional indexing expression */

  3987       if (mpl->token == T_LBRACE)

  3988       {  /* this is output table */

  3989          tab->type = A_OUTPUT;

  3990          tab->u.out.domain = indexing_expression(mpl);

  3991          if (!is_keyword(mpl, "OUT"))

  3992             error(mpl, "keyword OUT missing where expected");

  3993          get_token(mpl /* OUT */);

  3994       }

  3995       else

  3996       {  /* this is input table */

  3997          tab->type = A_INPUT;

  3998          if (!is_keyword(mpl, "IN"))

  3999             error(mpl, "keyword IN missing where expected");

  4000          get_token(mpl /* IN */);

  4001       }

  4002       /* parse argument list */

  4003       tab->arg = last_arg = NULL;

  4004       for (;;)

  4005       {  /* create argument list entry */

  4006          arg = alloc(TABARG);

  4007          /* parse argument expression */

  4008          if (mpl->token == T_COMMA || mpl->token == T_COLON ||

  4009              mpl->token == T_SEMICOLON)

  4010             error(mpl, "argument expression missing where expected");

  4011          arg->code = expression_5(mpl);

  4012          /* convert the result to symbolic type, if necessary */

  4013          if (arg->code->type == A_NUMERIC)

  4014             arg->code =

  4015                make_unary(mpl, O_CVTSYM, arg->code, A_SYMBOLIC, 0);

  4016          /* check that now the result is of symbolic type */

  4017          if (arg->code->type != A_SYMBOLIC)

  4018             error(mpl, "argument expression has invalid type");

  4019          /* add the entry to the end of the list */

  4020          arg->next = NULL;

  4021          if (last_arg == NULL)

  4022             tab->arg = arg;

  4023          else

  4024             last_arg->next = arg;

  4025          last_arg = arg;

  4026          /* argument expression has been parsed */

  4027          if (mpl->token == T_COMMA)

  4028             get_token(mpl /* , */);

  4029          else if (mpl->token == T_COLON || mpl->token == T_SEMICOLON)

  4030             break;

  4031       }

  4032       xassert(tab->arg != NULL);

  4033       /* argument list must end with colon */

  4034       if (mpl->token == T_COLON)

  4035          get_token(mpl /* : */);

  4036       else

  4037          error(mpl, "colon missing where expected");

  4038       /* parse specific part of the table statement */

  4039       switch (tab->type)

  4040       {  case A_INPUT:  goto input_table;

  4041          case A_OUTPUT: goto output_table;

  4042          default:       xassert(tab != tab);

  4043       }

  4044 input_table:

  4045       /* parse optional set name */

  4046       if (mpl->token == T_NAME)

  4047       {  node = avl_find_node(mpl->tree, mpl->image);

  4048          if (node == NULL)

  4049             error(mpl, "%s not defined", mpl->image);

  4050          if (avl_get_node_type(node) != A_SET)

  4051             error(mpl, "%s not a set", mpl->image);

  4052          tab->u.in.set = (SET *)avl_get_node_link(node);

  4053          if (tab->u.in.set->assign != NULL)

  4054             error(mpl, "%s needs no data", mpl->image);

  4055          if (tab->u.in.set->dim != 0)

  4056             error(mpl, "%s must be a simple set", mpl->image);

  4057          get_token(mpl /* <symbolic name> */);

  4058          if (mpl->token == T_INPUT)

  4059             get_token(mpl /* <- */);

  4060          else

  4061             error(mpl, "delimiter <- missing where expected");

  4062       }

  4063       else if (is_reserved(mpl))

  4064          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  4065       else

  4066          tab->u.in.set = NULL;

  4067       /* parse field list */

  4068       tab->u.in.fld = last_fld = NULL;

  4069       nflds = 0;

  4070       if (mpl->token == T_LBRACKET)

  4071          get_token(mpl /* [ */);

  4072       else

  4073          error(mpl, "field list missing where expected");

  4074       for (;;)

  4075       {  /* create field list entry */

  4076          fld = alloc(TABFLD);

  4077          /* parse field name */

  4078          if (mpl->token == T_NAME)

  4079             ;

  4080          else if (is_reserved(mpl))

  4081             error(mpl,

  4082                "invalid use of reserved keyword %s", mpl->image);

  4083          else

  4084             error(mpl, "field name missing where expected");

  4085          fld->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);

  4086          strcpy(fld->name, mpl->image);

  4087          get_token(mpl /* <symbolic name> */);

  4088          /* add the entry to the end of the list */

  4089          fld->next = NULL;

  4090          if (last_fld == NULL)

  4091             tab->u.in.fld = fld;

  4092          else

  4093             last_fld->next = fld;

  4094          last_fld = fld;

  4095          nflds++;

  4096          /* field name has been parsed */

  4097          if (mpl->token == T_COMMA)

  4098             get_token(mpl /* , */);

  4099          else if (mpl->token == T_RBRACKET)

  4100             break;

  4101          else

  4102             error(mpl, "syntax error in field list");

  4103       }

  4104       /* check that the set dimen is equal to the number of fields */

  4105       if (tab->u.in.set != NULL && tab->u.in.set->dimen != nflds)

  4106          error(mpl, "there must be %d field%s rather than %d",

  4107             tab->u.in.set->dimen, tab->u.in.set->dimen == 1 ? "" : "s",

  4108             nflds);

  4109       get_token(mpl /* ] */);

  4110       /* parse optional input list */

  4111       tab->u.in.list = last_in = NULL;

  4112       while (mpl->token == T_COMMA)

  4113       {  get_token(mpl /* , */);

  4114          /* create input list entry */

  4115          in = alloc(TABIN);

  4116          /* parse parameter name */

  4117          if (mpl->token == T_NAME)

  4118             ;

  4119          else if (is_reserved(mpl))

  4120             error(mpl,

  4121                "invalid use of reserved keyword %s", mpl->image);

  4122          else

  4123             error(mpl, "parameter name missing where expected");

  4124          node = avl_find_node(mpl->tree, mpl->image);

  4125          if (node == NULL)

  4126             error(mpl, "%s not defined", mpl->image);

  4127          if (avl_get_node_type(node) != A_PARAMETER)

  4128             error(mpl, "%s not a parameter", mpl->image);

  4129          in->par = (PARAMETER *)avl_get_node_link(node);

  4130          if (in->par->dim != nflds)

  4131             error(mpl, "%s must have %d subscript%s rather than %d",

  4132                mpl->image, nflds, nflds == 1 ? "" : "s", in->par->dim);

  4133          if (in->par->assign != NULL)

  4134             error(mpl, "%s needs no data", mpl->image);

  4135          get_token(mpl /* <symbolic name> */);

  4136          /* parse optional field name */

  4137          if (mpl->token == T_TILDE)

  4138          {  get_token(mpl /* ~ */);

  4139             /* parse field name */

  4140             if (mpl->token == T_NAME)

  4141                ;

  4142             else if (is_reserved(mpl))

  4143                error(mpl,

  4144                   "invalid use of reserved keyword %s", mpl->image);

  4145             else

  4146                error(mpl, "field name missing where expected");

  4147             xassert(strlen(mpl->image) < sizeof(name));

  4148             strcpy(name, mpl->image);

  4149             get_token(mpl /* <symbolic name> */);

  4150          }

  4151          else

  4152          {  /* field name is the same as the parameter name */

  4153             xassert(strlen(in->par->name) < sizeof(name));

  4154             strcpy(name, in->par->name);

  4155          }

  4156          /* assign field name */

  4157          in->name = dmp_get_atomv(mpl->pool, strlen(name)+1);

  4158          strcpy(in->name, name);

  4159          /* add the entry to the end of the list */

  4160          in->next = NULL;

  4161          if (last_in == NULL)

  4162             tab->u.in.list = in;

  4163          else

  4164             last_in->next = in;

  4165          last_in = in;

  4166       }

  4167       goto end_of_table;

  4168 output_table:

  4169       /* parse output list */

  4170       tab->u.out.list = last_out = NULL;

  4171       for (;;)

  4172       {  /* create output list entry */

  4173          out = alloc(TABOUT);

  4174          /* parse expression */

  4175          if (mpl->token == T_COMMA || mpl->token == T_SEMICOLON)

  4176             error(mpl, "expression missing where expected");

  4177          if (mpl->token == T_NAME)

  4178          {  xassert(strlen(mpl->image) < sizeof(name));

  4179             strcpy(name, mpl->image);

  4180          }

  4181          else

  4182             name[0] = '\0';

  4183          out->code = expression_5(mpl);

  4184          /* parse optional field name */

  4185          if (mpl->token == T_TILDE)

  4186          {  get_token(mpl /* ~ */);

  4187             /* parse field name */

  4188             if (mpl->token == T_NAME)

  4189                ;

  4190             else if (is_reserved(mpl))

  4191                error(mpl,

  4192                   "invalid use of reserved keyword %s", mpl->image);

  4193             else

  4194                error(mpl, "field name missing where expected");

  4195             xassert(strlen(mpl->image) < sizeof(name));

  4196             strcpy(name, mpl->image);

  4197             get_token(mpl /* <symbolic name> */);

  4198          }

  4199          /* assign field name */

  4200          if (name[0] == '\0')

  4201             error(mpl, "field name required");

  4202          out->name = dmp_get_atomv(mpl->pool, strlen(name)+1);

  4203          strcpy(out->name, name);

  4204          /* add the entry to the end of the list */

  4205          out->next = NULL;

  4206          if (last_out == NULL)

  4207             tab->u.out.list = out;

  4208          else

  4209             last_out->next = out;

  4210          last_out = out;

  4211          /* output item has been parsed */

  4212          if (mpl->token == T_COMMA)

  4213             get_token(mpl /* , */);

  4214          else if (mpl->token == T_SEMICOLON)

  4215             break;

  4216          else

  4217             error(mpl, "syntax error in output list");

  4218       }

  4219       /* close the domain scope */

  4220       close_scope(mpl,tab->u.out.domain);

  4221 end_of_table:

  4222       /* the table statement must end with semicolon */

  4223       if (mpl->token != T_SEMICOLON)

  4224          error(mpl, "syntax error in table statement");

  4225       get_token(mpl /* ; */);

  4226       return tab;

  4227 }

  4228 #endif

  4230 /*----------------------------------------------------------------------

  4231 -- solve_statement - parse solve statement.

  4232 --

  4233 -- This routine parses solve statement using the syntax:

  4234 --

  4235 -- <solve statement> ::= solve ;

  4236 --

  4237 -- The solve statement can be used at most once. */

  4239 void *solve_statement(MPL *mpl)

  4240 {     xassert(is_keyword(mpl, "solve"));

  4241       if (mpl->flag_s)

  4242          error(mpl, "at most one solve statement allowed");

  4243       mpl->flag_s = 1;

  4244       get_token(mpl /* solve */);

  4245       /* semicolon must follow solve statement */

  4246       if (mpl->token != T_SEMICOLON)

  4247          error(mpl, "syntax error in solve statement");

  4248       get_token(mpl /* ; */);

  4249       return NULL;

  4250 }

  4252 /*----------------------------------------------------------------------

  4253 -- check_statement - parse check statement.

  4254 --

  4255 -- This routine parses check statement using the syntax:

  4256 --

  4257 -- <check statement> ::= check <domain> : <expression 13> ;

  4258 -- <domain> ::= <empty>

  4259 -- <domain> ::= <indexing expression>

  4260 --

  4261 -- If <domain> is omitted, colon following it may also be omitted. */

  4263 CHECK *check_statement(MPL *mpl)

  4264 {     CHECK *chk;

  4265       xassert(is_keyword(mpl, "check"));

  4266       /* create check descriptor */

  4267       chk = alloc(CHECK);

  4268       chk->domain = NULL;

  4269       chk->code = NULL;

  4270       get_token(mpl /* check */);

  4271       /* parse optional indexing expression */

  4272       if (mpl->token == T_LBRACE)

  4273       {  chk->domain = indexing_expression(mpl);

  4274 #if 0

  4275          if (mpl->token != T_COLON)

  4276             error(mpl, "colon missing where expected");

  4277 #endif

  4278       }

  4279       /* skip optional colon */

  4280       if (mpl->token == T_COLON) get_token(mpl /* : */);

  4281       /* parse logical expression */

  4282       chk->code = expression_13(mpl);

  4283       if (chk->code->type != A_LOGICAL)

  4284          error(mpl, "expression has invalid type");

  4285       xassert(chk->code->dim == 0);

  4286       /* close the domain scope */

  4287       if (chk->domain != NULL) close_scope(mpl, chk->domain);

  4288       /* the check statement has been completely parsed */

  4289       if (mpl->token != T_SEMICOLON)

  4290          error(mpl, "syntax error in check statement");

  4291       get_token(mpl /* ; */);

  4292       return chk;

  4293 }

  4295 #if 1 /* 15/V-2010 */

  4296 /*----------------------------------------------------------------------

  4297 -- display_statement - parse display statement.

  4298 --

  4299 -- This routine parses display statement using the syntax:

  4300 --

  4301 -- <display statement> ::= display <domain> : <display list> ;

  4302 -- <display statement> ::= display <domain> <display list> ;

  4303 -- <domain> ::= <empty>

  4304 -- <domain> ::= <indexing expression>

  4305 -- <display list> ::= <display entry>

  4306 -- <display list> ::= <display list> , <display entry>

  4307 -- <display entry> ::= <dummy index>

  4308 -- <display entry> ::= <set name>

  4309 -- <display entry> ::= <set name> [ <subscript list> ]

  4310 -- <display entry> ::= <parameter name>

  4311 -- <display entry> ::= <parameter name> [ <subscript list> ]

  4312 -- <display entry> ::= <variable name>

  4313 -- <display entry> ::= <variable name> [ <subscript list> ]

  4314 -- <display entry> ::= <constraint name>

  4315 -- <display entry> ::= <constraint name> [ <subscript list> ]

  4316 -- <display entry> ::= <expression 13> */

  4318 DISPLAY *display_statement(MPL *mpl)

  4319 {     DISPLAY *dpy;

  4320       DISPLAY1 *entry, *last_entry;

  4321       xassert(is_keyword(mpl, "display"));

  4322       /* create display descriptor */

  4323       dpy = alloc(DISPLAY);

  4324       dpy->domain = NULL;

  4325       dpy->list = last_entry = NULL;

  4326       get_token(mpl /* display */);

  4327       /* parse optional indexing expression */

  4328       if (mpl->token == T_LBRACE)

  4329          dpy->domain = indexing_expression(mpl);

  4330       /* skip optional colon */

  4331       if (mpl->token == T_COLON) get_token(mpl /* : */);

  4332       /* parse display list */

  4333       for (;;)

  4334       {  /* create new display entry */

  4335          entry = alloc(DISPLAY1);

  4336          entry->type = 0;

  4337          entry->next = NULL;

  4338          /* and append it to the display list */

  4339          if (dpy->list == NULL)

  4340             dpy->list = entry;

  4341          else

  4342             last_entry->next = entry;

  4343          last_entry = entry;

  4344          /* parse display entry */

  4345          if (mpl->token == T_NAME)

  4346          {  AVLNODE *node;

  4347             int next_token;

  4348             get_token(mpl /* <symbolic name> */);

  4349             next_token = mpl->token;

  4350             unget_token(mpl);

  4351             if (!(next_token == T_COMMA || next_token == T_SEMICOLON))

  4352             {  /* symbolic name begins expression */

  4353                goto expr;

  4354             }

  4355             /* display entry is dummy index or model object */

  4356             node = avl_find_node(mpl->tree, mpl->image);

  4357             if (node == NULL)

  4358                error(mpl, "%s not defined", mpl->image);

  4359             entry->type = avl_get_node_type(node);

  4360             switch (avl_get_node_type(node))

  4361             {  case A_INDEX:

  4362                   entry->u.slot =

  4363                      (DOMAIN_SLOT *)avl_get_node_link(node);

  4364                   break;

  4365                case A_SET:

  4366                   entry->u.set = (SET *)avl_get_node_link(node);

  4367                   break;

  4368                case A_PARAMETER:

  4369                   entry->u.par = (PARAMETER *)avl_get_node_link(node);

  4370                   break;

  4371                case A_VARIABLE:

  4372                   entry->u.var = (VARIABLE *)avl_get_node_link(node);

  4373                   if (!mpl->flag_s)

  4374                      error(mpl, "invalid reference to variable %s above"

  4375                         " solve statement", entry->u.var->name);

  4376                   break;

  4377                case A_CONSTRAINT:

  4378                   entry->u.con = (CONSTRAINT *)avl_get_node_link(node);

  4379                   if (!mpl->flag_s)

  4380                      error(mpl, "invalid reference to %s %s above solve"

  4381                         " statement",

  4382                         entry->u.con->type == A_CONSTRAINT ?

  4383                         "constraint" : "objective", entry->u.con->name);

  4384                   break;

  4385                default:

  4386                   xassert(node != node);

  4387             }

  4388             get_token(mpl /* <symbolic name> */);

  4389          }

  4390          else

  4391 expr:    {  /* display entry is expression */

  4392             entry->type = A_EXPRESSION;

  4393             entry->u.code = expression_13(mpl);

  4394          }

  4395          /* check a token that follows the entry parsed */

  4396          if (mpl->token == T_COMMA)

  4397             get_token(mpl /* , */);

  4398          else

  4399             break;

  4400       }

  4401       /* close the domain scope */

  4402       if (dpy->domain != NULL) close_scope(mpl, dpy->domain);

  4403       /* the display statement has been completely parsed */

  4404       if (mpl->token != T_SEMICOLON)

  4405          error(mpl, "syntax error in display statement");

  4406       get_token(mpl /* ; */);

  4407       return dpy;

  4408 }

  4409 #endif

  4411 /*----------------------------------------------------------------------

  4412 -- printf_statement - parse printf statement.

  4413 --

  4414 -- This routine parses print statement using the syntax:

  4415 --

  4416 -- <printf statement> ::= <printf clause> ;

  4417 -- <printf statement> ::= <printf clause> > <file name> ;

  4418 -- <printf statement> ::= <printf clause> >> <file name> ;

  4419 -- <printf clause> ::= printf <domain> : <format> <printf list>

  4420 -- <printf clause> ::= printf <domain> <format> <printf list>

  4421 -- <domain> ::= <empty>

  4422 -- <domain> ::= <indexing expression>

  4423 -- <format> ::= <expression 5>

  4424 -- <printf list> ::= <empty>

  4425 -- <printf list> ::= <printf list> , <printf entry>

  4426 -- <printf entry> ::= <expression 9>

  4427 -- <file name> ::= <expression 5> */

  4429 PRINTF *printf_statement(MPL *mpl)

  4430 {     PRINTF *prt;

  4431       PRINTF1 *entry, *last_entry;

  4432       xassert(is_keyword(mpl, "printf"));

  4433       /* create printf descriptor */

  4434       prt = alloc(PRINTF);

  4435       prt->domain = NULL;

  4436       prt->fmt = NULL;

  4437       prt->list = last_entry = NULL;

  4438       get_token(mpl /* printf */);

  4439       /* parse optional indexing expression */

  4440       if (mpl->token == T_LBRACE)

  4441       {  prt->domain = indexing_expression(mpl);

  4442 #if 0

  4443          if (mpl->token != T_COLON)

  4444             error(mpl, "colon missing where expected");

  4445 #endif

  4446       }

  4447       /* skip optional colon */

  4448       if (mpl->token == T_COLON) get_token(mpl /* : */);

  4449       /* parse expression for format string */

  4450       prt->fmt = expression_5(mpl);

  4451       /* convert it to symbolic type, if necessary */

  4452       if (prt->fmt->type == A_NUMERIC)

  4453          prt->fmt = make_unary(mpl, O_CVTSYM, prt->fmt, A_SYMBOLIC, 0);

  4454       /* check that now the expression is of symbolic type */

  4455       if (prt->fmt->type != A_SYMBOLIC)

  4456          error(mpl, "format expression has invalid type");

  4457       /* parse printf list */

  4458       while (mpl->token == T_COMMA)

  4459       {  get_token(mpl /* , */);

  4460          /* create new printf entry */

  4461          entry = alloc(PRINTF1);

  4462          entry->code = NULL;

  4463          entry->next = NULL;

  4464          /* and append it to the printf list */

  4465          if (prt->list == NULL)

  4466             prt->list = entry;

  4467          else

  4468             last_entry->next = entry;

  4469          last_entry = entry;

  4470          /* parse printf entry */

  4471          entry->code = expression_9(mpl);

  4472          if (!(entry->code->type == A_NUMERIC ||

  4473                entry->code->type == A_SYMBOLIC ||

  4474                entry->code->type == A_LOGICAL))

  4475             error(mpl, "only numeric, symbolic, or logical expression a"

  4476                "llowed");

  4477       }

  4478       /* close the domain scope */

  4479       if (prt->domain != NULL) close_scope(mpl, prt->domain);

  4480 #if 1 /* 14/VII-2006 */

  4481       /* parse optional redirection */

  4482       prt->fname = NULL, prt->app = 0;

  4483       if (mpl->token == T_GT || mpl->token == T_APPEND)

  4484       {  prt->app = (mpl->token == T_APPEND);

  4485          get_token(mpl /* > or >> */);

  4486          /* parse expression for file name string */

  4487          prt->fname = expression_5(mpl);

  4488          /* convert it to symbolic type, if necessary */

  4489          if (prt->fname->type == A_NUMERIC)

  4490             prt->fname = make_unary(mpl, O_CVTSYM, prt->fname,

  4491                A_SYMBOLIC, 0);

  4492          /* check that now the expression is of symbolic type */

  4493          if (prt->fname->type != A_SYMBOLIC)

  4494             error(mpl, "file name expression has invalid type");

  4495       }

  4496 #endif

  4497       /* the printf statement has been completely parsed */

  4498       if (mpl->token != T_SEMICOLON)

  4499          error(mpl, "syntax error in printf statement");

  4500       get_token(mpl /* ; */);

  4501       return prt;

  4502 }

  4504 /*----------------------------------------------------------------------

  4505 -- for_statement - parse for statement.

  4506 --

  4507 -- This routine parses for statement using the syntax:

  4508 --

  4509 -- <for statement> ::= for <domain> <statement>

  4510 -- <for statement> ::= for <domain> { <statement list> }

  4511 -- <domain> ::= <indexing expression>

  4512 -- <statement list> ::= <empty>

  4513 -- <statement list> ::= <statement list> <statement>

  4514 -- <statement> ::= <check statement>

  4515 -- <statement> ::= <display statement>

  4516 -- <statement> ::= <printf statement>

  4517 -- <statement> ::= <for statement> */

  4519 FOR *for_statement(MPL *mpl)

  4520 {     FOR *fur;

  4521       STATEMENT *stmt, *last_stmt;

  4522       xassert(is_keyword(mpl, "for"));

  4523       /* create for descriptor */

  4524       fur = alloc(FOR);

  4525       fur->domain = NULL;

  4526       fur->list = last_stmt = NULL;

  4527       get_token(mpl /* for */);

  4528       /* parse indexing expression */

  4529       if (mpl->token != T_LBRACE)

  4530          error(mpl, "indexing expression missing where expected");

  4531       fur->domain = indexing_expression(mpl);

  4532       /* skip optional colon */

  4533       if (mpl->token == T_COLON) get_token(mpl /* : */);

  4534       /* parse for statement body */

  4535       if (mpl->token != T_LBRACE)

  4536       {  /* parse simple statement */

  4537          fur->list = simple_statement(mpl, 1);

  4538       }

  4539       else

  4540       {  /* parse compound statement */

  4541          get_token(mpl /* { */);

  4542          while (mpl->token != T_RBRACE)

  4543          {  /* parse statement */

  4544             stmt = simple_statement(mpl, 1);

  4545             /* and append it to the end of the statement list */

  4546             if (last_stmt == NULL)

  4547                fur->list = stmt;

  4548             else

  4549                last_stmt->next = stmt;

  4550             last_stmt = stmt;

  4551          }

  4552          get_token(mpl /* } */);

  4553       }

  4554       /* close the domain scope */

  4555       xassert(fur->domain != NULL);

  4556       close_scope(mpl, fur->domain);

  4557       /* the for statement has been completely parsed */

  4558       return fur;

  4559 }

  4561 /*----------------------------------------------------------------------

  4562 -- end_statement - parse end statement.

  4563 --

  4564 -- This routine parses end statement using the syntax:

  4565 --

  4566 -- <end statement> ::= end ; <eof> */

  4568 void end_statement(MPL *mpl)

  4569 {     if (!mpl->flag_d && is_keyword(mpl, "end") ||

  4570            mpl->flag_d && is_literal(mpl, "end"))

  4571       {  get_token(mpl /* end */);

  4572          if (mpl->token == T_SEMICOLON)

  4573             get_token(mpl /* ; */);

  4574          else

  4575             warning(mpl, "no semicolon following end statement; missing"

  4576                " semicolon inserted");

  4577       }

  4578       else

  4579          warning(mpl, "unexpected end of file; missing end statement in"

  4580             "serted");

  4581       if (mpl->token != T_EOF)

  4582          warning(mpl, "some text detected beyond end statement; text ig"

  4583             "nored");

  4584       return;

  4585 }

  4587 /*----------------------------------------------------------------------

  4588 -- simple_statement - parse simple statement.

  4589 --

  4590 -- This routine parses simple statement using the syntax:

  4591 --

  4592 -- <statement> ::= <set statement>

  4593 -- <statement> ::= <parameter statement>

  4594 -- <statement> ::= <variable statement>

  4595 -- <statement> ::= <constraint statement>

  4596 -- <statement> ::= <objective statement>

  4597 -- <statement> ::= <solve statement>

  4598 -- <statement> ::= <check statement>

  4599 -- <statement> ::= <display statement>

  4600 -- <statement> ::= <printf statement>

  4601 -- <statement> ::= <for statement>

  4602 --

  4603 -- If the flag spec is set, some statements cannot be used. */

  4605 STATEMENT *simple_statement(MPL *mpl, int spec)

  4606 {     STATEMENT *stmt;

  4607       stmt = alloc(STATEMENT);

  4608       stmt->line = mpl->line;

  4609       stmt->next = NULL;

  4610       if (is_keyword(mpl, "set"))

  4611       {  if (spec)

  4612             error(mpl, "set statement not allowed here");

  4613          stmt->type = A_SET;

  4614          stmt->u.set = set_statement(mpl);

  4615       }

  4616       else if (is_keyword(mpl, "param"))

  4617       {  if (spec)

  4618             error(mpl, "parameter statement not allowed here");

  4619          stmt->type = A_PARAMETER;

  4620          stmt->u.par = parameter_statement(mpl);

  4621       }

  4622       else if (is_keyword(mpl, "var"))

  4623       {  if (spec)

  4624             error(mpl, "variable statement not allowed here");

  4625          stmt->type = A_VARIABLE;

  4626          stmt->u.var = variable_statement(mpl);

  4627       }

  4628       else if (is_keyword(mpl, "subject") ||

  4629                is_keyword(mpl, "subj") ||

  4630                mpl->token == T_SPTP)

  4631       {  if (spec)

  4632             error(mpl, "constraint statement not allowed here");

  4633          stmt->type = A_CONSTRAINT;

  4634          stmt->u.con = constraint_statement(mpl);

  4635       }

  4636       else if (is_keyword(mpl, "minimize") ||

  4637                is_keyword(mpl, "maximize"))

  4638       {  if (spec)

  4639             error(mpl, "objective statement not allowed here");

  4640          stmt->type = A_CONSTRAINT;

  4641          stmt->u.con = objective_statement(mpl);

  4642       }

  4643 #if 1 /* 11/II-2008 */

  4644       else if (is_keyword(mpl, "table"))

  4645       {  if (spec)

  4646             error(mpl, "table statement not allowed here");

  4647          stmt->type = A_TABLE;

  4648          stmt->u.tab = table_statement(mpl);

  4649       }

  4650 #endif

  4651       else if (is_keyword(mpl, "solve"))

  4652       {  if (spec)

  4653             error(mpl, "solve statement not allowed here");

  4654          stmt->type = A_SOLVE;

  4655          stmt->u.slv = solve_statement(mpl);

  4656       }

  4657       else if (is_keyword(mpl, "check"))

  4658       {  stmt->type = A_CHECK;

  4659          stmt->u.chk = check_statement(mpl);

  4660       }

  4661       else if (is_keyword(mpl, "display"))

  4662       {  stmt->type = A_DISPLAY;

  4663          stmt->u.dpy = display_statement(mpl);

  4664       }

  4665       else if (is_keyword(mpl, "printf"))

  4666       {  stmt->type = A_PRINTF;

  4667          stmt->u.prt = printf_statement(mpl);

  4668       }

  4669       else if (is_keyword(mpl, "for"))

  4670       {  stmt->type = A_FOR;

  4671          stmt->u.fur = for_statement(mpl);

  4672       }

  4673       else if (mpl->token == T_NAME)

  4674       {  if (spec)

  4675             error(mpl, "constraint statement not allowed here");

  4676          stmt->type = A_CONSTRAINT;

  4677          stmt->u.con = constraint_statement(mpl);

  4678       }

  4679       else if (is_reserved(mpl))

  4680          error(mpl, "invalid use of reserved keyword %s", mpl->image);

  4681       else

  4682          error(mpl, "syntax error in model section");

  4683       return stmt;

  4684 }

  4686 /*----------------------------------------------------------------------

  4687 -- model_section - parse model section.

  4688 --

  4689 -- This routine parses model section using the syntax:

  4690 --

  4691 -- <model section> ::= <empty>

  4692 -- <model section> ::= <model section> <statement>

  4693 --

  4694 -- Parsing model section is terminated by either the keyword 'data', or

  4695 -- the keyword 'end', or the end of file. */

  4697 void model_section(MPL *mpl)

  4698 {     STATEMENT *stmt, *last_stmt;

  4699       xassert(mpl->model == NULL);

  4700       last_stmt = NULL;

  4701       while (!(mpl->token == T_EOF || is_keyword(mpl, "data") ||

  4702                is_keyword(mpl, "end")))

  4703       {  /* parse statement */

  4704          stmt = simple_statement(mpl, 0);

  4705          /* and append it to the end of the statement list */

  4706          if (last_stmt == NULL)

  4707             mpl->model = stmt;

  4708          else

  4709             last_stmt->next = stmt;

  4710          last_stmt = stmt;

  4711       }

  4712       return;

  4713 }

  4715 /* eof */

author	Alpar Juttner <alpar@cs.elte.hu>
	Sun, 05 Dec 2010 17:35:23 +0100
changeset 2	4c8956a7bdf4
permissions	-rw-r--r--