Commit d53dfebb authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Added support for ECL 12.12.1 - lots of improvements!

Ignore-this: ca11b0358015cfd046cf0a44a359ed25

darcs-hash:5592e88d4c6284f79974d99677b8f64e7241ced6
parent d22a60ea
(in-package :closer-mop)
(defmacro removef (place item)
`(setf ,place (remove ,item ,place)))
(defun extract-lambda-list (lambda-list)
(loop for (arg . rest) on lambda-list
for keyp = (member arg lambda-list-keywords)
until keyp
if (consp arg)
collect (car arg) into args
else collect arg into args
finally (return (if keyp
(nconc args (cons arg rest))
args))))
(defun extract-specializer-names (lambda-list)
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
if (consp arg)
collect (cadr arg)
else collect 't))
(cl:defgeneric generic-function-method-class (object)
(:method ((gf generic-function))
(clos:generic-function-method-class gf)))
(cl:defmethod compute-discriminating-function ((gf generic-function))
(declare (ignore gf))
t)
(cl:defmethod make-method-lambda ((gf generic-function) (method method)
lambda-expression environment)
(declare (ignore environment method gf))
(destructuring-bind
(lambda (&rest args) &body body)
lambda-expression
(assert (eq lambda 'lambda))
(when (and (member '&key args :test #'eq)
(not (member '&allow-other-keys args :test #'eq)))
(let ((tail (member '&aux args :test #'eq)))
(setq lambda-expression
`(lambda (,.(ldiff args tail) &allow-other-keys ,@tail) ,@body))))
(values
lambda-expression
(let ((documentation (parse-method-body body lambda-expression)))
(when documentation
(list 'documentation documentation))))))
(cl:defmethod compute-effective-method-function ((gf standard-generic-function) effective-method options)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(when options
(cerror "Ignore these options."
"This version of compute-effective-method-function does not support method combination options: ~S"
options))
(if (only-standard-methods gf)
effective-method
(lambda (&rest args)
(funcall effective-method args nil))))
(cl:defgeneric find-method-combination (generic-function type options)
(:method ((gf generic-function) type options)
(declare (ignore gf))
(cons type options)))
(defclass standard-class (cl:standard-class)
((direct-methods :initform '() :reader specializer-direct-methods)))
(defun optimize-slot-access-p (class)
(flet ((applicablep (specializer)
(if (consp specializer)
(eql class (eql-specializer-object specializer))
(subclassp (class-of class) specializer))))
(when (and (loop for method in (generic-function-methods #'slot-value-using-class)
never (applicablep (first (method-specializers method))))
(loop for method in (generic-function-methods #'(setf slot-value-using-class))
never (applicablep (second (method-specializers method)))))
'(t))))
(cl:defmethod initialize-instance :around ((class standard-class) &rest initargs)
(apply #'call-next-method class
:optimize-slot-access
(optimize-slot-access-p class)
initargs))
(cl:defmethod reinitialize-instance :around ((class standard-class) &rest initargs)
(apply #'call-next-method class
:optimize-slot-access
(optimize-slot-access-p class)
initargs))
(cl:defmethod initialize-instance :around ((class funcallable-standard-class) &rest initargs)
(apply #'call-next-method class
:optimize-slot-access
(optimize-slot-access-p class)
initargs))
(cl:defmethod reinitialize-instance :around ((class funcallable-standard-class) &rest initargs)
(apply #'call-next-method class
:optimize-slot-access
(optimize-slot-access-p class)
initargs))
(cl:defmethod initialize-instance :before ((class standard-class) &key direct-superclasses)
(assert (loop for superclass in direct-superclasses
always (validate-superclass class superclass))))
(cl:defmethod reinitialize-instance :before ((class standard-class) &key (direct-superclasses '() direct-superclasses-p))
(when direct-superclasses-p
(assert (loop for superclass in direct-superclasses
always (validate-superclass class superclass)))
(loop for superclass in (class-direct-superclasses class)
unless (member superclass direct-superclasses)
do (remove-direct-subclass superclass class))))
(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
(assert (loop for superclass in direct-superclasses
always (validate-superclass class superclass))))
(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
(assert (loop for superclass in direct-superclasses
always (validate-superclass class superclass))))
(cl:defmethod (setf class-name) (new-value (class standard-class))
(reinitialize-instance class :name new-value)
new-value)
(cl:defmethod (setf generic-function-name) (new-value (gf standard-generic-function))
(reinitialize-instance gf :name new-value)
new-value)
(declaim (inline set-generic-function-name))
(defun set-generic-function-name (gf new-value)
(funcall (load-time-value (fdefinition '(setf generic-function-name))) new-value gf))
(defsetf generic-function-name set-generic-function-name)
(defvar *direct-methods-for-built-in-classes*
(make-hash-table :test #'eq))
(cl:defgeneric add-direct-method (specializer method)
(:method ((specializer class) (method method))
(declare (ignore specializer method)))
(:method ((specializer built-in-class) (method method))
(pushnew method (gethash specializer *direct-methods-for-built-in-classes*)))
(:method ((specializer standard-class) (method method))
(pushnew method (slot-value specializer 'direct-methods)))
(:method ((specializer funcallable-standard-class) (method method))
(pushnew method (slot-value specializer 'direct-methods))))
(cl:defgeneric remove-direct-method (specializer method)
(:method ((specializer class) (method method))
(declare (ignore specializer method)))
(:method ((specializer built-in-class) (method method))
(removef (gethash specializer *direct-methods-for-built-in-classes*) method))
(:method ((specializer standard-class) (method method))
(removef (slot-value specializer 'direct-methods) method))
(:method ((specializer funcallable-standard-class) (method method))
(removef (slot-value specializer 'direct-methods) method)))
(defvar *dependents* (make-hash-table :test #'eq))
(cl:defgeneric add-dependent (metaobject dependent)
(:method ((metaobject standard-class) dependent)
(pushnew dependent (gethash metaobject *dependents*)))
(:method ((metaobject funcallable-standard-class) dependent)
(pushnew dependent (gethash metaobject *dependents*)))
(:method ((metaobject standard-generic-function) dependent)
(pushnew dependent (gethash metaobject *dependents*))))
(cl:defgeneric remove-dependent (metaobject dependent)
(:method ((metaobject standard-class) dependent)
(setf (gethash metaobject *dependents*)
(delete dependent (gethash metaobject *dependents*))))
(:method ((metaobject funcallable-standard-class) dependent)
(setf (gethash metaobject *dependents*)
(delete dependent (gethash metaobject *dependents*))))
(:method ((metaobject standard-generic-function) dependent)
(setf (gethash metaobject *dependents*)
(delete dependent (gethash metaobject *dependents*)))))
(cl:defgeneric map-dependents (metaobject function)
(:method ((metaobject standard-class) function)
(mapc function (gethash metaobject *dependents*)))
(:method ((metaobject funcallable-standard-class) function)
(mapc function (gethash metaobject *dependents*)))
(:method ((metaobject standard-generic-function) function)
(mapc function (gethash metaobject *dependents*))))
(cl:defgeneric update-dependent (metaobject dependent &rest initargs))
(cl:defmethod reinitialize-instance :after ((metaobject standard-class) &rest initargs)
(map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))
(cl:defmethod reinitialize-instance :after ((metaobject funcallable-standard-class) &rest initargs)
(map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))
(cl:defmethod initialize-instance :after ((gf standard-generic-function) &rest initargs)
(declare (ignore initargs))
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
(cl:defmethod ensure-generic-function-using-class :around ((gf null) name &rest initargs)
(declare (ignore name initargs gf))
(let ((new-gf (call-next-method)))
(if (typep new-gf 'standard-generic-function)
(set-funcallable-instance-function new-gf (compute-discriminating-function new-gf))
new-gf)))
(cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &rest initargs)
(set-funcallable-instance-function gf (compute-discriminating-function gf))
(map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs))))
(cl:defgeneric remove-method (gf method)
(:method ((gf generic-function) (method method))
(cl:remove-method gf method)))
(cl:defmethod remove-method :after ((gf standard-generic-function) (method method))
(set-funcallable-instance-function gf (compute-discriminating-function gf))
(loop for specializer in (method-specializers method)
if (consp specializer) do (remove-direct-method (intern-eql-specializer*
(eql-specializer-object specializer))
method)
else do (remove-direct-method specializer method))
(map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
(cl:defgeneric find-method (gf qualifiers specializers &optional errorp)
(:method ((gf generic-function) qualifiers specializers &optional (errorp t))
(cl:find-method gf qualifiers specializers errorp)))
(cl:defmethod add-method :before ((gf standard-generic-function) (method method))
(let ((other-gf (method-generic-function method)))
(unless (or (null other-gf) (eq other-gf gf))
(error "The method ~S belongs to the generic function ~S and cannot be added to ~S."
method other-gf gf)))
(let ((old-method (find-method gf
(method-qualifiers method)
(method-specializers method)
nil)))
(when old-method
(remove-method gf old-method))))
(cl:defmethod add-method :after ((gf standard-generic-function) (method method))
(set-funcallable-instance-function gf (compute-discriminating-function gf))
(loop for specializer in (method-specializers method)
if (consp specializer) do (add-direct-method (intern-eql-specializer*
(eql-specializer-object specializer))
method)
else do (add-direct-method specializer method))
(map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method))))
(coerce `(lambda (&rest clos:.combined-method-args.)
(declare (special clos:.combined-method-args. clos:*next-methods*))
,effective-method)
'function))
(declaim (inline eql-specializer-p))
(defun eql-specializer-p (thing)
(and (consp thing)
(eq (car thing) 'eql)
(null (cddr thing))))
(deftype eql-specializer ()
'(or eql-specializer* (satisfies eql-specializer-p)))
(cl:defgeneric eql-specializer-object (eql-specializer)
(:method ((cons cons))
(if (eql-specializer-p cons)
(cadr cons)
(error "~S is not an eql-specializer." cons))))
(defun intern-eql-specializer (object)
`(eql ,object))
(cl:defmethod specializer-direct-methods ((cons cons))
(specializer-direct-methods (eql-specializer-object cons)))
(defclass eql-specializer* ()
((obj :reader eql-specializer-object
:initarg eso
:initform (error "Use intern-eql-specializer to create eql-specializers."))
(direct-methods :reader specializer-direct-methods
:accessor es-direct-methods
:initform ())))
(defvar *eql-specializers* (make-hash-table))
#+threads
(defvar *eql-specializers-lock* (mp:make-lock :name 'eql-specializers))
(defmacro with-eql-specializers-lock (&body body)
#+threads `(mp:with-lock (*eql-specializers-lock*) ,@body)
#-threads `(progn ,@body))
(defun intern-eql-specializer* (object)
(or #+threads (gethash object *eql-specializers*)
(with-eql-specializers-lock
(or (gethash object *eql-specializers*)
(setf (gethash object *eql-specializers*)
(make-instance 'eql-specializer* 'eso object))))))
(cl:defmethod add-direct-method ((specializer eql-specializer*) (method method))
(pushnew method (es-direct-methods specializer)))
(cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method))
(removef (es-direct-methods specializer) method))
(cl:defgeneric specializer-direct-generic-functions (specializer)
(:method ((class class))
(remove-duplicates
(mapcar #'method-generic-function
(specializer-direct-methods class))))
(:method ((eql-specializer eql-specializer*))
(remove-duplicates
(mapcar #'method-generic-function
(specializer-direct-methods eql-specializer))))
(:method ((cons cons))
(specializer-direct-generic-functions
(intern-eql-specializer*
(eql-specializer-object cons)))))
(cl:defgeneric validate-superclass (class superclass)
(:method (class superclass)
(or (eq superclass (find-class 't))
(typep superclass (find-class 'forward-referenced-class))
(eq (class-of class) (class-of superclass))
(let ((compatible-classes (list (find-class 'cl:standard-class)
(find-class 'standard-class)
(find-class 'clos:funcallable-standard-class)
(find-class 'funcallable-standard-class))))
(and (member (class-of class) compatible-classes)
(member (class-of superclass) compatible-classes))))))
(define-validate-superclass-method standard-class cl:standard-class)
(define-validate-superclass-method funcallable-standard-class clos:funcallable-standard-class)
(typep thing 'eql-specializer))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
......@@ -4,14 +4,12 @@
(:use #:common-lisp #+lispworks #:lispworks)
(:nicknames #:c2mop)
#+(or allegro clozure ecl lispworks mcl)
#+(or allegro clozure lispworks mcl)
(:shadow #:standard-class)
#+(or allegro clisp clozure ecl lispworks sbcl)
(:shadow #:defgeneric #:defmethod #:standard-generic-function)
#+ecl (:shadow #:compute-applicable-methods #:find-method #:remove-method)
#+clozure (:shadow standard-method)
#+(or cmu mcl) (:shadow #:typep subtypep)
......@@ -48,7 +46,7 @@
#:effective-slot-definition
#-lispworks #:eql-specializer
#:forward-referenced-class
#-(or ecl lispworks) #:funcallable-standard-class
#-lispworks #:funcallable-standard-class
#-lispworks4 #:funcallable-standard-object
#:metaobject
#:slot-definition
......@@ -61,8 +59,8 @@
#:standard-writer-method
#-lispworks4.3 #:accessor-method-slot-definition
#-(or ecl scl) #:add-dependent
#-(or ecl scl) #:add-direct-method
#-scl #:add-dependent
#-scl #:add-direct-method
#:add-direct-subclass
#-scl #:class-default-initargs
#-scl #:class-direct-default-initargs
......@@ -73,11 +71,11 @@
#:class-precedence-list
#:class-prototype
#:class-slots
#-(or clozure ecl lispworks mcl) #:compute-applicable-methods-using-classes
#-(or clozure lispworks mcl) #:compute-applicable-methods-using-classes
#:compute-class-precedence-list
#-(or lispworks4 lispworks5) #:compute-default-initargs
#-(or clozure ecl) #:compute-discriminating-function
#-(or clozure ecl scl) #:compute-effective-method
#-clozure #:compute-discriminating-function
#-(or clozure scl) #:compute-effective-method
#:compute-effective-slot-definition
#:compute-slots
#:direct-slot-definition-class
......@@ -86,28 +84,28 @@
#:ensure-class-using-class
#:ensure-generic-function-using-class
#-lispworks #:eql-specializer-object
#-ecl #:extract-lambda-list
#-ecl #:extract-specializer-names
#:extract-lambda-list
#:extract-specializer-names
#:finalize-inheritance
#-(or ecl lispworks) #:find-method-combination
#-lispworks #:find-method-combination
#-(or lispworks scl) #:funcallable-standard-instance-access
#-allegro #:generic-function-argument-precedence-order
#-ecl #:generic-function-declarations
#:generic-function-declarations
#:generic-function-lambda-list
#-ecl #:generic-function-method-class
#:generic-function-method-class
#:generic-function-method-combination
#:generic-function-methods
#:generic-function-name
#-lispworks #:intern-eql-specializer
#-(or allegro clisp clozure ecl lispworks mcl scl) #:make-method-lambda
#-(or ecl scl) #:map-dependents
#-(or allegro clisp clozure lispworks mcl scl) #:make-method-lambda
#-scl #:map-dependents
#-clozure #:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#-lispworks4.3 #:reader-method-class
#-(or ecl scl) #:remove-dependent
#-(or ecl scl) #:remove-direct-method
#-scl #:remove-dependent
#-scl #:remove-direct-method
#:remove-direct-subclass
#:set-funcallable-instance-function
#:slot-boundp-using-class
......@@ -125,8 +123,8 @@
#-lispworks #:specializer-direct-generic-functions
#:specializer-direct-methods
#-lispworks #:standard-instance-access
#-(or ecl scl) #:update-dependent
#-ecl #:validate-superclass
#-scl #:update-dependent
#:validate-superclass
#-lispworks4.3 #:writer-method-class)
(:export
......@@ -135,7 +133,7 @@
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#+(or ecl lispworks) #:eql-specializer*
#+lispworks #:eql-specializer*
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
......@@ -209,7 +207,7 @@
#:generic-function-methods
#:generic-function-name
#:intern-eql-specializer
#+(or ecl lispworks) #:intern-eql-specializer*
#+lispworks #:intern-eql-specializer*
#:make-method-lambda
#:map-dependents
#:method-function
......
......@@ -34,7 +34,7 @@
finally (return nil))))
#+(or allegro clozure ecl lispworks mcl)
#+(or allegro clozure lispworks mcl)
(progn
;; validate-superclass for metaclass classes is a little bit
;; more tricky than for class metaobject classes because
......@@ -68,25 +68,16 @@
#+(or allegro clisp clozure ecl lispworks sbcl)
(progn ;;; New generic functions.
#+ecl
(cl:defgeneric specializer-direct-methods (metaobject))
#+ecl
(defclass funcallable-standard-class (clos:funcallable-standard-class)
((direct-methods :initform '() :reader specializer-direct-methods)))
(defclass standard-generic-function (cl:standard-generic-function)
(#+(or clozure ecl lispworks) (argument-order :accessor argument-order)
#-sbcl (initial-methods :initform '())
#+ecl (declarations :initarg :declarations :initform '()
:reader generic-function-declarations))
(#+(or clozure lispworks) (argument-order :accessor argument-order)
#-(or abcl sbcl) (initial-methods :initform '()))
(:metaclass
#-lispworks funcallable-standard-class
#+lispworks clos:funcallable-standard-class)
#+clozure
(:default-initargs :name (gensym) :method-class (find-class 'standard-method)))
(:default-initargs :name (copy-symbol :name) :method-class (find-class 'standard-method)))
#+clozure
(progn
......@@ -147,8 +138,8 @@
#+(or clozure lispworks sbcl)
(when (only-standard-methods gf)
(return-from make-method-lambda (call-next-method)))
(let ((args (gensym)) (next-methods (gensym))
(more-args (gensym)) (method-function (gensym)))
(let ((args (copy-symbol 'args)) (next-methods (copy-symbol 'next-methods))
(more-args (copy-symbol 'more-args)) (method-function (copy-symbol 'method-function)))
(destructuring-bind
(lambda (&rest lambda-args) &body body)
lambda-expression
......@@ -178,7 +169,7 @@
#+clozure '(:closer-patch t)
#-clozure '()))))))
#+(or clozure ecl lispworks)
#+(or clozure lispworks)
(cl:defgeneric compute-applicable-methods-using-classes (generic-function classes)
(:method ((gf standard-generic-function) classes)
(labels ((subclass* (spec1 spec2 arg-spec)
......@@ -194,7 +185,7 @@
return (subclass* spec1 spec2 (nth n classes)))))
(let ((applicable-methods
(sort
(loop for method #-ecl of-type #-ecl method in (the list (generic-function-methods gf))
(loop for method of-type method in (the list (generic-function-methods gf))
when (loop for class in classes
for specializer in (the list (method-specializers method))
if (typep specializer 'eql-specializer)
......@@ -219,13 +210,13 @@
options))
(let ((all-t-specializers (required-args (generic-function-lambda-list gf)
(constantly (find-class 't))))
(args (gensym)))
(args (copy-symbol 'args)))
(labels ((transform-effective-method (form)
(if (atom form) form
(case (car form)
(call-method (transform-effective-method
(let ((the-method (transform-effective-method (cadr form)))
(method-var (gensym)))
(method-var (copy-symbol 'method-var)))
`(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
(let ((,method-var ,the-method))
(declare (ignorable ,method-var))
......@@ -273,16 +264,6 @@
#+clozure
(cl:defgeneric compute-discriminating-function (generic-function))
#+ecl
(cl:defgeneric compute-effective-method (generic-function combination methods)
(:method ((gf generic-function) combination methods)
(clos:compute-effective-method gf combination methods)))
#+ecl
(cl:defgeneric compute-applicable-methods (gf arguments)
(:method ((gf generic-function) arguments)
(cl:compute-applicable-methods gf arguments)))
(defun get-emf (gf args nof-required-args)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(let ((applicable-methods (compute-applicable-methods gf (subseq args 0 nof-required-args))))
......@@ -319,7 +300,9 @@
(defvar *standard-gfs*
(list #'compute-applicable-methods #'compute-applicable-methods-using-classes
#'compute-effective-method #'compute-effective-method-function #'make-method-lambda
#'compute-effective-method #'compute-effective-method-function
#'generic-function-method-class
#'make-method-lambda
#+allegro #'compute-discriminating-function))
(defun only-standard-methods (gf &rest other-gfs)
......@@ -356,9 +339,14 @@
(defun compute-discriminator (gf compute-native-discriminator)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(let ((nof-required-args (length (required-args (generic-function-lambda-list gf))))
(let ((nof-required-args
(length (required-args
(handler-case (generic-function-lambda-list gf)
(unbound-slot ()
(return-from compute-discriminator
(funcall compute-native-discriminator)))))))
discriminator)
#+(or clozure ecl lispworks)
#+(or clozure lispworks)
(setf (argument-order gf)
(compute-argument-order gf nof-required-args))
(flet ((discriminate (emf-setter args &optional (classes (loop for arg in args
......@@ -376,8 +364,8 @@
#+allegro #'compute-discriminating-function)
(funcall compute-native-discriminator)
(let ((argument-order
#-(or clozure ecl lispworks) (compute-argument-order gf nof-required-args)
#+(or clozure ecl lispworks) (argument-order gf)))
#-(or clozure lispworks) (compute-argument-order gf nof-required-args)
#+(or clozure lispworks) (argument-order gf)))
(cond ((null (generic-function-methods gf))
(lambda (&rest args)
(apply #'no-applicable-method gf args)))
......@@ -470,7 +458,7 @@
if (eq (car option) :method) collect option into method-options
else collect option into non-method-options
finally
(let ((gf (gensym))
(let ((gf (copy-symbol 'gf))
(non-standard (when generic-function-class-name
(let ((standard-generic-function (find-class 'standard-generic-function t env))
(this-generic-function (find-class generic-function-class-name t env)))
......@@ -566,7 +554,6 @@
(warn 'defmethod-without-generic-function :name name)))
(unless (typep generic-function 'standard-generic-function)
(return-from defmethod `(cl:defmethod ,@(cdr form))))
#-ecl
(when (only-standard-methods generic-function)
(return-from defmethod `(cl:defmethod ,@(cdr form))))
......@@ -666,14 +653,14 @@
:initargs :initform :initfunction
:readers :writers))
#+(or cmu ecl scl)
#+(or cmu scl)
(define-modify-macro nconcf (&rest lists) nconc)