Esempio n. 1
0
/************************************************************************************
  NAME         : MessageHandlerExistPCommand
  DESCRIPTION  : Determines if a message-handler is present in a class
  INPUTS       : None
  RETURNS      : TRUE if the message header is present, FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (message-handler-existp <class> <hnd> [<type>])
 ************************************************************************************/
globle int MessageHandlerExistPCommand(
  void *theEnv)
  {
   DEFCLASS *cls;
   SYMBOL_HN *mname;
   DATA_OBJECT temp;
   unsigned mtype = MPRIMARY;
   
   if (EnvArgTypeCheck(theEnv,"message-handler-existp",1,SYMBOL,&temp) == FALSE)
     return(FALSE);
   cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
   if (cls == NULL)
     {
      ClassExistError(theEnv,"message-handler-existp",DOToString(temp));
      return(FALSE);
     }
   if (EnvArgTypeCheck(theEnv,"message-handler-existp",2,SYMBOL,&temp) == FALSE)
     return(FALSE);
   mname = (SYMBOL_HN *) GetValue(temp);
   if (EnvRtnArgCount(theEnv) == 3)
     {
      if (EnvArgTypeCheck(theEnv,"message-handler-existp",3,SYMBOL,&temp) == FALSE)
        return(FALSE);
      mtype = HandlerType(theEnv,"message-handler-existp",DOToString(temp));
      if (mtype == MERROR)
        {
         SetEvaluationError(theEnv,TRUE);
         return(FALSE);
        }
     }
   if (FindHandlerByAddress(cls,mname,mtype) != NULL)
     return(TRUE);
   return(FALSE);
  }
Esempio n. 2
0
/******************************************************
  NAME         : CheckTwoClasses
  DESCRIPTION  : Checks for exactly two class arguments
                    for a H/L function
  INPUTS       : 1) The function name
                 2) Caller's buffer for first class
                 3) Caller's buffer for second class
  RETURNS      : TRUE if both found, FALSE otherwise
  SIDE EFFECTS : Caller's buffers set
  NOTES        : Assumes exactly 2 arguments
 ******************************************************/
static int CheckTwoClasses(
  void *theEnv,
  char *func,
  DEFCLASS **c1,
  DEFCLASS **c2)
  {
   DATA_OBJECT temp;

   if (EnvArgTypeCheck(theEnv,func,1,SYMBOL,&temp) == FALSE)
     return(FALSE);
   *c1 = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
   if (*c1 == NULL)
     {
      ClassExistError(theEnv,func,ValueToString(temp.value));
      return(FALSE);
     }
   if (EnvArgTypeCheck(theEnv,func,2,SYMBOL,&temp) == FALSE)
     return(FALSE);
   *c2 = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
   if (*c2 == NULL)
     {
      ClassExistError(theEnv,func,ValueToString(temp.value));
      return(FALSE);
     }
   return(TRUE);
  }
Esempio n. 3
0
/****************************************************************
  NAME         : BrowseClassesCommand
  DESCRIPTION  : Displays a "graph" of the class hierarchy
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : Syntax : (browse-classes [<class>])
 ****************************************************************/
globle void BrowseClassesCommand(
  void *theEnv)
  {
   register DEFCLASS *cls;
   
   if (EnvRtnArgCount(theEnv) == 0)
      /* ================================================
         Find the OBJECT root class (has no superclasses)
         ================================================ */
      cls = LookupDefclassByMdlOrScope(theEnv,OBJECT_TYPE_NAME);
   else
     {
      DATA_OBJECT tmp;

      if (EnvArgTypeCheck(theEnv,"browse-classes",1,SYMBOL,&tmp) == FALSE)
        return;
      cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
      if (cls == NULL)
        {
         ClassExistError(theEnv,"browse-classes",DOToString(tmp));
         return;
        }
     }
   EnvBrowseClasses(theEnv,WDISPLAY,(void *) cls);
  }
Esempio n. 4
0
globle void StrIndexFunction(
  void *theEnv,
  DATA_OBJECT_PTR result)
  {
   DATA_OBJECT theArgument1, theArgument2;
   char *strg1, *strg2;
   int i, j;

   result->type = SYMBOL;
   result->value = EnvFalseSymbol(theEnv);

   /*===================================*/
   /* Check and retrieve the arguments. */
   /*===================================*/

   if (EnvArgCountCheck(theEnv,"str-index",EXACTLY,2) == -1) return;

   if (EnvArgTypeCheck(theEnv,"str-index",1,SYMBOL_OR_STRING,&theArgument1) == FALSE) return;

   if (EnvArgTypeCheck(theEnv,"str-index",2,SYMBOL_OR_STRING,&theArgument2) == FALSE) return;

   strg1 = DOToString(theArgument1);
   strg2 = DOToString(theArgument2);

   /*=================================*/
   /* Find the position in string2 of */
   /* string1 (counting from 1).      */
   /*=================================*/

   if (strlen(strg1) == 0)
     {
      result->type = INTEGER;
      result->value = (void *) EnvAddLong(theEnv,(long) strlen(strg2) + 1L);
      return;
     }

   for (i=1; *strg2; i++, strg2++)
     {
      for (j=0; *(strg1+j) && *(strg1+j) == *(strg2+j); j++)
        { /* Do Nothing */ }

      if (*(strg1+j) == '\0')
        {
         result->type = INTEGER;
         result->value = (void *) EnvAddLong(theEnv,(long) i);
         return;
        }
     }

   return;
  }
Esempio n. 5
0
globle long int StrCompareFunction(
  void *theEnv)
  {
   int numArgs, length;
   DATA_OBJECT arg1, arg2, arg3;
   long returnValue;

   /*=======================================================*/
   /* Function str-compare expects either 2 or 3 arguments. */
   /*=======================================================*/

   if ((numArgs = EnvArgRangeCheck(theEnv,"str-compare",2,3)) == -1) return(0L);

   /*=============================================================*/
   /* The first two arguments should be of type symbol or string. */
   /*=============================================================*/

   if (EnvArgTypeCheck(theEnv,"str-compare",1,SYMBOL_OR_STRING,&arg1) == FALSE)
     { return(0L); }

   if (EnvArgTypeCheck(theEnv,"str-compare",2,SYMBOL_OR_STRING,&arg2) == FALSE)
     { return(0L); }

   /*===================================================*/
   /* Compare the strings. Use the 3rd argument for the */
   /* maximum length of comparison, if it is provided.  */
   /*===================================================*/

   if (numArgs == 3)
     {
      if (EnvArgTypeCheck(theEnv,"str-compare",3,INTEGER,&arg3) == FALSE)
        { return(0L); }

      length = CoerceToInteger(GetType(arg3),GetValue(arg3));
      returnValue = strncmp(DOToString(arg1),DOToString(arg2),
                            (STD_SIZE) length);
     }
   else
     { returnValue = strcmp(DOToString(arg1),DOToString(arg2)); }

   /*========================================================*/
   /* Return Values are as follows:                          */
   /* -1 is returned if <string-1> is less than <string-2>.  */
   /*  1 is return if <string-1> is greater than <string-2>. */
   /*  0 is returned if <string-1> is equal to <string-2>.   */
   /*========================================================*/

   if (returnValue < 0) returnValue = -1;
   else if (returnValue > 0) returnValue = 1;
   return(returnValue);
  }
Esempio n. 6
0
globle void GetFactListFunction(
  void *theEnv,
  DATA_OBJECT_PTR returnValue)
  {
   struct defmodule *theModule;
   DATA_OBJECT result;
   int numArgs;

   /*===========================================*/
   /* Determine if a module name was specified. */
   /*===========================================*/

   if ((numArgs = EnvArgCountCheck(theEnv,"get-fact-list",NO_MORE_THAN,1)) == -1)
     {
      EnvSetMultifieldErrorValue(theEnv,returnValue);
      return;
     }

   if (numArgs == 1)
     {
      EnvRtnUnknown(theEnv,1,&result);

      if (GetType(result) != SYMBOL)
        {
         EnvSetMultifieldErrorValue(theEnv,returnValue);
         ExpectedTypeError1(theEnv,"get-fact-list",1,"defmodule name");
         return;
        }

      if ((theModule = (struct defmodule *) EnvFindDefmodule(theEnv,DOToString(result))) == NULL)
        {
         if (strcmp("*",DOToString(result)) != 0)
           {
            EnvSetMultifieldErrorValue(theEnv,returnValue);
            ExpectedTypeError1(theEnv,"get-fact-list",1,"defmodule name");
            return;
           }

         theModule = NULL;
        }
     }
   else
     { theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv)); }

   /*=====================*/
   /* Get the constructs. */
   /*=====================*/

   EnvGetFactList(theEnv,returnValue,theModule);
  }
Esempio n. 7
0
globle struct defmodule *GetModuleName(
  void *theEnv,
  char *functionName,
  int whichArgument,
  int *error)
  {
   DATA_OBJECT result;
   struct defmodule *theModule;

   *error = FALSE;

   /*========================*/
   /* Retrieve the argument. */
   /*========================*/

   EnvRtnUnknown(theEnv,whichArgument,&result);

   /*=================================*/
   /* A module name must be a symbol. */
   /*=================================*/

   if (GetType(result) != SYMBOL)
     {
      ExpectedTypeError1(theEnv,functionName,whichArgument,"defmodule name");
      *error = TRUE;
      return(NULL);
     }

   /*=======================================*/
   /* Check to see that the symbol actually */
   /* corresponds to a defined module.      */
   /*=======================================*/

   if ((theModule = (struct defmodule *) EnvFindDefmodule(theEnv,DOToString(result))) == NULL)
     {
      if (strcmp("*",DOToString(result)) != 0)
        {
         ExpectedTypeError1(theEnv,functionName,whichArgument,"defmodule name");
         *error = TRUE;
        }
      return(NULL);
     }

   /*=================================*/
   /* Return a pointer to the module. */
   /*=================================*/

   return(theModule);
  }
