generic/compiler/instantiate.c

/*  ASCEND modelling environment
    Copyright (C) 2006 Carnegie Mellon University
    Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly
    Copyright (C) 1997 Benjamin Allan, Vicente Rico-Ramirez

    This program 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 2, or (at your option)
    any later version.

    This program 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 this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place - Suite 330,
    Boston, MA 02111-1307, USA.
*//*
    @file
    Ascend Instantiator Implementation

    @TODO this file is enormous and should be broken into pieces! -- JP
*//*
    by Tom Epperly
    Created: 1/24/90
    Last in CVS: $Revision: 1.84 $ $Date: 2003/02/06 04:08:30 $ $Author: ballan $
*/

#include <stdarg.h>
#include <utilities/ascConfig.h>
#include <utilities/ascMalloc.h>
#include <utilities/ascPanic.h>
#include <general/pool.h>
#include <general/list.h>
#include <general/dstring.h>
#include "compiler.h"
#if TIMECOMPILER
#include <time.h>
#include <general/tm_time.h>
#endif
#include "bit.h"
#include "symtab.h"
#include "fractions.h"
#include "dimen.h"
#include "functype.h"
#include "expr_types.h"
#include "instance_enum.h"
#include "stattypes.h"
#include "statement.h"
#include "child.h"
#include "type_desc.h"
#include "type_descio.h"
#include "module.h"
#include "library.h"
#include "sets.h"
#include "setio.h"
#include "extfunc.h"
#include "extcall.h"
#include "dimen.h"
#include "forvars.h"
#include "exprs.h"
#include "name.h"
#include "nameio.h"
#include "vlist.h"
#include "slist.h"
#include "evaluate.h"
#include "value_type.h"
#include "statio.h"
#include "pending.h"
#include "find.h"
#include "relation_type.h"
#include "relation.h"
#include "logical_relation.h"
#include "logrelation.h"
#include "relation_util.h"
#include "logrel_util.h"
#include "instance_types.h"
#include "cmpfunc.h"
#include "instance_io.h"
#include "when.h"
#include "case.h"
#include "when_util.h"
#include "select.h"
/* new headers */
#include "atomvalue.h"
#include "arrayinst.h"
#include "copyinst.h"
#include "createinst.h"
#include "destroyinst.h"
#include "extinst.h"
#include "visitinst.h"
#include "instquery.h"
#include "mathinst.h"
#include "mergeinst.h"
#include "parentchild.h"
#include "refineinst.h"
#include "check.h"
#include "instance_name.h"
#include "setinstval.h"
#include "anontype.h"
#include "anoncopy.h"
#include "parpend.h"
#include "parpend.h"
#include "bintoken.h"
#include "watchpt.h"
#include "initialize.h"
#include "instantiate.h"

/* don't even THINK ABOUT adding instmacro.h to this list -- ...what the? */

#define MAXNUMBER 4     /* maximum number of iterations allowed
                                 * without change */
#define PASS2MAXNUMBER 1    /* maximum number of iterations allowed
                                 * without change doing relations. In
                                 * system where rels reference rels, > 1 */

#define PASS3MAXNUMBER 4    /* maximum number of iterations allowed
                                 * without change doing logical relations.
                                 * In system where logrels reference logrels,
                                 * > 1 */

#define PASS4MAXNUMBER 1    /* maximum number of iterations allowed
                                 * without change executing WHEN. In
                                 * system where WHEN reference WHEN, > 1 */

#define AVG_CASES 2L        /* size to which all cases lists are */
                                /* initialized (WHEN instance) */
#define AVG_REF 2L      /* size to which all list of references */
                                /* in a case are initialized (WHEN) */

#define NO_INCIDENCES 7         /* avg number of vars in a external reln */

static int g_iteration = 0; /* the current iteration. */

/* moved from tcltk/generic/interface/SimsProc.c */
struct Instance *g_cursim;

#define NEW_ext 1
#define OLD_ext 0
/**<
    variable to check agreement in the number of boolean, integer or symbol
    variables in the WHEN/SELECT statement with the number of boolean, integer
    or symbol values in each of the CASEs
*/

#define MAX_VAR_IN_LIST  20
/**<
    Variables to switch old and new pass 2 instantiation.
    The condition for using new pass 2 (anonymous type-based
    relation copying) is g_use_copyanon != 0 || FORCE applied.
*/

int g_use_copyanon = 1;
/**
    the user switch for anonymous type based relation
    copying. if 0, no copying by that method is done.
*/

#if TIMECOMPILER
static int g_ExecuteREL_CreateTokenRelation_calls = 0;
/**<
    count the number of calls to CreateTokenRelation from ExecuteREL
*/

int g_CopyAnonRelation = 0;
#endif

long int g_compiler_counter = 1;
/**<
    What: counter incremented every time a compiler action capable of
         changing the instance tree is executed.
         At present the compiler cares nothing about this counter,
         but it is provided as a service to clients.
    
    Real applications:
    1) This variable is used for keeping track of calls to
    the compiler which will create the need for a total solver system
    rebuild.  This variable should be incremented anytime a function
    which changes the instance tree is called.
*/

/* #define DEBUG_RELS */
/* undef DEBUG_RELS if you want less spew in pass 2 */

#ifdef DEBUG_RELS
/* root of tree being visited in pass 2. */
struct Instance *debug_rels_work;
#endif /* dbgrels */

static unsigned
int g_instantiate_relns = ALLRELS;  /* default is to do all rels */

/* pointer to possible error message for child expansion.
 * messy way of error handling; do not imitate.
 */
static char *g_trychildexpansion_errmessage = NULL;
#define TCEM g_trychildexpansion_errmessage

/* error messages */
#define REDEFINE_CHILD_MESG "IS_A statement attempting to redefine child "
#define REDEFINE_CHILD_MESG2 "ALIASES statement attempting to redefine child "
#define UNDEFINED_TYPE_MESG "IS_A statement refers to undefined type "
#define IRT_UNDEFINED_TYPE "IS_REFINED_TO statement refers to undefined type "
#define REASSIGN_MESG1 "Attempt to reassign constant "
#define REASSIGN_MESG2 " value."

#ifndef lint
static CONST char InstantiatorRCSid[] = "$Id: instantiate.c,v 1.84 2003/02/06 04:08:30 ballan Exp $";
#endif

/*------------------------------------------------------------------------------
    forward declarations
*/

static void WriteForValueError(struct Statement *, struct value_t);
static void MakeInstance(CONST struct Name *, struct TypeDescription *, int,
                  struct Instance *, struct Statement *, struct Instance *);
static int CheckVarList(struct Instance *, struct Statement *);
static int CheckWhereStatements(struct Instance *,struct StatementList *);
static int ExecuteISA(struct Instance *, struct Statement *);
static int ExecuteCASGN(struct Instance *, struct Statement *);
static int DigestArguments(struct Instance *,
                    struct gl_list_t *, struct StatementList *,
                    struct StatementList *, struct Statement *);
static int DeriveSetType(CONST struct Set *, struct Instance *,CONST unsigned int);

static struct gl_list_t *FindInsts(struct Instance *, CONST struct VariableList *,
                            enum find_errors *);

static void MissingInsts(struct Instance *, CONST struct VariableList *,int);
static struct gl_list_t *FindArgInsts(struct Instance *, struct Set *,
                               enum find_errors *);
static void AddIncompleteInst(struct Instance *);
static int CheckALIASES(struct Instance *, struct Statement *);
static int CheckARR(struct Instance *, struct Statement *);
static int CheckISA(struct Instance *, struct Statement *);
static int AssignStructuralValue(struct Instance *,struct value_t,struct Statement *);
static int  CheckSELECT(struct Instance *, struct Statement *);
static int  CheckWHEN(struct Instance *, struct Statement *);
static void MakeRealWhenCaseReferencesFOR(struct Instance *,
                                          struct Instance *,
                                          struct Statement *,
                                          struct gl_list_t *);
static void MakeWhenCaseReferencesFOR(struct Instance *,
                                      struct Instance *,
                                      struct Statement *,
                                      struct gl_list_t *);
static int  Pass1CheckFOR(struct Instance *, struct Statement *);
static int  Pass1ExecuteFOR(struct Instance *, struct Statement *);
#ifdef THIS_IS_AN_UNUSED_FUNCTION
static int  Pass1RealCheckFOR(struct Instance *, struct Statement *);
#endif /* THIS_IS_AN_UNUSED_FUNCTION */
static void Pass1RealExecuteFOR(struct Instance *, struct Statement *);
static int  Pass2CheckFOR(struct Instance *, struct Statement *);
static int  Pass2ExecuteFOR(struct Instance *, struct Statement *);
static void Pass2FORMarkCond(struct Instance *, struct Statement *);
static void Pass2FORMarkCondRelations(struct Instance *, struct Statement *);
static int  Pass2RealCheckFOR(struct Instance *, struct Statement *);
static int  Pass2RealExecuteFOR(struct Instance *, struct Statement *);
static int  Pass3CheckFOR(struct Instance *, struct Statement *);
static int  Pass3ExecuteFOR(struct Instance *, struct Statement *);
static int  Pass3RealCheckFOR (struct Instance *, struct Statement *);
static int  Pass3RealExecuteFOR(struct Instance *, struct Statement *);
static void Pass3FORMarkCond(struct Instance *, struct Statement *);
static void Pass3FORMarkCondLogRels(struct Instance *, struct Statement *);
static int  Pass4CheckFOR(struct Instance *, struct Statement *);
static int  Pass4ExecuteFOR(struct Instance *, struct Statement *);
static int  Pass4RealCheckFOR(struct Instance *, struct Statement *);
static int  ExecuteUnSelectedForStatements(struct Instance *,
                                           struct StatementList *);
static void ExecuteDefault(struct Instance *, struct Statement *,
                           unsigned long int *);
static void RealDefaultFor(struct Instance *, struct Statement *,
                           unsigned long int *);
static void DefaultStatementList(struct Instance *, struct gl_list_t *,
                                 unsigned long int *);
static void ExecuteDefaultStatements(struct Instance *, struct gl_list_t *,
                                     unsigned long int *);
static int ExecuteSELECT(struct Instance *, unsigned long *,
                         struct Statement *);
static void ExecuteDefaultsInSELECT(struct Instance *, unsigned long *,
                                    struct Statement *, unsigned long int *);
static void RealExecuteWHEN(struct Instance *, struct Statement *);
static int  ExecuteUnSelectedSELECT(struct Instance *, unsigned long *,
                                    struct Statement *);
static void ExecuteUnSelectedStatements(struct Instance *i,unsigned long *,
                                        struct StatementList *);
static void ExecuteUnSelectedWhenStatements(struct Instance *,
                                            struct StatementList *);
static int ExecuteUnSelectedWHEN(struct Instance *, struct Statement *);
static void ReEvaluateSELECT(struct Instance *, unsigned long *,
                             struct Statement *, int, int *);

/*-----------------------------------------------------------------------------
    ...
*/


static
void ClearIteration(void)
{
  g_iteration = 0;
}

