Пример #1
0
static intBool GetVariableDefinition(
  void *theEnv,
  char *readSource,
  int *defglobalError,
  int tokenRead,
  struct token *theToken)
  {
   SYMBOL_HN *variableName;
   struct expr *assignPtr;
   DATA_OBJECT assignValue;

   /*========================================*/
   /* Get next token, which should either be */
   /* a closing parenthesis or a variable.   */
   /*========================================*/

   if (! tokenRead) GetToken(theEnv,readSource,theToken);
   if (theToken->type == RPAREN) return(FALSE);

   if (theToken->type == SF_VARIABLE)
     {
      SyntaxErrorMessage(theEnv,(char*)"defglobal");
      *defglobalError = TRUE;
      return(FALSE);
     }
   else if (theToken->type != GBL_VARIABLE)
     {
      SyntaxErrorMessage(theEnv,(char*)"defglobal");
      *defglobalError = TRUE;
      return(FALSE);
     }

   variableName = (SYMBOL_HN *) theToken->value;

   SavePPBuffer(theEnv,(char*)" ");

   /*================================*/
   /* Print out compilation message. */
   /*================================*/

#if DEBUGGING_FUNCTIONS
   if ((EnvGetWatchItem(theEnv,(char*)"compilations") == ON) && GetPrintWhileLoading(theEnv))
     {
      if (QFindDefglobal(theEnv,variableName) != NULL) 
        {
         PrintWarningID(theEnv,(char*)"CSTRCPSR",1,TRUE);
         EnvPrintRouter(theEnv,WDIALOG,(char*)"Redefining defglobal: ");
        }
      else EnvPrintRouter(theEnv,WDIALOG,(char*)"Defining defglobal: ");
      EnvPrintRouter(theEnv,WDIALOG,ValueToString(variableName));
      EnvPrintRouter(theEnv,WDIALOG,(char*)"\n");
     }
   else
#endif
     { if (GetPrintWhileLoading(theEnv)) EnvPrintRouter(theEnv,WDIALOG,(char*)":"); }

   /*==================================================================*/
   /* Check for import/export conflicts from the construct definition. */
   /*==================================================================*/

#if DEFMODULE_CONSTRUCT
   if (FindImportExportConflict(theEnv,(char*)"defglobal",((struct defmodule *) EnvGetCurrentModule(theEnv)),ValueToString(variableName)))
     {
      ImportExportConflictMessage(theEnv,(char*)"defglobal",ValueToString(variableName),NULL,NULL);
      *defglobalError = TRUE;
      return(FALSE);
     }
#endif

   /*==============================*/
   /* The next token must be an =. */
   /*==============================*/

   GetToken(theEnv,readSource,theToken);
   if (strcmp(theToken->printForm,"=") != 0)
     {
      SyntaxErrorMessage(theEnv,(char*)"defglobal");
      *defglobalError = TRUE;
      return(FALSE);
     }

   SavePPBuffer(theEnv,(char*)" ");

   /*======================================================*/
   /* Parse the expression to be assigned to the variable. */
   /*======================================================*/

   assignPtr = ParseAtomOrExpression(theEnv,readSource,NULL);
   if (assignPtr == NULL)
     {
      *defglobalError = TRUE;
      return(FALSE);
     }

   /*==========================*/
   /* Evaluate the expression. */
   /*==========================*/

   if (! ConstructData(theEnv)->CheckSyntaxMode)
     {
      SetEvaluationError(theEnv,FALSE);
      if (EvaluateExpression(theEnv,assignPtr,&assignValue))
        {
         ReturnExpression(theEnv,assignPtr);
         *defglobalError = TRUE;
         return(FALSE);
        }
     }
   else
     { ReturnExpression(theEnv,assignPtr); }

   SavePPBuffer(theEnv,(char*)")");

   /*======================================*/
   /* Add the variable to the global list. */
   /*======================================*/

   if (! ConstructData(theEnv)->CheckSyntaxMode)
     { AddDefglobal(theEnv,variableName,&assignValue,assignPtr); }

   /*==================================================*/
   /* Return TRUE to indicate that the global variable */
   /* definition was successfully parsed.              */
   /*==================================================*/

   return(TRUE);
  }
Пример #2
0
globle unsigned long HashMultifield(
  struct multifield *theSegment,
  unsigned long theRange)
  {
   unsigned long length, i;
   unsigned long tvalue;
   unsigned long count;
   struct field *fieldPtr;
   union
     {
      double fv;
      void *vv;
      unsigned long liv;
     } fis;
     
   /*================================================*/
   /* Initialize variables for computing hash value. */
   /*================================================*/

   count = 0;
   length = theSegment->multifieldLength;
   fieldPtr = theSegment->theFields;

   /*====================================================*/
   /* Loop through each value in the multifield, compute */
   /* its hash value, and add it to the running total.   */
   /*====================================================*/

   for (i = 0;
        i < length;
        i++)
     {
      switch(fieldPtr[i].type)
         {
          case MULTIFIELD:
            count += HashMultifield((struct multifield *) fieldPtr[i].value,theRange);
            break;

          case FLOAT:
            fis.liv = 0;
            fis.fv = ValueToDouble(fieldPtr[i].value);
            count += (fis.liv * (i + 29))  +
                     (unsigned long) ValueToDouble(fieldPtr[i].value);
            break;

          case INTEGER:
            count += (((unsigned long) ValueToLong(fieldPtr[i].value)) * (i + 29)) +
                      ((unsigned long) ValueToLong(fieldPtr[i].value));
            break;

          case FACT_ADDRESS:
#if OBJECT_SYSTEM
          case INSTANCE_ADDRESS:
#endif
            fis.liv = 0;
            fis.vv = fieldPtr[i].value;
            count += (unsigned long) (fis.liv * (i + 29));
            break;

          case EXTERNAL_ADDRESS:
            fis.liv = 0;
            fis.vv = ValueToExternalAddress(fieldPtr[i].value);
            count += (unsigned long) (fis.liv * (i + 29));
            break;

          case SYMBOL:
          case STRING:
#if OBJECT_SYSTEM
          case INSTANCE_NAME:
#endif
            tvalue = (unsigned long) HashSymbol(ValueToString(fieldPtr[i].value),theRange);
            count += (unsigned long) (tvalue * (i + 29));
            break;
         }
     }

   /*========================*/
   /* Return the hash value. */
   /*========================*/

   return(count);
  }
Пример #3
0
void *GetFactOrInstanceArgument(
  void *theEnv,
  int thePosition,
  DATA_OBJECT *item,
  char *functionName)
  {
   void *ptr;

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

   EnvRtnUnknown(theEnv,thePosition,item);

   /*==================================================*/
   /* Fact and instance addresses are valid arguments. */
   /*==================================================*/

   if ((GetpType(item) == FACT_ADDRESS) ||
       (GetpType(item) == INSTANCE_ADDRESS))
     { return(GetpValue(item)); }

   /*==================================================*/
   /* An integer is a valid argument if it corresponds */
   /* to the fact index of an existing fact.           */
   /*==================================================*/

#if DEFTEMPLATE_CONSTRUCT
   else if (GetpType(item) == INTEGER)
     {
      if ((ptr = (void *) FindIndexedFact(theEnv,DOPToLong(item))) == NULL)
        {
         char tempBuffer[20];
         sprintf(tempBuffer,"f-%ld",DOPToLong(item));
         CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
        }
      return(ptr);
     }
#endif

   /*================================================*/
   /* Instance names and symbols are valid arguments */
   /* if they correspond to an existing instance.    */
   /*================================================*/

#if OBJECT_SYSTEM
   else if ((GetpType(item) == INSTANCE_NAME) || (GetpType(item) == SYMBOL))
     {
      if ((ptr = (void *) FindInstanceBySymbol(theEnv,(SYMBOL_HN *) GetpValue(item))) == NULL)
        {
         CantFindItemErrorMessage(theEnv,"instance",ValueToString(GetpValue(item)));
        }
      return(ptr);
     }
#endif

   /*========================================*/
   /* Any other type is an invalid argument. */
   /*========================================*/

   ExpectedTypeError2(theEnv,functionName,thePosition);
   return(NULL);
  }
Пример #4
0
FString FAIDataProviderValue::ToString() const
{
	return IsDynamic() ? DataBinding->ToString(DataField) : ValueToString();
}
Пример #5
0
static int FindConstructBeginning(
  void *theEnv,
  char *readSource,
  struct token *theToken,
  int errorCorrection,
  int *noErrors)
  {
   int leftParenthesisFound = FALSE;
   int firstAttempt = TRUE;

   /*===================================================*/
   /* Process tokens until the beginning of a construct */
   /* is found or there are no more tokens.             */
   /*===================================================*/

   while (theToken->type != STOP)
     {
      /*=====================================================*/
      /* Constructs begin with a left parenthesis. Make note */
      /* that the opening parenthesis has been found.        */
      /*=====================================================*/

      if (theToken->type == LPAREN)
        { leftParenthesisFound = TRUE; }

      /*=================================================================*/
      /* The name of the construct follows the opening left parenthesis. */
      /* If it is the name of a valid construct, then return TRUE.       */
      /* Otherwise, reset the flags to look for the beginning of a       */
      /* construct. If error correction is being performed (i.e. the     */
      /* last construct parsed had an error in it), then don't bother to */
      /* print an error message, otherwise, print an error message.      */
      /*=================================================================*/

      else if ((theToken->type == SYMBOL) && (leftParenthesisFound == TRUE))
        {
         /*===========================================================*/
         /* Is this a valid construct name (e.g., defrule, deffacts). */
         /*===========================================================*/

         if (FindConstruct(theEnv,ValueToString(theToken->value)) != NULL) return(TRUE);

         /*===============================================*/
         /* The construct name is invalid. Print an error */
         /* message if one hasn't already been printed.   */
         /*===============================================*/

         if (firstAttempt && (! errorCorrection))
           {
            errorCorrection = TRUE;
            *noErrors = FALSE;
            PrintErrorID(theEnv,"CSTRCPSR",1,TRUE);
            EnvPrintRouter(theEnv,WERROR,"Expected the beginning of a construct.\n");
           }

         /*======================================================*/
         /* Indicate that an error has been found and that we're */
         /* looking for a left parenthesis again.                */
         /*======================================================*/

         firstAttempt = FALSE;
         leftParenthesisFound = FALSE;
        }

      /*====================================================================*/
      /* Any token encountered other than a left parenthesis or a construct */
      /* name following a left parenthesis is illegal. Again, if error      */
      /* correction is in progress, no error message is printed, otherwise, */
      /*  an error message is printed.                                      */
      /*====================================================================*/

      else
        {
         if (firstAttempt && (! errorCorrection))
           {
            errorCorrection = TRUE;
            *noErrors = FALSE;
            PrintErrorID(theEnv,"CSTRCPSR",1,TRUE);
            EnvPrintRouter(theEnv,WERROR,"Expected the beginning of a construct.\n");
           }

         firstAttempt = FALSE;
         leftParenthesisFound = FALSE;
        }

      /*============================================*/
      /* Move on to the next token to be processed. */
      /*============================================*/

      GetToken(theEnv,readSource,theToken);
     }

   /*===================================================================*/
   /* Couldn't find the beginning of a construct, so FALSE is returned. */
   /*===================================================================*/

   return(FALSE);
  }
Пример #6
0
/****************************************************
  NAME         : AddDeffunction
  DESCRIPTION  : Adds a deffunction to the list of
                 deffunctions
  INPUTS       : 1) The symbolic name
                 2) The action expressions
                 3) The minimum number of arguments
                 4) The maximum number of arguments
                    (can be -1)
                 5) The number of local variables
                 6) A flag indicating if this is
                    a header call so that the
                    deffunction can be recursively
                    called
  RETURNS      : The new deffunction (NULL on errors)
  SIDE EFFECTS : Deffunction structures allocated
  NOTES        : Assumes deffunction is not executing
 ****************************************************/
