Changeset 267

Timestamp:

Jan 12, 2004, 7:20:11 AM (21 years ago)

Author:

beer

Message:

Partial support for MAKE-INSTANCE on ObjC classes

File:

• trunk/ccl/examples/objc-clos.lisp (modified) (10 diffs)

trunk/ccl/examples/objc-clos.lisp

@@ -16 +16 @@
 ;;;
 ;;; TO DO
-;;;  - Need to add getter and setter functions for more foriegn slot types
+;;;  - Write SHARED-INITIALIZE and FINALIZE-INHERITANCE for ObjC classes
 ;;;  - OBJC-FOREIGN-ARG-TYPE in BRIDGE.LISP needs to handle BITFIELDs, 
 ;;;    ARRAYs and UNIONs
-;;;  - Need to get enough of the instance initialization and XXX
-;;;    protocols working so that foreign slot objects actually show up
-;;;    where they're supposed to
-;;;  - Implement slot access for OBJC-CLASS lisp slots
+;;;  - Need to fully handle init keywords and ObjC init messages
+;;;  - Need to add getter and setter functions for more foriegn slot types
+;;;  - Canonicalization and retention for ObjC objects
+;;;  - Provide Lisp structs for NS-POINT, NS-RECT, etc.?
 
 ;;; Package and module stuff
@@ -40 +40 @@
 ;;; All class names and instance variable names are interned in the NS package
 ;;; Force all symbols interned in the NS package to be external
