:export ())
#s(sb-cold:package-data
+ :name "SB!MOP"
+ :doc
+ "public: the MetaObject Protocol interface, as defined by
+The Art of the Metaobject Protocol, by Kiczales, des Rivieres and Bobrow:
+ISBN 0-262-61074-4."
+ :use ("SB!PCL")
+ :reexport ("ADD-DEPENDENT"
+ "ADD-DIRECT-METHOD"
+ "ADD-DIRECT-SUBCLASS"
+ "ADD-METHOD"
+ "ALLOCATE-INSTANCE"
+ "CLASS-DEFAULT-INITARGS"
+ "CLASS-DIRECT-DEFAULT-INITARGS"
+ "CLASS-DIRECT-SLOTS"
+ "CLASS-DIRECT-SUBCLASSES"
+ "CLASS-DIRECT-SUPERCLASSES"
+ "CLASS-FINALIZED-P"
+ "CLASS-NAME"
+ "CLASS-PRECEDENCE-LIST"
+ "CLASS-PROTOTYPE"
+ "CLASS-SLOTS"
+ "COMPUTE-APPLICABLE-METHODS"
+ "COMPUTE-APPLICABLE-METHODS-USING-CLASSES"
+ "COMPUTE-CLASS-PRECEDENCE-LIST"
+ "COMPUTE-DEFAULT-INITARGS"
+ "COMPUTE-DISCRIMINATING-FUNCTION"
+ "COMPUTE-EFFECTIVE-METHOD"
+ "COMPUTE-EFFECTIVE-SLOT-DEFINITION"
+ "COMPUTE-SLOTS"
+ "DIRECT-SLOT-DEFINITION-CLASS"
+ "EFFECTIVE-SLOT-DEFINITION-CLASS"
+ "ENSURE-CLASS"
+ "ENSURE-CLASS-USING-CLASS"
+ "ENSURE-GENERIC-FUNCTION"
+ "ENSURE-GENERIC-FUNCTION-USING-CLASS"
+ "EQL-SPECIALIZER-OBJECT"
+ "EXTRACT-LAMBDA-LIST"
+ "EXTRACT-SPECIALIZER-NAMES"
+ "FINALIZE-INHERITANCE"
+ "FIND-METHOD-COMBINATION"
+ "FUNCALLABLE-STANDARD-INSTANCE-ACCESS"
+ "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER"
+ "GENERIC-FUNCTION-DECLARATIONS"
+ "GENERIC-FUNCTION-LAMBDA-LIST"
+ "GENERIC-FUNCTION-METHOD-CLASS"
+ "GENERIC-FUNCTION-METHOD-COMBINATION"
+ "GENERIC-FUNCTION-METHODS"
+ "GENERIC-FUNCTION-NAME"
+ "INTERN-EQL-SPECIALIZER"
+ "MAKE-METHOD-LAMBDA"
+ "MAKE-INSTANCE"
+ "MAP-DEPENDENTS"
+ "METHOD-FUNCTION"
+ "METHOD-GENERIC-FUNCTION"
+ "METHOD-LAMBDA-LIST"
+ "METHOD-QUALIFIERS"
+ "METHOD-SPECIALIZERS"
+ "ACCESSOR-METHOD-SLOT-DEFINITION"
+ "READER-METHOD-CLASS"
+ "REMOVE-DEPENDENT"
+ "REMOVE-DIRECT-METHOD"
+ "REMOVE-DIRECT-SUBCLASS"
+ "REMOVE-METHOD"
+ "SET-FUNCALLABLE-INSTANCE-FUNCTION"
+ "SLOT-BOUNDP-USING-CLASS"
+ "SLOT-DEFINITION-ALLOCATION"
+ "SLOT-DEFINITION-INITARGS"
+ "SLOT-DEFINITION-INITFORM"
+ "SLOT-DEFINITION-INITFUNCTION"
+ "SLOT-DEFINITION-LOCATION"
+ "SLOT-DEFINITION-NAME"
+ "SLOT-DEFINITION-READERS"
+ "SLOT-DEFINITION-WRITERS"
+ "SLOT-DEFINITION-TYPE"
+ "SLOT-MAKUNBOUND-USING-CLASS"
+ "SLOT-VALUE-USING-CLASS"
+ "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS"
+ "SPECIALIZER-DIRECT-METHODS"
+ "STANDARD-INSTANCE-ACCESS"
+ "UPDATE-DEPENDENT"
+ "VALIDATE-SUPERCLASS"
+ "WRITER-METHOD-CLASS"))
+
+ #s(sb-cold:package-data
:name "SB!PCL"
:doc
"semi-public: This package includes useful meta-object protocol
;; Now that all package-package references exist, we can handle
;; REEXPORT operations. (We have to wait until now because they
- ;; interact with USE operations.) KLUDGE: This code doesn't detect
- ;; dependencies and do exports in proper order to work around them, so
- ;; it could break randomly (with build-time errors, not with silent
- ;; errors or runtime errors) if multiple levels of re-exportation are
- ;; used, e.g. package A exports X, package B uses A and reexports X,
- ;; and package C uses B and reexports X. That doesn't seem to be an
- ;; issue in the current code, and it's hard to see why anyone would
- ;; want to do it, and it should be straightforward (though tedious) to
- ;; extend the code here to deal with that if it ever becomes necessary.
- (dolist (package-data package-data-list)
- (let ((package (find-package (package-data-name package-data))))
- (dolist (symbol-name (package-data-reexport package-data))
- (multiple-value-bind (symbol status)
- (find-symbol symbol-name package)
- (unless status
- (error "No symbol named ~S is accessible in ~S."
- symbol-name
- package))
- (when (eq (symbol-package symbol) package)
- (error "~S is not inherited/imported, but native to ~S."
- symbol-name
- package))
- (export symbol package))))))
+ ;; interact with USE operations.) This code handles dependencies
+ ;; properly, but is somewhat ugly.
+ (let (done)
+ (labels
+ ((reexport (package-data)
+ (let ((package (find-package (package-data-name package-data))))
+ (cond
+ ((member package done))
+ ((null (package-data-reexport package-data))
+ (push package done))
+ (t
+ (mapcar #'reexport
+ (remove-if-not
+ (lambda (x)
+ (member x (package-data-use package-data)
+ :test #'string=))
+ package-data-list
+ :key #'package-data-name))
+ (dolist (symbol-name (package-data-reexport package-data))
+ (multiple-value-bind (symbol status)
+ (find-symbol symbol-name package)
+ (unless status
+ (error "No symbol named ~S is accessible in ~S."
+ symbol-name package))
+ (when (eq (symbol-package symbol) package)
+ (error
+ "~S is not inherited/imported, but native to ~S."
+ symbol-name package))
+ (export symbol package)))
+ (push package done))))))
+ (dolist (x package-data-list)
+ (reexport x))
+ (assert (= (length done) (length package-data-list))))))
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-;;;; Note that the MOP is not in a supported state. Package issues
-;;;; (both MOP/SB-PCL and CL/SB-PCL) have yet to be resolved, and
-;;;; there is likely to be missing functionality. However, this seems
-;;;; a good a way as any of ensuring that we have no regressions.
+;;;; Note that the MOP is not in an entirely supported state.
+;;;; However, this seems a good a way as any of ensuring that we have
+;;;; no regressions.
(defpackage "MOP-TEST"
- ;; eventually, we might want "MOP" as well here.
- (:use "CL"))
+ (:use "CL" "SB-MOP"))
(in-package "MOP-TEST")
\f
;;; Readers for Class Metaobjects (pp. 212--214 of AMOP)
(defclass red-herring (forward-ref) ())
-(assert (null (sb-pcl:class-direct-slots (find-class 'forward-ref))))
-(assert (null (sb-pcl:class-direct-default-initargs
+(assert (null (class-direct-slots (find-class 'forward-ref))))
+(assert (null (class-direct-default-initargs
(find-class 'forward-ref))))
\f
;;; Readers for Generic Function Metaobjects (pp. 216--218 of AMOP)
(:argument-precedence-order b c a))
(assert (equal
- (sb-pcl:generic-function-lambda-list #'fn-with-odd-arg-precedence)
+ (generic-function-lambda-list #'fn-with-odd-arg-precedence)
'(a b c)))
(assert (equal
- (sb-pcl:generic-function-argument-precedence-order #'fn-with-odd-arg-precedence)
+ (generic-function-argument-precedence-order #'fn-with-odd-arg-precedence)
'(b c a)))
;;; Test for DOCUMENTATION's order, which was wrong until sbcl-0.7.8.39
(assert (equal
- (sb-pcl:generic-function-argument-precedence-order #'documentation)
- (let ((ll (sb-pcl:generic-function-lambda-list #'documentation)))
+ (generic-function-argument-precedence-order #'documentation)
+ (let ((ll (generic-function-lambda-list #'documentation)))
(list (nth 1 ll) (nth 0 ll)))))
(assert (null
- (sb-pcl:generic-function-declarations #'fn-with-odd-arg-precedence)))
+ (generic-function-declarations #'fn-with-odd-arg-precedence)))
(defgeneric gf-with-declarations (x)
(declare (optimize (speed 3)))
(declare (optimize (safety 0))))
-(let ((decls (sb-pcl:generic-function-declarations #'gf-with-declarations)))
+(let ((decls (generic-function-declarations #'gf-with-declarations)))
(assert (= (length decls) 2))
(assert (member '(optimize (speed 3)) decls :test #'equal))
(assert (member '(optimize (safety 0)) decls :test #'equal)))
(a-class-slot :allocation :class :accessor a-class-slot)))
(dolist (m (list (list #'an-instance-slot :instance)
(list #'a-class-slot :class)))
- (let ((methods (sb-pcl:generic-function-methods (car m))))
+ (let ((methods (generic-function-methods (car m))))
(assert (= (length methods) 1))
- (assert (eq (sb-pcl:slot-definition-allocation
- (sb-pcl:accessor-method-slot-definition
+ (assert (eq (slot-definition-allocation
+ (accessor-method-slot-definition
(car methods)))
(cadr m)))))
\f
;;; Class Finalization Protocol (see section 5.5.2 of AMOP)
(let ((finalized-count 0))
- (defmethod sb-pcl:finalize-inheritance :after ((x standard-class))
+ (defmethod finalize-inheritance :after ((x standard-class))
(incf finalized-count))
(defun get-count () finalized-count))
(defclass finalization-test-1 () ())
;;; relationships. These aren't necessarily true, but are probably
;;; not going to change often.
(dolist (x '(number array sequence character symbol))
- (assert (eq (car (sb-pcl:class-direct-superclasses (find-class x)))
+ (assert (eq (car (class-direct-superclasses (find-class x)))
(find-class t)))
(assert (member (find-class x)
- (sb-pcl:class-direct-subclasses (find-class t)))))
+ (class-direct-subclasses (find-class t)))))
\f
;;; the class-prototype of the NULL class used to be some weird
;;; standard-instance-like thing. Make sure it's actually NIL.
;;;
;;; (and FIXME: eventually turn this into asserting that the prototype
;;; of all built-in-classes is of the relevant type)
-(assert (null (sb-pcl:class-prototype (find-class 'null))))
+(assert (null (class-prototype (find-class 'null))))
\f
;;; simple consistency checks for the SB-PCL (perhaps AKA SB-MOP)
;;; package: all of the functionality specified in AMOP is in
;;; and all generic functions in SB-PCL have at least one specified
;;; method, except for UPDATE-DEPENDENT
(assert (null (loop for x being each external-symbol in "SB-PCL"
- unless (or (eq x 'sb-pcl:update-dependent)
+ unless (or (eq x 'update-dependent)
(not (typep (fdefinition x) 'generic-function))
- (> (length (sb-pcl:generic-function-methods
+ (> (length (generic-function-methods
(fdefinition x)))
0))
collect x)))
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.13.pcl-class.6"
+"0.7.13.pcl-class.7"
projects / sbcl.git / commitdiff