/*******************************************************/   /*      "C" Language Integrated Production System      */   /*                                                     */   /*               CLIPS Version 6.20  01/31/02          */   /*                                                     */   /*             MULTIPLE INHERITANCE PARSER MODULE      */   /*******************************************************//**************************************************************//* Purpose: Parsing Routines for Multiple Inheritance         *//*                                                            *//* Principal Programmer(s):                                   *//*      Brian L. Donnell                                      *//*                                                            *//* Contributing Programmer(s):                                *//*                                                            *//* Revision History:                                          *//*                                                            *//**************************************************************//* =========================================   *****************************************               EXTERNAL DEFINITIONS   =========================================   ***************************************** */#include "setup.h"#if OBJECT_SYSTEM && (! BLOAD_ONLY) && (! RUN_TIME)#include "classcom.h"#include "classfun.h"#include "envrnmnt.h"#include "memalloc.h"#include "modulutl.h"#include "router.h"#include "scanner.h"#define _INHERPSR_SOURCE_#include "inherpsr.h"/* =========================================   *****************************************               MACROS AND TYPES   =========================================   ***************************************** */typedef struct partialOrder PARTIAL_ORDER;typedef struct successor SUCCESSOR;struct partialOrder  {   DEFCLASS *cls;   unsigned pre;   SUCCESSOR *suc;   struct partialOrder *nxt;  };struct successor  {   PARTIAL_ORDER *po;   struct successor *nxt;  };/* =========================================   *****************************************      INTERNALLY VISIBLE FUNCTION HEADERS   =========================================   ***************************************** */static PARTIAL_ORDER *InitializePartialOrderTable(void *,PARTIAL_ORDER *,PACKED_CLASS_LINKS *);static void RecordPartialOrders(void *,PARTIAL_ORDER *,DEFCLASS *,PACKED_CLASS_LINKS *,long);static PARTIAL_ORDER *FindPartialOrder(PARTIAL_ORDER *,DEFCLASS *);static void PrintPartialOrderLoop(void *,PARTIAL_ORDER *);static void PrintClassLinks(void *,char *,char *,CLASS_LINK *);/* =========================================   *****************************************          EXTERNALLY VISIBLE FUNCTIONS   =========================================   ***************************************** *//**************************************************************  NAME         : ParseSuperclasses  DESCRIPTION  : Parses the (is-a <superclass>+) portion of                 the (defclass ...) construct and returns                 a list of direct superclasses.  The                 class "standard-class" is the precedence list                 for classes with no direct superclasses.                 The final precedence list (not calculated here)                 will have the class in question first followed                 by the merged precedence lists of its direct                 superclasses.  INPUTS       : 1) The logical name of the input source                 2) The symbolic name of the new class  RETURNS      : The address of the superclass list                  or NULL if there was an error  SIDE EFFECTS : None  NOTES        : Assumes "(defclass <name> [<comment>] ("                 has already been scanned.                 All superclasses must be defined before                 their subclasses.  Duplicates in the (is-a                 ...) list are are not allowed (a class may only                 inherits from a superclass once).                 This routine also checks the class-precedence                 lists of each of the direct superclasses for                 an occurrence of the new class - i.e. cycles!                 This can only happen when a class is redefined                 (a new class cannot have an unspecified                 superclass).                 This routine allocates the space for the list ***************************************************************/globle PACKED_CLASS_LINKS *ParseSuperclasses(  void *theEnv,  char *readSource,  SYMBOL_HN *newClassName)  {   CLASS_LINK *clink = NULL,*cbot = NULL,*ctmp;   DEFCLASS *sclass;   PACKED_CLASS_LINKS *plinks;   if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN)     {      SyntaxErrorMessage(theEnv,"defclass inheritance");      return(NULL);     }   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);   if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE :       (DefclassData(theEnv)->ObjectParseToken.value != (void *) DefclassData(theEnv)->ISA_SYMBOL))     {      SyntaxErrorMessage(theEnv,"defclass inheritance");      return(NULL);     }   SavePPBuffer(theEnv," ");   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);   while (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)     {      if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)        {         SyntaxErrorMessage(theEnv,"defclass");         goto SuperclassParseError;        }      if (FindModuleSeparator(ValueToString(newClassName)))        {         IllegalModuleSpecifierMessage(theEnv);         goto SuperclassParseError;        }      if (GetValue(DefclassData(theEnv)->ObjectParseToken) == (void *) newClassName)        {         PrintErrorID(theEnv,"INHERPSR",1,FALSE);         EnvPrintRouter(theEnv,WERROR,"A class may not have itself as a superclass.\n");         goto SuperclassParseError;        }      for (ctmp = clink ; ctmp != NULL ; ctmp = ctmp->nxt)        {         if (GetValue(DefclassData(theEnv)->ObjectParseToken) == (void *) ctmp->cls->header.name)           {            PrintErrorID(theEnv,"INHERPSR",2,FALSE);            EnvPrintRouter(theEnv,WERROR,"A class may inherit from a superclass only once.\n");            goto SuperclassParseError;           }        }      sclass = LookupDefclassInScope(theEnv,ValueToString(GetValue(DefclassData(theEnv)->ObjectParseToken)));      if (sclass == NULL)        {         PrintErrorID(theEnv,"INHERPSR",3,FALSE);         EnvPrintRouter(theEnv,WERROR,"A class must be defined after all its superclasses.\n");         goto SuperclassParseError;        }      if ((sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]) ||          (sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS]) ||          (sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0]))        {         PrintErrorID(theEnv,"INHERPSR",6,FALSE);         EnvPrintRouter(theEnv,WERROR,"A user-defined class cannot be a subclass of ");         EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) sclass));         EnvPrintRouter(theEnv,WERROR,".\n");         goto SuperclassParseError;        }      ctmp = get_struct(theEnv,classLink);      ctmp->cls = sclass;      if (clink == NULL)        clink = ctmp;      else        cbot->nxt = ctmp;      ctmp->nxt = NULL;      cbot = ctmp;      SavePPBuffer(theEnv," ");      GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);     }   if (clink == NULL)     {      PrintErrorID(theEnv,"INHERPSR",4,FALSE);      EnvPrintRouter(theEnv,WERROR,"Must have at least one superclass.\n");      return(NULL);     }   PPBackup(theEnv);   PPBackup(theEnv);   SavePPBuffer(theEnv,")");   plinks = get_struct(theEnv,packedClassLinks);   PackClassLinks(theEnv,plinks,clink);   return(plinks);SuperclassParseError:   DeleteClassLinks(theEnv,clink);   return(NULL);  }/***************************************************************************  NAME         : FindPrecedenceList  DESCRIPTION  : A complete class precedence list is obtained from the                 list of direct superclasses as follows :                 Each class and its direct superclasses are recursively                 entered in order to a list called the partial order table.                 A class is only entered once.  The order reflects a pre-order                 depth-first traversal of the classes, and this order will be                 followed as closely as possible to preserve the "family"                 heuristic when constructing the class precedence list.                 Attached to each node is a count indicating the number of                 classes which must precede this class and a list of classes                 which must succeed this class (attached via the suc field and                 linked via nxt fields).  These predecessor counts                 and successor lists indicate the partial orderings given                 by the rules of multiple inheritance for the classes:                 1) a class must precede all its superclasses, and 2) a                 class determines the precedence of its immediate superclasses.                 For example, the following class definitions                 (defclass A (is-a USER))                 (defclass B (is-a USER))                 (defclass C (is-a A B))                 would give the following partial orders:                 C < A          by Rule 1                 C < B          by Rule 1                 A < B          by Rule 2                 B < USER       by Rule 1                 A < USER       by Rule 1                 USER < OBJECT  by Rule 1                 In turn, these partial orders would be recorded in a                 sequence table:                                     C     A      USER    OBJECT    B                 Predecessor Count   0     1       2        1       2                 Successor List     A,B  B,USER  OBJECT   <NIL>    USER                 To generate a precedence list for C, we pick the first                 class with a predecessor count of 0, append it to the                 precedence list, and decrement the counts of all its                 successors.  We continue scanning for a 0 from where                 we left off.  If we ever scan completely through the                 table without finding a 0, then we know there is an                 error.                 Shown below is the table above after each class is                 entered onto the precedence list:                 Precedence list: C                                     A      USER    OBJECT    B                 Predecessor Count   0       2        1       1                 Successor List     B,USER  OBJECT   <NIL>    USER                 Precedence list: C A                                    USER    OBJECT    B                 Predecessor Count   1        1       0                 Successor List     OBJECT   <NIL>   USER                 Precedence list: C A B                                    USER    OBJECT                 Predecessor Count   0        1                 Successor List     OBJECT   <NIL>                 Precedence list: C A B USER