static DEFFUNCTION *AddDeffunction(
    void *theEnv,
    SYMBOL_HN *name,
    EXPRESSION *actions,
    int min,
    int max,
    int lvars,
    int headerp)
{
    DEFFUNCTION *dfuncPtr;
    unsigned oldbusy;
#if DEBUGGING_FUNCTIONS
    unsigned DFHadWatch = FALSE;
#else
#if MAC_XCD
#pragma unused(headerp)
#endif
#endif

    /*===============================================================*/
    /* If the deffunction doesn't exist, create a new structure to   */
    /* contain it and add it to the List of deffunctions. Otherwise, */
    /* use the existing structure and remove the pretty print form   */
    /* and interpretive code.                                        */
    /*===============================================================*/
    dfuncPtr = (DEFFUNCTION *) EnvFindDeffunctionInModule(theEnv,ValueToString(name));
    if (dfuncPtr == NULL)
    {
        dfuncPtr = get_struct(theEnv,deffunctionStruct);
        InitializeConstructHeader(theEnv,"deffunction",(struct constructHeader *) dfuncPtr,name);
        IncrementSymbolCount(name);
        dfuncPtr->code = NULL;
        dfuncPtr->minNumberOfParameters = min;
        dfuncPtr->maxNumberOfParameters = max;
        dfuncPtr->numberOfLocalVars = lvars;
        dfuncPtr->busy = 0;
        dfuncPtr->executing = 0;
    }
    else
    {
#if DEBUGGING_FUNCTIONS
        DFHadWatch = EnvGetDeffunctionWatch(theEnv,(void *) dfuncPtr);
#endif
        dfuncPtr->minNumberOfParameters = min;
        dfuncPtr->maxNumberOfParameters = max;
        dfuncPtr->numberOfLocalVars = lvars;
        oldbusy = dfuncPtr->busy;
        ExpressionDeinstall(theEnv,dfuncPtr->code);
        dfuncPtr->busy = oldbusy;
        ReturnPackedExpression(theEnv,dfuncPtr->code);
        dfuncPtr->code = NULL;
        EnvSetDeffunctionPPForm(theEnv,(void *) dfuncPtr,NULL);

        /* =======================================
           Remove the deffunction from the list so
           that it can be added at the end
           ======================================= */
        RemoveConstructFromModule(theEnv,(struct constructHeader *) dfuncPtr);
    }

    AddConstructToModule((struct constructHeader *) dfuncPtr);

    /* ==================================
       Install the new interpretive code.
       ================================== */

    if (actions != NULL)
    {
        /* ===============================
           If a deffunction is recursive,
           do not increment its busy count
           based on self-references
           =============================== */
        oldbusy = dfuncPtr->busy;
        ExpressionInstall(theEnv,actions);
        dfuncPtr->busy = oldbusy;
        dfuncPtr->code = actions;
    }

    /* ===============================================================
       Install the pretty print form if memory is not being conserved.
       =============================================================== */

#if DEBUGGING_FUNCTIONS
    EnvSetDeffunctionWatch(theEnv,DFHadWatch ? TRUE : DeffunctionData(theEnv)->WatchDeffunctions,(void *) dfuncPtr);
    if ((EnvGetConserveMemory(theEnv) == FALSE) && (headerp == FALSE))
        EnvSetDeffunctionPPForm(theEnv,(void *) dfuncPtr,CopyPPBuffer(theEnv));
#endif
    return(dfuncPtr);
}
Пример #7
0
// DECL: static Scene* load(const char* filePath);
value hx_Scene_static_load(value filePath)
{
    const char *_filePath = ValueToString(filePath);
    return ReferenceToValue(Scene::load(_filePath));
}
Пример #8
0
static struct templateSlot *ParseSlot(
  void *theEnv,
  char *readSource,
  struct token *inputToken,
  struct templateSlot *slotList)
  {
   int parsingMultislot;
   SYMBOL_HN *slotName;
   struct templateSlot *newSlot;
   int rv;

   /*=====================================================*/
   /* Slots must  begin with keyword field or multifield. */
   /*=====================================================*/

   if ((strcmp(ValueToString(inputToken->value),(char*)"field") != 0) &&
       (strcmp(ValueToString(inputToken->value),(char*)"multifield") != 0) &&
       (strcmp(ValueToString(inputToken->value),(char*)"slot") != 0) &&
       (strcmp(ValueToString(inputToken->value),(char*)"multislot") != 0))
     {
      SyntaxErrorMessage(theEnv,(char*)"deftemplate");
      DeftemplateData(theEnv)->DeftemplateError = TRUE;
      return(NULL);
     }

   /*===============================================*/
   /* Determine if multifield slot is being parsed. */
   /*===============================================*/

   if ((strcmp(ValueToString(inputToken->value),(char*)"multifield") == 0) ||
       (strcmp(ValueToString(inputToken->value),(char*)"multislot") == 0))
     { parsingMultislot = TRUE; }
   else
     { parsingMultislot = FALSE; }

   /*========================================*/
   /* The name of the slot must be a symbol. */
   /*========================================*/

   SavePPBuffer(theEnv,(char*)" ");
   GetToken(theEnv,readSource,inputToken);
   if (inputToken->type != SYMBOL)
     {
      SyntaxErrorMessage(theEnv,(char*)"deftemplate");
      DeftemplateData(theEnv)->DeftemplateError = TRUE;
      return(NULL);
     }

   slotName = (SYMBOL_HN *) inputToken->value;

   /*================================================*/
   /* Determine if the slot has already been parsed. */
   /*================================================*/

   while (slotList != NULL)
     {
      if (slotList->slotName == slotName)
        {
         AlreadyParsedErrorMessage(theEnv,(char*)"slot ",ValueToString(slotList->slotName));
         DeftemplateData(theEnv)->DeftemplateError = TRUE;
         return(NULL);
        }

      slotList = slotList->next;
     }

   /*===================================*/
   /* Parse the attributes of the slot. */
   /*===================================*/

   newSlot = DefinedSlots(theEnv,readSource,slotName,parsingMultislot,inputToken);
   if (newSlot == NULL)
     {
      DeftemplateData(theEnv)->DeftemplateError = TRUE;
      return(NULL);
     }

   /*=================================*/
   /* Check for slot conflict errors. */
   /*=================================*/

   if (CheckConstraintParseConflicts(theEnv,newSlot->constraints) == FALSE)
     {
      ReturnSlots(theEnv,newSlot);
      DeftemplateData(theEnv)->DeftemplateError = TRUE;
      return(NULL);
     }

   if ((newSlot->defaultPresent) || (newSlot->defaultDynamic))
     { rv = ConstraintCheckExpressionChain(theEnv,newSlot->defaultList,newSlot->constraints); }
   else
     { rv = NO_VIOLATION; }

   if ((rv != NO_VIOLATION) && EnvGetStaticConstraintChecking(theEnv))
     {
      char *temp;
      if (newSlot->defaultDynamic) temp = (char*)"the default-dynamic attribute";
      else temp = (char*)"the default attribute";
      ConstraintViolationErrorMessage(theEnv,(char*)"An expression",temp,FALSE,0,
                                      newSlot->slotName,0,rv,newSlot->constraints,TRUE);
      ReturnSlots(theEnv,newSlot);
      DeftemplateData(theEnv)->DeftemplateError = TRUE;
      return(NULL);
     }

   /*==================*/
   /* Return the slot. */
   /*==================*/

   return(newSlot);
  }
Пример #9
0
static struct templateSlot *DefinedSlots(
  void *theEnv,
  char *readSource,
  SYMBOL_HN *slotName,
  int multifieldSlot,
  struct token *inputToken)
  {
   struct templateSlot *newSlot;
   struct expr *defaultList;
   int defaultFound = FALSE;
   int noneSpecified, deriveSpecified;
   CONSTRAINT_PARSE_RECORD parsedConstraints;

   /*===========================*/
   /* Build the slot container. */
   /*===========================*/

   newSlot = get_struct(theEnv,templateSlot);
   newSlot->slotName = slotName;
   newSlot->defaultList = NULL;
   newSlot->facetList = NULL;
   newSlot->constraints = GetConstraintRecord(theEnv);
   if (multifieldSlot)
     { newSlot->constraints->multifieldsAllowed = TRUE; }
   newSlot->multislot = multifieldSlot;
   newSlot->noDefault = FALSE;
   newSlot->defaultPresent = FALSE;
   newSlot->defaultDynamic = FALSE;
   newSlot->next = NULL;

   /*========================================*/
   /* Parse the primitive slot if it exists. */
   /*========================================*/

   InitializeConstraintParseRecord(&parsedConstraints);
   GetToken(theEnv,readSource,inputToken);

   while (inputToken->type != RPAREN)
     {
      PPBackup(theEnv);
      SavePPBuffer(theEnv,(char*)" ");
      SavePPBuffer(theEnv,inputToken->printForm);

      /*================================================*/
      /* Slot attributes begin with a left parenthesis. */
      /*================================================*/

      if (inputToken->type != LPAREN)
        {
         SyntaxErrorMessage(theEnv,(char*)"deftemplate");
         ReturnSlots(theEnv,newSlot);
         DeftemplateData(theEnv)->DeftemplateError = TRUE;
         return(NULL);
        }

      /*=============================================*/
      /* The name of the attribute must be a symbol. */
      /*=============================================*/

      GetToken(theEnv,readSource,inputToken);
      if (inputToken->type != SYMBOL)
        {
         SyntaxErrorMessage(theEnv,(char*)"deftemplate");
         ReturnSlots(theEnv,newSlot);
         DeftemplateData(theEnv)->DeftemplateError = TRUE;
         return(NULL);
        }

      /*================================================================*/
      /* Determine if the attribute is one of the standard constraints. */
      /*================================================================*/

      if (StandardConstraint(ValueToString(inputToken->value)))
        {
         if (ParseStandardConstraint(theEnv,readSource,(ValueToString(inputToken->value)),
                                     newSlot->constraints,&parsedConstraints,
                                     multifieldSlot) == FALSE)
           {
            DeftemplateData(theEnv)->DeftemplateError = TRUE;
            ReturnSlots(theEnv,newSlot);
            return(NULL);
           }
        }

      /*=================================================*/
      /* else if the attribute is the default attribute, */
      /* then get the default list for this slot.        */
      /*=================================================*/

      else if ((strcmp(ValueToString(inputToken->value),"default") == 0) ||
               (strcmp(ValueToString(inputToken->value),"default-dynamic") == 0))
        {
         /*======================================================*/
         /* Check to see if the default has already been parsed. */
         /*======================================================*/

         if (defaultFound)
           {
            AlreadyParsedErrorMessage(theEnv,(char*)"default attribute",NULL);
            DeftemplateData(theEnv)->DeftemplateError = TRUE;
            ReturnSlots(theEnv,newSlot);
            return(NULL);
           }

         newSlot->noDefault = FALSE;

         /*=====================================================*/
         /* Determine whether the default is dynamic or static. */
         /*=====================================================*/

         if (strcmp(ValueToString(inputToken->value),"default") == 0)
           {
            newSlot->defaultPresent = TRUE;
            newSlot->defaultDynamic = FALSE;
           }
         else
           {
            newSlot->defaultPresent = FALSE;
            newSlot->defaultDynamic = TRUE;
           }

         /*===================================*/
         /* Parse the list of default values. */
         /*===================================*/

         defaultList = ParseDefault(theEnv,readSource,multifieldSlot,(int) newSlot->defaultDynamic,
                                  TRUE,&noneSpecified,&deriveSpecified,&DeftemplateData(theEnv)->DeftemplateError);
         if (DeftemplateData(theEnv)->DeftemplateError == TRUE)
           {
            ReturnSlots(theEnv,newSlot);
            return(NULL);
           }

         /*==================================*/
         /* Store the default with the slot. */
         /*==================================*/

         defaultFound = TRUE;
         if (deriveSpecified) newSlot->defaultPresent = FALSE;
         else if (noneSpecified)
           {
            newSlot->noDefault = TRUE;
            newSlot->defaultPresent = FALSE;
           }
         newSlot->defaultList = defaultList;
        }
        
      /*===============================================*/
      /* else if the attribute is the facet attribute. */
      /*===============================================*/
      
      else if (strcmp(ValueToString(inputToken->value),"facet") == 0)
        {
         if (! ParseFacetAttribute(theEnv,readSource,newSlot,FALSE))
           {
            ReturnSlots(theEnv,newSlot);
            DeftemplateData(theEnv)->DeftemplateError = TRUE;
            return(NULL);
           }
        }
        
      else if (strcmp(ValueToString(inputToken->value),"multifacet") == 0)
        {
         if (! ParseFacetAttribute(theEnv,readSource,newSlot,TRUE))
           {
            ReturnSlots(theEnv,newSlot);
            DeftemplateData(theEnv)->DeftemplateError = TRUE;
            return(NULL);
           }
        }

      /*============================================*/
      /* Otherwise the attribute is an invalid one. */
      /*============================================*/

      else
        {
         SyntaxErrorMessage(theEnv,(char*)("slot attributes"));
         ReturnSlots(theEnv,newSlot);
         DeftemplateData(theEnv)->DeftemplateError = TRUE;
         return(NULL);
        }

      /*===================================*/
      /* Begin parsing the next attribute. */
      /*===================================*/

      GetToken(theEnv,readSource,inputToken);
     }

   /*============================*/
   /* Return the attribute list. */
   /*============================*/

   return(newSlot);
  }
Пример #10
0
/*****************************************************
  NAME         : PerformMessage
  DESCRIPTION  : Calls core framework for a message
  INPUTS       : 1) Caller's result buffer
                 2) Message argument expressions
                    (including implicit object)
                 3) Message name
  RETURNS      : Nothing useful
  SIDE EFFECTS : Any side-effects of message execution
                    and caller's result buffer set
  NOTES        : None
 *****************************************************/
