clipsruby 0.0.2

data/ext/clipsruby/inherpsr.c

@@ -0,0 +1,850 @@
+   /*******************************************************/
+   /*      "C" Language Integrated Production System      */
+   /*                                                     */
+   /*            CLIPS Version 6.40  07/30/16             */
+   /*                                                     */
+   /*             MULTIPLE INHERITANCE PARSER MODULE      */
+   /*******************************************************/
+
+/*************************************************************/
+/* Purpose: Parsing Routines for Multiple Inheritance        */
+/*                                                           */
+/* Principal Programmer(s):                                  */
+/*      Brian L. Dantes                                      */
+/*                                                           */
+/* Contributing Programmer(s):                               */
+/*                                                           */
+/* Revision History:                                         */
+/*                                                           */
+/*      6.30: Changed integer type/precision.                */
+/*                                                           */
+/*            Added const qualifiers to remove C++           */
+/*            deprecation warnings.                          */
+/*                                                           */
+/*      6.40: Pragma once and other inclusion changes.       */
+/*                                                           */
+/*            Added support for booleans with <stdbool.h>.   */
+/*                                                           */
+/*            Removed use of void pointers for specific      */
+/*            data structures.                               */
+/*                                                           */
+/*************************************************************/
+
+/* =========================================
+   *****************************************
+               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 "pprint.h"
+#include "prntutil.h"
+#include "router.h"
+#include "scanner.h"
+
+#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;
+  };
+
+/***************************************/
+/* LOCAL INTERNAL FUNCTION DEFINITIONS */
+/***************************************/
+
+   static PARTIAL_ORDER          *InitializePartialOrderTable(Environment *,PARTIAL_ORDER *,PACKED_CLASS_LINKS *);
+   static void                    RecordPartialOrders(Environment *,PARTIAL_ORDER *,Defclass *,
+                                                      PACKED_CLASS_LINKS *,unsigned long);
+   static PARTIAL_ORDER          *FindPartialOrder(PARTIAL_ORDER *,Defclass *);
+   static void                    PrintPartialOrderLoop(Environment *,PARTIAL_ORDER *);
+   static void                    PrintClassLinks(Environment *,const char *,const 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
+ ***************************************************************/
+PACKED_CLASS_LINKS *ParseSuperclasses(
+  Environment *theEnv,
+  const char *readSource,
+  CLIPSLexeme *newClassName)
+  {
+   CLASS_LINK *clink = NULL,*cbot = NULL,*ctmp;
+   Defclass *sclass;
+   PACKED_CLASS_LINKS *plinks;
+
+   if (DefclassData(theEnv)->ObjectParseToken.tknType != LEFT_PARENTHESIS_TOKEN)
+     {
+      SyntaxErrorMessage(theEnv,"defclass inheritance");
+      return NULL;
+     }
+   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
+   if ((DefclassData(theEnv)->ObjectParseToken.tknType != SYMBOL_TOKEN) ? 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 (DefclassData(theEnv)->ObjectParseToken.tknType != RIGHT_PARENTHESIS_TOKEN)
+     {
+      if (DefclassData(theEnv)->ObjectParseToken.tknType != SYMBOL_TOKEN)
+        {
+         SyntaxErrorMessage(theEnv,"defclass");
+         goto SuperclassParseError;
+        }
+      if (FindModuleSeparator(newClassName->contents))
+        {
+         IllegalModuleSpecifierMessage(theEnv);
+         goto SuperclassParseError;
+        }
+      if (DefclassData(theEnv)->ObjectParseToken.value == (void *) newClassName)
+        {
+         PrintErrorID(theEnv,"INHERPSR",1,false);
+         WriteString(theEnv,STDERR,"A class may not have itself as a superclass.\n");
+         goto SuperclassParseError;
+        }
+      for (ctmp = clink ; ctmp != NULL ; ctmp = ctmp->nxt)
+        {
+         if (DefclassData(theEnv)->ObjectParseToken.value == (void *) ctmp->cls->header.name)
+           {
+            PrintErrorID(theEnv,"INHERPSR",2,false);
+            WriteString(theEnv,STDERR,"A class may inherit from a superclass only once.\n");
+            goto SuperclassParseError;
+           }
+        }
+      sclass = LookupDefclassInScope(theEnv,DefclassData(theEnv)->ObjectParseToken.lexemeValue->contents);
+      if (sclass == NULL)
+        {
+         PrintErrorID(theEnv,"INHERPSR",3,false);
+         WriteString(theEnv,STDERR,"A class must be defined after all its superclasses.\n");
+         goto SuperclassParseError;
+        }
+      if ((sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME_TYPE]) ||
+          (sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS_TYPE]) ||
+          (sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME_TYPE]->directSuperclasses.classArray[0]))
+        {
+         PrintErrorID(theEnv,"INHERPSR",6,false);
+         WriteString(theEnv,STDERR,"A user-defined class cannot be a subclass of '");
+         WriteString(theEnv,STDERR,DefclassName(sclass));
+         WriteString(theEnv,STDERR,"'.\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);
+      WriteString(theEnv,STDERR,"A class 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
+                                    OBJECT
+                 Predecessor Count   0
+                 Successor List     <NIL>
+
+                 Precedence List: C A B USER OBJECT
+
+                 And since the table is now empty we are done!
+  INPUTS       : 1) The old class definition (NULL if it is new)
+                 2) The list of direct superclasses
+  RETURNS      : The address of the precedence list if successful,
+                 NULL otherwise
+  SIDE EFFECTS : Precedence list allocated
+  NOTES        : WARNING!! - This routine assumes that there are no
+                 cyclic dependencies in the given superclass list, i.e.
+                 none of the superclasses inherit from the class for
+                 which the precedence list is being defined.  (This
+                 is verified in ParseDefclasses() in CLASSCOM.C)
+
+                 Every class-precedence list has the class itself on it
+                 (implicitly) and a built-in system class on it explicitly
+                 (except for the built-in classes).
+
+                 The precedence determination algorithm is a variation on
+                 the topological sorting algorithm given in The Art of
+                 Computer Programming - Vol. I (Fundamental Algorithms) by
+                 Donald Knuth.
+ ***************************************************************************/
+PACKED_CLASS_LINKS *FindPrecedenceList(
+  Environment *theEnv,
+  Defclass *cls,
+  PACKED_CLASS_LINKS *supers)
+  {
+   PARTIAL_ORDER *po_table = NULL,*start,*pop,*poprv,*potmp;
+   SUCCESSOR *stmp;
+   CLASS_LINK *ptop,*pbot,*ptmp;
+   PACKED_CLASS_LINKS *plinks;
+   unsigned long i;
+
+   /* =====================================================================
+      Recursively add all superclasses in a pre-order depth-first traversal
+      to the partial order table.  There should be only one node per class.
+      ===================================================================== */
+   po_table = InitializePartialOrderTable(theEnv,po_table,supers);
+
+   /* =============================================================
+      If the class already exists, record the rule 1 partial orders
+      with the new superclass lists.  This is so that cyclic
+      dependencies can be detected.
+      ============================================================= */
+   if (cls != NULL)
+     {
+      pop = get_struct(theEnv,partialOrder);
+      pop->cls = cls;
+      pop->pre = 0;
+      pop->suc = NULL;
+      pop->nxt = po_table;
+      po_table = pop;
+      pop = po_table->nxt;
+      RecordPartialOrders(theEnv,po_table,cls,supers,0);
+     }
+   else
+     pop = po_table;
+
+   /* ==================================================================
+      Record the rule 1 and rule 2 partial orders given by the direct
+      superclass lists of the classes in the table.  There is no need to
+      recurse since all possible classes have been entered already.
+
+      Be sure to skip the class itself if it was added to the front of
+      the table.
+      ================================================================== */
+   for ( ; pop != NULL ; pop = pop->nxt)
+     {
+      RecordPartialOrders(theEnv,po_table,pop->cls,&pop->cls->directSuperclasses,0);
+      for (i = 0 ; i < pop->cls->directSuperclasses.classCount ; i++)
+        RecordPartialOrders(theEnv,po_table,pop->cls->directSuperclasses.classArray[i],
+                            &pop->cls->directSuperclasses,i+1);
+     }
+
+   /* =============================================================
+      Record the rule 2 partial orders given by the superclass list
+      ============================================================= */
+   for (i = 0 ; i < supers->classCount ; i++)
+     RecordPartialOrders(theEnv,po_table,supers->classArray[i],supers,i+1);
+
+   start = NULL;
+   poprv = NULL;
+   pop = po_table;
+   ptop = pbot = NULL;
+   while (pop != start)
+     {
+      /* ==============================================================
+         Allow wraparound - happens when the search for a 0 node begins
+         somewhere in the middle of the sequence table
+         ============================================================== */
+      if (pop == NULL)
+        {
+         poprv = NULL;
+         pop = po_table;
+         start = start->nxt;
+        }
+
+      /* =========================================================
+         Search for the first class with no remaining predecessors
+         ========================================================= */
+      if (pop->pre == 0)
+        {
+         /* =================================================
+            Decrement the predecessor count for all the
+            successors of this class and delete the list.
+
+            This is the variation on Knuth's algorithm which
+            allows us to preserve the "family" heuristic.
+            Since we will pick up scanning for 0's from
+            this point, we will be able to keep "family"
+            trees together, if possible. BuildPartialOrders()
+            entered the classes into the sequence table
+            in a pre-order depth traversal order.
+            ================================================= */
+         while (pop->suc != NULL)
+           {
+            stmp = pop->suc;
+            pop->suc = stmp->nxt;
+            stmp->po->pre--;
+            rtn_struct(theEnv,successor,stmp);
+           }
+
+         /* =============================================
+            Append the class to the precedence list and
+            remove its entry from the partial order table
+            ============================================= */
+         potmp = pop;
+         if (poprv == NULL)
+           po_table = pop->nxt;
+         else
+           poprv->nxt = pop->nxt;
+         pop = pop->nxt;
+         start = poprv;
+         ptmp = get_struct(theEnv,classLink);
+         ptmp->cls = potmp->cls;
+         ptmp->nxt = NULL;
+         rtn_struct(theEnv,partialOrder,potmp);
+         if (ptop == NULL)
+           ptop = ptmp;
+         else
+           pbot->nxt = ptmp;
+         pbot = ptmp;
+        }
+      else
+        {
+         poprv = pop;
+         pop = pop->nxt;
+        }
+     }
+
+   /* ======================================================================
+      If the table of partial orders is not empty and we were unable to find
+      a class with no predecessors, then there is no solution! Print out the
+      precedence loop in the partial orders. Delete the remaining partial
+      order table and the partial precedence list.
+      ====================================================================== */
+   if (po_table != NULL)
+     {
+      PrintErrorID(theEnv,"INHERPSR",5,false);
+      PrintClassLinks(theEnv,STDERR,"Partial precedence list formed:",ptop);
+      PrintPartialOrderLoop(theEnv,po_table);
+      while (po_table != NULL)
+        {
+         while (po_table->suc != NULL)
+           {
+            stmp = po_table->suc;
+            po_table->suc = stmp->nxt;
+            rtn_struct(theEnv,successor,stmp);
+           }
+         potmp = po_table;
+         po_table = po_table->nxt;
+         rtn_struct(theEnv,partialOrder,potmp);
+        }
+      DeleteClassLinks(theEnv,ptop);
+      return NULL;
+     }
+
+   /* =============================================================================
+      If the class already existed, be sure and remove it from its own precedence
+      list.  Remember that we stuck it on the table artificially to catch cycles.
+      It was first in the table, and, since it started with a predecessor count
+      of zero (given that there were no loops), it is first in the precedence list.
+
+      We will leave the dummy node there so that functions which wish to iterate
+      over a class and its superclasses may easily do so.
+      ============================================================================= */
+   if (cls == NULL)
+     {
+      ptmp = get_struct(theEnv,classLink);
+      ptmp->nxt = ptop;
+      ptop = ptmp;
+     }
+
+   /* ============================================================
+      The class pointer will be filled in later by ParseDefclass()
+      ============================================================ */
+   ptop->cls = NULL;
+
+   plinks = get_struct(theEnv,packedClassLinks);
+   PackClassLinks(theEnv,plinks,ptop);
+   return(plinks);
+  }
+
+/***************************************************
+  NAME         : PackClassLinks
+  DESCRIPTION  : Writes a list of class links into
+                 a contiguous section of memory to
+                 reduce overhead (the original list
+                 is deleted)
+  INPUTS       : 1) The packed list structure to use
+                 2) The top of the original list
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : Packed list allocated and old list
+                 deleted
+  NOTES        : None
+ ***************************************************/
+void PackClassLinks(
+  Environment *theEnv,
+  PACKED_CLASS_LINKS *plinks,
+  CLASS_LINK *lptop)
+  {
+   unsigned count;
+   CLASS_LINK *lp;
+
+   for (count = 0 , lp = lptop ; lp != NULL ; lp = lp->nxt)
+     count++;
+   if (count > 0)
+     plinks->classArray = (Defclass **) gm2(theEnv,(sizeof(Defclass *) * count));
+   else
+     plinks->classArray = NULL;
+   for (count = 0 , lp = lptop ; lp != NULL ; lp = lp->nxt , count++)
+     plinks->classArray[count] = lp->cls;
+   DeleteClassLinks(theEnv,lptop);
+   plinks->classCount = count;
+  }
+
+/* =========================================
+   *****************************************
+          INTERNALLY VISIBLE FUNCTIONS
+   =========================================
+   ***************************************** */
+
+/**************************************************************************
+  NAME         : InitializePartialOrderTable
+  DESCRIPTION  : This function recursively enters the classes
+                 that will be used in a precedence list
+                 determination in depth-first pre-order traversal.
+                 The predecessor counts and successor list are initialized.
+
+  INPUTS       : 1) The partial order table
+                 2) A list of direct superclasses
+                 3) The class for which a precedence class is being
+                    determined (NULL for new class)
+                 4) The class which superclass list is being processed
+  RETURNS      : The top of partial order table
+  SIDE EFFECTS : The partial order table is initialized.
+  NOTES        : None
+ **************************************************************************/
+static PARTIAL_ORDER *InitializePartialOrderTable(
+  Environment *theEnv,
+  PARTIAL_ORDER *po_table,
+  PACKED_CLASS_LINKS *supers)
+  {
+   PARTIAL_ORDER *pop,*poprv;
+   unsigned long i;
+
+   for (i = 0 ; i < supers->classCount ; i++)
+     {
+      /* =================================================
+         Append this class at the end of the partial order
+         table only if it is not already present
+         ================================================= */
+      poprv = NULL;
+      for (pop = po_table ; pop != NULL ; pop = pop->nxt)
+        {
+         if (pop->cls == supers->classArray[i])
+           break;
+         poprv = pop;
+        }
+      if (pop == NULL)
+        {
+         pop = get_struct(theEnv,partialOrder);
+         pop->cls = supers->classArray[i];
+         pop->nxt = NULL;
+         pop->suc = NULL;
+         pop->pre = 0;
+         if (poprv == NULL)
+           po_table = pop;
+         else
+           poprv->nxt = pop;
+
+         /* =============================================================
+            Recursively append all its superclasses immediately after it.
+            This order will allow us to preserve the "family" heuristic
+            in the precedence list.
+            ============================================================= */
+         po_table = InitializePartialOrderTable(theEnv,po_table,
+                     &supers->classArray[i]->directSuperclasses);
+        }
+     }
+   return(po_table);
+  }
+
+/***********************************************************************************
+  NAME         : RecordPartialOrders
+  DESCRIPTION  : Given a predecessor class and a list of successor classes, this
+                 function enters a number of partial orders into the table equaling
+                 the number of successor classes.
+  INPUTS       : 1) The partial order table
+                 2) The predecessor class
+                 3) An array of successor classes
+                 4) A starting index for the successor classes
+  RETURNS      : The top of sequence table
+  SIDE EFFECTS : The sequence table is built, e.g.:
+
+                 CLASS1 < CLASS2 , CLASS3
+
+                 would be recorded as:
+
+                 PO_TABLE -> NXT     -> NXT       -> NXT ->   <NIL>
+                             <CLASS1>   <CLASS2>     <CLASS3>
+                             SUC        SUC          SUC
+                              |          |            |
+                              V          V            V
+                             <CLASS2>   <NIL>        <NIL>
+                             NXT
+                              |
+                              V
+                             <CLASS3>
+                             NXT
+                              |
+                              V
+                             <NIL>
+
+                 The predecessor counts would be 0, 1 and 1 for CLASS1, CLASS2
+                 and CLASS3 respectively.
+  NOTES        : None
+ ***********************************************************************************/
+static void RecordPartialOrders(
+  Environment *theEnv,
+  PARTIAL_ORDER *po_table,
+  Defclass *cls,
+  PACKED_CLASS_LINKS *successors,
+  unsigned long starti)
+  {
+   PARTIAL_ORDER *clspo;
+   SUCCESSOR *stmp;
+
+   clspo = FindPartialOrder(po_table,cls);
+   while (starti < successors->classCount)
+     {
+      stmp = get_struct(theEnv,successor);
+      stmp->po = FindPartialOrder(po_table,successors->classArray[starti]);
+      stmp->nxt = clspo->suc;
+      clspo->suc = stmp;
+      stmp->po->pre++;
+      starti++;
+     }
+  }
+
+/***************************************************
+  NAME         : FindPartialOrder
+  DESCRIPTION  : Finds a partial order node
+  INPUTS       : 1) The partial order table
+                 2) The class to look up
+  RETURNS      : The partial order node address
+  SIDE EFFECTS : None
+  NOTES        : None
+ ***************************************************/
+static PARTIAL_ORDER *FindPartialOrder(
+  PARTIAL_ORDER *po_table,
+  Defclass *cls)
+  {
+   while (po_table != NULL)
+     {
+      if (po_table->cls == cls)
+        break;
+      po_table = po_table->nxt;
+     }
+   return(po_table);
+  }
+
+/**************************************************************************
+  NAME         : PrintPartialOrderLoop
+  DESCRIPTION  : This routine prints a conflicting loop (there may be more
+                 than one) in the given sequence table of partial orders.
+
+                 The algorithm works as follows:
+
+                 Given the following class definitions,
+
+                 (defclass A (is-a USER))
+                 (defclass B (is-a USER))
+                 (defclass C (is-a A B))
+                 (defclass D (is-a B A))
+                 (defclass E (is-a C D))
+
+                 the partial order table will look as follows after as many
+                 classes as possible have been entered onto the precedence
+                 list:
+
+                                      A      USER    OBJECT   B
+                 Predecessor Count    1       2        1      1
+                 Successor List     B,USER  OBJECT   <NIL>   A,USER
+
+                 Construct a new table where each class is linked to one
+                 of its predecessors.  For the example above one would be:
+
+                 Class:            A    USER    OBJECT    B
+                 Predecessor:      B      A      USER     A
+
+                 This table is actually implemnted using the original
+                 partial order table (see the code below for specifics).
+                 Now using this table, start with the first node, and visit
+                 successive nodes by following the predecessor links.  Mark
+                 each node as "visited".  When a previously visited node is
+                 encountered, the loop has been found.
+
+                 In the case above, we start with A, goto B and then goto A
+                 again which we have already seen.  So starting from where
+                 we found the loop (A) we follow the links again, printing
+                 the nodes as we go, until we're back where we started:
+                 A B A.  Notice that this loop reflects the Rule 2 conflicts
+                 between Class C and Class D in Class E's precedence list.
+
+  INPUTS       : The remaining partial order table of conflicting partial
+                 orders
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : The predecessor counts and successor lists are modified to
+                 implement the loop detection.
+  NOTES        : This algorithm is adopted from one  given in Donald
+                 Knuth's The Art of Computer Programming - Vol. I
+                 (Fundamental Algorithms).
+ **************************************************************************/
+static void PrintPartialOrderLoop(
+  Environment *theEnv,
+  PARTIAL_ORDER *po_table)
+  {
+   PARTIAL_ORDER *pop1,*pop2;
+   SUCCESSOR *prc,*stmp;
+
+   /* ====================================================
+      Set the predecessor count of every node to 0 so that
+      this field can be used as a marker
+      ==================================================== */
+   for (pop1 = po_table ; pop1 != NULL ; pop1 = pop1->nxt)
+     pop1->pre = 0;
+
+   /* =======================================================
+      Mark each node in the partial order table with one of
+      its predecessors.  If the class has already been marked
+      (predecessor count > 0), don't bother.  This is
+      accomplished by adding a node to the front of its
+      successors' successor lists.
+
+      When the process is finished, all nodes will have one
+      predecessor chained to them by their 'suc' field.
+      (If any nodes had had no predecessors, they would not
+       still be in the table.)
+      ======================================================= */
+   for (pop1 = po_table ; pop1 != NULL ; pop1 = pop1->nxt)
+     {
+      if (pop1->pre == 0)
+        {
+         prc = pop1->suc;
+         pop1->suc = NULL;
+        }
+      else
+        {
+         prc = pop1->suc->nxt;
+         pop1->suc->nxt = NULL;
+        }
+      while (prc != NULL)
+        {
+         pop2 = FindPartialOrder(po_table,prc->po->cls);
+         if (pop2->pre == 0)
+           {
+            stmp = get_struct(theEnv,successor);
+            stmp->po = pop1;
+            stmp->nxt = pop2->suc;
+            pop2->suc = stmp;
+            pop2->pre = 1;
+           }
+         stmp = prc;
+         prc = prc->nxt;
+         rtn_struct(theEnv,successor,stmp);
+        }
+     }
+
+   /* =================================================
+      Set the predecessor count of every node back to 0
+      so that this field can be used as a marker again
+      ================================================= */
+   for (pop1 = po_table ; pop1 != NULL ; pop1 = pop1->nxt)
+     pop1->pre = 0;
+
+   /* =========================================================
+      Now start with the first node in the partial order table,
+      and follow the predecessor links, marking the
+      nodes as they are visited.  When we reach a node
+      we have been before, we have found a loop!
+      Follow all the marked nodes again  starting from the
+      CURRENT position to print the loop.
+      ========================================================= */
+   pop1 = po_table;
+   while (pop1->pre == 0)
+     {
+      pop1->pre = 1;
+      pop1 = pop1->suc->po;
+     }
+
+   WriteString(theEnv,STDERR,"Precedence loop in superclasses:");
+   while (pop1->pre == 1)
+     {
+      WriteString(theEnv,STDERR," ");
+      PrintClassName(theEnv,STDERR,pop1->cls,false,false);
+      pop1->pre = 0;
+      pop1 = pop1->suc->po;
+     }
+   WriteString(theEnv,STDERR," ");
+   PrintClassName(theEnv,STDERR,pop1->cls,false,true);
+  }
+
+/***************************************************
+  NAME         : PrintClassLinks
+  DESCRIPTION  : Displays the names of classes in
+                 a list with a title
+  INPUTS       : 1) The logical name of the output
+                 2) Title string
+                 3) List of class links
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : None
+  NOTES        : None
+ ***************************************************/
+static void PrintClassLinks(
+  Environment *theEnv,
+  const char *logicalName,
+  const char *title,
+  CLASS_LINK *clink)
+  {
+   if (title != NULL)
+     WriteString(theEnv,logicalName,title);
+   while (clink != NULL)
+     {
+      WriteString(theEnv,logicalName," ");
+      PrintClassName(theEnv,logicalName,clink->cls,false,false);
+      clink = clink->nxt;
+     }
+   WriteString(theEnv,logicalName,"\n");
+  }
+
+#endif
+