/* glpmpl01.c */

/***********************************************************************

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

*

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

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

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

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

*

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

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

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

*  (at your option) any later version.

*

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

*  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY

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

*  License for more details.

*

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

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

***********************************************************************/

#define _GLPSTD_STDIO

#include "glpmpl.h"

#define dmp_get_atomv dmp_get_atom

/**********************************************************************/

/* * *                  PROCESSING MODEL SECTION                  * * */

/**********************************************************************/

/*----------------------------------------------------------------------

-- enter_context - enter current token into context queue.

--

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

void enter_context(MPL *mpl)

{     char *image, *s;

      if (mpl->token == T_EOF)

         image = "_|_";

      else if (mpl->token == T_STRING)

         image = "'...'";

      else

         image = mpl->image;

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

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

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

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

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

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

      }

      return;

}

/*----------------------------------------------------------------------

-- print_context - print current content of context queue.

--

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

void print_context(MPL *mpl)

{     int c;

      while (mpl->c_ptr > 0)

      {  mpl->c_ptr--;

         c = mpl->context[0];

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

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

      }

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

         CONTEXT_SIZE, mpl->context);

      return;

}

/*----------------------------------------------------------------------

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

--

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

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

void get_char(MPL *mpl)

{     int c;

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

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

      c = read_char(mpl);

      if (c == EOF)

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

            mpl->line--;

         else

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

      }

      else if (c == '\n')

         ;

      else if (isspace(c))

         c = ' ';

      else if (iscntrl(c))

      {  enter_context(mpl);

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

      }

      mpl->c = c;

done: return;

}

/*----------------------------------------------------------------------

-- append_char - append character to current token.

--

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

-- then scans a next character. */

void append_char(MPL *mpl)

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

      if (mpl->imlen == MAX_LENGTH)

      {  switch (mpl->token)

         {  case T_NAME:

               enter_context(mpl);

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

            case T_SYMBOL:

               enter_context(mpl);

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

            case T_NUMBER:

               enter_context(mpl);

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

            case T_STRING:

               enter_context(mpl);

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

            default:

               xassert(mpl != mpl);

         }

      }

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

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

      get_char(mpl);

      return;

}

/*----------------------------------------------------------------------

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

--

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

-- standard finite automation technique. */

void get_token(MPL *mpl)

{     /* save the current token */

      mpl->b_token = mpl->token;

      mpl->b_imlen = mpl->imlen;

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

      mpl->b_value = mpl->value;

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

      if (mpl->f_scan)

      {  mpl->f_scan = 0;

         mpl->token = mpl->f_token;

         mpl->imlen = mpl->f_imlen;

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

         mpl->value = mpl->f_value;

         goto done;

      }

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

      mpl->token = 0;

      mpl->imlen = 0;

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

      mpl->value = 0.0;

      /* skip any uninteresting characters */

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

      /* recognize and construct the token */

      if (mpl->c == EOF)

      {  /* end-of-file reached */

         mpl->token = T_EOF;

      }

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

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

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

         goto loop;

      }

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

      {  /* symbolic name or reserved keyword */

         mpl->token = T_NAME;

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

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

            mpl->token = T_AND;

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

            mpl->token = T_BY;

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

            mpl->token = T_CROSS;

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

            mpl->token = T_DIFF;

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

            mpl->token = T_DIV;

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

            mpl->token = T_ELSE;

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

            mpl->token = T_IF;

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

            mpl->token = T_IN;

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

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

            mpl->token = T_INFINITY;

#endif

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

            mpl->token = T_INTER;

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

            mpl->token = T_LESS;

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

            mpl->token = T_MOD;

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

            mpl->token = T_NOT;

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

            mpl->token = T_OR;

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

         {  mpl->token = T_SPTP;

            append_char(mpl);

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

sptp:       {  enter_context(mpl);

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

            }

            append_char(mpl);

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

            append_char(mpl);

         }

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

            mpl->token = T_SYMDIFF;

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

            mpl->token = T_THEN;

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

            mpl->token = T_UNION;

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

            mpl->token = T_WITHIN;

      }

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

      {  /* numeric literal */

         mpl->token = T_NUMBER;

         /* scan integer part */

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

         /* scan optional fractional part */

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

         {  append_char(mpl);

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

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

                  follow the integer part */

               mpl->imlen--;

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

               mpl->f_dots = 1;

               goto conv;

            }

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

         }

         /* scan optional decimal exponent */

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

         {  append_char(mpl);

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

            if (!isdigit(mpl->c))

            {  enter_context(mpl);

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

            }

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

         }

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

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

         {  enter_context(mpl);

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

               mpl->image, mpl->c);

         }

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

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