Esempio n. 8
0
/*******************************************************************************
  NAME         : PPDefmessageHandlerCommand
  DESCRIPTION  : Displays the pretty-print form (if any) for a handler
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax: (ppdefmessage-handler <class> <message> [<type>])
 *******************************************************************************/
globle void PPDefmessageHandlerCommand(
  void *theEnv)
  {
   DATA_OBJECT temp;
   SYMBOL_HN *csym,*msym;
   const char *tname;
   DEFCLASS *cls = NULL;
   unsigned mtype;
   HANDLER *hnd;

   if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",1,SYMBOL,&temp) == FALSE)
     return;
   csym = FindSymbolHN(theEnv,DOToString(temp));
   if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",2,SYMBOL,&temp) == FALSE)
     return;
   msym = FindSymbolHN(theEnv,DOToString(temp));
   if (EnvRtnArgCount(theEnv) == 3)
     {
      if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",3,SYMBOL,&temp) == FALSE)
        return;
      tname = DOToString(temp);
     }
   else
     tname = MessageHandlerData(theEnv)->hndquals[MPRIMARY];
   mtype = HandlerType(theEnv,"ppdefmessage-handler",tname);
   if (mtype == MERROR)
     {
      EnvSetEvaluationError(theEnv,TRUE);
      return;
     }
   if (csym != NULL)
     cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(csym));
   if (((cls == NULL) || (msym == NULL)) ? TRUE :
       ((hnd = FindHandlerByAddress(cls,msym,(unsigned) mtype)) == NULL))
     {
      PrintErrorID(theEnv,"MSGCOM",2,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Unable to find message-handler ");
      EnvPrintRouter(theEnv,WERROR,ValueToString(msym));
      EnvPrintRouter(theEnv,WERROR," ");
      EnvPrintRouter(theEnv,WERROR,tname);
      EnvPrintRouter(theEnv,WERROR," for class ");
      EnvPrintRouter(theEnv,WERROR,ValueToString(csym));
      EnvPrintRouter(theEnv,WERROR," in function ppdefmessage-handler.\n");
      EnvSetEvaluationError(theEnv,TRUE);
      return;
     }
   if (hnd->ppForm != NULL)
     PrintInChunks(theEnv,WDISPLAY,hnd->ppForm);
  }
Esempio n. 9
0
  std::vector<std::string> data_object_to_strings( dataObject& clipsdo ) {
    void* mfptr;
    long int end, i;
    std::string s;
    std::vector<std::string> strings;

    switch ( GetType(clipsdo) ) {
      case SYMBOL:
      case INSTANCE_NAME:
      case STRING:
        strings.push_back( DOToString( clipsdo ) );
        break;
      case MULTIFIELD:
        end = GetDOEnd( clipsdo );
        mfptr = GetValue( clipsdo );
        for ( i = GetDOBegin( clipsdo ); i <= end; i++ ) {
          switch ( GetMFType( mfptr, i ) ) {
            case SYMBOL:
            case STRING:
            case INSTANCE_NAME:
              strings.push_back( ValueToString( GetMFValue( mfptr, i ) ) );
              break;
            default:
              break;
          }
        }
      default:
        break;
    }

    return strings;
  }
Esempio n. 10
0
/*********************************************************************
  NAME         : SlotExistPCommand
  DESCRIPTION  : Determines if a slot is present in a class
  INPUTS       : None
  RETURNS      : TRUE if the slot exists, FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (slot-existp <class> <slot> [inherit])
 *********************************************************************/
globle int SlotExistPCommand(
  void *theEnv)
  {
   DEFCLASS *cls;
   SLOT_DESC *sd;
   int inheritFlag = FALSE;
   DATA_OBJECT dobj;
   
   sd = CheckSlotExists(theEnv,"slot-existp",&cls,FALSE,TRUE);
   if (sd == NULL)
     return(FALSE);
   if (EnvRtnArgCount(theEnv) == 3)
     {
      if (EnvArgTypeCheck(theEnv,"slot-existp",3,SYMBOL,&dobj) == FALSE)
        return(FALSE);
      if (strcmp(DOToString(dobj),"inherit") != 0)
        {
         ExpectedTypeError1(theEnv,"slot-existp",3,"keyword \"inherit\"");
         SetEvaluationError(theEnv,TRUE);
         return(FALSE);
        }
      inheritFlag = TRUE;
     }
   return((sd->cls == cls) ? TRUE : inheritFlag);
  }
