clips-sys 0.4.0

   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*            CLIPS Version 6.40  09/28/17             */
   /*                                                     */
   /*                                                     */
   /*******************************************************/

/*************************************************************/
/* Purpose: Query Functions for Objects                      */
/*                                                           */
/* Principal Programmer(s):                                  */
/*      Brian L. Dantes                                      */
/*                                                           */
/* Contributing Programmer(s):                               */
/*      Gary D. Riley                                        */
/*                                                           */
/* Revision History:                                         */
/*                                                           */
/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
/*                                                           */
/*            Corrected compilation errors for files         */
/*            generated by constructs-to-c. DR0861           */
/*                                                           */
/*      6.24: Renamed BOOLEAN macro type to intBool.         */
/*                                                           */
/*      6.30: Changed integer type/precision.                */
/*                                                           */
/*            Changed garbage collection algorithm.          */
/*                                                           */
/*            Added const qualifiers to remove C++           */
/*            deprecation warnings.                          */
/*                                                           */
/*      6.31: Retrieval for instance query slot function     */
/*            generates an error if the instance has been    */
/*            deleted.                                       */
/*                                                           */
/*            Functions delayed-do-for-all-instances and     */
/*            do-for-instance increment the busy count of    */
/*            matching instance sets so that actions can     */
/*            detect deleted instances.                      */
/*                                                           */
/*            Matching instance sets containing deleted      */
/*            instances are pruned.                          */
/*                                                           */
/*      6.40: Added Env prefix to GetEvaluationError and     */
/*            SetEvaluationError functions.                  */
/*                                                           */
/*            Pragma once and other inclusion changes.       */
/*                                                           */
/*            Added support for booleans with <stdbool.h>.   */
/*                                                           */
/*            Removed use of void pointers for specific      */
/*            data structures.                               */
/*                                                           */
/*            UDF redesign.                                  */
/*                                                           */
/*            Added GCBlockStart and GCBlockEnd functions    */
/*            for garbage collection blocks.                 */
/*                                                           */
/*            Eval support for run time and bload only.      */
/*                                                           */
/*************************************************************/

/* =========================================
   *****************************************
               EXTERNAL DEFINITIONS
   =========================================
   ***************************************** */
#include "setup.h"

#if INSTANCE_SET_QUERIES

#include "argacces.h"
#include "classcom.h"
#include "classfun.h"
#include "envrnmnt.h"
#include "exprnpsr.h"
#include "insfun.h"
#include "insmngr.h"
#include "insqypsr.h"
#include "memalloc.h"
#include "prcdrfun.h"
#include "prntutil.h"
#include "router.h"
#include "utility.h"

#include "insquery.h"

/***************************************/
/* LOCAL INTERNAL FUNCTION DEFINITIONS */
/***************************************/

   static void                    PushQueryCore(Environment *);
   static void                    PopQueryCore(Environment *);
   static QUERY_CORE             *FindQueryCore(Environment *,long long);
   static QUERY_CLASS            *DetermineQueryClasses(Environment *,Expression *,const char *,unsigned *);
   static QUERY_CLASS            *FormChain(Environment *,const char *,Defclass *,UDFValue *);
   static void                    DeleteQueryClasses(Environment *,QUERY_CLASS *);
   static bool                    TestForFirstInChain(Environment *,QUERY_CLASS *,unsigned);
   static bool                    TestForFirstInstanceInClass(Environment *,Defmodule *,int,Defclass *,QUERY_CLASS *,unsigned);
   static void                    TestEntireChain(Environment *,QUERY_CLASS *,unsigned);
   static void                    TestEntireClass(Environment *,Defmodule *,int,Defclass *,QUERY_CLASS *,unsigned);
   static void                    AddSolution(Environment *);
   static void                    PopQuerySoln(Environment *);

/****************************************************
  NAME         : SetupQuery
  DESCRIPTION  : Initializes instance query H/L
                   functions and parsers
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Sets up kernel functions and parsers
  NOTES        : None
 ****************************************************/
void SetupQuery(
  Environment *theEnv)
  {
   AllocateEnvironmentData(theEnv,INSTANCE_QUERY_DATA,sizeof(struct instanceQueryData),NULL);

#if ! RUN_TIME
   InstanceQueryData(theEnv)->QUERY_DELIMITER_SYMBOL = CreateSymbol(theEnv,QUERY_DELIMITER_STRING);
   IncrementLexemeCount(InstanceQueryData(theEnv)->QUERY_DELIMITER_SYMBOL);

   AddUDF(theEnv,"(query-instance)","n",0,UNBOUNDED,NULL,GetQueryInstance,"GetQueryInstance",NULL);

   AddUDF(theEnv,"(query-instance-slot)","*",0,UNBOUNDED,NULL,GetQueryInstanceSlot,"GetQueryInstanceSlot",NULL);

   AddUDF(theEnv,"any-instancep","b",0,UNBOUNDED,NULL,AnyInstances,"AnyInstances",NULL);

   AddUDF(theEnv,"find-instance","m",0,UNBOUNDED,NULL,QueryFindInstance,"QueryFindInstance",NULL);

   AddUDF(theEnv,"find-all-instances","m",0,UNBOUNDED,NULL,QueryFindAllInstances,"QueryFindAllInstances",NULL);

   AddUDF(theEnv,"do-for-instance","*",0,UNBOUNDED,NULL,QueryDoForInstance,"QueryDoForInstance",NULL);

   AddUDF(theEnv,"do-for-all-instances","*",0,UNBOUNDED,NULL,QueryDoForAllInstances,"QueryDoForAllInstances",NULL);

   AddUDF(theEnv,"delayed-do-for-all-instances","*",0,UNBOUNDED,NULL,DelayedQueryDoForAllInstances,"DelayedQueryDoForAllInstances",NULL);
#endif

   AddFunctionParser(theEnv,"any-instancep",ParseQueryNoAction);
   AddFunctionParser(theEnv,"find-instance",ParseQueryNoAction);
   AddFunctionParser(theEnv,"find-all-instances",ParseQueryNoAction);
   AddFunctionParser(theEnv,"do-for-instance",ParseQueryAction);
   AddFunctionParser(theEnv,"do-for-all-instances",ParseQueryAction);
   AddFunctionParser(theEnv,"delayed-do-for-all-instances",ParseQueryAction);
  }

