genrccom.c

clips源代码

static void RemoveDefgenericMethod(
  void *theEnv,
  DEFGENERIC *gfunc,
  long gi)
  {
   DEFMETHOD *narr;
   long b,e;

   if (gfunc->methods[gi].system)
     {
      SetEvaluationError(theEnv,TRUE);
      PrintErrorID(theEnv,"GENRCCOM",4,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Cannot remove implicit system function method for generic function ");
      EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
      EnvPrintRouter(theEnv,WERROR,".\n");
      return;
     }
   DeleteMethodInfo(theEnv,gfunc,&gfunc->methods[gi]);
   if (gfunc->mcnt == 1)
     {
      rm(theEnv,(void *) gfunc->methods,(int) sizeof(DEFMETHOD));
      gfunc->mcnt = 0;
      gfunc->methods = NULL;
     }
   else
     {
      gfunc->mcnt--;
      narr = (DEFMETHOD *) gm2(theEnv,(sizeof(DEFMETHOD) * gfunc->mcnt));
      for (b = e = 0 ; b < gfunc->mcnt ; b++ , e++)
        {
         if (((int) b) == gi)
           e++;
         GenCopyMemory(DEFMETHOD,1,&narr[b],&gfunc->methods[e]);
        }
      rm(theEnv,(void *) gfunc->methods,(sizeof(DEFMETHOD) * (gfunc->mcnt+1)));
      gfunc->methods = narr;
     }
  }

#endif

#if DEBUGGING_FUNCTIONS

/******************************************************
  NAME         : ListMethodsForGeneric
  DESCRIPTION  : Lists a brief description of methods
                   for a particular generic function
  INPUTS       : 1) The logical name of the output
                 2) Generic function to list methods for
  RETURNS      : The number of methods printed
  SIDE EFFECTS : None
  NOTES        : None
 ******************************************************/
static long ListMethodsForGeneric(
  void *theEnv,
  char *logicalName,
  DEFGENERIC *gfunc)
  {
   long gi;
   char buf[256];

   for (gi = 0 ; gi < gfunc->mcnt ; gi++)
     {
      EnvPrintRouter(theEnv,logicalName,EnvGetDefgenericName(theEnv,(void *) gfunc));
      EnvPrintRouter(theEnv,logicalName," #");
      PrintMethod(theEnv,buf,255,&gfunc->methods[gi]);
      EnvPrintRouter(theEnv,logicalName,buf);
      EnvPrintRouter(theEnv,logicalName,"\n");
     }
   return((long) gfunc->mcnt);
  }

/******************************************************************
  NAME         : DefgenericWatchAccess
  DESCRIPTION  : Parses a list of generic names passed by
                 AddWatchItem() and sets the traces accordingly
  INPUTS       : 1) A code indicating which trace flag is to be set
                    Ignored
                 2) The value to which to set the trace flags
                 3) A list of expressions containing the names
                    of the generics for which to set traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags set in specified generics
  NOTES        : Accessory function for AddWatchItem()
 ******************************************************************/
#if IBM_TBC
#pragma argsused
#endif
static unsigned DefgenericWatchAccess(
  void *theEnv,
  int code,
  unsigned newState,
  EXPRESSION *argExprs)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(code)
#endif

   return(ConstructSetWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,newState,argExprs,
                                    EnvGetDefgenericWatch,EnvSetDefgenericWatch));
  }

/***********************************************************************
  NAME         : DefgenericWatchPrint
  DESCRIPTION  : Parses a list of generic names passed by
                 AddWatchItem() and displays the traces accordingly
  INPUTS       : 1) The logical name of the output
                 2) A code indicating which trace flag is to be examined
                    Ignored
                 3) A list of expressions containing the names
                    of the generics for which to examine traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags displayed for specified generics
  NOTES        : Accessory function for AddWatchItem()
 ***********************************************************************/
#if IBM_TBC
#pragma argsused
#endif
static unsigned DefgenericWatchPrint(
  void *theEnv,
  char *logName,
  int code,
  EXPRESSION *argExprs)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(code)
#endif

   return(ConstructPrintWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,logName,argExprs,
                                    EnvGetDefgenericWatch,EnvSetDefgenericWatch));
  }

/******************************************************************
  NAME         : DefmethodWatchAccess
  DESCRIPTION  : Parses a list of methods passed by
                 AddWatchItem() and sets the traces accordingly
  INPUTS       : 1) A code indicating which trace flag is to be set
                    Ignored
                 2) The value to which to set the trace flags
                 3) A list of expressions containing the methods
                   for which to set traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags set in specified methods
  NOTES        : Accessory function for AddWatchItem()
 ******************************************************************/
#if IBM_TBC
#pragma argsused
#endif
static unsigned DefmethodWatchAccess(
  void *theEnv,
  int code,
  unsigned newState,
  EXPRESSION *argExprs)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(code)
#endif
   return(DefmethodWatchSupport(theEnv,(char *) (newState ? "watch" : "unwatch"),NULL,
                                newState,NULL,EnvSetDefmethodWatch,argExprs));
  }

/***********************************************************************
  NAME         : DefmethodWatchPrint
  DESCRIPTION  : Parses a list of methods passed by
                 AddWatchItem() and displays the traces accordingly
  INPUTS       : 1) The logical name of the output
                 2) A code indicating which trace flag is to be examined
                    Ignored
                 3) A list of expressions containing the methods for
                    which to examine traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags displayed for specified methods
  NOTES        : Accessory function for AddWatchItem()
 ***********************************************************************/
#if IBM_TBC
#pragma argsused
#endif
static unsigned DefmethodWatchPrint(
  void *theEnv,
  char *logName,
  int code,
  EXPRESSION *argExprs)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(code)