static
void WriteStatementLocation(FILE *f, struct Statement *stat)
{
  if (stat!= NULL){
    FPRINTF(f,"\nStatement located on line %lu of %s.\n",
            StatementLineNum(stat),
            Asc_ModuleBestName(StatementModule(stat)));
  }
  else
    FPRINTF(f,"NULL statement.\n");
}

static
void WriteSetError(struct Statement *statement, struct TypeDescription *def)
{
  STATEMENT_ERROR(statement, (GetBaseType(def) == set_type) ?
                             "No set type specified in IS_A statement"
                             : "Set type specified for a non-set type");
}

/**
    This code will emit error messages only on the last
    iteration when trying to clear pending statements.
    g_iteration is the global iteration counter, and MAXNUMBER
    is the number of times that the instantiator will try
    to clear the list, without change.
*/
static
void WriteUnexecutedMessage(FILE *f, struct Statement *stat, CONST char *msg)
{
  if (g_iteration>=(MAXNUMBER)) WSSM(f,stat,msg,0);
}


/**
    Write Unexecuted Error Message in Pass 3 WUEMPASS3
    
    This code will emit error messages only on the last
    iteration of pass3 when trying to clear pending statements.
    g_iteration is the global iteration counter, and PASS3MAXNUMBER
    is the number of times that the instantiator will try
    to clear the list, without change.
*/
static
void WUEMPASS3(FILE *f, struct Statement *stat, CONST char *msg)
{
  if (g_iteration>=(PASS3MAXNUMBER)) WSSM(f,stat,msg,0);
}

/*------------------------------------------------------------------------------
  DENSE ARRAY PROCESSING

    ...mostly
*/

/**
    returns 0 if c is NULL, probably should be -1.
    -2 if c is illegal set type
    1 if c IS_A integer_constant set type
    0 if c IS_A symbol_constant set type
    @param statement is used only to issue error messages.
*/
static
int CalcSetType(symchar *c, struct Statement *statement)
{
  struct TypeDescription *desc;
  if (c==NULL) return 0;
  if ((desc = FindType(c)) != NULL){
    switch(GetBaseType(desc)){
    case integer_constant_type: return 1;
    case symbol_constant_type: return 0;
    default:
      STATEMENT_ERROR(statement, "Incorrect set type in IS_A");
      /* lint should keep us from ever getting here */
      return -2;
    }
  } else{
    STATEMENT_ERROR(statement, "Unable to determine type of set.");
    return -2;
  }
}

/**
    last minute check for set values that subscript arrays.
    probably should check constantness too but does not.
    return 0 if ok, 1 if not.
*/
static
int CheckSetVal(struct value_t setval)
{
  if (ValueKind(setval) != set_value) {
    switch (ValueKind(setval)) {
    case integer_value:
      TCEM = "Incorrectly integer-valued array range.";
      break;
    case symbol_value:
      TCEM = "Incorrect symbol-valued array range.";
      break;
    case real_value:
      TCEM = "Incorrect real-valued array subscript.";
      break;
    case boolean_value:
      TCEM = "Incorrect boolean-valued array subscript.";
      break;
    case list_value:
      TCEM = "Incorrect list-valued array subscript.";
      break;
    case error_value:
      switch (ErrorValue(setval)) {
      case type_conflict:
        TCEM = "Set expression type conflict in array subscript.";
        break;
      default:
        TCEM = "Generic error 1 in array subscript.";
        break;
      }
      break;
    case set_value: /* really weird if this happens, since if eliminated it */
      break;
    default:
      TCEM = "Generic error 2 in array subscript.";
      break;
    }
    return 1;
  }
  return 0;
}

/**
    This attempts to evaluate a the next undone subscript of the
    array and call ExpandArray with that set value.
    In the case of ALIAS arrays this must always succeed, because
    we have checked first that it will. If it did not we would
    be stuck because later calls to ExpandArray will not know
    the difference between the unexpanded alias array and the
    unexpanded IS_A array.

    Similarly, in the case of parameterized arrays this must
    always succeed, OTHERWISE ExpandArray will not know the
    arguments of the IS_A type, arginst next time around.

    In the event that the set given or set value expanded is bogus,
    returns 1 and statement from which this call was derived is
    semantically garbage.
*/
static
int ValueExpand(struct Instance *i, unsigned long int pos,
                 struct value_t value, int *changed,
                 struct Instance *rhsinst, struct Instance *arginst,
                 struct gl_list_t *rhslist)
{
  struct value_t setval;
  switch(ValueKind(value)){
  case list_value:
    setval = CreateSetFromList(value);
    if (CheckSetVal(setval)) {
      return 1;
    }
    ExpandArray(i,pos,SetValue(setval),rhsinst,arginst,rhslist);
    /* this may modify the pending instance list if
     * rhslist and rhsinst both == NULL.
     */
    *changed = 1;
    DestroyValue(&setval);
    break;
  case error_value:
    switch(ErrorValue(value)){
    case name_unfound:
    case undefined_value:
      break;
    default:
      TCEM = "Array instance has incorrect index type.";
      return 1;
    }
    break;
  default:
    TCEM = "Array instance has incorrect index value type.";
    return 1;
  }
  return 0;
}

/**
    When an incorrect combination of sparse and dense indices is found,
    marks the statement wrong and whines. If the statement has already
    been marked wrong, does not whine.

    In FOR loops,
    this function warns  about a problem that the implementation really
    should allow. Alas, the fix is pending a complete rework of arrays.

    In user is idiot case,
    this really should have been ruled out by checkisa, which lets a little
    too much trash through. Our whole array implementation sucks.
*/
static
void SignalChildExpansionFailure(struct Instance *work,unsigned long cnum)
{
  struct TypeDescription *desc;
  ChildListPtr clp;
  struct Statement *statement;

  assert(work!= NULL);
  assert(cnum!= 0);
  assert(InstanceKind(work)==MODEL_INST);
  desc = InstanceTypeDesc(work);
  clp = GetChildList(desc);
  statement = (struct Statement *)ChildStatement(clp,cnum);
  if ( StatWrong(statement) != 0) {
    return;
  }
  if (TCEM != NULL) {
    FPRINTF(ASCERR,"%s\n",TCEM);
    TCEM = NULL;
  }
  if (StatInFOR(statement)) {
    MarkStatContext(statement,context_WRONG);
    STATEMENT_ERROR(statement, "Add another FOR index. In FOR loops,"
         " all array subscripts must be scalar values, not sets.");
    WSS(ASCERR,statement);
  } else {
    MarkStatContext(statement,context_WRONG);
    STATEMENT_ERROR(statement, "Subscripts of conflicting or incorrect types"
         " in rectangular array.");
    WSS(ASCERR,statement);
  }
  return;
}

/**
    Should never be called with BOTH rhs(inst/list) and arginst != NULL,
    but one or both may be NULL depending on other circumstances.
    Should never be called on ALIASES/IS_A inside a for loop.
    Returns an error number other than 0 if called inside a for loop.
    If error, outer scope should mark statement incorrect.
*/
static
int TryChildExpansion(struct Instance *child,
                       struct Instance *parent,
                       int *changed,
                       struct Instance *rhsinst,
                       struct Instance *arginst,
                       struct gl_list_t *rhslist)
{
  unsigned long pos,oldpos=0;
  struct value_t value;
  CONST struct Set *setp;
  int error=0;
  assert(arginst==NULL || (rhsinst==NULL && rhslist==NULL));
  /* one must be NULL as alii do not have args */
  while((pos=NextToExpand(child))>oldpos){
    oldpos=pos;
    setp = IndexSet(child,pos);
    if (GetEvaluationContext() != NULL) {
      error++;
      FPRINTF(ASCERR,"TryChildExpansion with mixed instance\n");
    } else {
      SetEvaluationContext(parent); /* could be wrong for mixed style arrays */
      value = EvaluateSet(setp,InstanceEvaluateName);
      SetEvaluationContext(NULL);
      if (ValueExpand(child,pos,value,changed,rhsinst,arginst,rhslist) != 0) {
        error++;
      }
      DestroyValue(&value);
    }
  }
  return error;
}

/**
    expands, if possible, children of nonrelation,
    nonalias, nonparameterized arrays.
*/
static
void TryArrayExpansion(struct Instance *work, int *changed)
{
  unsigned long c,len;
  struct Instance *child;
  struct TypeDescription *desc;
  len = NumberChildren(work);
  for(c=1;c<=len;c++){
    child = InstanceChild(work,c);
    if (child!=NULL){
      switch(InstanceKind(child)){
      case ARRAY_INT_INST:
      case ARRAY_ENUM_INST:
        desc = InstanceTypeDesc(child);
        /* no alii, no parameterized types, no for loops allowed. */
        if ((!GetArrayBaseIsRelation(desc))&&(!RectangleArrayExpanded(child)) &&
             (!GetArrayBaseIsLogRel(desc)) ) {
          if (TryChildExpansion(child,work,changed,NULL,NULL,NULL)!= 0) {
            SignalChildExpansionFailure(work,c);
          }
        }
        break;
      default:
#if 0 /* example of what not to do here */
        FPRINTF(ASCERR,"TryArrayExpansion called with non-array instance\n");
        /* calling with non array child is fairly common and unavoidable */
#endif
        break;
      }
    }
  }
}

static
void DestroyIndexList(struct gl_list_t *gl)
{
  struct IndexType *ptr;
  int c,len;
  if (gl!=NULL) {
    for (c=1,len = gl_length(gl);c <= len;c++) {
      ptr = (struct IndexType *)gl_fetch(gl,c);
      if (ptr) DestroyIndexType(ptr);
    }
    gl_destroy(gl);
  }
}

/**
    returns 1 if ex believed to be integer, 0 if symbol, and -1 if
    confused. if searchfor TRUE, includes fortable in search
*/
static
int FindExprType(CONST struct Expr *ex, struct Instance *parent,
                 CONST unsigned int searchfor
){
  struct Instance *i;
  struct gl_list_t *ilist;
  enum find_errors err;
  switch(ExprType(ex)){
  case e_var:
    ilist = FindInstances(parent,ExprName(ex),&err);
    if ((ilist!=NULL)&&(gl_length(ilist)>0)){
      i = (struct Instance *)gl_fetch(ilist,1);
      gl_destroy(ilist);
      switch(InstanceKind(i)){
      case INTEGER_ATOM_INST:
      case INTEGER_INST:
      case INTEGER_CONSTANT_INST:
        return 1;
      case SYMBOL_ATOM_INST:
      case SYMBOL_INST:
      case SYMBOL_CONSTANT_INST:
        return 0;
      case SET_ATOM_INST:
      case SET_INST:
        return IntegerSetInstance(i);
      default:
        FPRINTF(ASCERR,"Incorrect index type; guessing integer index.\n");
        return 1;
      }
    } else {
      if (ilist!=NULL) gl_destroy(ilist);
      if (GetEvaluationForTable()!=NULL) {
        symchar *name;
        struct for_var_t *ptr;
        AssertMemory(GetEvaluationForTable());
        name = SimpleNameIdPtr(ExprName(ex));
        if (name!=NULL) {
          ptr = FindForVar(GetEvaluationForTable(),name);
          if (ptr!=NULL) {
            switch(GetForKind(ptr)) {
            case f_integer:
              return 1;
            case f_symbol:
              return 0;
            default:
              FPRINTF(ASCERR,"Undefined FOR or indigestible variable.\n");
            }
          }
        }
      }
      return -1;
    }
  case e_int:
    return 1;
  case e_symbol:
    return 0;
  case e_set:
    return DeriveSetType(ExprSValue(ex),parent,searchfor);
  default:
    if (g_iteration>=(MAXNUMBER)) {
      /* referencing g_iteration sucks, but seeing spew sucks more.*/
      /* WUM, which we want, needs a statement ptr we can't supply. */
      FPRINTF(ASCERR,"Heuristic FindExprType failed. Check your indices.\n");
      FPRINTF(ASCERR,"Report this failure to %s if no apparent error.\n",
              ASC_MILD_BUGMAIL);
      FPRINTF(ASCERR,"Assuming integer array index.\n");
    }
    return -1;
  }
}

