1    /*******************************************************/
2    /*      "C" Language Integrated Production System      */
3    /*                                                     */
4    /*             CLIPS Version 6.30  08/16/14            */
5    /*                                                     */
6    /*                                                     */
7    /*******************************************************/
8 
9 /*************************************************************/
10 /* Purpose: Generic Function Execution Routines              */
11 /*                                                           */
12 /* Principal Programmer(s):                                  */
13 /*      Brian L. Dantes                                      */
14 /*                                                           */
15 /* Contributing Programmer(s):                               */
16 /*                                                           */
17 /* Revision History:                                         */
18 /*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
19 /*                                                           */
20 /*      6.24: Removed IMPERATIVE_METHODS compilation flag.   */
21 /*                                                           */
22 /*      6.30: Changed garbage collection algorithm.          */
23 /*                                                           */
24 /*            Support for long long integers.                */
25 /*                                                           */
26 /*            Changed integer type/precision.                */
27 /*                                                           */
28 /*            Added const qualifiers to remove C++           */
29 /*            deprecation warnings.                          */
30 /*                                                           */
31 /*************************************************************/
32 
33 /* =========================================
34    *****************************************
35                EXTERNAL DEFINITIONS
36    =========================================
37    ***************************************** */
38 #include "setup.h"
39 
40 #if DEFGENERIC_CONSTRUCT
41 
42 #include <string.h>
43 
44 #if OBJECT_SYSTEM
45 #include "classcom.h"
46 #include "classfun.h"
47 #include "insfun.h"
48 #endif
49 
50 #include "argacces.h"
51 #include "constrct.h"
52 #include "envrnmnt.h"
53 #include "genrccom.h"
54 #include "prcdrfun.h"
55 #include "prccode.h"
56 #include "proflfun.h"
57 #include "router.h"
58 #include "utility.h"
59 
60 #define _GENRCEXE_SOURCE_
61 #include "genrcexe.h"
62 
63 /* =========================================
64    *****************************************
65                    CONSTANTS
66    =========================================
67    ***************************************** */
68 
69 #define BEGIN_TRACE     ">>"
70 #define END_TRACE       "<<"
71 
72 /* =========================================
73    *****************************************
74       INTERNALLY VISIBLE FUNCTION HEADERS
75    =========================================
76    ***************************************** */
77 
78 static DEFMETHOD *FindApplicableMethod(void *,DEFGENERIC *,DEFMETHOD *);
79 
80 #if DEBUGGING_FUNCTIONS
81 static void WatchGeneric(void *,const char *);
82 static void WatchMethod(void *,const char *);
83 #endif
84 
85 #if OBJECT_SYSTEM
86 static DEFCLASS *DetermineRestrictionClass(void *,DATA_OBJECT *);
87 #endif
88 
89 /* =========================================
90    *****************************************
91           EXTERNALLY VISIBLE FUNCTIONS
92    =========================================
93    ***************************************** */
94 
95 /***********************************************************************************
96   NAME         : GenericDispatch
97   DESCRIPTION  : Executes the most specific applicable method
98   INPUTS       : 1) The generic function
99                  2) The method to start after in the search for an applicable
100                     method (ignored if arg #3 is not NULL).
101                  3) A specific method to call (NULL if want highest precedence
102                     method to be called)
103                  4) The generic function argument expressions
104                  5) The caller's result value buffer
105   RETURNS      : Nothing useful
106   SIDE EFFECTS : Any side-effects of evaluating the generic function arguments
107                  Any side-effects of evaluating query functions on method parameter
108                    restrictions when determining the core (see warning #1)
109                  Any side-effects of actual execution of methods (see warning #2)
110                  Caller's buffer set to the result of the generic function call
111 
112                  In case of errors, the result is FALSE, otherwise it is the
113                    result returned by the most specific method (which can choose
114                    to ignore or return the values of more general methods)
115   NOTES        : WARNING #1: Query functions on method parameter restrictions
116                     should not have side-effects, for they might be evaluated even
117                     for methods that aren't applicable to the generic function call.
118                  WARNING #2: Side-effects of method execution should not always rely
119                     on only being executed once per generic function call.  Every
120                     time a method calls (shadow-call) the same next-most-specific
121                     method is executed.  Thus, it is possible for a method to be
122                     executed multiple times per generic function call.
123  ***********************************************************************************/
GenericDispatch(void * theEnv,DEFGENERIC * gfunc,DEFMETHOD * prevmeth,DEFMETHOD * meth,EXPRESSION * params,DATA_OBJECT * result)124 globle void GenericDispatch(
125   void *theEnv,
126   DEFGENERIC *gfunc,
127   DEFMETHOD *prevmeth,
128   DEFMETHOD *meth,
129   EXPRESSION *params,
130   DATA_OBJECT *result)
131   {
132    DEFGENERIC *previousGeneric;
133    DEFMETHOD *previousMethod;
134    int oldce;
135 #if PROFILING_FUNCTIONS
136    struct profileFrameInfo profileFrame;
137 #endif
138    struct garbageFrame newGarbageFrame;
139    struct garbageFrame *oldGarbageFrame;
140 
141    result->type = SYMBOL;
142    result->value = EnvFalseSymbol(theEnv);
143    EvaluationData(theEnv)->EvaluationError = FALSE;
144    if (EvaluationData(theEnv)->HaltExecution)
145      return;
146 
147    oldGarbageFrame = UtilityData(theEnv)->CurrentGarbageFrame;
148    memset(&newGarbageFrame,0,sizeof(struct garbageFrame));
149    newGarbageFrame.priorFrame = oldGarbageFrame;
150    UtilityData(theEnv)->CurrentGarbageFrame = &newGarbageFrame;
151 
152    oldce = ExecutingConstruct(theEnv);
153    SetExecutingConstruct(theEnv,TRUE);
154    previousGeneric = DefgenericData(theEnv)->CurrentGeneric;
155    previousMethod = DefgenericData(theEnv)->CurrentMethod;
156    DefgenericData(theEnv)->CurrentGeneric = gfunc;
157    EvaluationData(theEnv)->CurrentEvaluationDepth++;
158    gfunc->busy++;
159    PushProcParameters(theEnv,params,CountArguments(params),
160                       EnvGetDefgenericName(theEnv,(void *) gfunc),
161                       "generic function",UnboundMethodErr);
162    if (EvaluationData(theEnv)->EvaluationError)
163      {
164       gfunc->busy--;
165       DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
166       DefgenericData(theEnv)->CurrentMethod = previousMethod;
167       EvaluationData(theEnv)->CurrentEvaluationDepth--;
168 
169       RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,result);
170       CallPeriodicTasks(theEnv);
171 
172       SetExecutingConstruct(theEnv,oldce);
173       return;
174      }
175    if (meth != NULL)
176      {
177       if (IsMethodApplicable(theEnv,meth))
178         {
179          meth->busy++;
180          DefgenericData(theEnv)->CurrentMethod = meth;
181         }
182       else
183         {
184          PrintErrorID(theEnv,"GENRCEXE",4,FALSE);
185          SetEvaluationError(theEnv,TRUE);
186          DefgenericData(theEnv)->CurrentMethod = NULL;
187          EnvPrintRouter(theEnv,WERROR,"Generic function ");
188          EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
189          EnvPrintRouter(theEnv,WERROR," method #");
190          PrintLongInteger(theEnv,WERROR,(long long) meth->index);
191          EnvPrintRouter(theEnv,WERROR," is not applicable to the given arguments.\n");
192         }
193      }
194    else
195      DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,gfunc,prevmeth);
196    if (DefgenericData(theEnv)->CurrentMethod != NULL)
197      {
198 #if DEBUGGING_FUNCTIONS
199       if (DefgenericData(theEnv)->CurrentGeneric->trace)
200         WatchGeneric(theEnv,BEGIN_TRACE);
201       if (DefgenericData(theEnv)->CurrentMethod->trace)
202         WatchMethod(theEnv,BEGIN_TRACE);
203 #endif
204       if (DefgenericData(theEnv)->CurrentMethod->system)
205         {
206          EXPRESSION fcall;
207 
208          fcall.type = FCALL;
209          fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
210          fcall.nextArg = NULL;
211          fcall.argList = GetProcParamExpressions(theEnv);
212          EvaluateExpression(theEnv,&fcall,result);
213         }
214       else
215         {
216 #if PROFILING_FUNCTIONS
217          StartProfile(theEnv,&profileFrame,
218                       &DefgenericData(theEnv)->CurrentMethod->usrData,
219                       ProfileFunctionData(theEnv)->ProfileConstructs);
220 #endif
221 
222          EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
223                              DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
224                              result,UnboundMethodErr);
225 
226 #if PROFILING_FUNCTIONS
227          EndProfile(theEnv,&profileFrame);
228 #endif
229         }
230       DefgenericData(theEnv)->CurrentMethod->busy--;
231 #if DEBUGGING_FUNCTIONS
232       if (DefgenericData(theEnv)->CurrentMethod->trace)
233         WatchMethod(theEnv,END_TRACE);
234       if (DefgenericData(theEnv)->CurrentGeneric->trace)
235         WatchGeneric(theEnv,END_TRACE);
236 #endif
237      }
238    else if (! EvaluationData(theEnv)->EvaluationError)
239      {
240       PrintErrorID(theEnv,"GENRCEXE",1,FALSE);
241       EnvPrintRouter(theEnv,WERROR,"No applicable methods for ");
242       EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
243       EnvPrintRouter(theEnv,WERROR,".\n");
244       SetEvaluationError(theEnv,TRUE);
245      }
246    gfunc->busy--;
247    ProcedureFunctionData(theEnv)->ReturnFlag = FALSE;
248    PopProcParameters(theEnv);
249    DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
250    DefgenericData(theEnv)->CurrentMethod = previousMethod;
251    EvaluationData(theEnv)->CurrentEvaluationDepth--;
252 
253    RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,result);
254    CallPeriodicTasks(theEnv);
255 
256    SetExecutingConstruct(theEnv,oldce);
257   }
258 
259 /*******************************************************
260   NAME         : UnboundMethodErr
261   DESCRIPTION  : Print out a synopis of the currently
262                    executing method for unbound variable
263                    errors
264   INPUTS       : None
265   RETURNS      : Nothing useful
266   SIDE EFFECTS : Error synopsis printed to WERROR
267   NOTES        : None
268  *******************************************************/
UnboundMethodErr(void * theEnv)269 globle void UnboundMethodErr(
270   void *theEnv)
271   {
272    EnvPrintRouter(theEnv,WERROR,"generic function ");
273    EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
274    EnvPrintRouter(theEnv,WERROR," method #");
275    PrintLongInteger(theEnv,WERROR,(long long) DefgenericData(theEnv)->CurrentMethod->index);
276    EnvPrintRouter(theEnv,WERROR,".\n");
277   }
278 
279 /***********************************************************************
280   NAME         : IsMethodApplicable
281   DESCRIPTION  : Tests to see if a method satsifies the arguments of a
282                    generic function
283                  A method is applicable if all its restrictions are
284                    satisfied by the corresponding arguments
285   INPUTS       : The method address
286   RETURNS      : TRUE if method is applicable, FALSE otherwise
287   SIDE EFFECTS : Any query functions are evaluated
288   NOTES        : Uses globals ProcParamArraySize and ProcParamArray
289  ***********************************************************************/
IsMethodApplicable(void * theEnv,DEFMETHOD * meth)290 globle intBool IsMethodApplicable(
291   void *theEnv,
292   DEFMETHOD *meth)
293   {
294    DATA_OBJECT temp;
295    short i,j,k;
296    register RESTRICTION *rp;
297 #if OBJECT_SYSTEM
298    void *type;
299 #else
300    int type;
301 #endif
302 
303    if ((ProceduralPrimitiveData(theEnv)->ProcParamArraySize < meth->minRestrictions) ||
304        ((ProceduralPrimitiveData(theEnv)->ProcParamArraySize > meth->minRestrictions) && (meth->maxRestrictions != -1)))
305      return(FALSE);
306    for (i = 0 , k = 0 ; i < ProceduralPrimitiveData(theEnv)->ProcParamArraySize ; i++)
307      {
308       rp = &meth->restrictions[k];
309       if (rp->tcnt != 0)
310         {
311 #if OBJECT_SYSTEM
312          type = (void *) DetermineRestrictionClass(theEnv,&ProceduralPrimitiveData(theEnv)->ProcParamArray[i]);
313          if (type == NULL)
314            return(FALSE);
315          for (j = 0 ; j < rp->tcnt ; j++)
316            {
317             if (type == rp->types[j])
318               break;
319             if (HasSuperclass((DEFCLASS *) type,(DEFCLASS *) rp->types[j]))
320               break;
321             if (rp->types[j] == (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS])
322               {
323                if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_ADDRESS)
324                  break;
325               }
326             else if (rp->types[j] == (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME])
327               {
328                if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_NAME)
329                  break;
330               }
331             else if (rp->types[j] ==
332                 (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0])
333               {
334                if ((ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_NAME) ||
335                    (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_ADDRESS))
336                  break;
337               }
338            }
339 #else
340          type = ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type;
341          for (j = 0 ; j < rp->tcnt ; j++)
342            {
343             if (type == ValueToInteger(rp->types[j]))
344               break;
345             if (SubsumeType(type,ValueToInteger(rp->types[j])))
346               break;
347            }
348 #endif
349          if (j == rp->tcnt)
350            return(FALSE);
351         }
352       if (rp->query != NULL)
353         {
354          DefgenericData(theEnv)->GenericCurrentArgument = &ProceduralPrimitiveData(theEnv)->ProcParamArray[i];
355          EvaluateExpression(theEnv,rp->query,&temp);
356          if ((temp.type != SYMBOL) ? FALSE :
357              (temp.value == EnvFalseSymbol(theEnv)))
358            return(FALSE);
359         }
360       if (((int) k) != meth->restrictionCount-1)
361         k++;
362      }
363    return(TRUE);
364   }
365 
366 /***************************************************
367   NAME         : NextMethodP
368   DESCRIPTION  : Determines if a shadowed generic
369                    function method is available for
370                    execution
371   INPUTS       : None
372   RETURNS      : TRUE if there is a method available,
373                    FALSE otherwise
374   SIDE EFFECTS : None
375   NOTES        : H/L Syntax: (next-methodp)
376  ***************************************************/
NextMethodP(void * theEnv)377 globle int NextMethodP(
378   void *theEnv)
379   {
380    register DEFMETHOD *meth;
381 
382    if (DefgenericData(theEnv)->CurrentMethod == NULL)
383      return(FALSE);
384    meth = FindApplicableMethod(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod);
385    if (meth != NULL)
386      {
387       meth->busy--;
388       return(TRUE);
389      }
390    return(FALSE);
391   }
392 
393 /****************************************************
394   NAME         : CallNextMethod
395   DESCRIPTION  : Executes the next available method
396                    in the core for a generic function
397   INPUTS       : Caller's buffer for the result
398   RETURNS      : Nothing useful
399   SIDE EFFECTS : Side effects of execution of shadow
400                  EvaluationError set if no method
401                    is available to execute.
402   NOTES        : H/L Syntax: (call-next-method)
403  ****************************************************/
CallNextMethod(void * theEnv,DATA_OBJECT * result)404 globle void CallNextMethod(
405   void *theEnv,
406   DATA_OBJECT *result)
407   {
408    DEFMETHOD *oldMethod;
409 #if PROFILING_FUNCTIONS
410    struct profileFrameInfo profileFrame;
411 #endif
412 
413    result->type = SYMBOL;
414    result->value = EnvFalseSymbol(theEnv);
415    if (EvaluationData(theEnv)->HaltExecution)
416      return;
417    oldMethod = DefgenericData(theEnv)->CurrentMethod;
418    if (DefgenericData(theEnv)->CurrentMethod != NULL)
419      DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod);
420    if (DefgenericData(theEnv)->CurrentMethod == NULL)
421      {
422       DefgenericData(theEnv)->CurrentMethod = oldMethod;
423       PrintErrorID(theEnv,"GENRCEXE",2,FALSE);
424       EnvPrintRouter(theEnv,WERROR,"Shadowed methods not applicable in current context.\n");
425       SetEvaluationError(theEnv,TRUE);
426       return;
427      }
428 
429 #if DEBUGGING_FUNCTIONS
430    if (DefgenericData(theEnv)->CurrentMethod->trace)
431      WatchMethod(theEnv,BEGIN_TRACE);
432 #endif
433    if (DefgenericData(theEnv)->CurrentMethod->system)
434      {
435       EXPRESSION fcall;
436 
437       fcall.type = FCALL;
438       fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
439       fcall.nextArg = NULL;
440       fcall.argList = GetProcParamExpressions(theEnv);
441       EvaluateExpression(theEnv,&fcall,result);
442      }
443    else
444      {
445 #if PROFILING_FUNCTIONS
446       StartProfile(theEnv,&profileFrame,
447                    &DefgenericData(theEnv)->CurrentGeneric->header.usrData,
448                    ProfileFunctionData(theEnv)->ProfileConstructs);
449 #endif
450 
451       EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
452                          DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
453                          result,UnboundMethodErr);
454 
455 #if PROFILING_FUNCTIONS
456       EndProfile(theEnv,&profileFrame);
457 #endif
458      }
459 
460    DefgenericData(theEnv)->CurrentMethod->busy--;
461 #if DEBUGGING_FUNCTIONS
462    if (DefgenericData(theEnv)->CurrentMethod->trace)
463      WatchMethod(theEnv,END_TRACE);
464 #endif
465    DefgenericData(theEnv)->CurrentMethod = oldMethod;
466    ProcedureFunctionData(theEnv)->ReturnFlag = FALSE;
467   }
468 
469 /**************************************************************************
470   NAME         : CallSpecificMethod
471   DESCRIPTION  : Allows a specific method to be called without regards to
472                    higher precedence methods which might also be applicable
473                    However, shadowed methods can still be called.
474   INPUTS       : A data object buffer to hold the method evaluation result
475   RETURNS      : Nothing useful
476   SIDE EFFECTS : Side-effects of method applicability tests and the
477                  evaluation of methods
478   NOTES        : H/L Syntax: (call-specific-method
479                                 <generic-function> <method-index> <args>)
480  **************************************************************************/
CallSpecificMethod(void * theEnv,DATA_OBJECT * result)481 globle void CallSpecificMethod(
482   void *theEnv,
483   DATA_OBJECT *result)
484   {
485    DATA_OBJECT temp;
486    DEFGENERIC *gfunc;
487    int mi;
488 
489    result->type = SYMBOL;
490    result->value = EnvFalseSymbol(theEnv);
491    if (EnvArgTypeCheck(theEnv,"call-specific-method",1,SYMBOL,&temp) == FALSE)
492      return;
493    gfunc = CheckGenericExists(theEnv,"call-specific-method",DOToString(temp));
494    if (gfunc == NULL)
495      return;
496    if (EnvArgTypeCheck(theEnv,"call-specific-method",2,INTEGER,&temp) == FALSE)
497      return;
498    mi = CheckMethodExists(theEnv,"call-specific-method",gfunc,(long) DOToLong(temp));
499    if (mi == -1)
500      return;
501    gfunc->methods[mi].busy++;
502    GenericDispatch(theEnv,gfunc,NULL,&gfunc->methods[mi],
503                    GetFirstArgument()->nextArg->nextArg,result);
504    gfunc->methods[mi].busy--;
505   }
506 
507 /***********************************************************************
508   NAME         : OverrideNextMethod
509   DESCRIPTION  : Changes the arguments to shadowed methods, thus the set
510                  of applicable methods to this call may change
511   INPUTS       : A buffer to hold the result of the call
512   RETURNS      : Nothing useful
513   SIDE EFFECTS : Any of evaluating method restrictions and bodies
514   NOTES        : H/L Syntax: (override-next-method <args>)
515  ***********************************************************************/
OverrideNextMethod(void * theEnv,DATA_OBJECT * result)516 globle void OverrideNextMethod(
517   void *theEnv,
518   DATA_OBJECT *result)
519   {
520    result->type = SYMBOL;
521    result->value = EnvFalseSymbol(theEnv);
522    if (EvaluationData(theEnv)->HaltExecution)
523      return;
524    if (DefgenericData(theEnv)->CurrentMethod == NULL)
525      {
526       PrintErrorID(theEnv,"GENRCEXE",2,FALSE);
527       EnvPrintRouter(theEnv,WERROR,"Shadowed methods not applicable in current context.\n");
528       SetEvaluationError(theEnv,TRUE);
529       return;
530      }
531    GenericDispatch(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod,NULL,
532                    GetFirstArgument(),result);
533   }
534 
535 /***********************************************************
536   NAME         : GetGenericCurrentArgument
537   DESCRIPTION  : Returns the value of the generic function
538                    argument being tested in the method
539                    applicability determination process
540   INPUTS       : A data-object buffer
541   RETURNS      : Nothing useful
542   SIDE EFFECTS : Data-object set
543   NOTES        : Useful for queries in wildcard restrictions
544  ***********************************************************/
GetGenericCurrentArgument(void * theEnv,DATA_OBJECT * result)545 globle void GetGenericCurrentArgument(
546   void *theEnv,
547   DATA_OBJECT *result)
548   {
549    result->type = DefgenericData(theEnv)->GenericCurrentArgument->type;
550    result->value = DefgenericData(theEnv)->GenericCurrentArgument->value;
551    result->begin = DefgenericData(theEnv)->GenericCurrentArgument->begin;
552    result->end = DefgenericData(theEnv)->GenericCurrentArgument->end;
553   }
554 
555 /* =========================================
556    *****************************************
557           INTERNALLY VISIBLE FUNCTIONS
558    =========================================
559    ***************************************** */
560 
561 /************************************************************
562   NAME         : FindApplicableMethod
563   DESCRIPTION  : Finds the first/next applicable
564                    method for a generic function call
565   INPUTS       : 1) The generic function pointer
566                  2) The address of the current method
567                     (NULL to find the first)
568   RETURNS      : The address of the first/next
569                    applicable method (NULL on errors)
570   SIDE EFFECTS : Any from evaluating query restrictions
571                  Methoid busy count incremented if applicable
572   NOTES        : None
573  ************************************************************/
FindApplicableMethod(void * theEnv,DEFGENERIC * gfunc,DEFMETHOD * meth)574 static DEFMETHOD *FindApplicableMethod(
575   void *theEnv,
576   DEFGENERIC *gfunc,
577   DEFMETHOD *meth)
578   {
579    if (meth != NULL)
580      meth++;
581    else
582      meth = gfunc->methods;
583    for ( ; meth < &gfunc->methods[gfunc->mcnt] ; meth++)
584      {
585       meth->busy++;
586       if (IsMethodApplicable(theEnv,meth))
587         return(meth);
588       meth->busy--;
589      }
590    return(NULL);
591   }
592 
593 #if DEBUGGING_FUNCTIONS
594 
595 /**********************************************************************
596   NAME         : WatchGeneric
597   DESCRIPTION  : Prints out a trace of the beginning or end
598                    of the execution of a generic function
599   INPUTS       : A string to indicate beginning or end of execution
600   RETURNS      : Nothing useful
601   SIDE EFFECTS : None
602   NOTES        : Uses the globals CurrentGeneric, ProcParamArraySize and
603                    ProcParamArray for other trace info
604  **********************************************************************/
WatchGeneric(void * theEnv,const char * tstring)605 static void WatchGeneric(
606   void *theEnv,
607   const char *tstring)
608   {
609    EnvPrintRouter(theEnv,WTRACE,"GNC ");
610    EnvPrintRouter(theEnv,WTRACE,tstring);
611    EnvPrintRouter(theEnv,WTRACE," ");
612    if (DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
613      {
614       EnvPrintRouter(theEnv,WTRACE,EnvGetDefmoduleName(theEnv,(void *)
615                         DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule));
616       EnvPrintRouter(theEnv,WTRACE,"::");
617      }
618    EnvPrintRouter(theEnv,WTRACE,ValueToString((void *) DefgenericData(theEnv)->CurrentGeneric->header.name));
619    EnvPrintRouter(theEnv,WTRACE," ");
620    EnvPrintRouter(theEnv,WTRACE," ED:");
621    PrintLongInteger(theEnv,WTRACE,(long long) EvaluationData(theEnv)->CurrentEvaluationDepth);
622    PrintProcParamArray(theEnv,WTRACE);
623   }
624 
625 /**********************************************************************
626   NAME         : WatchMethod
627   DESCRIPTION  : Prints out a trace of the beginning or end
628                    of the execution of a generic function
629                    method
630   INPUTS       : A string to indicate beginning or end of execution
631   RETURNS      : Nothing useful
632   SIDE EFFECTS : None
633   NOTES        : Uses the globals CurrentGeneric, CurrentMethod,
634                    ProcParamArraySize and ProcParamArray for
635                    other trace info
636  **********************************************************************/
WatchMethod(void * theEnv,const char * tstring)637 static void WatchMethod(
638   void *theEnv,
639   const char *tstring)
640   {
641    EnvPrintRouter(theEnv,WTRACE,"MTH ");
642    EnvPrintRouter(theEnv,WTRACE,tstring);
643    EnvPrintRouter(theEnv,WTRACE," ");
644    if (DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
645      {
646       EnvPrintRouter(theEnv,WTRACE,EnvGetDefmoduleName(theEnv,(void *)
647                         DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule));
648       EnvPrintRouter(theEnv,WTRACE,"::");
649      }
650    EnvPrintRouter(theEnv,WTRACE,ValueToString((void *) DefgenericData(theEnv)->CurrentGeneric->header.name));
651    EnvPrintRouter(theEnv,WTRACE,":#");
652    if (DefgenericData(theEnv)->CurrentMethod->system)
653      EnvPrintRouter(theEnv,WTRACE,"SYS");
654    PrintLongInteger(theEnv,WTRACE,(long long) DefgenericData(theEnv)->CurrentMethod->index);
655    EnvPrintRouter(theEnv,WTRACE," ");
656    EnvPrintRouter(theEnv,WTRACE," ED:");
657    PrintLongInteger(theEnv,WTRACE,(long long) EvaluationData(theEnv)->CurrentEvaluationDepth);
658    PrintProcParamArray(theEnv,WTRACE);
659   }
660 
661 #endif
662 
663 #if OBJECT_SYSTEM
664 
665 /***************************************************
666   NAME         : DetermineRestrictionClass
667   DESCRIPTION  : Finds the class of an argument in
668                    the ProcParamArray
669   INPUTS       : The argument data object
670   RETURNS      : The class address, NULL if error
671   SIDE EFFECTS : EvaluationError set on errors
672   NOTES        : None
673  ***************************************************/
DetermineRestrictionClass(void * theEnv,DATA_OBJECT * dobj)674 static DEFCLASS *DetermineRestrictionClass(
675   void *theEnv,
676   DATA_OBJECT *dobj)
677   {
678    INSTANCE_TYPE *ins;
679    DEFCLASS *cls;
680 
681    if (dobj->type == INSTANCE_NAME)
682      {
683       ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) dobj->value);
684       cls = (ins != NULL) ? ins->cls : NULL;
685      }
686    else if (dobj->type == INSTANCE_ADDRESS)
687      {
688       ins = (INSTANCE_TYPE *) dobj->value;
689       cls = (ins->garbage == 0) ? ins->cls : NULL;
690      }
691    else
692      return(DefclassData(theEnv)->PrimitiveClassMap[dobj->type]);
693    if (cls == NULL)
694      {
695       SetEvaluationError(theEnv,TRUE);
696       PrintErrorID(theEnv,"GENRCEXE",3,FALSE);
697       EnvPrintRouter(theEnv,WERROR,"Unable to determine class of ");
698       PrintDataObject(theEnv,WERROR,dobj);
699       EnvPrintRouter(theEnv,WERROR," in generic function ");
700       EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
701       EnvPrintRouter(theEnv,WERROR,".\n");
702      }
703    return(cls);
704   }
705 
706 #endif
707 
708 #endif
709 
710