prcdrfun.c

clips源代码

   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*             CLIPS Version 6.24  06/05/06            */
   /*                                                     */
   /*             PROCEDURAL FUNCTIONS MODULE             */
   /*******************************************************/

/*************************************************************/
/* Purpose: Contains the code for several procedural         */
/*   functions including if, while, loop-for-count, bind,    */
/*   progn, return, break, and switch                        */
/*                                                           */
/* Principal Programmer(s):                                  */
/*      Gary D. Riley                                        */
/*      Brian L. Donnell                                     */
/*                                                           */
/* Contributing Programmer(s):                               */
/*                                                           */
/* Revision History:                                         */
/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
/*                                                           */
/*            Changed name of variable exp to theExp         */
/*            because of Unix compiler warnings of shadowed  */
/*            definitions.                                   */
/*                                                           */
/*      6.24: Renamed BOOLEAN macro type to intBool.         */
/*                                                           */
/*************************************************************/

#define _PRCDRFUN_SOURCE_

#include <stdio.h>
#define _STDIO_INCLUDED_

#include "setup.h"

#include "argacces.h"
#include "constrnt.h"
#include "cstrnchk.h"
#include "cstrnops.h"
#include "envrnmnt.h"
#include "exprnpsr.h"
#include "memalloc.h"
#include "multifld.h"
#include "prcdrpsr.h"
#include "router.h"
#include "scanner.h"
#include "utility.h"

#include "prcdrfun.h"

#if DEFGLOBAL_CONSTRUCT
#include "globldef.h"
#endif

/**********************************************/
/* ProceduralFunctionDefinitions: Initializes */
/*   the procedural functions.                */
/**********************************************/
globle void ProceduralFunctionDefinitions(
  void *theEnv)
  {
   AllocateEnvironmentData(theEnv,PRCDRFUN_DATA,sizeof(struct procedureFunctionData),NULL);

#if ! RUN_TIME
   EnvDefineFunction2(theEnv,"if", 'u', PTIEF IfFunction, "IfFunction", NULL);
   EnvDefineFunction2(theEnv,"while", 'u', PTIEF WhileFunction, "WhileFunction", NULL);
   EnvDefineFunction2(theEnv,"loop-for-count",'u', PTIEF LoopForCountFunction, "LoopForCountFunction", NULL);
   EnvDefineFunction2(theEnv,"(get-loop-count)",'g', PTIEF GetLoopCount, "GetLoopCount", NULL);
   EnvDefineFunction2(theEnv,"bind", 'u', PTIEF BindFunction, "BindFunction", NULL);
   EnvDefineFunction2(theEnv,"progn", 'u', PTIEF PrognFunction, "PrognFunction", NULL);
   EnvDefineFunction2(theEnv,"return", 'u', PTIEF ReturnFunction, "ReturnFunction",NULL);
   EnvDefineFunction2(theEnv,"break", 'v', PTIEF BreakFunction, "BreakFunction",NULL);
   EnvDefineFunction2(theEnv,"switch", 'u', PTIEF SwitchFunction, "SwitchFunction",NULL);

   ProceduralFunctionParsers(theEnv);

   FuncSeqOvlFlags(theEnv,"progn",FALSE,FALSE);
   FuncSeqOvlFlags(theEnv,"if",FALSE,FALSE);
   FuncSeqOvlFlags(theEnv,"while",FALSE,FALSE);
   FuncSeqOvlFlags(theEnv,"loop-for-count",FALSE,FALSE);
   FuncSeqOvlFlags(theEnv,"return",FALSE,FALSE);
   FuncSeqOvlFlags(theEnv,"switch",FALSE,FALSE);
#endif
  }

/***************************************/
/* WhileFunction: H/L access routine   */
/*   for the while function.           */
/***************************************/
globle void WhileFunction(
  void *theEnv,
  DATA_OBJECT_PTR returnValue)
  {
   DATA_OBJECT theResult;
   
   /*====================================================*/
   /* Evaluate the body of the while loop as long as the */
   /* while condition evaluates to a non-FALSE value.    */
   /*====================================================*/

   EvaluationData(theEnv)->CurrentEvaluationDepth++;
   EnvRtnUnknown(theEnv,1,&theResult);
   while (((theResult.value != EnvFalseSymbol(theEnv)) ||
           (theResult.type != SYMBOL)) &&
           (EvaluationData(theEnv)->HaltExecution != TRUE))
     {
      if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
        break;
      EnvRtnUnknown(theEnv,2,&theResult);
      EvaluationData(theEnv)->CurrentEvaluationDepth--;
      if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
        { PropagateReturnValue(theEnv,&theResult); }
      PeriodicCleanup(theEnv,FALSE,TRUE);
      EvaluationData(theEnv)->CurrentEvaluationDepth++;
      if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
        break;
      EnvRtnUnknown(theEnv,1,&theResult);
     }
   EvaluationData(theEnv)->CurrentEvaluationDepth--;

   /*=====================================================*/
   /* Reset the break flag. The return flag is not reset  */
   /* because the while loop is probably contained within */
   /* a deffunction or RHS of a rule which needs to be    */
   /* returned from as well.                              */
   /*=====================================================*/

   ProcedureFunctionData(theEnv)->BreakFlag = FALSE;

   /*====================================================*/
   /* If the return command was issued, then return that */
   /* value, otherwise return the symbol FALSE.          */
   /*====================================================*/

   if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
     {
      returnValue->type = theResult.type;
      returnValue->value = theResult.value;
      returnValue->begin = theResult.begin;
      returnValue->end = theResult.end;
     }
   else
     {
      returnValue->type = SYMBOL;
      returnValue->value = EnvFalseSymbol(theEnv);
     }
  }