-;;; symbols.
 
 (defpackage "NS"
@@ -76 +75 @@
 (defvar *objc-class-class*)
 (defvar *objc-metaclass-class*)
+
+(defvar *objc-object-slot-vectors* (make-hash-table :test #'eql))
 
 (defun recognize-objc-object (p)
@@ -100 +101 @@
       (#.objc-flag-class (id->objc-metaclass index))
       (#.objc-flag-metaclass *objc-metaclass-class*))))
-
   
 (defun %objc-domain-classp (p)
@@ -134 +134 @@
     (declare (fixnum type flags index))
     (ecase flags
-      (#.objc-flag-instance nil)        ;maybe soon
+      (#.objc-flag-instance (gethash p *objc-object-slot-vectors*))
       (#.objc-flag-class (id->objc-class-slots-vector index))
       (#.objc-flag-metaclass (id->objc-metaclass-slots-vector index)))))
@@ -150 +150 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;                  OBJC Objects, Classes and Metaclasses                 ;;;;
+;;;;                  ObjC Objects, Classes and Metaclasses                 ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -266 +266 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;                        OBJC-CLASS Slot Protocol                        ;;;;
+;;;;                              Slot Protocol                             ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -346 +346 @@
 (defun compute-foreign-slot-accessors (eslotd)
   (let ((ftype (%slot-definition-type eslotd)))
-    (case ftype
-      (:unsigned-byte (values #'%get-unsigned-byte #'%set-byte))
-      (:signed-byte (values #'%get-signed-byte #'%set-byte))
-      (:unsigned-word (values #'%get-unsigned-word #'%set-word))
-      (:signed-word (values #'%get-signed-word #'%set-word))
-      (:unsigned-fullword (values #'%get-unsigned-long #'%set-long))
-      (:signed-fullword (values #'%get-signed-long #'%set-long))
-      (:unsigned-longlong (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong))
-      (:signed-longlong (values #'%%get-signed-longlong #'%%set-signed-longlong))
-      (:single-float (values #'%get-single-float #'%set-single-float))
-      (:double-float (values #'%get-double-float #'%set-double-float))
-      ((:id :address) (values #'%get-ptr #'%set-ptr))
-      (t 
-       (cond 
-        ((and (consp ftype) (eq (first ftype) :*))
-         (values #'%get-ptr #'%set-ptr))
-        (t (values 
-            #'(lambda (ptr &optional offset)
-                (declare (ignore ptr offset))
-                (error "Unhandled foreign slot type: ~S" ftype))
-            #'(lambda (ptr &optional offset)
-                (declare (ignore ptr offset))
-                (error "Unhandled foreign slot type: ~S" ftype)))))))))
+    (flet ((unhandled-foreign-slot-type (ptr &optional offset)
+             (declare (ignore ptr offset))
+             (error "Unhandled foreign slot type: ~S" ftype)))
+      (case ftype
+        (:unsigned-byte (values #'%get-unsigned-byte #'%set-byte))
+        (:signed-byte (values #'%get-signed-byte #'%set-byte))
+        (:unsigned-word (values #'%get-unsigned-word #'%set-word))
+        (:signed-word (values #'%get-signed-word #'%set-word))
+        (:unsigned-fullword (values #'%get-unsigned-long #'%set-long))
+        (:signed-fullword (values #'%get-signed-long #'%set-long))
+        (:unsigned-longlong (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong))
+        (:signed-longlong (values #'%%get-signed-longlong #'%%set-signed-longlong))
+        (:single-float (values #'%get-single-float #'%set-single-float))
+        (:double-float (values #'%get-double-float #'%set-double-float))
+        ((:id :address) (values #'%get-ptr #'%set-ptr))
+        (t 
+         (cond 
+          ((and (consp ftype) (eq (first ftype) :*))
+           (values #'%get-ptr #'%set-ptr))
+          (t (values #'unhandled-foreign-slot-type #'unhandled-foreign-slot-type)))))))) 
 
 
@@ -424 +421 @@
   t)
 
+(defmethod slot-makunbound-using-class ((class objc:objc-class-object)
+                                        instance
+                                        (slotd foreign-effective-slot-definition))
+  (declare (ignore instance))
+  (error "Foreign slots cannot be unbound: ~S" (slot-definition-name slotd)))
+
 (defmethod slot-value-using-class ((class objc:objc-class-object)
                                    instance
@@ -440 +443 @@
            value))
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;            Instance Allocation and Initialization Protocols            ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod make-instance ((class objc:objc-class) &rest initargs)
+  (let ((instance (allocate-instance class)))
+    (apply #'initialize-instance instance initargs)
+    instance))
+
+(defmethod allocate-instance ((class objc:objc-class) &key &allow-other-keys)
+  (unless (class-finalized-p class)
+    (finalize-inheritance class))
+  (let* ((instance (%send class 'alloc)) ; For now; Use SEND macro eventually
+         (len (length (%wrapper-instance-slots (class-own-wrapper class))))
+         (slot-vector (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker))))
+    (setf (slot-vector.instance slot-vector) instance)
+    (setf (gethash instance *objc-object-slot-vectors*) slot-vector) 
+    instance))
+
+(defmethod initialize-instance ((instance objc:objc-object) &rest initargs)
+  (apply #'shared-initialize instance t initargs))
+
+(defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs)
+  (apply #'shared-initialize instance nil initargs))
+
+(defmethod shared-initialize ((instance objc:objc-object) slot-names &rest initargs)
+  (let ((class (class-of instance)))
+    ;; Call appropriate ObjC init method
+    (multiple-value-bind (ks vs) (keys-and-vals initargs)
+      (apply #'%send instance (lisp-to-objc-init ks) vs))
+    ;; Initialize CLOS slots
+    (dolist (slotd (class-slots class))
+      (when (neq (slot-definition-allocation slotd) :foreign)  ; For now
+        (let ((sname (slot-definition-name slotd))
+              (slot-type (slot-definition-type slotd))
+              (typepred (slot-value slotd 'type-predicate))
+              (initfunction (slot-definition-initfunction slotd)))
+          (multiple-value-bind (ignore newval foundp)
+                               (get-properties initargs (slot-definition-initargs slotd))
+            (declare (ignore ignore))
+            (if foundp
+                (if (funcall typepred newval)
+                    (setf (slot-value instance sname) newval)
+                  (report-bad-arg newval slot-type))
+              (let ((curval (slot-value instance sname)))
+                (when (and (or (eq slot-names t) (member sname slot-names :test #'eq))
+                           (eq curval (%slot-unbound-marker))
+                           initfunction)
+                  (let ((newval (funcall initfunction)))
+                    (unless (funcall typepred newval)
+                      (report-bad-arg newval slot-type))))))))))
+    instance))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;              Class Definition and Finalization Protocols               ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;