static void PerformMessage(
  DATA_OBJECT *result,
  EXPRESSION *args,
  SYMBOL_HN *mname)
  {
   int oldce;
   HANDLER_LINK *oldCore;
   DEFCLASS *cls = NULL;
   INSTANCE_TYPE *ins = NULL;
   SYMBOL_HN *oldName;
#if PROFILING_FUNCTIONS
   struct profileFrameInfo profileFrame;
#endif

   result->type = SYMBOL;
   result->value = FalseSymbol;
   EvaluationError = FALSE;
   if (HaltExecution)
     return;
   oldce = ExecutingConstruct();
   SetExecutingConstruct(TRUE);
   oldName = CurrentMessageName;
   CurrentMessageName = mname;
   CurrentEvaluationDepth++;
   PushProcParameters(args,CountArguments(args),
                        ValueToString(CurrentMessageName),"message",
                        UnboundHandlerErr);

   if (EvaluationError)
     {
      CurrentEvaluationDepth--;
      CurrentMessageName = oldName;
      PeriodicCleanup(FALSE,TRUE);
      SetExecutingConstruct(oldce);
      return;
     }

   if (ProcParamArray->type == INSTANCE_ADDRESS)
     {
      ins = (INSTANCE_TYPE *) ProcParamArray->value;
      if (ins->garbage == 1)
        {
         StaleInstanceAddress("send",0);
         SetEvaluationError(TRUE);
        }
      else if (DefclassInScope(ins->cls,(struct defmodule *) GetCurrentModule()) == FALSE)
        NoInstanceError(ValueToString(ins->name),"send");
      else
        {
         cls = ins->cls;
         ins->busy++;
        }
     }
   else if (ProcParamArray->type == INSTANCE_NAME)
     {
      ins = FindInstanceBySymbol((SYMBOL_HN *) ProcParamArray->value);
      if (ins == NULL)
        {
         PrintErrorID("MSGPASS",2,FALSE);
         PrintRouter(WERROR,"No such instance ");
         PrintRouter(WERROR,ValueToString((SYMBOL_HN *) ProcParamArray->value));
         PrintRouter(WERROR," in function send.\n");
         SetEvaluationError(TRUE);
        }
      else
        {
         ProcParamArray->value = (void *) ins;
         ProcParamArray->type = INSTANCE_ADDRESS;
         cls = ins->cls;
         ins->busy++;
        }
     }
   else if ((cls = PrimitiveClassMap[ProcParamArray->type]) == NULL)
     {
      SystemError("MSGPASS",1);
      ExitRouter(EXIT_FAILURE);
     }
   if (EvaluationError)
     {
      PopProcParameters();
      CurrentEvaluationDepth--;
      CurrentMessageName = oldName;
      PeriodicCleanup(FALSE,TRUE);
      SetExecutingConstruct(oldce);
      return;
     }

   oldCore = TopOfCore;
   TopOfCore = FindApplicableHandlers(cls,mname);

   if (TopOfCore != NULL)
     {
      HANDLER_LINK *oldCurrent,*oldNext;

      oldCurrent = CurrentCore;
      oldNext = NextInCore;

#if IMPERATIVE_MESSAGE_HANDLERS

      if (TopOfCore->hnd->type == MAROUND)
        {
         CurrentCore = TopOfCore;
         NextInCore = TopOfCore->nxt;
#if DEBUGGING_FUNCTIONS
         if (WatchMessages)
           WatchMessage(WTRACE,BEGIN_TRACE);
         if (CurrentCore->hnd->trace)
           WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
         if (CheckHandlerArgCount())
           {
#if PROFILING_FUNCTIONS
            StartProfile(&profileFrame,
                         &CurrentCore->hnd->usrData,
                         ProfileConstructs);
#endif


           EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
                               CurrentCore->hnd->actions,
                               CurrentCore->hnd->localVarCount,
                               result,UnboundHandlerErr);


#if PROFILING_FUNCTIONS
            EndProfile(&profileFrame);
#endif
           }

#if DEBUGGING_FUNCTIONS
         if (CurrentCore->hnd->trace)
           WatchHandler(WTRACE,CurrentCore,END_TRACE);
         if (WatchMessages)
           WatchMessage(WTRACE,END_TRACE);
#endif
        }
      else

#endif  /* IMPERATIVE_MESSAGE_HANDLERS */

        {
         CurrentCore = NULL;
         NextInCore = TopOfCore;
#if DEBUGGING_FUNCTIONS
         if (WatchMessages)
           WatchMessage(WTRACE,BEGIN_TRACE);
#endif
         CallHandlers(result);
#if DEBUGGING_FUNCTIONS
         if (WatchMessages)
           WatchMessage(WTRACE,END_TRACE);
#endif
        }

      DestroyHandlerLinks(TopOfCore);
      CurrentCore = oldCurrent;
      NextInCore = oldNext;
     }

   TopOfCore = oldCore;
   ReturnFlag = FALSE;

   if (ins != NULL)
     ins->busy--;

   /* ==================================
      Restore the original calling frame
      ================================== */
   PopProcParameters();
   CurrentEvaluationDepth--;
   CurrentMessageName = oldName;
   PropagateReturnValue(result);
   PeriodicCleanup(FALSE,TRUE);
   SetExecutingConstruct(oldce);
   if (EvaluationError)
     {
      result->type = SYMBOL;
      result->value = FalseSymbol;
     }
  }
Пример #11
0
globle void PrintAtom(
  void *theEnv,
  char *logicalName,
  int type,
  void *value)
  {
   char buffer[20];

   switch (type)
     {
      case FLOAT:
        PrintFloat(theEnv,logicalName,ValueToDouble(value));
        break;
      case INTEGER:
        PrintLongInteger(theEnv,logicalName,ValueToLong(value));
        break;
      case SYMBOL:
        EnvPrintRouter(theEnv,logicalName,ValueToString(value));
        break;
      case STRING:
        if (PrintUtilityData(theEnv)->PreserveEscapedCharacters)
          { EnvPrintRouter(theEnv,logicalName,StringPrintForm(theEnv,ValueToString(value))); }
        else
          {
           EnvPrintRouter(theEnv,logicalName,"\"");
           EnvPrintRouter(theEnv,logicalName,ValueToString(value));
           EnvPrintRouter(theEnv,logicalName,"\"");
          }
        break;

      case EXTERNAL_ADDRESS:
        if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
        EnvPrintRouter(theEnv,logicalName,"<Pointer-");
        sprintf(buffer,"%p",value);
        EnvPrintRouter(theEnv,logicalName,buffer);
        EnvPrintRouter(theEnv,logicalName,">");
        if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
        break;

#if OBJECT_SYSTEM
      case INSTANCE_NAME:
        EnvPrintRouter(theEnv,logicalName,"[");
        EnvPrintRouter(theEnv,logicalName,ValueToString(value));
        EnvPrintRouter(theEnv,logicalName,"]");
        break;
#endif

      case RVOID:
        break;

      default:
        if (EvaluationData(theEnv)->PrimitivesArray[type] == NULL) break;
        if (EvaluationData(theEnv)->PrimitivesArray[type]->longPrintFunction == NULL)
          {
           EnvPrintRouter(theEnv,logicalName,"<unknown atom type>");
           break;
          }
        (*EvaluationData(theEnv)->PrimitivesArray[type]->longPrintFunction)(theEnv,logicalName,value);
        break;
     }
  }
Пример #12
0
/***************************************************
  NAME         : HandlerSlotPutFunction
  DESCRIPTION  : Access function for handling the
                 statically-bound direct slot
                 bindings in message-handlers
  INPUTS       : 1) The bitmap expression
                 2) A data object buffer
  RETURNS      : TRUE if OK, FALSE
                 on errors
  SIDE EFFECTS : Data object buffer gets symbol
                 TRUE and slot is set. On errors,
                 buffer gets symbol FALSE,
                 EvaluationError is set and error
                 messages are printed
  NOTES        : It is possible for a handler
                 (attached to a superclass of
                  the currently active instance)
                 containing these static references
                 to be called for an instance
                 which does not contain the slots
                 (e.g., an instance of a subclass
                  where the original slot was
                  no-inherit or the subclass
                  overrode the original slot)
 ***************************************************/
globle BOOLEAN HandlerSlotPutFunction(
  void *theValue,
  DATA_OBJECT *theResult)
  {
   HANDLER_SLOT_REFERENCE *theReference;
   DEFCLASS *theDefclass;
   INSTANCE_TYPE *theInstance;
   INSTANCE_SLOT *sp;
   unsigned instanceSlotIndex;
   DATA_OBJECT theSetVal;

   theReference = (HANDLER_SLOT_REFERENCE *) ValueToBitMap(theValue);
   theInstance = (INSTANCE_TYPE *) ProcParamArray[0].value;
   theDefclass = ClassIDMap[theReference->classID];

   if (theInstance->garbage)
     {
      StaleInstanceAddress("for slot put",0);
      theResult->type = SYMBOL;
      theResult->value = FalseSymbol;
      SetEvaluationError(TRUE);
      return(FALSE);
     }

   if (theInstance->cls == theDefclass)
     {
      instanceSlotIndex = theInstance->cls->slotNameMap[theReference->slotID];
      sp = theInstance->slotAddresses[instanceSlotIndex - 1];
     }
   else
     {
      if (theReference->slotID > theInstance->cls->maxSlotNameID)
        goto HandlerPutError;
      instanceSlotIndex = theInstance->cls->slotNameMap[theReference->slotID];
      if (instanceSlotIndex == 0)
        goto HandlerPutError;
      instanceSlotIndex--;
      sp = theInstance->slotAddresses[instanceSlotIndex];
      if (sp->desc->cls != theDefclass)
        goto HandlerPutError;
     }

   /* =======================================================
      The slot has already been verified not to be read-only.
      However, if it is initialize-only, we need to make sure
      that we are initializing the instance (something we
      could not verify at parse-time)
      ======================================================= */
   if (sp->desc->initializeOnly && (!theInstance->initializeInProgress))
     {
      SlotAccessViolationError(ValueToString(sp->desc->slotName->name),
                               TRUE,(void *) theInstance);
      goto HandlerPutError2;
     }

   /* ======================================
      No arguments means to use the
      special NoParamValue to reset the slot
      to its default value
      ====================================== */
   if (GetFirstArgument())
     {
      if (EvaluateAndStoreInDataObject((int) sp->desc->multiple,
                                       GetFirstArgument(),&theSetVal) == FALSE)
         goto HandlerPutError2;
     }
   else
     {
      SetDOBegin(theSetVal,1);
      SetDOEnd(theSetVal,0);
      SetType(theSetVal,MULTIFIELD);
      SetValue(theSetVal,NoParamValue);
     }
   if (PutSlotValue(theInstance,sp,&theSetVal,theResult,NULL) == FALSE)
      goto HandlerPutError2;
   return(TRUE);

HandlerPutError:
   EarlySlotBindError(theInstance,theDefclass,theReference->slotID);

HandlerPutError2:
   theResult->type = SYMBOL;
   theResult->value = FalseSymbol;
   SetEvaluationError(TRUE);

   return(FALSE);
  }
Пример #13
0
/********************************************************
  NAME         : CallNextHandler
  DESCRIPTION  : This function allows around-handlers
                   to execute the rest of the core frame.
                 It also allows primary handlers
                   to execute shadowed primaries.

                 The original handler arguments are
                   left intact.
  INPUTS       : The caller's result-value buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : The core frame is called and any
                   appropriate changes are made when
                   used in an around handler
                   See CallHandlers()
                 But when call-next-handler is called
                   from a primary, the same shadowed
                   primary is called over and over
                   again for repeated calls to
                   call-next-handler.
  NOTES        : H/L Syntax: (call-next-handler) OR
                    (override-next-handler <arg> ...)
 ********************************************************/
globle void CallNextHandler(
  DATA_OBJECT *result)
  {
   EXPRESSION args;
   int overridep;
   HANDLER_LINK *oldNext,*oldCurrent;
#if PROFILING_FUNCTIONS
   struct profileFrameInfo profileFrame;
#endif


   SetpType(result,SYMBOL);
   SetpValue(result,FalseSymbol);
   EvaluationError = FALSE;
   if (HaltExecution)
     return;
   if (NextHandlerAvailable() == FALSE)
     {
      PrintErrorID("MSGPASS",1,FALSE);
      PrintRouter(WERROR,"Shadowed message-handlers not applicable in current context.\n");
      SetEvaluationError(TRUE);
      return;
     }
   if (CurrentExpression->value == (void *) FindFunction("override-next-handler"))
     {
      overridep = 1;
      args.type = (short) ProcParamArray[0].type;
      if (args.type != MULTIFIELD)
        args.value = (void *) ProcParamArray[0].value;
      else
        args.value = (void *) &ProcParamArray[0];
      args.nextArg = GetFirstArgument();
      args.argList = NULL;
      PushProcParameters(&args,CountArguments(&args),
                          ValueToString(CurrentMessageName),"message",
                          UnboundHandlerErr);
      if (EvaluationError)
        {
         ReturnFlag = FALSE;
         return;
        }
     }
   else
     overridep = 0;
   oldNext = NextInCore;
   oldCurrent = CurrentCore;
   if (CurrentCore->hnd->type == MAROUND)
     {
      if (NextInCore->hnd->type == MAROUND)
        {
         CurrentCore = NextInCore;
         NextInCore = NextInCore->nxt;
#if DEBUGGING_FUNCTIONS
         if (CurrentCore->hnd->trace)
           WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
         if (CheckHandlerArgCount())
           {
#if PROFILING_FUNCTIONS
            StartProfile(&profileFrame,
                         &CurrentCore->hnd->usrData,
                         ProfileConstructs);
#endif

            EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
                               CurrentCore->hnd->actions,
                               CurrentCore->hnd->localVarCount,
                               result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
            EndProfile(&profileFrame);
#endif
           }
#if DEBUGGING_FUNCTIONS
         if (CurrentCore->hnd->trace)
           WatchHandler(WTRACE,CurrentCore,END_TRACE);
#endif
        }
      else
        CallHandlers(result);
     }
   else
     {
      CurrentCore = NextInCore;
      NextInCore = NextInCore->nxt;
#if DEBUGGING_FUNCTIONS
      if (CurrentCore->hnd->trace)
        WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
      if (CheckHandlerArgCount())
        {
#if PROFILING_FUNCTIONS
        StartProfile(&profileFrame,
                     &CurrentCore->hnd->usrData,
                     ProfileConstructs);
#endif

        EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
                            CurrentCore->hnd->actions,
                            CurrentCore->hnd->localVarCount,
                            result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
         EndProfile(&profileFrame);
#endif
        }

#if DEBUGGING_FUNCTIONS
      if (CurrentCore->hnd->trace)
        WatchHandler(WTRACE,CurrentCore,END_TRACE);
#endif
     }
   NextInCore = oldNext;
   CurrentCore = oldCurrent;
   if (overridep)
     PopProcParameters();
   ReturnFlag = FALSE;
  }
Пример #14
0
globle intBool ParseDefglobal(
  void *theEnv,
  char *readSource)
  {
   int defglobalError = FALSE;
#if (MAC_MCW || WIN_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theEnv,readSource)
#endif

#if (! RUN_TIME) && (! BLOAD_ONLY)

   struct token theToken;
   int tokenRead = TRUE;
   struct defmodule *theModule;

   /*=====================================*/
   /* Pretty print buffer initialization. */
   /*=====================================*/

   SetPPBufferStatus(theEnv,ON);
   FlushPPBuffer(theEnv);
   SetIndentDepth(theEnv,3);
   SavePPBuffer(theEnv,(char*)"(defglobal ");

   /*=================================================*/
   /* Individual defglobal constructs can't be parsed */
   /* while a binary load is in effect.               */
   /*=================================================*/

#if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
   if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      CannotLoadWithBloadMessage(theEnv,(char*)"defglobal");
      return(TRUE);
     }