/**
    returns -1 if has no clue,
    returns 1 if set appears to be int set
    returns 0 if apparently symbol_constant set.
*/
static
int DeriveSetType(CONST struct Set *sptr, struct Instance *parent,
                  CONST unsigned int searchfor
){
  register CONST struct Set *ptr;
  int result=-1;        /* -1 indicates a failure */
  ptr = sptr;
  /* if it contains a range it must be an integer set */
  while(ptr!=NULL){
    if (SetType(ptr)) return 1;
    ptr = NextSet(ptr);
  }
  ptr = sptr;
  /* try to find the type from the expressions */
  while(ptr!=NULL){
    if ((result = FindExprType(GetSingleExpr(ptr),parent,searchfor)) >= 0) {
      return result;
    }
    ptr = NextSet(ptr);
  }
  return -1;            /* undefined type */
}

/**
    Returns a gllist contain the string form (or forms) of array
    subscripts(s)
    e.g. Name a[1..2]['foo']
    will return a gllist containing something like:
    "1..2"
    "foo"
*/
static
struct gl_list_t *ArrayIndices(CONST struct Name *name,
                               struct Instance *parent)
{
  struct gl_list_t *result;
  int settype;
  CONST struct Set *sptr;

  if (!NameId(name)) return NULL;
  name = NextName(name);
  if (name == NULL) return NULL;
  result = gl_create(2L);
  while (name!=NULL){
    if (NameId(name)){
      DestroyIndexList(result);
      return NULL;
    }
    sptr = NameSetPtr(name);
    if ((settype = DeriveSetType(sptr,parent,0)) >= 0){
      gl_append_ptr(result,
                    (VOIDPTR)CreateIndexType(CopySetList(sptr),settype));
    } else{
      DestroyIndexList(result);
      return NULL;
    }
    name = NextName(name);
  }
  return result;
}

/*-----------------------------------------------------------------------------
  SPARSE AND DENSE ARRAY PROCESSING
*/

/**
    this function has been modified to handle list results when called
    from check aliases and dense executearr.
    The indices made here in the aliases case where the alias is NOT
    inside a FOR loop are NOT for consumption by anyone because they
    contain a dummy index type. They merely indicate that
    indices can be made. They should be immediately destroyed.
    DestroyIndexType is the only thing that groks the Dummy.
    This should not be called on the final subscript of an ALIASES/IS_A
    inside a FOR loop unless you can grok a dummy in last place.
*/
static
struct IndexType *MakeIndex(struct Instance *inst,
                            CONST struct Set *sptr,
                            struct Statement *stat, int last)
{
  struct value_t value;
  struct value_t setval;
  int intset;
  assert(GetEvaluationContext()==NULL);
  SetEvaluationContext(inst);
  if (StatInFOR(stat)) {
    if (sptr == NULL ||
        NextSet(sptr) != NULL ||
        SetType(sptr) != 0 ) {
      /* must be simple index */
      WriteUnexecutedMessage(ASCERR,stat,
        "Next subscript in FOR loop IS_A must be a scalar value,"
        " not a set value.");
      SetEvaluationContext(NULL);
      return NULL;
    }
    value = EvaluateExpr(GetSingleExpr(sptr),NULL,InstanceEvaluateName);
    SetEvaluationContext(NULL);
    switch(ValueKind(value)){
    case real_value:
    case boolean_value:
    case set_value:
    case list_value:
      if (last==0) {
        STATEMENT_ERROR(stat, "Index to sparse array is of an incorrect type");
        DestroyValue(&value);
        return NULL;
      } else {
        setval = CreateSetFromList(value);
        intset = (SetKind(SetValue(setval)) == integer_set);
        DestroyValue(&value);
        DestroyValue(&setval);
        return CreateDummyIndexType(intset);
        /* damn thing ends up in typedesc of arrays. */
      }
    case integer_value:
      DestroyValue(&value);
      return CreateIndexType(CopySetList(sptr),1);
    case symbol_value:
      DestroyValue(&value);
      return CreateIndexType(CopySetList(sptr),0);
    case error_value:
      switch(ErrorValue(value)){
      case undefined_value:
        if (StatementType(stat)==REL||StatementType(stat)==LOGREL) {
          WSSM(ASCERR,stat,"Undefined relation array indirect indices",3);
          /* don't want to warn about sparse IS_A/aliases here */
        }
        break;
      case name_unfound:
        break;
      default:
        WSSM(ASCERR,stat, "Error in sparse array indices",3);
        break;
      }
      DestroyValue(&value);
      return NULL;
    default:
      STATEMENT_ERROR(stat, "Unknown result value type in MakeIndex.\n");
      Asc_Panic(2, NULL, "Unknown result value type in MakeIndex.\n");
      
    }
  } else { /* checking subscripts on dense ALIASES/param'd IS_A statement */
    if (sptr==NULL) {
      SetEvaluationContext(NULL);
      return NULL;
    }
    value = EvaluateSet(sptr,InstanceEvaluateName);
    SetEvaluationContext(NULL);
    switch(ValueKind(value)){
    case list_value:
      DestroyValue(&value);
      return CreateDummyIndexType(0 /* doesn't matter -- dense alias check */);
    case error_value:
      switch(ErrorValue(value)){
        case undefined_value:
        case name_unfound:
          DestroyValue(&value);
          return NULL;
      default:
        DestroyValue(&value);
        WSSM(ASCERR,stat, "Error evaluating index to dense array",3);
        return NULL;
      }
    default:
      DestroyValue(&value);
      STATEMENT_ERROR(stat, "Bad index to dense alias array");
      Asc_Panic(2, NULL, "Bad index to dense alias array");
      
    }
    /* return NULL; */  /* unreachable */
  }
}

/**
    This function is used for making the indices of individual
    elements of sparse arrays (and for checking that it is possible)
    and for checking that the indices of dense alias arrays (a
    very wierd thing to have) and dense parameterized IS_A
    are fully defined so that aliases
    and parameterized/sparse IS_A can be fully constructed in 1 pass.
    paves over the last subscript on sparse ALIASES-IS_A.
*/
static
struct gl_list_t *MakeIndices(struct Instance *inst,
                              CONST struct Name *name,
                              struct Statement *stat)
{
  struct gl_list_t *result;
  CONST struct Set *sptr;
  struct IndexType *ptr;
  int last;


  result = gl_create((unsigned long)NameLength(name));
  while(name != NULL){
    if (NameId(name)){
      DestroyIndexList(result);
      return NULL;
    }
    sptr = NameSetPtr(name);
    last = (NextName(name)==NULL && StatementType(stat)==ARR);
    ptr = MakeIndex(inst,sptr,stat,last);
    if (ptr !=  NULL) {
      gl_append_ptr(result,(VOIDPTR)ptr);
    } else {
      DestroyIndexList(result);
      return NULL;
    }
    name = NextName(name);
  }
  return result;
}

static
void LinkToParentByName(struct Instance *inst,
                        struct Instance *child,
                        symchar *name)
{
  struct InstanceName rec;
  unsigned long pos;
  SetInstanceNameType(rec,StrName);
  SetInstanceNameStrPtr(rec,name);
  pos = ChildSearch(inst,&rec);
  LinkToParentByPos(inst,child,pos);
}

void LinkToParentByPos(struct Instance *inst,
                       struct Instance *child,
                       unsigned long pos)
{
  assert(pos);
  assert(child != NULL);
  assert(inst != NULL);

  StoreChildPtr(inst,pos,child);
  AddParent(child,inst);
}

static
struct Instance *GetArrayHead(struct Instance *inst, CONST struct Name *name)
{
  struct InstanceName rec;
  unsigned long pos;
  if (NameId(name)){
    SetInstanceNameType(rec,StrName);
    SetInstanceNameStrPtr(rec,NameIdPtr(name));
    pos=ChildSearch(inst,&rec);
    if (pos>0) {
      return InstanceChild(inst,pos);
    } else {
      return NULL;
    }
  }
  return NULL;
}

/**
    We are inside a FOR loop.
    If rhsinst is not null, we are in an alias statement and
    will use rhsinst as the child added instead of
    creating a new child.
    If arginst is not null, we will use it to aid in
    creating IS_A elements.
    at least one of arginst, rhsinst must be NULL.
    If last !=0, returns NULL naturally and ok.
*/
static
struct Instance *DoNextArray(struct Instance *parentofary, /* MODEL */
                             struct Instance *ptr, /* array layer */
                             CONST struct Name *name, /* subscript */
                             struct Statement *stat,
                             struct Instance *rhsinst, /*ALIASES*/
                             struct Instance *arginst, /* IS_A */
                             struct gl_list_t *rhslist, /*ARR*/
                             int last /* ARR */)
{
  CONST struct Set *sptr;
  struct value_t value;
  struct value_t setval;
  long i;
  symchar *sym;

  if (NameId(name) != 0) return NULL; /* must be subscript, i.e. set */
  sptr = NameSetPtr(name);
  if ((sptr==NULL)||(NextSet(sptr)!=NULL)||(SetType(sptr))) {
    return NULL;
  }
  assert(GetEvaluationContext()==NULL);
  assert(rhsinst==NULL || arginst==NULL);
  SetEvaluationContext(parentofary);
  value = EvaluateExpr(GetSingleExpr(sptr),NULL,InstanceEvaluateName);
  SetEvaluationContext(NULL);
  switch(ValueKind(value)){
  case real_value:
  case set_value:
  case boolean_value:
  case list_value:
    if (last==0) {
      STATEMENT_ERROR(stat, "Index to array is of an incorrect type");
      DestroyValue(&value);
      return NULL;
    } else {
      /* we are at last subscript of ALIASES/IS_A in for loop. */
      /* expand using rhslist pretending dense array. */
      setval = CreateSetFromList(value);
      ExpandArray(ptr,1L,SetValue(setval),NULL,NULL,rhslist);
      DestroyValue(&setval);
      DestroyValue(&value);
      return NULL;
    }
  case integer_value:
    i = IntegerValue(value);
    DestroyValue(&value);
    return FindOrAddIntChild(ptr,i,rhsinst,arginst);
  case symbol_value:
    sym = SymbolValue(value);
    DestroyValue(&value);
    return FindOrAddStrChild(ptr,sym,rhsinst,arginst);
  case error_value:
    switch(ErrorValue(value)){
    case undefined_value:
      if (StatementType(stat)==REL||StatementType(stat)==LOGREL) {
        WSSM(ASCERR,stat, "Undefined relation array indirect indices",3);
      }
      break;
    case name_unfound:
      break;
    default:
      STATEMENT_ERROR(stat, "Error in array indices");
      break;
    }
    DestroyValue(&value);
    return NULL;
  default:
    Asc_Panic(2, NULL ,"Unknown result value type.\n");
    
  }
}

