mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 05:43:19 -08:00
Code Issues Projects Releases Packages Wiki Activity

Wrapping is taken care of fully in INSTALL-METHOD

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-04-23 23:09:10 +02:00
parent f9b2bbe062
commit fb201406eb
4 changed files with 15 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

6
src/clos/fixup.lsp
View file

@ -254,9 +254,9 @@ their lambda lists ~A and ~A are not congruent."
'(gf args)
'nil
'nil
(wrapped-method-function
#'(ext:lambda-block compute-applicable-methods (gf args)
(std-compute-applicable-methods gf args))))
#'(ext:lambda-block compute-applicable-methods (gf args)
(std-compute-applicable-methods gf args))
t)
(setf (fdefinition 'compute-applicable-methods) #'aux-compute-applicable-methods)
(defmethod compute-applicable-methods-using-classes

8
src/clos/kernel.lsp
View file

@ -215,12 +215,13 @@
;;; ----------------------------------------------------------------------
;;; Methods
(defun install-method (name qualifiers specializers lambda-list doc plist fun
(defun install-method (name qualifiers specializers lambda-list doc plist fun wrap
&optional method-class &rest options)
(declare (ignore doc)
(notinline ensure-generic-function))
; (record-definition 'method `(method ,name ,@qualifiers ,specializers))
(let* ((gf (ensure-generic-function name))
(fun (if wrap (wrapped-method-function fun) fun))
(specializers (mapcar #'(lambda (x)
(cond ((consp x) (intern-eql-specializer (second x)))
((typep x 'specializer) x)
@ -235,6 +236,11 @@
(add-method gf method)
method))
(defun wrapped-method-function (method-function)
#'(lambda (.combined-method-args. *next-methods*)
(declare (special .combined-method-args. *next-methods*))
(apply method-function .combined-method-args.)))
;;; ----------------------------------------------------------------------
;;; early versions

12
src/clos/method.lsp
View file

@ -48,17 +48,12 @@
`(install-method ',name ',qualifiers
,(list 'si::quasiquote specializers)
',lambda-list ',doc
',plist ,fn-form))))))
',plist ,fn-form t))))))
;;; ----------------------------------------------------------------------
;;; method body expansion
(defun wrapped-method-function (method-function)
#'(lambda (.combined-method-args. *next-methods*)
(declare (special .combined-method-args. *next-methods*))
(apply method-function .combined-method-args.)))
(defun expand-defmethod (generic-function-name qualifiers lambda-list
required-parameters specializers body env)
(declare (ignore qualifiers)
@ -126,13 +121,12 @@
.next-methods.))
,@real-body)))))
(values
`(wrapped-method-function
#'(ext::lambda-block ,generic-function-name
`#'(ext::lambda-block ,generic-function-name
,lambda-list
,@(and class-declarations `((declare ,@class-declarations)))
,@(if copied-variables
`((let* ,copied-variables ,@real-body))
real-body)))
real-body))
documentation
plist)))))

4
src/clos/standard.lsp
View file

@ -698,10 +698,10 @@ because it contains a reference to the undefined class~% ~A"
writer-args))))
(dolist (fname (slot-definition-readers slotd))
(install-method fname nil `(,standard-class) '(self) nil nil
reader reader-class :slot-definition slotd))
reader t reader-class :slot-definition slotd))
(dolist (fname (slot-definition-writers slotd))
(install-method fname nil `(,(find-class t) ,standard-class) '(value self)
nil nil writer writer-class :slot-definition slotd))))))
nil nil writer t writer-class :slot-definition slotd))))))
;;; ======================================================================
;;; STANDARD-OBJECT