1 /*******************************************************/
2 /* "C" Language Integrated Production System */
3 /* */
4 /* CLIPS Version 6.30 01/25/15 */
5 /* */
6 /* */
7 /*******************************************************/
8
9 /*************************************************************/
10 /* Purpose: Generic Functions Parsing Routines */
11 /* */
12 /* Principal Programmer(s): */
13 /* Brian L. Dantes */
14 /* */
15 /* Contributing Programmer(s): */
16 /* */
17 /* Revision History: */
18 /* */
19 /* 6.24: Renamed BOOLEAN macro type to intBool. */
20 /* */
21 /* If the last construct in a loaded file is a */
22 /* deffunction or defmethod with no closing right */
23 /* parenthesis, an error should be issued, but is */
24 /* not. DR0872 */
25 /* */
26 /* 6.30: Changed integer type/precision. */
27 /* */
28 /* GetConstructNameAndComment API change. */
29 /* */
30 /* Support for long long integers. */
31 /* */
32 /* Used gensprintf instead of sprintf. */
33 /* */
34 /* Added const qualifiers to remove C++ */
35 /* deprecation warnings. */
36 /* */
37 /* Converted API macros to function calls. */
38 /* */
39 /* Fixed linkage issue when BLOAD_AND_SAVE */
40 /* compiler flag is set to 0. */
41 /* */
42 /* Fixed typing issue when OBJECT_SYSTEM */
43 /* compiler flag is set to 0. */
44 /* */
45 /* Changed find construct functionality so that */
46 /* imported modules are search when locating a */
47 /* named construct. */
48 /* */
49 /*************************************************************/
50
51 /* =========================================
52 *****************************************
53 EXTERNAL DEFINITIONS
54 =========================================
55 ***************************************** */
56 #include "setup.h"
57
58 #if DEFGENERIC_CONSTRUCT && (! BLOAD_ONLY) && (! RUN_TIME)
59
60 #if BLOAD || BLOAD_AND_BSAVE
61 #include "bload.h"
62 #endif
63
64 #if DEFFUNCTION_CONSTRUCT
65 #include "dffnxfun.h"
66 #endif
67
68 #if OBJECT_SYSTEM
69 #include "classfun.h"
70 #include "classcom.h"
71 #endif
72
73 #include "memalloc.h"
74 #include "cstrcpsr.h"
75 #include "envrnmnt.h"
76 #include "exprnpsr.h"
77 #include "genrccom.h"
78 #include "immthpsr.h"
79 #include "modulutl.h"
80 #include "prcdrpsr.h"
81 #include "prccode.h"
82 #include "router.h"
83 #include "scanner.h"
84 #include "sysdep.h"
85
86 #define _GENRCPSR_SOURCE_
87 #include "genrcpsr.h"
88
89 /* =========================================
90 *****************************************
91 CONSTANTS
92 =========================================
93 ***************************************** */
94 #define HIGHER_PRECEDENCE -1
95 #define IDENTICAL 0
96 #define LOWER_PRECEDENCE 1
97
98 #define CURR_ARG_VAR "current-argument"
99
100 /* =========================================
101 *****************************************
102 INTERNALLY VISIBLE FUNCTION HEADERS
103 =========================================
104 ***************************************** */
105
106 static intBool ValidGenericName(void *,const char *);
107 static SYMBOL_HN *ParseMethodNameAndIndex(void *,const char *,int *);
108
109 #if DEBUGGING_FUNCTIONS
110 static void CreateDefaultGenericPPForm(void *,DEFGENERIC *);
111 #endif
112
113 static int ParseMethodParameters(void *,const char *,EXPRESSION **,SYMBOL_HN **);
114 static RESTRICTION *ParseRestriction(void *,const char *);
115 static void ReplaceCurrentArgRefs(void *,EXPRESSION *);
116 static int DuplicateParameters(void *,EXPRESSION *,EXPRESSION **,SYMBOL_HN *);
117 static EXPRESSION *AddParameter(void *,EXPRESSION *,EXPRESSION *,SYMBOL_HN *,RESTRICTION *);
118 static EXPRESSION *ValidType(void *,SYMBOL_HN *);
119 static intBool RedundantClasses(void *,void *,void *);
120 static DEFGENERIC *AddGeneric(void *,SYMBOL_HN *,int *);
121 static DEFMETHOD *AddGenericMethod(void *,DEFGENERIC *,int,short);
122 static int RestrictionsCompare(EXPRESSION *,int,int,int,DEFMETHOD *);
123 static int TypeListCompare(RESTRICTION *,RESTRICTION *);
124 static DEFGENERIC *NewGeneric(void *,SYMBOL_HN *);
125
126 /* =========================================
127 *****************************************
128 EXTERNALLY VISIBLE FUNCTIONS
129 =========================================
130 ***************************************** */
131
132 /***************************************************************************
133 NAME : ParseDefgeneric
134 DESCRIPTION : Parses the defgeneric construct
135 INPUTS : The input logical name
136 RETURNS : FALSE if successful parse, TRUE otherwise
137 SIDE EFFECTS : Inserts valid generic function defn into generic entry
138 NOTES : H/L Syntax :
139 (defgeneric <name> [<comment>])
140 ***************************************************************************/
ParseDefgeneric(void * theEnv,const char * readSource)141 globle intBool ParseDefgeneric(
142 void *theEnv,
143 const char *readSource)
144 {
145 SYMBOL_HN *gname;
146 DEFGENERIC *gfunc;
147 int newGeneric;
148
149 SetPPBufferStatus(theEnv,ON);
150 FlushPPBuffer(theEnv);
151 SavePPBuffer(theEnv,"(defgeneric ");
152 SetIndentDepth(theEnv,3);
153
154 #if BLOAD || BLOAD_AND_BSAVE
155 if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
156 {
157 CannotLoadWithBloadMessage(theEnv,"defgeneric");
158 return(TRUE);
159 }
160 #endif
161
162 gname = GetConstructNameAndComment(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken,"defgeneric",
163 EnvFindDefgenericInModule,NULL,"^",TRUE,
164 TRUE,TRUE,FALSE);
165 if (gname == NULL)
166 return(TRUE);
167
168 if (ValidGenericName(theEnv,ValueToString(gname)) == FALSE)
169 return(TRUE);
170
171 if (DefgenericData(theEnv)->GenericInputToken.type != RPAREN)
172 {
173 PrintErrorID(theEnv,"GENRCPSR",1,FALSE);
174 EnvPrintRouter(theEnv,WERROR,"Expected ')' to complete defgeneric.\n");
175 return(TRUE);
176 }
177 SavePPBuffer(theEnv,"\n");
178
179 /* ========================================================
180 If we're only checking syntax, don't add the
181 successfully parsed deffacts to the KB.
182 ======================================================== */
183
184 if (ConstructData(theEnv)->CheckSyntaxMode)
185 { return(FALSE); }
186
187 gfunc = AddGeneric(theEnv,gname,&newGeneric);
188
189 #if DEBUGGING_FUNCTIONS
190 EnvSetDefgenericPPForm(theEnv,(void *) gfunc,EnvGetConserveMemory(theEnv) ? NULL : CopyPPBuffer(theEnv));
191 #endif
192 return(FALSE);
193 }
194
195 /***************************************************************************
196 NAME : ParseDefmethod
197 DESCRIPTION : Parses the defmethod construct
198 INPUTS : The input logical name
199 RETURNS : FALSE if successful parse, TRUE otherwise
200 SIDE EFFECTS : Inserts valid method definition into generic entry
201 NOTES : H/L Syntax :
202 (defmethod <name> [<index>] [<comment>]
203 (<restriction>* [<wildcard>])
204 <action>*)
205 <restriction> :== ?<name> |
206 (?<name> <type>* [<restriction-query>])
207 <wildcard> :== $?<name> |
208 ($?<name> <type>* [<restriction-query>])
209 ***************************************************************************/
ParseDefmethod(void * theEnv,const char * readSource)210 globle intBool ParseDefmethod(
211 void *theEnv,
212 const char *readSource)
213 {
214 SYMBOL_HN *gname;
215 int rcnt,mposn,mi,newMethod,mnew = FALSE,lvars,error;
216 EXPRESSION *params,*actions,*tmp;
217 SYMBOL_HN *wildcard;
218 DEFMETHOD *meth;
219 DEFGENERIC *gfunc;
220 int theIndex;
221
222 SetPPBufferStatus(theEnv,ON);
223 FlushPPBuffer(theEnv);
224 SetIndentDepth(theEnv,3);
225 SavePPBuffer(theEnv,"(defmethod ");
226
227 #if BLOAD || BLOAD_AND_BSAVE
228 if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
229 {
230 CannotLoadWithBloadMessage(theEnv,"defmethod");
231 return(TRUE);
232 }
233 #endif
234
235 gname = ParseMethodNameAndIndex(theEnv,readSource,&theIndex);
236 if (gname == NULL)
237 return(TRUE);
238
239 if (ValidGenericName(theEnv,ValueToString(gname)) == FALSE)
240 return(TRUE);
241
242 /* ========================================================
243 Go ahead and add the header so that the generic function
244 can be called recursively
245 ======================================================== */
246 gfunc = AddGeneric(theEnv,gname,&newMethod);
247
248 #if DEBUGGING_FUNCTIONS
249 if (newMethod && (! ConstructData(theEnv)->CheckSyntaxMode))
250 CreateDefaultGenericPPForm(theEnv,gfunc);
251 #endif
252
253 IncrementIndentDepth(theEnv,1);
254 rcnt = ParseMethodParameters(theEnv,readSource,¶ms,&wildcard);
255 DecrementIndentDepth(theEnv,1);
256 if (rcnt == -1)
257 goto DefmethodParseError;
258 PPCRAndIndent(theEnv);
259 for (tmp = params ; tmp != NULL ; tmp = tmp->nextArg)
260 {
261 ReplaceCurrentArgRefs(theEnv,((RESTRICTION *) tmp->argList)->query);
262 if (ReplaceProcVars(theEnv,"method",((RESTRICTION *) tmp->argList)->query,
263 params,wildcard,NULL,NULL))
264 {
265 DeleteTempRestricts(theEnv,params);
266 goto DefmethodParseError;
267 }
268 }
269 meth = FindMethodByRestrictions(gfunc,params,rcnt,wildcard,&mposn);
270 error = FALSE;
271 if (meth != NULL)
272 {
273 if (meth->system)
274 {
275 PrintErrorID(theEnv,"GENRCPSR",17,FALSE);
276 EnvPrintRouter(theEnv,WERROR,"Cannot replace the implicit system method #");
277 PrintLongInteger(theEnv,WERROR,(long long) meth->index);
278 EnvPrintRouter(theEnv,WERROR,".\n");
279 error = TRUE;
280 }
281 else if ((theIndex != 0) && (theIndex != meth->index))
282 {
283 PrintErrorID(theEnv,"GENRCPSR",2,FALSE);
284 EnvPrintRouter(theEnv,WERROR,"New method #");
285 PrintLongInteger(theEnv,WERROR,(long long) theIndex);
286 EnvPrintRouter(theEnv,WERROR," would be indistinguishable from method #");
287 PrintLongInteger(theEnv,WERROR,(long long) meth->index);
288 EnvPrintRouter(theEnv,WERROR,".\n");
289 error = TRUE;
290 }
291 }
292 else if (theIndex != 0)
293 {
294 mi = FindMethodByIndex(gfunc,theIndex);
295 if (mi == -1)
296 mnew = TRUE;
297 else if (gfunc->methods[mi].system)
298 {
299 PrintErrorID(theEnv,"GENRCPSR",17,FALSE);
300 EnvPrintRouter(theEnv,WERROR,"Cannot replace the implicit system method #");
301 PrintLongInteger(theEnv,WERROR,(long long) theIndex);
302 EnvPrintRouter(theEnv,WERROR,".\n");
303 error = TRUE;
304 }
305 }
306 else
307 mnew = TRUE;
308 if (error)
309 {
310 DeleteTempRestricts(theEnv,params);
311 goto DefmethodParseError;
312 }
313 ExpressionData(theEnv)->ReturnContext = TRUE;
314 actions = ParseProcActions(theEnv,"method",readSource,
315 &DefgenericData(theEnv)->GenericInputToken,params,wildcard,
316 NULL,NULL,&lvars,NULL);
317
318 /*===========================================================*/
319 /* Check for the closing right parenthesis of the defmethod. */
320 /*===========================================================*/
321
322 if ((DefgenericData(theEnv)->GenericInputToken.type != RPAREN) && /* DR0872 */
323 (actions != NULL))
324 {
325 SyntaxErrorMessage(theEnv,"defmethod");
326 DeleteTempRestricts(theEnv,params);
327 ReturnPackedExpression(theEnv,actions);
328 goto DefmethodParseError;
329 }
330
331 if (actions == NULL)
332 {
333 DeleteTempRestricts(theEnv,params);
334 goto DefmethodParseError;
335 }
336
337 /*==============================================*/
338 /* If we're only checking syntax, don't add the */
339 /* successfully parsed deffunction to the KB. */
340 /*==============================================*/
341
342 if (ConstructData(theEnv)->CheckSyntaxMode)
343 {
344 DeleteTempRestricts(theEnv,params);
345 ReturnPackedExpression(theEnv,actions);
346 if (newMethod)
347 {
348 RemoveConstructFromModule(theEnv,(struct constructHeader *) gfunc);
349 RemoveDefgeneric(theEnv,(struct constructHeader *) gfunc);
350 }
351 return(FALSE);
352 }
353
354 PPBackup(theEnv);
355 PPBackup(theEnv);
356 SavePPBuffer(theEnv,DefgenericData(theEnv)->GenericInputToken.printForm);
357 SavePPBuffer(theEnv,"\n");
358
359 #if DEBUGGING_FUNCTIONS
360 meth = AddMethod(theEnv,gfunc,meth,mposn,(short) theIndex,params,rcnt,lvars,wildcard,actions,
361 EnvGetConserveMemory(theEnv) ? NULL : CopyPPBuffer(theEnv),FALSE);
362 #else
363 meth = AddMethod(theEnv,gfunc,meth,mposn,theIndex,params,rcnt,lvars,wildcard,actions,NULL,FALSE);
364 #endif
365 DeleteTempRestricts(theEnv,params);
366 if (GetPrintWhileLoading(theEnv) && GetCompilationsWatch(theEnv) &&
367 (! ConstructData(theEnv)->CheckSyntaxMode))
368 {
369 const char *outRouter = WDIALOG;
370
371 if (mnew)
372 {
373 EnvPrintRouter(theEnv,outRouter," Method #");
374 PrintLongInteger(theEnv,outRouter,(long long) meth->index);
375 EnvPrintRouter(theEnv,outRouter," defined.\n");
376 }
377 else
378 {
379 outRouter = WWARNING;
380 PrintWarningID(theEnv,"CSTRCPSR",1,TRUE);
381 EnvPrintRouter(theEnv,outRouter,"Method #");
382 PrintLongInteger(theEnv,outRouter,(long long) meth->index);
383 EnvPrintRouter(theEnv,outRouter," redefined.\n");
384 }
385 }
386 return(FALSE);
387
388 DefmethodParseError:
389 if (newMethod)
390 {
391 RemoveConstructFromModule(theEnv,(struct constructHeader *) gfunc);
392 RemoveDefgeneric(theEnv,(void *) gfunc);
393 }
394 return(TRUE);
395 }
396
397 /************************************************************************
398 NAME : AddMethod
399 DESCRIPTION : (Re)defines a new method for a generic
400 If method already exists, deletes old information
401 before proceeding.
402 INPUTS : 1) The generic address
403 2) The old method address (can be NULL)
404 3) The old method array position (can be -1)
405 4) The method index to assign (0 if don't care)
406 5) The parameter expression-list
407 (restrictions attached to argList pointers)
408 6) The number of restrictions
409 7) The number of locals vars reqd
410 8) The wildcard symbol (NULL if none)
411 9) Method actions
412 10) Method pretty-print form
413 11) A flag indicating whether to copy the
414 restriction types or just use the pointers
415 RETURNS : The new (old) method address
416 SIDE EFFECTS : Method added to (or changed in) method array for generic
417 Restrictions repacked into new method
418 Actions and pretty-print form attached
419 NOTES : Assumes if a method is being redefined, its busy
420 count is 0!!
421 IMPORTANT: Expects that FindMethodByRestrictions() has
422 previously been called to determine if this method
423 is already present or not. Arguments #1 and #2
424 should be the values obtained from FindMethod...().
425 ************************************************************************/
AddMethod(void * theEnv,DEFGENERIC * gfunc,DEFMETHOD * meth,int mposn,short mi,EXPRESSION * params,int rcnt,int lvars,SYMBOL_HN * wildcard,EXPRESSION * actions,char * ppForm,int copyRestricts)426 globle DEFMETHOD *AddMethod(
427 void *theEnv,
428 DEFGENERIC *gfunc,
429 DEFMETHOD *meth,
430 int mposn,
431 short mi,
432 EXPRESSION *params,
433 int rcnt,
434 int lvars,
435 SYMBOL_HN *wildcard,
436 EXPRESSION *actions,
437 char *ppForm,
438 int copyRestricts)
439 {
440 RESTRICTION *rptr,*rtmp;
441 register int i,j;
442 int mai;
443
444 SaveBusyCount(gfunc);
445 if (meth == NULL)
446 {
447 mai = (mi != 0) ? FindMethodByIndex(gfunc,mi) : -1;
448 if (mai == -1)
449 meth = AddGenericMethod(theEnv,gfunc,mposn,mi);
450 else
451 {
452 DeleteMethodInfo(theEnv,gfunc,&gfunc->methods[mai]);
453 if (mai < mposn)
454 {
455 mposn--;
456 for (i = mai+1 ; i <= mposn ; i++)
457 GenCopyMemory(DEFMETHOD,1,&gfunc->methods[i-1],&gfunc->methods[i]);
458 }
459 else
460 {
461 for (i = mai-1 ; i >= mposn ; i--)
462 GenCopyMemory(DEFMETHOD,1,&gfunc->methods[i+1],&gfunc->methods[i]);
463 }
464 meth = &gfunc->methods[mposn];
465 meth->index = mi;
466 }
467 }
468 else
469 {
470 /* ================================
471 The old trace state is preserved
472 ================================ */
473 ExpressionDeinstall(theEnv,meth->actions);
474 ReturnPackedExpression(theEnv,meth->actions);
475 if (meth->ppForm != NULL)
476 rm(theEnv,(void *) meth->ppForm,(sizeof(char) * (strlen(meth->ppForm)+1)));
477 }
478 meth->system = 0;
479 meth->actions = actions;
480 ExpressionInstall(theEnv,meth->actions);
481 meth->ppForm = ppForm;
482 if (mposn == -1)
483 {
484 RestoreBusyCount(gfunc);
485 return(meth);
486 }
487
488 meth->localVarCount = (short) lvars;
489 meth->restrictionCount = (short) rcnt;
490 if (wildcard != NULL)
491 {
492 meth->minRestrictions = (short) (rcnt-1);
493 meth->maxRestrictions = -1;
494 }
495 else
496 meth->minRestrictions = meth->maxRestrictions = (short) rcnt;
497 if (rcnt != 0)
498 meth->restrictions = (RESTRICTION *)
499 gm2(theEnv,(sizeof(RESTRICTION) * rcnt));
500 else
501 meth->restrictions = NULL;
502 for (i = 0 ; i < rcnt ; i++)
503 {
504 rptr = &meth->restrictions[i];
505 rtmp = (RESTRICTION *) params->argList;
506 rptr->query = PackExpression(theEnv,rtmp->query);
507 rptr->tcnt = rtmp->tcnt;
508 if (copyRestricts)
509 {
510 if (rtmp->types != NULL)
511 {
512 rptr->types = (void **) gm2(theEnv,(rptr->tcnt * sizeof(void *)));
513 GenCopyMemory(void *,rptr->tcnt,rptr->types,rtmp->types);
514 }
515 else
516 rptr->types = NULL;
517 }
518 else
519 {
520 rptr->types = rtmp->types;
521
522 /* =====================================================
523 Make sure the types-array is not deallocated when the
524 temporary restriction nodes are
525 ===================================================== */
526 rtmp->tcnt = 0;
527 rtmp->types = NULL;
528 }
529 ExpressionInstall(theEnv,rptr->query);
530 for (j = 0 ; j < rptr->tcnt ; j++)
531 #if OBJECT_SYSTEM
532 IncrementDefclassBusyCount(theEnv,rptr->types[j]);
533 #else
534 IncrementIntegerCount((INTEGER_HN *) rptr->types[j]);
535 #endif
536 params = params->nextArg;
537 }
538 RestoreBusyCount(gfunc);
539 return(meth);
540 }
541
542 /*****************************************************
543 NAME : PackRestrictionTypes
544 DESCRIPTION : Takes the restriction type list
545 and packs it into a contiguous
546 array of void *.
547 INPUTS : 1) The restriction structure
548 2) The types expression list
549 RETURNS : Nothing useful
550 SIDE EFFECTS : Array allocated & expressions freed
551 NOTES : None
552 *****************************************************/
PackRestrictionTypes(void * theEnv,RESTRICTION * rptr,EXPRESSION * types)553 globle void PackRestrictionTypes(
554 void *theEnv,
555 RESTRICTION *rptr,
556 EXPRESSION *types)
557 {
558 EXPRESSION *tmp;
559 long i;
560
561 rptr->tcnt = 0;
562 for (tmp = types ; tmp != NULL ; tmp = tmp->nextArg)
563 rptr->tcnt++;
564 if (rptr->tcnt != 0)
565 rptr->types = (void **) gm2(theEnv,(sizeof(void *) * rptr->tcnt));
566 else
567 rptr->types = NULL;
568 for (i = 0 , tmp = types ; i < rptr->tcnt ; i++ , tmp = tmp->nextArg)
569 rptr->types[i] = (void *) tmp->value;
570 ReturnExpression(theEnv,types);
571 }
572
573 /***************************************************
574 NAME : DeleteTempRestricts
575 DESCRIPTION : Deallocates the method
576 temporary parameter list
577 INPUTS : The head of the list
578 RETURNS : Nothing useful
579 SIDE EFFECTS : List deallocated
580 NOTES : None
581 ***************************************************/
DeleteTempRestricts(void * theEnv,EXPRESSION * phead)582 globle void DeleteTempRestricts(
583 void *theEnv,
584 EXPRESSION *phead)
585 {
586 EXPRESSION *ptmp;
587 RESTRICTION *rtmp;
588
589 while (phead != NULL)
590 {
591 ptmp = phead;
592 phead = phead->nextArg;
593 rtmp = (RESTRICTION *) ptmp->argList;
594 rtn_struct(theEnv,expr,ptmp);
595 ReturnExpression(theEnv,rtmp->query);
596 if (rtmp->tcnt != 0)
597 rm(theEnv,(void *) rtmp->types,(sizeof(void *) * rtmp->tcnt));
598 rtn_struct(theEnv,restriction,rtmp);
599 }
600 }
601
602 /**********************************************************
603 NAME : FindMethodByRestrictions
604 DESCRIPTION : See if a method for the specified
605 generic satsifies the given restrictions
606 INPUTS : 1) Generic function
607 2) Parameter/restriction expression list
608 3) Number of restrictions
609 4) Wildcard symbol (can be NULL)
610 5) Caller's buffer for holding array posn
611 of where to add new generic method
612 (-1 if method already present)
613 RETURNS : The address of the found method, NULL if
614 not found
615 SIDE EFFECTS : Sets the caller's buffer to the index of
616 where to place the new method, -1 if
617 already present
618 NOTES : None
619 **********************************************************/
FindMethodByRestrictions(DEFGENERIC * gfunc,EXPRESSION * params,int rcnt,SYMBOL_HN * wildcard,int * posn)620 globle DEFMETHOD *FindMethodByRestrictions(
621 DEFGENERIC *gfunc,
622 EXPRESSION *params,
623 int rcnt,
624 SYMBOL_HN *wildcard,
625 int *posn)
626 {
627 register int i,cmp;
628 int min,max;
629
630 if (wildcard != NULL)
631 {
632 min = rcnt-1;
633 max = -1;
634 }
635 else
636 min = max = rcnt;
637 for (i = 0 ; i < gfunc->mcnt ; i++)
638 {
639 cmp = RestrictionsCompare(params,rcnt,min,max,&gfunc->methods[i]);
640 if (cmp == IDENTICAL)
641 {
642 *posn = -1;
643 return(&gfunc->methods[i]);
644 }
645 else if (cmp == HIGHER_PRECEDENCE)
646 {
647 *posn = i;
648 return(NULL);
649 }
650 }
651 *posn = i;
652 return(NULL);
653 }
654
655 /* =========================================
656 *****************************************
657 INTERNALLY VISIBLE FUNCTIONS
658 =========================================
659 ***************************************** */
660
661 /***********************************************************
662 NAME : ValidGenericName
663 DESCRIPTION : Determines if a particular function name
664 can be overloaded
665 INPUTS : The name
666 RETURNS : TRUE if OK, FALSE otherwise
667 SIDE EFFECTS : Error message printed
668 NOTES : GetConstructNameAndComment() (called before
669 this function) ensures that the defgeneric
670 name does not conflict with one from
671 another module
672 ***********************************************************/
ValidGenericName(void * theEnv,const char * theDefgenericName)673 static intBool ValidGenericName(
674 void *theEnv,
675 const char *theDefgenericName)
676 {
677 struct constructHeader *theDefgeneric;
678 #if DEFFUNCTION_CONSTRUCT
679 struct defmodule *theModule;
680 struct constructHeader *theDeffunction;
681 #endif
682 struct FunctionDefinition *systemFunction;
683
684 /* ============================================
685 A defgeneric cannot be named the same as a
686 construct type, e.g, defclass, defrule, etc.
687 ============================================ */
688 if (FindConstruct(theEnv,theDefgenericName) != NULL)
689 {
690 PrintErrorID(theEnv,"GENRCPSR",3,FALSE);
691 EnvPrintRouter(theEnv,WERROR,"Defgenerics are not allowed to replace constructs.\n");
692 return(FALSE);
693 }
694
695 #if DEFFUNCTION_CONSTRUCT
696 /* ========================================
697 A defgeneric cannot be named the same as
698 a defffunction (either in this module or
699 imported from another)
700 ======================================== */
701 theDeffunction =
702 (struct constructHeader *) LookupDeffunctionInScope(theEnv,theDefgenericName);
703 if (theDeffunction != NULL)
704 {
705 theModule = GetConstructModuleItem(theDeffunction)->theModule;
706 if (theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
707 {
708 PrintErrorID(theEnv,"GENRCPSR",4,FALSE);
709 EnvPrintRouter(theEnv,WERROR,"Deffunction ");
710 EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,(void *) theDeffunction));
711 EnvPrintRouter(theEnv,WERROR," imported from module ");
712 EnvPrintRouter(theEnv,WERROR,EnvGetDefmoduleName(theEnv,(void *) theModule));
713 EnvPrintRouter(theEnv,WERROR," conflicts with this defgeneric.\n");
714 return(FALSE);
715 }
716 else
717 {
718 PrintErrorID(theEnv,"GENRCPSR",5,FALSE);
719 EnvPrintRouter(theEnv,WERROR,"Defgenerics are not allowed to replace deffunctions.\n");
720 }
721 return(FALSE);
722 }
723 #endif
724
725 /* =========================================
726 See if the defgeneric already exists in
727 this module (or is imported from another)
728 ========================================= */
729 theDefgeneric = (struct constructHeader *) EnvFindDefgenericInModule(theEnv,theDefgenericName);
730 if (theDefgeneric != NULL)
731 {
732 /* ===========================================
733 And the redefinition of a defgeneric in
734 the current module is only valid if none
735 of its methods are executing
736 =========================================== */
737 if (MethodsExecuting((DEFGENERIC *) theDefgeneric))
738 {
739 MethodAlterError(theEnv,(DEFGENERIC *) theDefgeneric);
740 return(FALSE);
741 }
742 }
743
744 /* =======================================
745 Only certain specific system functions
746 may be overloaded by generic functions
747 ======================================= */
748 systemFunction = FindFunction(theEnv,theDefgenericName);
749 if ((systemFunction != NULL) ?
750 (systemFunction->overloadable == FALSE) : FALSE)
751 {
752 PrintErrorID(theEnv,"GENRCPSR",16,FALSE);
753 EnvPrintRouter(theEnv,WERROR,"The system function ");
754 EnvPrintRouter(theEnv,WERROR,theDefgenericName);
755 EnvPrintRouter(theEnv,WERROR," cannot be overloaded.\n");
756 return(FALSE);
757 }
758 return(TRUE);
759 }
760
761 #if DEBUGGING_FUNCTIONS
762
763 /***************************************************
764 NAME : CreateDefaultGenericPPForm
765 DESCRIPTION : Adds a default pretty-print form
766 for a gneric function when it is
767 impliciylt created by the defn
768 of its first method
769 INPUTS : The generic function
770 RETURNS : Nothing useful
771 SIDE EFFECTS : Pretty-print form created and
772 attached.
773 NOTES : None
774 ***************************************************/
CreateDefaultGenericPPForm(void * theEnv,DEFGENERIC * gfunc)775 static void CreateDefaultGenericPPForm(
776 void *theEnv,
777 DEFGENERIC *gfunc)
778 {
779 const char *moduleName, *genericName;
780 char *buf;
781
782 moduleName = EnvGetDefmoduleName(theEnv,(void *) ((struct defmodule *) EnvGetCurrentModule(theEnv)));
783 genericName = EnvGetDefgenericName(theEnv,(void *) gfunc);
784 buf = (char *) gm2(theEnv,(sizeof(char) * (strlen(moduleName) + strlen(genericName) + 17)));
785 gensprintf(buf,"(defgeneric %s::%s)\n",moduleName,genericName);
786 EnvSetDefgenericPPForm(theEnv,(void *) gfunc,buf);
787 }
788
789 #endif
790
791 /*******************************************************
792 NAME : ParseMethodNameAndIndex
793 DESCRIPTION : Parses the name of the method and
794 optional method index
795 INPUTS : 1) The logical name of the input source
796 2) Caller's buffer for method index
797 (0 if not specified)
798 RETURNS : The symbolic name of the method
799 SIDE EFFECTS : None
800 NOTES : Assumes "(defmethod " already parsed
801 *******************************************************/
ParseMethodNameAndIndex(void * theEnv,const char * readSource,int * theIndex)802 static SYMBOL_HN *ParseMethodNameAndIndex(
803 void *theEnv,
804 const char *readSource,
805 int *theIndex)
806 {
807 SYMBOL_HN *gname;
808
809 *theIndex = 0;
810 gname = GetConstructNameAndComment(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken,"defgeneric",
811 EnvFindDefgenericInModule,NULL,"&",TRUE,FALSE,TRUE,TRUE);
812 if (gname == NULL)
813 return(NULL);
814 if (GetType(DefgenericData(theEnv)->GenericInputToken) == INTEGER)
815 {
816 int tmp;
817
818 PPBackup(theEnv);
819 PPBackup(theEnv);
820 SavePPBuffer(theEnv," ");
821 SavePPBuffer(theEnv,DefgenericData(theEnv)->GenericInputToken.printForm);
822 tmp = (int) ValueToLong(GetValue(DefgenericData(theEnv)->GenericInputToken));
823 if (tmp < 1)
824 {
825 PrintErrorID(theEnv,"GENRCPSR",6,FALSE);
826 EnvPrintRouter(theEnv,WERROR,"Method index out of range.\n");
827 return(NULL);
828 }
829 *theIndex = tmp;
830 PPCRAndIndent(theEnv);
831 GetToken(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken);
832 }
833 if (GetType(DefgenericData(theEnv)->GenericInputToken) == STRING)
834 {
835 PPBackup(theEnv);
836 PPBackup(theEnv);
837 SavePPBuffer(theEnv," ");
838 SavePPBuffer(theEnv,DefgenericData(theEnv)->GenericInputToken.printForm);
839 PPCRAndIndent(theEnv);
840 GetToken(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken);
841 }
842 return(gname);
843 }
844
845 /************************************************************************
846 NAME : ParseMethodParameters
847 DESCRIPTION : Parses method restrictions
848 (parameter names with class and expression specifiers)
849 INPUTS : 1) The logical name of the input source
850 2) Caller's buffer for the parameter name list
851 (Restriction structures are attached to
852 argList pointers of parameter nodes)
853 3) Caller's buffer for wildcard symbol (if any)
854 RETURNS : The number of parameters, or -1 on errors
855 SIDE EFFECTS : Memory allocated for parameters and restrictions
856 Parameter names stored in expression list
857 Parameter restrictions stored in contiguous array
858 NOTES : Any memory allocated is freed on errors
859 Assumes first opening parenthesis has been scanned
860 ************************************************************************/
ParseMethodParameters(void * theEnv,const char * readSource,EXPRESSION ** params,SYMBOL_HN ** wildcard)861 static int ParseMethodParameters(
862 void *theEnv,
863 const char *readSource,
864 EXPRESSION **params,
865 SYMBOL_HN **wildcard)
866 {
867 EXPRESSION *phead = NULL,*pprv;
868 SYMBOL_HN *pname;
869 RESTRICTION *rtmp;
870 int rcnt = 0;
871
872 *wildcard = NULL;
873 *params = NULL;
874 if (GetType(DefgenericData(theEnv)->GenericInputToken) != LPAREN)
875 {
876 PrintErrorID(theEnv,"GENRCPSR",7,FALSE);
877 EnvPrintRouter(theEnv,WERROR,"Expected a '(' to begin method parameter restrictions.\n");
878 return(-1);
879 }
880 GetToken(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken);
881 while (DefgenericData(theEnv)->GenericInputToken.type != RPAREN)
882 {
883 if (*wildcard != NULL)
884 {
885 DeleteTempRestricts(theEnv,phead);
886 PrintErrorID(theEnv,"PRCCODE",8,FALSE);
887 EnvPrintRouter(theEnv,WERROR,"No parameters allowed after wildcard parameter.\n");
888 return(-1);
889 }
890 if ((DefgenericData(theEnv)->GenericInputToken.type == SF_VARIABLE) || (DefgenericData(theEnv)->GenericInputToken.type == MF_VARIABLE))
891 {
892 pname = (SYMBOL_HN *) DefgenericData(theEnv)->GenericInputToken.value;
893 if (DuplicateParameters(theEnv,phead,&pprv,pname))
894 {
895 DeleteTempRestricts(theEnv,phead);
896 return(-1);
897 }
898 if (DefgenericData(theEnv)->GenericInputToken.type == MF_VARIABLE)
899 *wildcard = pname;
900 rtmp = get_struct(theEnv,restriction);
901 PackRestrictionTypes(theEnv,rtmp,NULL);
902 rtmp->query = NULL;
903 phead = AddParameter(theEnv,phead,pprv,pname,rtmp);
904 rcnt++;
905 }
906 else if (DefgenericData(theEnv)->GenericInputToken.type == LPAREN)
907 {
908 GetToken(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken);
909 if ((DefgenericData(theEnv)->GenericInputToken.type != SF_VARIABLE) &&
910 (DefgenericData(theEnv)->GenericInputToken.type != MF_VARIABLE))
911 {
912 DeleteTempRestricts(theEnv,phead);
913 PrintErrorID(theEnv,"GENRCPSR",8,FALSE);
914 EnvPrintRouter(theEnv,WERROR,"Expected a variable for parameter specification.\n");
915 return(-1);
916 }
917 pname = (SYMBOL_HN *) DefgenericData(theEnv)->GenericInputToken.value;
918 if (DuplicateParameters(theEnv,phead,&pprv,pname))
919 {
920 DeleteTempRestricts(theEnv,phead);
921 return(-1);
922 }
923 if (DefgenericData(theEnv)->GenericInputToken.type == MF_VARIABLE)
924 *wildcard = pname;
925 SavePPBuffer(theEnv," ");
926 rtmp = ParseRestriction(theEnv,readSource);
927 if (rtmp == NULL)
928 {
929 DeleteTempRestricts(theEnv,phead);
930 return(-1);
931 }
932 phead = AddParameter(theEnv,phead,pprv,pname,rtmp);
933 rcnt++;
934 }
935 else
936 {
937 DeleteTempRestricts(theEnv,phead);
938 PrintErrorID(theEnv,"GENRCPSR",9,FALSE);
939 EnvPrintRouter(theEnv,WERROR,"Expected a variable or '(' for parameter specification.\n");
940 return(-1);
941 }
942 PPCRAndIndent(theEnv);
943 GetToken(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken);
944 }
945 if (rcnt != 0)
946 {
947 PPBackup(theEnv);
948 PPBackup(theEnv);
949 SavePPBuffer(theEnv,")");
950 }
951 *params = phead;
952 return(rcnt);
953 }
954
955 /************************************************************
956 NAME : ParseRestriction
957 DESCRIPTION : Parses the restriction for a parameter of a
958 method
959 This restriction is comprised of:
960 1) A list of classes (or types) that are
961 allowed for the parameter (None
962 if no type restriction)
963 2) And an optional restriction-query
964 expression
965 INPUTS : The logical name of the input source
966 RETURNS : The address of a RESTRICTION node, NULL on
967 errors
968 SIDE EFFECTS : RESTRICTION node allocated
969 Types are in a contiguous array of void *
970 Query is an expression
971 NOTES : Assumes "(?<var> " has already been parsed
972 H/L Syntax: <type>* [<query>])
973 ************************************************************/
ParseRestriction(void * theEnv,const char * readSource)974 static RESTRICTION *ParseRestriction(
975 void *theEnv,
976 const char *readSource)
977 {
978 EXPRESSION *types = NULL,*new_types,
979 *typesbot,*tmp,*tmp2,
980 *query = NULL;
981 RESTRICTION *rptr;
982
983 GetToken(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken);
984 while (DefgenericData(theEnv)->GenericInputToken.type != RPAREN)
985 {
986 if (query != NULL)
987 {
988 PrintErrorID(theEnv,"GENRCPSR",10,FALSE);
989 EnvPrintRouter(theEnv,WERROR,"Query must be last in parameter restriction.\n");
990 ReturnExpression(theEnv,query);
991 ReturnExpression(theEnv,types);
992 return(NULL);
993 }
994 if (DefgenericData(theEnv)->GenericInputToken.type == SYMBOL)
995 {
996 new_types = ValidType(theEnv,(SYMBOL_HN *) DefgenericData(theEnv)->GenericInputToken.value);
997 if (new_types == NULL)
998 {
999 ReturnExpression(theEnv,types);
1000 ReturnExpression(theEnv,query);
1001 return(NULL);
1002 }
1003 if (types == NULL)
1004 types = new_types;
1005 else
1006 {
1007 for (typesbot = tmp = types ; tmp != NULL ; tmp = tmp->nextArg)
1008 {
1009 for (tmp2 = new_types ; tmp2 != NULL ; tmp2 = tmp2->nextArg)
1010 {
1011 if (tmp->value == tmp2->value)
1012 {
1013 PrintErrorID(theEnv,"GENRCPSR",11,FALSE);
1014 #if OBJECT_SYSTEM
1015 EnvPrintRouter(theEnv,WERROR,"Duplicate classes not allowed in parameter restriction.\n");
1016 #else
1017 EnvPrintRouter(theEnv,WERROR,"Duplicate types not allowed in parameter restriction.\n");
1018 #endif
1019 ReturnExpression(theEnv,query);
1020 ReturnExpression(theEnv,types);
1021 ReturnExpression(theEnv,new_types);
1022 return(NULL);
1023 }
1024 if (RedundantClasses(theEnv,tmp->value,tmp2->value))
1025 {
1026 ReturnExpression(theEnv,query);
1027 ReturnExpression(theEnv,types);
1028 ReturnExpression(theEnv,new_types);
1029 return(NULL);
1030 }
1031 }
1032 typesbot = tmp;
1033 }
1034 typesbot->nextArg = new_types;
1035 }
1036 }
1037 else if (DefgenericData(theEnv)->GenericInputToken.type == LPAREN)
1038 {
1039 query = Function1Parse(theEnv,readSource);
1040 if (query == NULL)
1041 {
1042 ReturnExpression(theEnv,types);
1043 return(NULL);
1044 }
1045 if (GetParsedBindNames(theEnv) != NULL)
1046 {
1047 PrintErrorID(theEnv,"GENRCPSR",12,FALSE);
1048 EnvPrintRouter(theEnv,WERROR,"Binds are not allowed in query expressions.\n");
1049 ReturnExpression(theEnv,query);
1050 ReturnExpression(theEnv,types);
1051 return(NULL);
1052 }
1053 }
1054 #if DEFGLOBAL_CONSTRUCT
1055 else if (DefgenericData(theEnv)->GenericInputToken.type == GBL_VARIABLE)
1056 query = GenConstant(theEnv,GBL_VARIABLE,DefgenericData(theEnv)->GenericInputToken.value);
1057 #endif
1058 else
1059 {
1060 PrintErrorID(theEnv,"GENRCPSR",13,FALSE);
1061 #if OBJECT_SYSTEM
1062 EnvPrintRouter(theEnv,WERROR,"Expected a valid class name or query.\n");
1063 #else
1064 EnvPrintRouter(theEnv,WERROR,"Expected a valid type name or query.\n");
1065 #endif
1066 ReturnExpression(theEnv,query);
1067 ReturnExpression(theEnv,types);
1068 return(NULL);
1069 }
1070 SavePPBuffer(theEnv," ");
1071 GetToken(theEnv,readSource,&DefgenericData(theEnv)->GenericInputToken);
1072 }
1073 PPBackup(theEnv);
1074 PPBackup(theEnv);
1075 SavePPBuffer(theEnv,")");
1076 if ((types == NULL) && (query == NULL))
1077 {
1078 PrintErrorID(theEnv,"GENRCPSR",13,FALSE);
1079 #if OBJECT_SYSTEM
1080 EnvPrintRouter(theEnv,WERROR,"Expected a valid class name or query.\n");
1081 #else
1082 EnvPrintRouter(theEnv,WERROR,"Expected a valid type name or query.\n");
1083 #endif
1084 return(NULL);
1085 }
1086 rptr = get_struct(theEnv,restriction);
1087 rptr->query = query;
1088 PackRestrictionTypes(theEnv,rptr,types);
1089 return(rptr);
1090 }
1091
1092 /*****************************************************************
1093 NAME : ReplaceCurrentArgRefs
1094 DESCRIPTION : Replaces all references to ?current-argument in
1095 method parameter queries with special calls
1096 to (gnrc-current-arg)
1097 INPUTS : The query expression
1098 RETURNS : Nothing useful
1099 SIDE EFFECTS : Variable references to ?current-argument replaced
1100 NOTES : None
1101 *****************************************************************/
ReplaceCurrentArgRefs(void * theEnv,EXPRESSION * query)1102 static void ReplaceCurrentArgRefs(
1103 void *theEnv,
1104 EXPRESSION *query)
1105 {
1106 while (query != NULL)
1107 {
1108 if ((query->type != SF_VARIABLE) ? FALSE :
1109 (strcmp(ValueToString(query->value),CURR_ARG_VAR) == 0))
1110 {
1111 query->type = FCALL;
1112 query->value = (void *) FindFunction(theEnv,"(gnrc-current-arg)");
1113 }
1114 if (query->argList != NULL)
1115 ReplaceCurrentArgRefs(theEnv,query->argList);
1116 query = query->nextArg;
1117 }
1118 }
1119
1120 /**********************************************************
1121 NAME : DuplicateParameters
1122 DESCRIPTION : Examines the parameter expression
1123 chain for a method looking duplicates.
1124 INPUTS : 1) The parameter chain (can be NULL)
1125 2) Caller's buffer for address of
1126 last node searched (can be used to
1127 later attach new parameter)
1128 3) The name of the parameter being checked
1129 RETURNS : TRUE if duplicates found, FALSE otherwise
1130 SIDE EFFECTS : Caller's prv address set
1131 NOTES : Assumes all parameter list nodes are WORDS
1132 **********************************************************/
DuplicateParameters(void * theEnv,EXPRESSION * head,EXPRESSION ** prv,SYMBOL_HN * name)1133 static int DuplicateParameters(
1134 void *theEnv,
1135 EXPRESSION *head,
1136 EXPRESSION **prv,
1137 SYMBOL_HN *name)
1138 {
1139 *prv = NULL;
1140 while (head != NULL)
1141 {
1142 if (head->value == (void *) name)
1143 {
1144 PrintErrorID(theEnv,"PRCCODE",7,FALSE);
1145 EnvPrintRouter(theEnv,WERROR,"Duplicate parameter names not allowed.\n");
1146 return(TRUE);
1147 }
1148 *prv = head;
1149 head = head->nextArg;
1150 }
1151 return(FALSE);
1152 }
1153
1154 /*****************************************************************
1155 NAME : AddParameter
1156 DESCRIPTION : Shoves a new paramter with its restriction
1157 onto the list for a method
1158 The parameter list is a list of expressions
1159 linked by neext_arg pointers, and the
1160 argList pointers are used for the restrictions
1161 INPUTS : 1) The head of the list
1162 2) The bottom of the list
1163 3) The parameter name
1164 4) The parameter restriction
1165 RETURNS : The (new) head of the list
1166 SIDE EFFECTS : New parameter expression node allocated, set,
1167 and attached
1168 NOTES : None
1169 *****************************************************************/
AddParameter(void * theEnv,EXPRESSION * phead,EXPRESSION * pprv,SYMBOL_HN * pname,RESTRICTION * rptr)1170 static EXPRESSION *AddParameter(
1171 void *theEnv,
1172 EXPRESSION *phead,
1173 EXPRESSION *pprv,
1174 SYMBOL_HN *pname,
1175 RESTRICTION *rptr)
1176 {
1177 EXPRESSION *ptmp;
1178
1179 ptmp = GenConstant(theEnv,SYMBOL,(void *) pname);
1180 if (phead == NULL)
1181 phead = ptmp;
1182 else
1183 pprv->nextArg = ptmp;
1184 ptmp->argList = (EXPRESSION *) rptr;
1185 return(phead);
1186 }
1187
1188 /**************************************************************
1189 NAME : ValidType
1190 DESCRIPTION : Examines the name of a restriction type and
1191 forms a list of integer-code expressions
1192 corresponding to the primitive types
1193 (or a Class address if COOL is installed)
1194 INPUTS : The type name
1195 RETURNS : The expression chain (NULL on errors)
1196 SIDE EFFECTS : Expression type chain allocated
1197 one or more nodes holding codes for types
1198 (or class addresses)
1199 NOTES : None
1200 *************************************************************/
ValidType(void * theEnv,SYMBOL_HN * tname)1201 static EXPRESSION *ValidType(
1202 void *theEnv,
1203 SYMBOL_HN *tname)
1204 {
1205 #if OBJECT_SYSTEM
1206 DEFCLASS *cls;
1207
1208 if (FindModuleSeparator(ValueToString(tname)))
1209 IllegalModuleSpecifierMessage(theEnv);
1210 else
1211 {
1212 cls = LookupDefclassInScope(theEnv,ValueToString(tname));
1213 if (cls == NULL)
1214 {
1215 PrintErrorID(theEnv,"GENRCPSR",14,FALSE);
1216 EnvPrintRouter(theEnv,WERROR,"Unknown class in method.\n");
1217 return(NULL);
1218 }
1219 return(GenConstant(theEnv,DEFCLASS_PTR,(void *) cls));
1220 }
1221 #else
1222 if (strcmp(ValueToString(tname),INTEGER_TYPE_NAME) == 0)
1223 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) INTEGER)));
1224 if (strcmp(ValueToString(tname),FLOAT_TYPE_NAME) == 0)
1225 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) FLOAT)));
1226 if (strcmp(ValueToString(tname),SYMBOL_TYPE_NAME) == 0)
1227 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) SYMBOL)));
1228 if (strcmp(ValueToString(tname),STRING_TYPE_NAME) == 0)
1229 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) STRING)));
1230 if (strcmp(ValueToString(tname),MULTIFIELD_TYPE_NAME) == 0)
1231 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) MULTIFIELD)));
1232 if (strcmp(ValueToString(tname),EXTERNAL_ADDRESS_TYPE_NAME) == 0)
1233 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) EXTERNAL_ADDRESS)));
1234 if (strcmp(ValueToString(tname),FACT_ADDRESS_TYPE_NAME) == 0)
1235 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) FACT_ADDRESS)));
1236 if (strcmp(ValueToString(tname),NUMBER_TYPE_NAME) == 0)
1237 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) NUMBER_TYPE_CODE)));
1238 if (strcmp(ValueToString(tname),LEXEME_TYPE_NAME) == 0)
1239 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) LEXEME_TYPE_CODE)));
1240 if (strcmp(ValueToString(tname),ADDRESS_TYPE_NAME) == 0)
1241 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) ADDRESS_TYPE_CODE)));
1242 if (strcmp(ValueToString(tname),PRIMITIVE_TYPE_NAME) == 0)
1243 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) PRIMITIVE_TYPE_CODE)));
1244 if (strcmp(ValueToString(tname),OBJECT_TYPE_NAME) == 0)
1245 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) OBJECT_TYPE_CODE)));
1246 if (strcmp(ValueToString(tname),INSTANCE_TYPE_NAME) == 0)
1247 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) INSTANCE_TYPE_CODE)));
1248 if (strcmp(ValueToString(tname),INSTANCE_NAME_TYPE_NAME) == 0)
1249 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) INSTANCE_NAME)));
1250 if (strcmp(ValueToString(tname),INSTANCE_ADDRESS_TYPE_NAME) == 0)
1251 return(GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long long) INSTANCE_ADDRESS)));
1252
1253 PrintErrorID(theEnv,"GENRCPSR",14,FALSE);
1254 EnvPrintRouter(theEnv,WERROR,"Unknown type in method.\n");
1255 #endif
1256 return(NULL);
1257 }
1258
1259 /*************************************************************
1260 NAME : RedundantClasses
1261 DESCRIPTION : Determines if one class (type) is
1262 subsumes (or is subsumed by) another.
1263 INPUTS : Two void pointers which are class pointers
1264 if COOL is installed or integer hash nodes
1265 for type codes otherwise.
1266 RETURNS : TRUE if there is subsumption, FALSE otherwise
1267 SIDE EFFECTS : An error message is printed, if appropriate.
1268 NOTES : None
1269 *************************************************************/
RedundantClasses(void * theEnv,void * c1,void * c2)1270 static intBool RedundantClasses(
1271 void *theEnv,
1272 void *c1,
1273 void *c2)
1274 {
1275 const char *tname;
1276
1277 #if OBJECT_SYSTEM
1278 if (HasSuperclass((DEFCLASS *) c1,(DEFCLASS *) c2))
1279 tname = EnvGetDefclassName(theEnv,c1);
1280 else if (HasSuperclass((DEFCLASS *) c2,(DEFCLASS *) c1))
1281 tname = EnvGetDefclassName(theEnv,c2);
1282 #else
1283 if (SubsumeType(ValueToInteger(c1),ValueToInteger(c2)))
1284 tname = TypeName(theEnv,ValueToInteger(c1));
1285 else if (SubsumeType(ValueToInteger(c2),ValueToInteger(c1)))
1286 tname = TypeName(theEnv,ValueToInteger(c2));
1287 #endif
1288 else
1289 return(FALSE);
1290 PrintErrorID(theEnv,"GENRCPSR",15,FALSE);
1291 EnvPrintRouter(theEnv,WERROR,tname);
1292 EnvPrintRouter(theEnv,WERROR," class is redundant.\n");
1293 return(TRUE);
1294 }
1295
1296 /*********************************************************
1297 NAME : AddGeneric
1298 DESCRIPTION : Inserts a new generic function
1299 header into the generic list
1300 INPUTS : 1) Symbolic name of the new generic
1301 2) Caller's input buffer for flag
1302 if added generic is new or not
1303 RETURNS : The address of the new node, or
1304 address of old node if already present
1305 SIDE EFFECTS : Generic header inserted
1306 If the node is already present, it is
1307 moved to the end of the list, otherwise
1308 the new node is inserted at the end
1309 NOTES : None
1310 *********************************************************/
AddGeneric(void * theEnv,SYMBOL_HN * name,int * newGeneric)1311 static DEFGENERIC *AddGeneric(
1312 void *theEnv,
1313 SYMBOL_HN *name,
1314 int *newGeneric)
1315 {
1316 DEFGENERIC *gfunc;
1317
1318 gfunc = (DEFGENERIC *) EnvFindDefgenericInModule(theEnv,ValueToString(name));
1319 if (gfunc != NULL)
1320 {
1321 *newGeneric = FALSE;
1322
1323 if (ConstructData(theEnv)->CheckSyntaxMode)
1324 { return(gfunc); }
1325
1326 /* ================================
1327 The old trace state is preserved
1328 ================================ */
1329 RemoveConstructFromModule(theEnv,(struct constructHeader *) gfunc);
1330 }
1331 else
1332 {
1333 *newGeneric = TRUE;
1334 gfunc = NewGeneric(theEnv,name);
1335 IncrementSymbolCount(name);
1336 AddImplicitMethods(theEnv,gfunc);
1337 }
1338 AddConstructToModule((struct constructHeader *) gfunc);
1339 return(gfunc);
1340 }
1341
1342 /**********************************************************************
1343 NAME : AddGenericMethod
1344 DESCRIPTION : Inserts a blank method (with the method-index set)
1345 into the specified position of the generic
1346 method array
1347 INPUTS : 1) The generic function
1348 2) The index where to add the method in the array
1349 3) The method user-index (0 if don't care)
1350 RETURNS : The address of the new method
1351 SIDE EFFECTS : Fields initialized (index set) and new method inserted
1352 Generic function new method-index set to specified
1353 by user-index if > current new method-index
1354 NOTES : None
1355 **********************************************************************/
AddGenericMethod(void * theEnv,DEFGENERIC * gfunc,int mposn,short mi)1356 static DEFMETHOD *AddGenericMethod(
1357 void *theEnv,
1358 DEFGENERIC *gfunc,
1359 int mposn,
1360 short mi)
1361 {
1362 DEFMETHOD *narr;
1363 long b, e;
1364
1365 narr = (DEFMETHOD *) gm2(theEnv,(sizeof(DEFMETHOD) * (gfunc->mcnt+1)));
1366 for (b = e = 0 ; b < gfunc->mcnt ; b++ , e++)
1367 {
1368 if (b == mposn)
1369 e++;
1370 GenCopyMemory(DEFMETHOD,1,&narr[e],&gfunc->methods[b]);
1371 }
1372 if (mi == 0)
1373 narr[mposn].index = gfunc->new_index++;
1374 else
1375 {
1376 narr[mposn].index = mi;
1377 if (mi >= gfunc->new_index)
1378 gfunc->new_index = (short) (mi+1);
1379 }
1380 narr[mposn].busy = 0;
1381 #if DEBUGGING_FUNCTIONS
1382 narr[mposn].trace = DefgenericData(theEnv)->WatchMethods;
1383 #endif
1384 narr[mposn].minRestrictions = 0;
1385 narr[mposn].maxRestrictions = 0;
1386 narr[mposn].restrictionCount = 0;
1387 narr[mposn].localVarCount = 0;
1388 narr[mposn].system = 0;
1389 narr[mposn].restrictions = NULL;
1390 narr[mposn].actions = NULL;
1391 narr[mposn].ppForm = NULL;
1392 narr[mposn].usrData = NULL;
1393 if (gfunc->mcnt != 0)
1394 rm(theEnv,(void *) gfunc->methods,(sizeof(DEFMETHOD) * gfunc->mcnt));
1395 gfunc->mcnt++;
1396 gfunc->methods = narr;
1397 return(&narr[mposn]);
1398 }
1399
1400 /****************************************************************
1401 NAME : RestrictionsCompare
1402 DESCRIPTION : Compares the restriction-expression list
1403 with an existing methods restrictions to
1404 determine an ordering
1405 INPUTS : 1) The parameter/restriction expression list
1406 2) The total number of restrictions
1407 3) The number of minimum restrictions
1408 4) The number of maximum restrictions (-1
1409 if unlimited)
1410 5) The method with which to compare restrictions
1411 RETURNS : A code representing how the method restrictions
1412 -1 : New restrictions have higher precedence
1413 0 : New restrictions are identical
1414 1 : New restrictions have lower precedence
1415 SIDE EFFECTS : None
1416 NOTES : The new restrictions are stored in the argList
1417 pointers of the parameter expressions
1418 ****************************************************************/
RestrictionsCompare(EXPRESSION * params,int rcnt,int min,int max,DEFMETHOD * meth)1419 static int RestrictionsCompare(
1420 EXPRESSION *params,
1421 int rcnt,
1422 int min,
1423 int max,
1424 DEFMETHOD *meth)
1425 {
1426 register int i;
1427 register RESTRICTION *r1,*r2;
1428 int diff = FALSE,rtn;
1429
1430 for (i = 0 ; (i < rcnt) && (i < meth->restrictionCount) ; i++)
1431 {
1432 /* =============================================================
1433 A wildcard parameter always has lower precedence than
1434 a regular parameter, regardless of the class restriction list
1435 ============================================================= */
1436 if ((i == rcnt-1) && (max == -1) &&
1437 (meth->maxRestrictions != -1))
1438 return(LOWER_PRECEDENCE);
1439 if ((i == meth->restrictionCount-1) && (max != -1) &&
1440 (meth->maxRestrictions == -1))
1441 return(HIGHER_PRECEDENCE);
1442
1443 /* =============================================================
1444 The parameter with the most specific type list has precedence
1445 ============================================================= */
1446 r1 = (RESTRICTION *) params->argList;
1447 r2 = &meth->restrictions[i];
1448 rtn = TypeListCompare(r1,r2);
1449 if (rtn != IDENTICAL)
1450 return(rtn);
1451
1452 /* =====================================================
1453 The parameter with a query restriction has precedence
1454 ===================================================== */
1455 if ((r1->query == NULL) && (r2->query != NULL))
1456 return(LOWER_PRECEDENCE);
1457 if ((r1->query != NULL) && (r2->query == NULL))
1458 return(HIGHER_PRECEDENCE);
1459
1460 /* ==========================================================
1461 Remember if the method restrictions differ at all - query
1462 expressions must be identical as well for the restrictions
1463 to be the same
1464 ========================================================== */
1465 if (IdenticalExpression(r1->query,r2->query) == FALSE)
1466 diff = TRUE;
1467 params = params->nextArg;
1468 }
1469
1470 /* =============================================================
1471 If the methods have the same number of parameters here, they
1472 are either the same restrictions, or they differ only in
1473 the query restrictions
1474 ============================================================= */
1475 if (rcnt == meth->restrictionCount)
1476 return(diff ? LOWER_PRECEDENCE : IDENTICAL);
1477
1478 /* =============================================
1479 The method with the greater number of regular
1480 parameters has precedence
1481
1482 If they require the smae # of reg params,
1483 then one without a wildcard has precedence
1484 ============================================= */
1485 if (min > meth->minRestrictions)
1486 return(HIGHER_PRECEDENCE);
1487 if (meth->minRestrictions < min)
1488 return(LOWER_PRECEDENCE);
1489 return((max == - 1) ? LOWER_PRECEDENCE : HIGHER_PRECEDENCE);
1490 }
1491
1492 /*****************************************************
1493 NAME : TypeListCompare
1494 DESCRIPTION : Determines the precedence between
1495 the class lists on two restrictions
1496 INPUTS : 1) Restriction address #1
1497 2) Restriction address #2
1498 RETURNS : -1 : r1 precedes r2
1499 0 : Identical classes
1500 1 : r2 precedes r1
1501 SIDE EFFECTS : None
1502 NOTES : None
1503 *****************************************************/
TypeListCompare(RESTRICTION * r1,RESTRICTION * r2)1504 static int TypeListCompare(
1505 RESTRICTION *r1,
1506 RESTRICTION *r2)
1507 {
1508 long i;
1509 int diff = FALSE;
1510
1511 if ((r1->tcnt == 0) && (r2->tcnt == 0))
1512 return(IDENTICAL);
1513 if (r1->tcnt == 0)
1514 return(LOWER_PRECEDENCE);
1515 if (r2->tcnt == 0)
1516 return(HIGHER_PRECEDENCE);
1517 for (i = 0 ; (i < r1->tcnt) && (i < r2->tcnt) ; i++)
1518 {
1519 if (r1->types[i] != r2->types[i])
1520 {
1521 diff = TRUE;
1522 #if OBJECT_SYSTEM
1523 if (HasSuperclass((DEFCLASS *) r1->types[i],(DEFCLASS *) r2->types[i]))
1524 return(HIGHER_PRECEDENCE);
1525 if (HasSuperclass((DEFCLASS *) r2->types[i],(DEFCLASS *) r1->types[i]))
1526 return(LOWER_PRECEDENCE);
1527 #else
1528 if (SubsumeType(ValueToInteger(r1->types[i]),ValueToInteger(r2->types[i])))
1529 return(HIGHER_PRECEDENCE);
1530 if (SubsumeType(ValueToInteger(r2->types[i]),ValueToInteger(r1->types[i])))
1531 return(LOWER_PRECEDENCE);
1532 #endif
1533 }
1534 }
1535 if (r1->tcnt < r2->tcnt)
1536 return(HIGHER_PRECEDENCE);
1537 if (r1->tcnt > r2->tcnt)
1538 return(LOWER_PRECEDENCE);
1539 if (diff)
1540 return(LOWER_PRECEDENCE);
1541 return(IDENTICAL);
1542 }
1543
1544 /***************************************************
1545 NAME : NewGeneric
1546 DESCRIPTION : Allocates and initializes a new
1547 generic function header
1548 INPUTS : The name of the new generic
1549 RETURNS : The address of the new generic
1550 SIDE EFFECTS : Generic function header created
1551 NOTES : None
1552 ***************************************************/
NewGeneric(void * theEnv,SYMBOL_HN * gname)1553 static DEFGENERIC *NewGeneric(
1554 void *theEnv,
1555 SYMBOL_HN *gname)
1556 {
1557 DEFGENERIC *ngen;
1558
1559 ngen = get_struct(theEnv,defgeneric);
1560 InitializeConstructHeader(theEnv,"defgeneric",(struct constructHeader *) ngen,gname);
1561 ngen->busy = 0;
1562 ngen->new_index = 1;
1563 ngen->methods = NULL;
1564 ngen->mcnt = 0;
1565 #if DEBUGGING_FUNCTIONS
1566 ngen->trace = DefgenericData(theEnv)->WatchGenerics;
1567 #endif
1568 return(ngen);
1569 }
1570
1571 #endif /* DEFGENERIC_CONSTRUCT && (! BLOAD_ONLY) && (! RUN_TIME) */
1572
1573 /***************************************************
1574 NAME :
1575 DESCRIPTION :
1576 INPUTS :
1577 RETURNS :
1578 SIDE EFFECTS :
1579 NOTES :
1580 ***************************************************/
1581