Commit 5b2275a7 authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Added completely reworked support for ECL.

Ignore-this: 2ab109817fa449fb4b8b8652bacd1487

darcs-hash:f1b3e0310b250651c26bf5477be4c57d2e26cb50
parent 503d313f
(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)) t)
(cl:defmethod make-method-lambda ((gf generic-function) (method method)
lambda-expression environment)
(declare (ignore environment))
(destructuring-bind
(lambda (&rest args) &body body)
lambda-expression
(declare (ignore args))
(assert (eq lambda 'lambda))
(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)
(declare (dynamic-extent args))
(funcall effective-method args nil))))
(cl:defgeneric find-method-combination (generic-function type options)
(:method ((gf generic-function) type options)
(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)
(declare (dynamic-extent 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)
(declare (dynamic-extent 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)
(declare (dynamic-extent 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)
(declare (dynamic-extent 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)
(defvar *direct-methods-for-built-in-classes*
(make-hash-table :test #'eq))
(cl:defgeneric add-direct-method (specializer method)
(:method ((specializer class) (method 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)))
(: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)
(declare (dynamic-extent initargs))
(map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))
(cl:defmethod reinitialize-instance :after ((metaobject funcallable-standard-class) &rest initargs)
(declare (dynamic-extent 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))
(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)
(declare (dynamic-extent 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))))
(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)
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
......@@ -4,12 +4,14 @@
(:use #:common-lisp #+lispworks #:lispworks)
(:nicknames #:c2mop)
#+(or allegro clozure lispworks mcl)
#+(or allegro clozure ecl lispworks mcl)
(:shadow #:standard-class)
#+(or allegro clisp clozure lispworks sbcl)
#+(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)
......@@ -19,6 +21,7 @@
#+allegro #:excl
#+clozure #:ccl
#+cmu #:pcl
#+ecl #:clos
#+lispworks #:clos
#+mcl #:ccl
#+sbcl #:sb-pcl
......@@ -30,6 +33,7 @@
#+clisp #:clos
#+clozure #:ccl
#+cmu #:clos-mop
#+ecl #:clos
#+lispworks #:clos
#+mcl #:ccl
#+sbcl #:sb-mop
......@@ -39,7 +43,7 @@
#:effective-slot-definition
#-lispworks #:eql-specializer
#:forward-referenced-class
#-lispworks #:funcallable-standard-class
#-(or ecl lispworks) #:funcallable-standard-class
#-lispworks4 #:funcallable-standard-object
#:metaobject
#:slot-definition
......@@ -52,8 +56,8 @@
#:standard-writer-method
#-lispworks4.3 #:accessor-method-slot-definition
#-scl #:add-dependent
#-scl #:add-direct-method
#-(or ecl scl) #:add-dependent
#-(or ecl scl) #:add-direct-method
#:add-direct-subclass
#-scl #:class-default-initargs
#-scl #:class-direct-default-initargs
......@@ -64,11 +68,11 @@
#:class-precedence-list
#:class-prototype
#:class-slots
#-(or clozure lispworks mcl) #:compute-applicable-methods-using-classes
#-(or clozure ecl lispworks mcl) #:compute-applicable-methods-using-classes
#:compute-class-precedence-list
#-lispworks #:compute-default-initargs
#-clozure #:compute-discriminating-function
#-(or clozure scl) #:compute-effective-method
#-(or clozure ecl) #:compute-discriminating-function
#-(or clozure ecl scl) #:compute-effective-method
#:compute-effective-slot-definition
#:compute-slots
#:direct-slot-definition-class
......@@ -77,28 +81,28 @@
#:ensure-class-using-class
#:ensure-generic-function-using-class
#-lispworks #:eql-specializer-object
#:extract-lambda-list
#:extract-specializer-names
#-ecl #:extract-lambda-list
#-ecl #:extract-specializer-names
#:finalize-inheritance
#-lispworks #:find-method-combination
#-(or ecl lispworks) #:find-method-combination
#-(or lispworks scl) #:funcallable-standard-instance-access
#-allegro #:generic-function-argument-precedence-order
#:generic-function-declarations
#-ecl #:generic-function-declarations
#:generic-function-lambda-list
#:generic-function-method-class
#-ecl #:generic-function-method-class
#:generic-function-method-combination
#:generic-function-methods
#:generic-function-name
#-lispworks #:intern-eql-specializer
#-(or allegro clisp clozure lispworks mcl scl) #:make-method-lambda
#-scl #:map-dependents
#-(or allegro clisp clozure ecl lispworks mcl scl) #:make-method-lambda
#-(or ecl scl) #:map-dependents
#-clozure #:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#-lispworks4.3 #:reader-method-class
#-scl #:remove-dependent
#-scl #:remove-direct-method
#-(or ecl scl) #:remove-dependent
#-(or ecl scl) #:remove-direct-method
#:remove-direct-subclass
#:set-funcallable-instance-function
#:slot-boundp-using-class
......@@ -116,8 +120,8 @@
#-lispworks #:specializer-direct-generic-functions
#:specializer-direct-methods
#-lispworks #:standard-instance-access
#-scl #:update-dependent
#:validate-superclass
#-(or ecl scl) #:update-dependent
#-ecl #:validate-superclass
#-lispworks4.3 #:writer-method-class)
(:export
......@@ -126,7 +130,7 @@
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#+lispworks #:eql-specializer*
#+(or ecl lispworks) #:eql-specializer*
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
......@@ -200,7 +204,7 @@
#:generic-function-methods
#:generic-function-name
#:intern-eql-specializer
#+lispworks #:intern-eql-specializer*
#+(or ecl lispworks) #:intern-eql-specializer*
#:make-method-lambda
#:map-dependents
#:method-function
......
......@@ -34,7 +34,7 @@
finally (return nil))))
#+(or allegro clozure lispworks mcl)
#+(or allegro clozure ecl lispworks mcl)
(progn
;; validate-superclass for metaclass classes is a little bit
;; more tricky than for class metaobject classes because
......@@ -65,12 +65,21 @@
(defun classp (thing)
(typep thing 'class)))
#+(or allegro clisp clozure lispworks sbcl)
#+(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 lispworks) (argument-order :accessor argument-order)
#-sbcl (initial-methods :initform '()))
(#+(or clozure ecl lispworks) (argument-order :accessor argument-order)
#-sbcl (initial-methods :initform '())
#+ecl (declarations :initarg :declarations :initform '()
:reader generic-function-declarations))
(:metaclass
#-lispworks funcallable-standard-class
......@@ -88,14 +97,16 @@
(defclass standard-method (cl:standard-method)
((fn :initarg :real-function :reader method-function))))
(declaim (inline m-function))
(defun m-function (m)
(method-function m))
(define-compiler-macro m-function (m)
(handler-case (method-function m)
(error () `(the function (method-function real-method-function (the method ,m))))))
#-ecl
(progn
(declaim (inline m-function))
(defun m-function (m)
(method-function m))
(define-compiler-macro m-function (m)
(handler-case (method-function m)
(error () `(the function (method-function real-method-function (the method ,m)))))))
(defun compute-argument-order (gf nof-required-args)
(loop with specialized-count = (make-array nof-required-args :initial-element 0)
......@@ -117,7 +128,9 @@
#-sbcl (cl:defgeneric make-method-lambda (generic-function method lambda-expression environment))
(cl:defmethod make-method-lambda ((gf standard-generic-function) (method standard-method) lambda-expression environment)
#-ecl
(cl:defmethod make-method-lambda ((gf standard-generic-function) (method standard-method)
lambda-expression environment)
(declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0)))
#+(or clozure lispworks sbcl)
(when (only-standard-methods gf)
......@@ -146,7 +159,7 @@
#-clozure '()
#+clozure '(:closer-patch t))))
#+(or clozure lispworks)
#+(or clozure ecl lispworks)
(cl:defgeneric compute-applicable-methods-using-classes (generic-function classes)
(:method ((gf standard-generic-function) classes)
(labels ((subclass* (spec1 spec2 arg-spec)
......@@ -162,7 +175,7 @@
return (subclass* spec1 spec2 (nth n classes)))))
(let ((applicable-methods
(sort
(loop for method of-type method in (the list (generic-function-methods gf))
(loop for method #-ecl of-type #-ecl 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)
......@@ -174,67 +187,82 @@
#'method-more-specific-p)))
(values applicable-methods t)))))
(cl:defgeneric compute-effective-method-function (gf effective-method options)
(:method ((gf generic-function) effective-method options)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(when #-clisp options
#+clisp (or (cdr (assoc :arguments options))
(cdr (assoc :duplicates options)))
(cerror "Ignore these options."
"This version of compute-effective-method-function does not support method combination options: ~S"
options))
(let ((all-t-specializers (required-args (generic-function-lambda-list gf)
(constantly (find-class 't))))
(args (gensym)))
(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)))
`(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
(let ((,method-var ,the-method))
(declare (ignorable ,method-var))
(funcall (m-function ,(if (typep the-method 'method)
the-method method-var))
,args
,@(let ((subforms
(loop for subform in (the list (cddr form))
collect `',subform)))
(if subforms subforms '(())))
:generic-function ,gf
:method ,(if (typep the-method 'method)
the-method method-var)))))))
(make-method (when (cddr form)
(error "Incorrect make-method form: ~S." form))
(let ((method-class (generic-function-method-class gf)))
(ensure-finalized method-class)
(multiple-value-bind
(method-lambda method-options)
(make-method-lambda
gf (class-prototype method-class)
`(lambda (&rest ,args)
(declare (dynamic-extent ,args) (ignorable ,args))
,(transform-effective-method (cadr form))) nil)
(apply #'make-instance
method-class
:qualifiers '()
:specializers all-t-specializers
:lambda-list (generic-function-lambda-list gf)
:function (compile nil method-lambda)
method-options))))
(t (mapcar #'transform-effective-method (the list form)))))))
(let ((emf-lambda `(lambda (&rest ,args)
(declare (dynamic-extent ,args) (ignorable ,args))
,(transform-effective-method effective-method))))
(multiple-value-bind (function warnings failure)
(compile nil emf-lambda)
(declare (ignore warnings))
(assert (not failure))
function))))))
#+clozure (cl:defgeneric compute-effective-method (generic-function combination methods))
#+clozure (cl:defgeneric compute-discriminating-function (generic-function))
(cl:defgeneric compute-effective-method-function (gf effective-method options))