/**
    We are inside a FOR loop.
    If rhsinst is not null, we are in an alias statement and
    will eventually use rhsinst as the child added instead of
    creating a new child.
    we expand each subscript individually here rahter than recursively.
    If we are on last subscript of an ALIASES/IS_A, we copy the
    layer in rhslist rather than expanding individually.
    rhslist and intset only make sense simultaneously.
*/
static
struct Instance *AddArrayChild(struct Instance *parentofary,
                               CONST struct Name *name,
                               struct Statement *stat,
                               struct Instance *rhsinst,
                               struct Instance *arginst,
                               struct gl_list_t *rhslist)
{
  struct Instance *ptr;
  int last;

  ptr = GetArrayHead(parentofary,name);
  if(ptr != NULL) {
    name = NextName(name);
    while(name!=NULL){
      last = (rhslist != NULL && NextName(name)==NULL);
      ptr = DoNextArray(parentofary,ptr,name,stat,
                        rhsinst,arginst,rhslist,last);
      if (ptr==NULL){
        return NULL;
      }
      name = NextName(name);
    }
    return ptr;
  } else {
    return NULL;
  }
}

/**
    Create the sparse array typedesc based on the statement kind
    and also add first child named. intset and def used for nonrelation types
    only.

    This function returns the child pointer because relation functions
    need it, not because the child is unconnected.
    
    If rhsinst is not NULL, uses rhsinst instead of creating new one.
    If rhslist is not NULL, uses rhslist instead of rhsinst or creating.

    It is expected that all subscripts will be evaluatable and that
    in the case of the ALIASES-IS_A statement, the IS_A part is done
    just before the ALIASES part.
*/
static
struct Instance *MakeSparseArray(struct Instance *parent,
                                 CONST struct Name *name,
                                 struct Statement *stat,
                                 struct TypeDescription *def,
                                 int intset,
                                 struct Instance *rhsinst,
                                 struct Instance *arginst,
                                 struct gl_list_t *rhslist)
{
  struct TypeDescription *desc = NULL;
  struct Instance *aryinst;
  struct gl_list_t *indices;
  indices = MakeIndices(parent,NextName(name),stat);
  if (indices != NULL) {
    switch (StatementType(stat)) {
    case REL:
      assert(def==NULL && rhsinst==NULL && rhslist == NULL && arginst == NULL);
      desc = CreateArrayTypeDesc(StatementModule(stat),FindRelationType(),
                                 0,1,0,0,indices);
      break;
    case LOGREL:
      assert(def==NULL && rhsinst==NULL && rhslist == NULL && arginst == NULL);
      desc = CreateArrayTypeDesc(StatementModule(stat),FindLogRelType(),
                                 0,0,1,0,indices);
      break;
    case WHEN:
      assert(def==NULL && rhsinst==NULL && rhslist == NULL && arginst == NULL);
      desc = CreateArrayTypeDesc(StatementModule(stat),
                                 FindWhenType(),0,0,0,1,indices);
      break;
    case ISA:
    case ALIASES:
    case ARR:
      assert(def!=NULL);
      desc = CreateArrayTypeDesc(StatementModule(stat),def,
                                 intset,0,0,0,indices);
      break;
    default:
      STATEMENT_ERROR(stat, "Utter screw-up in MakeSparseArray");
      Asc_Panic(2, NULL, "Utter screw-up in MakeSparseArray");
    }
    aryinst = CreateArrayInstance(desc,1);
    LinkToParentByName(parent,aryinst,NameIdPtr(name));
    return AddArrayChild(parent,name,stat,rhsinst,arginst,rhslist);
  } else {
    return NULL;
  }
}

/*------------------------------------------------------------------------------
    ...
*/

/**
    handles construction of alias statements, allegedly, per lhs.
    parent function should find rhs and send it in as rhsinst.
    rhsinst == null should never be used with this function.
    currently, arrays ignored, fatally.
*/
static
void MakeAliasInstance(CONST struct Name *name,
                       CONST struct TypeDescription *basedef,
                       struct Instance *rhsinst,
                       struct gl_list_t *rhslist,
                       int intset,
                       struct Instance *parent,
                       struct Statement *statement)
{
  symchar *childname;
  int changed;
  unsigned long pos;
  struct Instance *inst;
  struct InstanceName rec;
  struct TypeDescription *arydef, *def;
  struct gl_list_t *indices;
  int tce;
  assert(rhsinst != NULL || rhslist !=NULL); /* one required */
  assert(rhsinst == NULL || rhslist ==NULL); /* only one allowed */
  childname = SimpleNameIdPtr(name);
  if (childname !=NULL){
    /* case of simple part name */
    if (StatInFOR(statement) && StatWrong(statement)==0) {
      MarkStatContext(statement,context_WRONG);
      STATEMENT_ERROR(statement,"Unindexed statement in FOR loop not allowed.");
      WSS(ASCERR,statement);
      return;
    }
    SetInstanceNameType(rec,StrName);
    SetInstanceNameStrPtr(rec,childname);
    pos = ChildSearch(parent,&rec);
    if (pos>0){
      /* case of part expected */
      if (InstanceChild(parent,pos)==NULL){
        /* case of part not there yet */
        inst = rhsinst;
        StoreChildPtr(parent,pos,inst);
        if (SearchForParent(inst,parent)==0) {
          /* case where we don't already have it at this scope */
          AddParent(inst,parent);
        }
      } else{           /* redefining instance */
        /* case of part already there and we barf */
        char *msg = ASC_NEW_ARRAY(char,SCLEN(childname)+strlen(REDEFINE_CHILD_MESG2)+1);
        strcpy(msg,REDEFINE_CHILD_MESG2);
        strcat(msg,SCP(childname));
        STATEMENT_ERROR(statement,msg);
        ascfree(msg);
      }
    } else{         /* unknown child name */
      /* case of part not expected */
      STATEMENT_ERROR(statement, "Unknown child name.  Never should happen");
      Asc_Panic(2, NULL, "Unknown child name.  Never should happen");
    }
  } else{
    /* if reach the else, means compound identifier or garbage */
    indices = ArrayIndices(name,parent);
    if (rhsinst != NULL) {
      def = InstanceTypeDesc(rhsinst);
    } else {
      def = (struct TypeDescription *)basedef;
    }
    if (indices!=NULL){ /* array of some sort */
      childname = NameIdPtr(name);
      SetInstanceNameType(rec,StrName);
      SetInstanceNameStrPtr(rec,childname);
      pos = ChildSearch(parent,&rec);
      if (!StatInFOR(statement)) {
        /* rectangle arrays */
        arydef = CreateArrayTypeDesc(StatementModule(statement),
                                     def,intset,0,0,0,indices);
        if (pos>0) {
          inst = CreateArrayInstance(arydef,1);
          if (inst!=NULL){
            changed = 0;
            tce = TryChildExpansion(inst,parent,&changed,rhsinst,NULL,rhslist);
            /* we're not in a for loop, so can't fail unless user is idiot. */
            LinkToParentByPos(parent,inst,pos); /* don't want to lose memory */
            /* if user is idiot, whine. */
            if (tce != 0) {
              SignalChildExpansionFailure(parent,pos);
            }
          } else {
            STATEMENT_ERROR(statement, "Unable to create alias array instance");
            Asc_Panic(2, NULL, "Unable to create alias array instance");
          }
        } else {
          DeleteTypeDesc(arydef);
          STATEMENT_ERROR(statement,
               "Unknown array child name. Never should happen");
          Asc_Panic(2, NULL, "Unknown array child name. Never should happen");
        }
      } else {
        /* sparse array */
        DestroyIndexList(indices);
        if (pos>0) {
          if (InstanceChild(parent,pos)==NULL) {
            /* need to make alias array */
            /* should check for NULL return here */
            (void)
            MakeSparseArray(parent,name,statement,def,
                            intset,rhsinst,NULL,rhslist);
          } else {
            /* need to add alias array element */
            /* should check for NULL return here */
            (void) AddArrayChild(parent,name,statement,
                                 rhsinst,NULL,rhslist);
          }
        } else {
          STATEMENT_ERROR(statement,
            "Unknown array child name. Never should happen");
          Asc_Panic(2, NULL, "Unknown array child name. Never should happen");
        }
      }
    } else {
      /* bad child name. cannot create parts of parts. should never
       * happen, being trapped out in typelint.
       */
      STATEMENT_ERROR(statement,"Bad ALIASES child name.");
    }
  }
}

/**
    @return 1 if concluded with statement, 0 if might try later.
*/
static
int ExecuteALIASES(struct Instance *inst, struct Statement *statement)
{
  CONST struct VariableList *vlist;
  struct gl_list_t *rhslist;
  struct Instance *rhsinst;
  CONST struct Name *name;
  enum find_errors ferr;
  int intset;

  assert(StatementType(statement)==ALIASES);
  if (StatWrong(statement)) {
    /* incorrect statements should be warned about when they are
     * marked wrong, so we just ignore them here.
     */
    return 1;
  }
  if (!CheckALIASES(inst,statement)) {
    WriteUnexecutedMessage(ASCERR,statement,
      "Possibly undefined sets/ranges in ALIASES statement.");
    return 0;
  }
  name = AliasStatName(statement);
  rhslist = FindInstances(inst,name,&ferr);
  if (rhslist == NULL) {
    WriteUnexecutedMessage(ASCERR,statement,
      "Possibly undefined right hand side in ALIASES statement.");
    return 0; /* rhs not compiled yet */
  }
  if (gl_length(rhslist)>1) {
    STATEMENT_ERROR(statement,"ALIASES needs exactly 1 RHS");
    gl_destroy(rhslist);
    return 1; /* rhs not unique for current values of sets */
  }
  rhsinst = (struct Instance *)gl_fetch(rhslist,1);
  gl_destroy(rhslist);
  if (InstanceKind(rhsinst)==REL_INST || LREL_INST ==InstanceKind(rhsinst)) {
    STATEMENT_ERROR(statement,"Direct ALIASES of relations are not permitted");
    MarkStatContext(statement,context_WRONG);
    WSS(ASCERR,statement);
    return 1; /* relations only aliased through models */
  }
  intset = ( (InstanceKind(rhsinst)==SET_ATOM_INST) &&
             (IntegerSetInstance(rhsinst)) );
  vlist = GetStatVarList(statement);
  while (vlist!=NULL){
    MakeAliasInstance(NamePointer(vlist),NULL,rhsinst,
                      NULL,intset,inst,statement);
    vlist = NextVariableNode(vlist);
  }
  return 1;
}