Esempio n. 11
0
globle void AproposCommand(
    void *theEnv)
{
    char *argument;
    DATA_OBJECT argPtr;
    struct symbolHashNode *hashPtr = NULL;
    size_t theLength;

    /*=======================================================*/
    /* The apropos command expects a single symbol argument. */
    /*=======================================================*/

    if (EnvArgCountCheck(theEnv,"apropos",EXACTLY,1) == -1) return;
    if (EnvArgTypeCheck(theEnv,"apropos",1,SYMBOL,&argPtr) == FALSE) return;

    /*=======================================*/
    /* Determine the length of the argument. */
    /*=======================================*/

    argument = DOToString(argPtr);
    theLength = strlen(argument);

    /*====================================================================*/
    /* Print each entry in the symbol table that contains the argument as */
    /* a substring. When using a non-ANSI compiler, only those strings    */
    /* that contain the substring starting at the beginning of the string */
    /* are printed.                                                       */
    /*====================================================================*/

    while ((hashPtr = GetNextSymbolMatch(theEnv,argument,theLength,hashPtr,TRUE,NULL)) != NULL)
    {
        EnvPrintRouter(theEnv,WDISPLAY,ValueToString(hashPtr));
        EnvPrintRouter(theEnv,WDISPLAY,"\n");
    }
}
Esempio n. 12
0
globle void StringToFieldFunction(
  void *theEnv,
  DATA_OBJECT *returnValue)
  {
   DATA_OBJECT theArg;

   /*========================================================*/
   /* Function string-to-field expects exactly one argument. */
   /*========================================================*/

   if (EnvArgCountCheck(theEnv,"string-to-field",EXACTLY,1) == -1)
     {
      returnValue->type = STRING;
      returnValue->value = (void *) EnvAddSymbol(theEnv,"*** ERROR ***");
      return;
     }

   /*==================================================*/
   /* The argument should be of type symbol or string. */
   /*==================================================*/

   if (EnvArgTypeCheck(theEnv,"string-to-field",1,SYMBOL_OR_STRING,&theArg) == FALSE)
     {
      returnValue->type = STRING;
      returnValue->value = (void *) EnvAddSymbol(theEnv,"*** ERROR ***");
      return;
     }

   /*================================*/
   /* Convert the string to an atom. */
   /*================================*/

   StringToField(theEnv,DOToString(theArg),returnValue);
  }
Esempio n. 13
0
globle long int StrLengthFunction(
  void *theEnv)
  {
   DATA_OBJECT theArg;

   /*===================================================*/
   /* Function str-length expects exactly one argument. */
   /*===================================================*/

   if (EnvArgCountCheck(theEnv,"str-length",EXACTLY,1) == -1)
     { return(-1L); }

   /*==================================================*/
   /* The argument should be of type symbol or string. */
   /*==================================================*/

   if (EnvArgTypeCheck(theEnv,"str-length",1,SYMBOL_OR_STRING,&theArg) == FALSE)
     { return(-1L); }

   /*============================================*/
   /* Return the length of the string or symbol. */
   /*============================================*/

   return( (long) strlen(DOToString(theArg)));
  }
Esempio n. 14
0
globle void CheckSyntaxFunction(
  DATA_OBJECT *returnValue)
  {
   DATA_OBJECT theArg;

   /*===============================*/
   /* Set up a default return value */
   /* (TRUE for problems found).    */
   /*===============================*/

   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,TrueSymbol);

   /*=====================================================*/
   /* Function check-syntax expects exactly one argument. */
   /*=====================================================*/

   if (ArgCountCheck("check-syntax",EXACTLY,1) == -1) return;

   /*========================================*/
   /* The argument should be of type STRING. */
   /*========================================*/

   if (ArgTypeCheck("check-syntax",1,STRING,&theArg) == FALSE)
     { return; }

   /*===================*/
   /* Check the syntax. */
   /*===================*/

   CheckSyntax(DOToString(theArg),returnValue);
  }
Esempio n. 15
0
globle void RemoveBreakCommand(
  void *theEnv)
  {
   DATA_OBJECT argPtr;
   char *argument;
   int nargs;
   void *defrulePtr;

   if ((nargs = EnvArgCountCheck(theEnv,"remove-break",NO_MORE_THAN,1)) == -1)
     { return; }

   if (nargs == 0)
     {
      RemoveAllBreakpoints(theEnv);
      return;
     }

   if (EnvArgTypeCheck(theEnv,"remove-break",1,SYMBOL,&argPtr) == FALSE) return;

   argument = DOToString(argPtr);

   if ((defrulePtr = EnvFindDefrule(theEnv,argument)) == NULL)
     {
      CantFindItemErrorMessage(theEnv,"defrule",argument);
      return;
     }

   if (EnvRemoveBreak(theEnv,defrulePtr) == FALSE)
     {
      EnvPrintRouter(theEnv,WERROR,"Rule ");
      EnvPrintRouter(theEnv,WERROR,argument);
      EnvPrintRouter(theEnv,WERROR," does not have a breakpoint set.\n");
     }
  }