#endif

   /*===========================*/
   /* Look for the module name. */
   /*===========================*/

   GetToken(theEnv,readSource,&theToken);
   if (theToken.type == SYMBOL)
     {
      /*=================================================*/
      /* The optional module name can't contain a module */
      /* separator like other constructs. For example,   */
      /* (defrule X::foo is OK for rules, but the right  */
      /* syntax for defglobals is (defglobal X ?*foo*.   */
      /*=================================================*/

      tokenRead = FALSE;
      if (FindModuleSeparator(ValueToString(theToken.value)))
        {
         SyntaxErrorMessage(theEnv,(char*)"defglobal");
         return(TRUE);
        }

      /*=================================*/
      /* Determine if the module exists. */
      /*=================================*/

      theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(theToken.value));
      if (theModule == NULL)
        {
         CantFindItemErrorMessage(theEnv,(char*)"defmodule",ValueToString(theToken.value));
         return(TRUE);
        }

      /*=========================================*/
      /* If the module name was OK, then set the */
      /* current module to the specified module. */
      /*=========================================*/

      SavePPBuffer(theEnv,(char*)" ");
      EnvSetCurrentModule(theEnv,(void *) theModule);
     }

   /*===========================================*/
   /* If the module name wasn't specified, then */
   /* use the current module's name in the      */
   /* defglobal's pretty print representation.  */
   /*===========================================*/

   else
     {
      PPBackup(theEnv);
      SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,((struct defmodule *) EnvGetCurrentModule(theEnv))));
      SavePPBuffer(theEnv,(char*)" ");
      SavePPBuffer(theEnv,theToken.printForm);
     }

   /*======================*/
   /* Parse the variables. */
   /*======================*/

   while (GetVariableDefinition(theEnv,readSource,&defglobalError,tokenRead,&theToken))
     {
      tokenRead = FALSE;

      FlushPPBuffer(theEnv);
      SavePPBuffer(theEnv,(char*)"(defglobal ");
      SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,((struct defmodule *) EnvGetCurrentModule(theEnv))));
      SavePPBuffer(theEnv,(char*)" ");
     }

#endif

   /*==================================*/
   /* Return the parsing error status. */
   /*==================================*/

   return(defglobalError);
  }
Пример #15
0
/***********************************************************************
  NAME         : ParseDefmessageHandler
  DESCRIPTION  : Parses a message-handler for a class of objects
  INPUTS       : The logical name of the input source
  RETURNS      : FALSE if successful parse, TRUE otherwise
  SIDE EFFECTS : Handler allocated and inserted into class
  NOTES        : H/L Syntax:

                 (defmessage-handler <class> <name> [<type>] [<comment>]
                    (<params>)
                    <action>*)

                 <params> ::= <var>* | <var>* $?<name>
 ***********************************************************************/
globle int ParseDefmessageHandler(
  void *theEnv,
  char *readSource)
  {
   DEFCLASS *cls;
   SYMBOL_HN *cname,*mname,*wildcard;
   unsigned mtype = MPRIMARY;
   int min,max,error,lvars;
   EXPRESSION *hndParams,*actions;
   HANDLER *hnd;

   SetPPBufferStatus(theEnv,ON);
   FlushPPBuffer(theEnv);
   SetIndentDepth(theEnv,3);
   SavePPBuffer(theEnv,"(defmessage-handler ");

#if BLOAD || BLOAD_AND_BSAVE
   if ((Bloaded(theEnv)) && (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      CannotLoadWithBloadMessage(theEnv,"defmessage-handler");
      return(TRUE);
     }
#endif
   cname = GetConstructNameAndComment(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,"defmessage-handler",
                                      NULL,NULL,"~",TRUE,FALSE,DEFMODULE_CONSTRUCT);
   if (cname == NULL)
     return(TRUE);
   cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(cname));
   if (cls == NULL)
     {
      PrintErrorID(theEnv,"MSGPSR",1,FALSE);
      EnvPrintRouter(theEnv,WERROR,"A class must be defined before its message-handlers.\n");
      return(TRUE);
     }
   if ((cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]) ||
       (cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS]) ||
       (cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0]))
     {
      PrintErrorID(theEnv,"MSGPSR",8,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Message-handlers cannot be attached to the class ");
      EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) cls));
      EnvPrintRouter(theEnv,WERROR,".\n");
      return(TRUE);
     }
   if (HandlersExecuting(cls))
     {
      PrintErrorID(theEnv,"MSGPSR",2,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Cannot (re)define message-handlers during execution of \n");
      EnvPrintRouter(theEnv,WERROR,"  other message-handlers for the same class.\n");
      return(TRUE);
     }
   if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
     {
      SyntaxErrorMessage(theEnv,"defmessage-handler");
      return(TRUE);
     }
   PPBackup(theEnv);
   PPBackup(theEnv);
   SavePPBuffer(theEnv," ");
   SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
   SavePPBuffer(theEnv," ");
   mname = (SYMBOL_HN *) GetValue(DefclassData(theEnv)->ObjectParseToken);
   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
   if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN)
     {
      SavePPBuffer(theEnv," ");
      if (GetType(DefclassData(theEnv)->ObjectParseToken) != STRING)
        {
         if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
           {
            SyntaxErrorMessage(theEnv,"defmessage-handler");
            return(TRUE);
           }
         mtype = HandlerType(theEnv,"defmessage-handler",DOToString(DefclassData(theEnv)->ObjectParseToken));
         if (mtype == MERROR)
           return(TRUE);
#if ! IMPERATIVE_MESSAGE_HANDLERS
         if (mtype == MAROUND)
           return(TRUE);
#endif
         GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
         if (GetType(DefclassData(theEnv)->ObjectParseToken) == STRING)
           {
            SavePPBuffer(theEnv," ");
            GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
           }
        }
      else
        {
         SavePPBuffer(theEnv," ");
         GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
        }
     }
   PPBackup(theEnv);
   PPBackup(theEnv);
   PPCRAndIndent(theEnv);
   SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);

   hnd = FindHandlerByAddress(cls,mname,mtype);
   if (GetPrintWhileLoading(theEnv) && GetCompilationsWatch(theEnv))
     {
      EnvPrintRouter(theEnv,WDIALOG,"   Handler ");
      EnvPrintRouter(theEnv,WDIALOG,ValueToString(mname));
      EnvPrintRouter(theEnv,WDIALOG," ");
      EnvPrintRouter(theEnv,WDIALOG,MessageHandlerData(theEnv)->hndquals[mtype]);
      EnvPrintRouter(theEnv,WDIALOG,(char *) ((hnd == NULL) ? " defined.\n" : " redefined.\n"));
     }

   if ((hnd != NULL) ? hnd->system : FALSE)
     {
      PrintErrorID(theEnv,"MSGPSR",3,FALSE);
      EnvPrintRouter(theEnv,WERROR,"System message-handlers may not be modified.\n");
      return(TRUE);
     }

   hndParams = GenConstant(theEnv,SYMBOL,(void *) MessageHandlerData(theEnv)->SELF_SYMBOL);
   hndParams = ParseProcParameters(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,hndParams,
                                    &wildcard,&min,&max,&error,IsParameterSlotReference);
   if (error)
     return(TRUE);
   PPCRAndIndent(theEnv);
   ExpressionData(theEnv)->ReturnContext = TRUE;
   actions = ParseProcActions(theEnv,"message-handler",readSource,
                              &DefclassData(theEnv)->ObjectParseToken,hndParams,wildcard,
                              SlotReferenceVar,BindSlotReference,&lvars,
                              (void *) cls);
   if (actions == NULL)
     {
      ReturnExpression(theEnv,hndParams);
      return(TRUE);
     }
   if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
     {
      SyntaxErrorMessage(theEnv,"defmessage-handler");
      ReturnExpression(theEnv,hndParams);
      ReturnPackedExpression(theEnv,actions);
      return(TRUE);
     }
   PPBackup(theEnv);
   PPBackup(theEnv);
   SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
   SavePPBuffer(theEnv,"\n");

   /* ===================================================
      If we're only checking syntax, don't add the
      successfully parsed defmessage-handler to the KB.
      =================================================== */

   if (ConstructData(theEnv)->CheckSyntaxMode)
     {
      ReturnExpression(theEnv,hndParams);
      ReturnPackedExpression(theEnv,actions);
      return(FALSE);
     }

   if (hnd != NULL)
     {
      ExpressionDeinstall(theEnv,hnd->actions);
      ReturnPackedExpression(theEnv,hnd->actions);
      if (hnd->ppForm != NULL)
        rm(theEnv,(void *) hnd->ppForm,
           (sizeof(char) * (strlen(hnd->ppForm)+1)));
     }
   else
     {
      hnd = InsertHandlerHeader(theEnv,cls,mname,(int) mtype);
      IncrementSymbolCount(hnd->name);
     }
   ReturnExpression(theEnv,hndParams);

   hnd->minParams = min;
   hnd->maxParams = max;
   hnd->localVarCount = lvars;
   hnd->actions = actions;
   ExpressionInstall(theEnv,hnd->actions);
#if DEBUGGING_FUNCTIONS

   /* ===================================================
      Old handler trace status is automatically preserved
      =================================================== */
   if (EnvGetConserveMemory(theEnv) == FALSE)
     hnd->ppForm = CopyPPBuffer(theEnv);
   else
#endif
     hnd->ppForm = NULL;
   return(FALSE);
  }
Пример #16
0
static intBool ParseFacetAttribute(
  void *theEnv,
  char *readSource,
  struct templateSlot *theSlot,
  intBool multifacet)
  {
   struct token inputToken;
   SYMBOL_HN *facetName;
   struct expr *facetPair, *tempFacet, *facetValue = NULL, *lastValue = NULL;

   /*==============================*/
   /* Parse the name of the facet. */
   /*==============================*/
   
   SavePPBuffer(theEnv,(char*)(" "));
   GetToken(theEnv,readSource,&inputToken);
   
   /*==================================*/
   /* The facet name must be a symbol. */
   /*==================================*/
   
   if (inputToken.type != SYMBOL)
     {
      if (multifacet) SyntaxErrorMessage(theEnv,(char*)("multifacet attribute"));
      else SyntaxErrorMessage(theEnv,(char*)("facet attribute"));
      return(FALSE);
     }
     
   facetName = (SYMBOL_HN *) inputToken.value;

   /*===================================*/
   /* Don't allow facets with the same  */
   /* name as a predefined CLIPS facet. */
   /*===================================*/
   
   /*====================================*/
   /* Has the facet already been parsed? */
   /*====================================*/
   
   for (tempFacet = theSlot->facetList;
        tempFacet != NULL;
        tempFacet = tempFacet->nextArg)
     {
      if (tempFacet->value == facetName)
        {
         if (multifacet) AlreadyParsedErrorMessage(theEnv,(char*)("multifacet "),ValueToString(facetName));
         else AlreadyParsedErrorMessage(theEnv,(char*)("facet "),ValueToString(facetName));
         return(FALSE);
        }
     }
   
   /*===============================*/
   /* Parse the value of the facet. */
   /*===============================*/
   
   SavePPBuffer(theEnv,(char*)(" "));
   GetToken(theEnv,readSource,&inputToken);

   while (inputToken.type != RPAREN)
     {
      /*=====================================*/
      /* The facet value must be a constant. */
      /*=====================================*/
   
      if (! ConstantType(inputToken.type))
        {
         if (multifacet) SyntaxErrorMessage(theEnv,
               (char*)("multifacet attribute"));
         else SyntaxErrorMessage(theEnv,
               (char*)("facet attribute"));
         ReturnExpression(theEnv,facetValue);
         return(FALSE);
        }

      /*======================================*/
      /* Add the value to the list of values. */
      /*======================================*/
      
      if (lastValue == NULL)
        { 
         facetValue = GenConstant(theEnv,inputToken.type,inputToken.value);
         lastValue = facetValue;
        }
      else
        {
         lastValue->nextArg = GenConstant(theEnv,inputToken.type,inputToken.value);
         lastValue = lastValue->nextArg;
        }
        
      /*=====================*/
      /* Get the next token. */
      /*=====================*/
      
      SavePPBuffer(theEnv,(char*)(" "));
      GetToken(theEnv,readSource,&inputToken);
      
      /*===============================================*/
      /* A facet can't contain more than one constant. */
      /*===============================================*/
      
      if ((! multifacet) && (inputToken.type != RPAREN))
        {
         SyntaxErrorMessage(theEnv,(char*)("facet attribute"));
         ReturnExpression(theEnv,facetValue);
         return(FALSE);
        }
     }
     
   /*========================================================*/
   /* Remove the space before the closing right parenthesis. */
   /*========================================================*/
   
   PPBackup(theEnv);
   PPBackup(theEnv);
   SavePPBuffer(theEnv,(char*)(")"));

   /*====================================*/
   /* A facet must contain one constant. */
   /*====================================*/
      
   if ((! multifacet) && (facetValue == NULL))
     {
      SyntaxErrorMessage(theEnv,(char*)("facet attribute"));
      return(FALSE);
     }

   /*=================================================*/
   /* Add the facet to the list of the slot's facets. */
   /*=================================================*/
   
   facetPair = GenConstant(theEnv,SYMBOL,facetName);
   
   if (multifacet)
     { 
      facetPair->argList = GenConstant(theEnv,FCALL,
            (void *) FindFunction(theEnv,(char*)("create$")));
      facetPair->argList->argList = facetValue;
     }
   else
     { facetPair->argList = facetValue; }
   
   facetPair->nextArg = theSlot->facetList;
   theSlot->facetList = facetPair;
   
   /*===============================================*/
   /* The facet/multifacet was successfully parsed. */
   /*===============================================*/

   return(TRUE);
  }
Пример #17
0
/***************************************************************************
  NAME         : ParseDeffunction
  DESCRIPTION  : Parses the deffunction construct
  INPUTS       : The input logical name
  RETURNS      : FALSE if successful parse, TRUE otherwise
  SIDE EFFECTS : Creates valid deffunction definition
  NOTES        : H/L Syntax :
                 (deffunction <name> [<comment>]
                    (<single-field-varible>* [<multifield-variable>])
                    <action>*)
 ***************************************************************************/
