Changeset 123
- Timestamp:
- Dec 15, 2003, 1:11:24 PM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/examples/gnu-objc.lisp (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/gnu-objc.lisp
r122 r123 1 1 ;;;-*-Mode: LISP; Package: CCL -*- 2 2 ;;; 3 ;;; Copyright (C) 2002 Clozure Associates4 ;;; This file is part of Open sourced MCL.3 ;;; Copyright (C) 2002-2003 Clozure Associates 4 ;;; This file is part of OpenMCL. 5 5 ;;; 6 ;;; Opensourced MCL is free software; you can redistribute it and/or 7 ;;; modify it under the terms of the GNU Lesser General Public 8 ;;; License as published by the Free Software Foundation; either 9 ;;; version 2.1 of the License, or (at your option) any later version. 6 ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public 7 ;;; License , known as the LLGPL and distributed with OpenMCL as the 8 ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, 9 ;;; which is distributed with OpenMCL as the file "LGPL". Where these 10 ;;; conflict, the preamble takes precedence. 10 11 ;;; 11 ;;; Opensourced MCL is distributed in the hope that it will be useful, 12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 ;;; Lesser General Public License for more details. 12 ;;; OpenMCL is referenced in the preamble as the "LIBRARY." 15 13 ;;; 16 ;;; You should have received a copy of the GNU Lesser General Public 17 ;;; License along with this library; if not, write to the Free Software 18 ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 ;;; 14 ;;; The LLGPL is also available online at 15 ;;; http://opensource.franz.com/preamble.html 16 20 17 21 18 (in-package "CCL") … … 26 23 (use-interface-dir :gnustep)) 27 24 28 (defparameter *gnustep-system-root* "/usr/GNUstep/") 29 30 (defparameter *pending-loaded-classes* ()) 25 (eval-when (:compile-toplevel :load-toplevel :execute) 26 (require "SPLAY-TREE") 27 (require "NAME-TRANSLATION")) 28 29 (defun ensure-objc-classptr-resolved (classptr) 30 (unless (logtest #$_CLS_RESOLV (pref classptr :objc_class.info)) 31 (external-call "__objc_resolve_class_links" :void))) 32 33 (let* ((objc-class-map (make-splay-tree #'%ptr-eql #'(lambda (x y) 34 (< (the (unsigned-byte 32) 35 (%ptr-to-int x)) 36 (the (unsigned-byte 32) 37 (%ptr-to-int Y)))))) 38 (objc-metaclass-map (make-splay-tree #'%ptr-eql #'(lambda (x y) 39 (< (the (unsigned-byte 32) 40 (%ptr-to-int x)) 41 (the (unsigned-byte 32) 42 (%ptr-to-int Y)))))) 43 (objc-class-lock (make-lock)) 44 (next-objc-class-id 0) 45 (class-table-size 1024) 46 (c (make-array 1024)) 47 (m (make-array 1024)) 48 (cw (make-array 1024)) 49 (mw (make-array 1024)) 50 (csv (make-array 1024)) 51 (msv (make-array 1024))) 52 53 (flet ((assign-next-class-id () 54 (let* ((id next-objc-class-id)) 55 (if (= (incf next-objc-class-id) class-table-size) 56 (let* ((old-size class-table-size) 57 (new-size (* 2 class-table-size))) 58 (declare (fixnum old-size new-size)) 59 (macrolet ((extend (v) 60 `(setq ,v (%extend-vector old-size ,v new-size)))) 61 (extend c) 62 (extend m) 63 (extend cw) 64 (extend mw) 65 (extend csv) 66 (extend msv)) 67 (setq class-table-size new-size))) 68 id))) 69 (defun id->objc-class (i) 70 (svref c i)) 71 (defun (setf id->objc-class) (new i) 72 (setf (svref c i) new)) 73 (defun id->objc-metaclass (i) 74 (svref m i)) 75 (defun (setf id->objc-metaclass) (new i) 76 (setf (svref m i) new)) 77 (defun id->objc-class-wrapper (i) 78 (svref cw i)) 79 (defun (setf id->objc-class-wrapper) (new i) 80 (setf (svref cw i) new)) 81 (defun id->objc-metaclass-wrapper (i) 82 (svref mw i)) 83 (defun (setf id->objc-metaclass-wrapper) (new i) 84 (setf (svref mw i) new)) 85 (defun id->objc-class-slots-vector (i) 86 (svref csv i)) 87 (defun (setf id->objc-class-slots-vector) (new i) 88 (setf (svref csv i) new)) 89 (defun id->metaclass-slot-vector (i) 90 (svref msv i)) 91 (defun (setf id->metaclass-slot-vector) (new i) 92 (setf (svref msv i) new)) 93 94 (defun %clear-objc-class-maps () 95 (with-lock-grabbed (objc-class-lock) 96 (fill c 0) 97 (fill m 0) 98 (fill cw 0) 99 (fill mw 0) 100 (fill csv 0) 101 (fill msv 0) 102 (setf (splay-tree-root objc-class-map) nil 103 (splay-tree-root objc-metaclass-map) nil 104 next-objc-class-id 0))) 105 (defun map-objc-class (class) 106 "ensure that the class (and metaclass) are mapped to a small integer" 107 (with-lock-grabbed (objc-class-lock) 108 (or (splay-tree-get objc-class-map class) 109 (let* ((id (assign-next-class-id)) 110 (class (%inc-ptr class 0)) 111 (meta (pref class :objc_class.class_pointer))) 112 (ensure-objc-classptr-resolved class) 113 (splay-tree-put objc-class-map class id) 114 (splay-tree-put objc-metaclass-map meta id) 115 (setf (svref c id) class 116 (svref m id) meta) 117 id)))) 118 (defun objc-class-id (class) 119 (with-lock-grabbed (objc-class-lock) 120 (splay-tree-get objc-class-map class))) 121 (defun objc-metaclass-id (meta) 122 (with-lock-grabbed (objc-class-lock) 123 (splay-tree-get objc-metaclass-map meta))) 124 (defun objc-class-map () objc-class-map) 125 (defun objc-metaclass-map () objc-metaclass-map))) 126 127 128 129 (defparameter *gnustep-system-root* "/usr/GNUstep/" "The root of all evil.") 130 (defparameter *gnustep-libraries-pathname* 131 (merge-pathnames "System/Library/Libraries/" *gnustep-system-root*)) 132 133 (defloadvar *pending-loaded-classes* ()) 31 134 32 135 (defcallback register-class-callback (:address class :address category :void) 33 (let* ((class (%inc-ptr class 0)) ; make a heap-allocated copy 34 (cell (or (assoc class *pending-loaded-classes*) 35 (let* ((c (list class))) 36 (push c *pending-loaded-classes*) 37 c)))) 38 ; (format t "~&~s: " (%get-cstring (pref class :objc_class.name))) 136 (let* ((id (map-objc-class class))) 39 137 (unless (%null-ptr-p category) 40 (push (%inc-ptr category 0) (cdr cell)) 41 ;(format t "~& ~s" (%get-cstring (pref category :objc_category.category_name))) 42 ))) 43 44 45 46 (def-ccl-pointers gnustep-framework () 138 (let* ((cell (or (assoc id *pending-loaded-classes*) 139 (let* ((c (list id))) 140 (push c *pending-loaded-classes*) 141 c)))) 142 (push (%inc-ptr category 0) (cdr cell)))))) 143 144 145 (defun init-gnustep-framework () 47 146 (or (getenv "GNUSTEP_SYSTEM_ROOT") 48 147 (setenv "GNUSTEP_SYSTEM_ROOT" *gnustep-system-root*)) … … 50 149 (setf (%get-ptr (foreign-symbol-address "_objc_load_callback")) 51 150 register-class-callback) 52 (open-shared-library "/usr/GNUstep/System/Library/Libraries/libgnustep-base.so") 53 (open-shared-library "/usr/GNUstep/System/Library/Libraries/libgnustep-gui.so") 54 ) 55 56 (defvar *objc-readtable* (copy-readtable nil)) 57 58 (eval-when (:compile-toplevel :load-toplevel :execute) 59 (set-syntax-from-char #\] #\) *objc-readtable*)) 60 61 ;;; We use the convention that [:super ....] denotes a send to the 62 ;;; defining object's superclass's method, and that a return value 63 ;;; specification of the form (:-> ... x) indicates a message send 64 ;;; that returns a structure (by reference) via the pointer x. 65 66 (set-macro-character 67 #\[ 68 (nfunction 69 |objc-[-reader| 70 (lambda (stream ignore) 71 (declare (ignore ignore)) 72 (let* ((tail (read-delimited-list #\] stream)) 73 (structptr nil)) 74 (let* ((return (car (last tail)))) 75 (when (and (consp return) (eq (car return) :->)) 76 (rplaca (last tail) :void) 77 (setq structptr (car (last return))))) 78 (if (eq (car tail) :super) 79 (if structptr 80 `(objc-message-send-super-stret ,structptr super ,@(cdr tail)) 81 `(objc-message-send-super super ,@(cdr tail))) 82 (if structptr 83 `(objc-message-send-stret ,structptr ,@tail) 84 `(objc-message-send ,@tail)))))) 85 nil 86 *objc-readtable*) 87 88 (eval-when (:compile-toplevel :execute) 89 (setq *readtable* *objc-readtable*)) 151 (open-shared-library (namestring (merge-pathnames "libgnustep-base.so" 152 *gnustep-libraries-pathname*))) 153 (open-shared-library (namestring (merge-pathnames "libgnustep-gui.so" 154 *gnustep-libraries-pathname*)))) 155 156 (def-ccl-pointers gnustep-framework () 157 (init-gnustep-framework)) 158 159 90 160 91 161 ;;; The global reference to the "NSConstantString" class allows us to … … 96 166 (defloadvar *NSConstantString-class* 97 167 (with-cstrs ((name "NSConstantString")) 98 (#_objc_ get_class name)))168 (#_objc_lookup_class name))) 99 169 100 170 ;;; An instance of NSConstantString (which is a subclass of NSString) … … 110 180 ;;; *NSConstantString-class*, CSTRING and LEN). 111 181 (defmacro with-nsstr ((nsstr cstring len) &body body) 112 `(rlet ((,nsstr :<N SC>onstant<S>tring182 `(rlet ((,nsstr :<NXC>onstant<S>tring 113 183 :isa *NSConstantString-class* 114 : nxcsptr,cstring115 : nxcslen ,len))184 :c_string ,cstring 185 :len ,len)) 116 186 ,@body)) 117 187 118 188 ;;; Make a persistent (heap-allocated) NSConstantString. 119 189 (defun %make-nsstring (string) 120 (make-record :<N SC>onstant<S>tring190 (make-record :<NXC>onstant<S>tring 121 191 :isa *NSConstantString-Class* 122 : nxcsptr(make-cstring string)123 : nxcslen (length string)))192 :c_string (make-cstring string) 193 :len (length string))) 124 194 125 195 … … 159 229 (let* ((string (read stream))) 160 230 (check-type string string) 161 `(@ ,string)))) 162 *objc-readtable*) 231 `(@ ,string))))) 163 232 164 233 165 234 166 235 ;;; Registering named objc classes. 236 237 (defun objc-class-name-string (name) 238 (etypecase name 239 (symbol (lisp-to-objc-classname name)) 240 (string name))) 167 241 168 242 ;;; We'd presumably cache this result somewhere, so we'd only do the … … 210 284 211 285 (defmacro @class (name) 212 `(%objc-class-classptr ,(objc-class-descriptor name))) 286 (let* ((name (objc-class-name-string name))) 287 `(the (@metaclass ,name) (%objc-class-classptr ,(objc-class-descriptor name))))) 288 213 289 214 290 ;;; This isn't quite the inverse operation of LOOKUP-OBJC-CLASS: it … … 216 292 ;;; instance (returning the class name.) 217 293 (defun objc-class-name (object) 218 (with-macptrs (p) 219 (%setf-macptr p (#_object_getClassName object)) 220 (unless (%null-ptr-p p) 221 (%get-cstring p)))) 294 (unless (%null-ptr-p object) 295 (with-macptrs ((parent (pref object :objc_object.class_pointer))) 296 (unless (%null-ptr-p parent) 297 (if (logtest (pref parent :objc_class.info) #$_CLS_CLASS) 298 (%get-cstring (pref parent :objc_class.name)) 299 (%get-cstring (pref object :objc_class.name))))))) 222 300 223 301 … … 228 306 (defun get-selector-for (method-name &optional error) 229 307 (with-cstrs ((method-name method-name)) 230 (let* ((p (#_sel_get_ uid method-name)))308 (let* ((p (#_sel_get_any_uid method-name))) 231 309 (if (%null-ptr-p p) 232 310 (if error … … 265 343 `(load-objc-selector ,(objc-selector-name s))) 266 344 267 ;;; #_objc_msgSend takes two required arguments (the receiving object 268 ;;; and the method selector) and 0 or more additional arguments; 269 ;;; there'd have to be some macrology to handle common cases, since we 270 ;;; want the compiler to see all of the args in a foreign call. 345 271 346 272 347 (defmacro objc-message-send (receiver selector-name &rest argspecs) … … 407 482 (foreign-double-float-type "d") 408 483 (foreign-single-float-type "f") 409 63.121.41.174(foreign-integer-type484 (foreign-integer-type 410 485 (let* ((signed (foreign-integer-type-signed type)) 411 486 (bits (foreign-integer-type-bits type))) … … 564 639 565 640 (defun find-class-ivar-offset (classname ivar-string) 566 (let* ((class (lookup-objc-class classname t))) 567 (with-cstrs ((s ivar-string)) 568 (with-macptrs ((ivar)) 569 (%setf-macptr ivar (#_class_getInstanceVariable class s)) 570 (if (%null-ptr-p ivar) 571 (error "Unknown instance variable ~s in class ~s" 572 ivar-string classname) 573 (pref ivar :objc_ivar.ivar_offset)))))) 641 (with-cstrs ((s ivar-string)) 642 (do* ((class (lookup-objc-class classname t) 643 (pref class :objc_class.super_class))) 644 ((%null-ptr-p class) 645 (error "Unknown instance variable ~s in class ~s" 646 ivar-string classname)) 647 (let* ((offset (with-macptrs ((ivars (pref class :objc_class.ivars))) 648 (unless (%null-ptr-p ivars) 649 (do* ((i 0 (1+ i)) 650 (n (pref ivars :objc_ivar_list.ivar_count)) 651 (ivar (pref ivars :objc_ivar_list.ivar_list) 652 (%inc-ptr ivar (record-length :objc_ivar)))) 653 ((= i n)) 654 (with-macptrs ((name (pref ivar :objc_ivar.ivar_name))) 655 (unless (%null-ptr-p name) 656 (if (eql 0 (#_strcmp name s)) 657 (return (pref ivar :objc_ivar.ivar_offset)))))))))) 658 (when offset (return offset)))))) 659 574 660 575 661 (defun ivar-offset (info) … … 693 779 (objc-class-info-superclassname info) 694 780 (objc-class-info-ivars info)))) 695 ( #_objc_addClass class)781 (external-call "__objc_add_class_to_hash" :address class :void) 696 782 (%objc-class-classptr descriptor))))) 697 783 … … 719 805 ;;; This is intended (mostly) for debugging (e.g., to support inspecting/ 720 806 ;;; describing ObjC objects.) 807 808 721 809 722 810 (defloadvar *all-objc-classes* (%null-ptr))
Note:
See TracChangeset
for help on using the changeset viewer.