Esempio n. 16
0
globle void EvalFunction(
  void *theEnv,
  DATA_OBJECT_PTR returnValue)
  {
   DATA_OBJECT theArg;

   /*=============================================*/
   /* Function eval expects exactly one argument. */
   /*=============================================*/

   if (EnvArgCountCheck(theEnv,"eval",EXACTLY,1) == -1)
     {
      SetpType(returnValue,SYMBOL);
      SetpValue(returnValue,EnvFalseSymbol(theEnv));
      return;
     }

   /*==================================================*/
   /* The argument should be of type SYMBOL or STRING. */
   /*==================================================*/

   if (EnvArgTypeCheck(theEnv,"eval",1,SYMBOL_OR_STRING,&theArg) == FALSE)
     {
      SetpType(returnValue,SYMBOL);
      SetpValue(returnValue,EnvFalseSymbol(theEnv));
      return;
     }

   /*======================*/
   /* Evaluate the string. */
   /*======================*/

   EnvEval(theEnv,DOToString(theArg),returnValue);
  }
Esempio n. 17
0
globle void *SetSalienceEvaluationCommand(
    void *theEnv)
{
    DATA_OBJECT argPtr;
    char *argument, *oldValue;

    /*==================================================*/
    /* Get the current setting for salience evaluation. */
    /*==================================================*/

    oldValue = SalienceEvaluationName(EnvGetSalienceEvaluation(theEnv));

    /*=========================================*/
    /* This function expects a single argument */
    /* which must be a symbol.                 */
    /*=========================================*/

    if (EnvArgCountCheck(theEnv,(char*)"set-salience-evaluation",EXACTLY,1) == -1)
    {
        return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
    }

    if (EnvArgTypeCheck(theEnv,(char*)"set-salience-evaluation",1,SYMBOL,&argPtr) == FALSE)
    {
        return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
    }

    /*=============================================================*/
    /* The allowed symbols to pass as an argument to this function */
    /* are when-defined, when-activated, and every-cycle.          */
    /*=============================================================*/

    argument = DOToString(argPtr);

    if (strcmp(argument,(char*)"when-defined") == 0)
    {
        EnvSetSalienceEvaluation(theEnv,WHEN_DEFINED);
    }
    else if (strcmp(argument,(char*)"when-activated") == 0)
    {
        EnvSetSalienceEvaluation(theEnv,WHEN_ACTIVATED);
    }
    else if (strcmp(argument,(char*)"every-cycle") == 0)
    {
        EnvSetSalienceEvaluation(theEnv,EVERY_CYCLE);
    }
    else
    {
        ExpectedTypeError1(theEnv,(char*)"set-salience-evaluation",1,
                           (char*)"symbol with value when-defined, when-activated, or every-cycle");
        return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
    }

    /*=================================================*/
    /* Return the old setting for salience evaluation. */
    /*=================================================*/

    return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
}
Esempio n. 18
0
/*************************************************************
  NAME         : PreviewGeneric
  DESCRIPTION  : Allows the user to see a printout of all the
                   applicable methods for a particular generic
                   function call
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Any side-effects of evaluating the generic
                   function arguments
                 and evaluating query-functions to determine
                   the set of applicable methods
  NOTES        : H/L Syntax: (preview-generic <func> <args>)
 *************************************************************/
globle void PreviewGeneric(
  void *theEnv,
  EXEC_STATUS)
  {
   DEFGENERIC *gfunc;
   DEFGENERIC *previousGeneric;
   int oldce;
   DATA_OBJECT temp;

   execStatus->EvaluationError = FALSE;
   if (EnvArgTypeCheck(theEnv,execStatus,"preview-generic",1,SYMBOL,&temp) == FALSE)
     return;
   gfunc = LookupDefgenericByMdlOrScope(theEnv,execStatus,DOToString(temp));
   if (gfunc == NULL)
     {
      PrintErrorID(theEnv,execStatus,"GENRCFUN",3,FALSE);
      EnvPrintRouter(theEnv,execStatus,WERROR,"Unable to find generic function ");
      EnvPrintRouter(theEnv,execStatus,WERROR,DOToString(temp));
      EnvPrintRouter(theEnv,execStatus,WERROR," in function preview-generic.\n");
      return;
     }
   oldce = ExecutingConstruct(theEnv,execStatus);
   SetExecutingConstruct(theEnv,execStatus,TRUE);
   previousGeneric = DefgenericData(theEnv,execStatus)->CurrentGeneric;
   DefgenericData(theEnv,execStatus)->CurrentGeneric = gfunc;
   execStatus->CurrentEvaluationDepth++;
   PushProcParameters(theEnv,execStatus,GetFirstArgument()->nextArg,
                          CountArguments(GetFirstArgument()->nextArg),
                          EnvGetDefgenericName(theEnv,execStatus,(void *) gfunc),"generic function",
                          UnboundMethodErr);
   if (execStatus->EvaluationError)
     {
      PopProcParameters(theEnv,execStatus);
      DefgenericData(theEnv,execStatus)->CurrentGeneric = previousGeneric;
      execStatus->CurrentEvaluationDepth--;
      SetExecutingConstruct(theEnv,execStatus,oldce);
      return;
     }
   gfunc->busy++;
   DisplayGenericCore(theEnv,execStatus,gfunc);
   gfunc->busy--;
   PopProcParameters(theEnv,execStatus);
   DefgenericData(theEnv,execStatus)->CurrentGeneric = previousGeneric;
   execStatus->CurrentEvaluationDepth--;
   SetExecutingConstruct(theEnv,execStatus,oldce);
  }
