src/clipsrules/core/genrcexe.c Source File

00001    /*******************************************************/
00002    /*      "C" Language Integrated Production System      */
00003    /*                                                     */
00004    /*             CLIPS Version 6.24  05/17/06            */
00005    /*                                                     */
00006    /*                                                     */
00007    /*******************************************************/
00008 
00009 /*************************************************************/
00010 /* Purpose: Generic Function Execution Routines              */
00011 /*                                                           */
00012 /* Principal Programmer(s):                                  */
00013 /*      Brian L. Dantes                                      */
00014 /*                                                           */
00015 /* Contributing Programmer(s):                               */
00016 /*                                                           */
00017 /* Revision History:                                         */
00018 /*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
00019 /*                                                           */
00020 /*      6.24: Removed IMPERATIVE_METHODS compilation flag.   */
00021 /*                                                           */
00022 /*************************************************************/
00023 
00024 /* =========================================
00025    *****************************************
00026                EXTERNAL DEFINITIONS
00027    =========================================
00028    ***************************************** */
00029 #include "setup.h"
00030 
00031 #if DEFGENERIC_CONSTRUCT
00032 
00033 #if OBJECT_SYSTEM
00034 #include "classcom.h"
00035 #include "classfun.h"
00036 #include "insfun.h"
00037 #endif
00038 
00039 #include "argacces.h"
00040 #include "constrct.h"
00041 #include "envrnmnt.h"
00042 #include "genrccom.h"
00043 #include "prcdrfun.h"
00044 #include "prccode.h"
00045 #include "proflfun.h"
00046 #include "router.h"
00047 #include "utility.h"
00048 
00049 #define _GENRCEXE_SOURCE_
00050 #include "genrcexe.h"
00051 
00052 /* =========================================
00053    *****************************************
00054                    CONSTANTS
00055    =========================================
00056    ***************************************** */
00057 
00058 #define BEGIN_TRACE     ">>"
00059 #define END_TRACE       "<<"
00060 
00061 /* =========================================
00062    *****************************************
00063       INTERNALLY VISIBLE FUNCTION HEADERS
00064    =========================================
00065    ***************************************** */
00066 
00067 static DEFMETHOD *FindApplicableMethod(void *,DEFGENERIC *,DEFMETHOD *);
00068 
00069 #if DEBUGGING_FUNCTIONS
00070 static void WatchGeneric(void *,char *);
00071 static void WatchMethod(void *,char *);
00072 #endif
00073 
00074 #if OBJECT_SYSTEM
00075 static DEFCLASS *DetermineRestrictionClass(void *,DATA_OBJECT *);
00076 #endif
00077 
00078 /* =========================================
00079    *****************************************
00080           EXTERNALLY VISIBLE FUNCTIONS
00081    =========================================
00082    ***************************************** */
00083 
00084 /***********************************************************************************
00085   NAME         : GenericDispatch
00086   DESCRIPTION  : Executes the most specific applicable method
00087   INPUTS       : 1) The generic function
00088                  2) The method to start after in the search for an applicable
00089                     method (ignored if arg #3 is not NULL).
00090                  3) A specific method to call (NULL if want highest precedence
00091                     method to be called)
00092                  4) The generic function argument expressions
00093                  5) The caller's result value buffer
00094   RETURNS      : Nothing useful
00095   SIDE EFFECTS : Any side-effects of evaluating the generic function arguments
00096                  Any side-effects of evaluating query functions on method parameter
00097                    restrictions when determining the core (see warning #1)
00098                  Any side-effects of actual execution of methods (see warning #2)
00099                  Caller's buffer set to the result of the generic function call
00100 
00101                  In case of errors, the result is FALSE, otherwise it is the
00102                    result returned by the most specific method (which can choose
00103                    to ignore or return the values of more general methods)
00104   NOTES        : WARNING #1: Query functions on method parameter restrictions
00105                     should not have side-effects, for they might be evaluated even
00106                     for methods that aren't applicable to the generic function call.
00107                  WARNING #2: Side-effects of method execution should not always rely
00108                     on only being executed once per generic function call.  Every
00109                     time a method calls (shadow-call) the same next-most-specific
00110                     method is executed.  Thus, it is possible for a method to be
00111                     executed multiple times per generic function call.
00112  ***********************************************************************************/
00113 globle void GenericDispatch(
00114   void *theEnv,
00115   DEFGENERIC *gfunc,
00116   DEFMETHOD *prevmeth,
00117   DEFMETHOD *meth,
00118   EXPRESSION *params,
00119   DATA_OBJECT *result)
00120   {
00121    DEFGENERIC *previousGeneric;
00122    DEFMETHOD *previousMethod;
00123    int oldce;
00124 #if PROFILING_FUNCTIONS
00125    struct profileFrameInfo profileFrame;
00126 #endif
00127 
00128    result->type = SYMBOL;
00129    result->value = EnvFalseSymbol(theEnv);
00130    EvaluationData(theEnv)->EvaluationError = FALSE;
00131    if (EvaluationData(theEnv)->HaltExecution)
00132      return;
00133    oldce = ExecutingConstruct(theEnv);
00134    SetExecutingConstruct(theEnv,TRUE);
00135    previousGeneric = DefgenericData(theEnv)->CurrentGeneric;
00136    previousMethod = DefgenericData(theEnv)->CurrentMethod;
00137    DefgenericData(theEnv)->CurrentGeneric = gfunc;
00138    EvaluationData(theEnv)->CurrentEvaluationDepth++;
00139    gfunc->busy++;
00140    PushProcParameters(theEnv,params,CountArguments(params),
00141                       EnvGetDefgenericName(theEnv,(void *) gfunc),
00142                       "generic function",UnboundMethodErr);
00143    if (EvaluationData(theEnv)->EvaluationError)
00144      {
00145       gfunc->busy--;
00146       DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
00147       DefgenericData(theEnv)->CurrentMethod = previousMethod;
00148       EvaluationData(theEnv)->CurrentEvaluationDepth--;
00149       PeriodicCleanup(theEnv,FALSE,TRUE);
00150       SetExecutingConstruct(theEnv,oldce);
00151       return;
00152      }
00153    if (meth != NULL)
00154      {
00155       if (IsMethodApplicable(theEnv,meth))
00156         {
00157          meth->busy++;
00158          DefgenericData(theEnv)->CurrentMethod = meth;
00159         }
00160       else
00161         {
00162          PrintErrorID(theEnv,"GENRCEXE",4,FALSE);
00163          SetEvaluationError(theEnv,TRUE);
00164          DefgenericData(theEnv)->CurrentMethod = NULL;
00165          EnvPrintRouter(theEnv,WERROR,"Generic function ");
00166          EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
00167          EnvPrintRouter(theEnv,WERROR," method #");
00168          PrintLongInteger(theEnv,WERROR,(long long) meth->index);
00169          EnvPrintRouter(theEnv,WERROR," is not applicable to the given arguments.\n");
00170         }
00171      }
00172    else
00173      DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,gfunc,prevmeth);
00174    if (DefgenericData(theEnv)->CurrentMethod != NULL)
00175      {
00176 #if DEBUGGING_FUNCTIONS
00177       if (DefgenericData(theEnv)->CurrentGeneric->trace)
00178         WatchGeneric(theEnv,BEGIN_TRACE);
00179       if (DefgenericData(theEnv)->CurrentMethod->trace)
00180         WatchMethod(theEnv,BEGIN_TRACE);
00181 #endif
00182       if (DefgenericData(theEnv)->CurrentMethod->system)
00183         {
00184          EXPRESSION fcall;
00185 
00186          fcall.type = FCALL;
00187          fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
00188          fcall.nextArg = NULL;
00189          fcall.argList = GetProcParamExpressions(theEnv);
00190          EvaluateExpression(theEnv,&fcall,result);
00191         }
00192       else
00193         {
00194 #if PROFILING_FUNCTIONS
00195          StartProfile(theEnv,&profileFrame,
00196                       &DefgenericData(theEnv)->CurrentMethod->usrData,
00197                       ProfileFunctionData(theEnv)->ProfileConstructs);
00198 #endif
00199 
00200          EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
00201                              DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
00202                              result,UnboundMethodErr);
00203 
00204 #if PROFILING_FUNCTIONS
00205          EndProfile(theEnv,&profileFrame);
00206 #endif
00207         }
00208       DefgenericData(theEnv)->CurrentMethod->busy--;
00209 #if DEBUGGING_FUNCTIONS
00210       if (DefgenericData(theEnv)->CurrentMethod->trace)
00211         WatchMethod(theEnv,END_TRACE);
00212       if (DefgenericData(theEnv)->CurrentGeneric->trace)
00213         WatchGeneric(theEnv,END_TRACE);
00214 #endif
00215      }
00216    else if (! EvaluationData(theEnv)->EvaluationError)
00217      {
00218       PrintErrorID(theEnv,"GENRCEXE",1,FALSE);
00219       EnvPrintRouter(theEnv,WERROR,"No applicable methods for ");
00220       EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
00221       EnvPrintRouter(theEnv,WERROR,".\n");
00222       SetEvaluationError(theEnv,TRUE);
00223      }
00224    gfunc->busy--;
00225    ProcedureFunctionData(theEnv)->ReturnFlag = FALSE;
00226    PopProcParameters(theEnv);
00227    DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
00228    DefgenericData(theEnv)->CurrentMethod = previousMethod;
00229    EvaluationData(theEnv)->CurrentEvaluationDepth--;
00230    PropagateReturnValue(theEnv,result);
00231    PeriodicCleanup(theEnv,FALSE,TRUE);
00232    SetExecutingConstruct(theEnv,oldce);
00233   }
00234 
00235 /*******************************************************
00236   NAME         : UnboundMethodErr
00237   DESCRIPTION  : Print out a synopis of the currently
00238                    executing method for unbound variable
00239                    errors
00240   INPUTS       : None
00241   RETURNS      : Nothing useful
00242   SIDE EFFECTS : Error synopsis printed to WERROR
00243   NOTES        : None
00244  *******************************************************/
00245 globle void UnboundMethodErr(
00246   void *theEnv)
00247   {
00248    EnvPrintRouter(theEnv,WERROR,"generic function ");
00249    EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
00250    EnvPrintRouter(theEnv,WERROR," method #");
00251    PrintLongInteger(theEnv,WERROR,(long long) DefgenericData(theEnv)->CurrentMethod->index);
00252    EnvPrintRouter(theEnv,WERROR,".\n");
00253   }
00254 
00255 /***********************************************************************
00256   NAME         : IsMethodApplicable
00257   DESCRIPTION  : Tests to see if a method satsifies the arguments of a
00258                    generic function
00259                  A method is applicable if all its restrictions are
00260                    satisfied by the corresponding arguments
00261   INPUTS       : The method address
00262   RETURNS      : TRUE if method is applicable, FALSE otherwise
00263   SIDE EFFECTS : Any query functions are evaluated
00264   NOTES        : Uses globals ProcParamArraySize and ProcParamArray
00265  ***********************************************************************/
00266 globle intBool IsMethodApplicable(
00267   void *theEnv,
00268   DEFMETHOD *meth)
00269   {
00270    DATA_OBJECT temp;
00271    short i,j,k;
00272    register RESTRICTION *rp;
00273 #if OBJECT_SYSTEM
00274    void *type;
00275 #else
00276    int type;
00277 #endif
00278 
00279    if ((ProceduralPrimitiveData(theEnv)->ProcParamArraySize < meth->minRestrictions) ||
00280        ((ProceduralPrimitiveData(theEnv)->ProcParamArraySize > meth->minRestrictions) && (meth->maxRestrictions != -1)))
00281      return(FALSE);
00282    for (i = 0 , k = 0 ; i < ProceduralPrimitiveData(theEnv)->ProcParamArraySize ; i++)
00283      {
00284       rp = &meth->restrictions[k];
00285       if (rp->tcnt != 0)
00286         {
00287 #if OBJECT_SYSTEM
00288          type = (void *) DetermineRestrictionClass(theEnv,&ProceduralPrimitiveData(theEnv)->ProcParamArray[i]);
00289          if (type == NULL)
00290            return(FALSE);
00291          for (j = 0 ; j < rp->tcnt ; j++)
00292            {
00293             if (type == rp->types[j])
00294               break;
00295             if (HasSuperclass((DEFCLASS *) type,(DEFCLASS *) rp->types[j]))
00296               break;
00297             if (rp->types[j] == (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS])
00298               {
00299                if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_ADDRESS)
00300                  break;
00301               }
00302             else if (rp->types[j] == (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME])
00303               {
00304                if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_NAME)
00305                  break;
00306               }
00307             else if (rp->types[j] ==
00308                 (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0])
00309               {
00310                if ((ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_NAME) ||
00311                    (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_ADDRESS))
00312                  break;
00313               }
00314            }
00315 #else
00316          type = ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type;
00317          for (j = 0 ; j < rp->tcnt ; j++)
00318            {
00319             if (type == ValueToInteger(rp->types[j]))
00320               break;
00321             if (SubsumeType(type,ValueToInteger(rp->types[j])))
00322               break;
00323            }
00324 #endif
00325          if (j == rp->tcnt)
00326            return(FALSE);
00327         }
00328       if (rp->query != NULL)
00329         {
00330          DefgenericData(theEnv)->GenericCurrentArgument = &ProceduralPrimitiveData(theEnv)->ProcParamArray[i];
00331          EvaluateExpression(theEnv,rp->query,&temp);
00332          if ((temp.type != SYMBOL) ? FALSE :
00333              (temp.value == EnvFalseSymbol(theEnv)))
00334            return(FALSE);
00335         }
00336       if (((int) k) != meth->restrictionCount-1)
00337         k++;
00338      }
00339    return(TRUE);
00340   }
00341 
00342 /***************************************************
00343   NAME         : NextMethodP
00344   DESCRIPTION  : Determines if a shadowed generic
00345                    function method is available for
00346                    execution
00347   INPUTS       : None
00348   RETURNS      : TRUE if there is a method available,
00349                    FALSE otherwise
00350   SIDE EFFECTS : None
00351   NOTES        : H/L Syntax: (next-methodp)
00352  ***************************************************/
00353 globle int NextMethodP(
00354   void *theEnv)
00355   {
00356    register DEFMETHOD *meth;
00357 
00358    if (DefgenericData(theEnv)->CurrentMethod == NULL)
00359      return(FALSE);
00360    meth = FindApplicableMethod(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod);
00361    if (meth != NULL)
00362      {
00363       meth->busy--;
00364       return(TRUE);
00365      }
00366    return(FALSE);
00367   }
00368 
00369 /****************************************************
00370   NAME         : CallNextMethod
00371   DESCRIPTION  : Executes the next available method
00372                    in the core for a generic function
00373   INPUTS       : Caller's buffer for the result
00374   RETURNS      : Nothing useful
00375   SIDE EFFECTS : Side effects of execution of shadow
00376                  EvaluationError set if no method
00377                    is available to execute.
00378   NOTES        : H/L Syntax: (call-next-method)
00379  ****************************************************/
00380 globle void CallNextMethod(
00381   void *theEnv,
00382   DATA_OBJECT *result)
00383   {
00384    DEFMETHOD *oldMethod;
00385 #if PROFILING_FUNCTIONS
00386    struct profileFrameInfo profileFrame;
00387 #endif
00388 
00389    result->type = SYMBOL;
00390    result->value = EnvFalseSymbol(theEnv);
00391    if (EvaluationData(theEnv)->HaltExecution)
00392      return;
00393    oldMethod = DefgenericData(theEnv)->CurrentMethod;
00394    if (DefgenericData(theEnv)->CurrentMethod != NULL)
00395      DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod);
00396    if (DefgenericData(theEnv)->CurrentMethod == NULL)
00397      {
00398       DefgenericData(theEnv)->CurrentMethod = oldMethod;
00399       PrintErrorID(theEnv,"GENRCEXE",2,FALSE);
00400       EnvPrintRouter(theEnv,WERROR,"Shadowed methods not applicable in current context.\n");
00401       SetEvaluationError(theEnv,TRUE);
00402       return;
00403      }
00404 
00405 #if DEBUGGING_FUNCTIONS
00406    if (DefgenericData(theEnv)->CurrentMethod->trace)
00407      WatchMethod(theEnv,BEGIN_TRACE);
00408 #endif
00409    if (DefgenericData(theEnv)->CurrentMethod->system)
00410      {
00411       EXPRESSION fcall;
00412 
00413       fcall.type = FCALL;
00414       fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
00415       fcall.nextArg = NULL;
00416       fcall.argList = GetProcParamExpressions(theEnv);
00417       EvaluateExpression(theEnv,&fcall,result);
00418      }
00419    else
00420      {
00421 #if PROFILING_FUNCTIONS
00422       StartProfile(theEnv,&profileFrame,
00423                    &DefgenericData(theEnv)->CurrentGeneric->header.usrData,
00424                    ProfileFunctionData(theEnv)->ProfileConstructs);
00425 #endif
00426 
00427       EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
00428                          DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
00429                          result,UnboundMethodErr);
00430 
00431 #if PROFILING_FUNCTIONS
00432       EndProfile(theEnv,&profileFrame);
00433 #endif
00434      }
00435 
00436    DefgenericData(theEnv)->CurrentMethod->busy--;
00437 #if DEBUGGING_FUNCTIONS
00438    if (DefgenericData(theEnv)->CurrentMethod->trace)
00439      WatchMethod(theEnv,END_TRACE);
00440 #endif
00441    DefgenericData(theEnv)->CurrentMethod = oldMethod;
00442    ProcedureFunctionData(theEnv)->ReturnFlag = FALSE;
00443   }
00444 
00445 /**************************************************************************
00446   NAME         : CallSpecificMethod
00447   DESCRIPTION  : Allows a specific method to be called without regards to
00448                    higher precedence methods which might also be applicable
00449                    However, shadowed methods can still be called.
00450   INPUTS       : A data object buffer to hold the method evaluation result
00451   RETURNS      : Nothing useful
00452   SIDE EFFECTS : Side-effects of method applicability tests and the
00453                  evaluation of methods
00454   NOTES        : H/L Syntax: (call-specific-method
00455                                 <generic-function> <method-index> <args>)
00456  **************************************************************************/
00457 globle void CallSpecificMethod(
00458   void *theEnv,
00459   DATA_OBJECT *result)
00460   {
00461    DATA_OBJECT temp;
00462    DEFGENERIC *gfunc;
00463    int mi;
00464 
00465    result->type = SYMBOL;
00466    result->value = EnvFalseSymbol(theEnv);
00467    if (EnvArgTypeCheck(theEnv,"call-specific-method",1,SYMBOL,&temp) == FALSE)
00468      return;
00469    gfunc = CheckGenericExists(theEnv,"call-specific-method",DOToString(temp));
00470    if (gfunc == NULL)
00471      return;
00472    if (EnvArgTypeCheck(theEnv,"call-specific-method",2,INTEGER,&temp) == FALSE)
00473      return;
00474    mi = CheckMethodExists(theEnv,"call-specific-method",gfunc,(long) DOToLong(temp));
00475    if (mi == -1)
00476      return;
00477    gfunc->methods[mi].busy++;
00478    GenericDispatch(theEnv,gfunc,NULL,&gfunc->methods[mi],
00479                    GetFirstArgument()->nextArg->nextArg,result);
00480    gfunc->methods[mi].busy--;
00481   }
00482 
00483 /***********************************************************************
00484   NAME         : OverrideNextMethod
00485   DESCRIPTION  : Changes the arguments to shadowed methods, thus the set
00486                  of applicable methods to this call may change
00487   INPUTS       : A buffer to hold the result of the call
00488   RETURNS      : Nothing useful
00489   SIDE EFFECTS : Any of evaluating method restrictions and bodies
00490   NOTES        : H/L Syntax: (override-next-method <args>)
00491  ***********************************************************************/
00492 globle void OverrideNextMethod(
00493   void *theEnv,
00494   DATA_OBJECT *result)
00495   {
00496    result->type = SYMBOL;
00497    result->value = EnvFalseSymbol(theEnv);
00498    if (EvaluationData(theEnv)->HaltExecution)
00499      return;
00500    if (DefgenericData(theEnv)->CurrentMethod == NULL)
00501      {
00502       PrintErrorID(theEnv,"GENRCEXE",2,FALSE);
00503       EnvPrintRouter(theEnv,WERROR,"Shadowed methods not applicable in current context.\n");
00504       SetEvaluationError(theEnv,TRUE);
00505       return;
00506      }
00507    GenericDispatch(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod,NULL,
00508                    GetFirstArgument(),result);
00509   }
00510 
00511 /***********************************************************
00512   NAME         : GetGenericCurrentArgument
00513   DESCRIPTION  : Returns the value of the generic function
00514                    argument being tested in the method
00515                    applicability determination process
00516   INPUTS       : A data-object buffer
00517   RETURNS      : Nothing useful
00518   SIDE EFFECTS : Data-object set
00519   NOTES        : Useful for queries in wildcard restrictions
00520  ***********************************************************/
00521 globle void GetGenericCurrentArgument(
00522   void *theEnv,
00523   DATA_OBJECT *result)
00524   {
00525    result->type = DefgenericData(theEnv)->GenericCurrentArgument->type;
00526    result->value = DefgenericData(theEnv)->GenericCurrentArgument->value;
00527    result->begin = DefgenericData(theEnv)->GenericCurrentArgument->begin;
00528    result->end = DefgenericData(theEnv)->GenericCurrentArgument->end;
00529   }
00530 
00531 /* =========================================
00532    *****************************************
00533           INTERNALLY VISIBLE FUNCTIONS
00534    =========================================
00535    ***************************************** */
00536 
00537 /************************************************************
00538   NAME         : FindApplicableMethod
00539   DESCRIPTION  : Finds the first/next applicable
00540                    method for a generic function call
00541   INPUTS       : 1) The generic function pointer
00542                  2) The address of the current method
00543                     (NULL to find the first)
00544   RETURNS      : The address of the first/next
00545                    applicable method (NULL on errors)
00546   SIDE EFFECTS : Any from evaluating query restrictions
00547                  Methoid busy count incremented if applicable
00548   NOTES        : None
00549  ************************************************************/
00550 static DEFMETHOD *FindApplicableMethod(
00551   void *theEnv,
00552   DEFGENERIC *gfunc,
00553   DEFMETHOD *meth)
00554   {
00555    if (meth != NULL)
00556      meth++;
00557    else
00558      meth = gfunc->methods;
00559    for ( ; meth < &gfunc->methods[gfunc->mcnt] ; meth++)
00560      {
00561       meth->busy++;
00562       if (IsMethodApplicable(theEnv,meth))
00563         return(meth);
00564       meth->busy--;
00565      }
00566    return(NULL);
00567   }
00568 
00569 #if DEBUGGING_FUNCTIONS
00570 
00571 /**********************************************************************
00572   NAME         : WatchGeneric
00573   DESCRIPTION  : Prints out a trace of the beginning or end
00574                    of the execution of a generic function
00575   INPUTS       : A string to indicate beginning or end of execution
00576   RETURNS      : Nothing useful
00577   SIDE EFFECTS : None
00578   NOTES        : Uses the globals CurrentGeneric, ProcParamArraySize and
00579                    ProcParamArray for other trace info
00580  **********************************************************************/
00581 static void WatchGeneric(
00582   void *theEnv,
00583   char *tstring)
00584   {
00585    EnvPrintRouter(theEnv,WTRACE,"GNC ");
00586    EnvPrintRouter(theEnv,WTRACE,tstring);
00587    EnvPrintRouter(theEnv,WTRACE," ");
00588    if (DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
00589      {
00590       EnvPrintRouter(theEnv,WTRACE,EnvGetDefmoduleName(theEnv,(void *)
00591                         DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule));
00592       EnvPrintRouter(theEnv,WTRACE,"::");
00593      }
00594    EnvPrintRouter(theEnv,WTRACE,ValueToString((void *) DefgenericData(theEnv)->CurrentGeneric->header.name));
00595    EnvPrintRouter(theEnv,WTRACE," ");
00596    EnvPrintRouter(theEnv,WTRACE," ED:");
00597    PrintLongInteger(theEnv,WTRACE,(long long) EvaluationData(theEnv)->CurrentEvaluationDepth);
00598    PrintProcParamArray(theEnv,WTRACE);
00599   }
00600 
00601 /**********************************************************************
00602   NAME         : WatchMethod
00603   DESCRIPTION  : Prints out a trace of the beginning or end
00604                    of the execution of a generic function
00605                    method
00606   INPUTS       : A string to indicate beginning or end of execution
00607   RETURNS      : Nothing useful
00608   SIDE EFFECTS : None
00609   NOTES        : Uses the globals CurrentGeneric, CurrentMethod,
00610                    ProcParamArraySize and ProcParamArray for
00611                    other trace info
00612  **********************************************************************/
00613 static void WatchMethod(
00614   void *theEnv,
00615   char *tstring)
00616   {
00617    EnvPrintRouter(theEnv,WTRACE,"MTH ");
00618    EnvPrintRouter(theEnv,WTRACE,tstring);
00619    EnvPrintRouter(theEnv,WTRACE," ");
00620    if (DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
00621      {
00622       EnvPrintRouter(theEnv,WTRACE,EnvGetDefmoduleName(theEnv,(void *)
00623                         DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule));
00624       EnvPrintRouter(theEnv,WTRACE,"::");
00625      }
00626    EnvPrintRouter(theEnv,WTRACE,ValueToString((void *) DefgenericData(theEnv)->CurrentGeneric->header.name));
00627    EnvPrintRouter(theEnv,WTRACE,":#");
00628    if (DefgenericData(theEnv)->CurrentMethod->system)
00629      EnvPrintRouter(theEnv,WTRACE,"SYS");
00630    PrintLongInteger(theEnv,WTRACE,(long long) DefgenericData(theEnv)->CurrentMethod->index);
00631    EnvPrintRouter(theEnv,WTRACE," ");
00632    EnvPrintRouter(theEnv,WTRACE," ED:");
00633    PrintLongInteger(theEnv,WTRACE,(long long) EvaluationData(theEnv)->CurrentEvaluationDepth);
00634    PrintProcParamArray(theEnv,WTRACE);
00635   }
00636 
00637 #endif
00638 
00639 #if OBJECT_SYSTEM
00640 
00641 /***************************************************
00642   NAME         : DetermineRestrictionClass
00643   DESCRIPTION  : Finds the class of an argument in
00644                    the ProcParamArray
00645   INPUTS       : The argument data object
00646   RETURNS      : The class address, NULL if error
00647   SIDE EFFECTS : EvaluationError set on errors
00648   NOTES        : None
00649  ***************************************************/
00650 static DEFCLASS *DetermineRestrictionClass(
00651   void *theEnv,
00652   DATA_OBJECT *dobj)
00653   {
00654    INSTANCE_TYPE *ins;
00655    DEFCLASS *cls;
00656 
00657    if (dobj->type == INSTANCE_NAME)
00658      {
00659       ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) dobj->value);
00660       cls = (ins != NULL) ? ins->cls : NULL;
00661      }
00662    else if (dobj->type == INSTANCE_ADDRESS)
00663      {
00664       ins = (INSTANCE_TYPE *) dobj->value;
00665       cls = (ins->garbage == 0) ? ins->cls : NULL;
00666      }
00667    else
00668      return(DefclassData(theEnv)->PrimitiveClassMap[dobj->type]);
00669    if (cls == NULL)
00670      {
00671       SetEvaluationError(theEnv,TRUE);
00672       PrintErrorID(theEnv,"GENRCEXE",3,FALSE);
00673       EnvPrintRouter(theEnv,WERROR,"Unable to determine class of ");
00674       PrintDataObject(theEnv,WERROR,dobj);
00675       EnvPrintRouter(theEnv,WERROR," in generic function ");
00676       EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
00677       EnvPrintRouter(theEnv,WERROR,".\n");
00678      }
00679    return(cls);
00680   }
00681 
00682 #endif
00683 
00684 #endif
00685