miscfun.c

clips源代码

     { EnvSetConserveMemory(theEnv,FALSE); }

   /*=====================================================*/
   /* Otherwise, generate an error since the only allowed */
   /* arguments are "on" or "off."                        */
   /*=====================================================*/

   else
     {
      ExpectedTypeError1(theEnv,"conserve-mem",1,"symbol with value on or off");
      return;
     }

   return;
  }

#if DEBUGGING_FUNCTIONS

/****************************************/
/* MemUsedCommand: H/L access routine   */
/*   for the mem-used command.          */
/****************************************/
globle long long MemUsedCommand(
  void *theEnv)
  {
   /*=============================================*/
   /* The mem-used function accepts no arguments. */
   /*=============================================*/

   if (EnvArgCountCheck(theEnv,"mem-used",EXACTLY,0) == -1) return(0);

   /*============================================*/
   /* Return the amount of memory currently held */
   /* (both for current use and for later use).  */
   /*============================================*/

   return(EnvMemUsed(theEnv));
  }

/********************************************/
/* MemRequestsCommand: H/L access routine   */
/*   for the mem-requests command.          */
/********************************************/
globle long long MemRequestsCommand(
  void *theEnv)
  {
   /*=================================================*/
   /* The mem-requests function accepts no arguments. */
   /*=================================================*/

   if (EnvArgCountCheck(theEnv,"mem-requests",EXACTLY,0) == -1) return(0);

   /*==================================*/
   /* Return the number of outstanding */
   /* memory requests.                 */
   /*==================================*/

   return(EnvMemRequests(theEnv));
  }

#endif

/****************************************/
/* AproposCommand: H/L access routine   */
/*   for the apropos command.           */
/****************************************/
globle void AproposCommand(
  void *theEnv)
  {
   char *argument;
   DATA_OBJECT argPtr;
   struct symbolHashNode *hashPtr = NULL;
   size_t theLength;

   /*=======================================================*/
   /* The apropos command expects a single symbol argument. */
   /*=======================================================*/

   if (EnvArgCountCheck(theEnv,"apropos",EXACTLY,1) == -1) return;
   if (EnvArgTypeCheck(theEnv,"apropos",1,SYMBOL,&argPtr) == FALSE) return;

   /*=======================================*/
   /* Determine the length of the argument. */
   /*=======================================*/

   argument = DOToString(argPtr);
   theLength = strlen(argument);

   /*====================================================================*/
   /* Print each entry in the symbol table that contains the argument as */
   /* a substring. When using a non-ANSI compiler, only those strings    */
   /* that contain the substring starting at the beginning of the string */
   /* are printed.                                                       */
   /*====================================================================*/

   while ((hashPtr = GetNextSymbolMatch(theEnv,argument,theLength,hashPtr,TRUE,NULL)) != NULL)
     {
      EnvPrintRouter(theEnv,WDISPLAY,ValueToString(hashPtr));
      EnvPrintRouter(theEnv,WDISPLAY,"\n");
     }
  }

/****************************************/
/* OptionsCommand: H/L access routine   */
/*   for the options command.           */
/****************************************/
globle void OptionsCommand(
  void *theEnv)
  {
   /*===========================================*/
   /* The options command accepts no arguments. */
   /*===========================================*/

   if (EnvArgCountCheck(theEnv,"options",EXACTLY,0) == -1) return;

   /*=================================*/
   /* Print the state of the compiler */
   /* flags for this executable.      */
   /*=================================*/

   EnvPrintRouter(theEnv,WDISPLAY,"Machine type: ");

#if GENERIC
   EnvPrintRouter(theEnv,WDISPLAY,"Generic ");
#endif
#if VAX_VMS
   EnvPrintRouter(theEnv,WDISPLAY,"VAX VMS ");
#endif
#if UNIX_V
   EnvPrintRouter(theEnv,WDISPLAY,"UNIX System V or 4.2BSD ");
#endif
#if UNIX_7
   EnvPrintRouter(theEnv,WDISPLAY,"UNIX System III Version 7 or Sun Unix ");
#endif
#if MAC_MCW
   EnvPrintRouter(theEnv,WDISPLAY,"Apple Macintosh with CodeWarrior");
#endif
#if MAC_XCD
   EnvPrintRouter(theEnv,WDISPLAY,"Apple Macintosh with Xcode");
#endif
#if IBM_MSC
   EnvPrintRouter(theEnv,WDISPLAY,"IBM PC with Microsoft C");
#endif
#if IBM_TBC
   EnvPrintRouter(theEnv,WDISPLAY,"IBM PC with Turbo C");
#endif
#if IBM_MCW
   EnvPrintRouter(theEnv,WDISPLAY,"IBM PC with Metrowerks CodeWarrior");
#endif
EnvPrintRouter(theEnv,WDISPLAY,"\n");

EnvPrintRouter(theEnv,WDISPLAY,"Defrule construct is ");
#if DEFRULE_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"Defmodule construct is ");
#if DEFMODULE_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"Deftemplate construct is ");
#if DEFTEMPLATE_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"  Fact-set queries are ");
#if FACT_SET_QUERIES
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

#if DEFTEMPLATE_CONSTRUCT

EnvPrintRouter(theEnv,WDISPLAY,"  Deffacts construct is ");
#if DEFFACTS_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

#endif

EnvPrintRouter(theEnv,WDISPLAY,"Defglobal construct is ");
#if DEFGLOBAL_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"Deffunction construct is ");
#if DEFFUNCTION_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"Defgeneric/Defmethod constructs are ");
#if DEFGENERIC_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"Object System is ");
#if OBJECT_SYSTEM
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

#if OBJECT_SYSTEM

EnvPrintRouter(theEnv,WDISPLAY,"  Definstances construct is ");
#if DEFINSTANCES_CONSTRUCT
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"  Instance-set queries are ");
#if INSTANCE_SET_QUERIES
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"  Binary loading of instances is ");
#if BLOAD_INSTANCES
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"  Binary saving of instances is ");
#if BSAVE_INSTANCES
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

#endif

EnvPrintRouter(theEnv,WDISPLAY,"Extended math package is ");
#if EX_MATH
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"Text processing package is ");
#if TEXTPRO_FUNCTIONS
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

EnvPrintRouter(theEnv,WDISPLAY,"Help system is ");
#if HELP_FUNCTIONS
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
#endif

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

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

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

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

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

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

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

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

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

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

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

EnvPrintRouter(theEnv,WDISPLAY,"Run time module is ");
#if RUN_TIME
  EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
#else
  EnvPrintRouter(theEnv,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(
  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;