Commit 198ec387 authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Separated code strictly into folders per implementation, and cleaned up the code.

Ignore-this: 8505094d361aee4763045939771f8cfa

Originally, when I started Closer to MOP, I expected implementations that stem from the same original implementations to have similar issues with regard to CLOS MOP compatibility. So specifically, I packaged the code for CMUCL and SBCL into one folder, and that for MCL, OpenMCL and Clozure Common Lisp into one folder. It turned out that the incompatibilites are not at all similar, and that this created more problems than it solved. So I now decided to keep implementations strictly separated, to make my life easier in the future.

darcs-hash:b18e457aea79fad11fed31cb4d2e94af211cc4ef
parent a4a2ed2a
......@@ -173,7 +173,7 @@
#:generic-function-methods
#:generic-function-name
#:intern-eql-specializer
#-allegro #:make-method-lambda
#:make-method-lambda
#:map-dependents
#:method-function
#:method-generic-function
......
......@@ -38,7 +38,7 @@
;; We need a new standard-class for various things.
(cl:defclass standard-class (cl:standard-class excl:lockable-object)
(defclass standard-class (cl:standard-class excl:lockable-object)
((valid-slot-allocations :initform '(:instance :class)
:accessor valid-slot-allocations
:reader excl::valid-slot-allocation-list)))
......@@ -120,34 +120,10 @@
;; We need a new standard-generic-function for various things.
(cl:defclass standard-generic-function (cl:standard-generic-function)
(defclass standard-generic-function (cl:standard-generic-function)
()
(:metaclass clos:funcallable-standard-class))
#|
;; The following ensures that the new standard-generic-function is used.
(defun ensure-generic-function
(name &rest args
&key (generic-function-class 'standard-generic-function)
&allow-other-keys)
(declare (dynamic-extent args))
(when (fboundp name)
(let ((function (fdefinition name)))
(unless (typep function 'generic-function)
(cerror "Discard existing definition and create generic function."
"~S is already fbound, but not as a generic function." name)
(fmakunbound name))))
(if (fboundp name)
(let ((function (fdefinition name)))
(apply #'ensure-generic-function-using-class
function name args))
(apply #'ensure-generic-function-using-class nil name
:generic-function-class generic-function-class
args)))
|#
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.
......
......@@ -30,10 +30,12 @@ OTHER DEALINGS IN THE SOFTWARE.
((:module
#+allegro "allegro"
#+clisp "clisp"
#+clozure "clozure"
#+cmu "cmu"
#+ecl "ecl"
#+lispworks "lispworks"
#+(or clozure mcl) "mcl"
#+(or cmu sbcl) "pcl"
#+mcl "mcl"
#+sbcl "sbcl"
#+scl "scl"
:components ((:file "closer-mop-packages")
(:file "closer-mop"
......@@ -41,8 +43,10 @@ OTHER DEALINGS IN THE SOFTWARE.
(:file "closer-mop-utility-packages"
:depends-on (#+allegro "allegro"
#+clisp "clisp"
#+clozure "clozure"
#+cmu "cmu"
#+ecl "ecl"
#+lispworks "lispworks"
#+(or clozure mcl) "mcl"
#+(or cmu sbcl) "pcl"
#+mcl "mcl"
#+sbcl "sbcl"
#+scl "scl"))))
(in-package :cl-user)
(defpackage #:closer-mop
(:use #:common-lisp)
(:nicknames #:c2mop)
(:shadow
#:standard-class
#:defgeneric #:standard-generic-function
#:defmethod #:standard-method #:method-function)
(:import-from #:ccl
#:classp
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
#:metaobject
#:slot-definition
#:specializer
#:standard-accessor-method
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:standard-reader-method
#:standard-slot-definition
#:standard-writer-method
#:accessor-method-slot-definition
#:add-dependent
#:add-direct-method
#:add-direct-subclass
#:class-default-initargs
#:class-direct-default-initargs
#:class-direct-slots
#:class-direct-subclasses
#:class-direct-superclasses
#:class-finalized-p
#:class-precedence-list
#:class-prototype
#:class-slots
#-clozure #:compute-applicable-methods-using-classes
#:compute-class-precedence-list
#:compute-default-initargs
#-clozure #:compute-discriminating-function
#-clozure #: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-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
#-clozure #:make-method-lambda
#:map-dependents
#-clozure #:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#:reader-method-class
#:remove-dependent
#:remove-direct-method
#:remove-direct-subclass
#: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)
(:export
#:built-in-class
#:class
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
#:generic-function
#:metaobject
#:method
#:method-combination
#:slot-definition
#:specializer
#:standard-accessor-method
#:standard-class
#:standard-generic-function
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:standard-method
#:standard-object
#:standard-reader-method
#:standard-slot-definition
#:standard-writer-method
#:defclass
#:defgeneric
#:define-method-combination
#:defmethod
#:classp
#:ensure-finalized
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#:add-dependent
#:add-direct-method
#:add-direct-subclass
#:class-default-initargs
#:class-direct-default-initargs
#:class-direct-slots
#:class-direct-subclasses
#:class-direct-superclasses
#:class-finalized-p
#:class-precedence-list
#:class-prototype
#:class-slots
#:compute-applicable-methods-using-classes
#:compute-class-precedence-list
#:compute-default-initargs
#:compute-discriminating-function
#:compute-effective-method
#:compute-effective-method-function
#: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
#:map-dependents
#:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#:reader-method-class
#:remove-dependent
#:remove-direct-method
#:remove-direct-subclass
#: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
#:warn-on-defmethod-without-generic-function))
This diff is collapsed.
(in-package :cl-user)
(defpackage #:closer-mop
(:use #:common-lisp)
(:nicknames #:c2mop)
(:shadow #:typep #:subtypep)
(:import-from #:pcl #:classp)
(:import-from #:clos-mop
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
#:metaobject
#:slot-definition
#:specializer
#:standard-accessor-method
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:standard-reader-method
#:standard-slot-definition
#:standard-writer-method
#:accessor-method-slot-definition
#:add-dependent
#:add-direct-method
#:add-direct-subclass
#:class-default-initargs
#:class-direct-default-initargs
#:class-direct-slots
#:class-direct-subclasses
#:class-direct-superclasses
#:class-finalized-p
#:class-precedence-list
#:class-prototype
#:class-slots
#: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-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
#:map-dependents
#:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#:reader-method-class
#:remove-dependent
#:remove-direct-method
#:remove-direct-subclass
#: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)
(:export
#:built-in-class
#:class
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
#:generic-function
#:metaobject
#:method
#:method-combination
#:slot-definition
#:specializer
#:standard-accessor-method
#:standard-class
#:standard-generic-function
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:standard-method
#:standard-object
#:standard-reader-method
#:standard-slot-definition
#:standard-writer-method
#:defclass
#:defgeneric
#:define-method-combination
#:defmethod
#:classp
#:ensure-finalized
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#:add-dependent
#:add-direct-method
#:add-direct-subclass
#:class-default-initargs
#:class-direct-default-initargs
#:class-direct-slots
#:class-direct-subclasses
#:class-direct-superclasses
#:class-finalized-p
#:class-precedence-list
#:class-prototype
#:class-slots
#:compute-applicable-methods-using-classes
#:compute-class-precedence-list
#:compute-default-initargs
#:compute-discriminating-function
#:compute-effective-method
#:compute-effective-method-function
#: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
#:map-dependents
#:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#:reader-method-class
#:remove-dependent
#:remove-direct-method
#:remove-direct-subclass
#: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
#:subtypep
#:typep
#:update-dependent
#:validate-superclass
#:writer-method-class))
(in-package :closer-mop)
;; Some internal utility functions.
(define-modify-macro nconcf (&rest lists) nconc)
;; Some utility functions.
(defun required-args (lambda-list &optional (collector #'identity))
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (funcall collector arg)))
(defun ensure-finalized (class &optional (errorp t))
(if (typep class 'class)
(unless (class-finalized-p class)
(finalize-inheritance class))
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
;; In CMUCL, reader-method-class and writer-method-class are
;; not used during class initialization. The following definitions
;; correct this.
(defun modify-accessors (class)
(loop with reader-specializers = (list class)
with writer-specializers = (list (find-class 't) class)
for slotd in (class-direct-slots class) do
(loop for reader in (slot-definition-readers slotd)
for reader-function = (fdefinition reader)
for reader-method = (find-method reader-function () reader-specializers)
for initargs = (list :qualifiers ()
:lambda-list '(object)
:specializers reader-specializers
:function (method-function reader-method)
:slot-definition slotd)
for method-class = (apply #'reader-method-class class slotd initargs)
unless (eq method-class (class-of reader-method))
do (add-method reader-function (apply #'make-instance method-class initargs)))
(loop for writer in (slot-definition-writers slotd)
for writer-function = (fdefinition writer)
for writer-method = (find-method writer-function () writer-specializers)
for initargs = (list :qualifiers ()
:lambda-list '(new-value object)
:specializers writer-specializers
:function (method-function writer-method)
:slot-definition slotd)
for method-class = (apply #'writer-method-class class slotd initargs)
unless (eq method-class (class-of writer-method))
do (add-method writer-function (apply #'make-instance method-class initargs)))))
;; The following methods additionally create a gensym for the class name
;; unless a name is explicitly provided. AMOP requires classes to be
;; potentially anonymous.
(defmethod initialize-instance :around
((class standard-class) &rest initargs
&key (name (gensym)))
(declare (dynamic-extent initargs))
(prog1 (apply #'call-next-method class :name name initargs)
(modify-accessors class)))
(defmethod initialize-instance :around
((class funcallable-standard-class) &rest initargs
&key (name (gensym)))
(declare (dynamic-extent initargs))
(prog1 (apply #'call-next-method class :name name initargs)
(modify-accessors class)))
(defmethod reinitialize-instance :after
((class standard-class) &key)
(modify-accessors class))
(defmethod reinitialize-instance :after
((class funcallable-standard-class) &key)
(modify-accessors class))
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.
;; The following method additionally ensures that
;; compute-discriminating-function is triggered.
; Note that for CMUCL, these methods violate the AMOP specification
; by specializing on the original standard-generic-function metaclass. However,
; this is necassary because in CMUCL, only one subclass of
; standard-generic-function can be created, and taking away that option from user
; code doesn't make a lot of sense in our context.
(defmethod reinitialize-instance :after
((gf standard-generic-function) &rest initargs)
(declare (dynamic-extent initargs))
(set-funcallable-instance-function
gf (compute-discriminating-function gf)))
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (required-args lambda-list (constantly 't))))
(funcall (compile nil `(lambda ()
(defmethod ,(generic-function-name gf) ,@qualifiers