globle intBool ParseDeffunction(
    void *theEnv,
    const char *readSource)
{
    SYMBOL_HN *deffunctionName;
    EXPRESSION *actions;
    EXPRESSION *parameterList;
    SYMBOL_HN *wildcard;
    int min,max,lvars,DeffunctionError = FALSE;
    short overwrite = FALSE, owMin = 0, owMax = 0;
    DEFFUNCTION *dptr;

    SetPPBufferStatus(theEnv,ON);

    FlushPPBuffer(theEnv);
    SetIndentDepth(theEnv,3);
    SavePPBuffer(theEnv,"(deffunction ");

#if BLOAD || BLOAD_AND_BSAVE
    if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
    {
        CannotLoadWithBloadMessage(theEnv,"deffunctions");
        return(TRUE);
    }
#endif

    /* =====================================================
       Parse the name and comment fields of the deffunction.
       ===================================================== */
    deffunctionName = GetConstructNameAndComment(theEnv,readSource,&DeffunctionData(theEnv)->DFInputToken,"deffunction",
                      EnvFindDeffunctionInModule,NULL,
                      "!",TRUE,TRUE,TRUE,FALSE);
    if (deffunctionName == NULL)
        return(TRUE);

    if (ValidDeffunctionName(theEnv,ValueToString(deffunctionName)) == FALSE)
        return(TRUE);

    /*==========================*/
    /* Parse the argument list. */
    /*==========================*/
    parameterList = ParseProcParameters(theEnv,readSource,&DeffunctionData(theEnv)->DFInputToken,NULL,&wildcard,
                                        &min,&max,&DeffunctionError,NULL);
    if (DeffunctionError)
        return(TRUE);

    /*===================================================================*/
    /* Go ahead and add the deffunction so it can be recursively called. */
    /*===================================================================*/

    if (ConstructData(theEnv)->CheckSyntaxMode)
    {
        dptr = (DEFFUNCTION *) EnvFindDeffunctionInModule(theEnv,ValueToString(deffunctionName));
        if (dptr == NULL)
        {
            dptr = AddDeffunction(theEnv,deffunctionName,NULL,min,max,0,TRUE);
        }
        else
        {
            overwrite = TRUE;
            owMin = (short) dptr->minNumberOfParameters;
            owMax = (short) dptr->maxNumberOfParameters;
            dptr->minNumberOfParameters = min;
            dptr->maxNumberOfParameters = max;
        }
    }
    else
    {
        dptr = AddDeffunction(theEnv,deffunctionName,NULL,min,max,0,TRUE);
    }

    if (dptr == NULL)
    {
        ReturnExpression(theEnv,parameterList);
        return(TRUE);
    }

    /*==================================================*/
    /* Parse the actions contained within the function. */
    /*==================================================*/

    PPCRAndIndent(theEnv);

    ExpressionData(theEnv)->ReturnContext = TRUE;
    actions = ParseProcActions(theEnv,"deffunction",readSource,
                               &DeffunctionData(theEnv)->DFInputToken,parameterList,wildcard,
                               NULL,NULL,&lvars,NULL);

    /*=============================================================*/
    /* Check for the closing right parenthesis of the deffunction. */
    /*=============================================================*/

    if ((DeffunctionData(theEnv)->DFInputToken.type != RPAREN) && /* DR0872 */
            (actions != NULL))
    {
        SyntaxErrorMessage(theEnv,"deffunction");

        ReturnExpression(theEnv,parameterList);
        ReturnPackedExpression(theEnv,actions);

        if (overwrite)
        {
            dptr->minNumberOfParameters = owMin;
            dptr->maxNumberOfParameters = owMax;
        }

        if ((dptr->busy == 0) && (! overwrite))
        {
            RemoveConstructFromModule(theEnv,(struct constructHeader *) dptr);
            RemoveDeffunction(theEnv,dptr);
        }

        return(TRUE);
    }

    if (actions == NULL)
    {
        ReturnExpression(theEnv,parameterList);
        if (overwrite)
        {
            dptr->minNumberOfParameters = owMin;
            dptr->maxNumberOfParameters = owMax;
        }

        if ((dptr->busy == 0) && (! overwrite))
        {
            RemoveConstructFromModule(theEnv,(struct constructHeader *) dptr);
            RemoveDeffunction(theEnv,dptr);
        }
        return(TRUE);
    }

    /*==============================================*/
    /* If we're only checking syntax, don't add the */
    /* successfully parsed deffunction to the KB.   */
    /*==============================================*/

    if (ConstructData(theEnv)->CheckSyntaxMode)
    {
        ReturnExpression(theEnv,parameterList);
        ReturnPackedExpression(theEnv,actions);
        if (overwrite)
        {
            dptr->minNumberOfParameters = owMin;
            dptr->maxNumberOfParameters = owMax;
        }
        else
        {
            RemoveConstructFromModule(theEnv,(struct constructHeader *) dptr);
            RemoveDeffunction(theEnv,dptr);
        }
        return(FALSE);
    }

    /*=============================*/
    /* Reformat the closing token. */
    /*=============================*/

    PPBackup(theEnv);
    PPBackup(theEnv);
    SavePPBuffer(theEnv,DeffunctionData(theEnv)->DFInputToken.printForm);
    SavePPBuffer(theEnv,"\n");

    /*======================*/
    /* Add the deffunction. */
    /*======================*/

    AddDeffunction(theEnv,deffunctionName,actions,min,max,lvars,FALSE);

    ReturnExpression(theEnv,parameterList);

    return(DeffunctionError);
}
Пример #18
0
globle int ParseDeftemplate(
  void *theEnv,
  char *readSource)
  {

#if (! RUN_TIME) && (! BLOAD_ONLY)
   SYMBOL_HN *deftemplateName;
   struct deftemplate *newDeftemplate;
   struct templateSlot *slots;
   struct token inputToken;

   /*================================================*/
   /* Initialize pretty print and error information. */
   /*================================================*/

   DeftemplateData(theEnv)->DeftemplateError = FALSE;
   SetPPBufferStatus(theEnv,ON);
   FlushPPBuffer(theEnv);
   SavePPBuffer(theEnv,(char*)"(deftemplate ");

   /*==============================================================*/
   /* Deftemplates can not be added when a binary image is loaded. */
   /*==============================================================*/

#if BLOAD || BLOAD_AND_BSAVE
   if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      CannotLoadWithBloadMessage(theEnv,(char*)("deftemplate"));
      return(TRUE);
     }
#endif

   /*=======================================================*/
   /* Parse the name and comment fields of the deftemplate. */
   /*=======================================================*/

#if DEBUGGING_FUNCTIONS
   DeftemplateData(theEnv)->DeletedTemplateDebugFlags = 0;
#endif

   deftemplateName = GetConstructNameAndComment(theEnv,readSource,&inputToken,(char*)("deftemplate"),
                                                EnvFindDeftemplate,EnvUndeftemplate,(char*)("%"),
                                                TRUE,TRUE,TRUE);
   if (deftemplateName == NULL) return(TRUE);

   if (ReservedPatternSymbol(theEnv,ValueToString(deftemplateName),(char*)("deftemplate")))
     {
      ReservedPatternSymbolErrorMsg(theEnv,ValueToString(deftemplateName),
            (char*)("a deftemplate name"));
      return(TRUE);
     }

   /*===========================================*/
   /* Parse the slot fields of the deftemplate. */
   /*===========================================*/

   slots = SlotDeclarations(theEnv,readSource,&inputToken);
   if (DeftemplateData(theEnv)->DeftemplateError == TRUE) return(TRUE);

   /*==============================================*/
   /* If we're only checking syntax, don't add the */
   /* successfully parsed deftemplate to the KB.   */
   /*==============================================*/

   if (ConstructData(theEnv)->CheckSyntaxMode)
     {
      ReturnSlots(theEnv,slots);
      return(FALSE);
     }

   /*=====================================*/
   /* Create a new deftemplate structure. */
   /*=====================================*/

   newDeftemplate = get_struct(theEnv,deftemplate);
   newDeftemplate->header.name =  deftemplateName;
   newDeftemplate->header.next = NULL;
   newDeftemplate->header.usrData = NULL;
   newDeftemplate->slotList = slots;
   newDeftemplate->implied = FALSE;
   newDeftemplate->numberOfSlots = 0;
   newDeftemplate->busyCount = 0;
   newDeftemplate->watch = 0;
   newDeftemplate->inScope = TRUE;
   newDeftemplate->patternNetwork = NULL;
   newDeftemplate->factList = NULL;
   newDeftemplate->lastFact = NULL;
   newDeftemplate->header.whichModule = (struct defmoduleItemHeader *)
                                        GetModuleItem(theEnv,NULL,DeftemplateData(theEnv)->DeftemplateModuleIndex);

   /*================================*/
   /* Determine the number of slots. */
   /*================================*/

   while (slots != NULL)
     {
      newDeftemplate->numberOfSlots++;
      slots = slots->next;
     }

   /*====================================*/
   /* Store pretty print representation. */
   /*====================================*/

   if (EnvGetConserveMemory(theEnv) == TRUE)
     { newDeftemplate->header.ppForm = NULL; }
   else
     { newDeftemplate->header.ppForm = CopyPPBuffer(theEnv); }

   /*=======================================================================*/
   /* If a template is redefined, then we want to restore its watch status. */
   /*=======================================================================*/

#if DEBUGGING_FUNCTIONS
   if ((BitwiseTest(DeftemplateData(theEnv)->DeletedTemplateDebugFlags,0)) || 
         EnvGetWatchItem(theEnv,(char*)"facts"))
     { EnvSetDeftemplateWatch(theEnv,ON,(void *) newDeftemplate); }
#endif

   /*==============================================*/
   /* Add deftemplate to the list of deftemplates. */
   /*==============================================*/

   AddConstructToModule(&newDeftemplate->header);

   InstallDeftemplate(theEnv,newDeftemplate);

#else
#endif

   return(FALSE);
  }
Пример #19
0
static struct lhsParseNode *LiteralRestrictionParse(
  void *theEnv,
  char *readSource,
  struct token *theToken,
  int *error)
  {
   struct lhsParseNode *topNode;
   struct expr *theExpression;

   /*============================================*/
   /* Create a node to represent the constraint. */
   /*============================================*/

   topNode = GetLHSParseNode(theEnv);

   /*=================================================*/
   /* Determine if the constraint has a '~' preceding */
   /* it. If it  does, then the field is negated      */
   /* (e.g. ~red means "not the constant red."        */
   /*=================================================*/

   if (theToken->type == NOT_CONSTRAINT)
     {
      GetToken(theEnv,readSource,theToken);
      topNode->negated = TRUE;
     }
   else
     { topNode->negated = FALSE; }

   /*===========================================*/
   /* Determine if the constraint is one of the */
   /* recognized types. These are ?variables,   */
   /* symbols, strings, numbers, :(expression), */
   /* and =(expression).                        */
   /*===========================================*/

   topNode->type = theToken->type;

   /*============================================*/
   /* Any symbol is valid, but an = signifies a  */
   /* return value constraint and an : signifies */
   /* a predicate constraint.                    */
   /*============================================*/

   if (theToken->type == SYMBOL)
     {
      /*==============================*/
      /* If the symbol is an =, parse */
      /* a return value constraint.   */
      /*==============================*/

      if (strcmp(ValueToString(theToken->value),"=") == 0)
        {
         theExpression = Function0Parse(theEnv,readSource);
         if (theExpression == NULL)
           {
            *error = TRUE;
            ReturnLHSParseNodes(theEnv,topNode);
            return(NULL);
           }
         topNode->type = RETURN_VALUE_CONSTRAINT;
         topNode->expression = ExpressionToLHSParseNodes(theEnv,theExpression);
         ReturnExpression(theEnv,theExpression);
        }

      /*=============================*/
      /* If the symbol is a :, parse */
      /* a predicate constraint.     */
      /*=============================*/

      else if (strcmp(ValueToString(theToken->value),":") == 0)
        {
         theExpression = Function0Parse(theEnv,readSource);
         if (theExpression == NULL)
           {
            *error = TRUE;
            ReturnLHSParseNodes(theEnv,topNode);
            return(NULL);
           }
         topNode->type = PREDICATE_CONSTRAINT;
         topNode->expression = ExpressionToLHSParseNodes(theEnv,theExpression);
         ReturnExpression(theEnv,theExpression);
        }

      /*==============================================*/
      /* Otherwise, treat the constraint as a symbol. */
      /*==============================================*/

      else
        { topNode->value = theToken->value; }
     }

   /*=====================================================*/
   /* Single and multifield variables and float, integer, */
   /* string, and instance name constants are also valid. */
   /*=====================================================*/

   else if ((theToken->type == SF_VARIABLE)  ||
            (theToken->type == MF_VARIABLE)  ||
            (theToken->type == FLOAT) ||
            (theToken->type == INTEGER) ||
            (theToken->type == STRING) ||
            (theToken->type == INSTANCE_NAME))
     { topNode->value = theToken->value; }

   /*===========================*/
   /* Anything else is invalid. */
   /*===========================*/

   else
     {
      SyntaxErrorMessage(theEnv,"defrule");
      *error = TRUE;
      ReturnLHSParseNodes(theEnv,topNode);
      return(NULL);
     }

   /*===============================*/
   /* Return the parsed constraint. */
   /*===============================*/

   return(topNode);
  }
