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,&params,&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