mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-17 14:51:20 -08:00
Code Issues Projects Releases Packages Wiki Activity

All accessors are redefined as generic functions after bootstrapping ECL

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-10-05 23:04:12 +02:00
parent 5acf316523
commit d799c7a4e7
2 changed files with 26 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/clos/fixup.lsp
View file

@ -45,7 +45,9 @@
(map-into direct-slots #'identity new-direct-slots)
(map-into effective-slots #'identity new-effective-slots)
(when (typep class 'std-class)
(std-create-slots-table class)))
(std-create-slots-table class)
)
(std-class-generate-accessors class))
(mapc #'convert-one-class (class-direct-subclasses class)))
;;;

32
src/clos/standard.lsp
View file

@ -655,8 +655,21 @@ because it contains a reference to the undefined class~% ~A"
#'(lambda (value self)
(setf (slot-value self slot-name) value))))
(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))))
(defun std-class-generate-accessors (standard-class &aux optimizable)
(declare (si::c-local))
;;
;; The accessors are closures, which are generated every time the
;; slots of the class change. The accessors are safe: they check that
@ -700,15 +713,16 @@ because it contains a reference to the undefined class~% ~A"
(apply #'writer-method-class standard-class slotd
writer-args))))
(dolist (fname (slot-definition-readers slotd))
(add-method (ensure-generic-function fname)
(make-method reader-class nil `(,standard-class) '(self)
(wrapped-method-function reader)
(list :slot-definition slotd))))
(safe-add-method fname
(make-method reader-class nil `(,standard-class) '(self)
(wrapped-method-function reader)
(list :slot-definition slotd))))
(dolist (fname (slot-definition-writers slotd))
(add-method (ensure-generic-function fname)
(make-method writer-class nil `(,(find-class t) ,standard-class) '(value self)
(wrapped-method-function writer)
(list :slot-definition slotd))))))))
(safe-add-method fname
(make-method writer-class nil
`(,(find-class t) ,standard-class) '(value self)
(wrapped-method-function writer)
(list :slot-definition slotd))))))))
;;; ======================================================================
;;; STANDARD-OBJECT