err:     {  enter_context(mpl);

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

               "oint number", mpl->image);

         }

      }

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

      {  /* character string */

         int quote = mpl->c;

         mpl->token = T_STRING;

         get_char(mpl);

         for (;;)

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

            {  enter_context(mpl);

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

                  "plete");

            }

            if (mpl->c == quote)

            {  get_char(mpl);

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

            }

            append_char(mpl);

         }

      }

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

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

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

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

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

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

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

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

      }

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

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

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

         {  /* comment sequence */

            get_char(mpl);

            for (;;)

            {  if (mpl->c == EOF)

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

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

                     "incomplete");

               }

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

               {  get_char(mpl);

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

               }

               else

                  get_char(mpl);

            }

            get_char(mpl);

            goto loop;

         }

      }

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

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

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

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

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

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

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

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

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

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

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

#endif

      }

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

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

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

      }

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

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

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

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

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

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

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

#endif

      }

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

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

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

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

      }

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

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

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

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

      }

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

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

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

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

      }

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

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

         if (mpl->f_dots)

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

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

            mpl->token = T_DOTS;

            mpl->imlen = 2;

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

            mpl->f_dots = 0;

         }

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

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

         else if (isdigit(mpl->c))

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

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

            goto frac;

         }

      }

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

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

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

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

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

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

      }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#endif

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

      {  /* symbol */

         xassert(mpl->flag_d);

         mpl->token = T_SYMBOL;

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

            append_char(mpl);

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

         {  case 0:

               mpl->token = T_NUMBER;

               break;

            case 1:

               goto err;

            case 2:

               break;

            default:

               xassert(mpl != mpl);

         }

      }

      else

      {  enter_context(mpl);

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

      }

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

      enter_context(mpl);

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

         is used by expression_list() */

      mpl->flag_x = 0;

done: return;

}

/*----------------------------------------------------------------------

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

--

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

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

void unget_token(MPL *mpl)

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

      xassert(!mpl->f_scan);

      mpl->f_scan = 1;

      mpl->f_token = mpl->token;

      mpl->f_imlen = mpl->imlen;

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

      mpl->f_value = mpl->value;

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

      mpl->token = mpl->b_token;

      mpl->imlen = mpl->b_imlen;

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

      mpl->value = mpl->b_value;

      return;

}

/*----------------------------------------------------------------------

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

--

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

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

int is_keyword(MPL *mpl, char *keyword)

{     return

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

}

/*----------------------------------------------------------------------

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

--

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

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

int is_reserved(MPL *mpl)

{     return

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

         mpl->token == T_BY ||

         mpl->token == T_CROSS ||

         mpl->token == T_DIFF ||

         mpl->token == T_DIV ||

         mpl->token == T_ELSE ||

         mpl->token == T_IF ||

         mpl->token == T_IN ||

         mpl->token == T_INTER ||

         mpl->token == T_LESS ||

         mpl->token == T_MOD ||

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

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

         mpl->token == T_SYMDIFF ||

         mpl->token == T_THEN ||

         mpl->token == T_UNION ||

         mpl->token == T_WITHIN;

}

/*----------------------------------------------------------------------

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

--

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

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

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

{     CODE *code;

      DOMAIN *domain;

      DOMAIN_BLOCK *block;

      ARG_LIST *e;

      /* generate pseudo-code */

      code = alloc(CODE);

      code->op = op;

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

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

         being generated, because the latter becomes the parent for all

         its operands */

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

      switch (op)

      {  case O_NUMBER:

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

            break;

         case O_STRING:

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

            break;

         case O_INDEX:

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

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

            break;

         case O_MEMNUM:

         case O_MEMSYM:

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

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

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

               e->x->up = code;

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

            }

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

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

            break;

         case O_MEMSET:

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

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

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

               e->x->up = code;

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

            }

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

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

            break;

         case O_MEMVAR:

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

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

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

               e->x->up = code;

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

            }

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

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

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

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

