miscfun.c

clips源代码

   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*             CLIPS Version 6.24  05/17/06            */
   /*                                                     */
   /*            MISCELLANEOUS FUNCTIONS MODULE           */
   /*******************************************************/

/*************************************************************/
/* Purpose:                                                  */
/*                                                           */
/* Principal Programmer(s):                                  */
/*      Gary D. Riley                                        */
/*                                                           */
/* Contributing Programmer(s):                               */
/*      Brian L. Donnell                                     */
/*                                                           */
/* Revision History:                                         */
/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
/*                                                           */
/*            Corrected compilation errors for files         */
/*            generated by constructs-to-c. DR0861           */
/*                                                           */
/*            Changed name of variable exp to theExp         */
/*            because of Unix compiler warnings of shadowed  */
/*            definitions.                                   */
/*                                                           */
/*      6.24: Removed CONFLICT_RESOLUTION_STRATEGIES,        */
/*            DYNAMIC_SALIENCE, INCREMENTAL_RESET,           */
/*            LOGICAL_DEPENDENCIES, IMPERATIVE_METHODS       */
/*            INSTANCE_PATTERN_MATCHING,                     */
/*            IMPERATIVE_MESSAGE_HANDLERS, and               */
/*            AUXILIARY_MESSAGE_HANDLERS compilation flags.  */
/*                                                           */
/*            Renamed BOOLEAN macro type to intBool.         */
/*                                                           */
/*************************************************************/

#define _MISCFUN_SOURCE_

#include <stdio.h>
#define _STDIO_INCLUDED_
#include <string.h>

#include "setup.h"

#include "argacces.h"
#include "envrnmnt.h"
#include "exprnpsr.h"
#include "memalloc.h"
#include "multifld.h"
#include "router.h"
#include "sysdep.h"
#include "utility.h"

#if DEFFUNCTION_CONSTRUCT
#include "dffnxfun.h"
#endif

#include "miscfun.h"

#define MISCFUN_DATA 9

struct miscFunctionData
  { 
   long long GensymNumber;
  };

#define MiscFunctionData(theEnv) ((struct miscFunctionData *) GetEnvironmentData(theEnv,MISCFUN_DATA))

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

   static void                    ExpandFuncMultifield(void *,DATA_OBJECT *,EXPRESSION *,
                                                       EXPRESSION **,void *);

/*****************************************************************/
/* MiscFunctionDefinitions: Initializes miscellaneous functions. */
/*****************************************************************/
globle void MiscFunctionDefinitions(
  void *theEnv)
  {
   AllocateEnvironmentData(theEnv,MISCFUN_DATA,sizeof(struct miscFunctionData),NULL);
   MiscFunctionData(theEnv)->GensymNumber = 1;
   
#if ! RUN_TIME
   EnvDefineFunction2(theEnv,"gensym",           'w', PTIEF GensymFunction,      "GensymFunction", "00");
   EnvDefineFunction2(theEnv,"gensym*",          'w', PTIEF GensymStarFunction,  "GensymStarFunction", "00");
   EnvDefineFunction2(theEnv,"setgen",           'g', PTIEF SetgenFunction,      "SetgenFunction", "11i");
   EnvDefineFunction2(theEnv,"system",           'v', PTIEF gensystem,           "gensystem", "1*k");
   EnvDefineFunction2(theEnv,"length",           'g', PTIEF LengthFunction,      "LengthFunction", "11q");
   EnvDefineFunction2(theEnv,"length$",          'g', PTIEF LengthFunction,      "LengthFunction", "11q");
   EnvDefineFunction2(theEnv,"time",             'd', PTIEF TimeFunction,        "TimeFunction", "00");
   EnvDefineFunction2(theEnv,"random",           'g', PTIEF RandomFunction,      "RandomFunction", "02i");
   EnvDefineFunction2(theEnv,"seed",             'v', PTIEF SeedFunction,        "SeedFunction", "11i");
   EnvDefineFunction2(theEnv,"conserve-mem",     'v', PTIEF ConserveMemCommand,  "ConserveMemCommand", "11w");
   EnvDefineFunction2(theEnv,"release-mem",      'g', PTIEF ReleaseMemCommand,   "ReleaseMemCommand", "00");
#if DEBUGGING_FUNCTIONS
   EnvDefineFunction2(theEnv,"mem-used",         'g', PTIEF MemUsedCommand,      "MemUsedCommand", "00");
   EnvDefineFunction2(theEnv,"mem-requests",     'g', PTIEF MemRequestsCommand,  "MemRequestsCommand", "00");
#endif
   EnvDefineFunction2(theEnv,"options",          'v', PTIEF OptionsCommand,      "OptionsCommand", "00");
   EnvDefineFunction2(theEnv,"(expansion-call)", 'u', PTIEF ExpandFuncCall,      "ExpandFuncCall",NULL);
   EnvDefineFunction2(theEnv,"expand$",'u', PTIEF DummyExpandFuncMultifield,
                                           "DummyExpandFuncMultifield","11m");
   FuncSeqOvlFlags(theEnv,"expand$",FALSE,FALSE);
   EnvDefineFunction2(theEnv,"(set-evaluation-error)",
                                       'w', PTIEF CauseEvaluationError,"CauseEvaluationError",NULL);
   EnvDefineFunction2(theEnv,"set-sequence-operator-recognition",
                                       'b', PTIEF SetSORCommand,"SetSORCommand","11w");
   EnvDefineFunction2(theEnv,"get-sequence-operator-recognition",'b',
                    PTIEF EnvGetSequenceOperatorRecognition,"EnvGetSequenceOperatorRecognition","00");
   EnvDefineFunction2(theEnv,"get-function-restrictions",'s',
                   PTIEF GetFunctionRestrictions,"GetFunctionRestrictions","11w");
   EnvDefineFunction2(theEnv,"create$",     'm', PTIEF CreateFunction,  "CreateFunction", NULL);
   EnvDefineFunction2(theEnv,"mv-append",   'm', PTIEF CreateFunction,  "CreateFunction", NULL);
   EnvDefineFunction2(theEnv,"apropos",   'v', PTIEF AproposCommand,  "AproposCommand", "11w");
   EnvDefineFunction2(theEnv,"get-function-list",   'm', PTIEF GetFunctionListFunction,  "GetFunctionListFunction", "00");
   EnvDefineFunction2(theEnv,"funcall",'u', PTIEF FuncallFunction,"FuncallFunction","1**k");
   EnvDefineFunction2(theEnv,"timer",'d', PTIEF TimerFunction,"TimerFunction","**");
#endif
  }