Esempio n. 19
0
globle void LowcaseFunction(
  void *theEnv,
  DATA_OBJECT_PTR returnValue)
  {
   DATA_OBJECT theArg;
   unsigned i;
   size_t slen;
   char *osptr, *nsptr;

   /*================================================*/
   /* Function lowcase expects exactly one argument. */
   /*================================================*/

   if (EnvArgCountCheck(theEnv,"lowcase",EXACTLY,1) == -1)
     {
      SetpType(returnValue,STRING);
      SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,""));
      return;
     }

   /*==================================================*/
   /* The argument should be of type symbol or string. */
   /*==================================================*/

   if (EnvArgTypeCheck(theEnv,"lowcase",1,SYMBOL_OR_STRING,&theArg) == FALSE)
     {
      SetpType(returnValue,STRING);
      SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,""));
      return;
     }

   /*======================================================*/
   /* Allocate temporary memory and then copy the original */
   /* string or symbol to that memory, while lowercasing   */
   /* upper case alphabetic characters.                    */
   /*======================================================*/

   osptr = DOToString(theArg);
   slen = strlen(osptr) + 1;
   nsptr = (char *) gm2(theEnv,slen);

   for (i = 0  ; i < slen ; i++)
     {
      if (isupper(osptr[i]))
        { nsptr[i] = (char) tolower(osptr[i]); }
      else
        { nsptr[i] = osptr[i]; }
     }

   /*========================================*/
   /* Return the lowercased string and clean */
   /* up the temporary memory used.          */
   /*========================================*/

   SetpType(returnValue,GetType(theArg));
   SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,nsptr));
   rm(theEnv,nsptr,slen);
  }
Esempio n. 20
0
/********************************************************
  NAME         : ClassExistPCommand
  DESCRIPTION  : Determines if a class exists
  INPUTS       : None
  RETURNS      : TRUE if class exists, FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (class-existp <arg>)
 ********************************************************/
globle intBool ClassExistPCommand(
  void *theEnv)
  {
   DATA_OBJECT temp;
   
   if (EnvArgTypeCheck(theEnv,"class-existp",1,SYMBOL,&temp) == FALSE)
     return(FALSE);
   return((LookupDefclassByMdlOrScope(theEnv,DOToString(temp)) != NULL) ? TRUE : FALSE);
  }
Esempio n. 21
0
/*************************************************************
  NAME         : PreviewGeneric
  DESCRIPTION  : Allows the user to see a printout of all the
                   applicable methods for a particular generic
                   function call
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Any side-effects of evaluating the generic
                   function arguments
                 and evaluating query-functions to determine
                   the set of applicable methods
  NOTES        : H/L Syntax: (preview-generic <func> <args>)
 *************************************************************/
globle void PreviewGeneric()
  {
   DEFGENERIC *gfunc;
   DEFGENERIC *previousGeneric;
   int oldce;
   DATA_OBJECT temp;

   EvaluationError = FALSE;
   if (ArgTypeCheck("preview-generic",1,SYMBOL,&temp) == FALSE)
     return;
   gfunc = LookupDefgenericByMdlOrScope(DOToString(temp));
   if (gfunc == NULL)
     {
      PrintErrorID("GENRCFUN",3,FALSE);
      PrintRouter(WERROR,"Unable to find generic function ");
      PrintRouter(WERROR,DOToString(temp));
      PrintRouter(WERROR," in function preview-generic.\n");
      return;
     }
   oldce = ExecutingConstruct();
   SetExecutingConstruct(TRUE);
   previousGeneric = CurrentGeneric;
   CurrentGeneric = gfunc;
   CurrentEvaluationDepth++;
   PushProcParameters(GetFirstArgument()->nextArg,
                          CountArguments(GetFirstArgument()->nextArg),
                          GetDefgenericName((void *) gfunc),"generic function",
                          UnboundMethodErr);
   if (EvaluationError)
     {
      PopProcParameters();
      CurrentGeneric = previousGeneric;
      CurrentEvaluationDepth--;
      SetExecutingConstruct(oldce);
      return;
     }
   gfunc->busy++;
   DisplayGenericCore(gfunc);
   gfunc->busy--;
   PopProcParameters();
   CurrentGeneric = previousGeneric;
   CurrentEvaluationDepth--;
   SetExecutingConstruct(oldce);
  }
Esempio n. 22
0
/******************************************************************************
  NAME         : UndefmessageHandlerCommand
  DESCRIPTION  : Deletes a handler from a class
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Handler deleted if possible
  NOTES        : H/L Syntax: (undefmessage-handler <class> <handler> [<type>])
 ******************************************************************************/
