Changeset 488

Timestamp:

Feb 7, 2004, 1:54:58 PM (21 years ago)

Author:

Gary Byers

Message:

Revive objc-classes/methods when restarting an image.
Check appkit/foundation versions, print a message & exit if mismatch.
Find cfstring-containing library sections after loading appkit/foundation,
and again on image startup.

File:

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

trunk/ccl/examples/objc-runtime.lisp

@@ -337 +337 @@
 )
 
+(defun get-appkit-version ()
+  (%get-double-float (foreign-symbol-address #+apple-objc "_NSAppKitVersionNumber" #+gnu-objc "NSAppKitVersionNumber")))
+
+(defun get-foundation-version ()
+  (%get-double-float (foreign-symbol-address #+apple-objc "_NSFoundationVersionNumber" #+gnu-objc "NSFoundationVersionNumber")))
+
+(defparameter *appkit-library-version-number* (get-appkit-version))
+(defparameter *foundation-library-version-number* (get-foundation-version))
+
+(def-ccl-pointers cfstring-sections ()
+  (reset-cfstring-sections)
+  (find-cfstring-sections))
 
 ;;; When starting up an image that's had ObjC classes in it, all of
@@ -354 +366 @@
   ;; resolving those foreign classes that existed in the old
   ;; image and still exist in the new.
+  (unless (= *foundation-library-version-number* (get-foundation-version))
+    (format *error-output* "~&Foundation version mismatch: expected ~s, got ~s~&"
+            *Foundation-library-version-number* (get-foundation-version))
+    (#_exit 1))
+  (unless (= *appkit-library-version-number* (get-appkit-version))
+    (format *error-output* "~&AppKit version mismatch: expected ~s, got ~s~&"
+            *appkit-library-version-number* (get-appkit-version))
+    (#_exit 1))
   (let* ((class-map (objc-class-map))
          (metaclass-map (objc-metaclass-map))
@@ -374 +394 @@
                                       #+gnu-objc :objc_class.class_pointer)))
               (splay-tree-put metaclass-map m meta-id))))))
-    (break "second pass")
     ;; Second pass: install class objects for user-defined classes,
-    ;; assuming the superclasses are already "revived".
+    ;; assuming the superclasses are already "revived".  If the
+    ;; superclass is itself user-defined, it'll appear first in the
+    ;; class table; that's an artifact of the current implementation.
     (dotimes (i nclasses)
       (let* ((c (id->objc-class i)))
@@ -386 +407 @@
                  (meta-id (objc-class-id->objc-metaclass-id i))
                  (m (id->objc-metaclass meta-id)))
-            (when (%null-ptr-p m)
+            (unless (splay-tree-get metaclass-map m)
+              (%revive-macptr m)
               (%setf-macptr m (%make-basic-meta-class
-                               (objc-metaclass-id-foreign-name meta-id)
+                               (make-cstring (objc-metaclass-id-foreign-name meta-id))
                                super
-                               (@class "NSObject")))
+                               (find-class 'ns::ns-object)))
               (splay-tree-put metaclass-map m meta-id))
             (%setf-macptr c (%make-class-object
                              m
                              super
-                             (objc-class-id-foreign-name i)
+                             (make-cstring (objc-class-id-foreign-name i))
                              (%null-ptr)
                              0))
@@ -402 +424 @@
               (%add-objc-class c ivars instance-size)
               (splay-tree-put class-map c i))))))))
-      
-      
+
+(pushnew #'revive-objc-classes *lisp-system-pointer-functions*
+         :test #'eq
+         :key #'function-name)
     
     
@@ -1297 +1321 @@
      imp)))
 
-
+(def-ccl-pointers add-objc-methods ()
+  (maphash #'(lambda (impname m)
+               (declare (ignore impname))
+               (%add-lisp-objc-method m))
+           *lisp-objc-methods*))
 
 (defun %define-lisp-objc-method (impname classname selname typestring imp
@@ -1516 +1544 @@
   (setf (%get-ptr (foreign-symbol-address "__dealloc")) *original-deallocate-hook*))
 
-#+testing
 (pushnew #'uninstall-lisp-deallocate-hook *lisp-cleanup-functions* :test #'eq
          :key #'function-name)