/**********************************************/
/* LoopForCountFunction: H/L access routine   */
/*   for the loop-for-count function.         */
/**********************************************/
globle void LoopForCountFunction(
  void *theEnv,
  DATA_OBJECT_PTR loopResult)
  {
   DATA_OBJECT arg_ptr;
   long long iterationEnd;
   LOOP_COUNTER_STACK *tmpCounter;

   tmpCounter = get_struct(theEnv,loopCounterStack);
   tmpCounter->loopCounter = 0L;
   tmpCounter->nxt = ProcedureFunctionData(theEnv)->LoopCounterStack;
   ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter;
   if (EnvArgTypeCheck(theEnv,"loop-for-count",1,INTEGER,&arg_ptr) == FALSE)
     {
      loopResult->type = SYMBOL;
      loopResult->value = EnvFalseSymbol(theEnv);
      ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter->nxt;
      rtn_struct(theEnv,loopCounterStack,tmpCounter);
      return;
     }
   tmpCounter->loopCounter = DOToLong(arg_ptr);
   if (EnvArgTypeCheck(theEnv,"loop-for-count",2,INTEGER,&arg_ptr) == FALSE)
     {
      loopResult->type = SYMBOL;
      loopResult->value = EnvFalseSymbol(theEnv);
      ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter->nxt;
      rtn_struct(theEnv,loopCounterStack,tmpCounter);
      return;
     }
   iterationEnd = DOToLong(arg_ptr);
   while ((tmpCounter->loopCounter <= iterationEnd) &&
          (EvaluationData(theEnv)->HaltExecution != TRUE))
     {
      if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
        break;
      EvaluationData(theEnv)->CurrentEvaluationDepth++;
      EnvRtnUnknown(theEnv,3,&arg_ptr);
      EvaluationData(theEnv)->CurrentEvaluationDepth--;
      if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
        { PropagateReturnValue(theEnv,&arg_ptr); }
      PeriodicCleanup(theEnv,FALSE,TRUE);
      if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
        break;
      tmpCounter->loopCounter++;
     }

   ProcedureFunctionData(theEnv)->BreakFlag = FALSE;
   if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
     {
      loopResult->type = arg_ptr.type;
      loopResult->value = arg_ptr.value;
      loopResult->begin = arg_ptr.begin;
      loopResult->end = arg_ptr.end;
     }
   else
     {
      loopResult->type = SYMBOL;
      loopResult->value = EnvFalseSymbol(theEnv);
     }
   ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter->nxt;
   rtn_struct(theEnv,loopCounterStack,tmpCounter);
  }

/************************************************/
/* GetLoopCount                                 */
/************************************************/
globle long long GetLoopCount(
  void *theEnv)
  {
   int depth;
   LOOP_COUNTER_STACK *tmpCounter;

   depth = ValueToInteger(GetFirstArgument()->value);
   tmpCounter = ProcedureFunctionData(theEnv)->LoopCounterStack;
   while (depth > 0)
     {
      tmpCounter = tmpCounter->nxt;
      depth--;
     }
   return(tmpCounter->loopCounter);
  }

/************************************/
/* IfFunction: H/L access routine   */
/*   for the if function.           */
/************************************/
globle void IfFunction(
  void *theEnv,
  DATA_OBJECT_PTR returnValue)
  {
   int numArgs;
   struct expr *theExpr;

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

   if ((EvaluationData(theEnv)->CurrentExpression->argList == NULL) ||
       (EvaluationData(theEnv)->CurrentExpression->argList->nextArg == NULL))
     {
      EnvArgRangeCheck(theEnv,"if",2,3);
      returnValue->type = SYMBOL;
      returnValue->value = EnvFalseSymbol(theEnv);
      return;
     }

   if (EvaluationData(theEnv)->CurrentExpression->argList->nextArg->nextArg == NULL)
     { numArgs = 2; }
   else if (EvaluationData(theEnv)->CurrentExpression->argList->nextArg->nextArg->nextArg == NULL)
     { numArgs = 3; }
   else
     {
      EnvArgRangeCheck(theEnv,"if",2,3);
      returnValue->type = SYMBOL;
      returnValue->value = EnvFalseSymbol(theEnv);
      return;
     }

   /*=========================*/
   /* Evaluate the condition. */
   /*=========================*/

   EvaluateExpression(theEnv,EvaluationData(theEnv)->CurrentExpression->argList,returnValue);

   if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
     {
      returnValue->type = SYMBOL;
      returnValue->value = EnvFalseSymbol(theEnv);
      return;
     }

   /*=========================================*/
   /* If the condition evaluated to FALSE and */
   /* an "else" portion exists, evaluate it   */
   /* and return the value.                   */
   /*=========================================*/

   if ((returnValue->value == EnvFalseSymbol(theEnv)) &&
       (returnValue->type == SYMBOL) &&
       (numArgs == 3))
     {
      theExpr = EvaluationData(theEnv)->CurrentExpression->argList->nextArg->nextArg;
      switch (theExpr->type)
        {
         case INTEGER:
         case FLOAT:
         case SYMBOL:
         case STRING:
#if OBJECT_SYSTEM
         case INSTANCE_NAME:
         case INSTANCE_ADDRESS:
#endif
         case EXTERNAL_ADDRESS:
           returnValue->type = theExpr->type;
           returnValue->value = theExpr->value;
           break;

         default:
           EvaluateExpression(theEnv,theExpr,returnValue);
           break;
        }
      return;
     }