classinf.c

来自「clips源代码」· C语言 代码 · 共 1,113 行 · 第 1/3 页

   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*             CLIPS Version 6.24  07/01/05            */
   /*                                                     */
   /*        CLASS INFO PROGRAMMATIC ACCESS MODULE        */
   /*******************************************************/

/**************************************************************/
/* Purpose: Class Information Interface Support Routines      */
/*                                                            */
/* Principal Programmer(s):                                   */
/*      Brian L. Donnell                                      */
/*                                                            */
/* Contributing Programmer(s):                                */
/*                                                            */
/* Revision History:                                          */
/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859   */
/*                                                            */
/*            Changed name of variable exp to theExp          */
/*            because of Unix compiler warnings of shadowed   */
/*            definitions.                                    */
/*                                                            */
/*      6.24: Added allowed-classes slot facet.               */
/*                                                            */
/*            Converted INSTANCE_PATTERN_MATCHING to          */
/*            DEFRULE_CONSTRUCT.                              */
/*                                                            */
/*            Renamed BOOLEAN macro type to intBool.          */
/*                                                            */
/**************************************************************/

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

#if OBJECT_SYSTEM

#ifndef _STDIO_INCLUDED_
#define _STDIO_INCLUDED_
#include <stdio.h>
#endif

#include <string.h>

#include "argacces.h"
#include "classcom.h"
#include "classexm.h"
#include "classfun.h"
#include "classini.h"
#include "envrnmnt.h"
#include "memalloc.h"
#include "insfun.h"
#include "msgcom.h"
#include "msgfun.h"
#include "multifld.h"
#include "prntutil.h"

#define _CLASSINF_SOURCE_
#include "classinf.h"

/* =========================================
   *****************************************
      INTERNALLY VISIBLE FUNCTION HEADERS
   =========================================
   ***************************************** */

static void SlotInfoSupportFunction(void *,DATA_OBJECT *,char *,void (*)(void *,void *,char *,DATA_OBJECT *));
static unsigned CountSubclasses(DEFCLASS *,int,int);
static unsigned StoreSubclasses(void *,unsigned,DEFCLASS *,int,int,short);
static SLOT_DESC *SlotInfoSlot(void *,DATA_OBJECT *,DEFCLASS *,char *,char *);

/*********************************************************************
  NAME         : ClassAbstractPCommand
  DESCRIPTION  : Determines if direct instances of a class can be made
  INPUTS       : None
  RETURNS      : TRUE (1) if class is abstract, FALSE (0) if concrete
  SIDE EFFECTS : None
  NOTES        : Syntax: (class-abstractp <class>)
 *********************************************************************/
globle int ClassAbstractPCommand(
  void *theEnv)
  {
   DATA_OBJECT tmp;
   DEFCLASS *cls;
   
   if (EnvArgTypeCheck(theEnv,"class-abstractp",1,SYMBOL,&tmp) == FALSE)
     return(FALSE);
   cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
   if (cls == NULL)
     {
      ClassExistError(theEnv,"class-abstractp",ValueToString(tmp.value));
      return(FALSE);
     }
   return(EnvClassAbstractP(theEnv,(void *) cls));
  }

#if DEFRULE_CONSTRUCT

/*****************************************************************
  NAME         : ClassReactivePCommand
  DESCRIPTION  : Determines if instances of a class can match rule
                 patterns
  INPUTS       : None
  RETURNS      : TRUE (1) if class is reactive, FALSE (0)
                 if non-reactive
  SIDE EFFECTS : None
  NOTES        : Syntax: (class-reactivep <class>)
 *****************************************************************/
globle int ClassReactivePCommand(
  void *theEnv)
  {
   DATA_OBJECT tmp;
   DEFCLASS *cls;
   
   if (EnvArgTypeCheck(theEnv,"class-reactivep",1,SYMBOL,&tmp) == FALSE)
     return(FALSE);
   cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
   if (cls == NULL)
     {
      ClassExistError(theEnv,"class-reactivep",ValueToString(tmp.value));
      return(FALSE);
     }
   return(EnvClassReactiveP(theEnv,(void *) cls));
  }

#endif

/***********************************************************
  NAME         : ClassInfoFnxArgs
  DESCRIPTION  : Examines arguments for:
                   class-slots, get-defmessage-handler-list,
                   class-superclasses and class-subclasses
  INPUTS       : 1) Name of function
                 2) A buffer to hold a flag indicating if
                    the inherit keyword was specified
  RETURNS      : Pointer to the class on success,
                   NULL on errors
  SIDE EFFECTS : inhp flag set
                 error flag set
  NOTES        : None
 ***********************************************************/
globle void *ClassInfoFnxArgs(
  void *theEnv,
  char *fnx,
  int *inhp)
  {
   void *clsptr;
   DATA_OBJECT tmp;

   *inhp = 0;
   if (EnvRtnArgCount(theEnv) == 0)
     {
      ExpectedCountError(theEnv,fnx,AT_LEAST,1);
      SetEvaluationError(theEnv,TRUE);
      return(NULL);
     }
   if (EnvArgTypeCheck(theEnv,fnx,1,SYMBOL,&tmp) == FALSE)
     return(NULL);
   clsptr = (void *) LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
   if (clsptr == NULL)
     {
      ClassExistError(theEnv,fnx,ValueToString(tmp.value));
      return(NULL);
     }
   if (EnvRtnArgCount(theEnv) == 2)
     {
      if (EnvArgTypeCheck(theEnv,fnx,2,SYMBOL,&tmp) == FALSE)
        return(NULL);
      if (strcmp(ValueToString(tmp.value),"inherit") == 0)
        *inhp = 1;
      else
        {
         SyntaxErrorMessage(theEnv,fnx);
         SetEvaluationError(theEnv,TRUE);
         return(NULL);
        }
     }
   return(clsptr);
  }

