mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-21 12:03:40 -08:00
Generating accessors happens at a later stage in std-accessors.lsp
This commit is contained in:
Juan Jose Garcia Ripoll
parent
e8ac760e2c
commit
43a5b0fdae
4 changed files with 237 additions and 198 deletions
|
|
@ -15,6 +15,38 @@
|
|||
(defconstant +builtin-classes-pre-array+
|
||||
(make-array (1+ #.(length +builtin-classes-list+))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; The following macro is also used at bootstap for instantiating
|
||||
;;; a class based only on the s-form description.
|
||||
;;;
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defmacro with-early-make-instance (slots (object class &rest key-value-pairs)
|
||||
&rest body)
|
||||
(when (symbolp slots)
|
||||
(setf slots (symbol-value slots)))
|
||||
`(let* ((%class ,class)
|
||||
(,object (si::allocate-raw-instance nil %class
|
||||
,(length slots))))
|
||||
(declare (type standard-object ,object))
|
||||
,@(flet ((initializerp (name list)
|
||||
(not (eq (getf list name 'wrong) 'wrong))))
|
||||
(loop for (name . slotd) in slots
|
||||
for initarg = (getf slotd :initarg)
|
||||
for initform = (getf slotd :initform (si::unbound))
|
||||
for initvalue = (getf key-value-pairs initarg)
|
||||
for index from 0
|
||||
do (cond ((and initarg (initializerp initarg key-value-pairs))
|
||||
(setf initform (getf key-value-pairs initarg)))
|
||||
((initializerp name key-value-pairs)
|
||||
(setf initform (getf key-value-pairs name))))
|
||||
when (si:sl-boundp initform)
|
||||
collect `(si::instance-set ,object ,index ,initform)))
|
||||
(when %class
|
||||
(si::instance-sig-set ,object))
|
||||
(with-early-accessors (,slots)
|
||||
,@body))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Building the classes T, CLASS, STANDARD-OBJECT and STANDARD-CLASS.
|
||||
;;;
|
||||
|
|
@ -87,42 +119,6 @@
|
|||
(slot-table class) table
|
||||
(class-direct-slots class) (copy-list all-slots)))))
|
||||
|
||||
(defun reader-closure (index)
|
||||
(declare (si::c-local))
|
||||
(lambda (object) (si::instance-ref object index)))
|
||||
|
||||
(defun writer-closure (index)
|
||||
(declare (si::c-local))
|
||||
(lambda (value object) (si::instance-set object index value)))
|
||||
|
||||
(defun generate-accessors (class slotd-definitions)
|
||||
(declare (si::c-local)
|
||||
(optimize speed (safety 0)))
|
||||
(loop for index from 0
|
||||
for slotd in slotd-definitions
|
||||
do (loop with key-value-pairs = (rest slotd)
|
||||
for key = (pop key-value-pairs)
|
||||
for value = (pop key-value-pairs)
|
||||
while key
|
||||
do (case key
|
||||
(:reader
|
||||
(setf (fdefinition value) (reader-closure index))
|
||||
#+(or)
|
||||
(install-method value nil (list class) '(self)
|
||||
(reader-closure index) t))
|
||||
#+(or)
|
||||
(:writer ;; not used above
|
||||
(setf (fdefinition value) (writer-closure index)))
|
||||
(:accessor
|
||||
(setf (fdefinition value) (reader-closure index)
|
||||
(fdefinition `(setf ,value)) (writer-closure index))
|
||||
#+(or)
|
||||
(install-method value nil (list class) '(self)
|
||||
(reader-closure index) t))
|
||||
#+(or)
|
||||
(install-method value nil (list (find-class 't) class) '(value self)
|
||||
(writer-closure index) t)))))
|
||||
|
||||
;; 1) Create the classes
|
||||
;;
|
||||
;; Notice that, due to circularity in the definition, STANDARD-CLASS has
|
||||
|
|
@ -137,8 +133,6 @@
|
|||
(defconstant +the-std-class+ (find-class 'std-class nil))
|
||||
(defconstant +the-funcallable-standard-class+
|
||||
(find-class 'funcallable-standard-class nil))
|
||||
(loop for c in class-hierarchy
|
||||
do (generate-accessors (find-class (first c)) (getf (rest c) :direct-slots)))
|
||||
;;
|
||||
;; 2) Class T had its metaclass wrong. Fix it.
|
||||
;;
|
||||
|
|
@ -150,5 +144,5 @@
|
|||
;;
|
||||
;; This is needed for further optimization
|
||||
;;
|
||||
(setf (class-sealedp (find-class 'method-combination)) t)
|
||||
(setf (slot-value (find-class 'method-combination) 'sealedp) t)
|
||||
))
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
"src:clos;std-slot-value.lsp"
|
||||
"src:clos;boot.lsp"
|
||||
"src:clos;kernel.lsp"
|
||||
"src:clos;std-accessors.lsp"
|
||||
"src:clos;method.lsp"
|
||||
"src:clos;combin.lsp"
|
||||
"src:clos;defclass.lsp"
|
||||
|
|
|
|||
|
|
@ -565,165 +565,6 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(defmethod compute-slots :around ((class std-class))
|
||||
(std-class-compute-slots class (call-next-method)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Optional accessors
|
||||
;;;
|
||||
|
||||
(defun unbound-slot-error (object index)
|
||||
(declare (type standard-object object)
|
||||
(type fixnum index)
|
||||
(optimize (safety 0))
|
||||
(si::c-local))
|
||||
(let* ((class (class-of object))
|
||||
(slotd (find index (class-slots class) :key #'slot-definition-location)))
|
||||
(values (slot-unbound class object (slot-definition-name slotd)))))
|
||||
|
||||
(defun safe-instance-ref (object index)
|
||||
(declare (type standard-object object)
|
||||
(type fixnum index)
|
||||
(optimize (safety 0)))
|
||||
(let ((value (si:instance-ref object index)))
|
||||
(if (si:sl-boundp value)
|
||||
value
|
||||
(unbound-slot-error object index))))
|
||||
|
||||
;;; The following does not get as fast as it should because we are not
|
||||
;;; allowed to memoize the position of a slot. The problem is that the
|
||||
;;; AMOP specifies that slot accessors are created from the direct
|
||||
;;; slots, without knowing the slot position. This semantics is
|
||||
;;; required for working standard-reader- and
|
||||
;;; standard-writer-method. OTOH if we want to have memoized slot
|
||||
;;; positions we have to work from the effective slots and we have to
|
||||
;;; create methods for all slots, not only the direct ones in this
|
||||
;;; class. Both semantics are incompatible, but we currently have no
|
||||
;;; safe way to choose one or another
|
||||
;;;
|
||||
(defun std-class-optimized-accessors (slot-name)
|
||||
(declare (si::c-local))
|
||||
(macrolet ((slot-table (class)
|
||||
`(si::instance-ref ,class #.(position 'slot-table +standard-class-slots+
|
||||
:key #'first)))
|
||||
(slot-definition-location (slotd)
|
||||
`(si::instance-ref ,slotd #.(position 'location +slot-definition-slots+
|
||||
:key #'first))))
|
||||
(values #'(lambda (self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(let* ((class (si:instance-class self))
|
||||
(table (slot-table class))
|
||||
(slotd (truly-the slot-definition (gethash slot-name table)))
|
||||
(index (slot-definition-location slotd))
|
||||
(value (if (si::fixnump index)
|
||||
(si:instance-ref self (truly-the fixnum index))
|
||||
(car (truly-the cons index)))))
|
||||
(if (si:sl-boundp value)
|
||||
value
|
||||
(values (slot-unbound (class-of self) self slot-name)))))
|
||||
#'(lambda (value self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(let* ((class (si:instance-class self))
|
||||
(table (slot-table class))
|
||||
(slotd (truly-the slot-definition (gethash slot-name table)))
|
||||
(index (slot-definition-location slotd)))
|
||||
(if (si::fixnump index)
|
||||
(si:instance-set self (truly-the fixnum index) value)
|
||||
(rplaca (truly-the cons index) value)))))))
|
||||
|
||||
(defun std-class-sealed-accessors (index)
|
||||
(declare (si::c-local)
|
||||
(fixnum index))
|
||||
(values #'(lambda (self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(safe-instance-ref self index))
|
||||
#'(lambda (value self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(si:instance-set self index value))))
|
||||
|
||||
(defun std-class-accessors (slot-name)
|
||||
(declare (si::c-local))
|
||||
;; The following are very slow. We do not optimize for the slot position.
|
||||
(values #'(lambda (self)
|
||||
(slot-value self slot-name))
|
||||
#'(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
|
||||
(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)
|
||||
;;
|
||||
;; The accessors are closures, which are generated every time the
|
||||
;; slots of the class change. The accessors are safe: they check that
|
||||
;; the slot is bound after retreiving the value, and they may take
|
||||
;; the liberty of using SI:INSTANCE-REF because they know the class of
|
||||
;; the instance.
|
||||
;;
|
||||
(dolist (slotd (class-direct-slots standard-class))
|
||||
(multiple-value-bind (reader writer)
|
||||
(let ((name (slot-definition-name slotd))
|
||||
(allocation (slot-definition-allocation slotd))
|
||||
(location (safe-slot-definition-location slotd)))
|
||||
(cond ((and (eq allocation :instance) (typep location 'fixnum))
|
||||
(std-class-sealed-accessors (slot-definition-location slotd)))
|
||||
;; When a class is the specified STANDARD-CLASS, then the
|
||||
;; user may not write any method around SLOT-VALUE-USING-CLASS
|
||||
;; This allows us to write optimized versions of the accessors.
|
||||
((and (eq allocation :instance)
|
||||
(eq standard-class +the-standard-class+))
|
||||
(std-class-optimized-accessors name))
|
||||
(t
|
||||
(std-class-accessors name))))
|
||||
(let* ((reader-args (list :function reader
|
||||
:generic-function nil
|
||||
:qualifiers nil
|
||||
:lambda-list '(object)
|
||||
:specializers `(,standard-class)
|
||||
:slot-definition slotd))
|
||||
(reader-class (if (boundp '*early-methods*)
|
||||
'standard-reader-method
|
||||
(apply #'reader-method-class standard-class slotd
|
||||
reader-args)))
|
||||
(writer-args (list :function writer
|
||||
:generic-function nil
|
||||
:qualifiers nil
|
||||
:lambda-list '(value object)
|
||||
:specializers `(,(find-class t) ,standard-class)
|
||||
:slot-definition slotd))
|
||||
(writer-class (if (boundp '*early-methods*)
|
||||
'standard-writer-method
|
||||
(apply #'writer-method-class standard-class slotd
|
||||
writer-args))))
|
||||
(dolist (fname (slot-definition-readers 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))
|
||||
(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
|
||||
;;;
|
||||
|
|
|
|||
203
src/clos/std-accessors.lsp
Normal file
203
src/clos/std-accessors.lsp
Normal file
|
|
@ -0,0 +1,203 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
|
||||
;;;;
|
||||
;;;; Copyright (c) 1992, Giuseppe Attardi.o
|
||||
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; ACCESSOR / READER / WRITER METHOD CREATION
|
||||
;;;
|
||||
;;; The following code creates optimized and unoptimized versions of the
|
||||
;;; slot accessors defined for a class. They are designed so that at least
|
||||
;;; some varieties work at boot time.
|
||||
;;;
|
||||
|
||||
(defun unbound-slot-error (object index)
|
||||
(declare (type standard-object object)
|
||||
(type fixnum index)
|
||||
(optimize (safety 0))
|
||||
(si::c-local))
|
||||
(let* ((class (class-of object))
|
||||
(slotd (find index (class-slots class) :key #'slot-definition-location)))
|
||||
(values (slot-unbound class object (slot-definition-name slotd)))))
|
||||
|
||||
(defun safe-instance-ref (object index)
|
||||
(declare (type standard-object object)
|
||||
(type fixnum index)
|
||||
(optimize (safety 0)))
|
||||
(let ((value (si:instance-ref object index)))
|
||||
(if (si:sl-boundp value)
|
||||
value
|
||||
(unbound-slot-error object index))))
|
||||
|
||||
;;; The following does not get as fast as it should because we are not
|
||||
;;; allowed to memoize the position of a slot. The problem is that the
|
||||
;;; AMOP specifies that slot accessors are created from the direct
|
||||
;;; slots, without knowing the slot position. This semantics is
|
||||
;;; required for working standard-reader- and
|
||||
;;; standard-writer-method. OTOH if we want to have memoized slot
|
||||
;;; positions we have to work from the effective slots and we have to
|
||||
;;; create methods for all slots, not only the direct ones in this
|
||||
;;; class. Both semantics are incompatible, but we currently have no
|
||||
;;; safe way to choose one or another
|
||||
;;;
|
||||
(defun std-class-optimized-accessors (slot-name)
|
||||
(declare (si::c-local))
|
||||
(macrolet ((slot-table (class)
|
||||
`(si::instance-ref ,class #.(position 'slot-table +standard-class-slots+
|
||||
:key #'first)))
|
||||
(slot-definition-location (slotd)
|
||||
`(si::instance-ref ,slotd #.(position 'location +slot-definition-slots+
|
||||
:key #'first))))
|
||||
(values #'(lambda (self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(let* ((class (si:instance-class self))
|
||||
(table (slot-table class))
|
||||
(slotd (truly-the slot-definition (gethash slot-name table)))
|
||||
(index (slot-definition-location slotd))
|
||||
(value (if (si::fixnump index)
|
||||
(si:instance-ref self (truly-the fixnum index))
|
||||
(car (truly-the cons index)))))
|
||||
(if (si:sl-boundp value)
|
||||
value
|
||||
(values (slot-unbound (class-of self) self slot-name)))))
|
||||
#'(lambda (value self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(let* ((class (si:instance-class self))
|
||||
(table (slot-table class))
|
||||
(slotd (truly-the slot-definition (gethash slot-name table)))
|
||||
(index (slot-definition-location slotd)))
|
||||
(if (si::fixnump index)
|
||||
(si:instance-set self (truly-the fixnum index) value)
|
||||
(rplaca (truly-the cons index) value)))))))
|
||||
|
||||
(defun std-class-sealed-accessors (index)
|
||||
(declare (si::c-local)
|
||||
(fixnum index))
|
||||
(values #'(lambda (self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(safe-instance-ref self index))
|
||||
#'(lambda (value self)
|
||||
(declare (optimize (safety 0) (speed 3) (debug 0))
|
||||
(standard-object self))
|
||||
(ensure-up-to-date-instance self)
|
||||
(si:instance-set self index value))))
|
||||
|
||||
(defun std-class-accessors (slot-name)
|
||||
(declare (si::c-local))
|
||||
;; The following are very slow. We do not optimize for the slot position.
|
||||
(values #'(lambda (self)
|
||||
(slot-value self slot-name))
|
||||
#'(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
|
||||
(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)
|
||||
;;
|
||||
;; The accessors are closures, which are generated every time the
|
||||
;; slots of the class change. The accessors are safe: they check that
|
||||
;; the slot is bound after retreiving the value, and they may take
|
||||
;; the liberty of using SI:INSTANCE-REF because they know the class of
|
||||
;; the instance.
|
||||
;;
|
||||
(dolist (slotd (class-direct-slots standard-class))
|
||||
(multiple-value-bind (reader writer)
|
||||
(let ((name (slot-definition-name slotd))
|
||||
(allocation (slot-definition-allocation slotd))
|
||||
(location (safe-slot-definition-location slotd)))
|
||||
(cond ((and (eq allocation :instance) (typep location 'fixnum))
|
||||
(std-class-sealed-accessors (slot-definition-location slotd)))
|
||||
;; When a class is the specified STANDARD-CLASS, then the
|
||||
;; user may not write any method around SLOT-VALUE-USING-CLASS
|
||||
;; This allows us to write optimized versions of the accessors.
|
||||
((and (eq allocation :instance)
|
||||
(eq standard-class +the-standard-class+))
|
||||
(std-class-optimized-accessors name))
|
||||
(t
|
||||
(std-class-accessors name))))
|
||||
(let* ((reader-args (list :function reader
|
||||
:generic-function nil
|
||||
:qualifiers nil
|
||||
:lambda-list '(object)
|
||||
:specializers `(,standard-class)
|
||||
:slot-definition slotd))
|
||||
(reader-class (if (boundp '*early-methods*)
|
||||
'standard-reader-method
|
||||
(apply #'reader-method-class standard-class slotd
|
||||
reader-args)))
|
||||
(writer-args (list :function writer
|
||||
:generic-function nil
|
||||
:qualifiers nil
|
||||
:lambda-list '(value object)
|
||||
:specializers `(,(find-class t) ,standard-class)
|
||||
:slot-definition slotd))
|
||||
(writer-class (if (boundp '*early-methods*)
|
||||
'standard-writer-method
|
||||
(apply #'writer-method-class standard-class slotd
|
||||
writer-args))))
|
||||
(dolist (fname (slot-definition-readers 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))
|
||||
(safe-add-method fname
|
||||
(make-method writer-class nil
|
||||
`(,(find-class t) ,standard-class) '(value self)
|
||||
(wrapped-method-function writer)
|
||||
(list :slot-definition slotd))))))))
|
||||
|
||||
(defun reader-closure (index)
|
||||
(declare (si::c-local))
|
||||
(lambda (object) (si::instance-ref object index)))
|
||||
|
||||
(defun writer-closure (index)
|
||||
(declare (si::c-local))
|
||||
(lambda (value object) (si::instance-set object index value)))
|
||||
|
||||
(labels ((generate-accessors (class)
|
||||
(declare (optimize speed (safety 0)))
|
||||
(loop for index from 0
|
||||
for slotd in (slot-value class 'slots)
|
||||
do (loop for reader in (slot-definition-readers slotd)
|
||||
do (setf (fdefinition reader) (reader-closure index))
|
||||
#+(or)
|
||||
(install-method reader nil (list class) '(self)
|
||||
(reader-closure index) t))
|
||||
do (loop for writer in (slot-definition-writers slotd)
|
||||
do (setf (fdefinition writer) (writer-closure index))
|
||||
#+(or)
|
||||
(install-method writer nil (list +the-t-class+ class)
|
||||
'(value self)
|
||||
(writer-closure index) t)))
|
||||
(mapc #'generate-accessors (slot-value class 'direct-subclasses))))
|
||||
(generate-accessors +the-t-class+))
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue