~mdw
/
sod
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
d1cf6f0
)
doc/list-exports.lisp: Support use of CMUCL MOP.
author
Mark Wooding
<mdw@distorted.org.uk>
Thu, 26 May 2016 08:26:09 +0000
(09:26 +0100)
committer
Mark Wooding
<mdw@distorted.org.uk>
Sun, 29 May 2016 13:27:39 +0000
(14:27 +0100)
doc/list-exports.lisp
patch
|
blob
|
blame
|
history
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
(cl:defpackage #:sod-exports
- (:use #:common-lisp))
+ (:use #:common-lisp
+ #+cmu #:mop
+ #+sbcl #:sb-mop))
(cl:in-package #:sod-exports)
(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))))
(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)
(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))
(defun categorize (symbol)
(let ((things nil))
@@
-191,7
+195,7
@@
(let ((done (make-hash-table)))
(labels ((walk-up (class)
(unless (gethash class done)
(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))))
(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
(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)))))
(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)
(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
(typesw (keyword
(compare (string< left right)))
(symbol
@@
-289,7
+293,7
@@
(flet ((dofunc (func)
(when (typep func 'generic-function)
(setf (gethash func functions) t)
(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)))))
(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
(let ((class (find-class symbol nil)))
(when class
(dolist
- (func (s
b-mop:s
pecializer-direct-generic-functions class))
+ (func (specializer-direct-generic-functions class))
(let ((name (function-name-core
(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)
(when (or (not (eq (symbol-package name) package))
(gethash name externs))
(setf (gethash func functions) t)
- (dolist (method (s
b-mop:s
pecializer-direct-methods class))
+ (dolist (method (specializer-direct-methods class))
(setf (gethash method methods) t)))))))))
(let ((funclist nil))
(maphash (lambda (func value)
(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))))
(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)
(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)))
(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
(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
#'order-specializers
- :key #'
sb-mop:
method-specializers))
+ :key #'method-specializers))
(when (gethash method methods)
(format t "~2T~{~A~^ ~}~%"
(mapcar
(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))))
(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))))))
(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))
(defun check-slot-names (package)
(setf package (find-package package))
@@
-358,8
+362,8
@@
(offenders (mapcan
(lambda (class)
(let* ((slot-names
(offenders (mapcan
(lambda (class)
(let* ((slot-names
- (mapcar #'s
b-mop:s
lot-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))
(exported (remove-if
(lambda (sym)
(and (not (exported-symbol-p sym))