Changeset 868

Timestamp:

Aug 30, 2004, 2:59:22 PM (20 years ago)

Author:

Gary Byers

Message:

Assert that SELF is an instance in instance method (should also assert
that :ID-typed parameters are instances/classes.)

File:

• trunk/ccl/examples/objc-runtime.lisp (modified) (5 diffs)

trunk/ccl/examples/objc-runtime.lisp

@@ -1239 +1239 @@
 (defun %objc-instance-class-index (p)
   #+apple-objc
-  (if (or (pointer-in-cfstring-section-p p)
-          (with-macptrs ((zone (#_malloc_zone_from_ptr p)))
-            (not (%null-ptr-p zone))))
+  (if (or (with-macptrs ((zone (#_malloc_zone_from_ptr p)))
+            (not (%null-ptr-p zone)))
+          (pointer-in-cfstring-section-p p))
     (with-macptrs ((parent (pref p :objc_object.isa)))
       (objc-class-id parent)))
   #+gnu-objc
-  (with-macptrs ((parent (pref p objc_object.class_pointer)))
+  (with-macptrs ((parent (pref p :objc_object.class_pointer)))
     (objc-class-id-parent))
   )
@@ -1502 +1502 @@
                         struct-return)
       (parse-objc-method selector-arg class-arg body)
+    (let* ((self (intern "SELF")))
       (multiple-value-bind (body decls) (parse-body body env)
+        (unless class-p
+          (push `(%set-objc-instance-type ,self) body))
         (setq body (coerce-foreign-boolean-args argspecs body))
         (if (eq resulttype :<BOOL>)
@@ -1510 +1513 @@
                                         class-name
                                         selector-name)))
-               (self (intern "SELF"))
                (_cmd (intern "_CMD"))
                (super (gensym "SUPER"))
@@ -1520 +1522 @@
           `(progn
             (defcallback ,impname
-                    (:without-interrupts nil
-                                         #+(and openmcl-native-threads apple-objc) :error-return
-                                         #+(and openmcl-native-threads apple-objc)  (condition objc-callback-error-return) ,@params ,resulttype)
-                  (declare (ignorable ,_cmd))
-                  ,@decls
-                  (rlet ((,super :objc_super
-                           #+apple-objc :receiver #+gnu-objc :self ,self
-                           :class
-                           ,@(if class-p
-                                 `((pref
-                                    (pref (@class ,class-name)
-                                     #+apple-objc :objc_class.isa
-                                     #+gnu-objc :objc_class.super_class )
-                                    :objc_class.super_class))
-                                 `((pref (@class ,class-name) :objc_class.super_class)))))
-                    (macrolet ((send-super (msg &rest args &environment env) 
-                                 (make-optimized-send nil msg args env nil ',super ,class-name))
-                               (send-super/stret (s msg &rest args &environment env) 
-                                 (make-optimized-send nil msg args env s ',super ,class-name)))
-                      (flet ((%send-super (msg &rest args)
-                               (make-general-send nil msg args nil ,super ,class-name))
-                             (%send-super/stret (s msg &rest args)
-                               (make-general-send nil msg args s ,super ,class-name))
-                             (super () ,super))
-                        ,@body))))
+                (:without-interrupts nil
+                 #+(and openmcl-native-threads apple-objc) :error-return
+                 #+(and openmcl-native-threads apple-objc)  (condition objc-callback-error-return) ,@params ,resulttype)
+              (declare (ignorable ,_cmd))
+              ,@decls
+              (rlet ((,super :objc_super
+                       #+apple-objc :receiver #+gnu-objc :self ,self
+                       :class
+                       ,@(if class-p
+                             `((pref
+                                (pref (@class ,class-name)
+                                 #+apple-objc :objc_class.isa
+                                 #+gnu-objc :objc_class.super_class )
+                                :objc_class.super_class))
+                             `((pref (@class ,class-name) :objc_class.super_class)))))
+                (macrolet ((send-super (msg &rest args &environment env) 
+                             (make-optimized-send nil msg args env nil ',super ,class-name))
+                           (send-super/stret (s msg &rest args &environment env) 
+                             (make-optimized-send nil msg args env s ',super ,class-name)))
+                  (flet ((%send-super (msg &rest args)
+                           (make-general-send nil msg args nil ,super ,class-name))
+                         (%send-super/stret (s msg &rest args)
+                           (make-general-send nil msg args s ,super ,class-name))
+                         (super () ,super))
+                    ,@body))))
             (%define-lisp-objc-method
              ',impname
@@ -1551 +1553 @@
              ,typestring
              ,impname
-             ,class-p))))))
+             ,class-p)))))))
 
 (defmacro define-objc-method ((selector-arg class-arg)