#endif
   return(DefmethodWatchSupport(theEnv,"list-watch-items",logName,0,
                                PrintMethodWatchFlag,NULL,argExprs));
  }

/*******************************************************
  NAME         : DefmethodWatchSupport
  DESCRIPTION  : Sets or displays methods specified
  INPUTS       : 1) The calling function name
                 2) The logical output name for displays
                    (can be NULL)
                 3) The new set state
                 4) The print function (can be NULL)
                 5) The trace function (can be NULL)
                 6) The methods expression list
  RETURNS      : TRUE if all OK,
                 FALSE otherwise
  SIDE EFFECTS : Method trace flags set or displayed
  NOTES        : None
 *******************************************************/
static unsigned DefmethodWatchSupport(
  void *theEnv,
  char *funcName,
  char *logName,
  unsigned newState,
  void (*printFunc)(void *,char *,void *,long),
  void (*traceFunc)(void *,unsigned,void *,long),
  EXPRESSION *argExprs)
  {
   void *theGeneric;
   unsigned long theMethod = 0;
   int argIndex = 2;
   DATA_OBJECT genericName,methodIndex;
   struct defmodule *theModule;

   /* ==============================
      If no methods are specified,
      show the trace for all methods
      in all generics
      ============================== */
   if (argExprs == NULL)
     {
      SaveCurrentModule(theEnv);
      theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
      while (theModule != NULL)
        {
         EnvSetCurrentModule(theEnv,(void *) theModule);
         if (traceFunc == NULL)
           {
            EnvPrintRouter(theEnv,logName,EnvGetDefmoduleName(theEnv,(void *) theModule));
            EnvPrintRouter(theEnv,logName,":\n");
           }
         theGeneric = EnvGetNextDefgeneric(theEnv,NULL);
         while (theGeneric != NULL)
            {
             theMethod = EnvGetNextDefmethod(theEnv,theGeneric,0);
             while (theMethod != 0)
               {
                if (traceFunc != NULL)
                  (*traceFunc)(theEnv,newState,theGeneric,theMethod);
                else
                  {
                   EnvPrintRouter(theEnv,logName,"   ");
                   (*printFunc)(theEnv,logName,theGeneric,theMethod);
                  }
                theMethod = EnvGetNextDefmethod(theEnv,theGeneric,theMethod);
               }
             theGeneric = EnvGetNextDefgeneric(theEnv,theGeneric);
            }
         theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,(void *) theModule);
        }
      RestoreCurrentModule(theEnv);
      return(TRUE);
     }

   /* =========================================
      Set the traces for every method specified
      ========================================= */
   while (argExprs != NULL)
     {
      if (EvaluateExpression(theEnv,argExprs,&genericName))
        return(FALSE);
      if ((genericName.type != SYMBOL) ? TRUE :
          ((theGeneric = (void *)
              LookupDefgenericByMdlOrScope(theEnv,DOToString(genericName))) == NULL))
        {
         ExpectedTypeError1(theEnv,funcName,argIndex,"generic function name");
         return(FALSE);
        }
      if (GetNextArgument(argExprs) == NULL)
        theMethod = 0;
      else
        {
         argExprs = GetNextArgument(argExprs);
         argIndex++;
         if (EvaluateExpression(theEnv,argExprs,&methodIndex))
           return(FALSE);
         if ((methodIndex.type != INTEGER) ? FALSE :
             ((DOToLong(methodIndex) <= 0) ? FALSE :
              (FindMethodByIndex((DEFGENERIC *) theGeneric,theMethod) != -1)))
           theMethod = (long) DOToLong(methodIndex);
         else
           {
            ExpectedTypeError1(theEnv,funcName,argIndex,"method index");
            return(FALSE);
           }
        }
      if (theMethod == 0)
        {
         theMethod = EnvGetNextDefmethod(theEnv,theGeneric,0);
         while (theMethod != 0)
           {
            if (traceFunc != NULL)
              (*traceFunc)(theEnv,newState,theGeneric,theMethod);
            else
              (*printFunc)(theEnv,logName,theGeneric,theMethod);
            theMethod = EnvGetNextDefmethod(theEnv,theGeneric,theMethod);
           }
        }
      else
        {
         if (traceFunc != NULL)
           (*traceFunc)(theEnv,newState,theGeneric,theMethod);
         else
           (*printFunc)(theEnv,logName,theGeneric,theMethod);
        }
      argExprs = GetNextArgument(argExprs);
      argIndex++;
     }
   return(TRUE);
  }

/***************************************************
  NAME         : PrintMethodWatchFlag
  DESCRIPTION  : Displays trace value for method
  INPUTS       : 1) The logical name of the output
                 2) The generic function
                 3) The method index
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
static void PrintMethodWatchFlag(
  void *theEnv,
  char *logName,
  void *theGeneric,
  long theMethod)
  {
   char buf[60];

   EnvPrintRouter(theEnv,logName,EnvGetDefgenericName(theEnv,theGeneric));
   EnvPrintRouter(theEnv,logName," ");
   EnvGetDefmethodDescription(theEnv,buf,59,theGeneric,theMethod);
   EnvPrintRouter(theEnv,logName,buf);
   EnvPrintRouter(theEnv,logName,(char *) (EnvGetDefmethodWatch(theEnv,theGeneric,theMethod) ? " = on\n" : " = off\n"));
  }

#endif

#if ! OBJECT_SYSTEM

/***************************************************
  NAME         : TypeCommand
  DESCRIPTION  : Works like "class" in COOL
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax: (type <primitive>)
 ***************************************************/
globle void TypeCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   EvaluateExpression(theEnv,GetFirstArgument(),result);
   result->value = (void *) EnvAddSymbol(theEnv,TypeName(theEnv,result->type));
   result->type = SYMBOL;
  }

#endif

#endif