miscfun.c

一套美国国家宇航局人工智能中心NASA的专家系统工具源代码

PrintCLIPS(WDISPLAY,"Bload capability is ");
#if BLOAD_ONLY
  PrintCLIPS(WDISPLAY,"BLOAD ONLY");
#endif
#if BLOAD
  PrintCLIPS(WDISPLAY,"BLOAD");
#endif
#if BLOAD_AND_BSAVE
  PrintCLIPS(WDISPLAY,"BLOAD AND BSAVE");
#endif
#if (! BLOAD_ONLY) && (! BLOAD) && (! BLOAD_AND_BSAVE)
  PrintCLIPS(WDISPLAY,"OFF ");
#endif
PrintCLIPS(WDISPLAY,"\n");

PrintCLIPS(WDISPLAY,"EMACS Editor is ");
#if EMACS_EDITOR
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Construct compiler is ");
#if CONSTRUCT_COMPILER
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Basic I/O is ");
#if BASIC_IO
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Extended I/O is ");
#if EXT_IO
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"String function package is ");
#if STRING_FUNCTIONS
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Multifield function package is ");
#if MULTIFIELD_FUNCTIONS
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Debugging functions are ");
#if DEBUGGING_FUNCTIONS
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Block memory is ");
#if BLOCK_MEMORY
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Window Interface flag is ");
#if WINDOW_INTERFACE
   PrintCLIPS(WDISPLAY,"ON\n");
#else
   PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Short link names are ");
#if SHORT_LINK_NAMES
   PrintCLIPS(WDISPLAY,"ON\n");
#else
   PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Developer flag is ");
#if DEVELOPER
   PrintCLIPS(WDISPLAY,"ON\n");
#else
   PrintCLIPS(WDISPLAY,"OFF\n");
#endif

PrintCLIPS(WDISPLAY,"Run time module is ");
#if RUN_TIME
  PrintCLIPS(WDISPLAY,"ON\n");
#else
  PrintCLIPS(WDISPLAY,"OFF\n");
#endif
  }

/********************************************************************
  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(result)
  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(GetFirstArgument()->argList);
   ExpandFuncMultifield(result,newargexp,&newargexp,
                        (VOID *) FindFunction("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(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(ValueToString(func->callFunctionName),
                                func->restrictions,CountArguments(newargexp)) == CLIPS_FALSE)
        {
         result->type = SYMBOL;
         result->value = CLIPSFalseSymbol;
         ReturnExpression(fcallexp);
         return;
        }
     }
#if DEFFUNCTION_CONSTRUCT 
   else if (fcallexp->type == PCALL)
     {
      if (CheckDeffunctionCall(fcallexp->value,
              CountArguments(fcallexp->argList)) == CLIPS_FALSE)
        {
         result->type = SYMBOL;
         result->value = CLIPSFalseSymbol;
         ReturnExpression(fcallexp);
         SetEvaluationError(TRUE);
         return;
        }
     }
#endif
     
   EvaluateExpression(fcallexp,result);
   ReturnExpression(fcallexp);
  }
  
/***********************************************************************
  NAME         : DummyExpandFuncMultifield
  DESCRIPTION  : The expansion of multifield arguments is valid only
                 when done for a function call.  All these expansions
                 are handled by the CLIPS wrpa-around function
                 (expansion-call) - see ExpandFuncCall.  If the CLIPS
                 function, epand-multifield is ever called directly,
                 it is an error.
  INPUTS       : Data object buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : EvaluationError set
  NOTES        : None
 **********************************************************************/
globle VOID DummyExpandFuncMultifield(result)
  DATA_OBJECT *result;
  {
   result->type = SYMBOL;
   result->value = CLIPSFalseSymbol;
   SetEvaluationError(TRUE);
   PrintErrorID("MISCFUN",1,CLIPS_FALSE);
   PrintCLIPS(WERROR,"expand$ must be used in the argument list of a function call.\n");
  }
  
/***********************************************************************
  NAME         : ExpandFuncMultifield
  DESCRIPTION  : Recursively examines an expression and replaces
                   PROC_EXPAND_MULTIFIELD expressions with the expanded
                   evaluation expression of its argument
  INPUTS       : 1) A data object result buffer
                 2) The expression to modify
                 3) The address of the expression, in case it is
                    deleted entirely
                 4) The address of the CLIPS function expand$
  RETURNS      : Nothing useful
  SIDE EFFECTS : Expressions allocated/deallocated as necessary
                 Evaluations performed
                 On errors, argument expression set to call a function
                   which causes an evaluation error when evaluated
                   a second time by actual caller.
  NOTES        : THIS ROUTINE MODIFIES EXPRESSIONS AT RUNTIME!!  MAKE
                 SURE THAT THE EXPRESSION PASSED IS SAFE TO CHANGE!!
 **********************************************************************/