/******************************************************************/
/* CreateFunction: H/L access routine for the create$ function.   */
/******************************************************************/
globle void CreateFunction(
  void *theEnv,
  DATA_OBJECT_PTR returnValue)
  {
   StoreInMultifield(theEnv,returnValue,GetFirstArgument(),TRUE);
  }

/*****************************************************************/
/* SetgenFunction: H/L access routine for the setgen function.   */
/*****************************************************************/
globle long long SetgenFunction(
  void *theEnv)
  {
   long long theLong;
   DATA_OBJECT theValue;

   /*==========================================================*/
   /* Check to see that a single integer argument is provided. */
   /*==========================================================*/

   if (EnvArgCountCheck(theEnv,"setgen",EXACTLY,1) == -1) return(MiscFunctionData(theEnv)->GensymNumber);
   if (EnvArgTypeCheck(theEnv,"setgen",1,INTEGER,&theValue) == FALSE) return(MiscFunctionData(theEnv)->GensymNumber);

   /*========================================*/
   /* The integer must be greater than zero. */
   /*========================================*/

   theLong = ValueToLong(theValue.value);

   if (theLong < 1LL)
     {
      ExpectedTypeError1(theEnv,"setgen",1,"number (greater than or equal to 1)");
      return(MiscFunctionData(theEnv)->GensymNumber);
     }

   /*====================================*/
   /* Set the gensym index to the number */
   /* provided and return this value.    */
   /*====================================*/

   MiscFunctionData(theEnv)->GensymNumber = theLong;
   return(theLong);
  }

/****************************************/
/* GensymFunction: H/L access routine   */
/*   for the gensym function.           */
/****************************************/
globle void *GensymFunction(
  void *theEnv)
  {
   char genstring[128];
   
   /*===========================================*/
   /* The gensym function accepts no arguments. */
   /*===========================================*/

   EnvArgCountCheck(theEnv,"gensym",EXACTLY,0);

   /*================================================*/
   /* Create a symbol using the current gensym index */
   /* as the postfix.                                */
   /*================================================*/

   gensprintf(genstring,"gen%lld",MiscFunctionData(theEnv)->GensymNumber);
   MiscFunctionData(theEnv)->GensymNumber++;

   /*====================*/
   /* Return the symbol. */
   /*====================*/

   return(EnvAddSymbol(theEnv,genstring));
  }

/************************************************/
/* GensymStarFunction: H/L access routine for   */
/*   the gensym* function.                      */
/************************************************/
globle void *GensymStarFunction(
  void *theEnv)
  {
   /*============================================*/
   /* The gensym* function accepts no arguments. */
   /*============================================*/

   EnvArgCountCheck(theEnv,"gensym*",EXACTLY,0);

   /*====================*/
   /* Return the symbol. */
   /*====================*/

   return(GensymStar(theEnv));
  }

/************************************/
/* GensymStar: C access routine for */
/*   the gensym* function.          */
/************************************/
globle void *GensymStar(
  void *theEnv)
  {
   char genstring[128];
   
   /*=======================================================*/
   /* Create a symbol using the current gensym index as the */
   /* postfix. If the symbol is already present in the      */
   /* symbol table, then continue generating symbols until  */
   /* a unique symbol is found.                             */
   /*=======================================================*/

   do
     {
      gensprintf(genstring,"gen%lld",MiscFunctionData(theEnv)->GensymNumber);
      MiscFunctionData(theEnv)->GensymNumber++;
     }
   while (FindSymbolHN(theEnv,genstring) != NULL);

   /*====================*/
   /* Return the symbol. */
   /*====================*/

   return(EnvAddSymbol(theEnv,genstring));
  }

