From 2f0d83727a76cce890850e8ea59e132f00448c77 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 29 Nov 2009 22:02:52 +0100 Subject: [PATCH] The slot accessors must check that the structures are up-to-date. --- src/CHANGELOG | 4 ++++ src/clos/boot.lsp | 4 ++-- src/clos/kernel.lsp | 8 ++++++-- src/clos/standard.lsp | 12 ++++++++++++ src/clos/stdmethod.lsp | 4 ++-- 5 files changed, 26 insertions(+), 6 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 0fa72daff..be2fbe7c0 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -75,9 +75,13 @@ ECL 9.12.1: - FDEFINITION and SYMBOL-FUNCTION caused an incorrect error condition when acting on NIL. +* Clos: + - CLOS:SET-FUNCALLABLE-INSTANCE-FUNCTION broke the value if SI:INSTANCE-SIG, preventing any further access to the instance slots. + - The optimized slot accessors check that the instances are up to date. + * Sockets: - The socket option TCP_NODELAY option has been fixed: it was improperly using diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 791137807..fe72449c0 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -50,9 +50,9 @@ (the-t (make-empty-standard-class 'T the-class)) ;; It does not matter that we pass NIL instead of a class object, ;; because CANONICAL-SLOT-TO-DIRECT-SLOT will make simple slots. - (class-slots (loop for s in (parse-slots '#.+class-slots+) + (class-slots (loop for s in (parse-slots '#.(remove-accessors +class-slots+)) collect (canonical-slot-to-direct-slot nil s))) - (standard-slots (loop for s in (parse-slots '#.+standard-class-slots+) + (standard-slots (loop for s in (parse-slots '#.(remove-accessors +standard-class-slots+)) collect (canonical-slot-to-direct-slot nil s))) (hash-table (make-hash-table :size 24))) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 5877923c5..87c197d73 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -34,7 +34,6 @@ name) (dolist (s slotds `(progn ,@output)) (when (setf name (getf (cdr s) :accessor)) - (remf (cdr s) :accessor) (setf output (append output `((defun ,name (obj) @@ -46,6 +45,11 @@ `(si:instance-ref ,obj ,,i)) )))) (incf i)))) +(defun remove-accessors (slotds) + (loop for i in slotds + for j = (copy-list i) + do (remf (cdr j) :accessor) + collect j)) ) ;;; ---------------------------------------------------------------------- @@ -69,7 +73,7 @@ (sealedp :initarg :sealedp :initform nil :accessor class-sealedp) (prototype)))) -#.(create-accessors +class-slots+ 'class) +;#.(create-accessors +class-slots+ 'class) ;;; ---------------------------------------------------------------------- ;;; STANDARD-CLASS diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index f285504c8..4ad629f50 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -548,6 +548,9 @@ because it contains a reference to the undefined class~% ~A" `(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 (gethash slot-name table)) @@ -559,6 +562,9 @@ because it contains a reference to the undefined class~% ~A" 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 (gethash slot-name table)) @@ -571,8 +577,14 @@ because it contains a reference to the undefined class~% ~A" (declare (si::c-local) (fixnum slot-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) diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index 98c40933c..1ee565648 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -25,7 +25,7 @@ (:metaclass 'funcallable-standard-class)) (defclass standard-generic-function (generic-function) - #.+standard-generic-function-slots+ + #.(remove-accessors +standard-generic-function-slots+) (:metaclass 'funcallable-standard-class)) ;;;---------------------------------------------------------------------- @@ -35,7 +35,7 @@ (defclass method () ()) (defclass standard-method (method) - #.+standard-method-slots+) + #.(remove-accessors +standard-method-slots+)) (defun function-keywords (method)