static VOID ExpandFuncMultifield(result,exp,sto,expmult)
  DATA_OBJECT *result;
  EXPRESSION *exp,**sto;
  VOID *expmult;
  {
   EXPRESSION *newexp,*top,*bot;
   register long i; /* 6.04 Bug Fix */
   
   while (exp != NULL)
     {
      if (exp->value == expmult)
        {
         EvaluateExpression(exp->argList,result);
         ReturnExpression(exp->argList);
         if ((EvaluationError) || (result->type != MULTIFIELD))
           {
            exp->argList = NULL;
            if ((EvaluationError == CLIPS_FALSE) && (result->type != MULTIFIELD))
              ExpectedTypeError2("expand$",1);
            exp->value = (VOID *) FindFunction("(set-evaluation-error)");
            EvaluationError = CLIPS_FALSE;
            HaltExecution = CLIPS_FALSE;
            return;
           }
         top = bot = NULL;
         for (i = GetpDOBegin(result) ; i <= GetpDOEnd(result) ; i++)
           {
            newexp = get_struct(expr);
            newexp->type = GetMFType(result->value,i);
            newexp->value = GetMFValue(result->value,i);
            newexp->argList = NULL;
            newexp->nextArg = NULL;
            if (top == NULL)
              top = newexp;
            else
              bot->nextArg = newexp;
            bot = newexp;
           }
         if (top == NULL)
           {
            *sto = exp->nextArg;
            rtn_struct(expr,exp);
            exp = *sto;
           }
         else
           {
            bot->nextArg = exp->nextArg;
            *sto = top;
            rtn_struct(expr,exp);
            sto = &bot->nextArg;
            exp = bot->nextArg;
           }
        }
      else
        {
         if (exp->argList != NULL)
           ExpandFuncMultifield(result,exp->argList,&exp->argList,expmult);
         sto = &exp->nextArg;
         exp = exp->nextArg;
        }
     }
  }

/****************************************************************
  NAME         : CauseEvaluationError
  DESCRIPTION  : Dummy function use to cause evaluation errors on
                   a function call to generate error messages
  INPUTS       : None
  RETURNS      : A pointer to the CLIPSFalseSymbol
  SIDE EFFECTS : EvaluationError set
  NOTES        : None
 ****************************************************************/
globle SYMBOL_HN *CauseEvaluationError()
  {
   SetEvaluationError(TRUE);
   return((SYMBOL_HN *) CLIPSFalseSymbol);
  }
  
/****************************************************************
  NAME         : SetSORCommand
  DESCRIPTION  : Toggles SequenceOpMode - if TRUE, multifield
                   references are replaced with sequence
                   expansion operators
  INPUTS       : None
  RETURNS      : The old value of SequenceOpMode
  SIDE EFFECTS : SequenceOpMode toggled
  NOTES        : None
 ****************************************************************/
globle BOOLEAN SetSORCommand()
  {
#if (! RUN_TIME) && (! BLOAD_ONLY)
   DATA_OBJECT arg;
   
   if (ArgTypeCheck("set-sequence-operator-recognition",1,SYMBOL,&arg) == CLIPS_FALSE)
     return(SequenceOpMode);
   return(SetSequenceOperatorRecognition((arg.value == CLIPSFalseSymbol) ? 
                                         CLIPS_FALSE : CLIPS_TRUE));
#else 
     return(SequenceOpMode);
#endif
  }
  
/********************************************************************
  NAME         : GetFunctionRestrictions
  DESCRIPTION  : Gets DefineFunction2() restriction list for function
  INPUTS       : None
  RETURNS      : A string containing the function restriction codes
  SIDE EFFECTS : EvaluationError set on errors
  NOTES        : None
 ********************************************************************/
globle SYMBOL_HN *GetFunctionRestrictions()
  {
   DATA_OBJECT temp;
   struct FunctionDefinition *fptr;
   
   if (ArgTypeCheck("get-function-restrictions",1,SYMBOL,&temp) == CLIPS_FALSE)
     return((SYMBOL_HN *) AddSymbol(""));
   fptr = FindFunction(DOToString(temp));
   if (fptr == NULL)
     {
      CantFindItemErrorMessage("function",DOToString(temp));
      SetEvaluationError(TRUE);
      return((SYMBOL_HN *) AddSymbol(""));
     }
   if (fptr->restrictions == NULL)
     return((SYMBOL_HN *) AddSymbol("0**"));
   return((SYMBOL_HN *) AddSymbol(fptr->restrictions));
  }