/********************************************/
/* RandomFunction: H/L access routine for   */
/*   the random function.                   */
/********************************************/
globle long long RandomFunction(
  void *theEnv)
  {
   int argCount;
   long long rv;
   DATA_OBJECT theValue;
   long long begin, end;

   /*====================================*/
   /* The random function accepts either */
   /* zero or two arguments.             */
   /*====================================*/

   argCount = EnvRtnArgCount(theEnv);
   
   if ((argCount != 0) && (argCount != 2))
     {
      PrintErrorID(theEnv,"MISCFUN",2,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Function random expected either 0 or 2 arguments\n"); 
     }

   /*========================================*/
   /* Return the randomly generated integer. */
   /*========================================*/

   rv = genrand();
   
   if (argCount == 2)
     {
      if (EnvArgTypeCheck(theEnv,"random",1,INTEGER,&theValue) == FALSE) return(rv);
      begin = DOToLong(theValue);
      if (EnvArgTypeCheck(theEnv,"random",2,INTEGER,&theValue) == FALSE) return(rv);
      end = DOToLong(theValue);
      if (end < begin)
        {
         PrintErrorID(theEnv,"MISCFUN",3,FALSE);
         EnvPrintRouter(theEnv,WERROR,"Function random expected argument #1 to be less than argument #2\n"); 
         return(rv);
        }
        
      rv = begin + (rv % ((end - begin) + 1));
     }
   
   
   return(rv);
  }

/******************************************/
/* SeedFunction: H/L access routine for   */
/*   the seed function.                   */
/******************************************/
globle void SeedFunction(
  void *theEnv)
  {
   DATA_OBJECT theValue;

   /*==========================================================*/
   /* Check to see that a single integer argument is provided. */
   /*==========================================================*/

   if (EnvArgCountCheck(theEnv,"seed",EXACTLY,1) == -1) return;
   if (EnvArgTypeCheck(theEnv,"seed",1,INTEGER,&theValue) == FALSE) return;

   /*=============================================================*/
   /* Seed the random number generator with the provided integer. */
   /*=============================================================*/

   genseed((int) DOToLong(theValue));
  }

/********************************************/
/* LengthFunction: H/L access routine for   */
/*   the length$ function.                  */
/********************************************/
globle long long LengthFunction(
  void *theEnv)
  {
   DATA_OBJECT item;

   /*====================================================*/
   /* The length$ function expects exactly one argument. */
   /*====================================================*/

   if (EnvArgCountCheck(theEnv,"length$",EXACTLY,1) == -1) return(-1L);
   EnvRtnUnknown(theEnv,1,&item);

   /*====================================================*/
   /* If the argument is a string or symbol, then return */
   /* the number of characters in the argument.          */
   /*====================================================*/

   if ((GetType(item) == STRING) || (GetType(item) == SYMBOL))
     {  return( (long) strlen(DOToString(item))); }

   /*====================================================*/
   /* If the argument is a multifield value, then return */
   /* the number of fields in the argument.              */
   /*====================================================*/

   if (GetType(item) == MULTIFIELD)
     { return ( (long) GetDOLength(item)); }

   /*=============================================*/
   /* If the argument wasn't a string, symbol, or */
   /* multifield value, then generate an error.   */
   /*=============================================*/

   SetEvaluationError(theEnv,TRUE);
   ExpectedTypeError2(theEnv,"length$",1);
   return(-1L);
  }

/*******************************************/
/* ReleaseMemCommand: H/L access routine   */
/*   for the release-mem function.         */
/*******************************************/
globle long long ReleaseMemCommand(
  void *theEnv)
  {
   /*================================================*/
   /* The release-mem function accepts no arguments. */
   /*================================================*/

   if (EnvArgCountCheck(theEnv,"release-mem",EXACTLY,0) == -1) return(0LL);

   /*========================================*/
   /* Release memory to the operating system */
   /* and return the amount of memory freed. */
   /*========================================*/

   return(EnvReleaseMem(theEnv,-1L,FALSE));
  }

/******************************************/
/* ConserveMemCommand: H/L access routine */
/*   for the conserve-mem command.        */
/******************************************/
globle void ConserveMemCommand(
  void *theEnv)
  {
   char *argument;
   DATA_OBJECT theValue;

   /*===================================*/
   /* The conserve-mem function expects */
   /* a single symbol argument.         */
   /*===================================*/

   if (EnvArgCountCheck(theEnv,"conserve-mem",EXACTLY,1) == -1) return;
   if (EnvArgTypeCheck(theEnv,"conserve-mem",1,SYMBOL,&theValue) == FALSE) return;

   argument = DOToString(theValue);

   /*====================================================*/
   /* If the argument is the symbol "on", then store the */
   /* pretty print representation of a construct when it */
   /* is defined.                                        */
   /*====================================================*/

   if (strcmp(argument,"on") == 0)
     { EnvSetConserveMemory(theEnv,TRUE); }

   /*======================================================*/
   /* Otherwise, if the argument is the symbol "off", then */
   /* don't store the pretty print representation of a     */
   /* construct when it is defined.                        */
   /*======================================================*/

   else if (strcmp(argument,"off") == 0)