From 91d9ba3cb6ed57640dc29c2b2e73bb89e2628484 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 26 May 2016 09:26:09 +0100
Subject: [PATCH] doc/list-exports.lisp: Support use of CMUCL MOP.

---
 doc/list-exports.lisp | 48 ++++++++++++++++++++++++++----------------------
 1 file changed, 26 insertions(+), 22 deletions(-)

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index eab4d54..5eab34e 100644
--- a/doc/list-exports.lisp
+++ b/doc/list-exports.lisp
@@ -1,7 +1,11 @@
 (cl:defpackage #:sod-exports
-  (:use #:common-lisp))
+  (:use #:common-lisp
+	#+cmu #:mop
+	#+sbcl #:sb-mop))
 
 (cl:in-package #:sod-exports)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc #'asdf:load-system '(:sod :sod-frontend)))
 
 (defun symbolicate (&rest things)
   (intern (apply #'concatenate 'string (mapcar #'string things))))
@@ -103,10 +107,10 @@
 
 (defun specialized-on-p (func arg what)
   (some (lambda (method)
-	  (let ((spec (nth arg (sb-mop:method-specializers method))))
-	    (and (typep spec 'sb-mop:eql-specializer)
-		 (eql (sb-mop:eql-specializer-object spec) what))))
-	(sb-mop:generic-function-methods func)))
+	  (let ((spec (nth arg (method-specializers method))))
+	    (and (typep spec 'eql-specializer)
+		 (eql (eql-specializer-object spec) what))))
+	(generic-function-methods func)))
 
 (defun categorize (symbol)
   (let ((things nil))
@@ -191,7 +195,7 @@
     (let ((done (make-hash-table)))
       (labels ((walk-up (class)
 		 (unless (gethash class done)
-		   (dolist (super (sb-mop:class-direct-superclasses class))
+		   (dolist (super (class-direct-superclasses class))
 		     (push class (gethash super subs))
 		     (walk-up super))
 		   (setf (gethash class done) t))))
@@ -205,7 +209,7 @@
 				 (pretty-symbol-name (class-name class)
 						     package))
 			       (remove super
-				       (sb-mop:class-direct-superclasses this))))
+				       (class-direct-superclasses this))))
 	       (dolist (sub (sort (copy-list (gethash this subs))
 				  #'string< :key #'class-name))
 		 (walk-down sub this (1+ depth)))))
@@ -252,8 +256,8 @@
   (deep-compare (la lb)
     (loop (typesw (null (return nil)))
 	  (focus (car it)
-	    (typesw (sb-mop:eql-specializer
-		     (focus (sb-mop:eql-specializer-object it)
+	    (typesw (eql-specializer
+		     (focus (eql-specializer-object it)
 		       (typesw (keyword
 				(compare (string< left right)))
 			       (symbol
@@ -289,7 +293,7 @@
 	(flet ((dofunc (func)
 		 (when (typep func 'generic-function)
 		   (setf (gethash func functions) t)
-		   (dolist (method (sb-mop:generic-function-methods func))
+		   (dolist (method (generic-function-methods func))
 		     (setf (gethash method methods) t)))))
 	  (dofunc (and (fboundp symbol) (fdefinition symbol)))
 	  (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
@@ -297,13 +301,13 @@
 	  (let ((class (find-class symbol nil)))
 	    (when class
 	      (dolist
-		  (func (sb-mop:specializer-direct-generic-functions class))
+		  (func (specializer-direct-generic-functions class))
 		(let ((name (function-name-core
-			     (sb-mop:generic-function-name func))))
+			     (generic-function-name func))))
 		  (when (or (not (eq (symbol-package name) package))
 			    (gethash name externs))
 		    (setf (gethash func functions) t)
-		    (dolist (method (sb-mop:specializer-direct-methods class))
+		    (dolist (method (specializer-direct-methods class))
 		      (setf (gethash method methods) t)))))))))
       (let ((funclist nil))
 	(maphash (lambda (func value)
@@ -317,9 +321,9 @@
 				 (if (eq core-a core-b)
 				     (and (atom a) (consp b))
 				     (string< core-a core-b))))
-			     :key #'sb-mop:generic-function-name))
+			     :key #'generic-function-name))
 	(dolist (function funclist)
-	  (let ((name (sb-mop:generic-function-name function)))
+	  (let ((name (generic-function-name function)))
 	    (etypecase name
 	      (symbol
 	       (format t "~A~%" (pretty-symbol-name name package)))
@@ -327,9 +331,9 @@
 	       (format t "(setf ~A)~%"
 		       (pretty-symbol-name (cadr name) package)))))
 	  (dolist (method (sort (copy-list
-				 (sb-mop:generic-function-methods function))
+				 (generic-function-methods function))
 				#'order-specializers
-				:key #'sb-mop:method-specializers))
+				:key #'method-specializers))
 	    (when (gethash method methods)
 	      (format t "~2T~{~A~^ ~}~%"
 		      (mapcar
@@ -339,13 +343,13 @@
 			    (let ((name (class-name spec)))
 			      (if (eq name t) "t"
 				  (pretty-symbol-name name package))))
-			   (sb-mop:eql-specializer
-			    (let ((obj (sb-mop:eql-specializer-object spec)))
+			   (eql-specializer
+			    (let ((obj (eql-specializer-object spec)))
 			      (format nil "(eql ~A)"
 				      (if (symbolp obj)
 					  (pretty-symbol-name obj package)
 					  obj))))))
-		       (sb-mop:method-specializers method))))))))))
+		       (method-specializers method))))))))))
 
 (defun check-slot-names (package)
   (setf package (find-package package))
@@ -358,8 +362,8 @@
 	 (offenders (mapcan
 		     (lambda (class)
 		       (let* ((slot-names
-			       (mapcar #'sb-mop:slot-definition-name
-				       (sb-mop:class-direct-slots class)))
+			       (mapcar #'slot-definition-name
+				       (class-direct-slots class)))
 			      (exported (remove-if
 					 (lambda (sym)
 					   (and (not (exported-symbol-p sym))
-- 
2.11.0