doc/list-exports.lisp: Support use of CMUCL MOP.

[sod] / doc / list-exports.lisp

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index eab4d54..5eab34e 100644 (file)
--- 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))