miscfun.c

clips源代码

         result->value = EnvFalseSymbol(theEnv);
         ReturnExpression(theEnv,fcallexp);
         SetEvaluationError(theEnv,TRUE);
         return;
        }
     }
#endif

   EvaluateExpression(theEnv,fcallexp,result);
   ReturnExpression(theEnv,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 H/L wrap-around function
                 (expansion-call) - see ExpandFuncCall.  If the H/L
                 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(
  void *theEnv,
  DATA_OBJECT *result)
  {
   result->type = SYMBOL;
   result->value = EnvFalseSymbol(theEnv);
   SetEvaluationError(theEnv,TRUE);
   PrintErrorID(theEnv,"MISCFUN",1,FALSE);
   EnvPrintRouter(theEnv,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 H/L 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(
  void *theEnv,
  DATA_OBJECT *result,
  EXPRESSION *theExp,
  EXPRESSION **sto,
  void *expmult)
  {
   EXPRESSION *newexp,*top,*bot;
   register long i; /* 6.04 Bug Fix */

   while (theExp != NULL)
     {
      if (theExp->value == expmult)
        {
         EvaluateExpression(theEnv,theExp->argList,result);
         ReturnExpression(theEnv,theExp->argList);
         if ((EvaluationData(theEnv)->EvaluationError) || (result->type != MULTIFIELD))
           {
            theExp->argList = NULL;
            if ((EvaluationData(theEnv)->EvaluationError == FALSE) && (result->type != MULTIFIELD))
              ExpectedTypeError2(theEnv,"expand$",1);
            theExp->value = (void *) FindFunction(theEnv,"(set-evaluation-error)");
            EvaluationData(theEnv)->EvaluationError = FALSE;
            EvaluationData(theEnv)->HaltExecution = FALSE;
            return;
           }
         top = bot = NULL;
         for (i = GetpDOBegin(result) ; i <= GetpDOEnd(result) ; i++)
           {
            newexp = get_struct(theEnv,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 = theExp->nextArg;
            rtn_struct(theEnv,expr,theExp);
            theExp = *sto;
           }
         else
           {
            bot->nextArg = theExp->nextArg;
            *sto = top;
            rtn_struct(theEnv,expr,theExp);
            sto = &bot->nextArg;
            theExp = bot->nextArg;
           }
        }
      else
        {
         if (theExp->argList != NULL)
           ExpandFuncMultifield(theEnv,result,theExp->argList,&theExp->argList,expmult);
         sto = &theExp->nextArg;
         theExp = theExp->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 FalseSymbol
  SIDE EFFECTS : EvaluationError set
  NOTES        : None
 ****************************************************************/
globle void *CauseEvaluationError(
  void *theEnv)
  {
   SetEvaluationError(theEnv,TRUE);
   return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
  }

/****************************************************************
  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 intBool SetSORCommand(
  void *theEnv)
  {
#if (! RUN_TIME) && (! BLOAD_ONLY)
   DATA_OBJECT arg;

   if (EnvArgTypeCheck(theEnv,"set-sequence-operator-recognition",1,SYMBOL,&arg) == FALSE)
     return(ExpressionData(theEnv)->SequenceOpMode);
   return(EnvSetSequenceOperatorRecognition(theEnv,(arg.value == EnvFalseSymbol(theEnv)) ?
                                         FALSE : TRUE));
#else
     return(ExpressionData(theEnv)->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 void *GetFunctionRestrictions(
  void *theEnv)
  {
   DATA_OBJECT temp;
   struct FunctionDefinition *fptr;

   if (EnvArgTypeCheck(theEnv,"get-function-restrictions",1,SYMBOL,&temp) == FALSE)
     return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
   fptr = FindFunction(theEnv,DOToString(temp));
   if (fptr == NULL)
     {
      CantFindItemErrorMessage(theEnv,"function",DOToString(temp));
      SetEvaluationError(theEnv,TRUE);
      return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
     }
   if (fptr->restrictions == NULL)
     return((SYMBOL_HN *) EnvAddSymbol(theEnv,"0**"));
   return((SYMBOL_HN *) EnvAddSymbol(theEnv,fptr->restrictions));
  }

/*************************************************/
/* GetFunctionListFunction: H/L access routine   */
/*   for the get-function-list function.         */
/*************************************************/
globle void GetFunctionListFunction(
  void *theEnv,
  DATA_OBJECT *returnValue)
  {
   struct FunctionDefinition *theFunction;
   struct multifield *theList;
   unsigned long functionCount = 0;

   if (EnvArgCountCheck(theEnv,"get-function-list",EXACTLY,0) == -1)
     {
      EnvSetMultifieldErrorValue(theEnv,returnValue);
      return;
     }

   for (theFunction = GetFunctionList(theEnv);
        theFunction != NULL;
        theFunction = theFunction->next)
     { functionCount++; }

   SetpType(returnValue,MULTIFIELD);
   SetpDOBegin(returnValue,1);
   SetpDOEnd(returnValue,functionCount);
   theList = (struct multifield *) EnvCreateMultifield(theEnv,functionCount);
   SetpValue(returnValue,(void *) theList);

   for (theFunction = GetFunctionList(theEnv), functionCount = 1;
        theFunction != NULL;
        theFunction = theFunction->next, functionCount++)
     {
      SetMFType(theList,functionCount,SYMBOL);
      SetMFValue(theList,functionCount,theFunction->callFunctionName);
     }
  }

/***************************************/
/* FuncallFunction: H/L access routine */
/*   for the funcall function.         */
/***************************************/
globle void FuncallFunction(
  void *theEnv,
  DATA_OBJECT *returnValue)
  {
   int argCount, i, j;
   DATA_OBJECT theValue;
   FUNCTION_REFERENCE theReference;
   char *name;
   struct multifield *theMultifield;
   struct expr *lastAdd = NULL, *nextAdd, *multiAdd;
   struct FunctionDefinition *theFunction;
    
   /*==================================*/
   /* Set up the default return value. */
   /*==================================*/
   
   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,EnvFalseSymbol(theEnv));
   
   /*=================================================*/
   /* The funcall function has at least one argument: */
   /* the name of the function being called.          */
   /*=================================================*/
   
   if ((argCount = EnvArgCountCheck(theEnv,"funcall",AT_LEAST,1)) == -1) return;
   
   /*============================================*/
   /* Get the name of the function to be called. */
   /*============================================*/
   
   if (EnvArgTypeCheck(theEnv,"funcall",1,SYMBOL_OR_STRING,&theValue) == FALSE) 
     { return; }
   
   /*====================*/
   /* Find the function. */
   /*====================*/

   name = DOToString(theValue);
   if (! GetFunctionReference(theEnv,name,&theReference))
     {
      ExpectedTypeError1(theEnv,"funcall",1,"function, deffunction, or generic function name");
      return; 
     }
     
   /*====================================*/
   /* Functions with specialized parsers */
   /* cannot be used with funcall.       */
   /*====================================*/

   if (theReference.type == FCALL)
     {
      theFunction = FindFunction(theEnv,name);
      if (theFunction->parser != NULL)
        {
         ExpectedTypeError1(theEnv,"funcall",1,"function without specialized parser");
         return; 
        }
     }

   /*======================================*/
   /* Add the arguments to the expression. */
   /*======================================*/
     
   ExpressionInstall(theEnv,&theReference);

   for (i = 2; i <= argCount; i++)
     {
      EnvRtnUnknown(theEnv,i,&theValue);
      if (GetEvaluationError(theEnv))
        {  
         ExpressionDeinstall(theEnv,&theReference);
         return; 
        }
      
      switch(GetType(theValue))
        {
         case MULTIFIELD:
           nextAdd = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$"));

           if (lastAdd == NULL)
             { theReference.argList = nextAdd; }
           else
             { lastAdd->nextArg = nextAdd; }
           lastAdd = nextAdd;

           multiAdd = NULL;
           theMultifield = (struct multifield *) GetValue(theValue);
           for (j = GetDOBegin(theValue); j <= GetDOEnd(theValue); j++)
             {
              nextAdd = GenConstant(theEnv,GetMFType(theMultifield,j),GetMFValue(theMultifield,j));
              if (multiAdd == NULL)
                { lastAdd->argList = nextAdd; }
              else
                { multiAdd->nextArg = nextAdd; }
              multiAdd = nextAdd;
             }

           ExpressionInstall(theEnv,lastAdd);
           break;
         
         default:
           nextAdd = GenConstant(theEnv,GetType(theValue),GetValue(theValue));
           if (lastAdd == NULL)
             { theReference.argList = nextAdd; }
           else
             { lastAdd->nextArg = nextAdd; }
           lastAdd = nextAdd;
           ExpressionInstall(theEnv,lastAdd);
           break;    
        }
     }

   /*===========================================================*/
   /* Verify a deffunction has the correct number of arguments. */
   /*===========================================================*/

#if DEFFUNCTION_CONSTRUCT
   if (theReference.type == PCALL)
     {
      if (CheckDeffunctionCall(theEnv,theReference.value,CountArguments(theReference.argList)) == FALSE)
        {
         PrintErrorID(theEnv,"MISCFUN",4,FALSE);
         EnvPrintRouter(theEnv,WERROR,"Function funcall called with the wrong number of arguments for deffunction ");
         EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,theReference.value));
         EnvPrintRouter(theEnv,WERROR,"\n");
         ExpressionDeinstall(theEnv,&theReference);   
         ReturnExpression(theEnv,theReference.argList);
         return;
        }
     }
#endif
     
   /*======================*/
   /* Call the expression. */
   /*======================*/
   
   EvaluateExpression(theEnv,&theReference,returnValue);
   
   /*========================================*/
   /* Return the expression data structures. */
   /*========================================*/
   
   ExpressionDeinstall(theEnv,&theReference);
   ReturnExpression(theEnv,theReference.argList);
  }
  
/************************************/
/* TimeFunction: H/L access routine */
/*   for the time function.         */
/************************************/
globle double TimeFunction(
  void *theEnv)
  {
   /*=========================================*/
   /* The time function accepts no arguments. */
   /*=========================================*/

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

   /*==================*/
   /* Return the time. */
   /*==================*/

   return(gentime());
  }

/***************************************/
/* TimerFunction: H/L access routine   */
/*   for the timer function.           */
/***************************************/
globle double TimerFunction(
  void *theEnv)
  {
   int numa, i;
   double startTime;
   DATA_OBJECT returnValue;

   startTime = gentime();
   
   numa = EnvRtnArgCount(theEnv);

   i = 1;
   while ((i <= numa) && (GetHaltExecution(theEnv) != TRUE))
     {
      EnvRtnUnknown(theEnv,i,&returnValue);
      i++;
     }

   return(gentime() - startTime);
  }