/*************************************************************
  NAME         : GetQueryInstance
  DESCRIPTION  : Internal function for referring to instance
                    array on instance-queries
  INPUTS       : None
  RETURNS      : The name of the specified instance-set member
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : ((query-instance) <index>)
 *************************************************************/
void GetQueryInstance(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   QUERY_CORE *core;

   core = FindQueryCore(theEnv,GetFirstArgument()->integerValue->contents);
   returnValue->value = GetFullInstanceName(theEnv,core->solns[GetFirstArgument()->nextArg->integerValue->contents]);
  }

/***************************************************************************
  NAME         : GetQueryInstanceSlot
  DESCRIPTION  : Internal function for referring to slots of instances in
                    instance array on instance-queries
  INPUTS       : The caller's result buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Caller's result buffer set appropriately
  NOTES        : H/L Syntax : ((query-instance-slot) <index> <slot-name>)
 **************************************************************************/
void GetQueryInstanceSlot(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   Instance *ins;
   InstanceSlot *sp;
   UDFValue temp;
   QUERY_CORE *core;
   const char *varSlot;

   returnValue->lexemeValue = FalseSymbol(theEnv);

   core = FindQueryCore(theEnv,GetFirstArgument()->integerValue->contents);
   ins = core->solns[GetFirstArgument()->nextArg->integerValue->contents];
   varSlot = GetFirstArgument()->nextArg->nextArg->nextArg->lexemeValue->contents;

   /*=======================================*/
   /* Accessing the slot value of a deleted */
   /* instance generates an error.          */
   /*=======================================*/

   if (ins->garbage)
     {
      InstanceVarSlotErrorMessage1(theEnv,ins,varSlot);
      SetEvaluationError(theEnv,true);
      return;
     }
   
   EvaluateExpression(theEnv,GetFirstArgument()->nextArg->nextArg,&temp);
   if (temp.header->type != SYMBOL_TYPE)
     {
      InvalidVarSlotErrorMessage(theEnv,varSlot);
      SetEvaluationError(theEnv,true);
      return;
     }
   sp = FindInstanceSlot(theEnv,ins,temp.lexemeValue);
   if (sp == NULL)
     {
      InstanceVarSlotErrorMessage2(theEnv,ins,varSlot);
      SetEvaluationError(theEnv,true);
      return;
     }
   returnValue->value = sp->value;
   if (sp->type == MULTIFIELD_TYPE)
     {
      returnValue->begin = 0;
      returnValue->range = sp->multifieldValue->length;
     }
  }

/* =============================================================================
   =============================================================================
   Following are the instance query functions :

     any-instancep         : Determines if any instances satisfy the query
     find-instance         : Finds first (set of) instance(s) which satisfies
                               the query and stores it in a multi-field
     find-all-instances    : Finds all (sets of) instances which satisfy the
                               the query and stores them in a multi-field
     do-for-instance       : Executes a given action for the first (set of)
                               instance(s) which satisfy the query
     do-for-all-instances  : Executes an action for all instances which satisfy
                               the query as they are found
     delayed-do-for-all-instances : Same as above - except that the list of instances
                               which satisfy the query is formed before any
                               actions are executed

     Instance candidate search algorithm :

     All permutations of first restriction class instances with other
       restriction class instances (Rightmost are varied first)
     All permutations of first restriction class's subclasses' instances with
       other restriction class instances.
     And  so on...

     For any one class, instances are examined in the order they were defined

     Example :
     (defclass a (is-a standard-user))
     (defclass b (is-a standard-user))
     (defclass c (is-a standard-user))
     (defclass d (is-a a b))
     (make-instance a1 of a)
     (make-instance a2 of a)
     (make-instance b1 of b)
     (make-instance b2 of b)
     (make-instance c1 of c)
     (make-instance c2 of c)
     (make-instance d1 of d)
     (make-instance d2 of d)

     (any-instancep ((?a a b) (?b c)) <query>)

     The permutations (?a ?b) would be examined in the following order :

     (a1 c1),(a1 c2),(a2 c1),(a2 c2),(d1 c1),(d1 c2),(d2 c1),(d2 c2),
     (b1 c1),(b1 c2),(b2 c1),(b2 c2),(d1 c1),(d1 c2),(d2 c1),(d2 c2)

     Notice the duplication because d is a subclass of both and a and b.
   =============================================================================
   ============================================================================= */

/******************************************************************************
  NAME         : AnyInstances
  DESCRIPTION  : Determines if there any existing instances which satisfy
                   the query
  INPUTS       : None
  RETURNS      : True if the query is satisfied, false otherwise
  SIDE EFFECTS : The query class-expressions are evaluated once,
                   and the query boolean-expression is evaluated
                   zero or more times (depending on instance restrictions
                   and how early the expression evaulates to true - if at all).
  NOTES        : H/L Syntax : See ParseQueryNoAction()
 ******************************************************************************/