#endif

            break;

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

         case O_MEMCON:

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

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

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

               e->x->up = code;

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

            }

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

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

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

            break;

#endif

         case O_TUPLE:

         case O_MAKE:

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

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

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

               e->x->up = code;

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

            }

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

            break;

         case O_SLICE:

            xassert(arg->slice != NULL);

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

            break;

         case O_IRAND224:

         case O_UNIFORM01:

         case O_NORMAL01:

         case O_GMTIME:

            code->vflag = 1;

            break;

         case O_CVTNUM:

         case O_CVTSYM:

         case O_CVTLOG:

         case O_CVTTUP:

         case O_CVTLFM:

         case O_PLUS:

         case O_MINUS:

         case O_NOT:

         case O_ABS:

         case O_CEIL:

         case O_FLOOR:

         case O_EXP:

         case O_LOG:

         case O_LOG10:

         case O_SQRT:

         case O_SIN:

         case O_COS:

         case O_ATAN:

         case O_ROUND:

         case O_TRUNC:

         case O_CARD:

         case O_LENGTH:

            /* unary operation */

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

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

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

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

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

            break;

         case O_ADD:

         case O_SUB:

         case O_LESS:

         case O_MUL:

         case O_DIV:

         case O_IDIV:

         case O_MOD:

         case O_POWER:

         case O_ATAN2:

         case O_ROUND2:

         case O_TRUNC2:

         case O_UNIFORM:

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

         case O_NORMAL:

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

         case O_CONCAT:

         case O_LT:

         case O_LE:

         case O_EQ:

         case O_GE:

         case O_GT:

         case O_NE:

         case O_AND:

         case O_OR:

         case O_UNION:

         case O_DIFF:

         case O_SYMDIFF:

         case O_INTER:

         case O_CROSS:

         case O_IN:

         case O_NOTIN:

         case O_WITHIN:

         case O_NOTWITHIN:

         case O_SUBSTR:

         case O_STR2TIME:

         case O_TIME2STR:

            /* binary operation */

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

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

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

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

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

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

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

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

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

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

            break;

         case O_DOTS:

         case O_FORK:

         case O_SUBSTR3:

            /* ternary operation */

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

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

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

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

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

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

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

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

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

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

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

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

            }

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

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

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

            break;

         case O_MIN:

         case O_MAX:

            /* n-ary operation */

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

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

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

               e->x->up = code;

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

            }

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

            break;

         case O_SUM:

         case O_PROD:

         case O_MINIMUM:

         case O_MAXIMUM:

         case O_FORALL:

         case O_EXISTS:

         case O_SETOF:

         case O_BUILD:

            /* iterated operation */

            domain = arg->loop.domain;

            xassert(domain != NULL);

            if (domain->code != NULL)

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

               domain->code->up = code;

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

            }

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

               block->next)

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

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

               block->code->up = code;

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

            }

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

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

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

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

            }

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

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

            break;

         default:

            xassert(op != op);

      }

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

      code->type = type;

      code->dim = dim;

      code->up = NULL;

      code->valid = 0;

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

      return code;

}

/*----------------------------------------------------------------------

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

--

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

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

{     CODE *code;

      OPERANDS arg;

      xassert(x != NULL);

      arg.arg.x = x;

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

      return code;

}

/*----------------------------------------------------------------------

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

--

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

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

      int dim)

{     CODE *code;

      OPERANDS arg;

      xassert(x != NULL);

      xassert(y != NULL);

      arg.arg.x = x;

      arg.arg.y = y;

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

      return code;

}

/*----------------------------------------------------------------------

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

--

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

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

      int type, int dim)

{     CODE *code;

      OPERANDS arg;

      xassert(x != NULL);

      xassert(y != NULL);

      /* third operand can be NULL */

      arg.arg.x = x;

      arg.arg.y = y;

      arg.arg.z = z;

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

      return code;

}