/*------------------------------------------------------------------------------
  SUPPORT FOR ALIASES-IS_A STATEMENTS
*/

/**
    enforce max len and no-apostrope (') rules for subscripts. string returned
    may not be string sent.
*/
static
char *DeSingleQuote(char *s)
{
  char *old;
  int len;
  if (s==NULL) {
    return s;
  }
  len = strlen(s);
  if (len > 40) {
    old = s;
    s = ASC_NEW_ARRAY(char,41);
    strncpy(s,old,17);
    s[17] = '.';
    s[18] = '.';
    s[19] = '.';
    s[20] = '\0';
    strcat(s,(old+len-20));
    ascfree(old);
  }
  old = s;
  while (*s != '\0') {
    if (*s =='\'') {
      *s = '_';
    }
    s++;
  }

  return old;
}

/**
    returns a symchar based on but not in strset,
    and adds original and results to sym table.
    destroys the s given.
*/
static
symchar *UniquifyString(char *s, struct set_t *strset)
{
  int oldlen, maxlen, c;
  char *new;
  symchar *tmp;

  tmp = AddSymbol(s);
  if (StrMember(tmp,strset)!=0) {
    oldlen = strlen(s);
    maxlen = oldlen+12;
    new = ascrealloc(s,oldlen+14);
    assert(new!=NULL);
    while ( (oldlen+1) < maxlen) {
      new[oldlen+1] = '\0';
      for(c = 'a'; c <= 'z'; c++){
        new[oldlen] = (char)c;
        tmp = AddSymbol(new);
        if (StrMember(tmp,strset)==0) {
          ascfree(new);
          return tmp;
        }
      }
      oldlen++;
    }
    Asc_Panic(2, NULL,
              "Unable to generate unique compound alias subscript.\n");
    
  } else {
    ascfree(s);
    return tmp;
  }
}

static
struct value_t GenerateSubscripts(struct Instance *iref,
                                  struct gl_list_t *rhslist,
                                  int intset)
{
  struct set_t *setinstval;
  unsigned long c,len;
  char *str;
  symchar *sym;

  setinstval = CreateEmptySet();
  len = gl_length(rhslist);
  if (intset!=0) {
    /* create subscripts 1..rhslistlen */
    for (c=1;c<=len; c++) {
      AppendIntegerElement(setinstval,c);
    }
    return CreateSetValue(setinstval);
  }
  /* create string subscripts */
  for (c=1; c<= len; c++) {
    str = WriteInstanceNameString((struct Instance *)gl_fetch(rhslist,c),iref);
    str = DeSingleQuote(str); /* transmogrify for length and ' marks */
    sym = UniquifyString(str,setinstval); /* convert to symbol and free str */
    AppendStringElement(setinstval,sym);
  }
  return CreateSetValue(setinstval);
}

static
void DestroyArrayElements(struct gl_list_t *rhslist)
{
  unsigned long c,len;
  if (rhslist==NULL){
    return;
  }
  for (c=1, len = gl_length(rhslist); c <= len; c++) {
    FREEPOOLAC(gl_fetch(rhslist,c));
  }
  gl_destroy(rhslist);
}

/**
    this function computes the subscript set (or generates it if
    needed) and checks it for matching against the instance list
    and whines when things aren't kosher.
    When things are kosher, creates a gl_list of array children.
    This list is returned through rhslist.
*/
static
struct value_t ComputeArrayElements(struct Instance *inst,
                                    struct Statement *statement,
                                    struct gl_list_t *rhsinstlist,
                                    struct gl_list_t **rhslist)
{
  struct value_t subslist;
  struct value_t subscripts;
  struct value_t result; /* return value is the expanded subscript set */
  CONST struct Set *setp;
  struct set_t *sip;
  int intset;
  unsigned long c, len;
  struct ArrayChild *ptr;

  assert((*rhslist)==NULL && rhsinstlist != NULL && rhslist != NULL);

  intset = ArrayStatIntSet(statement);
  len = gl_length(rhsinstlist);
  setp = ArrayStatSetValues(statement);
  if (setp==NULL) {
    /* value generated is a set and automatically is of correct CARD() */
    result = GenerateSubscripts(inst,rhsinstlist,intset);
    /* fill up rhslist and return */
    *rhslist = gl_create(len);
    sip = SetValue(result);
    if (intset != 0) {
      for (c = 1; c <= len; c++) {
        ptr = MALLOCPOOLAC;
        ptr->inst = gl_fetch(rhsinstlist,c);
        ptr->name.index = FetchIntMember(sip,c);
        gl_append_ptr(*rhslist,(VOIDPTR)ptr);
      }
    } else {
      for (c = 1; c <= len; c++) {
        ptr = MALLOCPOOLAC;
        ptr->inst = gl_fetch(rhsinstlist,c);
        ptr->name.str = FetchStrMember(sip,c);
        gl_append_ptr(*rhslist,(VOIDPTR)ptr);
      }
    }
    return result;
  } else {
    /* cook up the users list */
    assert(GetEvaluationContext()==NULL);
    SetEvaluationContext(inst);
    subslist = EvaluateSet(setp,InstanceEvaluateName);
    SetEvaluationContext(NULL);
    /* check that it evaluates */
    if (ValueKind(subslist)==error_value) {
      switch(ErrorValue(subslist)) {
      case name_unfound:
      case undefined_value:
        DestroyValue(&subslist);
        WriteUnexecutedMessage(ASCERR,statement,
          "Undefined values in WITH_VALUE () list");
        return CreateErrorValue(undefined_value);
      default:
        STATEMENT_ERROR(statement,"Bad result in evaluating WITH_VALUE list\n");
        MarkStatContext(statement,context_WRONG);
        WSS(ASCERR,statement);
        DestroyValue(&subslist);
      }
    }
    /* collect sets to assign later */
    result = CreateSetFromList(subslist); /* unique list */
    ListMode=1;
    subscripts = CreateOrderedSetFromList(subslist); /* as ordered to insts */
    ListMode=0;
    DestroyValue(&subslist); /* done with it */
    /* check everything dumb that can happen */
    if ( ValueKind(result) != set_value ||
         Cardinality(SetValue(subscripts)) != Cardinality(SetValue(result))
       ) {
      DestroyValue(&result);
      DestroyValue(&subscripts);
      STATEMENT_ERROR(statement,
        "WITH_VALUE list does not form a proper subscript set.\n");
      MarkStatContext(statement,context_WRONG);
      WSS(ASCERR,statement);
      return CreateErrorValue(type_conflict);
    }
    /* check sanity of values. may need fixing around empty set. */
    if ( (SetKind(SetValue(subscripts))==integer_set) != (intset!=0)) {
      STATEMENT_ERROR(statement,
        "Unable to construct set. Values and set type mismatched\n");
      DestroyValue(&result);
      DestroyValue(&subscripts);
      MarkStatContext(statement,context_WRONG);
      WSS(ASCERR,statement);
      return CreateErrorValue(type_conflict);
    }
    /* check set size == instances to alias */
    if (Cardinality(SetValue(subscripts)) != len) {
      STATEMENT_ERROR(statement,"In: ");
      FPRINTF(ASCERR,
        "WITH_VALUE list length (%lu) != number of instances given (%lu)\n",
        Cardinality(SetValue(subscripts)),len);
      DestroyValue(&result);
      DestroyValue(&subscripts);
      MarkStatContext(statement,context_WRONG);
      WSS(ASCERR,statement);
      return CreateErrorValue(type_conflict);
    }
    /* fill up rhslist and return */
    *rhslist = gl_create(len);
    sip = SetValue(subscripts);
    if (intset != 0) {
      for (c = 1; c <= len; c++) {
        ptr = MALLOCPOOLAC;
        ptr->inst = gl_fetch(rhsinstlist,c);
        ptr->name.index = FetchIntMember(sip,c);
        gl_append_ptr(*rhslist,(VOIDPTR)ptr);
      }
    } else {
      for (c = 1; c <= len; c++) {
        ptr = MALLOCPOOLAC;
        ptr->inst = gl_fetch(rhsinstlist,c);
        ptr->name.str = FetchStrMember(sip,c);
        gl_append_ptr(*rhslist,(VOIDPTR)ptr);
      }
    }
    DestroyValue(&subscripts);
    return result;
  }
}

/**
    @return 1 if concluded with statement, 0 if might try later.
*/
static
int ExecuteARR(struct Instance *inst, struct Statement *statement)
{
  CONST struct VariableList *vlist;
  struct gl_list_t *rhsinstlist; /* list of instances found to alias */
  struct gl_list_t *setinstl; /* instance found searching for IS_A'd set */
  struct gl_list_t *rhslist=NULL; /* list of arraychild structures */
  struct value_t subsset;
#ifndef NDEBUG
  struct Instance *rhsinst;
#endif
  struct Instance *setinst;
  enum find_errors ferr;
  CONST struct TypeDescription *basedef;
  ChildListPtr icl;
  int intset;

  assert(StatementType(statement)==ARR);
  if (StatWrong(statement)) {
    /* incorrect statements should be warned about when they are
     * marked wrong, so we just ignore them here.
     */
    return 1;
  }
  if (!CheckARR(inst,statement)) {
    WriteUnexecutedMessage(ASCERR,statement,
      "Possibly undefined instances/sets/ranges in ALIASES-IS_A statement.");
    return 0;
  }
  rhsinstlist = FindInsts(inst,GetStatVarList(statement),&ferr);
  if (rhsinstlist == NULL) {
    MissingInsts(inst,GetStatVarList(statement),0);
    WriteUnexecutedMessage(ASCERR,statement,
      "Incompletely defined source instance list in ALIASES-IS_A statement.");
    return 0; /* rhs's not compiled yet */
  }
  /* check for illegal rhs types. parser normally bars this. */
#ifndef NDEBUG
  if (gl_length(rhsinstlist) >0) {
    rhsinst = (struct Instance *)gl_fetch(rhsinstlist,1);
    if (BaseTypeIsEquation(InstanceTypeDesc(rhsinst))) {
      STATEMENT_ERROR(statement,
        "Direct ALIASES of rels/lrels/whens are not permitted");
      MarkStatContext(statement,context_WRONG);
      WSS(ASCERR,statement);
      gl_destroy(rhsinstlist);
      return 1; /* (log)relations/whens only aliased through models */
    }
  }
#endif
  /* evaluate name list, if given, OTHERWISE generate it, and check CARD.
   * issues warnings as needed
   */
  subsset = ComputeArrayElements(inst,statement,rhsinstlist,&rhslist);
  gl_destroy(rhsinstlist);
  /* check return values of subsset and rhslist here */
  if (ValueKind(subsset)== error_value) {
    if (ErrorValue(subsset) == undefined_value) {
      DestroyValue(&subsset);
      return 0;
    } else {
      DestroyValue(&subsset);
      return 1;
    }
  }
  assert(rhslist!=NULL); /* might be empty, but not NULL */
  /* make set ATOM */
  vlist = ArrayStatSetName(statement);
  intset = ArrayStatIntSet(statement);
  MakeInstance(NamePointer(vlist),FindSetType(),intset,inst,statement,NULL);
  /* get instance  and assign. */
  setinstl = FindInstances(inst,NamePointer(vlist),&ferr);
  if (setinstl == NULL || gl_length(setinstl) != 1L) {
    FPRINTF(ASCERR,"Unable to construct set.\n");
    FPRINTF(ASCERR,"Bizarre error in ALIASES-IS_A. Please report it to:\n%s",
      ASC_BIG_BUGMAIL);
    if (setinstl!=NULL) {
      gl_destroy(setinstl);
    }
    DestroyArrayElements(rhslist);
    DestroyValue(&subsset);
    MarkStatContext(statement,context_WRONG);
    WSS(ASCERR,statement);
    /* should nuke entire compound ALIASES/IS_A array pair already built */
    return 1;
  } else {
    setinst = (struct Instance *)gl_fetch(setinstl,1);
    gl_destroy(setinstl);
    AssignSetAtomList(setinst,CopySet(SetValue(subsset)));
    DestroyValue(&subsset);
  }

  /* create  ALIASES-IS_A array */
  /* recycle the local pointer to our set ATOM to check base type of rhslist */
  setinst = CAC(gl_fetch(rhslist,1))->inst;
  intset = ( InstanceKind(setinst)==SET_ATOM_INST &&
             IntegerSetInstance(setinst)!=0 );
  /* the real question is does anyone downstream care if intset correct?
   * probably not since its an alias anyway.
   */
  vlist = ArrayStatAvlNames(statement);
  icl = GetChildList(InstanceTypeDesc(inst));
  basedef = ChildBaseTypePtr(icl,ChildPos(icl,NameIdPtr(NamePointer(vlist))));
  while (vlist!=NULL){
    /* fix me for sparse case. dense ok. */
    MakeAliasInstance(NamePointer(vlist), basedef,NULL,
                      rhslist, intset, inst, statement);
    vlist = NextVariableNode(vlist);
  }
  /* clean up memory */
  DestroyArrayElements(rhslist);

  return 1;
}

