C++ SetEvaluationError函数代码示例

/***************************************************************************
  NAME         : GetQueryInstanceSlot
  DESCRIPTION  : Internal function for referring to slots of instances in
                    instance array on instance-queries
  INPUTS       : The caller's result buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Caller's result buffer set appropriately
  NOTES        : H/L Syntax : ((query-instance-slot) <index> <slot-name>)
 **************************************************************************/
globle void GetQueryInstanceSlot(
  DATA_OBJECT *result)
  {
   INSTANCE_TYPE *ins;
   INSTANCE_SLOT *sp;
   DATA_OBJECT temp;
   QUERY_CORE *core;

   result->type = SYMBOL;
   result->value = FalseSymbol;

   core = FindQueryCore(DOPToInteger(GetFirstArgument()));
   ins = core->solns[DOPToInteger(GetFirstArgument()->nextArg)];
   EvaluateExpression(GetFirstArgument()->nextArg->nextArg,&temp);
   if (temp.type != SYMBOL)
     {
      ExpectedTypeError1("get",1,"symbol");
      SetEvaluationError(TRUE);
      return;
     }
   sp = FindInstanceSlot(ins,(SYMBOL_HN *) temp.value);
   if (sp == NULL)
     {
      SlotExistError(ValueToString(temp.value),"instance-set query");
      return;
     }
   result->type = sp->type;
   result->value = sp->value;
   if (sp->type == MULTIFIELD)
     {
      result->begin = 0;
      result->end = GetInstanceSlotLength(sp) - 1;
     }
  }

void MultiIntoSingleFieldSlotError(
  Environment *theEnv,
  struct templateSlot *theSlot,
  Deftemplate *theDeftemplate)
  {
   PrintErrorID(theEnv,"TMPLTFUN",1,true);
   WriteString(theEnv,STDERR,"Attempted to assert a multifield value ");
   WriteString(theEnv,STDERR,"into the single field slot ");
   if (theSlot != NULL)
     {
      WriteString(theEnv,STDERR,"'");
      WriteString(theEnv,STDERR,theSlot->slotName->contents);
      WriteString(theEnv,STDERR,"'");
     }
   else
     { WriteString(theEnv,STDERR,"<<unknown>>"); }
   WriteString(theEnv,STDERR," of deftemplate ");
   if (theDeftemplate != NULL)
     {
      WriteString(theEnv,STDERR,"'");
      WriteString(theEnv,STDERR,theDeftemplate->header.name->contents);
      WriteString(theEnv,STDERR,"'");
     }
   else
     { WriteString(theEnv,STDERR,"<<unknown>>"); }
   WriteString(theEnv,STDERR,".\n");

   SetEvaluationError(theEnv,true);
  }

/************************************************************************************
  NAME         : MessageHandlerExistPCommand
  DESCRIPTION  : Determines if a message-handler is present in a class
  INPUTS       : None
  RETURNS      : TRUE if the message header is present, FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (message-handler-existp <class> <hnd> [<type>])
 ************************************************************************************/
globle int MessageHandlerExistPCommand(
  void *theEnv)
  {
   DEFCLASS *cls;
   SYMBOL_HN *mname;
   DATA_OBJECT temp;
   unsigned mtype = MPRIMARY;
   
   if (EnvArgTypeCheck(theEnv,"message-handler-existp",1,SYMBOL,&temp) == FALSE)
     return(FALSE);
   cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
   if (cls == NULL)
     {
      ClassExistError(theEnv,"message-handler-existp",DOToString(temp));
      return(FALSE);
     }
   if (EnvArgTypeCheck(theEnv,"message-handler-existp",2,SYMBOL,&temp) == FALSE)
     return(FALSE);
   mname = (SYMBOL_HN *) GetValue(temp);
   if (EnvRtnArgCount(theEnv) == 3)
     {
      if (EnvArgTypeCheck(theEnv,"message-handler-existp",3,SYMBOL,&temp) == FALSE)
        return(FALSE);
      mtype = HandlerType(theEnv,"message-handler-existp",DOToString(temp));
      if (mtype == MERROR)
        {
         SetEvaluationError(theEnv,TRUE);
         return(FALSE);
        }
     }
   if (FindHandlerByAddress(cls,mname,mtype) != NULL)
     return(TRUE);
   return(FALSE);
  }

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