Пример #20
0
static DATA_OBJECT_PTR GetSaveFactsDeftemplateNames(
    void *theEnv,
    struct expr *theList,
    int saveCode,
    int *count,
    int *error)
{
    struct expr *tempList;
    DATA_OBJECT_PTR theDOArray;
    int i, tempCount;
    struct deftemplate *theDeftemplate = NULL;

    /*=============================*/
    /* Initialize the error state. */
    /*=============================*/

    *error = FALSE;

    /*=====================================================*/
    /* If no deftemplate names were specified as arguments */
    /* then the deftemplate name list is empty.            */
    /*=====================================================*/

    if (theList == NULL)
    {
        *count = 0;
        return(NULL);
    }

    /*======================================*/
    /* Determine the number of deftemplate  */
    /* names to be stored in the name list. */
    /*======================================*/

    for (tempList = theList, *count = 0;
            tempList != NULL;
            tempList = tempList->nextArg, (*count)++)
    {   /* Do Nothing */
    }

    /*=========================================*/
    /* Allocate the storage for the name list. */
    /*=========================================*/

    theDOArray = (DATA_OBJECT_PTR) gm3(theEnv,(long) sizeof(DATA_OBJECT) * *count);

    /*=====================================*/
    /* Loop through each of the arguments. */
    /*=====================================*/

    for (tempList = theList, i = 0;
            i < *count;
            tempList = tempList->nextArg, i++)
    {
        /*========================*/
        /* Evaluate the argument. */
        /*========================*/

        EvaluateExpression(theEnv,tempList,&theDOArray[i]);

        if (EvaluationData(theEnv)->EvaluationError)
        {
            *error = TRUE;
            rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
            return(NULL);
        }

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

        if (theDOArray[i].type != SYMBOL)
        {
            *error = TRUE;
            ExpectedTypeError1(theEnv,"save-facts",3+i,"symbol");
            rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
            return(NULL);
        }

        /*===================================================*/
        /* Find the deftemplate. For a local save, look only */
        /* in the current module. For a visible save, look   */
        /* in all visible modules.                           */
        /*===================================================*/

        if (saveCode == LOCAL_SAVE)
        {
            theDeftemplate = (struct deftemplate *)
                             EnvFindDeftemplate(theEnv,ValueToString(theDOArray[i].value));
            if (theDeftemplate == NULL)
            {
                *error = TRUE;
                ExpectedTypeError1(theEnv,"save-facts",3+i,"local deftemplate name");
                rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
                return(NULL);
            }
        }
        else if (saveCode == VISIBLE_SAVE)
        {
            theDeftemplate = (struct deftemplate *)
                             FindImportedConstruct(theEnv,"deftemplate",NULL,
                                                   ValueToString(theDOArray[i].value),
                                                   &tempCount,TRUE,NULL);
            if (theDeftemplate == NULL)
            {
                *error = TRUE;
                ExpectedTypeError1(theEnv,"save-facts",3+i,"visible deftemplate name");
                rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
                return(NULL);
            }
        }

        /*==================================*/
        /* Add a pointer to the deftemplate */
        /* to the array being created.      */
        /*==================================*/

        theDOArray[i].type = DEFTEMPLATE_PTR;
        theDOArray[i].value = (void *) theDeftemplate;
    }

    /*===================================*/
    /* Return the array of deftemplates. */
    /*===================================*/

    return(theDOArray);
}
Пример #21
0
static void *SearchImportedConstructModules(
  void *theEnv,
  EXEC_STATUS,
  struct symbolHashNode *constructType,
  struct defmodule *matchModule,
  struct moduleItem *theModuleItem,
  struct symbolHashNode *findName,
  int *count,
  int searchCurrent,
  struct defmodule *notYetDefinedInModule)
  {
   struct defmodule *theModule;
   struct portItem *theImportList, *theExportList;
   void *rv, *arv = NULL;
   int searchModule, exported;
   struct defmodule *currentModule;

   /*=========================================*/
   /* Start the search in the current module. */
   /* If the current module has already been  */
   /* visited, then return.                   */
   /*=========================================*/

   currentModule = ((struct defmodule *) EnvGetCurrentModule(theEnv,execStatus));
   if (currentModule->visitedFlag) return(NULL);

   /*=======================================================*/
   /* The searchCurrent flag indicates whether the current  */
   /* module should be included in the search. In addition, */
   /* if matchModule is non-NULL, the current module will   */
   /* only be searched if it is the specific module from    */
   /* which we want the construct imported.                 */
   /*=======================================================*/

   if ((searchCurrent) &&
       ((matchModule == NULL) || (currentModule == matchModule)))
     {
      /*===============================================*/
      /* Look for the construct in the current module. */
      /*===============================================*/

      rv = (*theModuleItem->findFunction)(theEnv,execStatus,ValueToString(findName));

      /*========================================================*/
      /* If we're in the process of defining the construct in   */
      /* the module we're searching then go ahead and increment */
      /* the count indicating the number of modules in which    */
      /* the construct was found.                               */
      /*========================================================*/

      if (notYetDefinedInModule == currentModule)
        {
         (*count)++;
         arv = rv;
        }

      /*=========================================================*/
      /* Otherwise, if the construct is in the specified module, */
      /* increment the count only if the construct actually      */
      /* belongs to the module. [Some constructs, like the COOL  */
      /* system classes, can be found in any module, but they    */
      /* actually belong to the MAIN module.]                    */
      /*=========================================================*/

      else if (rv != NULL)
        {
         if (((struct constructHeader *) rv)->whichModule->theModule == currentModule)
           { (*count)++; }
         arv = rv;
        }
     }

   /*=====================================*/
   /* Mark the current module as visited. */
   /*=====================================*/

   currentModule->visitedFlag = TRUE;

   /*===================================*/
   /* Search through all of the modules */
   /* imported by the current module.   */
   /*===================================*/

   theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv,execStatus));
   theImportList = theModule->importList;

   while (theImportList != NULL)
     {
      /*===================================================*/
      /* Determine if the module should be searched (based */
      /* upon whether the entire module, all constructs of */
      /* a specific type, or specifically named constructs */
      /* are imported).                                    */
      /*===================================================*/

      searchModule = FALSE;
      if ((theImportList->constructType == NULL) ||
          (theImportList->constructType == constructType))
        {
         if ((theImportList->constructName == NULL) ||
             (theImportList->constructName == findName))
           { searchModule = TRUE; }
        }

      /*=================================*/
      /* Determine if the module exists. */
      /*=================================*/

      if (searchModule)
        {
         theModule = (struct defmodule *)
                     EnvFindDefmodule(theEnv,execStatus,ValueToString(theImportList->moduleName));
         if (theModule == NULL) searchModule = FALSE;
        }

      /*=======================================================*/
      /* Determine if the construct is exported by the module. */
      /*=======================================================*/

      if (searchModule)
        {
         exported = FALSE;
         theExportList = theModule->exportList;
         while ((theExportList != NULL) && (! exported))
           {
            if ((theExportList->constructType == NULL) ||
                (theExportList->constructType == constructType))
              {
               if ((theExportList->constructName == NULL) ||
                   (theExportList->constructName == findName))
                 { exported = TRUE; }
               }

            theExportList = theExportList->next;
           }

         if (! exported) searchModule = FALSE;
        }

      /*=================================*/
      /* Search in the specified module. */
      /*=================================*/

      if (searchModule)
        {
         EnvSetCurrentModule(theEnv,execStatus,(void *) theModule);
         if ((rv = SearchImportedConstructModules(theEnv,execStatus,constructType,matchModule,
                                                  theModuleItem,findName,
                                                  count,TRUE,
                                                  notYetDefinedInModule)) != NULL)
           { arv = rv; }
        }

      /*====================================*/
      /* Move on to the next imported item. */
      /*====================================*/

      theImportList = theImportList->next;
     }

   /*=========================*/
   /* Return a pointer to the */
   /* last construct found.   */
   /*=========================*/

   return(arv);
  }
Пример #22
0
globle void RetractCommand(
    void *theEnv)
{
    long int factIndex;
    struct fact *ptr;
    struct expr *theArgument;
    DATA_OBJECT theResult;
    int argNumber;

    /*================================*/
    /* Iterate through each argument. */
    /*================================*/

    for (theArgument = GetFirstArgument(), argNumber = 1;
            theArgument != NULL;
            theArgument = GetNextArgument(theArgument), argNumber++)
    {
        /*========================*/
        /* Evaluate the argument. */
        /*========================*/

        EvaluateExpression(theEnv,theArgument,&theResult);

        /*===============================================*/
        /* If the argument evaluates to an integer, then */
        /* it's assumed to be the fact index of the fact */
        /* to be retracted.                              */
        /*===============================================*/

        if (theResult.type == INTEGER)
        {
            /*==========================================*/
            /* A fact index must be a positive integer. */
            /*==========================================*/

            factIndex = ValueToLong(theResult.value);
            if (factIndex < 0)
            {
                ExpectedTypeError1(theEnv,"retract",argNumber,"fact-address, fact-index, or the symbol *");
                return;
            }

            /*================================================*/
            /* See if a fact with the specified index exists. */
            /*================================================*/

            ptr = FindIndexedFact(theEnv,factIndex);

            /*=====================================*/
            /* If the fact exists then retract it, */
            /* otherwise print an error message.   */
            /*=====================================*/

            if (ptr != NULL)
            {
                EnvRetract(theEnv,(void *) ptr);
            }
            else
            {
                char tempBuffer[20];
                sprintf(tempBuffer,"f-%ld",factIndex);
                CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
            }
        }

        /*===============================================*/
        /* Otherwise if the argument evaluates to a fact */
        /* address, we can directly retract it.          */
        /*===============================================*/

        else if (theResult.type == FACT_ADDRESS)
        {
            EnvRetract(theEnv,theResult.value);
        }

        /*============================================*/
        /* Otherwise if the argument evaluates to the */
        /* symbol *, then all facts are retracted.    */
        /*============================================*/

        else if ((theResult.type == SYMBOL) ?
                 (strcmp(ValueToString(theResult.value),"*") == 0) : FALSE)
        {
            RemoveAllFacts(theEnv);
            return;
        }

        /*============================================*/
        /* Otherwise the argument has evaluated to an */
        /* illegal value for the retract command.     */
        /*============================================*/

        else
        {
            ExpectedTypeError1(theEnv,"retract",argNumber,"fact-address, fact-index, or the symbol *");
            SetEvaluationError(theEnv,TRUE);
        }
    }
}
Пример #23
0
globle int LoadConstructsFromLogicalName(
  void *theEnv,
  char *readSource)
  {
   int constructFlag;
   struct token theToken;
   int noErrors = TRUE;
   int foundConstruct;

   /*=========================================*/
   /* Reset the halt execution and evaluation */
   /* error flags in preparation for parsing. */
   /*=========================================*/

   if (EvaluationData(theEnv)->CurrentEvaluationDepth == 0) SetHaltExecution(theEnv,FALSE);
   SetEvaluationError(theEnv,FALSE);

   /*========================================================*/
   /* Find the beginning of the first construct in the file. */
   /*========================================================*/

   EvaluationData(theEnv)->CurrentEvaluationDepth++;
   GetToken(theEnv,readSource,&theToken);
   foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,FALSE,&noErrors);

   /*==================================================*/
   /* Parse the file until the end of file is reached. */
   /*==================================================*/

   while ((foundConstruct == TRUE) && (GetHaltExecution(theEnv) == FALSE))
     {
      /*===========================================================*/
      /* Clear the pretty print buffer in preparation for parsing. */
      /*===========================================================*/

      FlushPPBuffer(theEnv);

      /*======================*/
      /* Parse the construct. */
      /*======================*/

      constructFlag = ParseConstruct(theEnv,ValueToString(theToken.value),readSource);

      /*==============================================================*/
      /* If an error occurred while parsing, then find the beginning  */
      /* of the next construct (but don't generate any more error     */
      /* messages--in effect, skip everything until another construct */
      /* is found).                                                   */
      /*==============================================================*/

      if (constructFlag == 1)
        {
         EnvPrintRouter(theEnv,WERROR,"\nERROR:\n");
         PrintInChunks(theEnv,WERROR,GetPPBuffer(theEnv));
         EnvPrintRouter(theEnv,WERROR,"\n");
         noErrors = FALSE;
         GetToken(theEnv,readSource,&theToken);
         foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,TRUE,&noErrors);
        }

      /*======================================================*/
      /* Otherwise, find the beginning of the next construct. */
      /*======================================================*/

      else
        {
         GetToken(theEnv,readSource,&theToken);
         foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,FALSE,&noErrors);
        }

      /*=====================================================*/
      /* Yield time if necessary to foreground applications. */
      /*=====================================================*/

       if (foundConstruct)
         { IncrementSymbolCount(theToken.value); }
       EvaluationData(theEnv)->CurrentEvaluationDepth--;
       PeriodicCleanup(theEnv,FALSE,TRUE);
       YieldTime(theEnv);
       EvaluationData(theEnv)->CurrentEvaluationDepth++;
       if (foundConstruct)
         { DecrementSymbolCount(theEnv,(SYMBOL_HN *) theToken.value); }
     }

   EvaluationData(theEnv)->CurrentEvaluationDepth--;

   /*========================================================*/
   /* Print a carriage return if a single character is being */
   /* printed to indicate constructs are being processed.    */
   /*========================================================*/

#if DEBUGGING_FUNCTIONS
   if ((EnvGetWatchItem(theEnv,"compilations") != TRUE) && GetPrintWhileLoading(theEnv))
#else
   if (GetPrintWhileLoading(theEnv))
#endif
     { EnvPrintRouter(theEnv,WDIALOG,"\n"); }

   /*=============================================================*/
   /* Once the load is complete, destroy the pretty print buffer. */
   /* This frees up any memory that was used to create the pretty */
   /* print forms for constructs during parsing. Thus calls to    */
   /* the mem-used function will accurately reflect the amount of */
   /* memory being used after a load command.                     */
   /*=============================================================*/

   DestroyPPBuffer(theEnv);

   /*==========================================================*/
   /* Return a boolean flag which indicates whether any errors */
   /* were encountered while loading the constructs.           */
   /*==========================================================*/

   return(noErrors);
  }