/*------------------------------------------------------------------------------
    ...
*/
/**
    Makes a single instance of the type given,which must not be array
    or relation of any kind or when.

    If type is a MODEL, adds the MODEL to pending list.

    The argument intset is only used if type is set, then
    if intset==1, set ATOM made will be integer set.

    Attempts to find a UNIVERSAL before making the instance.

    @param statement only used for error messages.
*/
static
struct Instance *MakeSimpleInstance(struct TypeDescription *def,
                                    int intset,
                                    struct Statement *statement,
                                    struct Instance *arginst)
{
  struct Instance *inst;

  inst = ShortCutMakeUniversalInstance(def);
  if (inst==NULL) {
    switch(GetBaseType(def)){
    case model_type:
      inst = CreateModelInstance(def);  /* if we are here - build one */
      if (!GetUniversalFlag(def)||!InstanceInList(inst)) {
        /* add PENDING model if not UNIVERSAL, or UNIVERSAL and
         * this is the very first time seen - don't ever want an instance
         * in the pending list twice.
         */
        /*
         * here we need to shuffle in info from arginst.
         * note that because this is inside the UNIVERSAL check,
         * only the first set of arguments to a UNIVERSAL type will
         * ever apply.
         */
        ConfigureInstFromArgs(inst,arginst);
        AddBelow(NULL,inst);
      }
      break;
    case real_type:
    case real_constant_type:
      inst = CreateRealInstance(def);
      break;
    case boolean_type:
    case boolean_constant_type:
      inst = CreateBooleanInstance(def);
      break;
    case integer_type:
    case integer_constant_type:
      inst = CreateIntegerInstance(def);
      break;
    case set_type:
      inst = CreateSetInstance(def,intset);
      break;
    case symbol_type:
    case symbol_constant_type:
      inst = CreateSymbolInstance(def);
      break;
    case relation_type:
      inst = NULL;
      FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n",
              SCP(GetBaseTypeName(relation_type)));
    case logrel_type:
      inst = NULL;
      FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n",
              SCP(GetBaseTypeName(logrel_type)));
      break;
    case when_type:
      inst = NULL;
      FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n",
              SCP(GetBaseTypeName(when_type)));
      break;
    case array_type:
    default: /* picks up patch_type */
      STATEMENT_ERROR(statement, "MakeSimpleInstance error. PATCH/ARRAY found.\n");
      Asc_Panic(2, NULL,  "MakeSimpleInstance error. PATCH/ARRAY found.\n");
    }
  }
  return inst;
}

static unsigned long g_unasscon_count = 0L;
/* counter for the following functions */
static
void CountUnassignedConst(struct Instance *i)
{
  if (i!=NULL && (IsConstantInstance(i) || InstanceKind(i)==SET_ATOM_INST) ) {
    if (AtomAssigned(i)==0) {
      g_unasscon_count++;
    }
  }
}
/**
    Returns 0 if all constant scalars in ipass are assigned,
    for ipass that are of set/scalar array/scalar type.
    Handles null input gracefully, as if there is something
    unassigned in it.
    Variable types are considered permanently assigned, since
    we are checking for constants being unassigned.
    Assumes arrays, if passed in, are fully expanded.
*/
static
int ArgValuesUnassigned(struct Instance *ipass)
{
  struct TypeDescription *abd;
  if (ipass==NULL) return 1;
  switch (InstanceKind(ipass)) {
  case ERROR_INST:
   return 1;
  case SIM_INST:
  case MODEL_INST:
  case REL_INST:
  case LREL_INST:
  case WHEN_INST:
    return 0;
  case ARRAY_INT_INST:
  case ARRAY_ENUM_INST:
    abd = GetArrayBaseType(InstanceTypeDesc(ipass));
    if (BaseTypeIsConstant(abd)==0 && BaseTypeIsSet(abd)==0) {
      return 0;
    }
    g_unasscon_count = 0;
    SilentVisitInstanceTree(ipass,CountUnassignedConst,0,0);
    if (g_unasscon_count != 0) {
      return 1;
    } else {
      return 0;
    }
  case REAL_INST:
  case INTEGER_INST:
  case BOOLEAN_INST:
  case SYMBOL_INST:
  case SET_INST:
  case REAL_ATOM_INST:
  case INTEGER_ATOM_INST:
  case BOOLEAN_ATOM_INST:
  case SYMBOL_ATOM_INST:
    return 0;
  case SET_ATOM_INST:
  case REAL_CONSTANT_INST:
  case BOOLEAN_CONSTANT_INST:
  case INTEGER_CONSTANT_INST:
  case SYMBOL_CONSTANT_INST:
    return (AtomAssigned(ipass)==0); /* return 0 if assigned, 1 not */
  default:
    return 1; /* NOTREACHED */
  }
}
/**
    Appends the pointers in the set chain s
    into the list given args. args must not be NULL unless s is.

    If needed, args will be expanded, but if you know the length
    to expect, make args of that size before calling and this
    will be faster.
    
    This does not go into the expressions (which may contain other
    sets themselves) of the set nodes and disassemble them.
    The list may be safely destroyed, but its contents should not
    be destroyed with it as they belong to something else in all
    likelihood.
    
    @TODO This function should be moved into a set header someplace.
*/
static
void SplitArgumentSet(CONST struct Set *s, struct gl_list_t *args)
{
  struct Set *sp;
  if (s==NULL) return;
  assert(args !=NULL); /* debug WriteSet(ASCERR,s); FPRINTF(ASCERR,"\n"); */
  while (s!=NULL) {
    sp = CopySetNode(s);
    gl_append_ptr(args,(VOIDPTR)sp);
    s = NextSet(s);
  }
}

#define GETARG(l,n) ((struct Set *)gl_fetch((l),(n)))

/**
    Check compatibility of array elements? -- JP

    @return 1 if all ok, 0 if any array child is < type required,
        -1 if some array child is type incompatible with ptype/stype.

    Does some optimization around arrays of sets and array basetypes.
    Doesn't check names.
*/
static
int ArrayElementsTypeCompatible(CONST struct Instance *ipass,
                                CONST struct TypeDescription *ptype,
                                symchar *stype)
{
  struct gl_list_t *achildren=NULL;
  CONST struct TypeDescription *atype;
  CONST struct TypeDescription *mrtype;
  unsigned long c,len,lessrefined=0L;
  struct Instance *i;

  if (ipass==NULL || ptype == NULL) {
    return -1; /* hosed input */
  }
  assert(IsArrayInstance(ipass) != 0);
  atype = GetArrayBaseType(InstanceTypeDesc(ipass));
  if (BaseTypeIsSet(atype)==0 && MoreRefined(atype,ptype)==atype) {
      /* if not set and if array base is good enough */
    return 1;
  }
  achildren = CollectArrayInstances(ipass,NULL);
  len = gl_length(achildren);
  for (c = 1; c <= len; c++) {
    i = (struct Instance *)gl_fetch(achildren,c);
    atype = InstanceTypeDesc(i);
    if (InstanceKind(i) == SET_ATOM_INST) {
      /* both should be of same type "set" */
      if (atype!=ptype ||
          (IntegerSetInstance(i)==0 &&
           stype == GetBaseTypeName(integer_constant_type))
          || (IntegerSetInstance(i)==1 &&
              stype == GetBaseTypeName(symbol_constant_type))
         ) {
        /* set type mismatch */
        gl_destroy(achildren);
        return -1;
      } else {
        /* assumption about arrays of sets being sane, if 1 element is. */
        gl_destroy(achildren);
        return 1;
      }
    }
    if (ptype==atype) {
      continue;
    }
    mrtype = MoreRefined(ptype,atype);
    if (mrtype == NULL) {
      gl_destroy(achildren);
      return -1;
    }
    if (mrtype == ptype) {
      lessrefined++;
    }
  }
  gl_destroy(achildren);
  return (lessrefined==0L); /* if any elements are inadequately refined, 0 */
}

/**
    returns a value_t, but the real result is learned by consulting err.
    err == 0 means some interesting value found.
    err == 1 means try again later
    err == -1 means things are hopeless.
*/
static
struct value_t FindArgValue(struct Instance *parent,
                            struct Set *argset,
                            int *err)
{
  int previous_context;
  struct value_t value;

  assert(err!=NULL);
  *err=0;
  previous_context = GetDeclarativeContext();
  SetDeclarativeContext(0);
  assert(GetEvaluationContext()==NULL);
  SetEvaluationContext(parent);
  value = EvaluateExpr(GetSingleExpr(argset),
                       NULL,
                       InstanceEvaluateName);
  SetEvaluationContext(NULL);
  SetDeclarativeContext(previous_context);
  if (ValueKind(value)==error_value) {
    switch(ErrorValue(value)){
    case name_unfound:
      *err = 1;
      DestroyValue(&value);
      return CreateErrorValue(undefined_value);
    case undefined_value:
      *err = 1;
      return value;
    default:
      *err = -1;
    }
  }
  if (IsConstantValue(value)==0){
    *err = -1;
    DestroyValue(&value);
    return CreateErrorValue(type_conflict);
  }
  return value;
}