void AnyInstances(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   QUERY_CLASS *qclasses;
   unsigned rcnt;
   bool testResult;

   qclasses = DetermineQueryClasses(theEnv,GetFirstArgument()->nextArg,
                                      "any-instancep",&rcnt);
   if (qclasses == NULL)
     {
      returnValue->lexemeValue = FalseSymbol(theEnv);
      return;
     }

   PushQueryCore(theEnv);
   InstanceQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
   InstanceQueryData(theEnv)->QueryCore->solns = (Instance **) gm2(theEnv,(sizeof(Instance *) * rcnt));
   InstanceQueryData(theEnv)->QueryCore->query = GetFirstArgument();
   testResult = TestForFirstInChain(theEnv,qclasses,0);
   InstanceQueryData(theEnv)->AbortQuery = false;
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->solns,(sizeof(Instance *) * rcnt));
   rtn_struct(theEnv,query_core,InstanceQueryData(theEnv)->QueryCore);
   PopQueryCore(theEnv);
   DeleteQueryClasses(theEnv,qclasses);

   returnValue->lexemeValue = CreateBoolean(theEnv,testResult);
  }

/******************************************************************************
  NAME         : QueryFindInstance
  DESCRIPTION  : Finds the first set of instances which satisfy the query and
                   stores their names in the user's multi-field variable
  INPUTS       : Caller's result buffer
  RETURNS      : True if the query is satisfied, false otherwise
  SIDE EFFECTS : The query class-expressions are evaluated once,
                   and the query boolean-expression is evaluated
                   zero or more times (depending on instance restrictions
                   and how early the expression evaulates to true - if at all).
  NOTES        : H/L Syntax : See ParseQueryNoAction()
 ******************************************************************************/
void QueryFindInstance(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   QUERY_CLASS *qclasses;
   unsigned rcnt,i;

   returnValue->begin = 0;
   returnValue->range = 0;
   qclasses = DetermineQueryClasses(theEnv,GetFirstArgument()->nextArg,
                                      "find-instance",&rcnt);
   if (qclasses == NULL)
     {
      returnValue->value = CreateMultifield(theEnv,0L);
      return;
     }
   PushQueryCore(theEnv);
   InstanceQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
   InstanceQueryData(theEnv)->QueryCore->solns = (Instance **)
                      gm2(theEnv,(sizeof(Instance *) * rcnt));
   InstanceQueryData(theEnv)->QueryCore->query = GetFirstArgument();
   if (TestForFirstInChain(theEnv,qclasses,0) == true)
     {
      returnValue->value = CreateMultifield(theEnv,rcnt);
      returnValue->range = rcnt;
      for (i = 0 ; i < rcnt ; i++)
        {
         returnValue->multifieldValue->contents[i].lexemeValue =
            GetFullInstanceName(theEnv,InstanceQueryData(theEnv)->QueryCore->solns[i]);
        }
     }
   else
      returnValue->value = CreateMultifield(theEnv,0L);
   InstanceQueryData(theEnv)->AbortQuery = false;
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->solns,(sizeof(Instance *) * rcnt));
   rtn_struct(theEnv,query_core,InstanceQueryData(theEnv)->QueryCore);
   PopQueryCore(theEnv);
   DeleteQueryClasses(theEnv,qclasses);
  }

/******************************************************************************
  NAME         : QueryFindAllInstances
  DESCRIPTION  : Finds all sets of instances which satisfy the query and
                   stores their names in the user's multi-field variable

                 The sets are stored sequentially :

                   Number of sets = (Multi-field length) / (Set length)

                 The first set is if the first (set length) atoms of the
                   multi-field variable, and so on.
  INPUTS       : Caller's result buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : The query class-expressions are evaluated once,
                   and the query boolean-expression is evaluated
                   once for every instance set.
  NOTES        : H/L Syntax : See ParseQueryNoAction()
 ******************************************************************************/
void QueryFindAllInstances(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   QUERY_CLASS *qclasses;
   unsigned rcnt;
   size_t i, j;

   returnValue->begin = 0;
   returnValue->range = 0;
   qclasses = DetermineQueryClasses(theEnv,GetFirstArgument()->nextArg,
                                      "find-all-instances",&rcnt);
   if (qclasses == NULL)
     {
      returnValue->value = CreateMultifield(theEnv,0L);
      return;
     }
   PushQueryCore(theEnv);
   InstanceQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
   InstanceQueryData(theEnv)->QueryCore->solns = (Instance **) gm2(theEnv,(sizeof(Instance *) * rcnt));
   InstanceQueryData(theEnv)->QueryCore->query = GetFirstArgument();
   InstanceQueryData(theEnv)->QueryCore->action = NULL;
   InstanceQueryData(theEnv)->QueryCore->soln_set = NULL;
   InstanceQueryData(theEnv)->QueryCore->soln_size = rcnt;
   InstanceQueryData(theEnv)->QueryCore->soln_cnt = 0;
   TestEntireChain(theEnv,qclasses,0);
   InstanceQueryData(theEnv)->AbortQuery = false;
   returnValue->value = CreateMultifield(theEnv,InstanceQueryData(theEnv)->QueryCore->soln_cnt * rcnt);
   while (InstanceQueryData(theEnv)->QueryCore->soln_set != NULL)
     {
      for (i = 0 , j = returnValue->range ; i < rcnt ; i++ , j++)
        {
         returnValue->multifieldValue->contents[j].lexemeValue =
            GetFullInstanceName(theEnv,InstanceQueryData(theEnv)->QueryCore->soln_set->soln[i]);
        }
      returnValue->range = j;
      PopQuerySoln(theEnv);
     }
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->solns,(sizeof(Instance *) * rcnt));
   rtn_struct(theEnv,query_core,InstanceQueryData(theEnv)->QueryCore);
   PopQueryCore(theEnv);
   DeleteQueryClasses(theEnv,qclasses);
  }

