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

Fixed accessor redefinition (recursion problem still persists)

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-10-06 22:36:47 +02:00
parent 0563353926
commit ed78ecd2ea
4 changed files with 32 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/clos/generic.lsp
View file

@ -176,7 +176,8 @@
&rest initargs)
(declare (ignore initargs slot-names))
(call-next-method)
(compute-g-f-spec-list gfun)
(when (generic-function-methods gfun)
(compute-g-f-spec-list gfun))
(update-dependents gfun initargs)
gfun)

31
src/clos/method.lsp
View file

@ -360,21 +360,22 @@ have disappeared."
;;; early version used during bootstrap
(defun add-method (gf method)
(let* ((name (generic-function-name gf))
(method-entry (assoc name *early-methods*)))
(unless method-entry
(setq method-entry (list name))
(push method-entry *early-methods*))
(push method (cdr method-entry))
(push method (generic-function-methods gf))
(setf (method-generic-function method) gf)
(unless (si::sl-boundp (generic-function-lambda-list gf))
(setf (generic-function-lambda-list gf) (method-lambda-list method))
(setf (generic-function-argument-precedence-order gf)
(rest (si::process-lambda-list (method-lambda-list method) t))))
(compute-g-f-spec-list gf)
(set-generic-function-dispatch gf)
method))
(with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
(let* ((name (generic-function-name gf))
(method-entry (assoc name *early-methods*)))
(unless method-entry
(setq method-entry (list name))
(push method-entry *early-methods*))
(push method (cdr method-entry))
(push method (generic-function-methods gf))
(setf (method-generic-function method) gf)
(unless (si::sl-boundp (generic-function-lambda-list gf))
(setf (generic-function-lambda-list gf) (method-lambda-list method))
(setf (generic-function-argument-precedence-order gf)
(rest (si::process-lambda-list (method-lambda-list method) t))))
(compute-g-f-spec-list gf)
(set-generic-function-dispatch gf)
method)))
(defun find-method (gf qualifiers specializers &optional (errorp t))
(declare (notinline method-qualifiers))

4
src/clos/slotvalue.lsp
View file

@ -138,12 +138,12 @@ Slot name: ~A"
(defmethod slot-missing ((class t) object slot-name operation
&optional new-value)
(declare (ignore operation new-value class))
(print slot-name)
(print (class-id class))
(print (list 'slot-missing slot-name (class-id class)))
(error "~A is not a slot of ~A" slot-name object))
(defmethod slot-unbound ((class t) object slot-name)
(declare (ignore class))
(print (list 'slot-unbound (class-id class) (print slot-name)))
(error 'unbound-slot :instance object :name slot-name))
;;;

23
src/clos/standard.lsp
View file

@ -577,7 +577,7 @@ because it contains a reference to the undefined class~% ~A"
(si::c-local))
(let* ((class (class-of object))
(slotd (find index (class-slots class) :key #'slot-definition-location)))
(values (slotd-unbound class object (slot-definition-name slotd)))))
(values (slot-unbound class object (slot-definition-name slotd)))))
(defun safe-instance-ref (object index)
(declare (type standard-object object)
@ -658,16 +658,17 @@ because it contains a reference to the undefined class~% ~A"
(defun safe-add-method (name method)
;; Adds a method to a function which might have been previously defined
;; as non-generic, without breaking the function
(if (or *clos-booted*
(not (fboundp name))
(si::instancep (fdefinition name)))
(add-method (ensure-generic-function name) method)
(let* ((alt-name '#:foo)
(gf (ensure-generic-function alt-name)))
(add-method gf method)
(setf (fdefinition name) gf
(generic-function-name gf) name)
(fmakunbound alt-name))))
(cond ((or *clos-booted*
(not (fboundp name))
(si::instancep (fdefinition name)))
(add-method (ensure-generic-function name) method))
(t
(let* ((alt-name '#:foo)
(gf (ensure-generic-function alt-name)))
(add-method gf method)
(setf (generic-function-name gf) name)
(setf (fdefinition name) gf)
(fmakunbound alt-name)))))
(defun std-class-generate-accessors (standard-class &aux optimizable)
;;