X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/584285fba4d518f8d6f581b542ee6b38650ba287..fcdb9e3641b6b833f7f02538c2a777dda1d43602:/gffi/virtual-slots.lisp diff --git a/gffi/virtual-slots.lisp b/gffi/virtual-slots.lisp index b57082c..e2802c7 100644 --- a/gffi/virtual-slots.lisp +++ b/gffi/virtual-slots.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: virtual-slots.lisp,v 1.2 2006-08-16 11:02:45 espen Exp $ +;; $Id: virtual-slots.lisp,v 1.4 2006-09-05 13:16:18 espen Exp $ (in-package "GFFI") @@ -58,12 +58,21 @@ (defclass effective-special-slot-definition (standard-effective-slot-definition) (defclass virtual-slots-object (standard-object) ()) - +(defgeneric slot-readable-p (slotd)) +(defgeneric slot-writable-p (slotd)) (defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p)) (defgeneric compute-slot-boundp-function (slotd)) (defgeneric compute-slot-writer-function (slotd)) (defgeneric compute-slot-makunbound-function (slotd)) +(defmethod slot-readable-p ((slotd standard-effective-slot-definition)) + (declare (ignore slotd)) + t) + +(defmethod slot-writable-p ((slotd standard-effective-slot-definition)) + (declare (ignore slotd)) + t) + #+clisp (defmethod slot-definition-type ((slotd t)) @@ -87,6 +96,9 @@ (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest in (t (call-next-method)))) +(defmethod slot-readable-p ((slotd effective-virtual-slot-definition)) + (slot-boundp slotd 'getter)) + (define-condition unreadable-slot (cell-error) ((instance :reader unreadable-slot-instance :initarg :instance)) (:report (lambda (condition stream) @@ -95,45 +107,50 @@ (define-condition unreadable-slot (cell-error) (unreadable-slot-instance condition))))) (defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t)) - (let ((reader-function (call-next-method))) - (cond - ((not signal-unbound-p) reader-function) - - ;; An explicit boundp function has been supplied - ((slot-boundp slotd 'boundp) - (let ((unbound-value (slot-value slotd 'boundp))) - #'(lambda (object) - (let ((value (funcall reader-function object))) - (if (eq value unbound-value) - (slot-unbound (class-of object) object (slot-definition-name slotd)) - value))))) - - ;; A type unbound value exists - ((let ((unbound-method (find-applicable-type-method 'unbound-value - (slot-definition-type slotd) nil))) - (when unbound-method - (let ((unbound-value (funcall unbound-method (slot-definition-type slotd)))) - #'(lambda (object) - (let ((value (funcall reader-function object))) - (if (eq value unbound-value) - (slot-unbound (class-of object) object (slot-definition-name slotd)) - value))))))) - - ((let ((boundp-function (compute-slot-boundp-function slotd))) - #'(lambda (object) - (if (funcall boundp-function object) - (funcall reader-function object) - (slot-unbound (class-of object) object (slot-definition-name slotd))))))))) + (if (not (slot-readable-p slotd)) + #'(lambda (object) + (error 'unreadable-slot :name (slot-definition-name slotd) :instance object)) + (let ((reader-function (call-next-method))) + (cond + ;; Don't create wrapper to signal unbound value + ((not signal-unbound-p) reader-function) + + ;; An explicit boundp function has been supplied + ((slot-boundp slotd 'boundp) + (let ((unbound-value (slot-value slotd 'boundp))) + #'(lambda (object) + (let ((value (funcall reader-function object))) + (if (eq value unbound-value) + (slot-unbound (class-of object) object (slot-definition-name slotd)) + value))))) + + ;; A type unbound value exists + ((let ((unbound-method (find-applicable-type-method 'unbound-value + (slot-definition-type slotd) nil))) + (when unbound-method + (let ((unbound-value (funcall unbound-method (slot-definition-type slotd)))) + #'(lambda (object) + (let ((value (funcall reader-function object))) + (if (eq value unbound-value) + (slot-unbound (class-of object) object (slot-definition-name slotd)) + value))))))) + + ((let ((boundp-function (compute-slot-boundp-function slotd))) + #'(lambda (object) + (if (funcall boundp-function object) + (funcall reader-function object) + (slot-unbound (class-of object) object (slot-definition-name slotd)))))))))) (defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p) (declare (ignore signal-unbound-p)) - (if (slot-boundp slotd 'getter) - (slot-value slotd 'getter) - #'(lambda (object) - (error 'unreadable-slot :name (slot-definition-name slotd) :instance object)))) + (slot-value slotd 'getter)) (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition)) (cond + ;; Non readable slots are not bound per definition + ((not (slot-readable-p slotd)) + #'(lambda (object) (declare (ignore object)) nil)) + ;; An explicit boundp function has been supplied ((slot-boundp slotd 'boundp) (slot-value slotd 'boundp)) @@ -156,6 +173,9 @@ (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definitio ;; Slot has no unbound state (#'(lambda (object) (declare (ignore object)) t)))) +(defmethod slot-writable-p ((slotd effective-virtual-slot-definition)) + (slot-boundp slotd 'setter)) + (define-condition unwritable-slot (cell-error) ((instance :reader unwritable-slot-instance :initarg :instance)) (:report (lambda (condition stream) @@ -163,22 +183,35 @@ (define-condition unwritable-slot (cell-error) (cell-error-name condition) (unwritable-slot-instance condition))))) +(defmethod compute-slot-writer-function :around ((slotd effective-virtual-slot-definition)) + (if (not (slot-writable-p slotd)) + #'(lambda (value object) + (declare (ignore value)) + (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)) + (call-next-method))) + (defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition)) - (if (slot-boundp slotd 'setter) - (slot-value slotd 'setter) - #'(lambda (value object) - (declare (ignore value)) - (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))) + (slot-value slotd 'setter)) + +(define-condition slot-can-not-be-unbound (cell-error) + ((instance :reader slot-can-not-be-unbound-instance :initarg :instance)) + (:report (lambda (condition stream) + (format stream "~@" + (cell-error-name condition) + (slot-can-not-be-unbound-instance condition))))) (defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition)) (cond + ((not (slot-writable-p slotd)) + #'(lambda (object) + (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))) ((slot-boundp slotd 'makunbound) (slot-value slotd 'makunbound)) ((slot-boundp slotd 'unbound) #'(lambda (object) (funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object))) (t #'(lambda (object) - (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))))) + (error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object))))) #-clisp @@ -258,7 +291,7 @@ (defmethod slot-makunbound-using-class ;; In CLISP and SBCL (0.9.15 or newler) a class may not have been ;; finalized when update-slots are called. So to avoid the possibility -;; of finalize-instance beeing called recursivly we have to delay the +;; of finalize-instance being called recursivly we have to delay the ;; initialization of slot functions until after an instance has been ;; created. #?(or (sbcl>= 0 9 15) (featurep :clisp)) @@ -293,7 +326,7 @@ (defmethod slot-definition-special ((slotd standard-effective-slot-definition)) ;;; To determine if a slot should be initialized with the initform, ;;; CLISP checks whether it is unbound or not. This doesn't work with -;;; virtual slots which does not have an unbound state, so we have to +;;; virtual slots that does not have an unbound state, so we have to ;;; implement initform initialization in a way similar to how it is ;;; done in PCL. #+clisp