/******************************************************************************
  NAME         : QueryDoForInstance
  DESCRIPTION  : Finds the first set of instances which satisfy the query and
                   executes a user-action with that set
  INPUTS       : None
  RETURNS      : Caller's result buffer
  SIDE EFFECTS : The query class-expressions are evaluated once,
                   and the query boolean-expression is evaluated
                   zero or more times (depending on instance restrictions
                   and how early the expression evaulates to true - if at all).
                   Also the action expression is executed zero or once.
                 Caller's result buffer holds result of user-action
  NOTES        : H/L Syntax : See ParseQueryAction()
 ******************************************************************************/
void QueryDoForInstance(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   QUERY_CLASS *qclasses;
   unsigned i, rcnt;

   returnValue->lexemeValue = FalseSymbol(theEnv);
   qclasses = DetermineQueryClasses(theEnv,GetFirstArgument()->nextArg->nextArg,
                                      "do-for-instance",&rcnt);
   if (qclasses == NULL)
     return;
   PushQueryCore(theEnv);
   InstanceQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
   InstanceQueryData(theEnv)->QueryCore->solns = (Instance **) gm2(theEnv,(sizeof(Instance *) * rcnt));
   InstanceQueryData(theEnv)->QueryCore->query = GetFirstArgument();
   InstanceQueryData(theEnv)->QueryCore->action = GetFirstArgument()->nextArg;
   
   if (TestForFirstInChain(theEnv,qclasses,0) == true)
     {
      for (i = 0; i < rcnt; i++)
        { InstanceQueryData(theEnv)->QueryCore->solns[i]->busy++; }

      EvaluateExpression(theEnv,InstanceQueryData(theEnv)->QueryCore->action,returnValue);
      
      for (i = 0; i < rcnt; i++)
        { InstanceQueryData(theEnv)->QueryCore->solns[i]->busy--; }
     }
     
   InstanceQueryData(theEnv)->AbortQuery = false;
   ProcedureFunctionData(theEnv)->BreakFlag = false;
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->solns,(sizeof(Instance *) * rcnt));
   rtn_struct(theEnv,query_core,InstanceQueryData(theEnv)->QueryCore);
   PopQueryCore(theEnv);
   DeleteQueryClasses(theEnv,qclasses);
  }

/******************************************************************************
  NAME         : QueryDoForAllInstances
  DESCRIPTION  : Finds all sets of instances which satisfy the query and
                   executes a user-function for each set as it is found
  INPUTS       : Caller's result buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : The query class-expressions are evaluated once,
                   and the query boolean-expression is evaluated
                   once for every instance set.  Also, the action is
                   executed for every instance set.
                 Caller's result buffer holds result of last action executed.
  NOTES        : H/L Syntax : See ParseQueryAction()
 ******************************************************************************/
void QueryDoForAllInstances(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   QUERY_CLASS *qclasses;
   unsigned rcnt;

   returnValue->lexemeValue = FalseSymbol(theEnv);
   qclasses = DetermineQueryClasses(theEnv,GetFirstArgument()->nextArg->nextArg,
                                      "do-for-all-instances",&rcnt);
   if (qclasses == NULL)
     return;

   PushQueryCore(theEnv);
   InstanceQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
   InstanceQueryData(theEnv)->QueryCore->solns = (Instance **) gm2(theEnv,(sizeof(Instance *) * rcnt));
   InstanceQueryData(theEnv)->QueryCore->query = GetFirstArgument();
   InstanceQueryData(theEnv)->QueryCore->action = GetFirstArgument()->nextArg;
   InstanceQueryData(theEnv)->QueryCore->result = returnValue;
   RetainUDFV(theEnv,InstanceQueryData(theEnv)->QueryCore->result);
   TestEntireChain(theEnv,qclasses,0);
   ReleaseUDFV(theEnv,InstanceQueryData(theEnv)->QueryCore->result);

   InstanceQueryData(theEnv)->AbortQuery = false;
   ProcedureFunctionData(theEnv)->BreakFlag = false;
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->solns,(sizeof(Instance *) * rcnt));
   rtn_struct(theEnv,query_core,InstanceQueryData(theEnv)->QueryCore);
   PopQueryCore(theEnv);
   DeleteQueryClasses(theEnv,qclasses);
  }

/******************************************************************************
  NAME         : DelayedQueryDoForAllInstances
  DESCRIPTION  : Finds all sets of instances which satisfy the query and
                   and exceutes a user-action for each set

                 This function differs from QueryDoForAllInstances() in
                   that it forms the complete list of query satisfactions
                   BEFORE executing any actions.
  INPUTS       : Caller's result buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : The query class-expressions are evaluated once,
                   and the query boolean-expression is evaluated
                   once for every instance set.  The action is executed
                   for evry query satisfaction.
                 Caller's result buffer holds result of last action executed.
  NOTES        : H/L Syntax : See ParseQueryNoAction()
 ******************************************************************************/
void DelayedQueryDoForAllInstances(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   QUERY_CLASS *qclasses;
   unsigned rcnt;
   unsigned i;
   GCBlock gcb;
   QUERY_SOLN *theSet;

   returnValue->lexemeValue = FalseSymbol(theEnv);
   qclasses = DetermineQueryClasses(theEnv,GetFirstArgument()->nextArg->nextArg,
                                      "delayed-do-for-all-instances",&rcnt);
   if (qclasses == NULL)
     return;

   PushQueryCore(theEnv);
   InstanceQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
   InstanceQueryData(theEnv)->QueryCore->solns = (Instance **) gm2(theEnv,(sizeof(Instance *) * rcnt));
   InstanceQueryData(theEnv)->QueryCore->query = GetFirstArgument();
   InstanceQueryData(theEnv)->QueryCore->action = NULL;
   InstanceQueryData(theEnv)->QueryCore->soln_set = NULL;
   InstanceQueryData(theEnv)->QueryCore->soln_size = rcnt;
   InstanceQueryData(theEnv)->QueryCore->soln_cnt = 0;
   TestEntireChain(theEnv,qclasses,0);
   InstanceQueryData(theEnv)->AbortQuery = false;
   InstanceQueryData(theEnv)->QueryCore->action = GetFirstArgument()->nextArg;

   /*==================================================================*/
   /* Increment the busy count for all instances in the solution sets. */
   /*==================================================================*/

   GCBlockStart(theEnv,&gcb);

   for (theSet = InstanceQueryData(theEnv)->QueryCore->soln_set;
        theSet != NULL;
        theSet = theSet->nxt)
     {
      for (i = 0; i < rcnt; i++)
        { theSet->soln[i]->busy++; }
     }

   /*=====================*/
   /* Perform the action. */
   /*=====================*/

   for (theSet = InstanceQueryData(theEnv)->QueryCore->soln_set;
        theSet != NULL; )
     {
      for (i = 0 ; i < rcnt ; i++)
        {
         if (theSet->soln[i]->garbage)
           { goto nextSet; }
         InstanceQueryData(theEnv)->QueryCore->solns[i] = theSet->soln[i];
        }

      EvaluateExpression(theEnv,InstanceQueryData(theEnv)->QueryCore->action,returnValue);

      if (EvaluationData(theEnv)->HaltExecution || ProcedureFunctionData(theEnv)->BreakFlag || ProcedureFunctionData(theEnv)->ReturnFlag)
        { break; }

      CleanCurrentGarbageFrame(theEnv,NULL);
      CallPeriodicTasks(theEnv);
      
      nextSet: theSet = theSet->nxt;
     }

   /*==================================================================*/
   /* Decrement the busy count for all instances in the solution sets. */
   /*==================================================================*/

   for (theSet = InstanceQueryData(theEnv)->QueryCore->soln_set;
        theSet != NULL;
        theSet = theSet->nxt)
     {
      for (i = 0; i < rcnt; i++)
        { theSet->soln[i]->busy--; }
     }

   GCBlockEndUDF(theEnv,&gcb,returnValue);
   CallPeriodicTasks(theEnv);

   /*==================================*/
   /* Deallocate the query structures. */
   /*==================================*/
   
   while (InstanceQueryData(theEnv)->QueryCore->soln_set != NULL)
     { PopQuerySoln(theEnv); }

   ProcedureFunctionData(theEnv)->BreakFlag = false;
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->solns,(sizeof(Instance *) * rcnt));
   rtn_struct(theEnv,query_core,InstanceQueryData(theEnv)->QueryCore);
   PopQueryCore(theEnv);
   DeleteQueryClasses(theEnv,qclasses);
  }

/* =========================================
   *****************************************
          INTERNALLY VISIBLE FUNCTIONS
   =========================================
   ***************************************** */

/*******************************************************
  NAME         : PushQueryCore
  DESCRIPTION  : Pushes the current QueryCore onto stack
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Allocates new stack node and changes
                   QueryCoreStack
  NOTES        : None
 *******************************************************/
static void PushQueryCore(
  Environment *theEnv)
  {
   QUERY_STACK *qptr;

   qptr = get_struct(theEnv,query_stack);
   qptr->core = InstanceQueryData(theEnv)->QueryCore;
   qptr->nxt = InstanceQueryData(theEnv)->QueryCoreStack;
   InstanceQueryData(theEnv)->QueryCoreStack = qptr;
  }

/******************************************************
  NAME         : PopQueryCore
  DESCRIPTION  : Pops top of QueryCore stack and
                   restores QueryCore to this core
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Stack node deallocated, QueryCoreStack
                   changed and QueryCore reset
  NOTES        : Assumes stack is not empty
 ******************************************************/
static void PopQueryCore(
  Environment *theEnv)
  {
   QUERY_STACK *qptr;

   InstanceQueryData(theEnv)->QueryCore = InstanceQueryData(theEnv)->QueryCoreStack->core;
   qptr = InstanceQueryData(theEnv)->QueryCoreStack;
   InstanceQueryData(theEnv)->QueryCoreStack = InstanceQueryData(theEnv)->QueryCoreStack->nxt;
   rtn_struct(theEnv,query_stack,qptr);
  }

/***************************************************
  NAME         : FindQueryCore
  DESCRIPTION  : Looks up a QueryCore Stack Frame
                    Depth 0 is current frame
                    1 is next deepest, etc.
  INPUTS       : Depth
  RETURNS      : Address of query core stack frame
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
static QUERY_CORE *FindQueryCore(
  Environment *theEnv,
  long long depth)
  {
   QUERY_STACK *qptr;

   if (depth == 0)
     return InstanceQueryData(theEnv)->QueryCore;
   qptr = InstanceQueryData(theEnv)->QueryCoreStack;
   while (depth > 1)
     {
      qptr = qptr->nxt;
      depth--;
     }
   return qptr->core;
  }

/**********************************************************
  NAME         : DetermineQueryClasses
  DESCRIPTION  : Builds a list of classes to be used in
                   instance queries - uses parse form.
  INPUTS       : 1) The parse class expression chain
                 2) The name of the function being executed
                 3) Caller's buffer for restriction count
                    (# of separate lists)
  RETURNS      : The query list, or NULL on errors
  SIDE EFFECTS : Memory allocated for list
                 Busy count incremented for all classes
  NOTES        : Each restriction is linked by nxt pointer,
                   multiple classes in a restriction are
                   linked by the chain pointer.
                 Rcnt caller's buffer is set to reflect the
                   total number of chains
                 Assumes classExp is not NULL and that each
                   restriction chain is terminated with
                   the QUERY_DELIMITER_SYMBOL "(QDS)"
 **********************************************************/
