;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gboxed.lisp,v 1.9 2002-03-19 17:06:11 espen Exp $
+;; $Id: gboxed.lisp,v 1.10 2004-10-27 14:58:59 espen Exp $
(in-package "GLIB")
;;;; Metaclass for boxed classes
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass boxed-class (proxy-class))
+ (defclass boxed-class (proxy-class)
+ ())
(defmethod shared-initialize ((class boxed-class) names
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gcallback.lisp,v 1.8 2002-03-24 15:43:16 espen Exp $
+;; $Id: gcallback.lisp,v 1.9 2004-10-27 14:58:59 espen Exp $
(in-package "GLIB")
(unwind-protect
(let ((result (apply callback-function (reverse args))))
(when return-type
- (gvalue-set (print return-value) result))))
+ (gvalue-set return-value result))))
(continue nil :report "Return from callback function"
(when return-type
(defmethod signal-connect ((gobject gobject) signal function &key after object)
+"Connects a callback function to a signal for a particular object. If :OBJECT
+ is T, the object connected to is passed as the first argument to the callback
+ function, or if :OBJECT is any other non NIL value, it is passed as the first
+ argument instead. If :AFTER is non NIL, the handler will be called after the
+ default handler of the signal."
(let ((callback-id
(make-callback-closure
(cond
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: ginterface.lisp,v 1.1 2002-01-20 14:05:27 espen Exp $
+;; $Id: ginterface.lisp,v 1.2 2004-10-27 14:58:59 espen Exp $
(in-package "GLIB")
;;;;
-(defclass ginterface ())
+(defclass ginterface ()
+ ())
(deftype-method translate-type-spec ginterface (type-spec)
(declare (ignore type-spec))
;;;; Metaclass for interfaces
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass ginterface-class (pcl::standard-class)))
+ (defclass ginterface-class (virtual-slot-class)
+ ()))
(defmethod shared-initialize ((class ginterface-class) names
;;;;
-(defun expand-ginterface-type (type-number &rest args)
+(defun expand-ginterface-type (type-number options &rest args)
(declare (ignore args))
`(defclass ,(type-from-number type-number) (ginterface)
- ()
+ ,(getf options :slots)
(:metaclass ginterface-class)
(:alien-name ,(find-type-name type-number))))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: glib.lisp,v 1.12 2002-01-20 14:06:50 espen Exp $
+;; $Id: glib.lisp,v 1.13 2004-10-27 14:58:59 espen Exp $
(in-package "GLIB")
(use-prefix "g")
+;(load-shared-library "libglib-2.0")
;;;; Memory management
`(dotimes (i ,length)
(unreference-alien
element-type (sap-ref-sap c-vector (* i ,element-size))))
- `(do ((offset 0 (+ offset ,element-size))
+ `(do ((offset 0 (+ offset ,element-size)))
((sap=
(sap-ref-sap c-vector offset)
- *magic-end-of-array*)))
+ *magic-end-of-array*))
,(unreference-alien
element-type '(sap-ref-sap c-vector offset))))))
(deallocate-memory c-vector)))))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gobject.lisp,v 1.12 2002-04-02 14:57:19 espen Exp $
+;; $Id: gobject.lisp,v 1.13 2004-10-27 14:58:59 espen Exp $
(in-package "GLIB")
(:copy %object-ref)
(:free %object-unref)))
+
(defmethod initialize-instance ((object gobject) &rest initargs)
- (declare (ignore initargs))
- (setf (slot-value object 'location) (%gobject-new (type-number-of object)))
- (call-next-method))
+ (let ((slotds (class-slots (class-of object)))
+ (names (make-array 0 :adjustable t :fill-pointer t))
+ (values (make-array 0 :adjustable t :fill-pointer t)))
+
+ (loop
+ as tmp = initargs then (cddr tmp) while tmp
+ as key = (first tmp)
+ as value = (second tmp)
+ as slotd = (find-if
+ #'(lambda (slotd)
+ (member key (slot-definition-initargs slotd)))
+ slotds)
+ when (and (typep slotd 'effective-gobject-slot-definition)
+ (slot-value slotd 'construct))
+ do (let ((type (find-type-number (slot-definition-type slotd))))
+ (vector-push-extend (slot-definition-pname slotd) names)
+ (vector-push-extend (gvalue-new type value) values)
+ (remf initargs key)))
+
+ (setf
+ (slot-value object 'location)
+ (if (zerop (length names))
+ (%gobject-new (type-number-of object))
+ (%gobject-newvv (type-number-of object) (length names) names values))))
+ (apply #'call-next-method object initargs))
+
+
(defbinding (%gobject-new "g_object_new") () pointer
(type type-number)
(nil null))
+(defbinding (%gobject-newvv "g_object_newvv") () pointer
+ (type type-number)
+ (n-parameters unsigned-int)
+ (names (vector string))
+ (values (vector gvalue)))
-(defbinding %object-ref (type location) pointer
- (location pointer))
-(defbinding %object-unref (type location) nil
+(defbinding %object-ref (type location) pointer
(location pointer))
+ (defbinding %object-unref (type location) nil
+ (location pointer))
(defun object-ref (object)
(%object-ref nil (proxy-location object)))
;;;; Metaclass used for subclasses of gobject
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass gobject-class (ginstance-class))
+ (defclass gobject-class (ginstance-class)
+ ())
(defclass direct-gobject-slot-definition (direct-virtual-slot-definition)
- ((pname :reader slot-definition-pname)))
+ ((pname :reader slot-definition-pname :initarg :pname)
+ (readable :initform t :reader slot-readable-p :initarg :readable)
+ (writable :initform t :reader slot-writable-p :initarg :writable)
+ (construct :initform nil :initarg :construct)))
+
+ (defclass effective-gobject-slot-definition (effective-virtual-slot-definition)
+ ((pname :reader slot-definition-pname :initarg :pname)
+ (readable :reader slot-readable-p :initarg :readable)
+ (writable :reader slot-writable-p :initarg :writable)
+ (construct :initarg :construct))))
- (defclass effective-gobject-slot-definition
- (effective-virtual-slot-definition)))
-
; (defbinding object-class-install-param () nil
; (class pointer)
(defun signal-name-to-string (name)
(substitute #\_ #\- (string-downcase (string name))))
-(defmethod initialize-instance :after ((slotd direct-gobject-slot-definition)
- &rest initargs &key pname)
- (declare (ignore initargs))
- (when pname
- (setf
- (slot-value slotd 'pname)
- (signal-name-to-string (slot-definition-name slotd)))))
-(defmethod direct-slot-definition-class ((class gobject-class) initargs)
+(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
(case (getf initargs :allocation)
(:property (find-class 'direct-gobject-slot-definition))
(t (call-next-method))))
-(defmethod effective-slot-definition-class ((class gobject-class) initargs)
+(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
(case (getf initargs :allocation)
(:property (find-class 'effective-gobject-slot-definition))
(t (call-next-method))))
-(defmethod compute-virtual-slot-accessors
- ((class gobject-class) (slotd effective-gobject-slot-definition)
- direct-slotds)
- (with-slots (type) slotd
- (let ((pname (slot-definition-pname (first direct-slotds)))
- (type-number (find-type-number type)))
- (list
+(defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
+ (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
+ (nconc
+ (list :pname (signal-name-to-string
+ (most-specific-slot-value direct-slotds 'pname))
+ :readable (most-specific-slot-value direct-slotds 'readable)
+ :writable (most-specific-slot-value direct-slotds 'writable)
+ :construct (most-specific-slot-value direct-slotds 'construct))
+ (call-next-method))
+ (call-next-method)))
+
+
+(defmethod initialize-internal-slot-functions ((slotd effective-gobject-slot-definition))
+ (let* ((type (slot-definition-type slotd))
+ (pname (slot-definition-pname slotd))
+ (type-number (find-type-number type)))
+ (unless (slot-boundp slotd 'reader-function)
+ (setf
+ (slot-value slotd 'reader-function)
+ (if (slot-readable-p slotd)
+ #'(lambda (object)
+ (with-gc-disabled
+ (let ((gvalue (gvalue-new type-number)))
+ (%object-get-property object pname gvalue)
+ (unwind-protect
+ (funcall
+ (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
+ (gvalue-free gvalue t)))))
+ #'(lambda (value object)
+ (error "Slot is not readable: ~A" (slot-definition-name slotd))))))
+
+ (unless (slot-boundp slotd 'writer-function)
+ (setf
+ (slot-value slotd 'writer-function)
+ (if (slot-writable-p slotd)
+ #'(lambda (value object)
+ (with-gc-disabled
+ (let ((gvalue (gvalue-new type-number)))
+ (funcall
+ (intern-writer-function (type-from-number type-number)) ; temporary
+ value gvalue +gvalue-value-offset+)
+ (%object-set-property object pname gvalue)
+ (funcall
+ (intern-destroy-function (type-from-number type-number)) ; temporary
+ gvalue +gvalue-value-offset+)
+ (gvalue-free gvalue nil)
+ value)))
+ #'(lambda (value object)
+ (error "Slot is not writable: ~A" (slot-definition-name slotd))))))
+
+ (unless (slot-boundp slotd 'boundp-function)
+ (setf
+ (slot-value slotd 'boundp-function)
#'(lambda (object)
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (%object-get-property object pname gvalue)
- (unwind-protect
- (funcall
- (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
- (gvalue-free gvalue t)))))
- #'(lambda (value object)
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (funcall
- (intern-writer-function (type-from-number type-number)) ; temporary
- value gvalue +gvalue-value-offset+)
- (%object-set-property object pname gvalue)
- (funcall
- (intern-destroy-function (type-from-number type-number)) ; temporary
- gvalue +gvalue-value-offset+)
- (gvalue-free gvalue nil)
- value)))))))
+ (declare (ignore object))
+ t))))
+ (call-next-method))
+
(defmethod validate-superclass ((class gobject-class)
(super pcl::standard-class))
(intern
(format
nil "~A-~A~A" class-name slot-name
- (if (eq 'boolean type) "-P" ""))))
+ (if (eq type 'boolean) "-P" ""))))
(defun expand-gobject-type (type-number &optional options
(metaclass 'gobject-class))
(let* ((supers (cons (supertype type-number) (implements type-number)))
(class (type-from-number type-number))
- (override-slots (getf options :slots))
+ (manual-slots (getf options :slots))
(expanded-slots
(mapcar
#'(lambda (param)
(with-slots (name flags value-type documentation) param
(let* ((slot-name (default-slot-name name))
- (slot-type value-type) ;(type-from-number value-type t))
+; (slot-type value-type) ;(type-from-number value-type t))
+ (slot-type (or (type-from-number value-type) value-type))
(accessor
- (default-slot-accessor class slot-name (type-from-number slot-type)))) ; temporary workaround for wrong topological sorting of types
+ (default-slot-accessor class slot-name slot-type)));(type-from-number slot-type)))) ; temporary workaround for wrong topological sorting of types
+
`(,slot-name
:allocation :property
:pname ,name
,@(cond
((and
(member :writable flags)
- (member :readable flags))
+ (member :readable flags)
+ (not (member :construct-only flags)))
(list :accessor accessor))
- ((member :writable flags)
+ ((and (member :writable flags)
+ (not (member :construct-only flags)))
(list :writer `(setf ,accessor)))
((member :readable flags)
(list :reader accessor)))
+ ,@(when (or
+ (not (member :writable flags))
+ (member :construct-only flags))
+ (list :writable nil))
+ ,@(when (not (member :readable flags))
+ (list :readable nil))
+ ,@(when (or
+ (member :construct flags)
+ (member :construct-only flags))
+ (list :construct t))
,@(when (or
(member :construct flags)
+ (member :construct-only flags)
(member :writable flags))
(list :initarg (intern (string slot-name) "KEYWORD")))
:type ,slot-type
(list :documentation documentation))))))
(query-object-class-properties type-number))))
- (dolist (slot-def override-slots)
+ (dolist (slot-def (reverse manual-slots))
(let ((name (car slot-def))
(pname (getf (cdr slot-def) :pname)))
(setq
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gparam.lisp,v 1.6 2002-03-19 17:01:42 espen Exp $
+;; $Id: gparam.lisp,v 1.7 2004-10-27 14:59:00 espen Exp $
(in-package "GLIB")
(deftype gvalue () 'pointer)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defbinding (size-of-gvalue "size_of_gvalue") () unsigned-int))
+
(defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float))))
+(defconstant +gvalue-size+ #.(size-of-gvalue))
+
(defconstant +gvalue-value-offset+ (size-of 'type-number))
(defbinding (gvalue-init "g_value_init") () nil
+ (value gvalue)
(type type-number))
-(defun gvalue-new (type)
+(defun gvalue-new (type &optional (value nil value-p))
(let ((gvalue (allocate-memory +gvalue-size+)))
- (setf (system:sap-ref-32 gvalue 0) type)
-; (gvalue-init (type-number-of type))
+ (gvalue-init gvalue (find-type-number type))
+ (when value-p
+ (gvalue-set gvalue value))
gvalue))
(defun gvalue-free (gvalue free-content)
value)
+(deftype-method unreference-alien gvalue (type-spec location)
+ `(gvalue-free ,location nil))
+
+
+
(deftype param-flag-type ()
'(flags
(:readable 1)
(:lax-validation 16)
(:private 32)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;(eval-when (:compile-toplevel :load-toplevel :execute)
+;; TODO: rename to param-spec
(defclass param (ginstance)
((name
:allocation :alien
:type string))
(:metaclass ginstance-class)
(:ref "g_param_spec_ref")
- (:unref "g_param_spec_unref")))
+ (:unref "g_param_spec_unref"));)
(defclass param-char (param)
(defclass param-object (param)
()
(:metaclass ginstance-class))
-
-
-
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtype.lisp,v 1.16 2002-03-24 12:56:03 espen Exp $
+;; $Id: gtype.lisp,v 1.17 2004-10-27 14:59:00 espen Exp $
(in-package "GLIB")
(use-prefix "g")
+;(load-shared-library "libgobject-2.0" :init "g_type_init")
+
;;;;
(deftype type-number () '(unsigned 32))
(let ((type-number
(etypecase id
(integer id)
- (string (find-type-number id t)))))
+ (string (find-type-number id t))
+ (symbol (gethash id *type-to-number-hash*)))))
(setf (gethash type *type-to-number-hash*) type-number)
- (setf (gethash type-number *number-to-type-hash*) type)
+ (unless (symbolp id)
+ (setf (gethash type-number *number-to-type-hash*) type))
type-number))
(defbinding %type-from-name () type-number
;;;; Metaclass for subclasses of ginstance
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass ginstance-class (proxy-class)))
+ (defclass ginstance-class (proxy-class)
+ ()))
(defmethod shared-initialize ((class ginstance-class) names
&rest initargs &key name alien-name
- size ref unref)
+ ref unref)
(declare (ignore initargs names))
(let* ((class-name (or name (class-name class)))
(type-number
(find-type-number
(or (first alien-name) (default-alien-type-name class-name)) t)))
(register-type class-name type-number)
- (let ((size (or size (type-instance-size type-number))))
- (declare (special size))
- (call-next-method)))
+ (if (getf initargs :size)
+ (call-next-method)
+ (let ((size (type-instance-size type-number)))
+ (apply #'call-next-method class names :size (list size) initargs))))
(when ref
(let ((ref (mkbinding (first ref) 'pointer 'pointer)))
(slot-value class 'copy)
#'(lambda (type location)
(declare (ignore type))
- (funcall ref location)))))
+ (funcall ref location)))))
(when unref
(let ((unref (mkbinding (first unref) 'nil 'pointer)))
(setf
;;; Modifications for better AMOP conformance
;;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no>
-(in-package "PCL")
-
-;;;; Adding initargs parameter to change-class
-(defun change-class-internal (instance new-class initargs)
- (let* ((old-class (class-of instance))
- (copy (allocate-instance new-class))
- (new-wrapper (get-wrapper copy))
- (old-wrapper (class-wrapper old-class))
- (old-layout (wrapper-instance-slots-layout old-wrapper))
- (new-layout (wrapper-instance-slots-layout new-wrapper))
- (old-slots (get-slots instance))
- (new-slots (get-slots copy))
- (old-class-slots (wrapper-class-slots old-wrapper)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (ext:package-lock (find-package "PCL")) nil))
- ;;
- ;; "The values of local slots specified by both the class Cto and
- ;; Cfrom are retained. If such a local slot was unbound, it remains
- ;; unbound."
- ;;
- (iterate ((new-slot (list-elements new-layout))
- (new-position (interval :from 0)))
- (let ((old-position (posq new-slot old-layout)))
- (when old-position
- (setf (instance-ref new-slots new-position)
- (instance-ref old-slots old-position)))))
+(in-package "PCL")
+(defstruct slot-info
+ (name nil :type symbol)
+ ;;
+ ;; Specified slot allocation.or :INSTANCE.
+ (allocation :instance :type symbol)
+ ;;
+ ;; Specified slot type or T.
+ (type t :type (or symbol list number)))
+
+
+(defmethod compute-slots :around ((class standard-class))
+ (loop with slotds = (call-next-method) and location = -1
+ for slot in slotds do
+ (setf (slot-definition-location slot)
+ (case (slot-definition-allocation slot)
+ (:instance
+ (incf location))
+ (:class
+ (let* ((name (slot-definition-name slot))
+ (from-class (slot-definition-allocation-class slot))
+ (cell (assq name (class-slot-cells from-class))))
+ (assert (consp cell))
+ cell))))
+ (initialize-internal-slot-functions slot)
+ finally
+ (return slotds)))
+
+
+
+(defun update-slots (class eslotds)
+ (collect ((instance-slots) (class-slots))
+ (dolist (eslotd eslotds)
+ (case (slot-definition-allocation eslotd)
+ (:instance (instance-slots eslotd))
+ (:class (class-slots eslotd))))
;;
- ;; "The values of slots specified as shared in the class Cfrom and
- ;; as local in the class Cto are retained."
- ;;
- (iterate ((slot-and-val (list-elements old-class-slots)))
- (let ((position (posq (car slot-and-val) new-layout)))
- (when position
- (setf (instance-ref new-slots position) (cdr slot-and-val)))))
-
- ;; Make the copy point to the old instance's storage, and make the
- ;; old instance point to the new storage.
- (swap-wrappers-and-slots instance copy)
-
- (apply #'update-instance-for-different-class copy instance initargs)
- instance))
-
-
-(fmakunbound 'change-class)
-(defgeneric change-class (instance new-class &rest initargs))
-
-(defmethod change-class ((instance standard-object)
- (new-class standard-class)
- &rest initargs)
- (change-class-internal instance new-class initargs))
-
-(defmethod change-class ((instance funcallable-standard-object)
- (new-class funcallable-standard-class)
- &rest initargs)
- (change-class-internal instance new-class initargs))
-
-(defmethod change-class ((instance standard-object)
- (new-class funcallable-standard-class)
- &rest initargs)
- (declare (ignore initargs))
- (error "Can't change the class of ~S to ~S~@
- because it isn't already an instance with metaclass ~S."
- instance new-class 'standard-class))
-
-(defmethod change-class ((instance funcallable-standard-object)
- (new-class standard-class)
- &rest initargs)
- (declare (ignore initargs))
- (error "Can't change the class of ~S to ~S~@
- because it isn't already an instance with metaclass ~S."
- instance new-class 'funcallable-standard-class))
-
-(defmethod change-class ((instance t) (new-class symbol) &rest initargs)
- (change-class instance (find-class new-class) initargs))
-
-
-;;;; Make the class finalization protocol behave as specified in AMOP
-
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
- (multiple-value-bind (meta initargs)
- (ensure-class-values class args)
- (if (eq (class-of class) meta)
- (apply #'reinitialize-instance class initargs)
- (apply #'change-class class meta initargs))
- (setf (find-class name) class)
- (inform-type-system-about-class class name)
- class))
-
-(defmethod finalize-inheritance ((class std-class))
- (dolist (super (class-direct-superclasses class))
- (unless (class-finalized-p super) (finalize-inheritance super)))
- (update-cpl class (compute-class-precedence-list class))
- (update-slots class (compute-slots class))
- (update-gfs-of-class class)
- (update-inits class (compute-default-initargs class))
- (update-make-instance-function-table class))
-
-(defmethod finalize-inheritance ((class forward-referenced-class))
- (error "~A can't be finalized" class))
-
-(defun update-class (class &optional finalizep)
- (declare (ignore finalizep))
- (unless (class-has-a-forward-referenced-superclass-p class)
- (finalize-inheritance class)
- (dolist (sub (class-direct-subclasses class))
- (update-class sub))))
+ ;; If there is a change in the shape of the instances then the
+ ;; old class is now obsolete.
+ (let* ((nlayout (mapcar #'slot-definition-name
+ (sort (instance-slots) #'<
+ :key #'slot-definition-location)))
+ (nslots (length nlayout))
+ (nwrapper-class-slots (compute-class-slots (class-slots)))
+ (owrapper (when (class-finalized-p class)
+ (class-wrapper class)))
+ (olayout (when owrapper
+ (wrapper-instance-slots-layout owrapper)))
+ (nwrapper
+ (cond ((null owrapper)
+ (make-wrapper nslots class))
+ ;;
+ ;; We cannot reuse the old wrapper easily when it
+ ;; has class slot cells, even if these cells are
+ ;; EQUAL to the ones used in the new wrapper. The
+ ;; class slot cells of OWRAPPER may be referenced
+ ;; from caches, and if we don't change the wrapper,
+ ;; the caches won't notice that something has
+ ;; changed. We could do something here manually,
+ ;; but I don't think it's worth it.
+ ((and (equal nlayout olayout)
+ (null (wrapper-class-slots owrapper)))
+ owrapper)
+ (t
+ ;;
+ ;; This will initialize the new wrapper to have the same
+ ;; state as the old wrapper. We will then have to change
+ ;; that. This may seem like wasted work (it is), but the
+ ;; spec requires that we call make-instances-obsolete.
+ (make-instances-obsolete class)
+ (class-wrapper class)))))
+
+ (with-slots (wrapper slots finalized-p) class
+ (update-lisp-class-layout class nwrapper)
+ (setf slots eslotds
+ (wrapper-instance-slots-layout nwrapper) nlayout
+ (wrapper-class-slots nwrapper) nwrapper-class-slots
+ (wrapper-no-of-instance-slots nwrapper) nslots
+ wrapper nwrapper
+ finalized-p t))
+
+ (unless (eq owrapper nwrapper)
+ (update-inline-access class)
+ (update-pv-table-cache-info class)
+ (maybe-update-standard-class-locations class)))))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: proxy.lisp,v 1.7 2002-01-20 14:52:04 espen Exp $
+;; $Id: proxy.lisp,v 1.8 2004-10-27 14:59:00 espen Exp $
(in-package "GLIB")
+(import
+'(pcl::initialize-internal-slot-functions
+ pcl::compute-effective-slot-definition-initargs
+ pcl::compute-slot-accessor-info
+ pcl::reader-function pcl::writer-function pcl::boundp-function))
;;;; Superclass for all metaclasses implementing some sort of virtual slots
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass virtual-slot-class (pcl::standard-class))
+ (defclass virtual-slot-class (standard-class)
+ ())
(defclass direct-virtual-slot-definition (standard-direct-slot-definition)
((setter :reader slot-definition-setter :initarg :setter)
- (getter :reader slot-definition-getter :initarg :getter)))
+ (getter :reader slot-definition-getter :initarg :getter)
+ (boundp :reader slot-definition-boundp :initarg :boundp)))
- (defclass effective-virtual-slot-definition
- (standard-effective-slot-definition)))
+ (defclass effective-virtual-slot-definition (standard-effective-slot-definition)
+ ((setter :reader slot-definition-setter :initarg :setter)
+ (getter :reader slot-definition-getter :initarg :getter)
+ (boundp :reader slot-definition-boundp :initarg :boundp)))
+
+ (defun most-specific-slot-value (instances slot &optional default)
+ (let ((object (find-if
+ #'(lambda (ob)
+ (and (slot-exists-p ob slot) (slot-boundp ob slot)))
+ instances)))
+ (if object
+ (slot-value object slot)
+ default)))
+)
+
-(defmethod direct-slot-definition-class ((class virtual-slot-class) initargs)
+(defmethod direct-slot-definition-class ((class virtual-slot-class) &rest initargs)
(if (eq (getf initargs :allocation) :virtual)
(find-class 'direct-virtual-slot-definition)
(call-next-method)))
-(defmethod effective-slot-definition-class ((class virtual-slot-class) initargs)
+(defmethod effective-slot-definition-class ((class virtual-slot-class) &rest initargs)
(if (eq (getf initargs :allocation) :virtual)
(find-class 'effective-virtual-slot-definition)
(call-next-method)))
-(defun %most-specific-slot-value (slotds slot &optional default)
- (let ((slotd
- (find-if
- #'(lambda (slotd)
- (and
- (slot-exists-p slotd slot)
- (slot-boundp slotd slot)))
- slotds)))
- (if slotd
- (slot-value slotd slot)
- default)))
-
-(defgeneric compute-virtual-slot-accessors (class slotd direct-slotds))
-
-(defmethod compute-virtual-slot-accessors
- ((class virtual-slot-class)
- (slotd effective-virtual-slot-definition)
- direct-slotds)
- (let ((getter (%most-specific-slot-value direct-slotds 'getter))
- (setter (%most-specific-slot-value direct-slotds 'setter)))
- (list getter setter)))
-
-(defmethod compute-effective-slot-definition
- ((class virtual-slot-class) direct-slotds)
- (let ((slotd (call-next-method)))
- (when (typep slotd 'effective-virtual-slot-definition)
- (setf
- (slot-value slotd 'pcl::location)
- (compute-virtual-slot-accessors class slotd direct-slotds)))
- slotd))
+
+(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
+ (with-slots (getter setter boundp) slotd
+ (unless (slot-boundp slotd 'reader-function)
+ (setf
+ (slot-value slotd 'reader-function)
+ (etypecase getter
+ (function getter)
+ (null #'(lambda (object)
+ (declare (ignore object))
+ (error "Can't read slot: ~A" (slot-definition-name slotd))))
+ (symbol #'(lambda (object)
+ (funcall getter object))))))
+
+ (unless (slot-boundp slotd 'writer-function)
+ (setf
+ (slot-value slotd 'writer-function)
+ (etypecase setter
+ (function setter)
+ (null #'(lambda (object)
+ (declare (ignore object))
+ (error "Can't set slot: ~A" (slot-definition-name slotd))))
+ ((or symbol cons) #'(lambda (value object)
+ (funcall (fdefinition setter) value object))))))
+
+ (unless (slot-boundp slotd 'boundp-function)
+ (setf
+ (slot-value slotd 'boundp-function)
+ (etypecase boundp
+ (function boundp)
+ (null #'(lambda (object)
+ (declare (ignore object))
+ t))
+ (symbol #'(lambda (object)
+ (funcall boundp object)))))))
+ (initialize-internal-slot-gfs (slot-definition-name slotd)))
+
+
+
+(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition)
+ type gf)
+ nil)
+
+(defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class) direct-slotds)
+ (if (eq (most-specific-slot-value direct-slotds 'allocation) :virtual)
+ (nconc
+ (list :getter (most-specific-slot-value direct-slotds 'getter)
+ :setter (most-specific-slot-value direct-slotds 'setter)
+ :boundp (most-specific-slot-value direct-slotds 'boundp))
+ (call-next-method))
+ (call-next-method)))
+
(defmethod slot-value-using-class
((class virtual-slot-class) (object standard-object)
(slotd effective-virtual-slot-definition))
- (let ((reader (first (slot-definition-location slotd))))
- (if reader
- (funcall reader object)
- (slot-unbound class object (slot-definition-name slotd)))))
+ (if (funcall (slot-value slotd 'boundp-function) object)
+ (funcall (slot-value slotd 'reader-function) object)
+ (slot-unbound class object (slot-definition-name slotd))))
(defmethod slot-boundp-using-class
((class virtual-slot-class) (object standard-object)
(slotd effective-virtual-slot-definition))
- (and (first (slot-definition-location slotd)) t))
-
-(defmethod (setf slot-value-using-class)
+ (funcall (slot-value slotd 'boundp-function) object))
+
+(defmethod (setf slot-value-using-class)
(value (class virtual-slot-class) (object standard-object)
(slotd effective-virtual-slot-definition))
- (let ((setter (second (slot-definition-location slotd))))
- (cond
- ((null setter)
- (error
- "Can't set read-only slot ~A in ~A"
- (slot-definition-name slotd)
- object))
- ((or (functionp setter) (symbolp setter))
- (funcall setter value object)
- value)
- (t
- (funcall (fdefinition setter) value object)
- value))))
-
+ (funcall (slot-value slotd 'writer-function) value object))
+
+
(defmethod validate-superclass
- ((class virtual-slot-class) (super pcl::standard-class))
+ ((class virtual-slot-class) (super standard-class))
t)
(ext:finalize instance (instance-finalizer instance)))
(defmethod instance-finalizer ((instance proxy))
- (let ((free (proxy-class-free (class-of instance)))
+ (let ((class (class-of instance))
(type (type-of instance))
(location (proxy-location instance)))
- (declare
- (type symbol type)
- (type system-area-pointer location))
- #'(lambda ()
- (funcall free type location)
- (remove-cached-instance location))))
+ (declare (type symbol type) (type system-area-pointer location))
+ (let ((free (proxy-class-free class)))
+ #'(lambda ()
+ (funcall free type location)
+ (remove-cached-instance location)))))
(deftype-method translate-type-spec proxy (type-spec)
proxy (type-spec instance &optional weak-ref)
(if weak-ref
`(proxy-location ,instance)
- `(funcall
- ',(proxy-class-copy (find-class type-spec))
- ',type-spec (proxy-location ,instance))))
+ (let ((copy (proxy-class-copy (find-class type-spec))))
+ (if (symbolp copy)
+ `(,copy ',type-spec (proxy-location ,instance))
+ `(funcall ',copy ',type-spec (proxy-location ,instance))))))
(deftype-method unreference-alien proxy (type-spec location)
- `(funcall ',(proxy-class-free (find-class type-spec)) ',type-spec ,location))
+ (let ((free (proxy-class-free (find-class type-spec))))
+ (if (symbolp free)
+ `(,free ',type-spec ,location)
+ `(funcall ',free ',type-spec ,location))))
-(defun proxy-instance-size (proxy)
- (proxy-class-size (class-of proxy)))
+;; (defun proxy-instance-size (proxy)
+;; (proxy-class-size (class-of proxy)))
;;;; Metaclass used for subclasses of proxy
(offset :reader slot-definition-offset :initarg :offset)))
(defclass effective-alien-slot-definition (effective-virtual-slot-definition)
- ((offset :reader slot-definition-offset)))
+ ((offset :reader slot-definition-offset :initarg :offset)))
- (defclass effective-virtual-alien-slot-definition
- (effective-virtual-slot-definition))
+ (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition)
+ ())
(defmethod most-specific-proxy-superclass ((class proxy-class))
(find-if
#'(lambda (class)
(subtypep (class-name class) 'proxy))
- (cdr (pcl::compute-class-precedence-list class))))
-
+ (cdr (compute-class-precedence-list class))))
+
(defmethod direct-proxy-superclass ((class proxy-class))
(find-if
#'(lambda (class)
(subtypep (class-name class) 'proxy))
- (pcl::class-direct-superclasses class)))
-
+ (class-direct-superclasses class)))
+
(defmethod shared-initialize ((class proxy-class) names
&rest initargs &key size copy free)
(declare (ignore initargs))
(call-next-method)
(cond
- (size (setf (slot-value class 'size) (first size)))
- ((slot-boundp class 'size) (slot-makunbound class 'size)))
+ (size (setf (slot-value class 'size) (first size)))
+ ((slot-boundp class 'size) (slot-makunbound class 'size)))
(cond
- (copy (setf (slot-value class 'copy) (first copy)))
- ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
+ (copy (setf (slot-value class 'copy) (first copy)))
+ ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
(cond
- (free (setf (slot-value class 'free) (first free)))
- ((slot-boundp class 'free) (slot-makunbound class 'free))))
-
- (defmethod finalize-inheritance ((class proxy-class))
- (call-next-method)
+ (free (setf (slot-value class 'free) (first free)))
+ ((slot-boundp class 'free) (slot-makunbound class 'free))))
+
+;; (defmethod finalize-inheritance ((class proxy-class))
+;; (call-next-method)
+ (defmethod shared-initialize :after ((class proxy-class) names &rest initargs)
(let ((super (most-specific-proxy-superclass class)))
(unless (or (not super) (eq super (find-class 'proxy)))
- (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
- (setf (slot-value class 'copy) (proxy-class-copy super)))
- (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
- (setf (slot-value class 'free) (proxy-class-free super))))))
-
- (defmethod direct-slot-definition-class ((class proxy-class) initargs)
+ (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
+ (setf (slot-value class 'copy) (proxy-class-copy super)))
+ (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
+ (setf (slot-value class 'free) (proxy-class-free super))))))
+
+ (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
(case (getf initargs :allocation)
((nil :alien) (find-class 'direct-alien-slot-definition))
-; (:instance (error "Allocation :instance not allowed in class ~A" class))
(t (call-next-method))))
-
- (defmethod effective-slot-definition-class ((class proxy-class) initargs)
+
+ (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
(case (getf initargs :allocation)
(:alien (find-class 'effective-alien-slot-definition))
(:virtual (find-class 'effective-virtual-alien-slot-definition))
(t (call-next-method))))
- (defmethod compute-virtual-slot-accessors
- ((class proxy-class) (slotd effective-alien-slot-definition)
- direct-slotds)
- (with-slots (offset type) slotd
- (let ((reader (intern-reader-function type))
- (writer (intern-writer-function type))
- (destroy (intern-destroy-function type)))
- (setf offset (slot-definition-offset (first direct-slotds)))
- (list
- #'(lambda (object)
- (funcall reader (proxy-location object) offset))
- #'(lambda (value object)
- (let ((location (proxy-location object)))
- (funcall destroy location offset)
- (funcall writer value location offset)))))))
-
- (defmethod compute-virtual-slot-accessors
- ((class proxy-class)
- (slotd effective-virtual-alien-slot-definition)
- direct-slotds)
- (destructuring-bind (getter setter) (call-next-method)
- (with-slots (type) slotd
- (list
- (if (stringp getter)
- (let ((getter (mkbinding-late getter type 'pointer)))
- #'(lambda (object)
- (funcall getter (proxy-location object))))
- getter)
- (if (stringp setter)
- (let ((setter (mkbinding-late setter 'nil 'pointer type)))
- #'(lambda (value object)
- (funcall setter (proxy-location object) value)))
- setter)))))
+
+ (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
+ (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
+ (nconc
+ (list :offset (most-specific-slot-value direct-slotds 'offset))
+ (call-next-method))
+ (call-next-method)))
+
+
+ (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
+ (with-slots (offset) slotd
+ (let* ((type (slot-definition-type slotd))
+ (reader (intern-reader-function type))
+ (writer (intern-writer-function type))
+ (destroy (intern-destroy-function type)))
+ (unless (slot-boundp slotd 'reader-function)
+ (setf
+ (slot-value slotd 'reader-function)
+ #'(lambda (object)
+ (funcall reader (proxy-location object) offset))))
+
+ (unless (slot-boundp slotd 'writer-function)
+ (setf
+ (slot-value slotd 'writer-function)
+ #'(lambda (value object)
+ (let ((location (proxy-location object)))
+ (funcall destroy location offset)
+ (funcall writer value location offset)))))
+
+ (unless (slot-boundp slotd 'boundp-function)
+ (setf
+ (slot-value slotd 'boundp-function)
+ #'(lambda (object)
+ (declare (ignore object))
+ t)))))
+ (call-next-method))
+
+
+ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-alien-slot-definition))
+ (with-slots (getter setter type) slotd
+ (when (and (not (slot-boundp slotd 'reader-function)) (stringp getter))
+ (let ((reader (mkbinding-late getter type 'pointer)))
+ (setf (slot-value slotd 'reader-function)
+ #'(lambda (object)
+ (funcall reader (proxy-location object))))))
+
+ (when (and (not (slot-boundp slotd 'writer-function)) (stringp setter))
+ (let ((writer (mkbinding-late setter 'nil 'pointer type)))
+ (setf (slot-value slotd 'writer-function)
+ #'(lambda (value object)
+ (funcall writer (proxy-location object) value))))))
+ (call-next-method))
+
+ ;; TODO: call some C code to detect this a compile time
+ (defconstant +struct-alignmen+ 4)
(defmethod compute-slots ((class proxy-class))
- (with-slots (direct-slots size) class
- (let ((current-offset
- (proxy-class-size (most-specific-proxy-superclass class)))
- (max-size 0))
- (dolist (slotd direct-slots)
- (when (eq (slot-definition-allocation slotd) :alien)
- (with-slots (offset type) slotd
- (unless (slot-boundp slotd 'offset)
- (setf offset current-offset))
- (setq current-offset (+ offset (size-of type)))
- (setq max-size (max max-size current-offset)))))
- (unless (slot-boundp class 'size)
- (setf size max-size))))
+ ;; This stuff should really go somewhere else
+ (loop
+ with offset = (proxy-class-size (most-specific-proxy-superclass class))
+ with size = offset
+ for slotd in (class-direct-slots class)
+ when (eq (slot-definition-allocation slotd) :alien)
+ do (if (not (slot-boundp slotd 'offset))
+ (setf (slot-value slotd 'offset) offset)
+ (setq offset (slot-value slotd 'offset)))
+
+ (incf offset (size-of (slot-definition-type slotd)))
+ (incf offset (mod offset +struct-alignmen+))
+ (setq size (max size offset))
+
+ finally (unless (slot-boundp class 'size)
+ (setf (slot-value class 'size) size)))
(call-next-method))
-
- (defmethod validate-superclass ((class proxy-class)
- (super pcl::standard-class))
- (subtypep (class-name super) 'proxy))
+
+ (defmethod validate-superclass ((class proxy-class) (super standard-class))
+ (subtypep (class-name super) 'proxy))
+
(defmethod proxy-class-size (class)
(declare (ignore class))
0)
-
- (defgeneric make-proxy-instance (class location weak-ref
- &rest initargs &key)))
+)
+
+(defgeneric make-proxy-instance (class location weak-ref
+ &rest initargs &key));)
(defmethod make-proxy-instance ((class symbol) location weak-ref
&rest initargs &key)
(:copy %copy-struct)
(:free %free-struct)))
-(defmethod initialize-instance ((structure struct)
- &rest initargs)
+(defmethod initialize-instance ((structure struct) &rest initargs)
(declare (ignore initargs))
(setf
(slot-value structure 'location)
~mdw / clg / commitdiff