/*********************************************************************
  NAME         : SlotExistPCommand
  DESCRIPTION  : Determines if a slot is present in a class
  INPUTS       : None
  RETURNS      : True if the slot exists, false otherwise
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (slot-existp <class> <slot> [inherit])
 *********************************************************************/
void SlotExistPCommand(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   Defclass *cls;
   SlotDescriptor *sd;
   bool inheritFlag = false;
   UDFValue theArg;

   sd = CheckSlotExists(context,"slot-existp",&cls,false,true);
   if (sd == NULL)
     {
      returnValue->lexemeValue = FalseSymbol(theEnv);
      return;
     }

   if (UDFHasNextArgument(context))
     {
      if (! UDFNextArgument(context,SYMBOL_BIT,&theArg))
        { return; }

      if (strcmp(theArg.lexemeValue->contents,"inherit") != 0)
        {
         UDFInvalidArgumentMessage(context,"keyword \"inherit\"");
         SetEvaluationError(theEnv,true);
         returnValue->lexemeValue = FalseSymbol(theEnv);
         return;
        }
      inheritFlag = true;
     }

   returnValue->lexemeValue = CreateBoolean(theEnv,((sd->cls == cls) ? true : inheritFlag));
  }

/*******************************************************
  NAME         : TypeName
  DESCRIPTION  : Given an integer type code, this
                 function returns the string name of
                 the type
  INPUTS       : The type code
  RETURNS      : The name-string of the type, or
                 "<???UNKNOWN-TYPE???>" for unrecognized
                 types
  SIDE EFFECTS : EvaluationError set and error message
                 printed for unrecognized types
  NOTES        : Used only when COOL is not present
 *******************************************************/
globle char *TypeName(
  int tcode)
  {
   switch (tcode)
     {
      case INTEGER             : return(INTEGER_TYPE_NAME);
      case FLOAT               : return(FLOAT_TYPE_NAME);
      case SYMBOL              : return(SYMBOL_TYPE_NAME);
      case STRING              : return(STRING_TYPE_NAME);
      case MULTIFIELD          : return(MULTIFIELD_TYPE_NAME);
      case EXTERNAL_ADDRESS    : return(EXTERNAL_ADDRESS_TYPE_NAME);
      case FACT_ADDRESS        : return(FACT_ADDRESS_TYPE_NAME);
      case INSTANCE_ADDRESS    : return(INSTANCE_ADDRESS_TYPE_NAME);
      case INSTANCE_NAME       : return(INSTANCE_NAME_TYPE_NAME);
#if FUZZY_DEFTEMPLATES
      case FUZZY_VALUE         : return(FUZZY_VALUE_NAME);
#endif
      case OBJECT_TYPE_CODE    : return(OBJECT_TYPE_NAME);
      case PRIMITIVE_TYPE_CODE : return(PRIMITIVE_TYPE_NAME);
      case NUMBER_TYPE_CODE    : return(NUMBER_TYPE_NAME);
      case LEXEME_TYPE_CODE    : return(LEXEME_TYPE_NAME);
      case ADDRESS_TYPE_CODE   : return(ADDRESS_TYPE_NAME);
      case INSTANCE_TYPE_CODE  : return(INSTANCE_TYPE_NAME);
      default                  : PrintErrorID("INSCOM",1,FALSE);
                                 PrintRouter(WERROR,"Undefined type in function type.\n");
                                 SetEvaluationError(TRUE);
                                 return("<UNKNOWN-TYPE>");
     }
  }

static struct expr *StandardLoadFact(
    void *theEnv,
    char *logicalName,
    struct token *theToken)
{
    int error = FALSE;
    struct expr *temp;

    GetToken(theEnv,logicalName,theToken);
    if (theToken->type != LPAREN) return(NULL);

    temp = GenConstant(theEnv,FCALL,FindFunction(theEnv,"assert"));
    temp->argList = GetRHSPattern(theEnv,logicalName,theToken,&error,
                                  TRUE,FALSE,TRUE,RPAREN);

    if (error == TRUE)
    {
        EnvPrintRouter(theEnv,WERROR,"Function load-facts encountered an error\n");
        SetEvaluationError(theEnv,TRUE);
        ReturnExpression(theEnv,temp);
        return(NULL);
    }

    if (ExpressionContainsVariables(temp,TRUE))
    {
        ReturnExpression(theEnv,temp);
        return(NULL);
    }

    return(temp);
}