static QUERY_CLASS *DetermineQueryClasses(
  Environment *theEnv,
  Expression *classExp,
  const char *func,
  unsigned *rcnt)
  {
   QUERY_CLASS *clist = NULL,*cnxt = NULL,*cchain = NULL,*tmp;
   bool new_list = false;
   UDFValue temp;
   Defclass *theClass;

   *rcnt = 0;
   while (classExp != NULL)
     {
      theClass = NULL;
      
      if (classExp->type == DEFCLASS_PTR)
        {
         theClass = (Defclass *) classExp->value;
        }
      else if (EvaluateExpression(theEnv,classExp,&temp))
        {
         DeleteQueryClasses(theEnv,clist);
         return NULL;
        }
        
      if ((theClass == NULL) &&
          (temp.value == (void *) InstanceQueryData(theEnv)->QUERY_DELIMITER_SYMBOL))
        {
         new_list = true;
         (*rcnt)++;
        }
      else if ((tmp = FormChain(theEnv,func,theClass,&temp)) != NULL)
        {
         if (clist == NULL)
           clist = cnxt = cchain = tmp;
         else if (new_list == true)
           {
            new_list = false;
            cnxt->nxt = tmp;
            cnxt = cchain = tmp;
           }
         else
           cchain->chain = tmp;
         while (cchain->chain != NULL)
           cchain = cchain->chain;
        }
      else
        {
         SyntaxErrorMessage(theEnv,"instance-set query class restrictions");
         DeleteQueryClasses(theEnv,clist);
         SetEvaluationError(theEnv,true);
         return NULL;
        }
      classExp = classExp->nextArg;
     }
   return(clist);
  }

/*************************************************************
  NAME         : FormChain
  DESCRIPTION  : Builds a list of classes to be used in
                   instance queries - uses parse form.
  INPUTS       : 1) Name of calling function for error msgs
                 2) Data object - must be a symbol or a
                      multifield value containing all symbols
                 The symbols must be names of existing classes
  RETURNS      : The query chain, or NULL on errors
  SIDE EFFECTS : Memory allocated for chain
                 Busy count incremented for all classes
  NOTES        : None
 *************************************************************/
static QUERY_CLASS *FormChain(
  Environment *theEnv,
  const char *func,
  Defclass *theClass,
  UDFValue *val)
  {
   Defclass *cls;
   QUERY_CLASS *head,*bot,*tmp;
   size_t i;
   const char *className;
   Defmodule *currentModule;

   currentModule = GetCurrentModule(theEnv);
   if (theClass != NULL)
     {
      IncrementDefclassBusyCount(theEnv,theClass);
      head = get_struct(theEnv,query_class);
      head->cls = theClass;
      if (DefclassInScope(theEnv,head->cls,currentModule))
        head->theModule = currentModule;
      else
        head->theModule = head->cls->header.whichModule->theModule;
      head->chain = NULL;
      head->nxt = NULL;
      return(head);
     }

   if (val->header->type == SYMBOL_TYPE)
     {
      /* ===============================================
         Allow instance-set query restrictions to have a
         module specifier as part of the class name,
         but search imported defclasses too if a
         module specifier is not given
         =============================================== */
      cls = LookupDefclassByMdlOrScope(theEnv,val->lexemeValue->contents);
      if (cls == NULL)
        {
         ClassExistError(theEnv,func,val->lexemeValue->contents);
         return NULL;
        }
      IncrementDefclassBusyCount(theEnv,(Defclass *) cls);
      head = get_struct(theEnv,query_class);
      head->cls = cls;
      if (DefclassInScope(theEnv,head->cls,currentModule))
        head->theModule = currentModule;
      else
        head->theModule = head->cls->header.whichModule->theModule;
      head->chain = NULL;
      head->nxt = NULL;
      return(head);
     }

   if (val->header->type == MULTIFIELD_TYPE)
     {
      head = bot = NULL;
      for (i = val->begin ; i < (val->begin + val->range) ; i++)
        {
         if (val->multifieldValue->contents[i].header->type == SYMBOL_TYPE)
           {
            className = val->multifieldValue->contents[i].lexemeValue->contents;
            cls = LookupDefclassByMdlOrScope(theEnv,className);
            if (cls == NULL)
              {
               ClassExistError(theEnv,func,className);
               DeleteQueryClasses(theEnv,head);
               return NULL;
              }
           }
         else
           {
            DeleteQueryClasses(theEnv,head);
            return NULL;
           }
         IncrementDefclassBusyCount(theEnv,(Defclass *) cls);
         tmp = get_struct(theEnv,query_class);
         tmp->cls = cls;
         if (DefclassInScope(theEnv,tmp->cls,currentModule))
           tmp->theModule = currentModule;
         else
           tmp->theModule = tmp->cls->header.whichModule->theModule;
         tmp->chain = NULL;
         tmp->nxt = NULL;
         if (head == NULL)
           head = tmp;
         else
           bot->chain = tmp;
         bot = tmp;
        }
      return(head);
     }
   return NULL;
  }

/******************************************************
  NAME         : DeleteQueryClasses
  DESCRIPTION  : Deletes a query class-list
  INPUTS       : The query list address
  RETURNS      : Nothing useful
  SIDE EFFECTS : Nodes deallocated
                 Busy count decremented for all classes
  NOTES        : None
 ******************************************************/
static void DeleteQueryClasses(
  Environment *theEnv,
  QUERY_CLASS *qlist)
  {
   QUERY_CLASS *tmp;

   while (qlist != NULL)
     {
      while (qlist->chain != NULL)
        {
         tmp = qlist->chain;
         qlist->chain = qlist->chain->chain;
         DecrementDefclassBusyCount(theEnv,(Defclass *) tmp->cls);
         rtn_struct(theEnv,query_class,tmp);
        }
      tmp = qlist;
      qlist = qlist->nxt;
      DecrementDefclassBusyCount(theEnv,(Defclass *) tmp->cls);
      rtn_struct(theEnv,query_class,tmp);
     }
  }