globle void UndefmessageHandlerCommand(
  void *theEnv)
  {
#if RUN_TIME || BLOAD_ONLY
   PrintErrorID(theEnv,"MSGCOM",3,FALSE);
   EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n");
#else
   SYMBOL_HN *mname;
   const char *tname;
   DATA_OBJECT tmp;
   DEFCLASS *cls;

#if BLOAD || BLOAD_AND_BSAVE
   if (Bloaded(theEnv))
     {
      PrintErrorID(theEnv,"MSGCOM",3,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n");
      return;
     }
#endif
   if (EnvArgTypeCheck(theEnv,"undefmessage-handler",1,SYMBOL,&tmp) == FALSE)
     return;
   cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
   if ((cls == NULL) ? (strcmp(DOToString(tmp),"*") != 0) : FALSE)
     {
      ClassExistError(theEnv,"undefmessage-handler",DOToString(tmp));
      return;
     }
   if (EnvArgTypeCheck(theEnv,"undefmessage-handler",2,SYMBOL,&tmp) == FALSE)
     return;
   mname = (SYMBOL_HN *) tmp.value;
   if (EnvRtnArgCount(theEnv) == 3)
     {
      if (EnvArgTypeCheck(theEnv,"undefmessage-handler",3,SYMBOL,&tmp) == FALSE)
        return;
      tname = DOToString(tmp);
      if (strcmp(tname,"*") == 0)
        tname = NULL;
     }
   else
     tname = MessageHandlerData(theEnv)->hndquals[MPRIMARY];
   WildDeleteHandler(theEnv,cls,mname,tname);
#endif
  }
Esempio n. 23
0
/********************************************************************
  NAME         : GetFunctionRestrictions
  DESCRIPTION  : Gets DefineFunction2() restriction list for function
  INPUTS       : None
  RETURNS      : A string containing the function restriction codes
  SIDE EFFECTS : EvaluationError set on errors
  NOTES        : None
 ********************************************************************/
globle void *GetFunctionRestrictions(
    void *theEnv)
{
    DATA_OBJECT temp;
    struct FunctionDefinition *fptr;

    if (EnvArgTypeCheck(theEnv,"get-function-restrictions",1,SYMBOL,&temp) == FALSE)
        return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
    fptr = FindFunction(theEnv,DOToString(temp));
    if (fptr == NULL)
    {
        CantFindItemErrorMessage(theEnv,"function",DOToString(temp));
        SetEvaluationError(theEnv,TRUE);
        return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
    }
    if (fptr->restrictions == NULL)
        return((SYMBOL_HN *) EnvAddSymbol(theEnv,"0**"));
    return((SYMBOL_HN *) EnvAddSymbol(theEnv,fptr->restrictions));
}
Esempio n. 24
0
/*********************************************************
  NAME         : GetClassNameArgument
  DESCRIPTION  : Gets a class name-string
  INPUTS       : Calling function name
  RETURNS      : Class name (NULL on errors)
  SIDE EFFECTS : None
  NOTES        : Assumes only 1 argument
 *********************************************************/
static char *GetClassNameArgument(
  void *theEnv,
  char *fname)
  {
   DATA_OBJECT temp;

   if (EnvArgTypeCheck(theEnv,fname,1,SYMBOL,&temp) == FALSE)
     return(NULL);
   return(DOToString(temp));
  }
Esempio n. 25
0
/********************************************************************
  NAME         : CheckClassAndSlot
  DESCRIPTION  : Checks class and slot argument for various functions
  INPUTS       : 1) Name of the calling function
                 2) Buffer for class address
  RETURNS      : Slot symbol, NULL on errors
  SIDE EFFECTS : None
  NOTES        : None
 ********************************************************************/
globle SYMBOL_HN *CheckClassAndSlot(
   void *theEnv,
   const char *func,
   DEFCLASS **cls)
  {
   DATA_OBJECT temp;

   if (EnvArgTypeCheck(theEnv,func,1,SYMBOL,&temp) == FALSE)
     return(NULL);
   *cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
   if (*cls == NULL)
     {
      ClassExistError(theEnv,func,DOToString(temp));
      return(NULL);
     }
   if (EnvArgTypeCheck(theEnv,func,2,SYMBOL,&temp) == FALSE)
     return(NULL);
   return((SYMBOL_HN *) GetValue(temp));
  }
Esempio n. 26
0
/********************************************************************
  NAME         : PreviewSendCommand
  DESCRIPTION  : Displays a list of the core for a message describing
                   shadows,etc.
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Temporary core created and destroyed
  NOTES        : H/L Syntax: (preview-send <class> <msg>)
 ********************************************************************/
globle void PreviewSendCommand()
  {
   DEFCLASS *cls;
   DATA_OBJECT temp;

   /* =============================
      Get the class for the message
      ============================= */
   if (ArgTypeCheck("preview-send",1,SYMBOL,&temp) == FALSE)
     return;
   cls = LookupDefclassByMdlOrScope(DOToString(temp));
   if (cls == NULL)
     {
      ClassExistError("preview-send",ValueToString(temp.value));
      return;
     }

   if (ArgTypeCheck("preview-send",2,SYMBOL,&temp) == FALSE)
     return;
   PreviewSend(WDISPLAY,(void *) cls,DOToString(temp));
  }
Esempio n. 27
0
globle void *SetStrategyCommand(
  void *theEnv)
  {
   DATA_OBJECT argPtr;
   char *argument;
   int oldStrategy;

   oldStrategy = AgendaData(theEnv)->Strategy;

   /*=====================================================*/
   /* Check for the correct number and type of arguments. */
   /*=====================================================*/

   if (EnvArgCountCheck(theEnv,"set-strategy",EXACTLY,1) == -1)
     { return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); }

   if (EnvArgTypeCheck(theEnv,"set-strategy",1,SYMBOL,&argPtr) == FALSE)
     { return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); }

   argument = DOToString(argPtr);

   /*=============================================*/
   /* Set the strategy to the specified strategy. */
   /*=============================================*/

   if (strcmp(argument,"depth") == 0)
     { EnvSetStrategy(theEnv,DEPTH_STRATEGY); }
   else if (strcmp(argument,"breadth") == 0)
     { EnvSetStrategy(theEnv,BREADTH_STRATEGY); }
   else if (strcmp(argument,"lex") == 0)
     { EnvSetStrategy(theEnv,LEX_STRATEGY); }
   else if (strcmp(argument,"mea") == 0)
     { EnvSetStrategy(theEnv,MEA_STRATEGY); }
   else if (strcmp(argument,"complexity") == 0)
     { EnvSetStrategy(theEnv,COMPLEXITY_STRATEGY); }
   else if (strcmp(argument,"simplicity") == 0)
     { EnvSetStrategy(theEnv,SIMPLICITY_STRATEGY); }
   else if (strcmp(argument,"random") == 0)
     { EnvSetStrategy(theEnv,RANDOM_STRATEGY); }
   else
     {
      ExpectedTypeError1(theEnv,"set-strategy",1,
      "symbol with value depth, breadth, lex, mea, complexity, simplicity, or random");
      return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv))));
     }

   /*=======================================*/
   /* Return the old value of the strategy. */
   /*=======================================*/

   return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(oldStrategy)));
  }
