1 /*******************************************************/
2 /* "C" Language Integrated Production System */
3 /* */
4 /* CLIPS Version 6.30 02/05/15 */
5 /* */
6 /* */
7 /*******************************************************/
8
9 /*************************************************************/
10 /* Purpose: Generic Functions Interface 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 /* Corrected compilation errors for files */
21 /* generated by constructs-to-c. DR0861 */
22 /* */
23 /* Changed name of variable log to logName */
24 /* because of Unix compiler warnings of shadowed */
25 /* definitions. */
26 /* */
27 /* 6.24: Removed IMPERATIVE_METHODS compilation flag. */
28 /* */
29 /* Renamed BOOLEAN macro type to intBool. */
30 /* */
31 /* Corrected code to remove run-time program */
32 /* compiler warning. */
33 /* */
34 /* 6.30: Removed conditional code for unsupported */
35 /* compilers/operating systems (IBM_MCW, */
36 /* MAC_MCW, and IBM_TBC). */
37 /* */
38 /* Changed integer type/precision. */
39 /* */
40 /* Added const qualifiers to remove C++ */
41 /* deprecation warnings. */
42 /* */
43 /* Converted API macros to function calls. */
44 /* */
45 /* Fixed linkage issue when DEBUGGING_FUNCTIONS */
46 /* is set to 0 and PROFILING_FUNCTIONS is set to */
47 /* 1. */
48 /* */
49 /* Changed find construct functionality so that */
50 /* imported modules are search when locating a */
51 /* named construct. */
52 /* */
53 /* Added code to keep track of pointers to */
54 /* constructs that are contained externally to */
55 /* to constructs, DanglingConstructs. */
56 /* */
57 /*************************************************************/
58
59 /* =========================================
60 *****************************************
61 EXTERNAL DEFINITIONS
62 =========================================
63 ***************************************** */
64 #include "setup.h"
65
66 #if DEFGENERIC_CONSTRUCT
67
68 #include <string.h>
69
70 #if DEFRULE_CONSTRUCT
71 #include "network.h"
72 #endif
73
74 #if BLOAD || BLOAD_AND_BSAVE
75 #include "bload.h"
76 #endif
77
78 #if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
79 #include "genrcbin.h"
80 #endif
81
82 #if CONSTRUCT_COMPILER
83 #include "genrccmp.h"
84 #endif
85
86 #if (! BLOAD_ONLY) && (! RUN_TIME)
87 #include "constrct.h"
88 #include "genrcpsr.h"
89 #endif
90
91 #if OBJECT_SYSTEM
92 #include "classcom.h"
93 #include "inscom.h"
94 #endif
95
96 #if DEBUGGING_FUNCTIONS
97 #include "watch.h"
98 #endif
99
100 #include "argacces.h"
101 #include "cstrcpsr.h"
102 #include "envrnmnt.h"
103 #include "extnfunc.h"
104 #include "genrcexe.h"
105 #include "memalloc.h"
106 #include "modulpsr.h"
107 #include "multifld.h"
108 #include "router.h"
109
110 #define _GENRCCOM_SOURCE_
111 #include "genrccom.h"
112
113 /* =========================================
114 *****************************************
115 INTERNALLY VISIBLE FUNCTION HEADERS
116 =========================================
117 ***************************************** */
118
119 static void PrintGenericCall(void *,const char *,void *);
120 static intBool EvaluateGenericCall(void *,void *,DATA_OBJECT *);
121 static void DecrementGenericBusyCount(void *,void *);
122 static void IncrementGenericBusyCount(void *,void *);
123 static void DeallocateDefgenericData(void *);
124 #if ! RUN_TIME
125 static void DestroyDefgenericAction(void *,struct constructHeader *,void *);
126 #endif
127
128 #if (! BLOAD_ONLY) && (! RUN_TIME)
129
130 static void SaveDefgenerics(void *,void *,const char *);
131 static void SaveDefmethods(void *,void *,const char *);
132 static void SaveDefmethodsForDefgeneric(void *,struct constructHeader *,void *);
133 static void RemoveDefgenericMethod(void *,DEFGENERIC *,long);
134
135 #endif
136
137 #if DEBUGGING_FUNCTIONS
138 static long ListMethodsForGeneric(void *,const char *,DEFGENERIC *);
139 static unsigned DefgenericWatchAccess(void *,int,unsigned,EXPRESSION *);
140 static unsigned DefgenericWatchPrint(void *,const char *,int,EXPRESSION *);
141 static unsigned DefmethodWatchAccess(void *,int,unsigned,EXPRESSION *);
142 static unsigned DefmethodWatchPrint(void *,const char *,int,EXPRESSION *);
143 static unsigned DefmethodWatchSupport(void *,const char *,const char *,unsigned,
144 void (*)(void *,const char *,void *,long),
145 void (*)(void *,unsigned,void *,long),
146 EXPRESSION *);
147 static void PrintMethodWatchFlag(void *,const char *,void *,long);
148 #endif
149
150 /* =========================================
151 *****************************************
152 EXTERNALLY VISIBLE FUNCTIONS
153 =========================================
154 ***************************************** */
155
156 /***********************************************************
157 NAME : SetupGenericFunctions
158 DESCRIPTION : Initializes all generic function
159 data structures, constructs and functions
160 INPUTS : None
161 RETURNS : Nothing useful
162 SIDE EFFECTS : Generic function H/L functions set up
163 NOTES : None
164 ***********************************************************/
SetupGenericFunctions(void * theEnv)165 globle void SetupGenericFunctions(
166 void *theEnv)
167 {
168 ENTITY_RECORD genericEntityRecord =
169 { "GCALL", GCALL,0,0,1,
170 PrintGenericCall,PrintGenericCall,
171 NULL,EvaluateGenericCall,NULL,
172 DecrementGenericBusyCount,IncrementGenericBusyCount,
173 NULL,NULL,NULL,NULL,NULL };
174
175 AllocateEnvironmentData(theEnv,DEFGENERIC_DATA,sizeof(struct defgenericData),DeallocateDefgenericData);
176 memcpy(&DefgenericData(theEnv)->GenericEntityRecord,&genericEntityRecord,sizeof(struct entityRecord));
177
178 InstallPrimitive(theEnv,&DefgenericData(theEnv)->GenericEntityRecord,GCALL);
179
180 DefgenericData(theEnv)->DefgenericModuleIndex =
181 RegisterModuleItem(theEnv,"defgeneric",
182 #if (! RUN_TIME)
183 AllocateDefgenericModule,FreeDefgenericModule,
184 #else
185 NULL,NULL,
186 #endif
187 #if BLOAD_AND_BSAVE || BLOAD || BLOAD_ONLY
188 BloadDefgenericModuleReference,
189 #else
190 NULL,
191 #endif
192 #if CONSTRUCT_COMPILER && (! RUN_TIME)
193 DefgenericCModuleReference,
194 #else
195 NULL,
196 #endif
197 EnvFindDefgenericInModule);
198
199 DefgenericData(theEnv)->DefgenericConstruct = AddConstruct(theEnv,"defgeneric","defgenerics",
200 #if (! BLOAD_ONLY) && (! RUN_TIME)
201 ParseDefgeneric,
202 #else
203 NULL,
204 #endif
205 EnvFindDefgeneric,
206 GetConstructNamePointer,GetConstructPPForm,
207 GetConstructModuleItem,EnvGetNextDefgeneric,
208 SetNextConstruct,EnvIsDefgenericDeletable,
209 EnvUndefgeneric,
210 #if (! BLOAD_ONLY) && (! RUN_TIME)
211 RemoveDefgeneric
212 #else
213 NULL
214 #endif
215 );
216
217 #if ! RUN_TIME
218 AddClearReadyFunction(theEnv,"defgeneric",ClearDefgenericsReady,0);
219
220 #if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
221 SetupGenericsBload(theEnv);
222 #endif
223
224 #if CONSTRUCT_COMPILER
225 SetupGenericsCompiler(theEnv);
226 #endif
227
228 #if ! BLOAD_ONLY
229 #if DEFMODULE_CONSTRUCT
230 AddPortConstructItem(theEnv,"defgeneric",SYMBOL);
231 #endif
232 AddConstruct(theEnv,"defmethod","defmethods",ParseDefmethod,
233 NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL);
234
235 /* ================================================================
236 Make sure defmethods are cleared last, for other constructs may
237 be using them and need to be cleared first
238
239 Need to be cleared in two stages so that mutually dependent
240 constructs (like classes) can be cleared
241 ================================================================ */
242 AddSaveFunction(theEnv,"defgeneric",SaveDefgenerics,1000);
243 AddSaveFunction(theEnv,"defmethod",SaveDefmethods,-1000);
244 EnvDefineFunction2(theEnv,"undefgeneric",'v',PTIEF UndefgenericCommand,"UndefgenericCommand","11w");
245 EnvDefineFunction2(theEnv,"undefmethod",'v',PTIEF UndefmethodCommand,"UndefmethodCommand","22*wg");
246 #endif
247
248 EnvDefineFunction2(theEnv,"call-next-method",'u',PTIEF CallNextMethod,"CallNextMethod","00");
249 FuncSeqOvlFlags(theEnv,"call-next-method",TRUE,FALSE);
250 EnvDefineFunction2(theEnv,"call-specific-method",'u',PTIEF CallSpecificMethod,
251 "CallSpecificMethod","2**wi");
252 FuncSeqOvlFlags(theEnv,"call-specific-method",TRUE,FALSE);
253 EnvDefineFunction2(theEnv,"override-next-method",'u',PTIEF OverrideNextMethod,
254 "OverrideNextMethod",NULL);
255 FuncSeqOvlFlags(theEnv,"override-next-method",TRUE,FALSE);
256 EnvDefineFunction2(theEnv,"next-methodp",'b',PTIEF NextMethodP,"NextMethodP","00");
257 FuncSeqOvlFlags(theEnv,"next-methodp",TRUE,FALSE);
258
259 EnvDefineFunction2(theEnv,"(gnrc-current-arg)",'u',PTIEF GetGenericCurrentArgument,
260 "GetGenericCurrentArgument",NULL);
261
262 #if DEBUGGING_FUNCTIONS
263 EnvDefineFunction2(theEnv,"ppdefgeneric",'v',PTIEF PPDefgenericCommand,"PPDefgenericCommand","11w");
264 EnvDefineFunction2(theEnv,"list-defgenerics",'v',PTIEF ListDefgenericsCommand,"ListDefgenericsCommand","01");
265 EnvDefineFunction2(theEnv,"ppdefmethod",'v',PTIEF PPDefmethodCommand,"PPDefmethodCommand","22*wi");
266 EnvDefineFunction2(theEnv,"list-defmethods",'v',PTIEF ListDefmethodsCommand,"ListDefmethodsCommand","01w");
267 EnvDefineFunction2(theEnv,"preview-generic",'v',PTIEF PreviewGeneric,"PreviewGeneric","1**w");
268 #endif
269
270 EnvDefineFunction2(theEnv,"get-defgeneric-list",'m',PTIEF GetDefgenericListFunction,
271 "GetDefgenericListFunction","01");
272 EnvDefineFunction2(theEnv,"get-defmethod-list",'m',PTIEF GetDefmethodListCommand,
273 "GetDefmethodListCommand","01w");
274 EnvDefineFunction2(theEnv,"get-method-restrictions",'m',PTIEF GetMethodRestrictionsCommand,
275 "GetMethodRestrictionsCommand","22iw");
276 EnvDefineFunction2(theEnv,"defgeneric-module",'w',PTIEF GetDefgenericModuleCommand,
277 "GetDefgenericModuleCommand","11w");
278
279 #if OBJECT_SYSTEM
280 EnvDefineFunction2(theEnv,"type",'u',PTIEF ClassCommand,"ClassCommand","11u");
281 #else
282 EnvDefineFunction2(theEnv,"type",'u',PTIEF TypeCommand,"TypeCommand","11u");
283 #endif
284
285 #endif
286
287 #if DEBUGGING_FUNCTIONS
288 AddWatchItem(theEnv,"generic-functions",0,&DefgenericData(theEnv)->WatchGenerics,34,
289 DefgenericWatchAccess,DefgenericWatchPrint);
290 AddWatchItem(theEnv,"methods",0,&DefgenericData(theEnv)->WatchMethods,33,
291 DefmethodWatchAccess,DefmethodWatchPrint);
292 #endif
293 }
294
295 /*****************************************************/
296 /* DeallocateDefgenericData: Deallocates environment */
297 /* data for the defgeneric construct. */
298 /*****************************************************/
DeallocateDefgenericData(void * theEnv)299 static void DeallocateDefgenericData(
300 void *theEnv)
301 {
302 #if ! RUN_TIME
303 struct defgenericModule *theModuleItem;
304 void *theModule;
305
306 #if BLOAD || BLOAD_AND_BSAVE
307 if (Bloaded(theEnv)) return;
308 #endif
309
310 DoForAllConstructs(theEnv,DestroyDefgenericAction,DefgenericData(theEnv)->DefgenericModuleIndex,FALSE,NULL);
311
312 for (theModule = EnvGetNextDefmodule(theEnv,NULL);
313 theModule != NULL;
314 theModule = EnvGetNextDefmodule(theEnv,theModule))
315 {
316 theModuleItem = (struct defgenericModule *)
317 GetModuleItem(theEnv,(struct defmodule *) theModule,
318 DefgenericData(theEnv)->DefgenericModuleIndex);
319
320 rtn_struct(theEnv,defgenericModule,theModuleItem);
321 }
322 #else
323 #if MAC_XCD
324 #pragma unused(theEnv)
325 #endif
326 #endif
327 }
328
329 #if ! RUN_TIME
330 /****************************************************/
331 /* DestroyDefgenericAction: Action used to remove */
332 /* defgenerics as a result of DestroyEnvironment. */
333 /****************************************************/
DestroyDefgenericAction(void * theEnv,struct constructHeader * theConstruct,void * buffer)334 static void DestroyDefgenericAction(
335 void *theEnv,
336 struct constructHeader *theConstruct,
337 void *buffer)
338 {
339 #if MAC_XCD
340 #pragma unused(buffer)
341 #endif
342 #if (! BLOAD_ONLY) && (! RUN_TIME)
343 struct defgeneric *theDefgeneric = (struct defgeneric *) theConstruct;
344 long i;
345
346 if (theDefgeneric == NULL) return;
347
348 for (i = 0 ; i < theDefgeneric->mcnt ; i++)
349 { DestroyMethodInfo(theEnv,theDefgeneric,&theDefgeneric->methods[i]); }
350
351 if (theDefgeneric->mcnt != 0)
352 rm(theEnv,(void *) theDefgeneric->methods,(sizeof(DEFMETHOD) * theDefgeneric->mcnt));
353
354 DestroyConstructHeader(theEnv,&theDefgeneric->header);
355
356 rtn_struct(theEnv,defgeneric,theDefgeneric);
357 #else
358 #if MAC_XCD
359 #pragma unused(theEnv,theConstruct)
360 #endif
361 #endif
362 }
363 #endif
364
365 /***************************************************
366 NAME : EnvFindDefgeneric
367 DESCRIPTION : Searches for a generic
368 INPUTS : The name of the generic
369 (possibly including a module name)
370 RETURNS : Pointer to the generic if
371 found, otherwise NULL
372 SIDE EFFECTS : None
373 NOTES : None
374 ***************************************************/
EnvFindDefgeneric(void * theEnv,const char * genericModuleAndName)375 globle void *EnvFindDefgeneric(
376 void *theEnv,
377 const char *genericModuleAndName)
378 {
379 return(FindNamedConstructInModuleOrImports(theEnv,genericModuleAndName,DefgenericData(theEnv)->DefgenericConstruct));
380 }
381
382 /***************************************************
383 NAME : EnvFindDefgenericInModule
384 DESCRIPTION : Searches for a generic
385 INPUTS : The name of the generic
386 (possibly including a module name)
387 RETURNS : Pointer to the generic if
388 found, otherwise NULL
389 SIDE EFFECTS : None
390 NOTES : None
391 ***************************************************/
EnvFindDefgenericInModule(void * theEnv,const char * genericModuleAndName)392 globle void *EnvFindDefgenericInModule(
393 void *theEnv,
394 const char *genericModuleAndName)
395 {
396 return(FindNamedConstructInModule(theEnv,genericModuleAndName,DefgenericData(theEnv)->DefgenericConstruct));
397 }
398
399 /***************************************************
400 NAME : LookupDefgenericByMdlOrScope
401 DESCRIPTION : Finds a defgeneric anywhere (if
402 module is specified) or in current
403 or imported modules
404 INPUTS : The defgeneric name
405 RETURNS : The defgeneric (NULL if not found)
406 SIDE EFFECTS : Error message printed on
407 ambiguous references
408 NOTES : None
409 ***************************************************/
LookupDefgenericByMdlOrScope(void * theEnv,const char * defgenericName)410 globle DEFGENERIC *LookupDefgenericByMdlOrScope(
411 void *theEnv,
412 const char *defgenericName)
413 {
414 return((DEFGENERIC *) LookupConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,defgenericName,TRUE));
415 }
416
417 /***************************************************
418 NAME : LookupDefgenericInScope
419 DESCRIPTION : Finds a defgeneric in current or
420 imported modules (module
421 specifier is not allowed)
422 INPUTS : The defgeneric name
423 RETURNS : The defgeneric (NULL if not found)
424 SIDE EFFECTS : Error message printed on
425 ambiguous references
426 NOTES : None
427 ***************************************************/
LookupDefgenericInScope(void * theEnv,const char * defgenericName)428 globle DEFGENERIC *LookupDefgenericInScope(
429 void *theEnv,
430 const char *defgenericName)
431 {
432 return((DEFGENERIC *) LookupConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,defgenericName,FALSE));
433 }
434
435 /***********************************************************
436 NAME : EnvGetNextDefgeneric
437 DESCRIPTION : Finds first or next generic function
438 INPUTS : The address of the current generic function
439 RETURNS : The address of the next generic function
440 (NULL if none)
441 SIDE EFFECTS : None
442 NOTES : If ptr == NULL, the first generic function
443 is returned.
444 ***********************************************************/
EnvGetNextDefgeneric(void * theEnv,void * ptr)445 globle void *EnvGetNextDefgeneric(
446 void *theEnv,
447 void *ptr)
448 {
449 return((void *) GetNextConstructItem(theEnv,(struct constructHeader *) ptr,DefgenericData(theEnv)->DefgenericModuleIndex));
450 }
451
452 /***********************************************************
453 NAME : EnvGetNextDefmethod
454 DESCRIPTION : Find the next method for a generic function
455 INPUTS : 1) The generic function address
456 2) The index of the current method
457 RETURNS : The index of the next method
458 (0 if none)
459 SIDE EFFECTS : None
460 NOTES : If index == 0, the index of the first
461 method is returned
462 ***********************************************************/
EnvGetNextDefmethod(void * theEnv,void * ptr,long theIndex)463 globle long EnvGetNextDefmethod(
464 void *theEnv,
465 void *ptr,
466 long theIndex)
467 {
468 DEFGENERIC *gfunc;
469 long mi;
470 #if MAC_XCD
471 #pragma unused(theEnv)
472 #endif
473
474 gfunc = (DEFGENERIC *) ptr;
475 if (theIndex == 0)
476 {
477 if (gfunc->methods != NULL)
478 return(gfunc->methods[0].index);
479 return(0);
480 }
481 mi = FindMethodByIndex(gfunc,theIndex);
482 if ((mi+1) == gfunc->mcnt)
483 return(0);
484 return(gfunc->methods[mi+1].index);
485 }
486
487 /*****************************************************
488 NAME : GetDefmethodPointer
489 DESCRIPTION : Returns a pointer to a method
490 INPUTS : 1) Pointer to a defgeneric
491 2) Array index of method in generic's
492 method array (+1)
493 RETURNS : Pointer to the method.
494 SIDE EFFECTS : None
495 NOTES : None
496 *****************************************************/
GetDefmethodPointer(void * ptr,long theIndex)497 globle DEFMETHOD *GetDefmethodPointer(
498 void *ptr,
499 long theIndex)
500 {
501 return(&((DEFGENERIC *) ptr)->methods[theIndex-1]);
502 }
503
504 /***************************************************
505 NAME : EnvIsDefgenericDeletable
506 DESCRIPTION : Determines if a generic function
507 can be deleted
508 INPUTS : Address of the generic function
509 RETURNS : TRUE if deletable, FALSE otherwise
510 SIDE EFFECTS : None
511 NOTES : None
512 ***************************************************/
EnvIsDefgenericDeletable(void * theEnv,void * ptr)513 globle int EnvIsDefgenericDeletable(
514 void *theEnv,
515 void *ptr)
516 {
517 if (! ConstructsDeletable(theEnv))
518 { return FALSE; }
519
520 return ((((DEFGENERIC *) ptr)->busy == 0) ? TRUE : FALSE);
521 }
522
523 /***************************************************
524 NAME : EnvIsDefmethodDeletable
525 DESCRIPTION : Determines if a generic function
526 method can be deleted
527 INPUTS : 1) Address of the generic function
528 2) Index of the method
529 RETURNS : TRUE if deletable, FALSE otherwise
530 SIDE EFFECTS : None
531 NOTES : None
532 ***************************************************/
EnvIsDefmethodDeletable(void * theEnv,void * ptr,long theIndex)533 globle int EnvIsDefmethodDeletable(
534 void *theEnv,
535 void *ptr,
536 long theIndex)
537 {
538 if (! ConstructsDeletable(theEnv))
539 { return FALSE; }
540
541 if (((DEFGENERIC *) ptr)->methods[FindMethodByIndex((DEFGENERIC *) ptr,theIndex)].system)
542 return(FALSE);
543
544 #if (! BLOAD_ONLY) && (! RUN_TIME)
545 return((MethodsExecuting((DEFGENERIC *) ptr) == FALSE) ? TRUE : FALSE);
546 #else
547 return FALSE;
548 #endif
549 }
550
551 /**********************************************************
552 NAME : UndefgenericCommand
553 DESCRIPTION : Deletes all methods for a generic function
554 INPUTS : None
555 RETURNS : Nothing useful
556 SIDE EFFECTS : methods deallocated
557 NOTES : H/L Syntax: (undefgeneric <name> | *)
558 **********************************************************/
UndefgenericCommand(void * theEnv)559 globle void UndefgenericCommand(
560 void *theEnv)
561 {
562 UndefconstructCommand(theEnv,"undefgeneric",DefgenericData(theEnv)->DefgenericConstruct);
563 }
564
565 /****************************************************************
566 NAME : GetDefgenericModuleCommand
567 DESCRIPTION : Determines to which module a defgeneric belongs
568 INPUTS : None
569 RETURNS : The symbolic name of the module
570 SIDE EFFECTS : None
571 NOTES : H/L Syntax: (defgeneric-module <generic-name>)
572 ****************************************************************/
GetDefgenericModuleCommand(void * theEnv)573 globle void *GetDefgenericModuleCommand(
574 void *theEnv)
575 {
576 return(GetConstructModuleCommand(theEnv,"defgeneric-module",DefgenericData(theEnv)->DefgenericConstruct));
577 }
578
579 /**************************************************************
580 NAME : UndefmethodCommand
581 DESCRIPTION : Deletes one method for a generic function
582 INPUTS : None
583 RETURNS : Nothing useful
584 SIDE EFFECTS : methods deallocated
585 NOTES : H/L Syntax: (undefmethod <name> <index> | *)
586 **************************************************************/
UndefmethodCommand(void * theEnv)587 globle void UndefmethodCommand(
588 void *theEnv)
589 {
590 DATA_OBJECT temp;
591 DEFGENERIC *gfunc;
592 long mi;
593
594 if (EnvArgTypeCheck(theEnv,"undefmethod",1,SYMBOL,&temp) == FALSE)
595 return;
596 gfunc = LookupDefgenericByMdlOrScope(theEnv,DOToString(temp));
597 if ((gfunc == NULL) ? (strcmp(DOToString(temp),"*") != 0) : FALSE)
598 {
599 PrintErrorID(theEnv,"GENRCCOM",1,FALSE);
600 EnvPrintRouter(theEnv,WERROR,"No such generic function ");
601 EnvPrintRouter(theEnv,WERROR,DOToString(temp));
602 EnvPrintRouter(theEnv,WERROR," in function undefmethod.\n");
603 return;
604 }
605 EnvRtnUnknown(theEnv,2,&temp);
606 if (temp.type == SYMBOL)
607 {
608 if (strcmp(DOToString(temp),"*") != 0)
609 {
610 PrintErrorID(theEnv,"GENRCCOM",2,FALSE);
611 EnvPrintRouter(theEnv,WERROR,"Expected a valid method index in function undefmethod.\n");
612 return;
613 }
614 mi = 0;
615 }
616 else if (temp.type == INTEGER)
617 {
618 mi = (long) DOToLong(temp);
619 if (mi == 0)
620 {
621 PrintErrorID(theEnv,"GENRCCOM",2,FALSE);
622 EnvPrintRouter(theEnv,WERROR,"Expected a valid method index in function undefmethod.\n");
623 return;
624 }
625 }
626 else
627 {
628 PrintErrorID(theEnv,"GENRCCOM",2,FALSE);
629 EnvPrintRouter(theEnv,WERROR,"Expected a valid method index in function undefmethod.\n");
630 return;
631 }
632 EnvUndefmethod(theEnv,(void *) gfunc,mi);
633 }
634
635 /**************************************************************
636 NAME : EnvUndefgeneric
637 DESCRIPTION : Deletes all methods for a generic function
638 INPUTS : The generic-function address (NULL for all)
639 RETURNS : TRUE if generic successfully deleted,
640 FALSE otherwise
641 SIDE EFFECTS : methods deallocated
642 NOTES : None
643 **************************************************************/
EnvUndefgeneric(void * theEnv,void * vptr)644 globle intBool EnvUndefgeneric(
645 void *theEnv,
646 void *vptr)
647 {
648 #if RUN_TIME || BLOAD_ONLY
649 return(FALSE);
650 #else
651 DEFGENERIC *gfunc;
652 int success = TRUE;
653
654 gfunc = (DEFGENERIC *) vptr;
655 if (gfunc == NULL)
656 {
657 if (ClearDefmethods(theEnv) == FALSE)
658 success = FALSE;
659 if (ClearDefgenerics(theEnv) == FALSE)
660 success = FALSE;
661 return(success);
662 }
663 if (EnvIsDefgenericDeletable(theEnv,vptr) == FALSE)
664 return(FALSE);
665 RemoveConstructFromModule(theEnv,(struct constructHeader *) vptr);
666 RemoveDefgeneric(theEnv,gfunc);
667 return(TRUE);
668 #endif
669 }
670
671 /**************************************************************
672 NAME : EnvUndefmethod
673 DESCRIPTION : Deletes one method for a generic function
674 INPUTS : 1) Address of generic function (can be NULL)
675 2) Method index (0 for all)
676 RETURNS : TRUE if method deleted successfully,
677 FALSE otherwise
678 SIDE EFFECTS : methods deallocated
679 NOTES : None
680 **************************************************************/
EnvUndefmethod(void * theEnv,void * vptr,long mi)681 globle intBool EnvUndefmethod(
682 void *theEnv,
683 void *vptr,
684 long mi)
685 {
686 DEFGENERIC *gfunc;
687
688 #if RUN_TIME || BLOAD_ONLY
689 gfunc = (DEFGENERIC *) vptr;
690 PrintErrorID(theEnv,"PRNTUTIL",4,FALSE);
691 EnvPrintRouter(theEnv,WERROR,"Unable to delete method ");
692 if (gfunc != NULL)
693 {
694 PrintGenericName(theEnv,WERROR,gfunc);
695 EnvPrintRouter(theEnv,WERROR," #");
696 PrintLongInteger(theEnv,WERROR,(long long) mi);
697 }
698 else
699 EnvPrintRouter(theEnv,WERROR,"*");
700 EnvPrintRouter(theEnv,WERROR,".\n");
701 return(FALSE);
702 #else
703 long nmi;
704
705 gfunc = (DEFGENERIC *) vptr;
706 #if BLOAD || BLOAD_AND_BSAVE
707 if (Bloaded(theEnv) == TRUE)
708 {
709 PrintErrorID(theEnv,"PRNTUTIL",4,FALSE);
710 EnvPrintRouter(theEnv,WERROR,"Unable to delete method ");
711 if (gfunc != NULL)
712 {
713 EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
714 EnvPrintRouter(theEnv,WERROR," #");
715 PrintLongInteger(theEnv,WERROR,(long long) mi);
716 }
717 else
718 EnvPrintRouter(theEnv,WERROR,"*");
719 EnvPrintRouter(theEnv,WERROR,".\n");
720 return(FALSE);
721 }
722 #endif
723 if (gfunc == NULL)
724 {
725 if (mi != 0)
726 {
727 PrintErrorID(theEnv,"GENRCCOM",3,FALSE);
728 EnvPrintRouter(theEnv,WERROR,"Incomplete method specification for deletion.\n");
729 return(FALSE);
730 }
731 return(ClearDefmethods(theEnv));
732 }
733 if (MethodsExecuting(gfunc))
734 {
735 MethodAlterError(theEnv,gfunc);
736 return(FALSE);
737 }
738 if (mi == 0)
739 RemoveAllExplicitMethods(theEnv,gfunc);
740 else
741 {
742 nmi = CheckMethodExists(theEnv,"undefmethod",gfunc,mi);
743 if (nmi == -1)
744 return(FALSE);
745 RemoveDefgenericMethod(theEnv,gfunc,nmi);
746 }
747 return(TRUE);
748 #endif
749 }
750
751 #if DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS
752
753 /*****************************************************
754 NAME : EnvGetDefmethodDescription
755 DESCRIPTION : Prints a synopsis of method parameter
756 restrictions into caller's buffer
757 INPUTS : 1) Caller's buffer
758 2) Buffer size (not including space
759 for terminating '\0')
760 3) Address of generic function
761 4) Index of method
762 RETURNS : Nothing useful
763 SIDE EFFECTS : Caller's buffer written
764 NOTES : Terminating '\n' not written
765 *****************************************************/
EnvGetDefmethodDescription(void * theEnv,char * buf,size_t buflen,void * ptr,long theIndex)766 globle void EnvGetDefmethodDescription(
767 void *theEnv,
768 char *buf,
769 size_t buflen,
770 void *ptr,
771 long theIndex)
772 {
773 DEFGENERIC *gfunc;
774 long mi;
775 #if MAC_XCD
776 #pragma unused(theEnv)
777 #endif
778
779 gfunc = (DEFGENERIC *) ptr;
780 mi = FindMethodByIndex(gfunc,theIndex);
781 PrintMethod(theEnv,buf,buflen,&gfunc->methods[mi]);
782 }
783 #endif /* DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS */
784
785 #if DEBUGGING_FUNCTIONS
786
787 /*********************************************************
788 NAME : EnvGetDefgenericWatch
789 DESCRIPTION : Determines if trace messages are
790 gnerated when executing generic function
791 INPUTS : A pointer to the generic
792 RETURNS : TRUE if a trace is active,
793 FALSE otherwise
794 SIDE EFFECTS : None
795 NOTES : None
796 *********************************************************/
EnvGetDefgenericWatch(void * theEnv,void * theGeneric)797 globle unsigned EnvGetDefgenericWatch(
798 void *theEnv,
799 void *theGeneric)
800 {
801 #if MAC_XCD
802 #pragma unused(theEnv)
803 #endif
804
805 return(((DEFGENERIC *) theGeneric)->trace);
806 }
807
808 /*********************************************************
809 NAME : EnvSetDefgenericWatch
810 DESCRIPTION : Sets the trace to ON/OFF for the
811 generic function
812 INPUTS : 1) TRUE to set the trace on,
813 FALSE to set it off
814 2) A pointer to the generic
815 RETURNS : Nothing useful
816 SIDE EFFECTS : Watch flag for the generic set
817 NOTES : None
818 *********************************************************/
EnvSetDefgenericWatch(void * theEnv,unsigned newState,void * theGeneric)819 globle void EnvSetDefgenericWatch(
820 void *theEnv,
821 unsigned newState,
822 void *theGeneric)
823 {
824 #if MAC_XCD
825 #pragma unused(theEnv)
826 #endif
827
828 ((DEFGENERIC *) theGeneric)->trace = newState;
829 }
830
831 /*********************************************************
832 NAME : EnvGetDefmethodWatch
833 DESCRIPTION : Determines if trace messages for calls
834 to this method will be generated or not
835 INPUTS : 1) A pointer to the generic
836 2) The index of the method
837 RETURNS : TRUE if a trace is active,
838 FALSE otherwise
839 SIDE EFFECTS : None
840 NOTES : None
841 *********************************************************/
EnvGetDefmethodWatch(void * theEnv,void * theGeneric,long theIndex)842 globle unsigned EnvGetDefmethodWatch(
843 void *theEnv,
844 void *theGeneric,
845 long theIndex)
846 {
847 DEFGENERIC *gfunc;
848 long mi;
849 #if MAC_XCD
850 #pragma unused(theEnv)
851 #endif
852
853 gfunc = (DEFGENERIC *) theGeneric;
854 mi = FindMethodByIndex(gfunc,theIndex);
855 return(gfunc->methods[mi].trace);
856 }
857
858 /*********************************************************
859 NAME : EnvSetDefmethodWatch
860 DESCRIPTION : Sets the trace to ON/OFF for the
861 calling of the method
862 INPUTS : 1) TRUE to set the trace on,
863 FALSE to set it off
864 2) A pointer to the generic
865 3) The index of the method
866 RETURNS : Nothing useful
867 SIDE EFFECTS : Watch flag for the method set
868 NOTES : None
869 *********************************************************/
EnvSetDefmethodWatch(void * theEnv,unsigned newState,void * theGeneric,long theIndex)870 globle void EnvSetDefmethodWatch(
871 void *theEnv,
872 unsigned newState,
873 void *theGeneric,
874 long theIndex)
875 {
876 DEFGENERIC *gfunc;
877 long mi;
878 #if MAC_XCD
879 #pragma unused(theEnv)
880 #endif
881
882 gfunc = (DEFGENERIC *) theGeneric;
883 mi = FindMethodByIndex(gfunc,theIndex);
884 gfunc->methods[mi].trace = newState;
885 }
886
887
888 /********************************************************
889 NAME : PPDefgenericCommand
890 DESCRIPTION : Displays the pretty-print form of
891 a generic function header
892 INPUTS : None
893 RETURNS : Nothing useful
894 SIDE EFFECTS : None
895 NOTES : H/L Syntax: (ppdefgeneric <name>)
896 ********************************************************/
PPDefgenericCommand(void * theEnv)897 globle void PPDefgenericCommand(
898 void *theEnv)
899 {
900 PPConstructCommand(theEnv,"ppdefgeneric",DefgenericData(theEnv)->DefgenericConstruct);
901 }
902
903 /**********************************************************
904 NAME : PPDefmethodCommand
905 DESCRIPTION : Displays the pretty-print form of
906 a method
907 INPUTS : None
908 RETURNS : Nothing useful
909 SIDE EFFECTS : None
910 NOTES : H/L Syntax: (ppdefmethod <name> <index>)
911 **********************************************************/
PPDefmethodCommand(void * theEnv)912 globle void PPDefmethodCommand(
913 void *theEnv)
914 {
915 DATA_OBJECT temp;
916 const char *gname;
917 DEFGENERIC *gfunc;
918 int gi;
919
920 if (EnvArgTypeCheck(theEnv,"ppdefmethod",1,SYMBOL,&temp) == FALSE)
921 return;
922 gname = DOToString(temp);
923 if (EnvArgTypeCheck(theEnv,"ppdefmethod",2,INTEGER,&temp) == FALSE)
924 return;
925 gfunc = CheckGenericExists(theEnv,"ppdefmethod",gname);
926 if (gfunc == NULL)
927 return;
928 gi = CheckMethodExists(theEnv,"ppdefmethod",gfunc,(long) DOToLong(temp));
929 if (gi == -1)
930 return;
931 if (gfunc->methods[gi].ppForm != NULL)
932 PrintInChunks(theEnv,WDISPLAY,gfunc->methods[gi].ppForm);
933 }
934
935 /******************************************************
936 NAME : ListDefmethodsCommand
937 DESCRIPTION : Lists a brief description of methods
938 for a particular generic function
939 INPUTS : None
940 RETURNS : Nothing useful
941 SIDE EFFECTS : None
942 NOTES : H/L Syntax: (list-defmethods <name>)
943 ******************************************************/
ListDefmethodsCommand(void * theEnv)944 globle void ListDefmethodsCommand(
945 void *theEnv)
946 {
947 DATA_OBJECT temp;
948 DEFGENERIC *gfunc;
949
950 if (EnvRtnArgCount(theEnv) == 0)
951 EnvListDefmethods(theEnv,WDISPLAY,NULL);
952 else
953 {
954 if (EnvArgTypeCheck(theEnv,"list-defmethods",1,SYMBOL,&temp) == FALSE)
955 return;
956 gfunc = CheckGenericExists(theEnv,"list-defmethods",DOToString(temp));
957 if (gfunc != NULL)
958 EnvListDefmethods(theEnv,WDISPLAY,(void *) gfunc);
959 }
960 }
961
962 /***************************************************************
963 NAME : EnvGetDefmethodPPForm
964 DESCRIPTION : Getsa generic function method pretty print form
965 INPUTS : 1) Address of the generic function
966 2) Index of the method
967 RETURNS : Method ppform
968 SIDE EFFECTS : None
969 NOTES : None
970 ***************************************************************/
EnvGetDefmethodPPForm(void * theEnv,void * ptr,long theIndex)971 globle const char *EnvGetDefmethodPPForm(
972 void *theEnv,
973 void *ptr,
974 long theIndex)
975 {
976 DEFGENERIC *gfunc;
977 int mi;
978 #if MAC_XCD
979 #pragma unused(theEnv)
980 #endif
981
982 gfunc = (DEFGENERIC *) ptr;
983 mi = FindMethodByIndex(gfunc,theIndex);
984 return(gfunc->methods[mi].ppForm);
985 }
986
987 /***************************************************
988 NAME : ListDefgenericsCommand
989 DESCRIPTION : Displays all defgeneric names
990 INPUTS : None
991 RETURNS : Nothing useful
992 SIDE EFFECTS : Defgeneric names printed
993 NOTES : H/L Interface
994 ***************************************************/
ListDefgenericsCommand(void * theEnv)995 globle void ListDefgenericsCommand(
996 void *theEnv)
997 {
998 ListConstructCommand(theEnv,"list-defgenerics",DefgenericData(theEnv)->DefgenericConstruct);
999 }
1000
1001 /***************************************************
1002 NAME : EnvListDefgenerics
1003 DESCRIPTION : Displays all defgeneric names
1004 INPUTS : 1) The logical name of the output
1005 2) The module
1006 RETURNS : Nothing useful
1007 SIDE EFFECTS : Defgeneric names printed
1008 NOTES : C Interface
1009 ***************************************************/
EnvListDefgenerics(void * theEnv,const char * logicalName,struct defmodule * theModule)1010 globle void EnvListDefgenerics(
1011 void *theEnv,
1012 const char *logicalName,
1013 struct defmodule *theModule)
1014 {
1015 ListConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,logicalName,theModule);
1016 }
1017
1018 /******************************************************
1019 NAME : EnvListDefmethods
1020 DESCRIPTION : Lists a brief description of methods
1021 for a particular generic function
1022 INPUTS : 1) The logical name of the output
1023 2) Generic function to list methods for
1024 (NULL means list all methods)
1025 RETURNS : Nothing useful
1026 SIDE EFFECTS : None
1027 NOTES : None
1028 ******************************************************/
EnvListDefmethods(void * theEnv,const char * logicalName,void * vptr)1029 globle void EnvListDefmethods(
1030 void *theEnv,
1031 const char *logicalName,
1032 void *vptr)
1033 {
1034 DEFGENERIC *gfunc;
1035 long count;
1036 if (vptr != NULL)
1037 count = ListMethodsForGeneric(theEnv,logicalName,(DEFGENERIC *) vptr);
1038 else
1039 {
1040 count = 0L;
1041 for (gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL) ;
1042 gfunc != NULL ;
1043 gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc))
1044 {
1045 count += ListMethodsForGeneric(theEnv,logicalName,gfunc);
1046 if (EnvGetNextDefgeneric(theEnv,(void *) gfunc) != NULL)
1047 EnvPrintRouter(theEnv,logicalName,"\n");
1048 }
1049 }
1050 PrintTally(theEnv,logicalName,count,"method","methods");
1051 }
1052
1053 #endif /* DEBUGGING_FUNCTIONS */
1054
1055 /***************************************************************
1056 NAME : GetDefgenericListFunction
1057 DESCRIPTION : Groups all defgeneric names into
1058 a multifield list
1059 INPUTS : A data object buffer to hold
1060 the multifield result
1061 RETURNS : Nothing useful
1062 SIDE EFFECTS : Multifield allocated and filled
1063 NOTES : H/L Syntax: (get-defgeneric-list [<module>])
1064 ***************************************************************/
GetDefgenericListFunction(void * theEnv,DATA_OBJECT * returnValue)1065 globle void GetDefgenericListFunction(
1066 void *theEnv,
1067 DATA_OBJECT*returnValue)
1068 {
1069 GetConstructListFunction(theEnv,"get-defgeneric-list",returnValue,DefgenericData(theEnv)->DefgenericConstruct);
1070 }
1071
1072 /***************************************************************
1073 NAME : EnvGetDefgenericList
1074 DESCRIPTION : Groups all defgeneric names into
1075 a multifield list
1076 INPUTS : 1) A data object buffer to hold
1077 the multifield result
1078 2) The module from which to obtain defgenerics
1079 RETURNS : Nothing useful
1080 SIDE EFFECTS : Multifield allocated and filled
1081 NOTES : External C access
1082 ***************************************************************/
EnvGetDefgenericList(void * theEnv,DATA_OBJECT * returnValue,struct defmodule * theModule)1083 globle void EnvGetDefgenericList(
1084 void *theEnv,
1085 DATA_OBJECT *returnValue,
1086 struct defmodule *theModule)
1087 {
1088 GetConstructList(theEnv,returnValue,DefgenericData(theEnv)->DefgenericConstruct,theModule);
1089 }
1090
1091 /***********************************************************
1092 NAME : GetDefmethodListCommand
1093 DESCRIPTION : Groups indices of all methdos for a generic
1094 function into a multifield variable
1095 (NULL means get methods for all generics)
1096 INPUTS : A data object buffer
1097 RETURNS : Nothing useful
1098 SIDE EFFECTS : Multifield set to list of method indices
1099 NOTES : None
1100 ***********************************************************/
GetDefmethodListCommand(void * theEnv,DATA_OBJECT_PTR returnValue)1101 globle void GetDefmethodListCommand(
1102 void *theEnv,
1103 DATA_OBJECT_PTR returnValue)
1104 {
1105 DATA_OBJECT temp;
1106 DEFGENERIC *gfunc;
1107
1108 if (EnvRtnArgCount(theEnv) == 0)
1109 EnvGetDefmethodList(theEnv,NULL,returnValue);
1110 else
1111 {
1112 if (EnvArgTypeCheck(theEnv,"get-defmethod-list",1,SYMBOL,&temp) == FALSE)
1113 {
1114 EnvSetMultifieldErrorValue(theEnv,returnValue);
1115 return;
1116 }
1117 gfunc = CheckGenericExists(theEnv,"get-defmethod-list",DOToString(temp));
1118 if (gfunc != NULL)
1119 EnvGetDefmethodList(theEnv,(void *) gfunc,returnValue);
1120 else
1121 EnvSetMultifieldErrorValue(theEnv,returnValue);
1122 }
1123 }
1124
1125 /***********************************************************
1126 NAME : EnvGetDefmethodList
1127 DESCRIPTION : Groups indices of all methdos for a generic
1128 function into a multifield variable
1129 (NULL means get methods for all generics)
1130 INPUTS : 1) A pointer to a generic function
1131 2) A data object buffer
1132 RETURNS : Nothing useful
1133 SIDE EFFECTS : Multifield set to list of method indices
1134 NOTES : None
1135 ***********************************************************/
EnvGetDefmethodList(void * theEnv,void * vgfunc,DATA_OBJECT_PTR returnValue)1136 globle void EnvGetDefmethodList(
1137 void *theEnv,
1138 void *vgfunc,
1139 DATA_OBJECT_PTR returnValue)
1140 {
1141 DEFGENERIC *gfunc,*svg,*svnxt;
1142 long i,j;
1143 unsigned long count;
1144 MULTIFIELD_PTR theList;
1145
1146 if (vgfunc != NULL)
1147 {
1148 gfunc = (DEFGENERIC *) vgfunc;
1149 svnxt = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,vgfunc);
1150 SetNextDefgeneric(vgfunc,NULL);
1151 }
1152 else
1153 {
1154 gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL);
1155 svnxt = (gfunc != NULL) ? (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc) : NULL;
1156 }
1157 count = 0;
1158 for (svg = gfunc ;
1159 gfunc != NULL ;
1160 gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc))
1161 count += (unsigned long) gfunc->mcnt;
1162 count *= 2;
1163 SetpType(returnValue,MULTIFIELD);
1164 SetpDOBegin(returnValue,1);
1165 SetpDOEnd(returnValue,count);
1166 theList = (MULTIFIELD_PTR) EnvCreateMultifield(theEnv,count);
1167 SetpValue(returnValue,theList);
1168 for (gfunc = svg , i = 1 ;
1169 gfunc != NULL ;
1170 gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc))
1171 {
1172 for (j = 0 ; j < gfunc->mcnt ; j++)
1173 {
1174 SetMFType(theList,i,SYMBOL);
1175 SetMFValue(theList,i++,GetDefgenericNamePointer((void *) gfunc));
1176 SetMFType(theList,i,INTEGER);
1177 SetMFValue(theList,i++,EnvAddLong(theEnv,(long long) gfunc->methods[j].index));
1178 }
1179 }
1180 if (svg != NULL)
1181 SetNextDefgeneric((void *) svg,(void *) svnxt);
1182 }
1183
1184 /***********************************************************************************
1185 NAME : GetMethodRestrictionsCommand
1186 DESCRIPTION : Stores restrictions of a method in multifield
1187 INPUTS : A data object buffer to hold a multifield
1188 RETURNS : Nothing useful
1189 SIDE EFFECTS : Multifield created (length zero on errors)
1190 NOTES : Syntax: (get-method-restrictions <generic-function> <method-index>)
1191 ***********************************************************************************/
GetMethodRestrictionsCommand(void * theEnv,DATA_OBJECT * result)1192 globle void GetMethodRestrictionsCommand(
1193 void *theEnv,
1194 DATA_OBJECT *result)
1195 {
1196 DATA_OBJECT temp;
1197 DEFGENERIC *gfunc;
1198
1199 if (EnvArgTypeCheck(theEnv,"get-method-restrictions",1,SYMBOL,&temp) == FALSE)
1200 {
1201 EnvSetMultifieldErrorValue(theEnv,result);
1202 return;
1203 }
1204 gfunc = CheckGenericExists(theEnv,"get-method-restrictions",DOToString(temp));
1205 if (gfunc == NULL)
1206 {
1207 EnvSetMultifieldErrorValue(theEnv,result);
1208 return;
1209 }
1210 if (EnvArgTypeCheck(theEnv,"get-method-restrictions",2,INTEGER,&temp) == FALSE)
1211 {
1212 EnvSetMultifieldErrorValue(theEnv,result);
1213 return;
1214 }
1215 if (CheckMethodExists(theEnv,"get-method-restrictions",gfunc,(long) DOToLong(temp)) == -1)
1216 {
1217 EnvSetMultifieldErrorValue(theEnv,result);
1218 return;
1219 }
1220 EnvGetMethodRestrictions(theEnv,(void *) gfunc,(unsigned) DOToLong(temp),result);
1221 }
1222
1223 /***********************************************************************
1224 NAME : EnvGetMethodRestrictions
1225 DESCRIPTION : Stores restrictions of a method in multifield
1226 INPUTS : 1) Pointer to the generic function
1227 2) The method index
1228 3) A data object buffer to hold a multifield
1229 RETURNS : Nothing useful
1230 SIDE EFFECTS : Multifield created (length zero on errors)
1231 NOTES : The restrictions are stored in the multifield
1232 in the following format:
1233
1234 <min-number-of-arguments>
1235 <max-number-of-arguments> (-1 if wildcard allowed)
1236 <restriction-count>
1237 <index of 1st restriction>
1238 .
1239 .
1240 <index of nth restriction>
1241 <restriction 1>
1242 <query TRUE/FALSE>
1243 <number-of-classes>
1244 <class 1>
1245 .
1246 .
1247 <class n>
1248 .
1249 .
1250 .
1251 <restriction n>
1252
1253 Thus, for the method
1254 (defmethod foo ((?a NUMBER SYMBOL) (?b (= 1 1)) $?c))
1255 (get-method-restrictions foo 1) would yield
1256
1257 (2 -1 3 7 11 13 FALSE 2 NUMBER SYMBOL TRUE 0 FALSE 0)
1258 ***********************************************************************/
EnvGetMethodRestrictions(void * theEnv,void * vgfunc,long mi,DATA_OBJECT * result)1259 globle void EnvGetMethodRestrictions(
1260 void *theEnv,
1261 void *vgfunc,
1262 long mi,
1263 DATA_OBJECT *result)
1264 {
1265 short i,j;
1266 register DEFMETHOD *meth;
1267 register RESTRICTION *rptr;
1268 long count;
1269 int roffset,rstrctIndex;
1270 MULTIFIELD_PTR theList;
1271
1272 meth = ((DEFGENERIC *) vgfunc)->methods + FindMethodByIndex((DEFGENERIC *) vgfunc,mi);
1273 count = 3;
1274 for (i = 0 ; i < meth->restrictionCount ; i++)
1275 count += meth->restrictions[i].tcnt + 3;
1276 theList = (MULTIFIELD_PTR) EnvCreateMultifield(theEnv,count);
1277 SetpType(result,MULTIFIELD);
1278 SetpValue(result,theList);
1279 SetpDOBegin(result,1);
1280 SetpDOEnd(result,count);
1281 SetMFType(theList,1,INTEGER);
1282 SetMFValue(theList,1,EnvAddLong(theEnv,(long long) meth->minRestrictions));
1283 SetMFType(theList,2,INTEGER);
1284 SetMFValue(theList,2,EnvAddLong(theEnv,(long long) meth->maxRestrictions));
1285 SetMFType(theList,3,INTEGER);
1286 SetMFValue(theList,3,EnvAddLong(theEnv,(long long) meth->restrictionCount));
1287 roffset = 3 + meth->restrictionCount + 1;
1288 rstrctIndex = 4;
1289 for (i = 0 ; i < meth->restrictionCount ; i++)
1290 {
1291 rptr = meth->restrictions + i;
1292 SetMFType(theList,rstrctIndex,INTEGER);
1293 SetMFValue(theList,rstrctIndex++,EnvAddLong(theEnv,(long long) roffset));
1294 SetMFType(theList,roffset,SYMBOL);
1295 SetMFValue(theList,roffset++,(rptr->query != NULL) ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv));
1296 SetMFType(theList,roffset,INTEGER);
1297 SetMFValue(theList,roffset++,EnvAddLong(theEnv,(long long) rptr->tcnt));
1298 for (j = 0 ; j < rptr->tcnt ; j++)
1299 {
1300 SetMFType(theList,roffset,SYMBOL);
1301 #if OBJECT_SYSTEM
1302 SetMFValue(theList,roffset++,EnvAddSymbol(theEnv,EnvGetDefclassName(theEnv,rptr->types[j])));
1303 #else
1304 SetMFValue(theList,roffset++,EnvAddSymbol(theEnv,TypeName(theEnv,ValueToInteger(rptr->types[j]))));
1305 #endif
1306 }
1307 }
1308 }
1309
1310 /* =========================================
1311 *****************************************
1312 INTERNALLY VISIBLE FUNCTIONS
1313 =========================================
1314 ***************************************** */
1315
1316 /***************************************************
1317 NAME : PrintGenericCall
1318 DESCRIPTION : PrintExpression() support function
1319 for generic function calls
1320 INPUTS : 1) The output logical name
1321 2) The generic function
1322 RETURNS : Nothing useful
1323 SIDE EFFECTS : Call expression printed
1324 NOTES : None
1325 ***************************************************/
PrintGenericCall(void * theEnv,const char * logName,void * value)1326 static void PrintGenericCall(
1327 void *theEnv,
1328 const char *logName,
1329 void *value)
1330 {
1331 #if DEVELOPER
1332
1333 EnvPrintRouter(theEnv,logName,"(");
1334 EnvPrintRouter(theEnv,logName,EnvGetDefgenericName(theEnv,value));
1335 if (GetFirstArgument() != NULL)
1336 {
1337 EnvPrintRouter(theEnv,logName," ");
1338 PrintExpression(theEnv,logName,GetFirstArgument());
1339 }
1340 EnvPrintRouter(theEnv,logName,")");
1341 #else
1342 #if MAC_XCD
1343 #pragma unused(theEnv)
1344 #pragma unused(logName)
1345 #pragma unused(value)
1346 #endif
1347 #endif
1348 }
1349
1350 /*******************************************************
1351 NAME : EvaluateGenericCall
1352 DESCRIPTION : Primitive support function for
1353 calling a generic function
1354 INPUTS : 1) The generic function
1355 2) A data object buffer to hold
1356 the evaluation result
1357 RETURNS : FALSE if the generic function
1358 returns the symbol FALSE,
1359 TRUE otherwise
1360 SIDE EFFECTS : Data obejct buffer set and any
1361 side-effects of calling the generic
1362 NOTES : None
1363 *******************************************************/
EvaluateGenericCall(void * theEnv,void * value,DATA_OBJECT * result)1364 static intBool EvaluateGenericCall(
1365 void *theEnv,
1366 void *value,
1367 DATA_OBJECT *result)
1368 {
1369 GenericDispatch(theEnv,(DEFGENERIC *) value,NULL,NULL,GetFirstArgument(),result);
1370 if ((GetpType(result) == SYMBOL) &&
1371 (GetpValue(result) == EnvFalseSymbol(theEnv)))
1372 return(FALSE);
1373 return(TRUE);
1374 }
1375
1376 /***************************************************
1377 NAME : DecrementGenericBusyCount
1378 DESCRIPTION : Lowers the busy count of a
1379 generic function construct
1380 INPUTS : The generic function
1381 RETURNS : Nothing useful
1382 SIDE EFFECTS : Busy count decremented if a clear
1383 is not in progress (see comment)
1384 NOTES : None
1385 ***************************************************/
DecrementGenericBusyCount(void * theEnv,void * value)1386 static void DecrementGenericBusyCount(
1387 void *theEnv,
1388 void *value)
1389 {
1390 /* ==============================================
1391 The generics to which expressions in other
1392 constructs may refer may already have been
1393 deleted - thus, it is important not to modify
1394 the busy flag during a clear.
1395 ============================================== */
1396 if (! ConstructData(theEnv)->ClearInProgress)
1397 ((DEFGENERIC *) value)->busy--;
1398 }
1399
1400 /***************************************************
1401 NAME : IncrementGenericBusyCount
1402 DESCRIPTION : Raises the busy count of a
1403 generic function construct
1404 INPUTS : The generic function
1405 RETURNS : Nothing useful
1406 SIDE EFFECTS : Busy count incremented
1407 NOTES : None
1408 ***************************************************/
IncrementGenericBusyCount(void * theEnv,void * value)1409 static void IncrementGenericBusyCount(
1410 void *theEnv,
1411 void *value)
1412 {
1413 #if MAC_XCD
1414 #pragma unused(theEnv)
1415 #endif
1416 #if (! RUN_TIME) && (! BLOAD_ONLY)
1417 if (! ConstructData(theEnv)->ParsingConstruct)
1418 { ConstructData(theEnv)->DanglingConstructs++; }
1419 #endif
1420
1421 ((DEFGENERIC *) value)->busy++;
1422 }
1423
1424 #if (! BLOAD_ONLY) && (! RUN_TIME)
1425
1426 /**********************************************************************
1427 NAME : SaveDefgenerics
1428 DESCRIPTION : Outputs pretty-print forms of generic function headers
1429 INPUTS : The logical name of the output
1430 RETURNS : Nothing useful
1431 SIDE EFFECTS : None
1432 NOTES : None
1433 **********************************************************************/
SaveDefgenerics(void * theEnv,void * theModule,const char * logName)1434 static void SaveDefgenerics(
1435 void *theEnv,
1436 void *theModule,
1437 const char *logName)
1438 {
1439 SaveConstruct(theEnv,theModule,logName,DefgenericData(theEnv)->DefgenericConstruct);
1440 }
1441
1442 /**********************************************************************
1443 NAME : SaveDefmethods
1444 DESCRIPTION : Outputs pretty-print forms of generic function methods
1445 INPUTS : The logical name of the output
1446 RETURNS : Nothing useful
1447 SIDE EFFECTS : None
1448 NOTES : None
1449 **********************************************************************/
SaveDefmethods(void * theEnv,void * theModule,const char * logName)1450 static void SaveDefmethods(
1451 void *theEnv,
1452 void *theModule,
1453 const char *logName)
1454 {
1455 DoForAllConstructsInModule(theEnv,theModule,SaveDefmethodsForDefgeneric,
1456 DefgenericData(theEnv)->DefgenericModuleIndex,
1457 FALSE,(void *) logName);
1458 }
1459
1460 /***************************************************
1461 NAME : SaveDefmethodsForDefgeneric
1462 DESCRIPTION : Save the pretty-print forms of
1463 all methods for a generic function
1464 to a file
1465 INPUTS : 1) The defgeneric
1466 2) The logical name of the output
1467 RETURNS : Nothing useful
1468 SIDE EFFECTS : Methods written
1469 NOTES : None
1470 ***************************************************/
SaveDefmethodsForDefgeneric(void * theEnv,struct constructHeader * theDefgeneric,void * userBuffer)1471 static void SaveDefmethodsForDefgeneric(
1472 void *theEnv,
1473 struct constructHeader *theDefgeneric,
1474 void *userBuffer)
1475 {
1476 DEFGENERIC *gfunc = (DEFGENERIC *) theDefgeneric;
1477 const char *logName = (const char *) userBuffer;
1478 long i;
1479
1480 for (i = 0 ; i < gfunc->mcnt ; i++)
1481 {
1482 if (gfunc->methods[i].ppForm != NULL)
1483 {
1484 PrintInChunks(theEnv,logName,gfunc->methods[i].ppForm);
1485 EnvPrintRouter(theEnv,logName,"\n");
1486 }
1487 }
1488 }
1489
1490 /****************************************************
1491 NAME : RemoveDefgenericMethod
1492 DESCRIPTION : Removes a generic function method
1493 from the array and removes the
1494 generic too if its the last method
1495 INPUTS : 1) The generic function
1496 2) The array index of the method
1497 RETURNS : Nothing useful
1498 SIDE EFFECTS : List adjusted
1499 Nodes deallocated
1500 NOTES : Assumes deletion is safe
1501 ****************************************************/
RemoveDefgenericMethod(void * theEnv,DEFGENERIC * gfunc,long gi)1502 static void RemoveDefgenericMethod(
1503 void *theEnv,
1504 DEFGENERIC *gfunc,
1505 long gi)
1506 {
1507 DEFMETHOD *narr;
1508 long b,e;
1509
1510 if (gfunc->methods[gi].system)
1511 {
1512 SetEvaluationError(theEnv,TRUE);
1513 PrintErrorID(theEnv,"GENRCCOM",4,FALSE);
1514 EnvPrintRouter(theEnv,WERROR,"Cannot remove implicit system function method for generic function ");
1515 EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
1516 EnvPrintRouter(theEnv,WERROR,".\n");
1517 return;
1518 }
1519 DeleteMethodInfo(theEnv,gfunc,&gfunc->methods[gi]);
1520 if (gfunc->mcnt == 1)
1521 {
1522 rm(theEnv,(void *) gfunc->methods,(int) sizeof(DEFMETHOD));
1523 gfunc->mcnt = 0;
1524 gfunc->methods = NULL;
1525 }
1526 else
1527 {
1528 gfunc->mcnt--;
1529 narr = (DEFMETHOD *) gm2(theEnv,(sizeof(DEFMETHOD) * gfunc->mcnt));
1530 for (b = e = 0 ; b < gfunc->mcnt ; b++ , e++)
1531 {
1532 if (((int) b) == gi)
1533 e++;
1534 GenCopyMemory(DEFMETHOD,1,&narr[b],&gfunc->methods[e]);
1535 }
1536 rm(theEnv,(void *) gfunc->methods,(sizeof(DEFMETHOD) * (gfunc->mcnt+1)));
1537 gfunc->methods = narr;
1538 }
1539 }
1540
1541 #endif
1542
1543 #if DEBUGGING_FUNCTIONS
1544
1545 /******************************************************
1546 NAME : ListMethodsForGeneric
1547 DESCRIPTION : Lists a brief description of methods
1548 for a particular generic function
1549 INPUTS : 1) The logical name of the output
1550 2) Generic function to list methods for
1551 RETURNS : The number of methods printed
1552 SIDE EFFECTS : None
1553 NOTES : None
1554 ******************************************************/
ListMethodsForGeneric(void * theEnv,const char * logicalName,DEFGENERIC * gfunc)1555 static long ListMethodsForGeneric(
1556 void *theEnv,
1557 const char *logicalName,
1558 DEFGENERIC *gfunc)
1559 {
1560 long gi;
1561 char buf[256];
1562
1563 for (gi = 0 ; gi < gfunc->mcnt ; gi++)
1564 {
1565 EnvPrintRouter(theEnv,logicalName,EnvGetDefgenericName(theEnv,(void *) gfunc));
1566 EnvPrintRouter(theEnv,logicalName," #");
1567 PrintMethod(theEnv,buf,255,&gfunc->methods[gi]);
1568 EnvPrintRouter(theEnv,logicalName,buf);
1569 EnvPrintRouter(theEnv,logicalName,"\n");
1570 }
1571 return((long) gfunc->mcnt);
1572 }
1573
1574 /******************************************************************
1575 NAME : DefgenericWatchAccess
1576 DESCRIPTION : Parses a list of generic names passed by
1577 AddWatchItem() and sets the traces accordingly
1578 INPUTS : 1) A code indicating which trace flag is to be set
1579 Ignored
1580 2) The value to which to set the trace flags
1581 3) A list of expressions containing the names
1582 of the generics for which to set traces
1583 RETURNS : TRUE if all OK, FALSE otherwise
1584 SIDE EFFECTS : Watch flags set in specified generics
1585 NOTES : Accessory function for AddWatchItem()
1586 ******************************************************************/
DefgenericWatchAccess(void * theEnv,int code,unsigned newState,EXPRESSION * argExprs)1587 static unsigned DefgenericWatchAccess(
1588 void *theEnv,
1589 int code,
1590 unsigned newState,
1591 EXPRESSION *argExprs)
1592 {
1593 #if MAC_XCD
1594 #pragma unused(code)
1595 #endif
1596
1597 return(ConstructSetWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,newState,argExprs,
1598 EnvGetDefgenericWatch,EnvSetDefgenericWatch));
1599 }
1600
1601 /***********************************************************************
1602 NAME : DefgenericWatchPrint
1603 DESCRIPTION : Parses a list of generic names passed by
1604 AddWatchItem() and displays the traces accordingly
1605 INPUTS : 1) The logical name of the output
1606 2) A code indicating which trace flag is to be examined
1607 Ignored
1608 3) A list of expressions containing the names
1609 of the generics for which to examine traces
1610 RETURNS : TRUE if all OK, FALSE otherwise
1611 SIDE EFFECTS : Watch flags displayed for specified generics
1612 NOTES : Accessory function for AddWatchItem()
1613 ***********************************************************************/
DefgenericWatchPrint(void * theEnv,const char * logName,int code,EXPRESSION * argExprs)1614 static unsigned DefgenericWatchPrint(
1615 void *theEnv,
1616 const char *logName,
1617 int code,
1618 EXPRESSION *argExprs)
1619 {
1620 #if MAC_XCD
1621 #pragma unused(code)
1622 #endif
1623
1624 return(ConstructPrintWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,logName,argExprs,
1625 EnvGetDefgenericWatch,EnvSetDefgenericWatch));
1626 }
1627
1628 /******************************************************************
1629 NAME : DefmethodWatchAccess
1630 DESCRIPTION : Parses a list of methods passed by
1631 AddWatchItem() and sets the traces accordingly
1632 INPUTS : 1) A code indicating which trace flag is to be set
1633 Ignored
1634 2) The value to which to set the trace flags
1635 3) A list of expressions containing the methods
1636 for which to set traces
1637 RETURNS : TRUE if all OK, FALSE otherwise
1638 SIDE EFFECTS : Watch flags set in specified methods
1639 NOTES : Accessory function for AddWatchItem()
1640 ******************************************************************/
DefmethodWatchAccess(void * theEnv,int code,unsigned newState,EXPRESSION * argExprs)1641 static unsigned DefmethodWatchAccess(
1642 void *theEnv,
1643 int code,
1644 unsigned newState,
1645 EXPRESSION *argExprs)
1646 {
1647 #if MAC_XCD
1648 #pragma unused(code)
1649 #endif
1650 if (newState)
1651 return(DefmethodWatchSupport(theEnv,"watch",NULL,newState,NULL,EnvSetDefmethodWatch,argExprs));
1652 else
1653 return(DefmethodWatchSupport(theEnv,"unwatch",NULL,newState,NULL,EnvSetDefmethodWatch,argExprs));
1654 }
1655
1656 /***********************************************************************
1657 NAME : DefmethodWatchPrint
1658 DESCRIPTION : Parses a list of methods passed by
1659 AddWatchItem() and displays the traces accordingly
1660 INPUTS : 1) The logical name of the output
1661 2) A code indicating which trace flag is to be examined
1662 Ignored
1663 3) A list of expressions containing the methods for
1664 which to examine traces
1665 RETURNS : TRUE if all OK, FALSE otherwise
1666 SIDE EFFECTS : Watch flags displayed for specified methods
1667 NOTES : Accessory function for AddWatchItem()
1668 ***********************************************************************/
DefmethodWatchPrint(void * theEnv,const char * logName,int code,EXPRESSION * argExprs)1669 static unsigned DefmethodWatchPrint(
1670 void *theEnv,
1671 const char *logName,
1672 int code,
1673 EXPRESSION *argExprs)
1674 {
1675 #if MAC_XCD
1676 #pragma unused(code)
1677 #endif
1678 return(DefmethodWatchSupport(theEnv,"list-watch-items",logName,0,
1679 PrintMethodWatchFlag,NULL,argExprs));
1680 }
1681
1682 /*******************************************************
1683 NAME : DefmethodWatchSupport
1684 DESCRIPTION : Sets or displays methods specified
1685 INPUTS : 1) The calling function name
1686 2) The logical output name for displays
1687 (can be NULL)
1688 3) The new set state
1689 4) The print function (can be NULL)
1690 5) The trace function (can be NULL)
1691 6) The methods expression list
1692 RETURNS : TRUE if all OK,
1693 FALSE otherwise
1694 SIDE EFFECTS : Method trace flags set or displayed
1695 NOTES : None
1696 *******************************************************/
DefmethodWatchSupport(void * theEnv,const char * funcName,const char * logName,unsigned newState,void (* printFunc)(void *,const char *,void *,long),void (* traceFunc)(void *,unsigned,void *,long),EXPRESSION * argExprs)1697 static unsigned DefmethodWatchSupport(
1698 void *theEnv,
1699 const char *funcName,
1700 const char *logName,
1701 unsigned newState,
1702 void (*printFunc)(void *,const char *,void *,long),
1703 void (*traceFunc)(void *,unsigned,void *,long),
1704 EXPRESSION *argExprs)
1705 {
1706 void *theGeneric;
1707 unsigned long theMethod = 0;
1708 int argIndex = 2;
1709 DATA_OBJECT genericName,methodIndex;
1710 struct defmodule *theModule;
1711
1712 /* ==============================
1713 If no methods are specified,
1714 show the trace for all methods
1715 in all generics
1716 ============================== */
1717 if (argExprs == NULL)
1718 {
1719 SaveCurrentModule(theEnv);
1720 theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
1721 while (theModule != NULL)
1722 {
1723 EnvSetCurrentModule(theEnv,(void *) theModule);
1724 if (traceFunc == NULL)
1725 {
1726 EnvPrintRouter(theEnv,logName,EnvGetDefmoduleName(theEnv,(void *) theModule));
1727 EnvPrintRouter(theEnv,logName,":\n");
1728 }
1729 theGeneric = EnvGetNextDefgeneric(theEnv,NULL);
1730 while (theGeneric != NULL)
1731 {
1732 theMethod = EnvGetNextDefmethod(theEnv,theGeneric,0);
1733 while (theMethod != 0)
1734 {
1735 if (traceFunc != NULL)
1736 (*traceFunc)(theEnv,newState,theGeneric,theMethod);
1737 else
1738 {
1739 EnvPrintRouter(theEnv,logName," ");
1740 (*printFunc)(theEnv,logName,theGeneric,theMethod);
1741 }
1742 theMethod = EnvGetNextDefmethod(theEnv,theGeneric,theMethod);
1743 }
1744 theGeneric = EnvGetNextDefgeneric(theEnv,theGeneric);
1745 }
1746 theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,(void *) theModule);
1747 }
1748 RestoreCurrentModule(theEnv);
1749 return(TRUE);
1750 }
1751
1752 /* =========================================
1753 Set the traces for every method specified
1754 ========================================= */
1755 while (argExprs != NULL)
1756 {
1757 if (EvaluateExpression(theEnv,argExprs,&genericName))
1758 return(FALSE);
1759 if ((genericName.type != SYMBOL) ? TRUE :
1760 ((theGeneric = (void *)
1761 LookupDefgenericByMdlOrScope(theEnv,DOToString(genericName))) == NULL))
1762 {
1763 ExpectedTypeError1(theEnv,funcName,argIndex,"generic function name");
1764 return(FALSE);
1765 }
1766 if (GetNextArgument(argExprs) == NULL)
1767 theMethod = 0;
1768 else
1769 {
1770 argExprs = GetNextArgument(argExprs);
1771 argIndex++;
1772 if (EvaluateExpression(theEnv,argExprs,&methodIndex))
1773 return(FALSE);
1774 if ((methodIndex.type != INTEGER) ? FALSE :
1775 ((DOToLong(methodIndex) <= 0) ? FALSE :
1776 (FindMethodByIndex((DEFGENERIC *) theGeneric,theMethod) != -1)))
1777 theMethod = (long) DOToLong(methodIndex);
1778 else
1779 {
1780 ExpectedTypeError1(theEnv,funcName,argIndex,"method index");
1781 return(FALSE);
1782 }
1783 }
1784 if (theMethod == 0)
1785 {
1786 theMethod = EnvGetNextDefmethod(theEnv,theGeneric,0);
1787 while (theMethod != 0)
1788 {
1789 if (traceFunc != NULL)
1790 (*traceFunc)(theEnv,newState,theGeneric,theMethod);
1791 else
1792 (*printFunc)(theEnv,logName,theGeneric,theMethod);
1793 theMethod = EnvGetNextDefmethod(theEnv,theGeneric,theMethod);
1794 }
1795 }
1796 else
1797 {
1798 if (traceFunc != NULL)
1799 (*traceFunc)(theEnv,newState,theGeneric,theMethod);
1800 else
1801 (*printFunc)(theEnv,logName,theGeneric,theMethod);
1802 }
1803 argExprs = GetNextArgument(argExprs);
1804 argIndex++;
1805 }
1806 return(TRUE);
1807 }
1808
1809 /***************************************************
1810 NAME : PrintMethodWatchFlag
1811 DESCRIPTION : Displays trace value for method
1812 INPUTS : 1) The logical name of the output
1813 2) The generic function
1814 3) The method index
1815 RETURNS : Nothing useful
1816 SIDE EFFECTS : None
1817 NOTES : None
1818 ***************************************************/
PrintMethodWatchFlag(void * theEnv,const char * logName,void * theGeneric,long theMethod)1819 static void PrintMethodWatchFlag(
1820 void *theEnv,
1821 const char *logName,
1822 void *theGeneric,
1823 long theMethod)
1824 {
1825 char buf[60];
1826
1827 EnvPrintRouter(theEnv,logName,EnvGetDefgenericName(theEnv,theGeneric));
1828 EnvPrintRouter(theEnv,logName," ");
1829 EnvGetDefmethodDescription(theEnv,buf,59,theGeneric,theMethod);
1830 EnvPrintRouter(theEnv,logName,buf);
1831 if (EnvGetDefmethodWatch(theEnv,theGeneric,theMethod))
1832 EnvPrintRouter(theEnv,logName," = on\n");
1833 else
1834 EnvPrintRouter(theEnv,logName," = off\n");
1835 }
1836
1837 #endif
1838
1839 #if ! OBJECT_SYSTEM
1840
1841 /***************************************************
1842 NAME : TypeCommand
1843 DESCRIPTION : Works like "class" in COOL
1844 INPUTS : None
1845 RETURNS : Nothing useful
1846 SIDE EFFECTS : None
1847 NOTES : H/L Syntax: (type <primitive>)
1848 ***************************************************/
TypeCommand(void * theEnv,DATA_OBJECT * result)1849 globle void TypeCommand(
1850 void *theEnv,
1851 DATA_OBJECT *result)
1852 {
1853 EvaluateExpression(theEnv,GetFirstArgument(),result);
1854 result->value = (void *) EnvAddSymbol(theEnv,TypeName(theEnv,result->type));
1855 result->type = SYMBOL;
1856 }
1857
1858 #endif
1859
1860 /*#############################*/
1861 /* Additional Access Functions */
1862 /*#############################*/
1863
GetDefgenericNamePointer(void * theDefgeneric)1864 globle SYMBOL_HN *GetDefgenericNamePointer(
1865 void *theDefgeneric)
1866 {
1867 return GetConstructNamePointer((struct constructHeader *) theDefgeneric);
1868 }
1869
SetNextDefgeneric(void * theDefgeneric,void * targetDefgeneric)1870 globle void SetNextDefgeneric(
1871 void *theDefgeneric,
1872 void *targetDefgeneric)
1873 {
1874 SetNextConstruct((struct constructHeader *) theDefgeneric,
1875 (struct constructHeader *) targetDefgeneric);
1876 }
1877
1878 /*##################################*/
1879 /* Additional Environment Functions */
1880 /*##################################*/
1881
EnvDefgenericModule(void * theEnv,void * theDefgeneric)1882 globle const char *EnvDefgenericModule(
1883 void *theEnv,
1884 void *theDefgeneric)
1885 {
1886 return GetConstructModuleName((struct constructHeader *) theDefgeneric);
1887 }
1888
EnvGetDefgenericName(void * theEnv,void * theDefgeneric)1889 globle const char *EnvGetDefgenericName(
1890 void *theEnv,
1891 void *theDefgeneric)
1892 {
1893 return GetConstructNameString((struct constructHeader *) theDefgeneric);
1894 }
1895
EnvGetDefgenericPPForm(void * theEnv,void * theDefgeneric)1896 globle const char *EnvGetDefgenericPPForm(
1897 void *theEnv,
1898 void *theDefgeneric)
1899 {
1900 return GetConstructPPForm(theEnv,(struct constructHeader *) theDefgeneric);
1901 }
1902
EnvGetDefgenericNamePointer(void * theEnv,void * theDefgeneric)1903 globle SYMBOL_HN *EnvGetDefgenericNamePointer(
1904 void *theEnv,
1905 void *theDefgeneric)
1906 {
1907 return GetConstructNamePointer((struct constructHeader *) theDefgeneric);
1908 }
1909
EnvSetDefgenericPPForm(void * theEnv,void * theDefgeneric,const char * thePPForm)1910 globle void EnvSetDefgenericPPForm(
1911 void *theEnv,
1912 void *theDefgeneric,
1913 const char *thePPForm)
1914 {
1915 SetConstructPPForm(theEnv,(struct constructHeader *) theDefgeneric,thePPForm);
1916 }
1917
1918 /*#####################################*/
1919 /* ALLOW_ENVIRONMENT_GLOBALS Functions */
1920 /*#####################################*/
1921
1922 #if ALLOW_ENVIRONMENT_GLOBALS
1923
SetDefgenericPPForm(void * theDefgeneric,const char * thePPForm)1924 globle void SetDefgenericPPForm(
1925 void *theDefgeneric,
1926 const char *thePPForm)
1927 {
1928 EnvSetDefgenericPPForm(GetCurrentEnvironment(),theDefgeneric,thePPForm);
1929 }
1930
DefgenericModule(void * theDefgeneric)1931 globle const char *DefgenericModule(
1932 void *theDefgeneric)
1933 {
1934 return EnvDefgenericModule(GetCurrentEnvironment(),theDefgeneric);
1935 }
1936
FindDefgeneric(const char * genericModuleAndName)1937 globle void *FindDefgeneric(
1938 const char *genericModuleAndName)
1939 {
1940 return EnvFindDefgeneric(GetCurrentEnvironment(),genericModuleAndName);
1941 }
1942
GetDefgenericList(DATA_OBJECT * returnValue,struct defmodule * theModule)1943 globle void GetDefgenericList(
1944 DATA_OBJECT *returnValue,
1945 struct defmodule *theModule)
1946 {
1947 EnvGetDefgenericList(GetCurrentEnvironment(),returnValue,theModule);
1948 }
1949
GetDefgenericName(void * theDefgeneric)1950 globle const char *GetDefgenericName(
1951 void *theDefgeneric)
1952 {
1953 return EnvGetDefgenericName(GetCurrentEnvironment(),theDefgeneric);
1954 }
1955
GetDefgenericPPForm(void * theDefgeneric)1956 globle const char *GetDefgenericPPForm(
1957 void *theDefgeneric)
1958 {
1959 return EnvGetDefgenericPPForm(GetCurrentEnvironment(),theDefgeneric);
1960 }
1961
GetNextDefgeneric(void * ptr)1962 globle void *GetNextDefgeneric(
1963 void *ptr)
1964 {
1965 return EnvGetNextDefgeneric(GetCurrentEnvironment(),ptr);
1966 }
1967
IsDefgenericDeletable(void * ptr)1968 globle int IsDefgenericDeletable(
1969 void *ptr)
1970 {
1971 return EnvIsDefgenericDeletable(GetCurrentEnvironment(),ptr);
1972 }
1973
Undefgeneric(void * vptr)1974 globle intBool Undefgeneric(
1975 void *vptr)
1976 {
1977 return EnvUndefgeneric(GetCurrentEnvironment(),vptr);
1978 }
1979
GetDefmethodList(void * vgfunc,DATA_OBJECT_PTR returnValue)1980 globle void GetDefmethodList(
1981 void *vgfunc,
1982 DATA_OBJECT_PTR returnValue)
1983 {
1984 EnvGetDefmethodList(GetCurrentEnvironment(),vgfunc,returnValue);
1985 }
1986
GetMethodRestrictions(void * vgfunc,long mi,DATA_OBJECT * result)1987 globle void GetMethodRestrictions(
1988 void *vgfunc,
1989 long mi,
1990 DATA_OBJECT *result)
1991 {
1992 EnvGetMethodRestrictions(GetCurrentEnvironment(),vgfunc,mi,result);
1993 }
1994
GetNextDefmethod(void * ptr,long theIndex)1995 globle long GetNextDefmethod(
1996 void *ptr,
1997 long theIndex)
1998 {
1999 return EnvGetNextDefmethod(GetCurrentEnvironment(),ptr,theIndex);
2000 }
2001
IsDefmethodDeletable(void * ptr,long theIndex)2002 globle int IsDefmethodDeletable(
2003 void *ptr,
2004 long theIndex)
2005 {
2006 return EnvIsDefmethodDeletable(GetCurrentEnvironment(),ptr,theIndex);
2007 }
2008
Undefmethod(void * vptr,long mi)2009 globle intBool Undefmethod(
2010 void *vptr,
2011 long mi)
2012 {
2013 return EnvUndefmethod(GetCurrentEnvironment(),vptr,mi);
2014 }
2015
2016 #if DEBUGGING_FUNCTIONS
2017
GetDefgenericWatch(void * theGeneric)2018 globle unsigned GetDefgenericWatch(
2019 void *theGeneric)
2020 {
2021 return EnvGetDefgenericWatch(GetCurrentEnvironment(),theGeneric);
2022 }
2023
ListDefgenerics(const char * logicalName,struct defmodule * theModule)2024 globle void ListDefgenerics(
2025 const char *logicalName,
2026 struct defmodule *theModule)
2027 {
2028 EnvListDefgenerics(GetCurrentEnvironment(),logicalName,theModule);
2029 }
2030
SetDefgenericWatch(unsigned newState,void * theGeneric)2031 globle void SetDefgenericWatch(
2032 unsigned newState,
2033 void *theGeneric)
2034 {
2035 EnvSetDefgenericWatch(GetCurrentEnvironment(),newState,theGeneric);
2036 }
2037
GetDefmethodPPForm(void * ptr,long theIndex)2038 globle const char *GetDefmethodPPForm(
2039 void *ptr,
2040 long theIndex)
2041 {
2042 return EnvGetDefmethodPPForm(GetCurrentEnvironment(),ptr,theIndex);
2043 }
2044
GetDefmethodWatch(void * theGeneric,long theIndex)2045 globle unsigned GetDefmethodWatch(
2046 void *theGeneric,
2047 long theIndex)
2048 {
2049 return EnvGetDefmethodWatch(GetCurrentEnvironment(),theGeneric,theIndex);
2050 }
2051
ListDefmethods(const char * logicalName,void * vptr)2052 globle void ListDefmethods(
2053 const char *logicalName,
2054 void *vptr)
2055 {
2056 EnvListDefmethods(GetCurrentEnvironment(),logicalName,vptr);
2057 }
2058
SetDefmethodWatch(unsigned newState,void * theGeneric,long theIndex)2059 globle void SetDefmethodWatch(
2060 unsigned newState,
2061 void *theGeneric,
2062 long theIndex)
2063 {
2064 EnvSetDefmethodWatch(GetCurrentEnvironment(),newState,theGeneric,theIndex);
2065 }
2066
2067 #endif /* DEBUGGING_FUNCTIONS */
2068
2069 #if DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS
2070
GetDefmethodDescription(char * buf,int buflen,void * ptr,long theIndex)2071 globle void GetDefmethodDescription(
2072 char *buf,
2073 int buflen,
2074 void *ptr,
2075 long theIndex)
2076 {
2077 EnvGetDefmethodDescription(GetCurrentEnvironment(),buf,buflen,ptr,theIndex);
2078 }
2079
2080 #endif /* DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS */
2081
2082 #endif /* ALLOW_ENVIRONMENT_GLOBALS */
2083
2084 #endif /* DEFGENERIC_CONSTRUCT */
2085
2086