/************************************************************
  NAME         : TestForFirstInChain
  DESCRIPTION  : Processes all classes in a restriction chain
                   until success or done
  INPUTS       : 1) The current chain
                 2) The index of the chain restriction
                     (e.g. the 4th query-variable)
  RETURNS      : True if query succeeds, false otherwise
  SIDE EFFECTS : Sets current restriction class
                 Instance variable values set
  NOTES        : None
 ************************************************************/
static bool TestForFirstInChain(
  Environment *theEnv,
  QUERY_CLASS *qchain,
  unsigned indx)
  {
   QUERY_CLASS *qptr;
   int id;

   InstanceQueryData(theEnv)->AbortQuery = true;
   for (qptr = qchain ; qptr != NULL ; qptr = qptr->chain)
     {
      InstanceQueryData(theEnv)->AbortQuery = false;
      if ((id = GetTraversalID(theEnv)) == -1)
        return false;
      if (TestForFirstInstanceInClass(theEnv,qptr->theModule,id,qptr->cls,qchain,indx))
        {
         ReleaseTraversalID(theEnv);
         return true;
        }
      ReleaseTraversalID(theEnv);
      if ((EvaluationData(theEnv)->HaltExecution == true) || (InstanceQueryData(theEnv)->AbortQuery == true))
        return false;
     }
   return false;
  }

/*****************************************************************
  NAME         : TestForFirstInstanceInClass
  DESCRIPTION  : Processes all instances in a class and then
                   all subclasses of a class until success or done
  INPUTS       : 1) The module for which classes tested must be
                    in scope
                 2) Visitation traversal id
                 3) The class
                 4) The current class restriction chain
                 5) The index of the current restriction
  RETURNS      : True if query succeeds, false otherwise
  SIDE EFFECTS : Instance variable values set
  NOTES        : None
 *****************************************************************/
static bool TestForFirstInstanceInClass(
  Environment *theEnv,
  Defmodule *theModule,
  int id,
  Defclass *cls,
  QUERY_CLASS *qchain,
  unsigned indx)
  {
   unsigned long i;
   Instance *ins;
   UDFValue temp;
   GCBlock gcb;
   unsigned j;

   if (TestTraversalID(cls->traversalRecord,id))
     return false;
   SetTraversalID(cls->traversalRecord,id);
   if (DefclassInScope(theEnv,cls,theModule) == false)
     return false;

   GCBlockStart(theEnv,&gcb);

   ins = cls->instanceList;
   while (ins != NULL)
     {
      InstanceQueryData(theEnv)->QueryCore->solns[indx] = ins;
      if (qchain->nxt != NULL)
        {
         ins->busy++;
         if (TestForFirstInChain(theEnv,qchain->nxt,indx+1) == true)
           {
            ins->busy--;
            break;
           }
         ins->busy--;
         if ((EvaluationData(theEnv)->HaltExecution == true) || (InstanceQueryData(theEnv)->AbortQuery == true))
           break;
        }
      else
        {
         for (j = 0; j < indx; j++)
           {
            if (InstanceQueryData(theEnv)->QueryCore->solns[j]->garbage)
              {
               ins = NULL;
               goto endTest;
              }
           }
           
         ins->busy++;
         EvaluateExpression(theEnv,InstanceQueryData(theEnv)->QueryCore->query,&temp);
         ins->busy--;
         if (EvaluationData(theEnv)->HaltExecution == true)
           break;
         if (temp.value != FalseSymbol(theEnv))
           break;
        }

      CleanCurrentGarbageFrame(theEnv,NULL);
      CallPeriodicTasks(theEnv);

      ins = ins->nxtClass;
      while ((ins != NULL) ? (ins->garbage == 1) : false)
        ins = ins->nxtClass;
     }
     
   endTest:

   GCBlockEnd(theEnv,&gcb);
   CallPeriodicTasks(theEnv);

   if (ins != NULL)
     return(((EvaluationData(theEnv)->HaltExecution == true) || (InstanceQueryData(theEnv)->AbortQuery == true))
             ? false : true);
   for (i = 0 ; i < cls->directSubclasses.classCount ; i++)
     {
      if (TestForFirstInstanceInClass(theEnv,theModule,id,cls->directSubclasses.classArray[i],
                                      qchain,indx))
        return true;
      if ((EvaluationData(theEnv)->HaltExecution == true) || (InstanceQueryData(theEnv)->AbortQuery == true))
        return false;
     }
   return false;
  }

/************************************************************
  NAME         : TestEntireChain
  DESCRIPTION  : Processes all classes in a restriction chain
                   until done
  INPUTS       : 1) The current chain
                 2) The index of the chain restriction
                     (i.e. the 4th query-variable)
  RETURNS      : Nothing useful
  SIDE EFFECTS : Sets current restriction class
                 Query instance variables set
                 Solution sets stored in global list
  NOTES        : None
 ************************************************************/
static void TestEntireChain(
  Environment *theEnv,
  QUERY_CLASS *qchain,
  unsigned indx)
  {
   QUERY_CLASS *qptr;
   int id;

   InstanceQueryData(theEnv)->AbortQuery = true;
   for (qptr = qchain ; qptr != NULL ; qptr = qptr->chain)
     {
      InstanceQueryData(theEnv)->AbortQuery = false;
      if ((id = GetTraversalID(theEnv)) == -1)
        return;
      TestEntireClass(theEnv,qptr->theModule,id,qptr->cls,qchain,indx);
      ReleaseTraversalID(theEnv);
      if ((EvaluationData(theEnv)->HaltExecution == true) || (InstanceQueryData(theEnv)->AbortQuery == true))
        return;
     }
  }