Esempio n. 28
0
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)
    {
        EnvSetConserveMemory(theEnv,FALSE);
    }

    /*=====================================================*/
    /* Otherwise, generate an error since the only allowed */
    /* arguments are "on" or "off."                        */
    /*=====================================================*/

    else
    {
        ExpectedTypeError1(theEnv,"conserve-mem",1,"symbol with value on or off");
        return;
    }

    return;
}
Esempio n. 29
0
/***************************************************************
  NAME         : ParseSimpleQualifier
  DESCRIPTION  : Parses abstract/concrete role and
                 pattern-matching reactivity for class
  INPUTS       : 1) The input logical name
                 2) The name of the qualifier being parsed
                 3) The qualifier value indicating that the
                    qualifier should be false
                 4) The qualifier value indicating that the
                    qualifier should be TRUE
                 5) A pointer to a bitmap indicating
                    if the qualifier has already been parsed
                 6) A buffer to store the value of the qualifier
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Bitmap and qualifier buffers set
                 Messages printed on errors
  NOTES        : None
 ***************************************************************/
static intBool ParseSimpleQualifier(
  void *theEnv,
  char *readSource,
  char *classQualifier,
  char *clearRelation,
  char *setRelation,
  intBool *alreadyTestedFlag,
  intBool *binaryFlag)
  {
   if (*alreadyTestedFlag)
     {
      PrintErrorID(theEnv,"CLASSPSR",4,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Class ");
      EnvPrintRouter(theEnv,WERROR,classQualifier);
      EnvPrintRouter(theEnv,WERROR," already declared.\n");
      return(FALSE);
     }
   SavePPBuffer(theEnv," ");
   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
   if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
     goto ParseSimpleQualifierError;
   if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),setRelation) == 0)
     *binaryFlag = TRUE;
   else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),clearRelation) == 0)
     *binaryFlag = FALSE;
   else
     goto ParseSimpleQualifierError;
   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
   if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
     goto ParseSimpleQualifierError;
   *alreadyTestedFlag = TRUE;
   return(TRUE);

ParseSimpleQualifierError:
   SyntaxErrorMessage(theEnv,"defclass");
   return(FALSE);
  }
Esempio n. 30
0
/*********************************************************************
  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()
  {
   DATA_OBJECT tmp;
   DEFCLASS *cls;

   if (ArgTypeCheck("class-abstractp",1,SYMBOL,&tmp) == FALSE)
     return(FALSE);
   cls = LookupDefclassByMdlOrScope(DOToString(tmp));
   if (cls == NULL)
     {
      ClassExistError("class-abstractp",ValueToString(tmp.value));
      return(FALSE);
     }
   return(ClassAbstractP((void *) cls));
  }