[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

check1.lisp (2/3)

;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
;;; All rights reserved.
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************

(in-package "PCL")

;;; This file contains:
;;;   * a new definition of compute-combination-point
;;;   * a new definition of compute-class-precedence-list
;;; This file is designed to be compiled and loaded in the 12/7/88
;;; version of PCL.  Attempting to load it into later versions of
;;; PCL can cause bad surprises.

;from miscellaneous places

(defun forward-referenced-class-p (x)
  (typep--class x 'forward-referenced-class))

;from defs.lisp

;;; This little macro requires one case for each of the currently defined
;;; kinds of specializers.  At macroexpansion time it will signal an error
;;; if an unsupplied case is found.  At runtime, it assumes the specializer
;;; argument is a legal specializer.  This means there is no error checking
;;; at all at runtime.
(defmacro specializer-case (specializer &body cases)
  (flet ((find-case (key)
	   (or (cdr (assq key cases))
	       (error "~S case not found." key))))
    (once-only (specializer)
      `(if (listp ,specializer)
	   (progn . ,(find-case :eql))
	   (progn . ,(find-case :class))))))

(defmacro specializer-cross-case (specializer-1 specializer-2 &body cases)
  (let ((otherwise (cdr (assq t cases))))
    (flet ((find-case (key)
	     (or (cdr (assq key cases))
		 (if otherwise
		     (error "~S case not found." key)))))
      (once-only (specializer-1 specializer-2)
	`(flet ,(and otherwise
		     `((.specializer-cross-case-otherwise. () . ,otherwise)))
	   (specializer-case ,specializer-1
	     (:eql   (specializer-case ,specializer-2
		       (:eql   . ,(find-case :eql-eql))
		       (:class . ,(find-case :eql-class))))
	     (:class (specializer-case ,specializer-2
		       (:eql   . ,(find-case :class-eql))
		       (:class . ,(find-case :class-class))))))))))

(defun specializer-eq (a b)
  (specializer-cross-case a b
    (:eql-eql     (eq (cadr a) (cadr b)))
    (:class-class (eq a b))
    (t nil)))
(defun specializer-assoc (specializer alist)
  (assoc specializer alist :test #'specializer-eq))

(defun sub-specializer-p (x y)
  (specializer-cross-case y x
    (:eql-eql     (eql (cadr x) (cadr y)))
    (:eql-class   nil)
    (:class-eql   (memq y (class-precedence-list (class-of (cadr x)))))
    (:class-class (memq y (class-precedence-list x)))))


;;; This code operates on a special kind of tree called a cptree (combination
;;; point tree).  A cptree is just a cpnode.  The cpnode contains the actual
;;; data stored at the cpnode, called the entry, and the subnodes.  This code
;;; doesn't define a special structure type for cpnodes.  It does define an
;;; abstraction for them though.
;;; The WALK-CPNODE and MAP-NODE functions are useful for operating on entire
;;; trees.
;;;  WALK-CPNODE applies the <function> argument to the entry of each cpnode
;;;              in the tree.  It proceeds in depth first order.  If at any 
;;;              point, the call to <function> returns non-nil, the walk is
;;;              terminated.
;;;  MAP-CPNODE  is like walk-cpnode except that it builds up a new tree.
;;;              The resultant tree has the same structure as the <node>
;;;              argument.  The node-entry at each node of the new tree
;;;              is the result of calling <function> on the corresponding
;;;              node-entry in the old tree.
;;;              If at any point, the second value returned by <function>
;;;              is non-nil, the walk is terminated.  In this case, the
;;;              result tree will have the same structure as the part of
;;;              input tree that was walked.
;;;   Some places in the code depend on CPNODEs being disjoint from lists.
(defmacro make-cpnode (entry subnodes)
  `(let ((.new-node. (make-array 2)))
     (setf (cpnode-entry .new-node.)     ,entry
	   (cpnode-subnodes .new-node.) ,subnodes)

(defmacro cpnode-entry (node)    `(svref ,node 0))
(defmacro cpnode-subnodes (node) `(svref ,node 1))

(defun walk-cpnode (node function)
  (funcall function (cpnode-entry node))
  (dolist (subnode (cpnode-subnodes node)) (walk-cpnode subnode function)))

(defun map-cpnode (node function)
  (make-cpnode (funcall function (cpnode-entry node))
	       (mapcar #'(lambda (subnode) (map-cpnode subnode function))
		       (cpnode-subnodes node))))

;;; Arrange for all of this to indent nicely in ZWEI.  Its amazingly stupid
;;; that this has to be evaluated after the functions are defined, but that
;;; is the way it goes.
  (zwei:defindentation (walk-cpnode 1 2))
  (zwei:defindentation (map-cpnode 1 2)))

;;; These entry types are used by code in combin.lisp to compute the so-called
;;; combination points of a generic function.  The full documentation for
;;; them appears there.  They are defined here for the obvious reason.

;;; point tree entries are used internally by CROSS-COLUMNS.
(defmacro make-point-entry (classes partial-method-order)
  `(vector ,classes ,partial-method-order nil ()))

(defmacro point-entry-classes    (point-entry) `(svref ,point-entry 0))
(defmacro point-entry-pmo        (point-entry) `(svref ,point-entry 1))
(defmacro point-entry-flag       (point-entry) `(svref ,point-entry 2))
(defmacro point-entry-cross-info (point-entry) `(svref ,point-entry 3))

;;; This entry type is used in the result of compute-columns.
(defmacro make-column-entry (class pmo)
  `(vector ,class ,pmo nil))

(defmacro column-entry-class (column-entry) `(svref ,column-entry 0))
(defmacro column-entry-pmo   (column-entry) `(svref ,column-entry 1))
(defmacro column-entry-flag  (column-entry) `(svref ,column-entry 2))

;;; The result of compute-precedence-dag is a tree with this entry type.
(defmacro make-cpd-entry (class precedence)
  `(vector ,class ,precedence nil))

(defmacro cpd-entry-class             (cpd-entry) `(svref ,cpd-entry 0))
(defmacro cpd-entry-precedence        (cpd-entry) `(svref ,cpd-entry 1))
(defmacro cpd-entry-multiple-supers-p (cpd-entry) `(svref ,cpd-entry 2))

;;; This entry type is used internally by compute-precedence-dag and friends.
;;; No entry with this type is ever returned by that function.
(defmacro make-cpdi-entry (class precedence)
  `(vector ,class ,precedence 0 () 'kept))

(defmacro cpdi-entry-class      (cpdi-entry) `(svref ,cpdi-entry 0))
(defmacro cpdi-entry-precedence (cpdi-entry) `(svref ,cpdi-entry 1))
(defmacro cpdi-entry-count      (cpdi-entry) `(svref ,cpdi-entry 2))
(defmacro cpdi-entry-supers     (cpdi-entry) `(svref ,cpdi-entry 3))
(defmacro cpdi-entry-status     (cpdi-entry) `(svref ,cpdi-entry 4))

;from combin.lisp
(defun *compute-combination-points (generic-function)
  (let ((methods (generic-function-methods generic-function)))
    (if (null (cdr methods))
	(list (list (method-type-specifiers (car methods)) methods))
	(let* ((precedence
		 ;; ***                                                    ***
		 ;; *** stupidly compute this for now.  Also have to fix   ***
		 ;; *** the lexical function inverse-precedence when this  ***
		 ;; *** is fixed                                           ***
		 ;; ***                                                    ***
		 (gathering1 (collecting)
		   (iterate ((i (interval :from 0))
			     (a (list-elements
				  (method-type-specifiers (car methods)))))
		     (progn a)
		     (gather1 i))))
	       (specializers (mapcar #'method-type-specifiers methods))
	       (columns (compute-columns specializers methods precedence)))
	  (cross-columns columns methods)))))

(defun cross-columns (columns all-methods)
  (cross-columns-main t (car columns) (cdr columns) all-methods))

(defun cross-columns-main (all-t-left-of-here first rest all-methods)
  (if (null rest)
      (cross-columns-null-rest all-t-left-of-here first all-methods)
      (let ((recurse
	      (cross-columns-main (and all-t-left-of-here (eq first 't))
				  (car rest)
				  (cdr rest)
	(if (eq first 't)
	    (cond (all-t-left-of-here
		   (dolist (point recurse) (push *the-class-t* (car point)))
		   (let ((flag (list nil)))
		     (walk-cpnode recurse
			#'(lambda (point-entry)
			    (unless (eq (point-entry-flag point-entry) flag)
			      (setf (point-entry-flag point-entry) flag)
			      (push *the-class-t*
				    (point-entry-classes point-entry))))))
	    (let ((points (full-on-column-cross first recurse)))
	      (if all-t-left-of-here
		  (progn (dolist (p points) (setf (cadr p)
						  (pmo->total (cadr p))))
		  (rebuild-combination-tree-from-points points)))))))

(defun cross-columns-null-rest (all-t-left-of-here first-column all-methods)
  (if (eq first-column 't)
      (if all-t-left-of-here
	  `((,*the-class-t*) ,all-methods)
	  (make-cpnode (make-point-entry (list *the-class-t*) all-methods)
      (if all-t-left-of-here
	  ;; In this case, we can just return a list of combination
	  ;; points, a point tree isn't needed.  Note that this also
	  ;; catches the case where there is only one column.
	  (gathering1 (collecting)
	    (walk-cpnode first-column		;Convert from a column tree
	       #'(lambda (column-entry)		;to actual points
		   (unless (column-entry-flag column-entry)
		     (setf (column-entry-flag column-entry) t) 
		     (let ((class (column-entry-class column-entry))
			   (pmo (column-entry-pmo column-entry)))
		       (when pmo
			 (gather1 `((,class) ,(pmo->total pmo)))))))))
	  ;; Need to make a tree because someone to the `left' of this
	  ;; column will need to do a full-on cross with it.
	  (map-cpnode first-column		;Convert from a column tree
	     #'(lambda (column-entry)		;to a combination point tree.
		 (let ((been-here (column-entry-flag column-entry)))
		   (if (and (neq been-here nil)
			    (neq been-here t))
		       (let* ((class (column-entry-class column-entry))
			      (pmo (column-entry-pmo column-entry))
			      (new-entry (make-point-entry (list class)
			 (setf (column-entry-flag column-entry) new-entry)

(defun full-on-column-cross (column point)
  (cross-column-with-point column point)
  (cross-point-with-column point column))

(defun cross-column-with-point (column point)
  (labels ((walk-column (cnode)
	     (let* ((centry (cpnode-entry cnode))
		    (cpmo   (column-entry-pmo centry)))
	       (unless (eq (column-entry-flag centry) 'been-here)
		 (setf (column-entry-flag centry) 'been-here)
		 (when cpmo (walk-point centry cpmo point t t))
		 (dolist (subnode (cpnode-subnodes cnode))
		   (walk-column subnode)))))
	   (walk-point (centry cpmo pnode super-crossed-pmo super-ppmo)
	     (let* ((pentry (cpnode-entry pnode))
		    (ppmo (point-entry-pmo pentry))
		    (force nil)
		    (crossed-pmo nil))
	       (unless (eq (point-entry-flag pentry) centry)	;Been here?
		 (setf (point-entry-flag pentry) centry)
		 (setq crossed-pmo (cross-pmos cpmo ppmo))
		 (setq force (equal ppmo super-ppmo))
		 (when (or force
			   (and crossed-pmo
				(not (equal crossed-pmo super-crossed-pmo))))
		   (setq super-crossed-pmo crossed-pmo)
		   (push (list centry force crossed-pmo)
			 (point-entry-cross-info pentry)))
		 (dolist (subnode (cpnode-subnodes pnode))
		   (walk-point centry cpmo subnode super-crossed-pmo ppmo))))))
    (walk-column column)))

(defun cross-point-with-column (point column)
  (gathering1 (collecting)
    (labels ((walk-point (pnode)
	       (let* ((pentry   (cpnode-entry pnode))
		      (pclasses (point-entry-classes pentry)))
		 (unless (eq (point-entry-flag pentry) 'been-here)
		   (setf (point-entry-flag pentry) 'been-here)
		   (walk-column pentry pclasses column t t)
		   (dolist (subnode (cpnode-subnodes pnode))
		     (walk-point subnode)))))
	     (walk-column (pentry pclasses cnode super-crossed-pmo super-cpmo)
	       (let* ((centry (cpnode-entry cnode))
		      (cclass (column-entry-class centry))
		      (cpmo   (column-entry-pmo centry)))
		 (unless (eq (column-entry-flag centry) pentry)	;Been here?
		   (setf (column-entry-flag centry) pentry)
		   (destructuring-bind (nil force crossed-pmo)
				       (assq centry
					     (point-entry-cross-info pentry))
		     (when (and crossed-pmo
				(or force 
				    (not (equal crossed-pmo super-crossed-pmo))
				    (equal super-cpmo cpmo)))
		       (setq super-crossed-pmo crossed-pmo)
		       (gather1 (list (cons cclass pclasses) crossed-pmo)))
		     (dolist (subnode (cpnode-subnodes cnode))
			 pentry pclasses subnode super-crossed-pmo cpmo)))))))
      (walk-point point))))

(defun rebuild-combination-tree-from-points (points)
  (labels ((insert-node (tree node entry methods)
	     (let ((subtrees (cpnode-subnodes tree))
		   (farther-down-p nil)
		   (between-here-and-sub-p nil))
	       ;; First try to stick it down below one of our subtrees.
	       ;; Note that it can go below more than one of our subtrees.
	       (dolist (sub subtrees)
		 (when (eq sub node) (return-from insert-node t))
		 (when (pmo-sub-p methods
				  (point-entry-pmo (cpnode-entry sub)))
		   (setq farther-down-p t)
		   (insert-node sub node entry methods)))
	       ;; Now try to put it between us and a subtree.
	       (dolist (sub subtrees)
		 (when (and (pmo-sub-p (point-entry-pmo (cpnode-entry sub)) 
			    (not (equal (point-entry-pmo (cpnode-entry sub)) 
		   (setf (cpnode-subnodes tree)
			 (remove sub (cpnode-subnodes tree)))
		   (push node (cpnode-subnodes tree))
		   (push sub (cpnode-subnodes node))
		   (setq between-here-and-sub-p t)))
	       ;; If it couldn't go below any of our subs, and it couldn't
	       ;; go between us and a sub, then it must just be a sub of
	       ;; us.  Do that.
	       (unless (or farther-down-p between-here-and-sub-p)
		 (push node (cpnode-subnodes tree))))))
    (let* ((t-point
	     (or (dolist (p points)
		   (when (every #'(lambda (x) (eq x *the-class-t*)) (car p))
		     (setq points (delete p points))
		     (return p)))
		 (list (make-list (length (caar points))
				  :initial-element *the-class-t*)
	   (result (make-cpnode (make-point-entry (car t-point) (cadr t-point))
      (dolist (point points)
	(let* ((entry (make-point-entry (car point) (cadr point)))
	       (node  (make-cpnode entry ())))
	  (insert-node result node entry (cadr point))))

;;; Returns a list of trees with entry type COLUMN-ENTRY.  Each tree in the
;;; list is the column combination for one column of the generic function.
;;; The list is in the same order as the precedence.  As a special case, if
;;; all the specializers of a column are T, the value for that column will
;;; be the symbol T.
;;; Each column is a fresh column since the COLUMN-ENTRY-FLAG field of the
;;; entries is intended to be modified by our caller.

(defun compute-columns (specializers methods precedence)
  (gathering1 (collecting)
    (dolist (n precedence)
      (gather1 (compute-one-column n specializers methods)))))

(defun compute-one-column (n specializers methods)
  (let* ((all-t-p t)
	   (mapcar #'(lambda (specializer-list)
		       (let ((specl (nth n specializer-list)))
			 (unless (eq specl *the-class-t*) (setq all-t-p nil))
    (if all-t-p
	(compute-one-column-internal specls methods))))

(defun compute-one-column-internal (specializers methods)
  (let ((been-here-alist ()))
    ;; CONVERT-1 actually converts a node and recurses.  CONVERT
    ;; deals with sharing in the result DAG by keeping track of
    ;; whether a node in the precedence has been visited before.
    (labels ((convert (cpd-node)
	       (let ((cpd-entry (cpnode-entry cpd-node))
		     (cpd-subnodes (cpnode-subnodes cpd-node)))
		 (if (cpd-entry-multiple-supers-p cpd-entry)
		     ;; Since this node has multiple supers, it is possible
		     ;; to visit it more than once.  Deal with the multiple
		     ;; visits stuff.  Note, have to maintain the separate
		     ;; alist because we aren't allowed to mutate precedence
		     ;; dags.
		     (let ((been-here (assq cpd-node been-here-alist)))
		       (if been-here
			   (cdr been-here)
			   (let ((new-node
				   (convert-1 cpd-entry cpd-subnodes)))
			     (push (cons cpd-node new-node) been-here-alist)
		     ;; No multiple supers means charge ahead!
		     (convert-1 cpd-entry cpd-subnodes))))
	     (convert-1 (cpd-entry cpd-subnodes)
	       (make-cpnode (make-column-entry
			      (cpd-entry-class cpd-entry)
			      (precedence->pmo (cpd-entry-precedence cpd-entry)
			    (mapcar #'convert cpd-subnodes))))
      (convert (compute-precedence-dag specializers)))))

;;; Random useful functions for manipulating partial method orders.
;;; A partial method order is just a set of methods which are ordered by
;;; one column in a combination.  A partial method order supplies absolute
;;; ordering information between some methods and no ordering information
;;; between other methods.  Its best described by example:
;;;   (M1 M2 M3)        Actually, this is a total order.
;;;   (M1 (M2 M3) M4)   M1 must precede M2, M3 and M4
;;;                     M2 must precede M4
;;;                     M3 must precede M4
;;;                     the order of M2 and M3 is unspecified
;;;   ((M1 M2) (M3 M4)) M1 must precede M3 and M4
;;;                     M2 must precede M3 and M4
;;;                     ordering of M1 and M2 unspecified
;;;                     ordering of M3 and M4 unspecified
;;; In other words, a partial method order is a list whose elements may be
;;; lists.  The top-level list provides ordering information.  Methods in
;;; the top level list must precede the `flattened' part of the list that
;;; follows them.  But, when an element of the top level list is itself a
;;; list, no ordering among those sublist elements is specified.
;;; The most important operation defined on partial method orders is a kind
;;; of cross product.  The result is a partial method order with only those
;;; methods that appeared in both inputs.  The order of the result is as
;;; specified by the first input, except that where the first input doesn't
;;; specify ordering between two methods, the ordering is taken from the
;;; second input.  If neither input provides ordering then there will be
;;; partial ordering in the result.

(defun precedence->pmo (precedence specializers methods)
  (gathering1 (collecting)
    (dolist (p precedence)
      (let ((last-hit-state nil)
	    (last-hit-p nil)
	    (last-hit-m nil))
	(flet ((enqueue (m)
		 (ecase last-hit-state
		   ((nil) (setq last-hit-state 'one
				last-hit-p p
				last-hit-m m))
		   (one   (setq last-hit-state 'two
				last-hit-m (list m last-hit-m)))
		   (two   (push m last-hit-m))))
	       (flush-queue ()
		 (ecase last-hit-state
		   ((nil) ())
		   (one   (gather1 last-hit-m))
		   (two   (gather1 (nreverse last-hit-m))))
		 (setq last-hit-state nil
		       last-hit-p nil)))
	  (do ((s specializers (cdr s))
	       (m methods (cdr m)))
	      ((null s) (flush-queue))
	    (when (specializer-eq (car s) p)
	      (enqueue (car m)))))))))

(defun pmo->total (pmo)
  (gathering1 (collecting)
    (dolist (e pmo)
      (if (not (listp e))
	  (gather1 e)
	  (dolist (ee e) (gather1 ee))))))

(defun pmo-nelements (pmo)
  (let ((n 0))
    (dolist (e pmo)
      (if (not (listp e))
	  (incf n)
	  (incf n (length e))))

(defun cross-pmos (pmo-1 pmo-2)
  (let* ((result (list nil))
	 (tail result)
	 (subsetp-flag t))
    (flet ((gather (m) (setq tail (setf (cdr tail) (list m)))))
      (dolist (e1 pmo-1)
	(if (not (listp e1))
	    (if (pmo-memq e1 pmo-2)
		(gather e1)
		(unless (eq subsetp-flag '?) (setq subsetp-flag nil)))
	    ;; This element of pmo-1 is a list.  That means
	    ;; pmo-1 supplies no ordering information among
	    ;; the elements of this list.  Now go use the order
	    ;; of pmo-2 to try and place elements of this
	    ;; list in the result.
	      (setq subsetp-flag '?)
	      (dolist (e2 pmo-2)
		(if (not (listp e2))
		    (if (memq e2 e1)
			(gather e2)
		    ;; Holy Shit Batman, we have come across a list in
		    ;; both pmo-1 and pmo-2.  The intersection
		    ;; of the two goes into the result now.
		    (let ((result (intersection e1 e2)))
		      (cond ((null result))
			    ((cdr result) (gather result))
			    (t (gather (car result)))))))))))
    (values (cdr result)
	    (ecase subsetp-flag
	      ((nil) nil)
	      ((t)   t)
	      (? (pmo-subsetp pmo-1 (cdr result)))))))

(defun pmo-subsetp (pmo-1 pmo-2)
  (dolist (e1 pmo-1 t)
    (if (not (listp e1))
	(unless (pmo-memq e1 pmo-2)  (return-from pmo-subsetp nil))
	(dolist (ee1 e1)
	  (unless (pmo-memq ee1 pmo-2) (return-from pmo-subsetp nil))))))

(defun pmo-memq (x pmo)
  (do* ((tail pmo (cdr tail))
	(e (car tail) (car tail)))
       ((null tail) nil)
    (if (not (listp e))
	(when (eq x e) (return tail))
	(when (memq x e) (return tail)))))

(defun pmo-sub-p (sub-pmo super-pmo)
  (dolist (super-e super-pmo t)
    (if (not (listp super-e))
	(unless (setq sub-pmo (pmo-memq super-e sub-pmo)) (return nil))
	(let ((farthest sub-pmo))
	  (dolist (super-ee super-e)
	    (do* ((tail sub-pmo (cdr tail))
		  (sub-e (car tail) (car tail)))
		 ((null tail) (return-from pmo-sub-p nil))
	      (if (not (listp sub-e))
		  (when (eq super-ee sub-e) (return 't))
		  (when (memq super-ee sub-e) (return 't)))
	      (when (eq farthest tail) (pop farthest))))
	  (setq sub-pmo farthest)))))

;;; The reason this value is split out is that it can be meaningfully cached.
;;; It is reasonable to expect that generic functions will have the same sets
;;; of specializers, so caching this value can save time.  This is especially
;;; winning since this is the part of this algorithm that takes the most work.
;;; The cache must be cleared whenever any class changes its class precedence
;;; list.  It does not need to be reset when a class gets a cpl for the very
;;; first time.  The cache reseting code could be changed pretty easily to
;;; invalidate less of the cache when something changes.  That is left as an
;;; exercise for future users.
(defvar *precedence-dag-cache* (make-hash-table :test #'equal :size 500))
(defvar *enable-precedence-dag-caching* 't)
(defun clear-precedence-dag-cache () (clrhash *precedence-dag-cache*))

(defun compute-precedence-dag (classes)
  (setq classes (remove-duplicates classes))
  (if (null *enable-precedence-dag-caching*)
      (compute-precedence-dag-1 classes)
      (let ((key (sort (copy-list classes)
		       #'(lambda (c1 c2)
			   (let ((cpl1 (class-precedence-list c1))
				 (cpl2 (class-precedence-list c2)))
			     (cond ((memq c2 cpl1) t)
				   ((memq c1 cpl2) nil)
				   (t (< (length cpl2) (length cpl1)))))))))
	(or (gethash key *precedence-dag-cache*)
	    (setf (gethash key *precedence-dag-cache*)
		  (compute-precedence-dag-1 classes))))))

;;; The code which actually builds the precedence dag works in three passes.
;;; The first two passes operate on a tree with an entry type specialized to
;;; this code.  The third pass uses that specialized tree to produce actual
;;; result tree.
;;; The specialized entry type used by this code is called CPDI-ENTRY.  CPDI
;;; is an abbreviation for Class Precedence Dag Internal.  These entries are
;;; created by the macro MAKE-CPDI-ENTRY.  These entries have 5 fields:
;;;     The class object for this entry.
;;;     The precedence of CLASSES at this node.
;;;     A list of the super nodes of this node.
;;;     At the end of the first pass, this is the length of
;;;     ENTRY-SUPERS.  During the second pass, this value is
;;;     decremented each time a node is encountered. When this
;;;     counter reaches zero, it means all the parents of this
;;;     node have been visited.  This gets parents first search.
;;;     The second pass uses this field to mark nodes as being
;;;     either KEPT or DELETED.  In the third pass this field
;;;     is used to know which nodes to place in the result and
;;;     to implement structure sharing in the result.  The first
;;;     a kept subtree is visited, this field is filled with the
;;;     result subtree for that subtree so that that result can
;;;     be used again if the kept node is encountered again.
;;; Entries in the returned tree are called CPD-ENTRY.  CPD is an abbreviation
;;; for Class Precedence Dag.  These have three fields:
;;;     The class object.
;;;     The precedence at this point in the dag.
;;;     A boolean flag indicating whether this subtree has multiple
;;;     supers in the dag.  Our caller is free to use this as an
;;;     optimization when detecting multiple inheritance in the dag.
;;; The first pass is the BUILD pass.  This builds a skeleton of the complete
;;; class DAG.  This skeleton includes:
;;;   * The class named T (the top of the tree).
;;;   * Each class in CLASSES.
;;;   * Any other class having the following properties:
;;;      - has multiple supers
;;;      - is a subclass of more than one class in CLASSES
;;;      - more than one of the supers is itself a subclass
;;;        of some class in CLASSES
;;; The second pass (REDUCE) goes through and marks some of the nodes deleted.
;;; Nodes are deleted when they have the same precedence as THE ONE of their
;;; parent nodes they inherit from.  This pass uses parents first traversal of
;;; the tree.  Parents first traversal means that when considering whether to
;;; delete or keep a node,  the status of each of its parents is known.  Using
;;; the class precedence list of the node, we can determine which of the kept
;;; parents the node will inherit from.
;;; The third pass (COLLECT) simply builds the returned tree by including one
;;; node for each kept node in the tree produced by pass 1 and 2.
(defun compute-precedence-dag-1 (classes)
  (let* ((top-entry (make-cpdi-entry *the-class-t* 
				     (remove-if #'(lambda (x)
						    (neq x *the-class-t*))
	 (top-of-tree (make-cpnode top-entry ())))
    (compute-precedence-dag-pass-1 classes top-of-tree)
    (compute-precedence-dag-pass-2 top-of-tree)
    (compute-precedence-dag-pass-3 top-of-tree)))

(defun compute-precedence-dag-pass-1 (classes tree)
  (let ((been-here-alist ()))
    (labels ((insert (tree new-node new-entry class cpl)
	       (let ((subtrees (cpnode-subnodes tree))
		     (inserted-somewhere-below-here-p nil))
		 ;; First see if the new node can be inserted below
		 ;; any of our subtrees.  Note that a new node can
		 ;; be below more than one of our subtrees.
		 (dolist (subtree subtrees)
		   (let* ((subentry (cpnode-entry subtree))
			  (subclass (cpdi-entry-class subentry)))
		     (when (memq subclass cpl)
		       (setq inserted-somewhere-below-here-p t)
		       (insert subtree new-node new-entry class cpl))))
		 ;; Then see if the new node can be inserted above
		 ;; any of our subtrees.  Note that a new node can
		 ;; be above some of our subtrees and below others.
		 (dolist (subtree subtrees)
		   (let* ((subentry (cpnode-entry subtree))
			  (subclass (cpdi-entry-class subentry)))
		     (when (memq class (class-precedence-list subclass))
		       (setq inserted-somewhere-below-here-p t)
		       (unlink subtree subentry tree)      ;sub not below us
		       (link new-node new-entry tree)	   ;new below us
		       (link subtree subentry new-node)))) ;sub below new

		 (unless inserted-somewhere-below-here-p
		   (link new-node new-entry tree))))

	     (build (node class)
	       (unless (or (eq class *the-class-t*)
			   (eq class *the-class-object*))
		 (dolist (subclass (class-direct-subclasses class))
		   (build-1 node subclass))))
	     (build-1 (node subclass)
	       (let ((been-here (assq subclass been-here-alist)))
		 (if been-here
		     ;; If we have already encountered this class, then
		     ;; record this possibly new path to whatever nodes
		     ;; are below it.  Note that we are relying on LINK
		     ;; not to record redundant relationships.
		     (dolist (old-node (cdr been-here))
		       (link old-node (cpnode-entry old-node) node))
		     (let ((cpl (class-precedence-list subclass)))
		       (if (class-goes-in-p subclass cpl)
			   ;; A new node has to go into the tree for this
			   ;; subclass.  Create that node, insert it, and
			   ;; then recurse with it.
			   (let* ((precedence (compute-precedence cpl))
				  (new-entry (make-cpdi-entry subclass
				  (new-node (make-cpnode new-entry ())))
			     (link new-node new-entry node)
			     (push (list subclass new-node) been-here-alist)
			     (build new-node subclass))
			   ;; No new node for this class.  But we do have
			   ;; to be sure to record this class on the been
			   ;; here alist.
			   (let ((existing (cpnode-subnodes node))
				 (been-here (list subclass)))
			     (build node subclass)
			     (dolist (new-sub (cpnode-subnodes node))
			       (unless (memq new-sub existing)
				 (push new-sub (cdr been-here))
				 (link new-sub (cpnode-entry new-sub) node)))
			     (push been-here been-here-alist)))))))

	     (class-goes-in-p (class cpl)
	       (let ((supers (class-local-supers class)))
		 (or (memq class classes)
		     (and (cdr supers)
			  (let ((state nil))	;More than one class
			    (dolist (class cpl)	;from classes in cpl?
			      (when (memq class classes)
				(if (eq state nil)
				    (setq state t)
				    (return 't)))))
			  (let ((state nil))
			    (block check-supers
			      (dolist (sup supers)
				(dolist (class (class-precedence-list sup))
				  (when (memq class classes)
				    (if (null state)
					(setq state t)
					(return-from check-supers 't)))))))))))

	     (compute-precedence (cpl)
	       (gathering1 (collecting)
		 (dolist (class cpl)
		   (when (memq class classes) (gather1 class)))))

	     (link (subnode subentry supnode)
	       (unless (memq subnode (cpnode-subnodes supnode))
		 (push subnode (cpnode-subnodes supnode))
		 (incf (cpdi-entry-count subentry))
		 (push supnode (cpdi-entry-supers subentry))))

	     (unlink (subnode subentry supnode)
	       (when (memq subnode (cpnode-subnodes supnode))
		 (setf (cpnode-subnodes supnode)
		       (delete subnode (cpnode-subnodes supnode)))
		 (decf (cpdi-entry-count subentry))
		 (setf (cpdi-entry-supers subentry)
		       (delete supnode (cpdi-entry-supers subentry))))))
      (dolist (class classes)
	(unless (or (eq class *the-class-t*)
		    (assq class been-here-alist))
	  (let* ((cpl (class-precedence-list class))
		 (precedence (compute-precedence cpl))
		 (new-entry (make-cpdi-entry class precedence))
		 (new-node (make-cpnode new-entry ())))
	    (insert tree new-node new-entry class cpl)
	    (push (list class new-node) been-here-alist)
	    (build new-node class))))

(defun compute-precedence-dag-pass-2 (tree)
  (labels ((reduce (node)
	     (let* ((entry (cpnode-entry node))
		    (subs  (cpnode-subnodes node))
		    (class ())
		    (rcpl  ())
		    (supers ())
		    (precedence ())
		    (kept-super nil))
	       (if (> (cpdi-entry-count entry) 1)
		   (decf (cpdi-entry-count entry))
		     (when (setq supers (cpdi-entry-supers entry))
		       (setq precedence (cpdi-entry-precedence entry)
			     class (cpdi-entry-class entry)
			     rcpl (reverse (class-precedence-list class))
			     kept-super (get-kept-super supers rcpl))
		       (when (and kept-super
				  (equal (cpdi-entry-precedence
			 (setf (cpdi-entry-status entry) 'deleted)))
		     (dolist (sub subs) (reduce sub))))))
	   (get-kept-super (supers rcpl)
	     (when supers
	       (let* ((best-super (car supers))
			(memq (cpdi-entry-class (cpnode-entry best-super))
		 (dolist (s (cdr supers))
		   (let ((tail (memq (cpdi-entry-class (cpnode-entry s))
		     (when tail
		       (setq best-rcpl-tail tail
			     best-super s))))
		 (if (eq (cpdi-entry-status (cpnode-entry best-super)) 'kept)
		     (values best-super best-rcpl-tail)
		     (let ((best-sub-super nil)
			   (best-sub-rcpl-tail ()))
		       (dolist (s supers)
			 (multiple-value-bind (sub-super sub-rcpl-tail)
			     (get-kept-super (cpdi-entry-supers (cpnode-entry s))
			   (when (and sub-super
				      (or (null best-sub-super)
					  (tailp sub-rcpl-tail
			     (setq best-sub-super sub-super
				   best-sub-rcpl-tail sub-rcpl-tail))))
		       (values best-sub-super best-sub-rcpl-tail)))))))
    (reduce tree)))

(defun compute-precedence-dag-pass-3 (tree)
  (labels ((collect (node previous-precedence)
	     (let* ((entry (cpnode-entry node))
		    (subnodes  (cpnode-subnodes node))
		    (status (cpdi-entry-status entry))
		    (precedence (cpdi-entry-precedence entry)))
	       (case (cpdi-entry-status entry)
		   (when (sub-precedence-p precedence previous-precedence)
		     (let* ((result-entry
			      (make-cpd-entry (cpdi-entry-class entry)
			      (make-cpnode result-entry
					   (collect-1 subnodes precedence))))
		       (setf (cpdi-entry-status entry) (list result-node)))))
		   (collect-1 subnodes previous-precedence))
		   ;; We have been here before, mark the node(s) as
		   ;; having multiple supers and return them.
		   (dolist (node status)
		     (let ((entry (cpnode-entry node)))
		       (setf (cpd-entry-multiple-supers-p entry) 't)))
	   (collect-1 (subnodes previous-precedence)
	     (gathering1 (joining)
	       (dolist (subnode subnodes)
		   (copy-list (collect subnode previous-precedence))))))
	   (sub-precedence-p (sub sup)
	     (dolist (c sup t)
	       (unless (setq sub (memq c sub)) (return nil)))))
    (car (collect tree ()))))


;from std-class.lisp

;;; compute-class-precedence-list
;;; Knuth section 2.2.3 has some interesting notes on this.
;;; What appears here is basically the algorithm presented there.
;;; The key idea is that we use class-precedence-description (CPD) structures
;;; to store the precedence information as we proceed.  The CPD structure for
;;; a class stores two critical pieces of information:
;;;  - a count of the number of "reasons" why the class can't go
;;;    into the class precedence list yet.
;;;  - a list of the "reasons" this class prevents others from
;;;    going in until after it
;;; A "reason" is essentially a single local precedence constraint.  If a
;;; constraint between two classes arises more than once it generates more
;;; than one reason.  This makes things simpler, linear, and isn't a problem
;;; as long as we make sure to keep track of each instance of a "reason".
;;; This code is divided into three phases.
;;;  - the first phase simply generates the CPD's for each of the class
;;;    and its superclasses.  The remainder of the code will manipulate
;;;    these CPDs rather than the class objects themselves.  At the end
;;;    of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
;;;    of the direct superclasses of the class.
;;;  - the second phase folds all the local constraints into the CPD
;;;    structure.  The CPD-COUNT of each CPD is built up, and the
;;;    CPD-AFTER fields are augmented to include precedence constraints
;;;    from the CPD-SUPERS field and from the order of classes in other
;;;    CPD-SUPERS fields.
;;;    After this phase, the CPD-AFTER field of a class includes all the
;;;    direct superclasses of the class plus any class that immediately
;;;    follows the class in the direct superclasses of another.  There
;;;    can be duplicates in this list.  The CPD-COUNT field is equal to
;;;    the number of times this class appears in the CPD-AFTER field of
;;;    all the other CPDs.
;;;  - In the third phase, classes are put into the precedence list one
;;;    at a time, with only those classes with a CPD-COUNT of 0 being
;;;    candidates for insertion.  When a class is inserted , every CPD
;;;    in its CPD-AFTER field has its count decremented.
;;;    In the usual case, there is only one candidate for insertion at
;;;    any point.  If there is more than one, the specified tiebreaker
;;;    rule is used to choose among them.

(defstruct (class-precedence-description
	     (:conc-name nil)
	     (:print-function (lambda (obj str depth)
				(declare (ignore depth))
				(format str
					"#<CPD ~S ~D>"
					(class-name (cpd-class obj))
					(cpd-count obj))))
	     (:constructor make-cpd ()))
  (cpd-class  nil)
  (cpd-supers ())
  (cpd-after  ())
  (cpd-count  0))

(defun compute-std-cpl (class)
  (let ((supers (class-local-supers class)))
    (cond ((null supers)			;First two branches of COND
	   (list class))			;are implementing the single
	  ((null (cdr supers))			;inheritance optimization.
	   (cons class (compute-std-cpl (car supers))))
	   (multiple-value-bind (all-cpds nclasses)
	       (compute-std-cpl-phase-1 class supers)
	     (compute-std-cpl-phase-2 all-cpds)
	     (compute-std-cpl-phase-3 class all-cpds nclasses))))))

(defvar *compute-std-cpl-class->entry-table-size* 60)

(defun compute-std-cpl-phase-1 (class supers)
  (let ((nclasses 0)
	(all-cpds ())
	(table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
				:test #'eq)))
    (labels ((get-cpd (c)
	       (or (gethash c table)
		   (setf (gethash c table) (make-cpd))))
	     (walk (c supers)
	       (if (forward-referenced-class-p c)
		   (cpl-forward-referenced-class-error class c)
		   (let ((cpd (get-cpd c)))
		     (unless (cpd-class cpd)	;If we have already done this
						;class before, we can quit.
		       (setf (cpd-class cpd) c)
		       (incf nclasses)
		       (push cpd all-cpds)
		       (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
		       (dolist (super supers)
			 (walk super (class-local-supers super))))))))
      (walk class supers)
      (values all-cpds nclasses))))

(defun compute-std-cpl-phase-2 (all-cpds)
  (dolist (cpd all-cpds)
    (let ((supers (cpd-supers cpd)))
      (when supers
	(setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
	(incf (cpd-count (car supers)) 1)
	(do* ((t1 supers t2)
	      (t2 (cdr t1) (cdr t1)))
	     ((null t2))
	  (incf (cpd-count (car t2)) 2)
	  (push (car t2) (cpd-after (car t1))))))))

(defun compute-std-cpl-phase-3 (class all-cpds nclasses)
  (let ((candidates ())
	(next-cpd nil)
	(rcpl ()))
    ;; We have to bootstrap the collection of those CPD's that
    ;; have a zero count.  Once we get going, we will maintain
    ;; this list incrementally.
    (dolist (cpd all-cpds)
      (when (zerop (cpd-count cpd)) (push cpd candidates)))

      (when (null candidates)
	;; If there are no candidates, and enough classes have been put
	;; into the precedence list, then we are all done.  Otherwise
	;; it means there is a consistency problem.
	(if (zerop nclasses)
	    (return (reverse rcpl))
	    (cpl-inconsistent-error class all-cpds)))
      ;; Try to find the next class to put in from among the candidates.
      ;; If there is only one, its easy, otherwise we have to use the
      ;; famous RPG tiebreaker rule.  There is some hair here to avoid
      ;; having to call DELETE on the list of candidates.  I dunno if
      ;; its worth it but what the hell.
      (setq next-cpd
	    (if (null (cdr candidates))
		(prog1 (car candidates)
		       (setq candidates ()))
		(block tie-breaker		      
		  (dolist (c rcpl)
		    (let ((supers (class-local-supers c)))
		      (if (memq (cpd-class (car candidates)) supers)
			  (return-from tie-breaker (pop candidates))
			  (do ((loc candidates (cdr loc)))
			      ((null (cdr loc)))
			    (let ((cpd (cadr loc)))
			      (when (memq (cpd-class cpd) supers)
				(setf (cdr loc) (cddr loc))
				(return-from tie-breaker cpd))))))))))
      (decf nclasses)
      (push (cpd-class next-cpd) rcpl)
      (dolist (after (cpd-after next-cpd))
	(when (zerop (decf (cpd-count after)))
	  (push after candidates))))))

;;; Support code for signalling nice error messages.

(defun cpl-error (class format-string &rest format-args)
  (error "While computing the class precedence list of the class ~A.~%~A"
	  (if (class-name class)
	      (format nil "named ~S" (class-name class))
	  (apply #'format nil format-string format-args)))

(defun cpl-forward-referenced-class-error (class forward-class)
  (flet ((class-or-name (class)
	   (if (class-name class)
	       (format nil "named ~S" (class-name class))
    (let ((names (mapcar #'class-or-name
			 (cdr (find-superclass-chain class forward-class)))))
      (cpl-error class
		 "The class ~A is a forward referenced class.~@
                  The class ~A is ~A."
		 (class-or-name forward-class)
		 (class-or-name forward-class)
		 (if (null (cdr names))
		     (format nil
			     "a direct superclass of the class ~A"
			     (class-or-name class))
		     (format nil
			     "reached from the class ~A by following~@
                              the direct superclass chain through: ~A~
                              ~%  ending at the class ~A"
			     (class-or-name class)
			     (format nil
				     "~{~%  the class ~A,~}"
				     (butlast names))
			     (car (last names))))))))

(defun find-superclass-chain (bottom top)
  (labels ((walk (c chain)
	     (if (eq c top)
		 (return-from find-superclass-chain (nreverse chain))
		 (dolist (super (class-local-supers c))
		   (walk super (cons super chain))))))
    (walk bottom (list bottom))))

(defun cpl-inconsistent-error (class all-cpds)
  (let ((reasons (find-cycle-reasons all-cpds)))
    (cpl-error class
      "It is not possible to compute the class precedence list because~@
       there ~A in the local precedence relations.~@
       ~A because:~{~%  ~A~}."
      (if (cdr reasons) "are circularities" "is a circularity")
      (if (cdr reasons) "These arise" "This arises")
      (format-cycle-reasons (apply #'append reasons)))))

(defun format-cycle-reasons (reasons)
  (flet ((class-or-name (cpd)
	   (let ((class (cpd-class cpd)))
	     (if (class-name class)
		 (format nil "named ~S" (class-name class))
      #'(lambda (reason)
	  (ecase (caddr reason)
		"the class ~A appears in the supers of the class ~A"
		(class-or-name (cadr reason))
		(class-or-name (car reason))))
		"the class ~A follows the class ~A in the supers of the class ~A"
		(class-or-name (cadr reason))
		(class-or-name (car reason))
		(class-or-name (cadddr reason))))))      

(defun find-cycle-reasons (all-cpds)
  (let ((been-here ())           ;List of classes we have visited.
	(cycle-reasons ()))
    (labels ((chase (path)
	       (if (memq (car path) (cdr path))
		   (record-cycle (memq (car path) (nreverse path)))
		   (unless (memq (car path) been-here)
		     (push (car path) been-here)
		     (dolist (after (cpd-after (car path)))
		       (chase (cons after path))))))
	     (record-cycle (cycle)
	       (let ((reasons ()))
		 (do* ((t1 cycle t2)
		       (t2 (cdr t1) (cdr t1)))
		      ((null t2))
		   (let ((c1 (car t1))
			 (c2 (car t2)))
		     (if (memq c2 (cpd-supers c1))
			 (push (list c1 c2 :super) reasons)
			 (dolist (cpd all-cpds)
			   (when (memq c2 (memq c1 (cpd-supers cpd)))
			       (push (list c1 c2 :in-supers cpd) reasons)))))))
		 (push (nreverse reasons) cycle-reasons))))
      (dolist (cpd all-cpds)
	(unless (zerop (cpd-count cpd))
	  (chase (list cpd))))