/* return codes and message handling for MakeParameterInst */
#define MPIOK 1
#define MPIWAIT 0
#define MPIINPUT -1
#define MPIARGTYPE -2
#define MPIARRINC -3
#define MPIBADASS -4
#define MPIARRRNG -5
#define MPIINSMEM -6
#define MPIBADARG -7
#define MPIMULTI -8
#define MPIBADVAL -9
#define MPIWEIRD -10
#define MPIUNMADE -11
#define MPIWEAKTYPE -12
#define MPIUNASSD -13
#define MPIARGVAL -14
#define MPIARGSIZ -15
#define MPIBADWBTS -16
#define MPIBADWNBTS -17
#define MPIBADMERGE -18
#define MPIREASGN -19
#define MPIREDEF -20
#define MPIFOR -21
#define MPIBADREL -22
#define MPIEXCEP -23
#define MPIVARREL -24
#define MPINOTBOOL -25
static
char *g_mpi_message[] = {
/* 0 */  "Nothing wrong with parameter",
/* -1 */ "Bad input statement or parent or arginstptr.",
/* -2 */ "Incompatible argument type.",
/* -3 */ "Incomplete assignment of absorbed pass-by-value array.",
/* -4 */ "Error in absorbed assignment RHS.",
/* -5 */ "Mismatch in range of array subscripts.",
/* -6 */ "Insufficient memory - crashing soon",
/* -7 */ "Nonexistent argument. (bad set in array expression, probably)",
/* -8 */ "Too many instances named for 1 parameter slot",
/* -9 */ "Bad expression passed to IS_A",
/* -10 */ "Something rotten in lint",
/* -11 */ "Instance doesn't yet exist",
/* -12 */ "Instance not sufficiently refined",
/* -13 */ "Argument value not assigned",
/* -14 */ "Argument value != required value",
/* -15 */ "Array object given has with too many/too few subscripts.",
/* -16 */ "Incorrect instance named in WILL_BE_THE_SAME.",
/* -17 */ "Nonexistent instance named in WILL_NOT_BE_THE_SAME.",
/* -18 */ "Merged instances found in WILL_NOT_BE_THE_SAME.",
/* -19 */ "Refinement cannot reassign constant value.",
/* -20 */ "Refinement must pass in same objects used in IS_A.",
/* -21 */ "Improper FOR loop in WHERE statements",
/* -22 */ "WHERE condition unsatisfied",
/* -23 */ "WHERE condition incorrect (system exception occurred)",
/* -24 */ "WHERE condition incorrect (nonconstant value)",
/* -25 */ "WHERE condition incorrect (nonboolean value)"
};

/**
    Returns MPIOK if value in ipass matches WITH_VALUE field of
    statement, or if the test is silly beacause ipass isn't
    a set/constant or if statement does not constrain value.
    Returns MPIWAIT if statement truth cannot be tested because
    WITH_VALUE clause is not yet evaluatable.
    Returns MPIARGVAL if WITH_VALUE is provably unsatisfied.
    On truly garbage input, unlikely to return.
*/
static
int ArgValueCorrect(struct Instance *inst,
                    struct Instance *tmpinst,
                    CONST struct Statement *statement)
{
  CONST struct Expr *check;
  int previous_context;
  struct value_t value;

  assert (inst!=NULL);
  assert (tmpinst!=NULL);
  assert (statement!=NULL);

  if ( StatementType(statement)!= WILLBE ||
       (check = GetStatCheckValue(statement)) == NULL ||
       ( IsConstantInstance(inst) ==0 &&
         InstanceKind(inst) != SET_ATOM_INST)
     ) {
    return MPIOK;
  }
  if (!AtomAssigned(inst)) {
    return MPIWAIT;
  }
  previous_context = GetDeclarativeContext();
  SetDeclarativeContext(0);
  assert(GetEvaluationContext()==NULL);
  SetEvaluationContext(tmpinst);
  value = EvaluateExpr(check, NULL, InstanceEvaluateName);
  SetEvaluationContext(NULL);
  SetDeclarativeContext(previous_context);
  if (ValueKind(value)==error_value) {
    switch(ErrorValue(value)){
    case name_unfound:
    case undefined_value:
      DestroyValue(&value);
      return MPIWAIT;
    default:
      DestroyValue(&value);
      return MPIARGVAL;
    }
  }
  if (IsConstantValue(value)==0){
    DestroyValue(&value);
    FPRINTF(ASCERR,"Variable value found where constant required\n");
    return MPIARGVAL;
  }
  /* ok, so we have a reasonable inst type and a constant value */
  switch(InstanceKind(inst)){
  case REAL_CONSTANT_INST:
    switch(ValueKind(value)){
    case real_value:
      if ( ( RealValue(value) != RealAtomValue(inst) ||
             !SameDimen(RealValueDimensions(value),RealAtomDims(inst)) )
         ) {
        DestroyValue(&value);
        return MPIARGVAL;
      }
      break;
    case integer_value:
      if ( ( (double)IntegerValue(value) != RealAtomValue(inst) ||
             !SameDimen(Dimensionless(),RealAtomDims(inst)) )
         ) {
        DestroyValue(&value);
        return MPIARGVAL;
      }
      break;
    default:
      DestroyValue(&value);
      return MPIARGVAL;
    }
    break;
  case BOOLEAN_CONSTANT_INST:
    if (ValueKind(value)!=boolean_value ||
        BooleanValue(value) != GetBooleanAtomValue(inst) ) {
      DestroyValue(&value);
      return MPIARGVAL;
    }
    break;
  case INTEGER_CONSTANT_INST:
    switch(ValueKind(value)){
    case integer_value:
      if (GetIntegerAtomValue(inst)!=IntegerValue(value)) {
        DestroyValue(&value);
        return MPIARGVAL;
      }
      break;
    case real_value: /* case which is parser artifact: real, wild 0 */
      if ( RealValue(value)==0.0 &&
           IsWild(RealValueDimensions(value)) &&
           GetIntegerAtomValue(inst) != 0) {
        DestroyValue(&value);
        return MPIARGVAL;
      }
      break;
    default:
      DestroyValue(&value);
      return MPIARGVAL;
    }
    break;
  case SET_ATOM_INST:
    if (ValueKind(value)!=set_value ||
        !SetsEqual(SetValue(value),SetAtomList(inst))) {
      DestroyValue(&value);
      return MPIARGVAL;
    }
    break;
  case SYMBOL_CONSTANT_INST:
    if (ValueKind(value) != symbol_value ||
         SymbolValue(value) != GetSymbolAtomValue(inst)) {
      assert(AscFindSymbol(SymbolValue(value))!=NULL);
      DestroyValue(&value);
      return MPIARGVAL;
    }
    break;
  default:
    DestroyValue(&value);
    return MPIARGVAL;
  }
  DestroyValue(&value);
  return MPIOK;
}

/**
    evaluate a logical or real relation and see that it is satisfied.
    
    @BUG baa. needs to be exception safe and is not.

    returns MPIOK (satisfied)
    returns MPIBADREL (dissatisified)
    returns MPIVARREL (dissatisified - variable result)
    returns MPIWAIT (not yet determinable)
    returns MPIEXCEP (evaluation is impossible due to float/other error)
    returns MPINOTBOOL (dissatisfied- nonboolean result)
    
    @param statement should be a rel or logrel.
*/
static
int MPICheckConstraint(struct Instance *tmpinst, struct Statement *statement)
{
  struct value_t value;

  IVAL(value);

  assert(GetEvaluationContext()==NULL);
  SetEvaluationContext(tmpinst);
  switch (StatementType(statement)){
  case REL:
    value = EvaluateExpr(RelationStatExpr(statement),NULL,
                         InstanceEvaluateName);
    break;
  case LOGREL:
    value = EvaluateExpr(LogicalRelStatExpr(statement),NULL,
                         InstanceEvaluateName);
    break;
  default:
    SetEvaluationContext(NULL);
    return MPIWEIRD;
  }
  SetEvaluationContext(NULL);
  switch (ValueKind(value)){
  case error_value:
    switch(ErrorValue(value)){
    case undefined_value:
      DestroyValue(&value);
      WriteUnexecutedMessage(ASCERR,statement,
        "Incomplete expression (value undefined) in argument condition.");
      return MPIWAIT;
    case name_unfound:
      DestroyValue(&value);
      WriteUnexecutedMessage(ASCERR,statement,
        "Incomplete expression (name unfound) in argument condition.");
      return MPIWAIT;
    default:
      /* it questionable whether this is a correct action in all cases*/
      /* we could probably turn out more useful error messages here */
      STATEMENT_ERROR(statement, "Condition doesn't make sense.");
      DestroyValue(&value);
      return MPIBADREL;
    }
  case boolean_value:
    if (IsConstantValue(value)!=0) {
      if (BooleanValue(value) != FALSE) {
        DestroyValue(&value);
        return MPIOK;
      } else {
        DestroyValue(&value);
        STATEMENT_ERROR(statement, "Arguments do not conform to requirements");
        return MPIBADREL;
      }
    } else {
      DestroyValue(&value);
      STATEMENT_ERROR(statement, "Requirements cannot be satisfied by variables");
      return MPIVARREL;
    }
  default:
    DestroyValue(&value);
    STATEMENT_ERROR(statement, "Constraint does not evaluate to boolean result.");
    return MPINOTBOOL;
  }
}

/**
    returns MPIOK if subscripts match declarations,
    MPIWAIT if declarations cannot yet be interpretted,
    or some other error if there is a mismatch.

    So far only the square version. Should have a forvar
    capable recursive version sometime when we allow
    passage of sparse arrays.

    Assumes the array given has proper number of
    subscripts to match name and is fully expanded.
*/
static
int MPICheckSubscripts(struct Instance *tmpinst,
                       struct Instance *aryinst,
                       struct Statement *s)
{
  CONST struct Name *nptr;

  nptr = NextName(NamePointer(GetStatVarList(s)));
  switch (RectangleSubscriptsMatch(tmpinst,aryinst,nptr)) {
  case -2:
    return MPIWAIT;
  case 1:
    return MPIOK;
  case 0:
  default:
    return MPIARRRNG;
  }
}

#define NOIPICHECK 0
#define IPICHECK 1
/**
    links parent and child. if checkdup != 0,
    it will check child to see if it already has this parent.
*/
static
int InsertParameterInst(struct Instance *parent,
                        struct Instance *child,
                        CONST struct Name *name,
                        CONST struct Statement *statement,
                        int checkdup)
{
  symchar *childname;
  struct InstanceName rec;
  unsigned long pos;

  childname = NameIdPtr(name);
  SetInstanceNameType(rec,StrName);
  SetInstanceNameStrPtr(rec,childname);
  pos = ChildSearch(parent,&rec);
  if (pos>0) {
    if (InstanceChild(parent,pos)==NULL) {
      StoreChildPtr(parent,pos,child);
      if (checkdup == 0 || SearchForParent(child,parent)==0) {
          /* case where we don't already have it at this scope */
        AddParent(child,parent);
      }
      return 1;
    } else {            /* redefining instance */
      char *msg = ASC_NEW_ARRAY(char,SCLEN(childname)+strlen(REDEFINE_CHILD_MESG)+1);
      strcpy(msg,REDEFINE_CHILD_MESG);
      strcat(msg,SCP(childname));
      STATEMENT_ERROR(statement,msg);
      ascfree(msg);
      return 0;
    }
  } else {          /* unknown name */
    STATEMENT_ERROR(statement, "Unknown parameter name.  Never should happen");
    Asc_Panic(2, NULL, "Unknown parameter name.  Never should happen");
    
  }
}