Пример #24
0
globle void FactsCommand(
    void *theEnv)
{
    int argumentCount;
    long int start = UNSPECIFIED, end = UNSPECIFIED, max = UNSPECIFIED;
    struct defmodule *theModule;
    DATA_OBJECT theValue;
    int argOffset;

    /*=========================================================*/
    /* Determine the number of arguments to the facts command. */
    /*=========================================================*/

    if ((argumentCount = EnvArgCountCheck(theEnv,"facts",NO_MORE_THAN,4)) == -1) return;

    /*==================================*/
    /* The default module for the facts */
    /* command is the current module.   */
    /*==================================*/

    theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));

    /*==========================================*/
    /* If no arguments were specified, then use */
    /* the default values to list the facts.    */
    /*==========================================*/

    if (argumentCount == 0)
    {
        EnvFacts(theEnv,WDISPLAY,theModule,(long) start,(long) end,(long) max);
        return;
    }

    /*========================================================*/
    /* Since there are one or more arguments, see if a module */
    /* or start index was specified as the first argument.    */
    /*========================================================*/

    EnvRtnUnknown(theEnv,1,&theValue);

    /*===============================================*/
    /* If the first argument is a symbol, then check */
    /* to see that a valid module was specified.     */
    /*===============================================*/

    if (theValue.type == SYMBOL)
    {
        theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(theValue.value));
        if ((theModule == NULL) && (strcmp(ValueToString(theValue.value),"*") != 0))
        {
            SetEvaluationError(theEnv,TRUE);
            CantFindItemErrorMessage(theEnv,"defmodule",ValueToString(theValue.value));
            return;
        }

        if ((start = GetFactsArgument(theEnv,2,argumentCount)) == INVALID) return;

        argOffset = 1;
    }

    /*================================================*/
    /* Otherwise if the first argument is an integer, */
    /* check to see that a valid index was specified. */
    /*================================================*/

    else if (theValue.type == INTEGER)
    {
        start = DOToLong(theValue);
        if (start < 0)
        {
            ExpectedTypeError1(theEnv,"facts",1,"symbol or positive number");
            SetHaltExecution(theEnv,TRUE);
            SetEvaluationError(theEnv,TRUE);
            return;
        }
        argOffset = 0;
    }

    /*==========================================*/
    /* Otherwise the first argument is invalid. */
    /*==========================================*/

    else
    {
        ExpectedTypeError1(theEnv,"facts",1,"symbol or positive number");
        SetHaltExecution(theEnv,TRUE);
        SetEvaluationError(theEnv,TRUE);
        return;
    }

    /*==========================*/
    /* Get the other arguments. */
    /*==========================*/

    if ((end = GetFactsArgument(theEnv,2 + argOffset,argumentCount)) == INVALID) return;
    if ((max = GetFactsArgument(theEnv,3 + argOffset,argumentCount)) == INVALID) return;

    /*=================*/
    /* List the facts. */
    /*=================*/

    EnvFacts(theEnv,WDISPLAY,theModule,(long) start,(long) end,(long) max);
}
Пример #25
0
globle SYMBOL_HN *GetConstructNameAndComment(
  void *theEnv,
  char *readSource,
  struct token *inputToken,
  char *constructName,
  void *(*findFunction)(void *,char *),
  int (*deleteFunction)(void *,void *),
  char *constructSymbol,
  int fullMessageCR,
  int getComment,
  int moduleNameAllowed)
  {
#if (MAC_MCW || WIN_MCW || MAC_XCD) && (! DEBUGGING_FUNCTIONS)
#pragma unused(fullMessageCR)
#endif
   SYMBOL_HN *name, *moduleName;
   int redefining = FALSE;
   void *theConstruct;
   unsigned separatorPosition;
   struct defmodule *theModule;

   /*==========================*/
   /* Next token should be the */
   /* name of the construct.   */
   /*==========================*/

   GetToken(theEnv,readSource,inputToken);
   if (inputToken->type != SYMBOL)
     {
      PrintErrorID(theEnv,"CSTRCPSR",2,TRUE);
      EnvPrintRouter(theEnv,WERROR,"Missing name for ");
      EnvPrintRouter(theEnv,WERROR,constructName);
      EnvPrintRouter(theEnv,WERROR," construct\n");
      return(NULL);
     }

   name = (SYMBOL_HN *) inputToken->value;

   /*===============================*/
   /* Determine the current module. */
   /*===============================*/

   separatorPosition = FindModuleSeparator(ValueToString(name));
   if (separatorPosition)
     {
      if (moduleNameAllowed == FALSE)
        {
         SyntaxErrorMessage(theEnv,"module specifier");
         return(NULL);
        }

      moduleName = ExtractModuleName(theEnv,separatorPosition,ValueToString(name));
      if (moduleName == NULL)
        {
         SyntaxErrorMessage(theEnv,"construct name");
         return(NULL);
        }

      theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(moduleName));
      if (theModule == NULL)
        {
         CantFindItemErrorMessage(theEnv,"defmodule",ValueToString(moduleName));
         return(NULL);
        }

      EnvSetCurrentModule(theEnv,(void *) theModule);
      name = ExtractConstructName(theEnv,separatorPosition,ValueToString(name));
      if (name == NULL)
        {
         SyntaxErrorMessage(theEnv,"construct name");
         return(NULL);
        }
     }

   /*=====================================================*/
   /* If the module was not specified, record the current */
   /* module name as part of the pretty-print form.       */
   /*=====================================================*/

   else
     {
      theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
      if (moduleNameAllowed)
        {
         PPBackup(theEnv);
         SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,theModule));
         SavePPBuffer(theEnv,"::");
         SavePPBuffer(theEnv,ValueToString(name));
        }
     }

   /*==================================================================*/
   /* Check for import/export conflicts from the construct definition. */
   /*==================================================================*/

#if DEFMODULE_CONSTRUCT
   if (FindImportExportConflict(theEnv,constructName,theModule,ValueToString(name)))
     {
      ImportExportConflictMessage(theEnv,constructName,ValueToString(name),NULL,NULL);
      return(NULL);
     }
#endif

   /*========================================================*/
   /* Remove the construct if it is already in the knowledge */
   /* base and we're not just checking syntax.               */
   /*========================================================*/

   if ((findFunction != NULL) && (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      theConstruct = (*findFunction)(theEnv,ValueToString(name));
      if (theConstruct != NULL)
        {
         redefining = TRUE;
         if (deleteFunction != NULL)
           {
            if ((*deleteFunction)(theEnv,theConstruct) == FALSE)
              {
               PrintErrorID(theEnv,"CSTRCPSR",4,TRUE);
               EnvPrintRouter(theEnv,WERROR,"Cannot redefine ");
               EnvPrintRouter(theEnv,WERROR,constructName);
               EnvPrintRouter(theEnv,WERROR," ");
               EnvPrintRouter(theEnv,WERROR,ValueToString(name));
               EnvPrintRouter(theEnv,WERROR," while it is in use.\n");
               return(NULL);
              }
           }
        }
     }

   /*=============================================*/
   /* If compilations are being watched, indicate */
   /* that a construct is being compiled.         */
   /*=============================================*/

#if DEBUGGING_FUNCTIONS
   if ((EnvGetWatchItem(theEnv,"compilations") == TRUE) &&
       GetPrintWhileLoading(theEnv) && (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      if (redefining) 
        {
         PrintWarningID(theEnv,"CSTRCPSR",1,TRUE);
         EnvPrintRouter(theEnv,WDIALOG,"Redefining ");
        }
      else EnvPrintRouter(theEnv,WDIALOG,"Defining ");

      EnvPrintRouter(theEnv,WDIALOG,constructName);
      EnvPrintRouter(theEnv,WDIALOG,": ");
      EnvPrintRouter(theEnv,WDIALOG,ValueToString(name));

      if (fullMessageCR) EnvPrintRouter(theEnv,WDIALOG,"\n");
      else EnvPrintRouter(theEnv,WDIALOG," ");
     }
   else
#endif
     {
      if (GetPrintWhileLoading(theEnv) && (! ConstructData(theEnv)->CheckSyntaxMode))
        { EnvPrintRouter(theEnv,WDIALOG,constructSymbol); }
     }

   /*===============================*/
   /* Get the comment if it exists. */
   /*===============================*/

   GetToken(theEnv,readSource,inputToken);
   if ((inputToken->type == STRING) && getComment)
     {
      PPBackup(theEnv);
      SavePPBuffer(theEnv," ");
      SavePPBuffer(theEnv,inputToken->printForm);
      GetToken(theEnv,readSource,inputToken);
      if (inputToken->type != RPAREN)
        {
         PPBackup(theEnv);
         SavePPBuffer(theEnv,"\n   ");
         SavePPBuffer(theEnv,inputToken->printForm);
        }
     }
   else if (inputToken->type != RPAREN)
     {
      PPBackup(theEnv);
      SavePPBuffer(theEnv,"\n   ");
      SavePPBuffer(theEnv,inputToken->printForm);
     }

   /*===================================*/
   /* Return the name of the construct. */
   /*===================================*/

   return(name);
  }
Пример #26
0
/*******************************************************************************
  NAME         : CreateGetAndPutHandlers
  DESCRIPTION  : Creates two message-handlers with
                  the following syntax for the slot:

                 (defmessage-handler <class> get-<slot-name> primary ()
                    ?self:<slot-name>)

                 For single-field slots:

                 (defmessage-handler <class> put-<slot-name> primary (?value)
                    (bind ?self:<slot-name> ?value))

                 For multifield slots:

                 (defmessage-handler <class> put-<slot-name> primary ($?value)
                    (bind ?self:<slot-name> ?value))

  INPUTS       : The class slot descriptor
  RETURNS      : Nothing useful
  SIDE EFFECTS : Message-handlers created
  NOTES        : A put handler is not created for read-only slots
 *******************************************************************************/
globle void CreateGetAndPutHandlers(
  void *theEnv,
  SLOT_DESC *sd)
  {
   char *className,*slotName;
   unsigned bufsz;
   char *buf,*handlerRouter = "*** Default Public Handlers ***";
   int oldPWL,oldCM;
   char *oldRouter;
   char *oldString;
   long oldIndex;

   if ((sd->createReadAccessor == 0) && (sd->createWriteAccessor == 0))
     return;
   className = ValueToString(sd->cls->header.name);
   slotName = ValueToString(sd->slotName->name);

   bufsz = (sizeof(char) * (strlen(className) + (strlen(slotName) * 2) + 80));
   buf = (char *) gm2(theEnv,bufsz);

   oldPWL = GetPrintWhileLoading(theEnv);
   SetPrintWhileLoading(theEnv,FALSE);
   oldCM = EnvSetConserveMemory(theEnv,TRUE);

   if (sd->createReadAccessor)
     {
      sprintf(buf,"%s get-%s () ?self:%s)",className,slotName,slotName);
      
      oldRouter = RouterData(theEnv)->FastCharGetRouter;
      oldString = RouterData(theEnv)->FastCharGetString;
      oldIndex = RouterData(theEnv)->FastCharGetIndex;
   
      RouterData(theEnv)->FastCharGetRouter = handlerRouter;
      RouterData(theEnv)->FastCharGetIndex = 0;
      RouterData(theEnv)->FastCharGetString = buf;
      
      ParseDefmessageHandler(theEnv,handlerRouter);
      DestroyPPBuffer(theEnv);
      /*
      if (OpenStringSource(theEnv,handlerRouter,buf,0))
        {
         ParseDefmessageHandler(handlerRouter);
         DestroyPPBuffer();
         CloseStringSource(theEnv,handlerRouter);
        }
      */
      RouterData(theEnv)->FastCharGetRouter = oldRouter;
      RouterData(theEnv)->FastCharGetIndex = oldIndex;
      RouterData(theEnv)->FastCharGetString = oldString;
     }

   if (sd->createWriteAccessor)
     {
      sprintf(buf,"%s put-%s ($?value) (bind ?self:%s ?value))",
                  className,slotName,slotName);
                  
      oldRouter = RouterData(theEnv)->FastCharGetRouter;
      oldString = RouterData(theEnv)->FastCharGetString;
      oldIndex = RouterData(theEnv)->FastCharGetIndex;
   
      RouterData(theEnv)->FastCharGetRouter = handlerRouter;
      RouterData(theEnv)->FastCharGetIndex = 0;
      RouterData(theEnv)->FastCharGetString = buf;
      
      ParseDefmessageHandler(theEnv,handlerRouter);
      DestroyPPBuffer(theEnv);

/*     
      if (OpenStringSource(theEnv,handlerRouter,buf,0))
        {
         ParseDefmessageHandler(handlerRouter);
         DestroyPPBuffer();
         CloseStringSource(theEnv,handlerRouter);
        }
*/        
      RouterData(theEnv)->FastCharGetRouter = oldRouter;
      RouterData(theEnv)->FastCharGetIndex = oldIndex;
      RouterData(theEnv)->FastCharGetString = oldString;
     }

   SetPrintWhileLoading(theEnv,oldPWL);
   EnvSetConserveMemory(theEnv,oldCM);

   rm(theEnv,(void *) buf,bufsz);
  }
Пример #27
0
globle void *ImplodeMultifield(
  void *theEnv,
  DATA_OBJECT *value)
  {
   size_t strsize = 0;
   long i, j;
   const char *tmp_str;
   char *ret_str;
   void *rv;
   struct multifield *theMultifield;
   DATA_OBJECT tempDO;

   /*===================================================*/
   /* Determine the size of the string to be allocated. */
   /*===================================================*/

   theMultifield = (struct multifield *) GetpValue(value);
   for (i = GetpDOBegin(value) ; i <= GetpDOEnd(value) ; i++)
     {
      if (GetMFType(theMultifield,i) == FLOAT)
        {
         tmp_str = FloatToString(theEnv,ValueToDouble(GetMFValue(theMultifield,i)));
         strsize += strlen(tmp_str) + 1;
        }
      else if (GetMFType(theMultifield,i) == INTEGER)
        {
         tmp_str = LongIntegerToString(theEnv,ValueToLong(GetMFValue(theMultifield,i)));
         strsize += strlen(tmp_str) + 1;
        }
      else if (GetMFType(theMultifield,i) == STRING)
        {
         strsize += strlen(ValueToString(GetMFValue(theMultifield,i))) + 3;
         tmp_str = ValueToString(GetMFValue(theMultifield,i));
         while(*tmp_str)
           {
            if (*tmp_str == '"')
              { strsize++; }
            else if (*tmp_str == '\\') /* GDR 111599 #835 */
              { strsize++; }           /* GDR 111599 #835 */
            tmp_str++;
           }
        }
#if OBJECT_SYSTEM
      else if (GetMFType(theMultifield,i) == INSTANCE_NAME)
        { strsize += strlen(ValueToString(GetMFValue(theMultifield,i))) + 3; }
      else if (GetMFType(theMultifield,i) == INSTANCE_ADDRESS)
        { strsize += strlen(ValueToString(((INSTANCE_TYPE *)
                            GetMFValue(theMultifield,i))->name)) + 3; }
#endif

      else
        { 
         SetType(tempDO,GetMFType(theMultifield,i));
         SetValue(tempDO,GetMFValue(theMultifield,i));
         strsize += strlen(DataObjectToString(theEnv,&tempDO)) + 1; 
        }
     }

   /*=============================================*/
   /* Allocate the string and copy all components */
   /* of the MULTIFIELD variable to it.           */
   /*=============================================*/

   if (strsize == 0) return(EnvAddSymbol(theEnv,""));
   ret_str = (char *) gm2(theEnv,strsize);
   for(j=0, i=GetpDOBegin(value); i <= GetpDOEnd(value) ; i++)
     {
      /*============================*/
      /* Convert numbers to strings */
      /*============================*/

      if (GetMFType(theMultifield,i) == FLOAT)
        {
         tmp_str = FloatToString(theEnv,ValueToDouble(GetMFValue(theMultifield,i)));
         while(*tmp_str)
           {
            *(ret_str+j) = *tmp_str;
            j++, tmp_str++;
           }
        }
      else if (GetMFType(theMultifield,i) == INTEGER)
        {
         tmp_str = LongIntegerToString(theEnv,ValueToLong(GetMFValue(theMultifield,i)));
         while(*tmp_str)
           {
            *(ret_str+j) = *tmp_str;
            j++, tmp_str++;
           }
        }

      /*=======================================*/
      /* Enclose strings in quotes and preceed */
      /* imbedded quotes with a backslash      */
      /*=======================================*/

      else if (GetMFType(theMultifield,i) == STRING)
        {
         tmp_str = ValueToString(GetMFValue(theMultifield,i));
         *(ret_str+j) = '"';
         j++;
         while(*tmp_str)
           {
            if (*tmp_str == '"')
              {
               *(ret_str+j) = '\\';
               j++;
              }
            else if (*tmp_str == '\\') /* GDR 111599 #835 */
              {                        /* GDR 111599 #835 */
               *(ret_str+j) = '\\';    /* GDR 111599 #835 */
               j++;                    /* GDR 111599 #835 */
              }                        /* GDR 111599 #835 */
              
            *(ret_str+j) = *tmp_str;
            j++, tmp_str++;
           }
         *(ret_str+j) = '"';
         j++;
        }
#if OBJECT_SYSTEM
      else if (GetMFType(theMultifield,i) == INSTANCE_NAME)
        {
         tmp_str = ValueToString(GetMFValue(theMultifield,i));
         *(ret_str + j++) = '[';
         while(*tmp_str)
           {
            *(ret_str+j) = *tmp_str;
            j++, tmp_str++;
           }
         *(ret_str + j++) = ']';
        }
      else if (GetMFType(theMultifield,i) == INSTANCE_ADDRESS)
        {
         tmp_str = ValueToString(((INSTANCE_TYPE *) GetMFValue(theMultifield,i))->name);
         *(ret_str + j++) = '[';
         while(*tmp_str)
           {
            *(ret_str+j) = *tmp_str;
            j++, tmp_str++;
           }
         *(ret_str + j++) = ']';
        }
#endif
      else
        {
         SetType(tempDO,GetMFType(theMultifield,i));
         SetValue(tempDO,GetMFValue(theMultifield,i));
         tmp_str = DataObjectToString(theEnv,&tempDO);
         while(*tmp_str)
           {
            *(ret_str+j) = *tmp_str;
            j++, tmp_str++;
           }
         }
      *(ret_str+j) = ' ';
      j++;
     }
   *(ret_str+j-1) = '\0';

   /*====================*/
   /* Return the string. */
   /*====================*/

   rv = EnvAddSymbol(theEnv,ret_str);
   rm(theEnv,ret_str,strsize);
   return(rv);
  }
Пример #28
0
/*********************************************************
  NAME         : CheckSlotReference
  DESCRIPTION  : Examines a ?self:<slot-name> reference
                 If the reference is a single-field or
                 global variable, checking and evaluation
                 is delayed until run-time.  If the
                 reference is a symbol, this routine
                 verifies that the slot is a legal
                 slot for the reference (i.e., it exists
                 in the class to which the message-handler
                 is being attached, it is visible and it
                 is writable for write reference)
  INPUTS       : 1) A buffer holding the class
                    of the handler being parsed
                 2) The type of the slot reference
                 3) The value of the slot reference
                 4) A flag indicating if this is a read
                    or write access
                 5) Value expression for write
  RETURNS      : Class slot on success, NULL on errors
  SIDE EFFECTS : Messages printed on errors.
  NOTES        : For static references, this function
                 insures that the slot is either
                 publicly visible or that the handler
                 is being attached to the same class in
                 which the private slot is defined.
 *********************************************************/
static SLOT_DESC *CheckSlotReference(
  void *theEnv,
  DEFCLASS *theDefclass,
  int theType,
  void *theValue,
  CLIPS_BOOLEAN writeFlag,
  EXPRESSION *writeExpression)
  {
   int slotIndex;
   SLOT_DESC *sd;
   int vCode;

   if (theType != SYMBOL)
     {
      PrintErrorID(theEnv,"MSGPSR",7,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Illegal value for ?self reference.\n");
      return(NULL);
     }
   slotIndex = FindInstanceTemplateSlot(theEnv,theDefclass,(SYMBOL_HN *) theValue);
   if (slotIndex == -1)
     {
      PrintErrorID(theEnv,"MSGPSR",6,FALSE);
      EnvPrintRouter(theEnv,WERROR,"No such slot ");
      EnvPrintRouter(theEnv,WERROR,ValueToString(theValue));
      EnvPrintRouter(theEnv,WERROR," in class ");
      EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) theDefclass));
      EnvPrintRouter(theEnv,WERROR," for ?self reference.\n");
      return(NULL);
     }
   sd = theDefclass->instanceTemplate[slotIndex];
   if ((sd->publicVisibility == 0) && (sd->cls != theDefclass))
     {
      SlotVisibilityViolationError(theEnv,sd,theDefclass);
      return(NULL);
     }
   if (! writeFlag)
     return(sd);

   /* =================================================
      If a slot is initialize-only, the WithinInit flag
      still needs to be checked at run-time, for the
      handler could be called out of the context of
      an init.
      ================================================= */
   if (sd->noWrite && (sd->initializeOnly == 0))
     {
      SlotAccessViolationError(theEnv,ValueToString(theValue),
                               FALSE,(void *) theDefclass);
      return(NULL);
     }

   if (EnvGetStaticConstraintChecking(theEnv))
     {
      vCode = ConstraintCheckExpressionChain(theEnv,writeExpression,sd->constraint);
      if (vCode != NO_VIOLATION)
        {
         PrintErrorID(theEnv,"CSTRNCHK",1,FALSE);
         EnvPrintRouter(theEnv,WERROR,"Expression for ");
         PrintSlot(theEnv,WERROR,sd,NULL,"direct slot write");
         ConstraintViolationErrorMessage(theEnv,NULL,NULL,0,0,NULL,0,
                                         vCode,sd->constraint,FALSE);
         return(NULL);
        }
     }
   return(sd);
  }