/*----------------------------------------------------------------------

-- numeric_literal - parse reference to numeric literal.

--

-- This routine parses primary expression using the syntax:

--

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

CODE *numeric_literal(MPL *mpl)

{     CODE *code;

      OPERANDS arg;

      xassert(mpl->token == T_NUMBER);

      arg.num = mpl->value;

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

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

      return code;

}

/*----------------------------------------------------------------------

-- string_literal - parse reference to string literal.

--

-- This routine parses primary expression using the syntax:

--

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

CODE *string_literal(MPL *mpl)

{     CODE *code;

      OPERANDS arg;

      xassert(mpl->token == T_STRING);

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

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

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

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

      return code;

}

/*----------------------------------------------------------------------

-- create_arg_list - create empty operands list.

--

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

ARG_LIST *create_arg_list(MPL *mpl)

{     ARG_LIST *list;

      xassert(mpl == mpl);

      list = NULL;

      return list;

}

/*----------------------------------------------------------------------

-- expand_arg_list - append operand to operands list.

--

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

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

{     ARG_LIST *tail, *temp;

      xassert(x != NULL);

      /* create new operands list entry */

      tail = alloc(ARG_LIST);

      tail->x = x;

      tail->next = NULL;

      /* and append it to the operands list */

      if (list == NULL)

         list = tail;

      else

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

         temp->next = tail;

      }

      return list;

}

/*----------------------------------------------------------------------

-- arg_list_len - determine length of operands list.

--

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

int arg_list_len(MPL *mpl, ARG_LIST *list)

{     ARG_LIST *temp;

      int len;

      xassert(mpl == mpl);

      len = 0;

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

      return len;

}

/*----------------------------------------------------------------------

-- subscript_list - parse subscript list.

--

-- This routine parses subscript list using the syntax:

--

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

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

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

ARG_LIST *subscript_list(MPL *mpl)

{     ARG_LIST *list;

      CODE *x;

      list = create_arg_list(mpl);

      for (;;)

      {  /* parse subscript expression */

         x = expression_5(mpl);

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

         if (x->type == A_NUMERIC)

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

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

         if (x->type != A_SYMBOLIC)

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

         xassert(x->dim == 0);

         /* and append it to the subscript list */

         list = expand_arg_list(mpl, list, x);

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

         if (mpl->token == T_COMMA)

            get_token(mpl /* , */);

         else if (mpl->token == T_RBRACKET)

            break;

         else

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

      }

      return list;

}

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

/*----------------------------------------------------------------------

-- object_reference - parse reference to named object.

--

-- This routine parses primary expression using the syntax:

--

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

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

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

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

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

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

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

--                          <suffix>

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

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

--                          <suffix>

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

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

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

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

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

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

CODE *object_reference(MPL *mpl)

{     AVLNODE *node;

      DOMAIN_SLOT *slot;

      SET *set;

      PARAMETER *par;

      VARIABLE *var;

      CONSTRAINT *con;

      ARG_LIST *list;

      OPERANDS arg;

      CODE *code;

      char *name;

      int dim, suff;

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

      xassert(mpl->token == T_NAME);

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

      if (node == NULL)

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

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

      switch (avl_get_node_type(node))

      {  case A_INDEX:

            /* dummy index */

            slot = (DOMAIN_SLOT *)avl_get_node_link(node);

            name = slot->name;

            dim = 0;

            break;

         case A_SET:

            /* model set */

            set = (SET *)avl_get_node_link(node);

            name = set->name;

            dim = set->dim;

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

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

               default */

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

            break;

         case A_PARAMETER:

            /* model parameter */

            par = (PARAMETER *)avl_get_node_link(node);

            name = par->name;

            dim = par->dim;

            break;

         case A_VARIABLE:

            /* model variable */

            var = (VARIABLE *)avl_get_node_link(node);

            name = var->name;

            dim = var->dim;

            break;

         case A_CONSTRAINT:

            /* model constraint or objective */

            con = (CONSTRAINT *)avl_get_node_link(node);

            name = con->name;

            dim = con->dim;

            break;

         default:

            xassert(node != node);

      }

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

      /* parse optional subscript list */

      if (mpl->token == T_LBRACKET)

      {  /* subscript list is specified */

         if (dim == 0)

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