/**
    The instance this is called with should not have
    any parents whatsoever. The instance this is called
    with will be completely destroyed including any parts
    of the instance that do not have other parents.
*/
static
void DestroyParameterInst(struct Instance *i)
{
  DestroyInstance(i,NULL);
}

/** 
    destroys everything you send it. If you send some arguments in
    as null, we don't mind.
*/
static
void ClearMPImem(
  struct gl_list_t *args,
  struct gl_list_t *il,
  struct Instance *tmpinst,
  struct Instance *ipass,
  struct value_t *valp
)
{
  if (args!=NULL) {
    gl_iterate(args,(void (*)(VOIDPTR))DestroySetNode);
    gl_destroy(args);
  }
  if (il!=NULL) {
    gl_destroy(il);
  }
  if (tmpinst!=NULL) {
    DestroyParameterInst(tmpinst);
  }
  if (ipass!=NULL) {
    DestroyParameterInst(ipass);
  }
  if (valp!=NULL) {
    DestroyValue(valp);
  }
}

/**
     What is MPI? parallel computing stuff?? -- JP
*/
static
void mpierror(struct Set *argset,
              unsigned long argn,
              struct Statement *statement,
              int errcode)
{
  int arrloc;
  if (errcode<0) {
    arrloc = (-errcode);
  } else {
    return;
    /* why are we here? */
  }
  FPRINTF(ASCERR,"Parameter passing error: %s\n",g_mpi_message[arrloc]);
  if (argset !=NULL && argn >0) {
    FPRINTF(ASCERR,"  Argument %lu:",argn);
    WriteSet(ASCERR,argset);
    FPRINTF(ASCERR,"\n");
  }
  STATEMENT_ERROR(statement,"Error in executing statement:");
  MarkStatContext(statement,context_WRONG);
  WSS(ASCERR,statement);
}

static
void MPIwum(struct Set *argset,
            unsigned long argn,
            struct Statement *statement,
            int msgcode)
{
  int arrloc;
  if (g_iteration < MAXNUMBER) {
    return;
  }
  if (msgcode<0) {
    arrloc = (-msgcode);
  } else {
    return;
    /* why are we here? */
  }
  FPRINTF(ASCERR,"Parameter list waiting on sufficient type or value of:\n");
  if (argset !=NULL && argn >0) {
    FPRINTF(ASCERR,"  Argument %lu:",argn);
    WriteSetNode(ASCERR,argset);
    FPRINTF(ASCERR,"\n");
  }
  WriteUnexecutedMessage(ASCERR,statement,g_mpi_message[arrloc]);
}

/**
    process pass by value scalar: evaluate and make it, or return
    appropriate whine if not possible.
    If this returns anything other than mpiok, the user may
    wish to dispose of tmpinst, args as we do not here.
    We do issue whines here, however.
*/
static
int MPIMakeSimple(struct Instance *parent,
                  struct Instance *tmpinst,
                  struct Set *argset,
                  unsigned long argn,
                  CONST struct Name *nptr,
                  struct TypeDescription *ptype,
                  int intset,
                  struct Statement *ps,
                  struct Statement *statement
)
{
  int tverr;    /* error return from checking array elt type, or value */
  struct Instance *ipass;
  struct value_t vpass;

  vpass = FindArgValue(parent,argset,&tverr);
  if (tverr != 0) {
    if (tverr == 1) { /* try later */
      MPIwum(argset,argn,statement,MPIUNASSD);
      return MPIWAIT;
    } else { /* hopeless */
      mpierror(argset,argn,statement,MPIBADVAL);
      return MPIBADVAL;
    }
  }
  /* don't forget to dispose of vpass if exiting err after here */
  ipass = MakeSimpleInstance(ptype,intset,ps,NULL);
  if (ipass==NULL) {
    DestroyValue(&vpass);
    return MPIINSMEM;
  }
  /* don't forget to dispose of vpass if exiting err after here */
  if (AssignStructuralValue(ipass,vpass,statement)!=1) {
    mpierror(argset,argn,statement,MPIARGTYPE);
    DestroyParameterInst(ipass);
    DestroyValue(&vpass);
    return MPIARGTYPE;
  }
  DestroyValue(&vpass);
  /* install ipass in tmpinst */
  if ( InsertParameterInst(tmpinst,ipass,nptr,ps,IPICHECK) != 1) {
    /* noipicheck because var just created has no parents at all,
     * unless of course var is UNIVERSAL... so ipicheck */
    mpierror(argset,argn,statement,MPIMULTI);
    DestroyParameterInst(ipass);
    return MPIMULTI;
  }
  return MPIOK;
}
#define NOKEEPARGINST 0
#define KEEPARGINST 1
/**
    Check and assemble the arguments of the parameterized type referenced in
    statement, using information derived from the parent instance.

    If the type found in the statement given is not a MODEL type,
    we will immediately return 1 and *arginstptr will be set NULL.

    In general, we are trying to check and assemble enough information
    to prove that a parameterized IS_A can be executed or proved wrong
    once ExecuteISA sees it.

    If keepargs ==KEEPARGINST, then on a successful return,
    *arginstptr will be to a MODEL instance (with no parents)
    with its children derived via parameter list filled in and
    all other children NULL.
    If there are NO children derived via parameter list or
    the reductions list, then *arginstptr will be NULL.
    If keepargs != KEEPARGINST, then arginstptr will not be
    used/set in any way, OTHERWISE it should be NULL on entry.
    If keepargs != KEEPARGINST, then we will do only the minimal
    necessary work to check that the arginst could be created.
    At present, we can't tell what this last ambition amounts to -
    we do the same amount of work regardless, though we try to put
    the more likely to fail steps first.

    A successful return value is 1.
    
    A failure possibly to succeed later is 0.
    Possible causes will be detailed via the WriteUnexecutedMessage
    facility.

    A permanent failure is any value < 0.
    Causes will be detailed via the WSEM facility, in addition return
    values < 0 have the interpretations given in g_mpi_message[-value]
    above.
    
    @NOTE assumes statement is well formed, in terms of
    arglist of IS_A/IS_REFINED_TO (if there is one) being of correct length.
    returns fairly quickly for nonmodel and nonparametric
    MODEL types.
*/
static
int MakeParameterInst(struct Instance *parent,
                      struct Statement *statement,
                      struct Instance **arginstptr,
                      int keepargs)
{
  struct TypeDescription *d; /* the type we are constructing or checking */
  struct TypeDescription *atype; /* the type we are being passed */
  struct TypeDescription *ptype; /* the type we are expecting */
  struct TypeDescription *mrtype; /* the more refined of two types */
  symchar *stype;       /* the set type we are expecting */
  struct gl_list_t *args; /* parameter Set given split for easy access */
  struct gl_list_t *il;   /* instance(s) required to digest a parameter */
  struct Instance *ipass; /* instance being passed into type */
  struct Instance *tmpinst; /* holding instance for derivation work. */
  struct StatementList *psl; /* list of parameters the type requires */
  struct StatementList *absorbed; /* list of absorbed isas and casgns */
  struct Statement *ps;      /* a statement from psl */
  struct Set *argset;       /* set element extracted from arglist */
  CONST struct VariableList *vl;
  struct for_table_t *SavedForTable;
  unsigned long slen,c,argn;
  int tverr;    /* error return from checking array elt type, or value */
  int suberr;   /* error return from other routine */
  int intset;
  enum find_errors ferr;
  unsigned int pc;       /* number of parameters the type requires */

  if (StatWrong(statement)) {
    /* incorrect statements should be warned about when they are
     * marked wrong, so we just ignore them here.
     */
    return MPIOK;
  }
  d = FindType(GetStatType(statement));
  if (d==NULL) {
    /* lint should make this impossible */
    mpierror(NULL,0L,statement,MPIINPUT);
    return MPIINPUT;
  }
  if (keepargs == KEEPARGINST && arginstptr == NULL) {
    /* someone screwed up the call, but maybe they get it right later. */
    FPRINTF(ASCERR," *** MakeParameterInst miscalled *** \n");
    return MPIWAIT;
  }
  if (keepargs == KEEPARGINST) {
    /* init arginstptr */
    *arginstptr = NULL;
  }
  if ( GetBaseType(d)!=model_type) {
    return MPIOK;
  }
  pc = GetModelParameterCount(d);
  absorbed = GetModelAbsorbedParameters(d);
  if (pc==0 && StatementListLength(absorbed)==0L) {
    /* no parameters in this type or its ancestors */
    return MPIOK;
  }
  /* init tmpinst, which we must remember to punt before
   * error returns or nokeep returns.
   */
  /* may want an SCMUI here, not sure. */
  tmpinst = CreateModelInstance(d);
  if (tmpinst==NULL) {
    mpierror(NULL,0L,statement,MPIINPUT);
    return MPIINSMEM;
  }
  args = gl_create((unsigned long)pc);
  if (args == NULL) {
    mpierror(NULL,0L,statement,MPIINPUT);
    ClearMPImem(NULL,NULL,tmpinst,NULL,NULL);
    return MPIINSMEM;
  }
  SplitArgumentSet(GetStatTypeArgs(statement),args);
  /* due to typelint, the following assertion should pass. fix lint if not. */
  assert(gl_length(args)==(unsigned long)pc);
  psl = GetModelParameterList(d);
  slen = StatementListLength(psl);
  argn = 1L;
  for (c = 1; c <= slen; c++) {
    ps = GetStatement(psl,c);
    vl = GetStatVarList(ps); /* move inside switch if allow FOR later */
    ptype = FindType(GetStatType(ps));
    stype = GetStatSetType(ps);
    intset = CalcSetType(stype,ps);
    if (intset <0 || intset >1) {
      /* shouldn't be possible -- typelint trapped */
      mpierror(NULL,0L,statement,MPIARGTYPE);
      ClearMPImem(args,NULL,tmpinst,NULL,NULL);
      return MPIARGTYPE;
    }
    switch (StatementType(ps)) {
    case WILLBE:
      while (vl != NULL) {
        argset = GETARG(args,argn);
        il = FindArgInsts(parent,argset,&ferr);
        if (il == NULL) {
          switch(ferr) {
          case unmade_instance:
          case undefined_instance: /* this case ought to be separable */
            MPIwum(argset,argn,statement,MPIUNMADE);
            ClearMPImem(args,NULL,tmpinst,NULL,NULL);
            return MPIWAIT;
          case impossible_instance:
            mpierror(argset,argn,statement,MPIBADARG);
            ClearMPImem(args,NULL,tmpinst,NULL,NULL);
            return MPIBADARG;
          case correct_instance:
            mpierror(argset,argn,statement,MPIWEIRD);
            ClearMPImem(args,NULL,tmpinst,NULL,NULL);
            return MPIWEIRD;
          }
        }
        if (gl_length(il)!=1L) {
          mpierror(argset,