Changeset 486
- Timestamp:
- Feb 6, 2004, 11:43:50 AM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/examples/objc-runtime.lisp (modified) (16 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/objc-runtime.lisp
r468 r486 91 91 (csv (make-array 1024)) 92 92 (msv (make-array 1024)) 93 (class-id->metaclass-id (make-array 1024 :initial-element nil))) 93 (class-id->metaclass-id (make-array 1024 :initial-element nil)) 94 (class-foreign-names (make-array 1024)) 95 (metaclass-foreign-names (make-array 1024)) 96 ) 94 97 95 98 (flet ((grow-vectors () … … 108 111 (extend msv) 109 112 (extend class-id->metaclass-id) 110 (fill class-id->metaclass-id nil :start old-size :end new-size)) 113 (fill class-id->metaclass-id nil :start old-size :end new-size) 114 (extend class-foreign-names) 115 (extend metaclass-foreign-names)) 111 116 (setq class-table-size new-size)))) 112 117 (flet ((assign-next-class-id () … … 144 149 (defun (setf id->objc-metaclass-slots-vector) (new i) 145 150 (setf (svref msv i) new)) 151 (defun objc-class-id-foreign-name (i) 152 (svref class-foreign-names i)) 153 (defun (setf objc-class-id-foreign-name) (new i) 154 (setf (svref class-foreign-names i) new)) 155 (defun objc-metaclass-id-foreign-name (i) 156 (svref metaclass-foreign-names i)) 157 (defun (setf objc-metaclass-id-foreign-name) (new i) 158 (setf (svref metaclass-foreign-names i) new)) 146 159 (defun %clear-objc-class-maps () 147 160 (with-lock-grabbed (objc-class-lock) 148 (fill c 0)149 (fill m 0)150 (fill cw nil)151 (fill mw nil)152 (fill csv 0)153 (fill msv 0)154 (fill class-id->metaclass-id nil)155 161 (setf (splay-tree-root objc-class-map) nil 156 162 (splay-tree-root objc-metaclass-map) nil 157 163 (splay-tree-count objc-class-map) 0 158 (splay-tree-count objc-metaclass-map) 0 159 next-objc-class-id 0 160 next-objc-metaclass-id 0))) 164 (splay-tree-count objc-metaclass-map) 0))) 161 165 (flet ((install-objc-metaclass (meta) 162 166 (or (splay-tree-get objc-metaclass-map meta) … … 194 198 (svref m (svref class-id->metaclass-id class-id))) 195 199 (defun objc-class-map () objc-class-map) 196 (defun objc-metaclass-map () objc-metaclass-map)))) 200 (defun %objc-class-count () next-objc-class-id) 201 (defun objc-metaclass-map () objc-metaclass-map) 202 (defun %objc-metaclass-count () next-objc-metaclass-id)))) 197 203 198 204 (pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq … … 214 220 (id->objc-metaclass id) 215 221 (error "Class ~S isn't recognized." m)))) 216 222 217 223 218 224 ;;; Open shared libs. … … 254 260 t)))))) 255 261 256 (pushnew 'remap-all-library-classes *lisp-system-pointer-functions*)257 262 258 263 (let* ((cfstring-sections (cons 0 nil))) … … 333 338 334 339 340 ;;; When starting up an image that's had ObjC classes in it, all of 341 ;;; those canonical classes (and metaclasses) will have had their type 342 ;;; changed (by SAVE-APPLICATION) to, CCL::DEAD-MACPTR and the addresses 343 ;;; of those classes may be bogus. The splay trees (objc-class/metaclass-map) 344 ;;; should be empty. 345 ;;; For each class that -had- had an assigned ID, determine its ObjC 346 ;;; class name, and ask ObjC where (if anywhere) the class is now. 347 ;;; If we get a non-null answer, revive the class pointer and set its 348 ;;; address appropriately, then add an entry to the splay tree; this 349 ;;; means that classes that existed on both sides of SAVE-APPLICATION 350 ;;; will retain the same ID. 351 352 (defun revive-objc-classes () 353 ;; Make a first pass over the class and metaclass tables; 354 ;; resolving those foreign classes that existed in the old 355 ;; image and still exist in the new. 356 (let* ((class-map (objc-class-map)) 357 (metaclass-map (objc-metaclass-map)) 358 (nclasses (%objc-class-count))) 359 (dotimes (i nclasses) 360 (let* ((c (id->objc-class i)) 361 (meta-id (objc-class-id->objc-metaclass-id i)) 362 (m (id->objc-metaclass meta-id))) 363 (%revive-macptr c) 364 (%revive-macptr m) 365 (unless (splay-tree-get class-map c) 366 (%set-pointer-to-objc-class-address (objc-class-id-foreign-name i) c) 367 ;; If the class is valid and the metaclass is still a 368 ;; dead pointer, revive the metaclass 369 (unless (%null-ptr-p c) 370 (splay-tree-put class-map c i) 371 (unless (splay-tree-get metaclass-map m) 372 (when (%null-ptr-p m) 373 (%setf-macptr m (pref c #+apple-objc :objc_class.isa 374 #+gnu-objc :objc_class.class_pointer))) 375 (splay-tree-put metaclass-map m meta-id)))))) 376 (break "second pass") 377 ;; Second pass: install class objects for user-defined classes, 378 ;; assuming the superclasses are already "revived". 379 (dotimes (i nclasses) 380 (let* ((c (id->objc-class i))) 381 (when (and (%null-ptr-p c) 382 (not (slot-value c 'foreign))) 383 (let* ((super (dolist (s (class-direct-superclasses c) 384 (error "No ObjC superclass of ~s" c)) 385 (when (objc-class-p s) (return s)))) 386 (meta-id (objc-class-id->objc-metaclass-id i)) 387 (m (id->objc-metaclass meta-id))) 388 (when (%null-ptr-p m) 389 (%setf-macptr m (%make-basic-meta-class 390 (objc-metaclass-id-foreign-name meta-id) 391 super 392 (@class "NSObject"))) 393 (splay-tree-put metaclass-map m meta-id)) 394 (%setf-macptr c (%make-class-object 395 m 396 super 397 (objc-class-id-foreign-name i) 398 (%null-ptr) 399 0)) 400 (multiple-value-bind (ivars instance-size) 401 (%make-objc-ivars c) 402 (%add-objc-class c ivars instance-size) 403 (splay-tree-put class-map c i)))))))) 404 405 406 407 408 335 409 (defun install-foreign-objc-class (class) 336 410 (let* ((id (objc-class-id class))) … … 342 416 (unless (%null-ptr-p super) 343 417 (install-foreign-objc-class super)) 344 (let* ((class-name 345 (objc-to-lisp-classname (%get-cstring 346 (pref class :objc_class.name)) 418 (let* ((class-foreign-name (%get-cstring 419 (pref class :objc_class.name))) 420 (class-name 421 (objc-to-lisp-classname class-foreign-name 347 422 "NS")) 348 423 (meta-id (objc-class-id->objc-metaclass-id id)) … … 351 426 ;; wrapper if so. 352 427 (unless (id->objc-metaclass-wrapper meta-id) 353 (let* ((meta-name (intern 428 (let* ((meta-foreign-name (%get-cstring 429 (pref meta :objc_class.name))) 430 (meta-name (intern 354 431 (concatenate 'string 355 432 "+" 356 433 (string 357 434 (objc-to-lisp-classname 358 (%get-cstring 359 (pref meta :objc_class.name)) 435 meta-foreign-name 360 436 "NS"))) 361 437 "NS")) … … 378 454 :peer class 379 455 :foreign t) 456 (setf (objc-metaclass-id-foreign-name meta-id) 457 meta-foreign-name) 380 458 (setf (find-class meta-name) meta))) 381 459 (setf (slot-value class 'direct-slots) … … 390 468 :peer meta 391 469 :foreign t) 470 (setf (objc-class-id-foreign-name id) class-foreign-name) 392 471 (setf (find-class class-name) class)))))) 393 472 … … 508 587 (error "ObjC class ~a not found" name)) 509 588 p)))) 589 590 (defun %set-pointer-to-objc-class-address (class-name-string ptr) 591 (with-cstrs ((cstr class-name-string)) 592 (%setf-macptr ptr 593 (#+apple-objc #_objc_lookUpClass 594 #+gnu-objc #_objc_lookup_class 595 cstr))) 596 nil) 597 598 510 599 511 600 (defvar *objc-class-descriptors* (make-hash-table :test #'equal)) … … 1001 1090 (%null-ptr) 1002 1091 0))) 1003 (meta (objc-class-id->objc-metaclass id)) 1092 (meta-id (objc-class-id->objc-metaclass-id id)) 1093 (meta (id->objc-metaclass meta-id)) 1004 1094 (class (id->objc-class id)) 1005 1095 (meta-name (intern (format nil "+~a" class-name) … … 1010 1100 :name meta-name 1011 1101 :direct-superclasses (list meta-super)) 1012 (setf (find-class meta-name) meta) 1102 (setf (objc-class-id-foreign-name id) class-name 1103 (objc-metaclass-id-foreign-name meta-id) class-name 1104 (find-class meta-name) meta) 1013 1105 class))) 1014 1106 … … 1205 1297 imp))) 1206 1298 1207 (def-ccl-pointers add-objc-methods () 1208 (maphash #'(lambda (impname m) 1209 (declare (ignore impname)) 1210 (%add-lisp-objc-method m)) 1211 *lisp-objc-methods*)) 1299 1212 1300 1213 1301 (defun %define-lisp-objc-method (impname classname selname typestring imp … … 1410 1498 #+apple-objc 1411 1499 (progn 1412 (defcallback deallocate-nsobject (:address obj :void) 1500 (defloadvar *original-deallocate-hook* 1501 (%get-ptr (foreign-symbol-address "__dealloc"))) 1502 1503 (defcallback deallocate-nsobject (:address obj :int) 1413 1504 (unless (%null-ptr-p obj) 1414 (remhash obj *objc-object-slot-vectors*) 1415 (setf (pref obj :objc_object.isa) 1416 (external-call "__objc_getFreedObjectClass" :address)) 1417 (free obj))) 1505 (remhash obj *objc-object-slot-vectors*)) 1506 (ff-call *original-deallocate-hook* :address obj :int)) 1507 1508 (defun install-lisp-deallocate-hook () 1509 (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject)) 1418 1510 1419 1511 (def-ccl-pointers install-deallocate-hook () 1420 (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject)) 1512 (install-lisp-deallocate-hook)) 1513 1514 (defun uninstall-lisp-deallocate-hook () 1515 (clrhash *objc-object-slot-vectors*) 1516 (setf (%get-ptr (foreign-symbol-address "__dealloc")) *original-deallocate-hook*)) 1517 1518 #+testing 1519 (pushnew #'uninstall-lisp-deallocate-hook *lisp-cleanup-functions* :test #'eq 1520 :key #'function-name) 1421 1521 ) 1422 1522
Note:
See TracChangeset
for help on using the changeset viewer.
