clipsruby 0.0.2

data/ext/clipsruby/factfun.c

@@ -0,0 +1,682 @@
+   /*******************************************************/
+   /*      "C" Language Integrated Production System      */
+   /*                                                     */
+   /*            CLIPS Version 6.41  12/04/22             */
+   /*                                                     */
+   /*               FACT FUNCTIONS MODULE                 */
+   /*******************************************************/
+
+/*************************************************************/
+/* Purpose:                                                  */
+/*                                                           */
+/*                                                           */
+/* (fact-existp <fact-address-or-index>)                     */
+/*    Returns TRUE if the fact exists, otherwise FALSE is    */
+/*    returned.                                              */
+/*                                                           */
+/* (fact-relation <fact-address-or-index>)                   */
+/*    Returns the deftemplate name of the fact. Returns      */
+/*    FALSE if the specified fact doesn't exist.             */
+/*                                                           */
+/* (fact-slot-value <fact-address-or-index> <slot-name>)     */
+/*    Returns the contents of a slot (use the slot name      */
+/*    implied for the implied multifield slot of an ordered  */
+/*    fact). Returns the value FALSE if the slot name is     */
+/*    invalid or the fact doesn't exist.                     */
+/*                                                           */
+/* (fact-slot-names <fact-address-or-index>)                 */
+/*    Returns the slot names associated with a fact in a     */
+/*    multifield value. Returns FALSE if the fact doesn't    */
+/*    exist.                                                 */
+/*                                                           */
+/* (get-fact-list [<module-name>])                           */
+/*    Returns the list of facts visible to the specified     */
+/*    module or to the current module if none is specified.  */
+/*    If * is specified then all facts are returned.         */
+/*                                                           */
+/* Principal Programmer(s):                                  */
+/*      Gary D. Riley                                        */
+/*                                                           */
+/* Contributing Programmer(s):                               */
+/*                                                           */
+/* Revision History:                                         */
+/*                                                           */
+/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
+/*                                                           */
+/*            Corrected compilation errors for files         */
+/*            generated by constructs-to-c. DR0861           */
+/*                                                           */
+/*      6.24: Added ppfact function.                         */
+/*                                                           */
+/*      6.30: Support for long long integers.                */
+/*                                                           */
+/*            Removed conditional code for unsupported       */
+/*            compilers/operating systems (IBM_MCW,          */
+/*            MAC_MCW, and IBM_TBC).                         */
+/*                                                           */
+/*            Added const qualifiers to remove C++           */
+/*            deprecation warnings.                          */
+/*                                                           */
+/*            Converted API macros to function calls.        */
+/*                                                           */
+/*            Added STDOUT and STDIN logical name            */
+/*            definitions.                                   */
+/*                                                           */
+/*      6.31: Calling EnvFactExistp for a fact that has      */
+/*            been created, but not asserted now returns     */
+/*            FALSE.                                         */
+/*                                                           */
+/*            Error messages are now generated when the      */
+/*            fact-relation, fact-slot-value,                */
+/*            fact-slot-names, and ppfact functions are      */
+/*            given a retracted fact.                        */
+/*                                                           */
+/*      6.40: Added Env prefix to GetEvaluationError and     */
+/*            SetEvaluationError functions.                  */
+/*                                                           */
+/*            Added Env prefix to GetHaltExecution and       */
+/*            SetHaltExecution functions.                    */
+/*                                                           */
+/*            Pragma once and other inclusion changes.       */
+/*                                                           */
+/*            Added support for booleans with <stdbool.h>.   */
+/*                                                           */
+/*            Removed use of void pointers for specific      */
+/*            data structures.                               */
+/*                                                           */
+/*            ALLOW_ENVIRONMENT_GLOBALS no longer supported. */
+/*                                                           */
+/*            UDF redesign.                                  */
+/*                                                           */
+/*            Watch facts for modify command only prints     */
+/*            changed slots.                                 */
+/*                                                           */
+/*            Pretty print functions accept optional logical */
+/*            name argument.                                 */
+/*                                                           */
+/*            Added fact-addressp function.                  */
+/*                                                           */
+/*      6.41: Used gensnprintf in place of gensprintf and.   */
+/*            sprintf.                                       */
+/*                                                           */
+/*************************************************************/
+
+#include <stdio.h>
+#include <string.h>
+
+#include "setup.h"
+
+#if DEFTEMPLATE_CONSTRUCT
+
+#include "argacces.h"
+#include "envrnmnt.h"
+#include "extnfunc.h"
+#include "multifld.h"
+#include "prntutil.h"
+#include "router.h"
+#include "sysdep.h"
+#include "tmpltutl.h"
+
+#include "factfun.h"
+
+/****************************************************/
+/* FactFunctionDefinitions: Defines fact functions. */
+/****************************************************/
+void FactFunctionDefinitions(
+  Environment *theEnv)
+  {
+#if ! RUN_TIME
+   AddUDF(theEnv,"fact-existp","b",1,1,"lf",FactExistpFunction,"FactExistpFunction",NULL);
+   AddUDF(theEnv,"fact-relation","y",1,1,"lf",FactRelationFunction,"FactRelationFunction",NULL);
+   AddUDF(theEnv,"fact-slot-value","*",2,2,";lf;y",FactSlotValueFunction,"FactSlotValueFunction",NULL);
+   AddUDF(theEnv,"fact-slot-names","*",1,1,"lf",FactSlotNamesFunction,"FactSlotNamesFunction",NULL);
+   AddUDF(theEnv,"get-fact-list","m",0,1,"y",GetFactListFunction,"GetFactListFunction",NULL);
+   AddUDF(theEnv,"ppfact","vs",1,3,"*;lf;ldsyn",PPFactFunction,"PPFactFunction",NULL);
+   AddUDF(theEnv,"fact-addressp","b",1,1,NULL,FactAddresspFunction,"FactAddresspFunction",NULL);
+#else
+#if MAC_XCD
+#pragma unused(theEnv)
+#endif
+#endif
+  }
+
+/**********************************************/
+/* FactRelationFunction: H/L access routine   */
+/*   for the fact-relation function.          */
+/**********************************************/
+void FactRelationFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Fact *theFact;
+
+   theFact = GetFactAddressOrIndexArgument(context,true);
+
+   if (theFact == NULL)
+     {
+      returnValue->lexemeValue = FalseSymbol(theEnv);
+      return;
+     }
+
+   returnValue->value = FactRelation(theFact);
+  }
+
+/**************************************/
+/* FactRelation: C access routine for */
+/*   the fact-relation function.      */
+/**************************************/
+CLIPSLexeme *FactRelation(
+  Fact *theFact)
+  {
+   return theFact->whichDeftemplate->header.name;
+  }
+
+/***************************************/
+/* FactDeftemplate: C access routine   */
+/*   to retrieve a fact's deftemplate. */
+/***************************************/
+Deftemplate *FactDeftemplate(
+  Fact *theFact)
+  {
+   return theFact->whichDeftemplate;
+  }
+
+/********************************************/
+/* FactExistpFunction: H/L access routine   */
+/*   for the fact-existp function.          */
+/********************************************/
+void FactExistpFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Fact *theFact;
+
+   theFact = GetFactAddressOrIndexArgument(context,false);
+
+   returnValue->lexemeValue = CreateBoolean(theEnv,FactExistp(theFact));
+  }
+
+/***********************************/
+/* FactExistp: C access routine    */
+/*   for the fact-existp function. */
+/***********************************/
+bool FactExistp(
+  Fact *theFact)
+  {
+   if (theFact == NULL) return false;
+
+   if (theFact->garbage) return false;
+
+   if (theFact->factIndex == 0LL) return false;
+
+   return true;
+  }
+
+/********************************************/
+/* FactAddresspFunction: H/L access routine */
+/*   for the fact-addressp function.        */
+/********************************************/
+void FactAddresspFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue item;
+
+   if (! UDFFirstArgument(context,ANY_TYPE_BITS,&item))
+     { return; }
+
+   if (CVIsType(&item,FACT_ADDRESS_BIT))
+     { returnValue->lexemeValue = TrueSymbol(theEnv); }
+   else
+     { returnValue->lexemeValue = FalseSymbol(theEnv); }
+  }
+
+/***********************************************/
+/* FactSlotValueFunction: H/L access routine   */
+/*   for the fact-slot-value function.         */
+/***********************************************/
+void FactSlotValueFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Fact *theFact;
+   UDFValue theArg;
+   CLIPSValue result;
+
+   /*================================*/
+   /* Get the reference to the fact. */
+   /*================================*/
+
+   theFact = GetFactAddressOrIndexArgument(context,true);
+   if (theFact == NULL)
+     {
+      returnValue->lexemeValue = FalseSymbol(theEnv);
+      return;
+     }
+
+   /*===========================*/
+   /* Get the name of the slot. */
+   /*===========================*/
+
+   if (! UDFNextArgument(context,SYMBOL_BIT,&theArg))
+     { return; }
+
+   /*=======================*/
+   /* Get the slot's value. */
+   /*=======================*/
+
+   FactSlotValue(theEnv,theFact,theArg.lexemeValue->contents,&result);
+   CLIPSToUDFValue(&result,returnValue);
+  }
+
+/***************************************/
+/* FactSlotValue: C access routine for */
+/*   the fact-slot-value function.     */
+/***************************************/
+void FactSlotValue(
+  Environment *theEnv,
+  Fact *theFact,
+  const char *theSlotName,
+  CLIPSValue *returnValue)
+  {
+   /*==================================================*/
+   /* Make sure the slot exists (the symbol implied is */
+   /* used for the implied slot of an ordered fact).   */
+   /*==================================================*/
+
+   if (theFact->whichDeftemplate->implied)
+     {
+      if (strcmp(theSlotName,"implied") != 0)
+        {
+         SetEvaluationError(theEnv,true);
+         InvalidDeftemplateSlotMessage(theEnv,theSlotName,
+                                       theFact->whichDeftemplate->header.name->contents,false);
+         returnValue->lexemeValue = FalseSymbol(theEnv);
+         return;
+        }
+     }
+
+   else if (FindSlot(theFact->whichDeftemplate,CreateSymbol(theEnv,theSlotName),NULL) == NULL)
+     {
+      SetEvaluationError(theEnv,true);
+      InvalidDeftemplateSlotMessage(theEnv,theSlotName,
+                                    theFact->whichDeftemplate->header.name->contents,false);
+      returnValue->lexemeValue = FalseSymbol(theEnv);
+      return;
+     }
+
+   /*==========================*/
+   /* Return the slot's value. */
+   /*==========================*/
+
+   if (theFact->whichDeftemplate->implied)
+     { GetFactSlot(theFact,NULL,returnValue); }
+   else
+     { GetFactSlot(theFact,theSlotName,returnValue); }
+  }
+
+/***********************************************/
+/* FactSlotNamesFunction: H/L access routine   */
+/*   for the fact-slot-names function.         */
+/***********************************************/
+void FactSlotNamesFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Fact *theFact;
+   CLIPSValue result;
+
+   /*================================*/
+   /* Get the reference to the fact. */
+   /*================================*/
+
+   theFact = GetFactAddressOrIndexArgument(context,true);
+   if (theFact == NULL)
+     {
+      returnValue->lexemeValue = FalseSymbol(theEnv);
+      return;
+     }
+
+   /*=====================*/
+   /* Get the slot names. */
+   /*=====================*/
+
+   FactSlotNames(theFact,&result);
+   CLIPSToUDFValue(&result,returnValue);
+  }
+
+/***************************************/
+/* FactSlotNames: C access routine     */
+/*   for the fact-slot-names function. */
+/***************************************/
+void FactSlotNames(
+  Fact *theFact,
+  CLIPSValue *returnValue)
+  {
+   Multifield *theList;
+   struct templateSlot *theSlot;
+   unsigned long count;
+   Environment *theEnv = theFact->whichDeftemplate->header.env;
+
+   /*===============================================*/
+   /* If we're dealing with an implied deftemplate, */
+   /* then the only slot names is "implied."        */
+   /*===============================================*/
+
+   if (theFact->whichDeftemplate->implied)
+     {
+      theList = CreateMultifield(theEnv,1);
+      theList->contents[0].lexemeValue = CreateSymbol(theEnv,"implied");
+      returnValue->value = theList;
+      return;
+     }
+
+   /*=================================*/
+   /* Count the number of slot names. */
+   /*=================================*/
+
+   for (count = 0, theSlot = theFact->whichDeftemplate->slotList;
+        theSlot != NULL;
+        count++, theSlot = theSlot->next)
+     { /* Do Nothing */ }
+
+   /*=============================================================*/
+   /* Create a multifield value in which to store the slot names. */
+   /*=============================================================*/
+
+   theList = CreateMultifield(theEnv,count);
+   returnValue->value = theList;
+
+   /*===============================================*/
+   /* Store the slot names in the multifield value. */
+   /*===============================================*/
+
+   for (count = 0, theSlot = theFact->whichDeftemplate->slotList;
+        theSlot != NULL;
+        count++, theSlot = theSlot->next)
+     {
+      theList->contents[count].lexemeValue = theSlot->slotName;
+     }
+  }
+
+/*********************************************/
+/* GetFactListFunction: H/L access routine   */
+/*   for the get-fact-list function.         */
+/*********************************************/
+void GetFactListFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Defmodule *theModule;
+   UDFValue theArg;
+   CLIPSValue result;
+
+   /*===========================================*/
+   /* Determine if a module name was specified. */
+   /*===========================================*/
+
+   if (UDFHasNextArgument(context))
+     {
+      if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
+        { return; }
+
+      if ((theModule = FindDefmodule(theEnv,theArg.lexemeValue->contents)) == NULL)
+        {
+         if (strcmp("*",theArg.lexemeValue->contents) != 0)
+           {
+            SetMultifieldErrorValue(theEnv,returnValue);
+            UDFInvalidArgumentMessage(context,"defmodule name");
+            return;
+           }
+
+         theModule = NULL;
+        }
+     }
+   else
+     { theModule = GetCurrentModule(theEnv); }
+
+   /*=====================*/
+   /* Get the constructs. */
+   /*=====================*/
+
+   GetFactList(theEnv,&result,theModule);
+   CLIPSToUDFValue(&result,returnValue);
+  }
+
+/*************************************/
+/* GetFactList: C access routine     */
+/*   for the get-fact-list function. */
+/*************************************/
+void GetFactList(
+  Environment *theEnv,
+  CLIPSValue *returnValue,
+  Defmodule *theModule)
+  {
+   Fact *theFact;
+   unsigned long count;
+   Multifield *theList;
+
+   /*==========================*/
+   /* Save the current module. */
+   /*==========================*/
+
+   SaveCurrentModule(theEnv);
+
+   /*============================================*/
+   /* Count the number of facts to be retrieved. */
+   /*============================================*/
+
+   if (theModule == NULL)
+     {
+      for (theFact = GetNextFact(theEnv,NULL), count = 0;
+           theFact != NULL;
+           theFact = GetNextFact(theEnv,theFact), count++)
+        { /* Do Nothing */ }
+     }
+   else
+     {
+      SetCurrentModule(theEnv,theModule);
+      UpdateDeftemplateScope(theEnv);
+      for (theFact = GetNextFactInScope(theEnv,NULL), count = 0;
+           theFact != NULL;
+           theFact = GetNextFactInScope(theEnv,theFact), count++)
+        { /* Do Nothing */ }
+     }
+
+   /*===========================================================*/
+   /* Create the multifield value to store the construct names. */
+   /*===========================================================*/
+
+   theList = CreateMultifield(theEnv,count);
+   returnValue->value = theList;
+
+   /*==================================================*/
+   /* Store the fact pointers in the multifield value. */
+   /*==================================================*/
+
+   if (theModule == NULL)
+     {
+      for (theFact = GetNextFact(theEnv,NULL), count = 0;
+           theFact != NULL;
+           theFact = GetNextFact(theEnv,theFact), count++)
+        {
+         theList->contents[count].factValue = theFact;
+        }
+     }
+   else
+     {
+      for (theFact = GetNextFactInScope(theEnv,NULL), count = 0;
+           theFact != NULL;
+           theFact = GetNextFactInScope(theEnv,theFact), count++)
+        {
+         theList->contents[count].factValue = theFact;
+        }
+     }
+
+   /*=============================*/
+   /* Restore the current module. */
+   /*=============================*/
+
+   RestoreCurrentModule(theEnv);
+   UpdateDeftemplateScope(theEnv);
+  }
+
+/**************************************/
+/* PPFactFunction: H/L access routine */
+/*   for the ppfact function.         */
+/**************************************/
+void PPFactFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Fact *theFact;
+   const char *logicalName = NULL;      /* Avoids warning */
+   bool ignoreDefaults = false;
+   UDFValue theArg;
+
+   theFact = GetFactAddressOrIndexArgument(context,true);
+   if (theFact == NULL) return;
+
+   /*===============================================================*/
+   /* Determine the logical name to which the fact will be printed. */
+   /*===============================================================*/
+
+   if (UDFHasNextArgument(context))
+     {
+      logicalName = GetLogicalName(context,STDOUT);
+      if (logicalName == NULL)
+        {
+         IllegalLogicalNameMessage(theEnv,"ppfact");
+         SetHaltExecution(theEnv,true);
+         SetEvaluationError(theEnv,true);
+         return;
+        }
+     }
+   else
+     { logicalName = STDOUT; }
+
+   /*=========================================*/
+   /* Should slot values be printed if they   */
+   /* are the same as the default slot value. */
+   /*=========================================*/
+
+   if (UDFHasNextArgument(context))
+     {
+      UDFNextArgument(context,ANY_TYPE_BITS,&theArg);
+
+      if (theArg.value == FalseSymbol(theEnv))
+        { ignoreDefaults = false; }
+      else
+        { ignoreDefaults = true; }
+     }
+
+   /*============================================================*/
+   /* Determine if any router recognizes the output destination. */
+   /*============================================================*/
+
+   if (strcmp(logicalName,"nil") == 0)
+     {
+      StringBuilder *theSB;
+      
+      theSB = CreateStringBuilder(theEnv,256);
+      
+      FactPPForm(theFact,theSB,ignoreDefaults);
+      returnValue->lexemeValue = CreateString(theEnv,theSB->contents);
+      
+      SBDispose(theSB);
+
+      return;
+     }
+   else if (QueryRouters(theEnv,logicalName) == false)
+     {
+      UnrecognizedRouterMessage(theEnv,logicalName);
+      return;
+     }
+
+   PPFact(theFact,logicalName,ignoreDefaults);
+  }
+
+/******************************/
+/* PPFact: C access routine   */
+/*   for the ppfact function. */
+/******************************/
+void PPFact(
+  Fact *theFact,
+  const char *logicalName,
+  bool ignoreDefaults)
+  {
+   Environment *theEnv = theFact->whichDeftemplate->header.env;
+   
+   if (theFact == NULL) return;
+
+   if (theFact->garbage) return;
+
+   PrintFact(theEnv,logicalName,theFact,true,ignoreDefaults,NULL);
+
+   WriteString(theEnv,logicalName,"\n");
+  }
+
+/**************************************************************/
+/* GetFactAddressOrIndexArgument: Retrieves an argument for a */
+/*   function which should be a reference to a valid fact.    */
+/**************************************************************/
+Fact *GetFactAddressOrIndexArgument(
+  UDFContext *context,
+  bool noFactError)
+  {
+   UDFValue theArg;
+   long long factIndex;
+   Fact *theFact;
+   Environment *theEnv = context->environment;
+   char tempBuffer[20];
+
+   if (! UDFNextArgument(context,ANY_TYPE_BITS,&theArg))
+     { return NULL; }
+
+   if (theArg.header->type == FACT_ADDRESS_TYPE)
+     {
+      if (theArg.factValue->garbage)
+        {
+         if (noFactError)
+           {
+            FactRetractedErrorMessage(theEnv,theArg.factValue);
+            SetEvaluationError(theEnv,true);
+           }
+         return NULL;
+        }
+      else return theArg.factValue;
+     }
+   else if (theArg.header->type == INTEGER_TYPE)
+     {
+      factIndex = theArg.integerValue->contents;
+      if (factIndex < 0)
+        {
+         UDFInvalidArgumentMessage(context,"fact-address or fact-index");
+         return NULL;
+        }
+
+      theFact = FindIndexedFact(theEnv,factIndex);
+      if ((theFact == NULL) && noFactError)
+        {
+         gensnprintf(tempBuffer,sizeof(tempBuffer),"f-%lld",factIndex);
+         CantFindItemErrorMessage(theEnv,"fact",tempBuffer,false);
+         return NULL;
+        }
+
+      return theFact;
+     }
+
+   UDFInvalidArgumentMessage(context,"fact-address or fact-index");
+   return NULL;
+  }
+
+#endif /* DEFTEMPLATE_CONSTRUCT */
+
+