Changeset 433
- Timestamp:
- Jan 30, 2004, 11:57:23 AM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/examples/objc-runtime.lisp (modified) (25 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/objc-runtime.lisp
r380 r433 66 66 (external-call "__objc_resolve_class_links" :void))) 67 67 68 69 70 ; (let* ((metaclass-name (intern (concatenate 'string "+" (string class-name)) (symbol-package class-name))) 68 71 69 72 … … 85 88 (c (make-array 1024)) 86 89 (m (make-array 1024)) 87 (cw (make-array 1024 ))88 (mw (make-array 1024 ))90 (cw (make-array 1024 :initial-element nil)) 91 (mw (make-array 1024 :initial-element nil)) 89 92 (csv (make-array 1024)) 90 93 (msv (make-array 1024))) … … 144 147 (splay-tree-count objc-metaclass-map) 0 145 148 next-objc-class-id 0))) 146 (defun map-objc-class (class &optional (name nil name-p)) 147 "ensure that the class (and metaclass) are mapped to a small integer" 149 150 (defun register-objc-class (class) 151 "ensure that the class (and metaclass) are mapped to a small integer, 152 and that each have slots-vectors associated with them." 148 153 (with-lock-grabbed (objc-class-lock) 149 (labels ((ensure-mapped-class (class &optional 150 (class-name 151 (objc-to-lisp-classname 152 (%get-cstring 153 (pref class :objc_class.name)) 154 "NS") 155 class-name-p)) 156 (ensure-objc-classptr-resolved class) 157 (with-macptrs ((super (pref class :objc_class.super_class))) 158 (unless (%null-ptr-p super) 159 (ensure-mapped-class super))) 160 (or (splay-tree-get objc-class-map class) 161 (let* ((id (assign-next-class-id)) 162 (class (%inc-ptr class 0)) 163 (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer))) 164 (splay-tree-put objc-class-map class id) 165 (splay-tree-put objc-metaclass-map meta id) 166 (setf (svref c id) class 167 (svref m id) meta) 168 (let* ((metaclass-name (intern (concatenate 'string "+" (string class-name)) (symbol-package class-name))) 169 (class-wrapper (%cons-wrapper class)) 170 (meta-wrapper (%cons-wrapper meta)) 171 (class-slot-vector 172 (initialize-objc-class-slots class 173 class-name 174 class-wrapper 175 (not class-name-p))) 176 (meta-slot-vector 177 (initialize-objc-metaclass-slots 178 meta 179 metaclass-name 180 meta-wrapper 181 (not class-name-p) 182 class))) 183 (setf (svref cw id) class-wrapper 184 (svref mw id) meta-wrapper 185 (svref csv id) class-slot-vector 186 (svref msv id) meta-slot-vector 187 (find-class class-name) class 188 (find-class metaclass-name) meta) 189 ) 190 id)))) 191 (if name-p 192 (ensure-mapped-class class name) 193 (ensure-mapped-class class))))) 154 (ensure-objc-classptr-resolved class) 155 (or (splay-tree-get objc-class-map class) 156 (let* ((id (assign-next-class-id)) 157 (class (%inc-ptr class 0)) 158 (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer))) 159 (splay-tree-put objc-class-map class id) 160 (splay-tree-put objc-metaclass-map meta id) 161 (setf (svref c id) class 162 (svref m id) meta 163 (svref csv id) 164 (make-objc-class-slots-vector class) 165 (svref msv id) 166 (make-objc-metaclass-slots-vector meta)) 167 id)))) 194 168 (defun objc-class-id (class) 195 169 (with-lock-grabbed (objc-class-lock) … … 208 182 (funcall f (id->objc-class id))))) 209 183 210 211 184 (defun canonicalize-registered-class (c) 185 (let* ((id (objc-class-id c))) 186 (if id 187 (id->objc-class id) 188 (error "Class ~S isn't recognized." c)))) 189 190 (defun canonicalize-registered-metaclass (m) 191 (let* ((id (objc-metaclass-id m))) 192 (if id 193 (id->objc-metaclass id) 194 (error "Class ~S isn't recognized." m)))) 195 196 197 ;;; Open shared libs. 212 198 #+darwinppc-target 213 199 (progn … … 225 211 (wait-on-semaphore done) 226 212 (car success))) 227 228 229 213 230 214 … … 251 235 (pushnew 'remap-all-library-classes *lisp-system-pointer-functions*) 252 236 253 254 255 ) ;#+darwinppc-target 237 ) 256 238 257 239 #+gnu-objc 258 240 (progn 259 260 261 241 (defparameter *gnustep-system-root* "/usr/GNUstep/" "The root of all evil.") 262 242 (defparameter *gnustep-libraries-pathname* … … 305 285 306 286 287 (defun install-foreign-objc-class (class) 288 (let* ((id (objc-class-id class))) 289 (unless id 290 (setq id (register-objc-class class) 291 class (id->objc-class id)) 292 ;; If not mapped, map the superclass (if there is one.) 293 (let* ((super (pref class :objc_class.super_class))) 294 (unless (%null-ptr-p super) 295 (install-foreign-objc-class super)) 296 (let* ((class-name 297 (objc-to-lisp-classname (%get-cstring 298 (pref class :objc_class.name)) 299 "NS")) 300 (meta (id->objc-metaclass id)) 301 (meta-name (intern (concatenate 'string 302 "+" 303 (string class-name)) 304 "NS")) 305 (meta-super (pref meta :objc_class.super_class))) 306 ;; It's important (here and when initializing the class 307 ;; below) to use the "canonical" (registered) version 308 ;; of the class, since some things in CLOS assume 309 ;; EQness. We probably don't want to violate that 310 ;; assumption; it'll be easier to revive a saved image 311 ;; if we don't have a lot of EQL-but-not-EQ class pointers 312 ;; to deal with. 313 (initialize-instance meta 314 :name meta-name 315 :direct-superclasses 316 (list 317 (if (or (%null-ptr-p meta-super) 318 (not (%objc-metaclass-p meta-super))) 319 (find-class 'objc:objc-class) 320 (canonicalize-registered-metaclass meta-super))) 321 :peer class 322 :foreign t) 323 (setf (find-class meta-name) meta) 324 ; (setf (id->objc-metaclass-wrapper id) (%class-own-wrapper meta)) 325 (setf (slot-value class 'direct-slots) 326 (%compute-foreign-direct-slots class)) 327 (initialize-instance class 328 :name class-name 329 :direct-superclasses 330 (list 331 (if (%null-ptr-p super) 332 (find-class 'objc:objc-object) 333 (canonicalize-registered-class super))) 334 :peer meta 335 :foreign t) 336 ; (setf (id->objc-class-wrapper id) (%class-own-wrapper class)) 337 (setf (find-class class-name) class)))))) 338 307 339 308 340 ;;; An instance of NSConstantString (which is a subclass of NSString) … … 325 357 (#_objc_lookup_class name))) 326 358 327 328 359 ;;; Execute the body with the variable NSSTR bound to a 329 360 ;;; stack-allocated NSConstantString instance (made from … … 415 446 (defun lookup-objc-class (name &optional error-p) 416 447 (with-cstrs ((cstr (objc-class-name-string name))) 417 (let* ((p (#+apple-objc #_objc_lookUpClass #+gnu-objc418 448 (let* ((p (#+apple-objc #_objc_lookUpClass 449 #+gnu-objc #_objc_lookup_class 419 450 cstr))) 420 451 (if (%null-ptr-p p) … … 673 704 (defvar *objc-char-type* (parse-foreign-type :char)) 674 705 675 (defun accessor-for-type-char (c) 676 (case c 677 ((#\@ @\: #\^ #\#) '%get-ptr) 678 (#\c '%get-signed-byte) 679 (#\C '%get-unsigned-byte) 680 (#\s '%get-signed-word) 681 (#\S '%get-unsigned-word) 682 ((#\i #\l) '%get-signed-long) 683 ((#\I #\L) '%get-unsigned-long) 684 (#\q '%%get-signed-longlong) 685 (#\Q '%%get-unsigned-longlong) 686 (#\f '%get-single-float) 687 (#\d '%get-double-float) 688 ((#\{ #\( #\[) '%inc-ptr))) 689 690 (defun encode-objc-arg-type (type) 706 (defun encode-objc-type (type &optional for-ivar) 691 707 (if (or (eq type *objc-id-type*) 692 708 (foreign-type-= type *objc-id-type*)) … … 703 719 (foreign-type-= target *objc-char-type*)) 704 720 "*" 705 (format nil "^~a" (encode-objc- arg-type target)))))721 (format nil "^~a" (encode-objc-type target))))) 706 722 (foreign-double-float-type "d") 707 723 (foreign-single-float-type "f") … … 709 725 (let* ((signed (foreign-integer-type-signed type)) 710 726 (bits (foreign-integer-type-bits type))) 711 (cond ((= bits 8) 712 (if signed "c" "C")) 713 ((= bits 16) 714 (if signed "s" "S")) 715 ((= bits 32) 716 ;; Should be some way of noting "longness". 717 (if signed "i" "I")) 718 ((= bits 64) 719 (if signed "q" "Q"))))) 727 (if (eq (foreign-integer-type-alignment type) 1) 728 (format nil "b~d" bits) 729 (cond ((= bits 8) 730 (if signed "c" "C")) 731 ((= bits 16) 732 (if signed "s" "S")) 733 ((= bits 32) 734 ;; Should be some way of noting "longness". 735 (if signed "i" "I")) 736 ((= bits 64) 737 (if signed "q" "Q")))))) 720 738 (foreign-record-type 721 739 (ensure-foreign-type-bits type) … … 725 743 (fields (foreign-record-type-fields type))) 726 744 (with-output-to-string (s) 727 (format s "~c~a=" (if (eq kind :struct) #\{ #\() name) 728 (dolist (f fields (format s "~a" (if (eq kind :struct) #\} #\)))) 729 (format s "~a" (encode-objc-arg-type 730 (foreign-record-field-type f))))))) 745 (format s "~c~a=" (if (eq kind :struct) #\{ #\() name) 746 (dolist (f fields (format s "~a" (if (eq kind :struct) #\} #\)))) 747 (when for-ivar 748 (format s "\"~a\"" 749 (unescape-foreign-name 750 (or (foreign-record-field-name f) ""))) 751 (format s "~a" (encode-objc-type 752 (foreign-record-field-type f)))))))) 731 753 (foreign-array-type 732 754 (ensure-foreign-type-bits type) … … 735 757 (if dims (format nil "[~d~a]" 736 758 (car dims) 737 (encode-objc- arg-type element-type))759 (encode-objc-type element-type)) 738 760 (if (or (eq element-type *objc-char-type*) 739 761 (foreign-type-= element-type *objc-char-type*)) 740 762 "*" 741 (format nil "^~a" (encode-objc- arg-type element-type))))))763 (format nil "^~a" (encode-objc-type element-type)))))) 742 764 (t (break "type = ~s" type))))))) 743 765 … … 785 807 (incf gprs-used (ceiling bits 32)))) 786 808 (t (break "argspec = ~s, arg = ~s" argspec arg))) 787 (push (list (encode-objc- arg-type arg) offset size) result))))))))809 (push (list (encode-objc-type arg) offset size) result)))))))) 788 810 (declare (fixnum gprs-used fprs-used)) 789 811 (let* ((max-parm-end … … 792 814 objc-forwarding-stack-offset))) 793 815 (format nil "~a~d~:{~a~d~}" 794 (encode-objc- arg-type816 (encode-objc-type 795 817 (parse-foreign-type result-spec)) 796 818 max-parm-end … … 869 891 :protocols (%null-ptr))) 870 892 871 (defstruct objc-class-info 872 classname 873 superclassname 874 ivars 875 objc-class) 876 877 (defvar *lisp-objc-classes* (make-hash-table :test #'equal)) 878 879 (defstruct ivar-info 880 classname 881 name ;symbol 882 string 883 type-encoding 884 foreign-type 885 accessor 886 %offset) 887 888 (defun lookup-ivar-info (ivar-name classname) 889 (let* ((class-info (or (gethash classname *lisp-objc-classes*) 890 (error "Unknown objc class : ~s" classname)))) 891 (or (find ivar-name (objc-class-info-ivars class-info) :key #'ivar-info-name) 892 (error "Unknown instance variable ~s in class ~s" ivar-name classname)))) 893 894 (defun %class-find-ivar-offset (class ivar-string) 895 #+apple-objc 896 (with-cstrs ((s ivar-string)) 897 (with-macptrs ((ivar)) 898 (%setf-macptr ivar (#_class_getInstanceVariable class s)) 899 (unless (%null-ptr-p ivar) 900 (pref ivar :objc_ivar.ivar_offset)))) 901 #+gnu-objc 902 (with-cstrs ((s ivar-string)) 903 (do* ((class class (pref class :objc_class.super_class))) 904 ((%null-ptr-p class)) 905 (let* ((offset (with-macptrs ((ivars (pref class :objc_class.ivars))) 906 (unless (%null-ptr-p ivars) 907 (do* ((i 0 (1+ i)) 908 (n (pref ivars :objc_ivar_list.ivar_count)) 909 (ivar (pref ivars :objc_ivar_list.ivar_list) 910 (%inc-ptr ivar (record-length :objc_ivar)))) 911 ((= i n)) 912 (with-macptrs ((name (pref ivar :objc_ivar.ivar_name))) 913 (unless (%null-ptr-p name) 914 (if (eql 0 (#_strcmp name s)) 915 (return (pref ivar :objc_ivar.ivar_offset)))))))))) 916 (when offset (return offset)))))) 917 918 (defun find-class-ivar-offset (classname ivar-string) 919 (or 920 (%class-find-ivar-offset (lookup-objc-class classname t) ivar-string) 921 (error "Unknown instance variable ~s in class ~s" ivar-string classname))) 922 923 924 (defun ivar-offset (info) 925 (or (ivar-info-%offset info) 926 (setf (ivar-info-%offset info) 927 (find-class-ivar-offset (ivar-info-classname info) 928 (ivar-info-string info))))) 929 930 (defmethod make-load-form ((ivar ivar-info) &optional env) 931 (declare (ignore env)) 932 `(lookup-ivar-info ',(ivar-info-name ivar) ',(ivar-info-classname ivar))) 933 934 935 (defun %encode-objc-ivar-type (spec) 936 (let* ((type (parse-foreign-type spec)) 937 (encoding (encode-objc-arg-type type))) 938 (values encoding type (accessor-for-type-char (schar encoding 0))))) 939 940 941 (defun spec-to-name-string-type (spec) 942 (if (atom spec) 943 (values spec (string-downcase spec) :id) 944 (if (atom (car spec)) 945 (values (car spec) (string-downcase (car spec)) (or (cadr spec) :id)) 946 (values (caar spec) (cadar spec) (or (cadr spec) :id))))) 947 948 (defun %make-objc-ivars (info-list start-offset) 949 (declare (list info-list) (fixnum start-offset)) 950 (if (null info-list) 951 (values (%null-ptr) start-offset) 952 (let* ((n (length info-list)) 953 (offset start-offset) 954 (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size 955 :objc_ivar :bytes)))))) 956 (setf (pref ivars :objc_ivar_list.ivar_count) n) 957 (do* ((l info-list (cdr l)) 958 (info (car l) (car l)) 959 (ivar (pref ivars :objc_ivar_list.ivar_list) 960 (%inc-ptr ivar (%foreign-type-or-record-size 961 :objc_ivar :bytes)))) 962 ((null l) (values ivars (align-offset offset 4))) 963 (let* ((string (ivar-info-string info)) 964 (type (ivar-info-foreign-type info)) 965 (alignment-bits (or (progn (ensure-foreign-type-bits type) 966 (foreign-type-alignment type)) 967 8)) 968 (alignment-bytes (ceiling alignment-bits 8)) 969 (encoding (ivar-info-type-encoding info))) 970 (setq offset (align-offset offset alignment-bytes)) 971 (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string) 972 (pref ivar :objc_ivar.ivar_type) (make-cstring encoding) 973 (pref ivar :objc_ivar.ivar_offset) offset 974 offset (+ offset (ceiling (foreign-type-bits type) 8)))))))) 975 976 (defun ivar-info-from-spec (classname spec) 977 (multiple-value-bind (name string typespec) 978 (spec-to-name-string-type spec) 979 (multiple-value-bind (type-encoding ftype accessor) 980 (%encode-objc-ivar-type typespec) 981 (declare (ignore ignore)) 982 (make-ivar-info :classname classname 983 :name name 984 :string string 985 :type-encoding type-encoding 986 :accessor accessor 987 :foreign-type ftype 988 :%offset nil)))) 989 990 ;;; If class info exists, re-use it (and whine if it doesn't match what 991 ;;; would be freshly generated.) We can't really redefine objc classes 992 ;;; at runtime. 993 (defun note-objc-class (classname superclassname specs) 994 (let* ((ivars (mapcar #'(lambda (spec) (ivar-info-from-spec classname spec)) specs)) 995 (class-info (gethash classname *lisp-objc-classes*))) 996 (if (not class-info) 997 (setf (gethash classname *lisp-objc-classes*) 998 (make-objc-class-info :classname classname 999 :superclassname superclassname 1000 :ivars ivars 1001 :objc-class (load-objc-class-descriptor classname))) 1002 (let* ((changed nil) 1003 (existing-ivars (objc-class-info-ivars class-info))) 1004 (unless (equal superclassname (objc-class-info-superclassname class-info)) 1005 (setf (objc-class-info-superclassname class-info) superclassname 1006 changed t)) 1007 (unless (do* ((ivars ivars (cdr ivars)) 1008 (existing existing-ivars (cdr existing)) 1009 (new (car ivars) (car ivars)) 1010 (old (car existing) (car existing))) 1011 ((null ivars) (null existing)) 1012 (unless (and (eq (ivar-info-name old) (ivar-info-name new)) 1013 (equal 1014 (ivar-info-type-encoding old) 1015 (ivar-info-type-encoding new)) 1016 (eq (ivar-info-accessor old) 1017 (ivar-info-accessor new))) 1018 (setf (ivar-info-name old) (ivar-info-name new) 1019 (ivar-info-type-encoding old) (ivar-info-type-encoding new) 1020 (ivar-info-accessor old) (ivar-info-accessor new)) 1021 (return nil)))) 1022 (when changed 1023 (warn "Definition of class ~s has changed. Recompile subclasses and~ 1024 client methods" classname)) 1025 class-info)))) 893 (defun superclass-instance-size (class) 894 (with-macptrs ((super (pref class :objc_class.super_class))) 895 (if (%null-ptr-p super) 896 0 897 (pref super :objc_class.instance_size)))) 898 1026 899 1027 (defun %make-objc-class (name superclass-name instance-vars) 1028 (let* ((nameptr (make-cstring name)) 1029 (superptr (%objc-class-classptr 1030 (load-objc-class-descriptor superclass-name))) 1031 (metaclass (%make-basic-meta-class nameptr superptr (@class "NSObject")))) 1032 (multiple-value-bind (ivars instance-size) 1033 (%make-objc-ivars instance-vars (pref superptr :objc_class.instance_size)) 1034 1035 (%make-class-object metaclass superptr nameptr ivars instance-size)))) 900 1036 901 1037 902 #+gnu-objc … … 1054 919 #+gnu-objc #$_CLS_META)) 1055 920 1056 (defun %add-objc-class (class) 921 922 923 924 925 ;;; Create (malloc) class and metaclass objects with the specified 926 ;;; name (string) and superclass name. Initialize the metaclass 927 ;;; instance, but don't install the class in the ObjC runtime system 928 ;;; (yet): we don't know anything about its ivars and don't know 929 ;;; how big instances will be yet. 930 ;;; If an ObjC class with this name already exists, we're very 931 ;;; confused; check for that case and error out if it occurs. 932 (defun %allocate-objc-class (name superptr) 933 (let* ((class-name (compute-objc-classname name))) 934 (if (lookup-objc-class class-name nil) 935 (error "An Objective C class with name ~s already exists." class-name)) 936 (let* ((nameptr (make-cstring class-name)) 937 (id (register-objc-class 938 (%make-class-object 939 (%make-basic-meta-class nameptr superptr (@class "NSObject")) 940 superptr 941 nameptr 942 (%null-ptr) 943 0))) 944 (meta (id->objc-metaclass id)) 945 (class (id->objc-class id)) 946 (meta-name (intern (format nil "+~a" class-name) 947 (symbol-package name))) 948 (meta-super (canonicalize-registered-metaclass 949 (pref meta :objc_class.super_class)))) 950 (initialize-instance meta 951 :name meta-name 952 :direct-superclasses (list meta-super)) 953 (setf ;(id->objc-metaclass-wrapper id) (%class-own-wrapper meta) 954 (find-class meta-name) meta) 955 class))) 956 957 ;;; Set up the class's ivar_list and instance_size fields, then 958 ;;; add the class to the ObjC runtime. 959 (defun %add-objc-class (class ivars instance-size) 960 (setf 961 (pref class :objc_class.ivars) ivars 962 (pref class :objc_class.instance_size) instance-size) 1057 963 #+apple-objc 1058 964 (#_objc_addClass class) … … 1080 986 (pref class :objc_class.info) (logior #$_CLS_RESOLV (pref class :objc_class.info))) 1081 987 (#___objc_exec_class m))) 1082 1083 (defun %define-objc-class (info) 1084 (let* ((descriptor (objc-class-info-objc-class info))) 1085 (or (%objc-class-classptr descriptor nil) 1086 (let* ((class (%make-objc-class (objc-class-info-classname info) 1087 (objc-class-info-superclassname info) 1088 (objc-class-info-ivars info)))) 1089 (%add-objc-class class) 1090 (map-objc-class class (objc-to-lisp-classname (objc-class-info-classname info))) 1091 (%objc-class-classptr descriptor))))) 1092 1093 (defun ensure-lisp-objc-class-defined (classname 1094 &optional (info 1095 (gethash classname 1096 *lisp-objc-classes*))) 1097 (when info 1098 (ensure-lisp-objc-class-defined (objc-class-info-superclassname info)) 1099 (%define-objc-class info))) 1100 1101 (def-ccl-pointers define-lisp-objc-classes () 1102 (maphash #'(lambda (classname info) 1103 (ensure-lisp-objc-class-defined classname info)) 1104 *lisp-objc-classes*)) 1105 1106 1107 (defmacro def-objc-class (class-name superclass-name &rest instance-vars) 1108 (let* ((class-name (objc-class-name-string class-name)) 1109 (superclass-name (objc-class-name-string superclass-name))) 1110 `(progn 1111 (eval-when (:compile-toplevel) 1112 (note-objc-class ,class-name ,superclass-name ',instance-vars)) 1113 (eval-when (:load-toplevel :execute) 1114 (%define-objc-class (note-objc-class ,class-name ,superclass-name ',instance-vars)))))) 988 1115 989 1116 990 … … 1167 1041 #+gnu-objc 1168 1042 (with-macptrs ((parent (pref p objc_object.class_pointer))) 1169 (objc-class-id-parent)) )1043 (objc-class-id-parent)) 1170 1044 1171 1045 ;;; If an instance, return (values :INSTANCE <class>). … … 1297 1171 impname) 1298 1172 1299 (defmacro ivar-ref (classname instance ivar-name) 1300 (let* ((info (lookup-ivar-info ivar-name classname))) 1301 `(,(ivar-info-accessor info) ,instance (ivar-offset ,info)))) 1302 1303 (defun objc-class-info-all-ivars (class-info) 1304 (append (let* ((super-info 1305 (gethash (objc-class-info-superclassname class-info) 1306 *lisp-objc-classes*))) 1307 (if super-info 1308 (objc-class-info-all-ivars super-info))) 1309 (objc-class-info-ivars class-info))) 1310 1311 (defmacro with-ivar-symbol-macros (classname instance &body body) 1312 (let* ((class-info (or (gethash classname *lisp-objc-classes*) 1313 (error "Unknown objective-C class name ~s" classname))) 1314 (ivars (objc-class-info-all-ivars class-info))) 1315 `(symbol-macrolet (,@(mapcar #'(lambda (ivar) 1316 `(,(ivar-info-name ivar) 1317 (,(ivar-info-accessor ivar) 1318 ,instance 1319 (ivar-offset (load-time-value ,ivar))))) 1320 ivars)) 1321 ,@body))) 1173 1174 1175 1322 1176 1323 1177 ;;; If any of the argspecs denote a value of type :<BOOL>, push an … … 1448 1302 (params `(:id ,self :<sel> ,_cmd ,@argspecs))) 1449 1303 `(progn 1450 (with-ivar-symbol-macros 1451 ,class-name ,self 1452 (defcallback ,impname 1304 (defcallback ,impname 1453 1305 (:without-interrupts nil 1454 1306 #+(and openmcl-native-threads apple-objc) :error-return … … 1475 1327 (make-general-send nil msg args s ,super ,class-name)) 1476 1328 (super () ,super)) 1477 ,@body)))) )1329 ,@body)))) 1478 1330 (%define-lisp-objc-method 1479 1331 ',impname … … 1504 1356 #+gnu-objc (#_method_get_number_of_arguments m)) 1505 1357 1506 1507 1508 1509 ;;; Getting & setting instance variables. 1510 1511 ;;; This works best if the value is a pointer of some sort. If it's 1512 ;;; hard to arrange that, lookup the instance variable's offset (see 1513 ;;; below) and use (SETF (CCL:%GET-??? ...) ...) directly. 1514 (defun set-objc-instance-variable (instance name value) 1515 (let* ((ivar-name (if (typep name 'string) 1516 name 1517 (unescape-foreign-name name)))) 1518 #+apple-objc 1519 (with-cstrs ((cname ivar-name)) 1520 (if (%null-ptr-p (#_object_setInstanceVariable instance cname value)) 1521 (error "Unknown instance varaiable ~s in ~s" name (objc-class-name instance))) 1522 value) 1523 #+gnu-objc 1524 (let* ((offset (%class-find-ivar-offset (pref instance :objc_object.class_pointer) ivar-name))) 1525 (if offset 1526 (setf (%get-ptr instance offset) value) 1527 (error "Unknown instance varaiable ~s in ~s" name (objc-class-name instance)))))) 1528 1529 ;;; This returns a pointer (conses). If you want to avoid either of 1530 ;;; those behaviors, lookup the instance variable's offset and use 1531 ;;; CCL::%GET-xxx directly. 1532 (defun get-objc-instance-variable (instance name) 1533 (let* ((ivar-name (if (typep name 'string) 1534 name 1535 (unescape-foreign-name name)))) 1536 #+apple-objc 1537 (with-cstrs ((cname ivar-name)) 1538 (rlet ((valptr (* t))) 1539 (if (%null-ptr-p (#_object_getInstanceVariable instance cname valptr)) 1540 (error "Unknown instance varaiable ~s in ~s" name (objc-class-name instance)) 1541 (%get-ptr valptr)))) 1542 #+gnu-objc 1543 (let* ((offset (%class-find-ivar-offset (pref instance :objc_object.class_pointer) ivar-name))) 1544 (if offset 1545 (%get-ptr instance offset) 1546 (error "Unknown instance varaiable ~s in ~s" name (objc-class-name instance)))))) 1547 1548 ;;; One might like something a little higher-level than what this offers, 1549 ;;; and one might like to do the lookup at macroexpand-time. The latter 1550 ;;; can only happen if the class is defined at macroexpand-time, which 1551 ;;; isn't generally guaranteed. If we're going to have to lookup the 1552 ;;; ivar's offset at runtime, we might as well keep things simple. 1553 (defun %ivar-offset (class varname) 1554 (or 1555 (%class-find-ivar-offset class (unescape-foreign-name varname)) 1556 (error "Unknown instance variable: ~s" varname))) 1358 #+apple-objc 1359 (progn 1360 (defcallback deallocate-nsobject (:address obj :void) 1361 (unless (%null-ptr-p obj) 1362 (remhash obj *objc-object-slot-vectors*) 1363 (setf (pref obj :objc_object.isa) 1364 (external-call "__objc_getFreedObjectClass" :address)) 1365 (free obj))) 1366 1367 (def-ccl-pointers install-deallocate-hook () 1368 (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject)) 1369 ) 1370 1557 1371 1558 1372 ;;; Return a typestring and offset as multiple values. … … 1633 1447 (error (ns-exception->lisp-condition (%inc-ptr exception 0)))))) 1634 1448 1635 #+apple-objc 1636 (progn 1637 (let* ((class-count 0)) 1638 (declare (fixnum class-count)) 1639 (defun reset-objc-class-count () (setq class-count 0)) 1640 (defun map-objc-classes () 1641 (let* ((n (#_objc_getClassList (%null-ptr) 0))) 1642 (declare (fixnum n)) 1643 (if (> n class-count) 1644 (%stack-block ((buffer (the fixnum (ash n ppc32::word-shift)))) 1645 (#_objc_getClassList buffer n) 1646 (do* ((i class-count (1+ i))) 1647 ((= i n (setq class-count i))) 1648 (declare (fixnum i)) 1649 (map-objc-class 1650 (%get-ptr buffer (the fixnum (ash i ppc32::word-shift)))))))))) 1651 (def-ccl-pointers revive-objc-classes () 1652 (reset-objc-class-count) 1653 (map-objc-classes))) 1654 1655 #+gnu-objc 1656 (defun iterate-over-class-methods (class method-function) 1657 (do* ((mlist (pref class :objc_class.methods) 1658 (pref mlist :objc_method_list.method_next))) 1659 ((%null-ptr-p mlist)) 1660 (do* ((n (pref mlist :objc_method_list.method_count)) 1661 (i 0 (1+ i)) 1662 (method (pref mlist :objc_method_list.method_list) 1663 (%incf-ptr method (record-length :objc_method)))) 1664 ((= i n)) 1665 (declare (fixnum i n)) 1666 (funcall method-function method class)))) 1667 1668 #+gnu-objc 1669 (progn 1670 (let* ((objc-class-count 0)) 1671 (defun reset-objc-class-count () (setq objc-class-count 0)) 1672 (defun note-all-library-methods (method-function) 1673 (do* ((i objc-class-count (1+ i)) 1674 (class (id->objc-class i) (id->objc-class i))) 1675 ((eq class 0)) 1676 (iterate-over-class-methods class method-function) 1677 (iterate-over-class-methods (id->objc-metaclass i) method-function)))) 1678 (def-ccl-pointers revive-objc-classes () 1679 (reset-objc-class-count))) 1680 1449
Note:
See TracChangeset
for help on using the changeset viewer.