globle int EnvArgRangeCheck(
  void *theEnv,
  char *functionName,
  int min,
  int max)
  {
   int numberOfArguments;

   numberOfArguments = EnvRtnArgCount(theEnv);
   if ((numberOfArguments < min) || (numberOfArguments > max))
     {
      PrintErrorID(theEnv,"ARGACCES",1,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Function ");
      EnvPrintRouter(theEnv,WERROR,functionName);
      EnvPrintRouter(theEnv,WERROR," expected at least ");
      PrintLongInteger(theEnv,WERROR,(long) min);
      EnvPrintRouter(theEnv,WERROR," and no more than ");
      PrintLongInteger(theEnv,WERROR,(long) max);
      EnvPrintRouter(theEnv,WERROR," arguments.\n");
      SetHaltExecution(theEnv,TRUE);
      SetEvaluationError(theEnv,TRUE);
      return(-1);
     }

   return(numberOfArguments);
  }

globle DATA_OBJECT_PTR EnvRtnUnknown(
  void *theEnv,
  int argumentPosition,
  DATA_OBJECT_PTR returnValue)
  {
   int count = 1;
   struct expr *argPtr;

   /*=====================================================*/
   /* Find the appropriate argument in the argument list. */
   /*=====================================================*/

   for (argPtr = EvaluationData(theEnv)->CurrentExpression->argList;
        (argPtr != NULL) && (count < argumentPosition);
        argPtr = argPtr->nextArg)
     { count++; }

   if (argPtr == NULL)
     {
      NonexistantError(theEnv,"RtnUnknown",
                       ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
                       argumentPosition);
      SetHaltExecution(theEnv,TRUE);
      SetEvaluationError(theEnv,TRUE);
      return(NULL);
     }

   /*=======================================*/
   /* Return the value of the nth argument. */
   /*=======================================*/

   EvaluateExpression(theEnv,argPtr,returnValue);
   return(returnValue);
  }

void GetWatchItemCommand(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   UDFValue theValue;
   const char *argument;
   bool recognized;

   /*========================================*/
   /* Determine which item is to be watched. */
   /*========================================*/

   if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue))
     { return; }

   argument = theValue.lexemeValue->contents;
   ValidWatchItem(theEnv,argument,&recognized);
   if (recognized == false)
     {
      SetEvaluationError(theEnv,true);
      ExpectedTypeError1(theEnv,"get-watch-item",1,"'watchable symbol'");
      returnValue->lexemeValue = FalseSymbol(theEnv);
      return;
     }

   /*===========================*/
   /* Get the watch item value. */
   /*===========================*/

   if (GetWatchItem(theEnv,argument) == 1)
     { returnValue->lexemeValue = TrueSymbol(theEnv); }
   else
     { returnValue->lexemeValue = FalseSymbol(theEnv); }
  }

/*******************************************************
  NAME         : TypeName
  DESCRIPTION  : Given an integer type code, this
                 function returns the string name of
                 the type
  INPUTS       : The type code
  RETURNS      : The name-string of the type, or
                 "<???UNKNOWN-TYPE???>" for unrecognized
                 types
  SIDE EFFECTS : EvaluationError set and error message
                 printed for unrecognized types
  NOTES        : Used only when COOL is not present
 *******************************************************/
globle char *TypeName(
  void *theEnv,
  EXEC_STATUS,
  int tcode)
  {
   switch (tcode)
     {
      case INTEGER             : return(INTEGER_TYPE_NAME);
      case FLOAT               : return(FLOAT_TYPE_NAME);
      case SYMBOL              : return(SYMBOL_TYPE_NAME);
      case STRING              : return(STRING_TYPE_NAME);
      case MULTIFIELD          : return(MULTIFIELD_TYPE_NAME);
      case EXTERNAL_ADDRESS    : return(EXTERNAL_ADDRESS_TYPE_NAME);
      case FACT_ADDRESS        : return(FACT_ADDRESS_TYPE_NAME);
      case INSTANCE_ADDRESS    : return(INSTANCE_ADDRESS_TYPE_NAME);
      case INSTANCE_NAME       : return(INSTANCE_NAME_TYPE_NAME);
      case OBJECT_TYPE_CODE    : return(OBJECT_TYPE_NAME);
      case PRIMITIVE_TYPE_CODE : return(PRIMITIVE_TYPE_NAME);
      case NUMBER_TYPE_CODE    : return(NUMBER_TYPE_NAME);
      case LEXEME_TYPE_CODE    : return(LEXEME_TYPE_NAME);
      case ADDRESS_TYPE_CODE   : return(ADDRESS_TYPE_NAME);
      case INSTANCE_TYPE_CODE  : return(INSTANCE_TYPE_NAME);
      default                  : PrintErrorID(theEnv,execStatus,"INSCOM",1,FALSE);
                                 EnvPrintRouter(theEnv,execStatus,WERROR,"Undefined type in function type.\n");
                                 SetEvaluationError(theEnv,execStatus,TRUE);
                                 return("<UNKNOWN-TYPE>");
     }
  }

