Commit 74da6543 authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Added support for LispWorks 5.0 - numerous changes.

darcs-hash:f117c253f5ab3d478f32c411f076a5b9d90f28be
parent d417922c
......@@ -317,6 +317,56 @@
:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots (no)
:subclasses-of-standard-writer-method-do-not-inherit-exported-slots (no)
:lispworks5.0
:add-method-calls-compute-discriminating-function (no)
:add-method-updates-specializer-direct-generic-functions (fixed)
:class-default-initargs (no)
:class-direct-default-initargs (no)
:compute-applicable-methods-using-classes (redef sgf)
:compute-default-initargs (probably not / redef finalize-inheritance)
:defgeneric-calls-find-method-combination (no)
:eql-specializer (partially fixed)
:eql-specializer-object (fixed)
:eql-specializers-are-objects (no)
:extensible-allocation (no)
:finalize-inheritance-calls-compute-default-initargs (probably not / redef finailze-inheritance)
:find-method-combination (partially fixed)
:funcallable-standard-instance-access (no)
:function-invocation-calls-compute-applicable-methods (redef sgf)
:function-invocation-calls-compute-applicable-methods-using-classes (redef sgf)
:initialize-instance-calls-compute-discriminating-function (no)
:intern-eql-specializer (partially fixed)
:make-method-lambda (partially fixed)
:method-functions-take-processed-parameters (no)
:reinitialize-instance-calls-compute-discriminating-function (no)
:remove-method-calls-compute-discriminating-function (no)
:setf-slot-value-using-class-specialized-on-slot-definition (fixed)
:slot-boundp-using-class-specialized-on-slot-definition (fixed)
:slot-makunbound-using-class-specialized-on-slot-definition (fixed)
:slot-reader-calls-slot-value-using-class (fixed)
:slot-value-using-class-specialized-on-slot-definition (fixed)
:slot-writer-calls-slot-value-using-class (fixed)
:specializer (no)
:specializer-direct-generic-functions (fixed)
:standard-class-and-funcallable-standard-class-are-compatible (no)
:standard-instance-access (no)
:subclasses-of-built-in-class-do-not-inherit-exported-slots (no)
:subclasses-of-class-do-not-inherit-exported-slots (no)
:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots (no)
:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots (no)
:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots (no)
:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots (no)
:subclasses-of-slot-definition-do-not-inherit-exported-slots (no)
:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots (no)
:subclasses-of-standard-class-do-not-inherit-exported-slots (no)
:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots (no)
:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots (no)
:subclasses-of-standard-generic-function-do-not-inherit-exported-slots (no)
:subclasses-of-standard-method-do-not-inherit-exported-slots (no)
:subclasses-of-standard-reader-method-do-not-inherit-exported-slots (no)
:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots (no)
:subclasses-of-standard-writer-method-do-not-inherit-exported-slots (no)
:mcl
:add-method-calls-compute-discriminating-function (no)
:compute-applicable-methods-using-classes (no)
......
......@@ -123,6 +123,28 @@ LispWorks, 4.4.5, 4.4.6, Personal and Professional Editions
- Subclasses of BUILT-IN-CLASS, CLASS, DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed.
LispWorks, 5.0, Professional Editions
- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS doesn't return canonicalized default initargs as specified. Not fixed.
- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice.
- COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Not fixed.
- COMPUTE-DEFAULT-INITARGS doesn't exist. Not fixed.
- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed.
- EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In LispWorks, eql specializers are lists not objects. I have provided EQL-SPECIALIZER as a type (not as a class) and EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER to work on lists, and a class EQL-SPECIALIZER* and corresponding EQL-SPECIALIZER-OBJECT* and INTERN-EQL-SPECILAIZER* to soften the incompatibilities.
- The :ALLOCATION type cannot be extended. Not fixed.
- FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options.
- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Not fixed.
- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Not fixed.
- MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed.
- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed.
- The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed.
- The generated accessor methods don't use the slot methods for accessing slots. Fixed. (Don't use :optimize-slot-access to deoptimize slot access, or otherwise the fixed slot access protocol doesn't work anymore!)
- SPECIALIZER doesn't exist. Not fixed.
- SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed.
- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed.
- Subclasses of BUILT-IN-CLASS, CLASS, DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed.
MCL 5.1
In MCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed.
......@@ -164,19 +186,19 @@ Summary:
- Specialize the methods for the dependent protocol on the class or generic function metaobject class. The example in AMOP doesn't do this but that is fragile code.
- Don't rely on methods being initialized with the specified initargs from inside the MOP.
- CLisp doesn't change a FORWARD-REFERENCED-CLASS via CHANGE-CLASS. Apart from that, FORWARD-REFERENCED-CLASS works reliably across all MOPs.
- Effective slot definitions and EFFECTIVE-SLOT-DEFINITION-CLASS don't receive :documentation in CMUCL, and no :allocation (!) in LispWorks.
- Effective slot definitions and EFFECTIVE-SLOT-DEFINITION-CLASS don't receive :documentation in CMUCL, and no :allocation (!) in LispWorks before 5.0.
- If you specialize DIRECT-SLOT-DEFINITION-CLASS, use FIX-SLOT-INITARGS in portable code.
- If you want to use :ALLOCATION types other than :CLASS or :INSTANCE, you cannot use CLisp before 2.37, LispWorks or MCL. Only Allegro Common Lisp, CLisp from 2.37 on, CMUCL, OpenMCL and SBCL support this.
- In Allegro, CMUCL and LispWorks, STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible.
- The function invocation protocol only works in CMUCL, SBCL and CLisp.
- If you need to see :direct-default-initargs when classes are initialized, conditionalize on #+lispworks to receive :default-initargs instead.
- If you need to see :direct-default-initargs when classes are initialized, conditionalize on #+lispworks to receive :default-initargs instead for LispWorks version before 5.0.
- COMPUTE-DEFAULT-INITARGS doesn't exist (and isn't called) in LispWorks.
- In LispWorks, eql specializers are lists.
- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS doesn't exist / should not be used in LispWorks.
- In CLisp before version 2.40, and in CMUCL, MCL and OpenMCL, the reinitialization of a class metaobject does not lead to a call of FINALIZE-INHERITANCE, so methods defined on FINALIZE-INHERITANCE won't be called again in that case.
- If you need to see :declarations when generic functions are initialized, conditionalize on #+lispworks to receive 'declare instead. (Actually, AMOP and ANSI Common Lisp diverge in this regard. AMOP specifies that :declarations is used whereas ANSI Common Lisp specifies that 'declare is used. Since most MOP implementations adhere to AMOP in this regard, I have also chosen that path.)
- If you need to see :declarations when generic functions are initialized, conditionalize on #+lispworks to receive 'declare instead for LispWorks versions before 5.0. (Actually, AMOP and ANSI Common Lisp diverge in this regard. AMOP specifies that :declarations is used whereas ANSI Common Lisp specifies that 'declare is used. Since most MOP implementations adhere to AMOP in this regard, I have also chosen that path.)
- In Allegro Common Lisp and LispWorks, method functions take the original parameters that a generic function has received.
- In LispWorks, the class SPECIALIZER doesn't exist.
- In LispWorks before 5.0, the class SPECIALIZER doesn't exist.
- If you need to rely on the generic function protocols, don't use MCL or OpenMCL (or be very careful - some minor things work there as specified).
- The declarations for a generic function cannot be inspected in MCL.
- All implementations define slots on various specified metaobject classes that are exported from some package and/or accessible in the package common-lisp-user. Only sbcl is safe from this, and clisp is relatively safe in that it does that only for the class METHOD-COMBINATION.
......@@ -20,7 +20,7 @@
#-lispworks #:eql-specializer
#:forward-referenced-class
#-lispworks #:funcallable-standard-class
#-lispworks #:funcallable-standard-object
#+lispworks5.0 #:funcallable-standard-object
#:metaobject
#:slot-definition
#-lispworks #:specializer
......
......@@ -34,9 +34,9 @@
"~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))
(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)))
......@@ -76,7 +76,7 @@
(defmacro defclass (name (&rest supers) &body options)
(if (member :metaclass options :key #'car)
`(cl:defclass ,name ,supers ,@options)
`(cl:defclass ,name ,supers ,@options)
`(cl:defclass ,name ,supers ,@options
(:metaclass standard-class))))
......@@ -98,9 +98,16 @@
(when (eq (class-of superclass) (find-class 'clos:funcallable-standard-class))
(validate-superclass class (class-prototype (find-class 'funcallable-standard-class))))))
#+lispworks5.0
(cl:defmethod validate-superclass
((class funcallable-standard-class)
(superclass (eql (find-class 'funcallable-standard-object))))
t)
;; We also need a new funcallable-standard-object because the default one
;; is not an instance of clos:funcallable-standard-class.
#-lispworks5.0
(cl:defclass funcallable-standard-object (clos:funcallable-standard-object)
()
(:metaclass clos:funcallable-standard-class))
......@@ -108,19 +115,20 @@
;; The following code ensures that possibly incorrect lists of direct
;; superclasses are corrected.
#-lispworks5.0
(defun modify-superclasses (direct-superclasses &optional (standardp t))
(if (null direct-superclasses)
(list (if standardp
(find-class 'standard-object)
(find-class 'funcallable-standard-object)))
(list (if standardp
(find-class 'standard-object)
(find-class 'funcallable-standard-object)))
(let ((standard-object (if standardp
(find-class 'standard-object)
(find-class 'standard-object)
(find-class 'clos:funcallable-standard-object))))
(if (eq (car (last direct-superclasses)) standard-object)
(if standardp
direct-superclasses
(append (butlast direct-superclasses)
(list (find-class 'funcallable-standard-object))))
(if standardp
direct-superclasses
(append (butlast direct-superclasses)
(list (find-class 'funcallable-standard-object))))
(remove standard-object direct-superclasses)))))
;; During class re/initialization, we take care of the following things:
......@@ -130,63 +138,82 @@
(cl:defmethod initialize-instance :around
((class standard-class) &rest initargs
&key (direct-superclasses ()))
#-lispworks5.0 &key
#-lispworks5.0 (direct-superclasses ()))
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:direct-superclasses (modify-superclasses direct-superclasses)
#-lispworks5.0 :direct-superclasses
#-lispworks5.0 (modify-superclasses direct-superclasses)
:optimize-slot-access nil
initargs))
(cl:defmethod reinitialize-instance :around
((class standard-class) &rest initargs
&key (direct-superclasses () direct-superclasses-p))
#-lispworks5.0 &key
#-lispworks5.0 (direct-superclasses () direct-superclasses-p))
(declare (dynamic-extent initargs))
(when direct-superclasses-p
(setq direct-superclasses (modify-superclasses direct-superclasses))
(loop for superclass in (copy-list (class-direct-superclasses class))
unless (member superclass direct-superclasses)
do (remove-direct-subclass superclass class)))
(if direct-superclasses-p
#-lispworks5.0
(progn
(when direct-superclasses-p
(setq direct-superclasses (modify-superclasses direct-superclasses))
(loop for superclass in (copy-list (class-direct-superclasses class))
unless (member superclass direct-superclasses)
do (remove-direct-subclass superclass class)))
(if direct-superclasses-p
(apply #'call-next-method class
:direct-superclasses direct-superclasses
:optimize-slot-access nil
initargs)
(apply #'call-next-method class
:optimize-slot-access nil
initargs)))
(apply #'call-next-method class
:optimize-slot-access nil
initargs)))
#+lispworks5.0
(apply #'call-next-method class
:optimize-slot-access nil
initargs))
(cl:defmethod initialize-instance :around
((class funcallable-standard-class) &rest initargs
&key (direct-superclasses ()))
#-lispworks5.0 &key
#-lispworks5.0 (direct-superclasses ()))
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:direct-superclasses (modify-superclasses direct-superclasses nil)
#-lispworks5.0 :direct-superclasses
#-lispworks5.0 (modify-superclasses direct-superclasses nil)
:optimize-slot-access nil
initargs))
(cl:defmethod reinitialize-instance :around
((class funcallable-standard-class) &rest initargs
&key (direct-superclasses () direct-superclasses-p))
#-lispworks5.0 &key
#-lispworks5.0 (direct-superclasses () direct-superclasses-p))
(declare (dynamic-extent initargs))
(when direct-superclasses-p
(setq direct-superclasses (modify-superclasses direct-superclasses nil))
(loop for superclass in (copy-list (class-direct-superclasses class))
unless (member superclass direct-superclasses)
do (remove-direct-subclass superclass class)))
(if direct-superclasses-p
#-lispworks5.0
(progn
(when direct-superclasses-p
(setq direct-superclasses (modify-superclasses direct-superclasses nil))
(loop for superclass in (copy-list (class-direct-superclasses class))
unless (member superclass direct-superclasses)
do (remove-direct-subclass superclass class)))
(if direct-superclasses-p
(apply #'call-next-method class
:direct-superclasses direct-superclasses
:optimize-slot-access nil
initargs)
(apply #'call-next-method class
:optimize-slot-access nil
initargs)))
(apply #'call-next-method class
:optimize-slot-access nil
initargs)))
#+lispworks5.0
(apply #'call-next-method class
:optimize-slot-access nil
initargs))
;; The following is necessary for forward-referenced-classes.
;; Since we replace the original funcallable-standard-object with
;; a new one, we have to prevent LispWorks from trying to use
;; the original one when forward-ferenced-classes are resolved.
#-lispworks5.0
(cl:defmethod change-class :around
((class forward-referenced-class)
(new-class funcallable-standard-class)
......@@ -210,7 +237,7 @@
:test #'eq
:key #'slot-definition-name)))
(if slotd
(slot-value-using-class class object slotd)
(slot-value-using-class class object slotd)
(slot-missing class object slot 'slot-value))))
(cl:defmethod slot-value-using-class
......@@ -230,8 +257,8 @@
:test #'eq
:key #'slot-definition-name)))
(if slotd
(setf (slot-value-using-class class object slotd)
new-value)
(setf (slot-value-using-class class object slotd)
new-value)
(slot-missing class object slot 'setf new-value))))
(cl:defmethod (setf slot-value-using-class)
......@@ -252,7 +279,7 @@
:test #'eq
:key #'slot-definition-name)))
(if slotd
(slot-boundp-using-class class object slotd)
(slot-boundp-using-class class object slotd)
(slot-missing class object slot 'slot-boundp))))
(cl:defmethod slot-boundp-using-class
......@@ -272,7 +299,7 @@
:test #'eq
:key #'slot-definition-name)))
(if slotd
(slot-makunbound-using-class class object slotd)
(slot-makunbound-using-class class object slotd)
(slot-missing class object slot 'slot-makunbound))))
(cl:defmethod slot-makunbound-using-class
......@@ -294,7 +321,7 @@
(cl:defgeneric eql-specializer-object (eql-specializer)
(:method ((cons cons))
(if (clos:eql-specializer-p cons)
(cadr cons)
(cadr cons)
(error "~S is not an eql-specializer." cons))))
(defun intern-eql-specializer (object)
......@@ -337,6 +364,7 @@
;; The following method ensures that remove-method is called.
#-lispworks5.0
(cl:defmethod add-method :before ((gf standard-generic-function) (method method))
(when-let (old-method (find-method gf (method-qualifiers method)
(method-specializers method) nil))
......@@ -347,24 +375,28 @@
(cl:defmethod add-method :after ((gf standard-generic-function) (method method))
(loop for specializer in (method-specializers method)
if (consp specializer)
do (add-direct-method
(if (consp specializer)
(intern-eql-specializer*
(eql-specializer-object specializer))
specializer)
method))
(intern-eql-specializer*
(eql-specializer-object specializer))
method)
#-lispworks5.0 else
#-lispworks5.0 do
#-lispworks5.0 (add-direct-method specializer method))
#+lispworks4.3
(map-dependents
gf (lambda (dep) (update-dependent gf dep 'add-method method))))
(cl:defmethod remove-method :after ((gf standard-generic-function) (method method))
(loop for specializer in (method-specializers method)
if (consp specializer)
do (remove-direct-method
(if (consp specializer)
(intern-eql-specializer*
(eql-specializer-object specializer))
specializer)
method))
(intern-eql-specializer*
(eql-specializer-object specializer))
method)
#-lispworks5.0 else
#-lispworks5.0 do
#-lispworks5.0 (remove-direct-method specializer method))
#+lispworks4.3
(map-dependents
gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
......@@ -396,7 +428,7 @@
if (stringp (car tail))
do (setf documentation
(if (eq documentation :unbound)
(car tail)
(car tail)
(error "Too many documentation strings in lambda expression ~S."
lambda-expression)))
else append (loop for declaration in (cdar tail)
......@@ -410,7 +442,7 @@
gf method args declarations
`(progn ,@tail) env)
(if (eq documentation :unbound)
(return (values method-lambda method-args))
(return (values method-lambda method-args))
(return (values
`(lambda ,(cadr method-lambda)
,documentation
......@@ -445,7 +477,7 @@
until (member arg stop-keywords)
collect arg into gf-lambda-list
finally (return (if (member arg '(&rest &key))
(append gf-lambda-list '(&key))
(append gf-lambda-list '(&key))
gf-lambda-list))))
;; The defmethod macro is needed in order to ensure that make-method-lambda
......@@ -466,14 +498,14 @@
if (stringp (car tail))
do (setq documentation
(if (eq documentation :unbound)
(car tail)
(car tail)
(error "Too many documentation strings for defmethod form ~S." form)))
else append (cdar tail) into declarations
finally
(let* ((lambda-list (extract-lambda-list specialized-args))
(gf-lambda-list (create-gf-lambda-list lambda-list))
(gf (if (fboundp name)
(ensure-generic-function name)
(ensure-generic-function name)
(ensure-generic-function name :lambda-list gf-lambda-list)))
(method-class (generic-function-method-class gf))
(lambda-expression `(lambda ,lambda-list
......@@ -491,7 +523,7 @@
(find-class 't)
(find-class 't))
nil)))
(return-from defmethod `(cl:defmethod ,@(rest form)))
(return-from defmethod `(cl:defmethod ,@(rest form)))
(multiple-value-bind
(method-lambda method-args)
(make-method-lambda
......@@ -500,7 +532,7 @@
(with-unique-names (gf method)
(return-from defmethod
`(let ((,gf (if (fboundp ',name)
(ensure-generic-function ',name)
(ensure-generic-function ',name)
(ensure-generic-function
',name :lambda-list ',gf-lambda-list)))
(,method
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment