Commit 489aba97 authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Major reorganization of the code, plus support for generic function invocation...

Major reorganization of the code, plus support for generic function invocation protocols in Allegro Common Lisp.

Ignore-this: 9be21704dcdc2ab8e47f596e5a82ff3b

A major reorganization of the code became necessary, because the old structure became harder than necessary to maintain. I have now moved code that is similar across many Common Lisp implementations into a shared source code file, and leave only small parts to implementation-dependent source code files. The setup of packages is combined into one file, and all relevant symbols are now exported from the packages, including symbols that may not have any definitions in some Common Lisp implementations. To further simplify things, I have moved source code from subfolders into the main folder, to avoid hierarchy creep.

Finally, Allegro Common Lisp now also supports the full generic function invocation protocols.

darcs-hash:4b756a79272aa1381988469961dd04652b9f712b
parent 81753452
(in-package :cl-user)
(defpackage #:closer-mop
(:use #:common-lisp)
(:nicknames #:c2mop)
(:shadow #:standard-class #:standard-generic-function)
(:import-from #:excl #:classp)
(:import-from #: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
#-allegro #: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
#-allegro #: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-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))
(in-package :cl-user)
(defpackage #:closer-mop
(:use #:common-lisp)
(:nicknames #:c2mop)
(:shadow
#:defgeneric
#:defmethod
#:standard-generic-function)
(:import-from #:clos
#: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
#-clisp #: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
#:update-dependent
#:validate-superclass
#:writer-method-class
#:warn-on-defmethod-without-generic-function))
This diff is collapsed.
(in-package :closer-mop)
;; 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))))
;; We need a new standard-class for various things.
(defclass standard-class (cl:standard-class excl:lockable-object)
......@@ -43,30 +7,12 @@
:accessor valid-slot-allocations
:reader excl::valid-slot-allocation-list)))
;; validate-superclass for metaclass classes is a little bit
;; more tricky than for class metaobject classes because
;; we don't want to make all standard-classes compatible to
;; each other.
;; Our validate-superclass may get passed a class-prototype
;; as its second argument, so don't expect its readers to
;; yield useful information. (In ANSI parlance, "the
;; consequences are undefined...")
(cl:defmethod validate-superclass
((class standard-class)
(superclass cl:standard-class))
(or (when (eq (class-of class) (find-class 'standard-class))
(or (eq (class-of superclass) (find-class 'cl:standard-class))
(eq (class-of superclass) (find-class 'standard-class))))
(call-next-method)
(when (eq (class-of superclass) (find-class 'cl:standard-class))
(validate-superclass class (class-prototype (find-class 'standard-class))))))
(define-validate-superclass-method standard-class cl:standard-class)
;; Allegro defines an extra check for :allocation kinds. AMOP expects any kind to be
;; permissible, though. This is corrected here.
(defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys)
(cl:defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys)
(unless (eq (class-of class) (find-class 'standard-class))
(excl:with-locked-object
(class :non-smp :without-scheduling)
......@@ -118,11 +64,25 @@
object
(slot-definition-name slotd)))
;; We need a new standard-generic-function for various things.
;;; New generic functions.
(defclass standard-generic-function (cl:standard-generic-function)
()
(:metaclass clos:funcallable-standard-class))
(cl:defmethod initialize-instance :around
((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p))
(declare (dynamic-extent initargs))
(if (and method-class-p (symbolp method-class))
(apply #'call-next-method gf
:method-class (find-class method-class)
initargs)
(call-next-method)))
(cl:defmethod reinitialize-instance :around
((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p))
(declare (dynamic-extent initargs))
(if (and method-class-p (symbolp method-class))
(apply #'call-next-method gf
:method-class (find-class method-class)
initargs)
(call-next-method)))
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.
......@@ -133,20 +93,16 @@
(cl:defmethod reinitialize-instance :after
((gf standard-generic-function) &rest initargs)
(declare (dynamic-extent initargs))
(set-funcallable-instance-function
gf (compute-discriminating-function gf))
(map-dependents
gf (lambda (dep) (apply #'update-dependent gf dep initargs))))
(set-funcallable-instance-function gf (compute-discriminating-function gf))
(map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs))))
(cl:defmethod add-method :after
((gf standard-generic-function) method)
(map-dependents
gf (lambda (dep) (update-dependent gf dep 'add-method method))))
(map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method))))
(cl:defmethod remove-method :after
((gf standard-generic-function) method)
(map-dependents
gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
(map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
;; The following method ensures that we get only the required arguments
;; from generic-function-argument-precedence-order
......@@ -155,36 +111,5 @@
(:method ((gf generic-function))
(required-args (mop:generic-function-argument-precedence-order gf))))
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (required-args lambda-list (constantly (find-class 't)))))
(funcall (compile nil `(lambda ()
(defmethod ,(generic-function-name gf) ,@qualifiers
,(loop for specializer in specializers
for (arg . rest) on lambda-list
collect `(,arg ,specializer) into args
finally (return (nconc args rest)))
,@(cddr lambda-expression))))))
;; The following can be used in direct-slot-definition-class to get the correct initargs
;; for a slot. Use it like this:
;;
;; (defmethod direct-slot-definition-class
;; ((class my-standard-class) &rest initargs)
;; (declare (dynamic-extent initargs))
;; (destructuring-bind
;; (&key key-of-interest &allow-other-keys)
;; (fix-slot-initargs initargs)
;; ...))
(defvar *standard-slot-keys*
'(:name :documentation
:initargs :initform :initfunction
:readers :writers))
(defun fix-slot-initargs (initargs)
initargs)
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
(in-package :closer-mop)
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
(in-package :closer-mop)
(defclass standard-class (cl:standard-class) ())
(define-validate-superclass-method standard-class cl:standard-class)
(cl:defmethod reinitialize-instance :after ((class standard-class) &key)
(finalize-inheritance class))
;;; New generic functions.
;; Store the method function somewhere else, to circumvent
;; the native check for congruent lambda lists.
(defparameter *stub-method-functions* (make-hash-table :test #'equal))
(defun get-stub-method-function (lambda-list)
(or (gethash lambda-list *stub-method-functions*)
(let ((ignore-list (loop for arg in lambda-list
unless (member arg lambda-list-keywords)
collect (etypecase arg
(symbol arg)
(cons (etypecase (car arg)
(symbol (car arg))
(cons (assert (cdr arg))
(cadr arg))))))))
(setf (gethash lambda-list *stub-method-functions*)
(compile nil `(lambda ,lambda-list
(declare (ignore ,@ignore-list))
(error "This method function must not be called.")))))))
(cl:defmethod initialize-instance :around
((method standard-method) &rest initargs &key lambda-list function closer-patch)
(if closer-patch
(apply #'call-next-method method
:real-function function
:function (get-stub-method-function lambda-list)
initargs)
(apply #'call-next-method method
:real-function function