/**********************************************************
  NAME         : DetermineQueryTemplates
  DESCRIPTION  : Builds a list of templates to be used in
                   fact queries - uses parse form.
  INPUTS       : 1) The parse template expression chain
                 2) The name of the function being executed
                 3) Caller's buffer for restriction count
                    (# of separate lists)
  RETURNS      : The query list, or NULL on errors
  SIDE EFFECTS : Memory allocated for list
                 Busy count incremented for all templates
  NOTES        : Each restriction is linked by nxt pointer,
                   multiple templates in a restriction are
                   linked by the chain pointer.
                 Rcnt caller's buffer is set to reflect the
                   total number of chains
                 Assumes templateExp is not NULL and that each
                   restriction chain is terminated with
                   the QUERY_DELIMITER_SYMBOL "(QDS)"
 **********************************************************/
static QUERY_TEMPLATE *DetermineQueryTemplates(
  Environment *theEnv,
  Expression *templateExp,
  const char *func,
  unsigned *rcnt)
  {
   QUERY_TEMPLATE *clist = NULL, *cnxt = NULL, *cchain = NULL, *tmp;
   bool new_list = false;
   UDFValue temp;
   Deftemplate *theDeftemplate;

   *rcnt = 0;
   while (templateExp != NULL)
     {
      theDeftemplate = NULL;
      
      if (templateExp->type == DEFTEMPLATE_PTR)
        { theDeftemplate = (Deftemplate *) templateExp->value; }
      else if (EvaluateExpression(theEnv,templateExp,&temp))
        {
         DeleteQueryTemplates(theEnv,clist);
         return NULL;
        }
        
      if ((theDeftemplate == NULL) &&
          (temp.value == (void *) FactQueryData(theEnv)->QUERY_DELIMITER_SYMBOL))
        {
         new_list = true;
         (*rcnt)++;
        }
      else if ((tmp = FormChain(theEnv,func,theDeftemplate,&temp)) != NULL)
        {
         if (clist == NULL)
           { clist = cnxt = cchain = tmp; }
         else if (new_list == true)
           {
            new_list = false;
            cnxt->nxt = tmp;
            cnxt = cchain = tmp;
           }
         else
           { cchain->chain = tmp; }
           
         while (cchain->chain != NULL)
           { cchain = cchain->chain; }
        }
      else
        {
         SyntaxErrorMessage(theEnv,"fact-set query class restrictions");
         DeleteQueryTemplates(theEnv,clist);
         SetEvaluationError(theEnv,true);
         return NULL;
        }
        
      templateExp = templateExp->nextArg;
     }
     
   return clist;
  }

globle int SetIncrementalResetCommand(
  void *theEnv,
  EXEC_STATUS)
  {
   int oldValue;
   DATA_OBJECT argPtr;
   struct defmodule *theModule;

   oldValue = EnvGetIncrementalReset(theEnv,execStatus);

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

   if (EnvArgCountCheck(theEnv,execStatus,"set-incremental-reset",EXACTLY,1) == -1)
     { return(oldValue); }

   /*=========================================*/
   /* The incremental reset behavior can't be */
   /* changed when rules are loaded.          */
   /*=========================================*/

   SaveCurrentModule(theEnv,execStatus);

   for (theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,execStatus,NULL);
        theModule != NULL;
        theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,execStatus,theModule))
     {
      EnvSetCurrentModule(theEnv,execStatus,(void *) theModule);
      if (EnvGetNextDefrule(theEnv,execStatus,NULL) != NULL)
        {
         RestoreCurrentModule(theEnv,execStatus);
         PrintErrorID(theEnv,execStatus,"INCRRSET",1,FALSE);
         EnvPrintRouter(theEnv,execStatus,WERROR,"The incremental reset behavior cannot be changed with rules loaded.\n");
         SetEvaluationError(theEnv,execStatus,TRUE);
         return(oldValue);
        }
     }
     
   RestoreCurrentModule(theEnv,execStatus);

   /*==================================================*/
   /* The symbol FALSE disables incremental reset. Any */
   /* other value enables incremental reset.           */
   /*==================================================*/

   EnvRtnUnknown(theEnv,execStatus,1,&argPtr);

   if ((argPtr.value == EnvFalseSymbol(theEnv,execStatus)) && (argPtr.type == SYMBOL))
     { EnvSetIncrementalReset(theEnv,execStatus,FALSE); }
   else
     { EnvSetIncrementalReset(theEnv,execStatus,TRUE); }

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

   return(oldValue);
  }