Пример #29
0
/*********************************************************************
  NAME         : DeleteHandler
  DESCRIPTION  : Deletes one or more message-handlers
                   from a class definition
  INPUTS       : 1) The class address
                 2) The message-handler name
                    (if this is * and there is no handler
                     called *, then the delete operations
                     will be applied to all handlers matching the type
                 3) The message-handler type
                    (if this is -1, then the delete operations will be
                     applied to all handlers matching the name
                 4) A flag saying whether to print error messages when
                     handlers are not found meeting specs
  RETURNS      : 1 if successful, 0 otherwise
  SIDE EFFECTS : Handlers deleted
  NOTES        : If any handlers for the class are
                   currently executing, this routine
                   will fail
 **********************************************************************/
globle int DeleteHandler(
   void *theEnv,
  EXEC_STATUS,
   DEFCLASS *cls,
   SYMBOL_HN *mname,
   int mtype,
   int indicate_missing)
  {
   long i;
   HANDLER *hnd;
   int found,success = 1;

   if (cls->handlerCount == 0)
     {
      if (indicate_missing)
        {
         HandlerDeleteError(theEnv,execStatus,EnvGetDefclassName(theEnv,execStatus,(void *) cls));
         return(0);
        }
      return(1);
     }
   if (HandlersExecuting(cls))
     {
      HandlerDeleteError(theEnv,execStatus,EnvGetDefclassName(theEnv,execStatus,(void *) cls));
      return(0);
     }
   if (mtype == -1)
     {
      found = FALSE;
      for (i = MAROUND ; i <= MAFTER ; i++)
        {
         hnd = FindHandlerByAddress(cls,mname,(unsigned) i);
         if (hnd != NULL)
           {
            found = TRUE;
            if (hnd->system == 0)
              hnd->mark = 1;
            else
              {
               PrintErrorID(theEnv,execStatus,"MSGPSR",3,FALSE);
               EnvPrintRouter(theEnv,execStatus,WERROR,"System message-handlers may not be modified.\n");
               success = 0;
              }
           }
        }
      if ((found == FALSE) ? (strcmp(ValueToString(mname),"*") == 0) : FALSE)
        {
         for (i = 0 ; i < cls->handlerCount ; i++)
           if (cls->handlers[i].system == 0)
             cls->handlers[i].mark = 1;
        }
     }
   else
     {
      hnd = FindHandlerByAddress(cls,mname,(unsigned) mtype);
      if (hnd == NULL)
        {
         if (strcmp(ValueToString(mname),"*") == 0)
           {
            for (i = 0 ; i < cls->handlerCount ; i++)
              if ((cls->handlers[i].type == (unsigned) mtype) &&
                  (cls->handlers[i].system == 0))
                cls->handlers[i].mark = 1;
           }
         else
           {
            if (indicate_missing)
              HandlerDeleteError(theEnv,execStatus,EnvGetDefclassName(theEnv,execStatus,(void *) cls));
            success = 0;
           }
        }
      else if (hnd->system == 0)
        hnd->mark = 1;
      else
        {
         if (indicate_missing)
           {
            PrintErrorID(theEnv,execStatus,"MSGPSR",3,FALSE);
            EnvPrintRouter(theEnv,execStatus,WERROR,"System message-handlers may not be modified.\n");
           }
         success = 0;
        }
     }
   DeallocateMarkedHandlers(theEnv,execStatus,cls);
   return(success);
  }
Пример #30
0
static struct expr *ModAndDupParse(
  void *theEnv,
  struct expr *top,
  char *logicalName,
  char *name)
  {
   int error = FALSE;
   struct token theToken;
   struct expr *nextOne, *tempSlot;
   struct expr *newField, *firstField, *lastField;
   int printError;
   short done;

   /*==================================================================*/
   /* Parse the fact-address or index to the modify/duplicate command. */
   /*==================================================================*/

   SavePPBuffer(theEnv," ");
   GetToken(theEnv,logicalName,&theToken);

   if ((theToken.type == SF_VARIABLE) || (theToken.type == GBL_VARIABLE))
     { nextOne = GenConstant(theEnv,theToken.type,theToken.value); }
   else if (theToken.type == INTEGER)
     {
      if (! TopLevelCommand(theEnv))
        {
         PrintErrorID(theEnv,"TMPLTFUN",1,TRUE);
         EnvPrintRouter(theEnv,WERROR,"Fact-indexes can only be used by ");
         EnvPrintRouter(theEnv,WERROR,name);
         EnvPrintRouter(theEnv,WERROR," as a top level command.\n");
         ReturnExpression(theEnv,top);
         return(NULL);
        }

      nextOne = GenConstant(theEnv,INTEGER,theToken.value);
     }
   else
     {
      ExpectedTypeError2(theEnv,name,1);
      ReturnExpression(theEnv,top);
      return(NULL);
     }

   nextOne->nextArg = NULL;
   nextOne->argList = NULL;
   top->argList = nextOne;
   nextOne = top->argList;

   /*=======================================================*/
   /* Parse the remaining modify/duplicate slot specifiers. */
   /*=======================================================*/

   GetToken(theEnv,logicalName,&theToken);
   while (theToken.type != RPAREN)
     {
      PPBackup(theEnv);
      SavePPBuffer(theEnv," ");
      SavePPBuffer(theEnv,theToken.printForm);

      /*=================================================*/
      /* Slot definition begins with a left parenthesis. */
      /*=================================================*/

      if (theToken.type != LPAREN)
        {
         SyntaxErrorMessage(theEnv,"duplicate/modify function");
         ReturnExpression(theEnv,top);
         return(NULL);
        }

      /*=================================*/
      /* The slot name must be a symbol. */
      /*=================================*/

      GetToken(theEnv,logicalName,&theToken);
      if (theToken.type != SYMBOL)
        {
         SyntaxErrorMessage(theEnv,"duplicate/modify function");
         ReturnExpression(theEnv,top);
         return(NULL);
        }

      /*=================================*/
      /* Check for duplicate slot names. */
      /*=================================*/

      for (tempSlot = top->argList->nextArg;
           tempSlot != NULL;
           tempSlot = tempSlot->nextArg)
        {
         if (tempSlot->value == theToken.value)
           {
            AlreadyParsedErrorMessage(theEnv,"slot ",ValueToString(theToken.value));
            ReturnExpression(theEnv,top);
            return(NULL);
           }
        }

      /*=========================================*/
      /* Add the slot name to the list of slots. */
      /*=========================================*/

      nextOne->nextArg = GenConstant(theEnv,SYMBOL,theToken.value);
      nextOne = nextOne->nextArg;

      /*====================================================*/
      /* Get the values to be stored in the specified slot. */
      /*====================================================*/

      firstField = NULL;
      lastField = NULL;
      done = FALSE;
      while (! done)
        {
         SavePPBuffer(theEnv," ");
         newField = GetAssertArgument(theEnv,logicalName,&theToken,&error,
                                      RPAREN,FALSE,&printError);

         if (error)
           {
            if (printError) SyntaxErrorMessage(theEnv,"deftemplate pattern");
            ReturnExpression(theEnv,top);
            return(NULL);
           }

         if (newField == NULL)
           { done = TRUE; }

         if (lastField == NULL)
           { firstField = newField; }
         else
           { lastField->nextArg = newField; }
         lastField = newField;
        }

      /*================================================*/
      /* Slot definition ends with a right parenthesis. */
      /*================================================*/

      if (theToken.type != RPAREN)
        {
         SyntaxErrorMessage(theEnv,"duplicate/modify function");
         ReturnExpression(theEnv,top);
         ReturnExpression(theEnv,firstField);
         return(NULL);
        }
      else
        {
         PPBackup(theEnv);
         PPBackup(theEnv);
         SavePPBuffer(theEnv,")");
        }

      nextOne->argList = firstField;

      GetToken(theEnv,logicalName,&theToken);
     }

   /*================================================*/
   /* Return the parsed modify/duplicate expression. */
   /*================================================*/

   return(top);
  }