/********************************************************************
  NAME         : ClassSlotsCommand
  DESCRIPTION  : Groups slot info for a class into a multifield value
                   for dynamic perusal
  INPUTS       : Data object buffer to hold the slots of the class
  RETURNS      : Nothing useful
  SIDE EFFECTS : Creates a multifield storing the names of
                    the slots of the class
  NOTES        : Syntax: (class-slots <class> [inherit])
 ********************************************************************/
globle void ClassSlotsCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   int inhp;
   void *clsptr;
   
   clsptr = ClassInfoFnxArgs(theEnv,"class-slots",&inhp);
   if (clsptr == NULL)
     {
      EnvSetMultifieldErrorValue(theEnv,result);
      return;
     }
   EnvClassSlots(theEnv,clsptr,result,inhp);
  }

/************************************************************************
  NAME         : ClassSuperclassesCommand
  DESCRIPTION  : Groups superclasses for a class into a multifield value
                   for dynamic perusal
  INPUTS       : Data object buffer to hold the superclasses of the class
  RETURNS      : Nothing useful
  SIDE EFFECTS : Creates a multifield storing the names of
                    the superclasses of the class
  NOTES        : Syntax: (class-superclasses <class> [inherit])
 ************************************************************************/
globle void ClassSuperclassesCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   int inhp;
   void *clsptr;
   
   clsptr = ClassInfoFnxArgs(theEnv,"class-superclasses",&inhp);
   if (clsptr == NULL)
     {
      EnvSetMultifieldErrorValue(theEnv,result);
      return;
     }
   EnvClassSuperclasses(theEnv,clsptr,result,inhp);
  }

/************************************************************************
  NAME         : ClassSubclassesCommand
  DESCRIPTION  : Groups subclasses for a class into a multifield value
                   for dynamic perusal
  INPUTS       : Data object buffer to hold the subclasses of the class
  RETURNS      : Nothing useful
  SIDE EFFECTS : Creates a multifield storing the names of
                    the subclasses of the class
  NOTES        : Syntax: (class-subclasses <class> [inherit])
 ************************************************************************/
globle void ClassSubclassesCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   int inhp;
   void *clsptr;
     
   clsptr = ClassInfoFnxArgs(theEnv,"class-subclasses",&inhp);
   if (clsptr == NULL)
     {
      EnvSetMultifieldErrorValue(theEnv,result);
      return;
     }
   EnvClassSubclasses(theEnv,clsptr,result,inhp);
  }

/***********************************************************************
  NAME         : GetDefmessageHandlersListCmd
  DESCRIPTION  : Groups message-handlers for a class into a multifield
                   value for dynamic perusal
  INPUTS       : Data object buffer to hold the handlers of the class
  RETURNS      : Nothing useful
  SIDE EFFECTS : Creates a multifield storing the names of
                    the message-handlers of the class
  NOTES        : Syntax: (get-defmessage-handler-list <class> [inherit])
 ***********************************************************************/
globle void GetDefmessageHandlersListCmd(
  void *theEnv,
  DATA_OBJECT *result)
  {
   int inhp;
   void *clsptr;
   
   if (EnvRtnArgCount(theEnv) == 0)
      EnvGetDefmessageHandlerList(theEnv,NULL,result,0);
   else
     {
      clsptr = ClassInfoFnxArgs(theEnv,"get-defmessage-handler-list",&inhp);
      if (clsptr == NULL)
        {
         EnvSetMultifieldErrorValue(theEnv,result);
         return;
        }
      EnvGetDefmessageHandlerList(theEnv,clsptr,result,inhp);
     }
  }

/*********************************
 Slot Information Access Functions
 *********************************/
globle void SlotFacetsCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   SlotInfoSupportFunction(theEnv,result,"slot-facets",EnvSlotFacets);
  }

globle void SlotSourcesCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {   
   SlotInfoSupportFunction(theEnv,result,"slot-sources",EnvSlotSources);
  }

globle void SlotTypesCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   SlotInfoSupportFunction(theEnv,result,"slot-types",EnvSlotTypes);
  }

globle void SlotAllowedValuesCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   SlotInfoSupportFunction(theEnv,result,"slot-allowed-values",EnvSlotAllowedValues);
  }

globle void SlotAllowedClassesCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   SlotInfoSupportFunction(theEnv,result,"slot-allowed-classes",EnvSlotAllowedClasses);
  }

globle void SlotRangeCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   SlotInfoSupportFunction(theEnv,result,"slot-range",EnvSlotRange);
  }

globle void SlotCardinalityCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   SlotInfoSupportFunction(theEnv,result,"slot-cardinality",EnvSlotCardinality);
  }

/********************************************************************
  NAME         : EnvClassAbstractP
  DESCRIPTION  : Determines if a class is abstract or not
  INPUTS       : Generic pointer to class
  RETURNS      : 1 if class is abstract, 0 otherwise
  SIDE EFFECTS : None
  NOTES        : None
 ********************************************************************/
#if IBM_TBC
#pragma argsused
#endif
globle intBool EnvClassAbstractP(
  void *theEnv,
  void *clsptr)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(theEnv)
#endif

   return(((DEFCLASS *) clsptr)->abstract);
  }

#if DEFRULE_CONSTRUCT

/********************************************************************
  NAME         : EnvClassReactiveP