;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: defpackage.lisp,v 1.9 2006-02-08 21:43:33 espen Exp $
+;; $Id: defpackage.lisp,v 1.10 2006-02-15 09:45:41 espen Exp $
;(export 'kernel::type-expand-1 "KERNEL")
(defpackage "GLIB"
(:use "COMMON-LISP""AUTOEXPORT")
#+cmu(:use "SYSTEM" "KERNEL" "PCL" "EXT")
- #+sbcl(:use "SB-SYS" "SB-KERNEL" "SB-PCL" "SB-EXT")
+ #+sbcl(:use "SB-SYS" "SB-KERNEL" "SB-MOP" "SB-EXT")
#+cmu(:shadowing-import-from "PCL"
"CLASS-DIRECT-SUPERCLASSES" "CLASS-DIRECT-SUPERCLASSES")
(:shadow "POINTER")
(:import-from #+cmu"PCL" #+sbcl"SB-PCL"
- "LOCATION" "ALLOCATION" "DIRECT-SLOTS"
"READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION"
"INITIALIZE-INTERNAL-SLOT-FUNCTIONS" "COMPUTE-SLOT-ACCESSOR-INFO"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"
#+cmu(:import-from "ALIEN" "CALLBACK")
(:import-from #+cmu"ALIEN" #+sbcl"SB-ALIEN"
"WITH-ALIEN" "ALIEN-FUNCALL" "%HEAP-ALIEN" "MAKE-HEAP-ALIEN-INFO"
- "ADDR" "PARSE-ALIEN-TYPE" "SYSTEM-AREA-POINTER" "EXTERN-ALIEN")
+ "ADDR" "PARSE-ALIEN-TYPE" "SYSTEM-AREA-POINTER" "EXTERN-ALIEN"
+ "ALIEN-SAP")
#+cmu(:import-from "C-CALL" "%NATURALIZE-C-STRING" "VOID")
#+sbcl(:import-from "SB-ALIEN"
"%NATURALIZE-UTF8-STRING" "%DEPORT-UTF8-STRING" "VOID")
"PACKAGE-PREFIX" "DEFCALLBACK" "CALLBACK" "CALL-NEXT-HANDLER")
(:export "LONG" "UNSIGNED-LONG" "INT" "UNSIGNED-INT" "SHORT" "UNSIGNED-SHORT"
"SIGNED" "UNSIGNED" "CHAR" "POINTER" "COPY-OF")
- (:export "LOCATION" "ALLOCATION" "DIRECT-SLOTS" "READER-FUNCTION"
- "WRITER-FUNCTION" "BOUNDP-FUNCTION"
+ (:export "LOCATION" "READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION"
"INITIALIZE-INTERNAL-SLOT-FUNCTIONS"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"))
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: proxy.lisp,v 1.32 2006-02-09 22:26:38 espen Exp $
+;; $Id: proxy.lisp,v 1.33 2006-02-15 09:45:41 espen Exp $
(in-package "GLIB")
(boundp :reader slot-definition-boundp :initarg :boundp)))
(defclass direct-special-slot-definition (standard-direct-slot-definition)
- ())
+ ((special :initarg :special :accessor slot-definition-special)))
(defclass effective-special-slot-definition (standard-effective-slot-definition)
- ()))
+ ((special :initarg :special :accessor slot-definition-special))))
(defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
(slot-value object slot)
default)))
-(defmethod initialize-instance ((slotd effective-special-slot-definition) &rest initargs)
- (declare (ignore initargs))
- (call-next-method)
- (setf (slot-value slotd 'allocation) :instance))
-
(defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
- (case (getf initargs :allocation)
- (:virtual (find-class 'direct-virtual-slot-definition))
- (:special (find-class 'direct-special-slot-definition))
- (t (call-next-method))))
+ (cond
+ ((eq (getf initargs :allocation) :virtual)
+ (find-class 'direct-virtual-slot-definition))
+ ((getf initargs :special)
+ (find-class 'direct-special-slot-definition))
+ (t (call-next-method))))
(defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
- (case (getf initargs :allocation)
- (:virtual (find-class 'effective-virtual-slot-definition))
- (:special (find-class 'effective-special-slot-definition))
- (t (call-next-method))))
+ (cond
+ ((eq (getf initargs :allocation) :virtual)
+ (find-class 'effective-virtual-slot-definition))
+ ((getf initargs :special)
+ (find-class 'effective-special-slot-definition))
+ (t (call-next-method))))
(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
nil)
(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
- (if (typep (first direct-slotds) 'direct-virtual-slot-definition)
- (let ((initargs ()))
- (let ((getter (most-specific-slot-value direct-slotds 'getter)))
- (unless (eq getter *unbound-marker*)
- (setf (getf initargs :getter) getter)))
- (let ((setter (most-specific-slot-value direct-slotds 'setter)))
- (unless (eq setter *unbound-marker*)
- (setf (getf initargs :setter) setter)))
- (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
- (unless (eq unbound *unbound-marker*)
- (setf (getf initargs :unbound) unbound)))
- (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
- (unless (eq boundp *unbound-marker*)
- (setf (getf initargs :boundp) boundp)))
- (nconc initargs (call-next-method)))
- (call-next-method)))
+ (typecase (first direct-slotds)
+ (direct-virtual-slot-definition
+ (let ((initargs ()))
+ (let ((getter (most-specific-slot-value direct-slotds 'getter)))
+ (unless (eq getter *unbound-marker*)
+ (setf (getf initargs :getter) getter)))
+ (let ((setter (most-specific-slot-value direct-slotds 'setter)))
+ (unless (eq setter *unbound-marker*)
+ (setf (getf initargs :setter) setter)))
+ (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
+ (unless (eq unbound *unbound-marker*)
+ (setf (getf initargs :unbound) unbound)))
+ (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
+ (unless (eq boundp *unbound-marker*)
+ (setf (getf initargs :boundp) boundp)))
+ (nconc initargs (call-next-method))))
+ (direct-special-slot-definition
+ (append '(:special t) (call-next-method)))
+ (t (call-next-method))))
(defmethod slot-value-using-class
t)
+(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
+ (declare (ignore slotd))
+ nil)
+
+(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
+ (declare (ignore slotd))
+ nil)
+
+
;;;; Proxy cache
(defvar *instance-cache* (make-hash-table :test #'eql))
;; TODO: add a ref-counted-proxy subclass
(defclass proxy ()
- ((location :allocation :special :type pointer))
+ ((location :special t :type pointer))
(:metaclass virtual-slots-class))
(defgeneric instance-finalizer (object))
((size :reader foreign-size)))
(defclass direct-alien-slot-definition (direct-virtual-slot-definition)
- ((allocation :initform :alien)
- (offset :reader slot-definition-offset :initarg :offset)))
+ ((offset :reader slot-definition-offset :initarg :offset))
+ (:default-initargs :allocation :alien))
(defclass effective-alien-slot-definition (effective-virtual-slot-definition)
((offset :reader slot-definition-offset :initarg :offset)))
(defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
- (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
+ (if (eq (slot-definition-allocation (first direct-slotds)) :alien)
(nconc
(list :offset (most-specific-slot-value direct-slotds 'offset))
(call-next-method))
(defmethod compute-slots :around ((class struct-class))
(let ((slots (call-next-method)))
(when (and
- #-sbcl>=0.9.8(class-finalized-p class) #+sbc098 t
+ #-sbcl>=0.9.8(class-finalized-p class)
(not (slot-boundp class 'size)))
(let ((size (loop
for slotd in slots