/*****************************************************************
  NAME         : TestEntireClass
  DESCRIPTION  : Processes all instances in a class and then
                   all subclasses of a class until done
  INPUTS       : 1) The module for which classes tested must be
                    in scope
                 2) Visitation traversal id
                 3) The class
                 4) The current class restriction chain
                 5) The index of the current restriction
  RETURNS      : Nothing useful
  SIDE EFFECTS : Instance variable values set
                 Solution sets stored in global list
  NOTES        : None
 *****************************************************************/
static void TestEntireClass(
  Environment *theEnv,
  Defmodule *theModule,
  int id,
  Defclass *cls,
  QUERY_CLASS *qchain,
  unsigned indx)
  {
   unsigned long i;
   Instance *ins;
   UDFValue temp;
   GCBlock gcb;
   unsigned j;
   
   if (TestTraversalID(cls->traversalRecord,id))
     return;
   SetTraversalID(cls->traversalRecord,id);
   if (DefclassInScope(theEnv,cls,theModule) == false)
     return;

   GCBlockStart(theEnv,&gcb);

   ins = cls->instanceList;
   while (ins != NULL)
     {
      InstanceQueryData(theEnv)->QueryCore->solns[indx] = ins;
      if (qchain->nxt != NULL)
        {
         ins->busy++;
         TestEntireChain(theEnv,qchain->nxt,indx+1);
         ins->busy--;
         if ((EvaluationData(theEnv)->HaltExecution == true) || (InstanceQueryData(theEnv)->AbortQuery == true))
           break;
        }
      else
        {
         for (j = 0; j < indx; j++)
           {
            if (InstanceQueryData(theEnv)->QueryCore->solns[j]->garbage)
              { goto endTest; }
           }

         ins->busy++;

         EvaluateExpression(theEnv,InstanceQueryData(theEnv)->QueryCore->query,&temp);

         ins->busy--;
         if (EvaluationData(theEnv)->HaltExecution == true)
           break;
         if (temp.value != FalseSymbol(theEnv))
           {
            if (InstanceQueryData(theEnv)->QueryCore->action != NULL)
              {
               ins->busy++;

               ReleaseUDFV(theEnv,InstanceQueryData(theEnv)->QueryCore->result);
               EvaluateExpression(theEnv,InstanceQueryData(theEnv)->QueryCore->action,InstanceQueryData(theEnv)->QueryCore->result);
               RetainUDFV(theEnv,InstanceQueryData(theEnv)->QueryCore->result);

               ins->busy--;
               if (ProcedureFunctionData(theEnv)->BreakFlag || ProcedureFunctionData(theEnv)->ReturnFlag)
                 {
                  InstanceQueryData(theEnv)->AbortQuery = true;
                  break;
                 }
               if (EvaluationData(theEnv)->HaltExecution == true)
                 break;
              }
            else
              AddSolution(theEnv);
           }
        }

      ins = ins->nxtClass;
      while ((ins != NULL) ? (ins->garbage == 1) : false)
        ins = ins->nxtClass;

      CleanCurrentGarbageFrame(theEnv,NULL);
      CallPeriodicTasks(theEnv);
     }
     
   endTest:
   
   GCBlockEnd(theEnv,&gcb);
   CallPeriodicTasks(theEnv);

   if (ins != NULL)
     return;
   for (i = 0 ; i < cls->directSubclasses.classCount ; i++)
     {
      TestEntireClass(theEnv,theModule,id,cls->directSubclasses.classArray[i],qchain,indx);
      if ((EvaluationData(theEnv)->HaltExecution == true) || (InstanceQueryData(theEnv)->AbortQuery == true))
        return;
     }
  }

/***************************************************************************
  NAME         : AddSolution
  DESCRIPTION  : Adds the current instance set to a global list of
                   solutions
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Global list and count updated
  NOTES        : Solutions are stored as sequential arrays of Instance *
 ***************************************************************************/
static void AddSolution(
  Environment *theEnv)
  {
   QUERY_SOLN *new_soln;
   unsigned i;

   new_soln = (QUERY_SOLN *) gm2(theEnv,sizeof(QUERY_SOLN));
   new_soln->soln = (Instance **)
                    gm2(theEnv,(sizeof(Instance *) * (InstanceQueryData(theEnv)->QueryCore->soln_size)));
   for (i = 0 ; i < InstanceQueryData(theEnv)->QueryCore->soln_size ; i++)
     new_soln->soln[i] = InstanceQueryData(theEnv)->QueryCore->solns[i];
   new_soln->nxt = NULL;
   if (InstanceQueryData(theEnv)->QueryCore->soln_set == NULL)
     InstanceQueryData(theEnv)->QueryCore->soln_set = new_soln;
   else
     InstanceQueryData(theEnv)->QueryCore->soln_bottom->nxt = new_soln;
   InstanceQueryData(theEnv)->QueryCore->soln_bottom = new_soln;
   InstanceQueryData(theEnv)->QueryCore->soln_cnt++;
  }

/***************************************************
  NAME         : PopQuerySoln
  DESCRIPTION  : Deallocates the topmost solution
                   set for an instance-set query
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Solution set deallocated
  NOTES        : Assumes QueryCore->soln_set != 0
 ***************************************************/
static void PopQuerySoln(
  Environment *theEnv)
  {
   InstanceQueryData(theEnv)->QueryCore->soln_bottom = InstanceQueryData(theEnv)->QueryCore->soln_set;
   InstanceQueryData(theEnv)->QueryCore->soln_set = InstanceQueryData(theEnv)->QueryCore->soln_set->nxt;
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->soln_bottom->soln,
      (sizeof(Instance *) * InstanceQueryData(theEnv)->QueryCore->soln_size));
   rm(theEnv,InstanceQueryData(theEnv)->QueryCore->soln_bottom,sizeof(QUERY_SOLN));
  }

#endif