void UnwatchCommand(
  Environment *theEnv,
  UDFContext *context,
  UDFValue *returnValue)
  {
   UDFValue theValue;
   const char *argument;
   bool recognized;
   WatchItemRecord *wPtr;

   /*==========================================*/
   /* Determine which item is to be unwatched. */
   /*==========================================*/

   if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue)) return;

   argument = theValue.lexemeValue->contents;
   wPtr = ValidWatchItem(theEnv,argument,&recognized);
   if (recognized == false)
     {
      SetEvaluationError(theEnv,true);
      UDFInvalidArgumentMessage(context,"watchable symbol");
      return;
     }

   /*=================================================*/
   /* Check to make sure extra arguments are allowed. */
   /*=================================================*/

   if (GetNextArgument(GetFirstArgument()) != NULL)
     {
      if ((wPtr == NULL) ? true : (wPtr->accessFunc == NULL))
        {
         SetEvaluationError(theEnv,true);
         ExpectedCountError(theEnv,"unwatch",EXACTLY,1);
         return;
        }
     }

   /*=====================*/
   /* Set the watch item. */
   /*=====================*/

   SetWatchItem(theEnv,argument,false,GetNextArgument(GetFirstArgument()));
  }

/********************************************************************
  NAME         : ExpandFuncCall
  DESCRIPTION  : This function is a wrap-around for a normal
                   function call.  It preexamines the argument
                   expression list and expands any references to the
                   sequence operator.  It builds a copy of the
                   function call expression with these new arguments
                   inserted and evaluates the function call.
  INPUTS       : A data object buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Expressions alloctaed/deallocated
                 Function called and arguments evaluated
                 EvaluationError set on errors
  NOTES        : None
 *******************************************************************/
globle void ExpandFuncCall(
    void *theEnv,
    DATA_OBJECT *result)
{
    EXPRESSION *newargexp,*fcallexp;
    struct FunctionDefinition *func;

    /* ======================================================================
       Copy the original function call's argument expression list.
       Look for expand$ function callsexpressions and replace those
         with the equivalent expressions of the expansions of evaluations
         of the arguments.
       ====================================================================== */
    newargexp = CopyExpression(theEnv,GetFirstArgument()->argList);
    ExpandFuncMultifield(theEnv,result,newargexp,&newargexp,
                         (void *) FindFunction(theEnv,"expand$"));

    /* ===================================================================
       Build the new function call expression with the expanded arguments.
       Check the number of arguments, if necessary, and call the thing.
       =================================================================== */
    fcallexp = get_struct(theEnv,expr);
    fcallexp->type = GetFirstArgument()->type;
    fcallexp->value = GetFirstArgument()->value;
    fcallexp->nextArg = NULL;
    fcallexp->argList = newargexp;
    if (fcallexp->type == FCALL)
    {
        func = (struct FunctionDefinition *) fcallexp->value;
        if (CheckFunctionArgCount(theEnv,ValueToString(func->callFunctionName),
                                  func->restrictions,CountArguments(newargexp)) == FALSE)
        {
            result->type = SYMBOL;
            result->value = EnvFalseSymbol(theEnv);
            ReturnExpression(theEnv,fcallexp);
            return;
        }
    }
#if DEFFUNCTION_CONSTRUCT
    else if (fcallexp->type == PCALL)
    {
        if (CheckDeffunctionCall(theEnv,fcallexp->value,
                                 CountArguments(fcallexp->argList)) == FALSE)
        {
            result->type = SYMBOL;
            result->value = EnvFalseSymbol(theEnv);
            ReturnExpression(theEnv,fcallexp);
            SetEvaluationError(theEnv,TRUE);
            return;
        }
    }
#endif

    EvaluateExpression(theEnv,fcallexp,result);
    ReturnExpression(theEnv,fcallexp);
}