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