Changeset 185


Ignore:
Timestamp:
Jan 3, 2004, 11:48:01 AM (21 years ago)
Author:
Gary Byers
Message:

More gnu-objc conditionalization. Take user-specified class-name when
mapping objc-class. Make CLASS-OF objc-metaclasses be OBJC-METACLASS.

Location:
trunk/ccl/examples
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/examples/objc-clos.lisp

    r160 r185  
    2626  (:use))
    2727
     28
     29;;; Force all symbols interned in the NS package to be external
     30;;; symbols.
     31(package-force-export "NS")
     32
    2833(defconstant objc-type-flags (byte 3 20))
    2934(defconstant objc-type-index (byte 20 0))
    … …  
    3136(defconstant objc-flag-class 1)
    3237(defconstant objc-flag-metaclass 2)
     38
     39(defvar *objc-class-class*)
     40(defvar *objc-metaclass-class*)
    3341
    3442(defun recognize-objc-object (p)
    … …  
    5462      (#.objc-flag-instance (id->objc-class index))
    5563      (#.objc-flag-class (id->objc-metaclass index))
    56       (#.objc-flag-metaclass (id->objc-metaclass 0)))))
     64      (#.objc-flag-metaclass *objc-metaclass-class*))))
    5765
    5866 
    … …  
    7179      (#.objc-flag-instance (id->objc-class-wrapper index))
    7280      (#.objc-flag-class (id->objc-metaclass-wrapper index))
    73       (#.objc-flag-metaclass (id->objc-metaclass-wrapper 0)))))
     81      (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*)))))
    7482
    7583(defun %objc-domain-class-own-wrapper (p)
    … …  
    118126    ())
    119127
     128(setq *objc-metaclass-class* (find-class 'objc:objc-metaclass))
     129
    120130(defclass objc:objc-class (objc:objc-class-object)
    121131    ())
    … …  
    124134  nil)
    125135
    126 (defmethod objc-metaclass-p ((c objc:objc-class))
     136(defmethod objc-metaclass-p ((c objc:objc-class-object))
    127137  (%objc-metaclass-p c))
    128138
    … …  
    132142    (format stream "~s ~:[~;[MetaClass] ~]~s (#x~x)" 'objc:objc-class (objc-metaclass-p c) (class-name c) (%ptr-to-int c))))
    133143
    134 '(defmethod print-object ((c objc:objc-metaclass) stream)
     144(defmethod print-object ((c objc:objc-metaclass) stream)
    135145  (print-unreadable-object (c stream)
    136146    (format stream "~s ~s (#x~x)" 'objc:objc-metaclass (class-name c) (%ptr-to-int c))))
    … …  
    219229             peer
    220230             )))
     231

  • trunk/ccl/examples/objc-runtime.lisp

    r161 r185  
    1818(in-package "CCL")
    1919
    20 
    21 (defun show-uvector (u)
    22   (dotimes (i (uvsize u) (values))
    23     (format t "~&~d : ~s" i (uvref u i))
    24     (force-output)))
    2520
    2621;;; Utilities for interacting with the Apple/GNU Objective-C runtime
    … …  
    147142              (splay-tree-count objc-metaclass-map) 0
    148143              next-objc-class-id 0)))
    149     (defun map-objc-class (class &optional foreign)
     144    (defun map-objc-class (class &optional (class-name
     145                                            (objc-to-lisp-classname
     146                                             (%get-cstring
     147                                              (pref class :objc_class.name))
     148                                             "NS")
     149                                            class-name-p))
    150150      "ensure that the class (and metaclass) are mapped to a small integer"
    151151      (with-lock-grabbed (objc-class-lock)
    152152        (labels ((ensure-mapped-class (class)
     153                   (ensure-objc-classptr-resolved class)
    153154                   (with-macptrs ((super (pref class :objc_class.super_class)))
    154155                     (unless (%null-ptr-p super)
    … …  
    158159                              (class (%inc-ptr class 0))
    159160                              (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
    160                          (ensure-objc-classptr-resolved class)
    161161                         (splay-tree-put objc-class-map class id)
    162162                         (splay-tree-put objc-metaclass-map meta id)
    163163                         (setf (svref c id) class
    164164                               (svref m id) meta)
    165                          (let* ((class-name (objc-to-lisp-classname
    166                                              (%get-cstring
    167                                               (pref class :objc_class.name))
    168                                              "NS"))
    169                                 (metaclass-name (intern (concatenate 'string "+" (string class-name)) (symbol-package class-name)))
     165                         (let* ((metaclass-name (intern (concatenate 'string "+" (string class-name)) (symbol-package class-name)))
    170166                                (class-wrapper (%cons-wrapper class))
    171167                                (meta-wrapper (%cons-wrapper meta))
    … …  
    174170                                                              class-name
    175171                                                              class-wrapper
    176                                                               foreign))
     172                                                              (not class-name-p)))
    177173                                (meta-slot-vector
    178174                                 (initialize-objc-metaclass-slots
    … …  
    180176                                  metaclass-name
    181177                                  meta-wrapper
    182                                   foreign
     178                                  (not class-name-p)
    183179                                  class)))
    184                            (when (eq (find-package "NS")
    185                                      (symbol-package class-name))
    186                              (export class-name "NS")
    187                              (export metaclass-name "NS"))
    188180                         (setf (svref cw id) class-wrapper
    189181                               (svref mw id) meta-wrapper
    … …  
    276268        (push (%inc-ptr category 0) (cdr cell))))))
    277269
     270;;; Shouldn't really be GNU-objc-specific.
     271
     272(defun get-c-format-string (c-format-ptr c-arg-ptr)
     273  (do* ((n 128))
     274       ()
     275    (declare (fixnum n))
     276    (%stack-block ((buf n))
     277      (let* ((m (#_vsnprintf buf n c-format-ptr c-arg-ptr)))
     278        (declare (fixnum m))
     279        (cond ((< m 0) (return nil))
     280              ((< m n) (return (%get-cstring buf)))
     281              (t (setq n m)))))))
     282
     283
    278284
    279285(defun init-gnustep-framework ()
    … …  
    375381  `(objc-constant-string-nsstringptr ,(ns-constant-string string)))
    376382
     383#+gnu-objc
     384(progn
     385  (defcallback lisp-objc-error-handler (:id receiver :int errcode (:* :char) format :address argptr :<BOOL>)
     386    (let* ((message (get-c-format-string format argptr)))
     387      (error "ObjC runtime error ~d, receiver ~s :~& ~a"
     388             errcode receiver message))
     389    #$YES)
     390
     391  (def-ccl-pointers install-lisp-objc-error-handler ()
     392    (#_objc_set_error_handler lisp-objc-error-handler)))
     393
     394
    377395
    378396
    … …  
    459477;;; represented by the same SEL.
    460478(defun get-selector-for (method-name &optional error)
    461   (with-cstrs ((method-name method-name))
     479  (with-cstrs ((cmethod-name method-name))
    462480    (let* ((p (#+apple-objc #_sel_getUid
    463                #+gnu-objc #_sel_get_any_uid
    464                method-name)))
     481               #+gnu-objc #_sel_get_uid
     482               cmethod-name)))
    465483      (if (%null-ptr-p p)
    466484        (if error
    … …  
    10331051  #+apple-objc
    10341052  (#_objc_addClass class)
    1035   ;; Reading the fine print (e.g., the source), we learn that it's
    1036   ;; necessary to grab a mutex (lock) around the call to
    1037   ;; #___objc_add_class_to_hash.  Naturally.  Why would anyone want to
    1038   ;; (easily) add a new class procedurally ?
    10391053  #+gnu-objc
    1040   (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*)
    1041       (external-call "__objc_add_class_to_hash" :address class :void)))
     1054  ;; Why would anyone want to create a class without creating a Module ?
     1055  ;; Rather than ask that vexing question, let's create a Module with
     1056  ;; one class in it and use #___objc_exec_class to add the Module.
     1057  ;; (I mean "... to add the class", of course.
     1058  ;; It appears that we have to heap allocate the module, symtab, and
     1059  ;; module name: the GNU ObjC runtime wants to add the module to a list
     1060  ;; that it subsequently ignores.
     1061  (let* ((name (make-cstring "Phony Module"))
     1062         (symtab (malloc (+ (record-length :objc_symtab) (record-length (:* :void)))))
     1063         (m (make-record :objc_module
     1064                         :version 8 #|OBJC_VERSION|#
     1065                         :size (record-length :<M>odule)
     1066                         :name name
     1067                         :symtab symtab)))
     1068    (setf (%get-ptr symtab (record-length :objc_symtab)) (%null-ptr))
     1069    (setf (pref symtab :objc_symtab.sel_ref_cnt) 0
     1070          (pref symtab :objc_symtab.refs) (%null-ptr)
     1071          (pref symtab :objc_symtab.cls_def_cnt) 1
     1072          (pref symtab :objc_symtab.cat_def_cnt) 0
     1073          (%get-ptr (pref symtab :objc_symtab.defs)) class
     1074          (pref class :objc_class.info) (logior #$_CLS_RESOLV (pref class :objc_class.info)))
     1075    (#___objc_exec_class m)))
    10421076 
    10431077(defun %define-objc-class (info)
    … …  
    10481082                                        (objc-class-info-ivars info))))
    10491083          (%add-objc-class class)
    1050           (map-objc-class class)
     1084          (map-objc-class class (objc-to-lisp-classname (objc-class-info-classname info)))
    10511085          (%objc-class-classptr descriptor)))))
    10521086
    … …  
    11651199  ;;; mutex held.
    11661200  (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*)
    1167     (flet ((find-mlist ()
    1168              (do* ((sel-uid (#_sel_get_uid selector))
    1169                    (prev (%inc-ptr classptr :objc_class.methods)
    1170                          (%inc-ptr mlist :objc_method_list.method_next))
    1171                    (mlist (%get-ptr prev) (%get-ptr prev)))
    1172                   ((%null-ptr-p mlist)
    1173                    (let* ((new-mlist (make-record :objc_method_list
    1174                                                   :method_count 1))
    1175                           (method (pref new-mlist :objc_method_list.method_list))
    1176                           (ctypestring (make-cstring typestring))
    1177                           (newsel (#_sel_register_typed_name
    1178                                    (#_sel_get_uid selector) ctypestring)))
    1179                      (setf (pref method :objc_method.method_name) newsel
    1180                            (pref method :objc_method.method_types) ctypestring
    1181                            (pref method :objc_method.method_imp) imp)
    1182                      new-mlist))
    1183                (let* ((existing
    1184                        (do* ((method (pref mlist :objc_method_list.method_list)
    1185                                      (%inc-ptr method (record-length :objc_method)))
    1186                              (i 0 (1+ i))
    1187                              (n (pref mlist :objc_method_list.method_count)))
    1188                             ((= i n))
    1189                          (with-macptrs ((method-sel (pref method :objc_method.method_name)))
    1190                            (unless (%null-ptr-p method-sel)
    1191                              (when (eql sel-uid (#_sel_get_uid method-sel))
    1192                                (setf (pref method :objc_method.method_imp)
    1193                                      imp)
    1194                                (return mlist)))))))
    1195                  (when existing
    1196                    (setf (%get-ptr prev) (%null-ptr)
    1197                          (pref existing :objc_method_list.method_next)
    1198                          (%null-ptr))
    1199                    (return existing))))))
    1200       (let* ((mlist (find-mlist)))
    1201         (setf (pref mlist :objc_method_list.method_next)
    1202               (pref classptr :objc_class.methods)
    1203               (pref classptr :objc_class.methods) mlist)
    1204         (#___objc_update_dispatch_table_for_class classptr)))))
     1201    (let* ((ctypestring (make-cstring typestring))
     1202           (new-mlist nil))
     1203      (with-macptrs ((method (external-call "search_for_method_in_list"
     1204                              :address (pref classptr :objc_class.methods)
     1205                              :address selector
     1206                              :address)))
     1207        (when (%null-ptr-p method)
     1208          (setq new-mlist (make-record :objc_method_list :method_count 1))
     1209          (%setf-macptr method (pref new-mlist :objc_method_list.method_list)))
     1210        (setf (pref method :objc_method.method_name) selector
     1211              (pref method :objc_method.method_types) ctypestring
     1212              (pref method :objc_method.method_imp) imp)
     1213        (if new-mlist
     1214          (external-call "GSObjCAddMethods"
     1215                         :address classptr
     1216                         :address new-mlist
     1217                         :void)
     1218          (external-call "__objc_update_dispatch_table_for_class"
     1219                         :address classptr
     1220                         :void))
     1221        (update-type-signatures-for-method (%inc-ptr method 0))))))
    12051222
    12061223(defvar *lisp-objc-methods* (make-hash-table :test #'eq))
    … …  
    14001417                (defcallback ,impname
    14011418                    (:without-interrupts nil
    1402                                          #+openmcl-native-threads :error-return
    1403                                          #+openmcl-native-threads (condition objc-callback-error-return) ,@params ,resulttype)
     1419                                         #+(and openmcl-native-threads apple-objc) :error-return
     1420                                         #+(and openmcl-native-threads apple-objc) (condition objc-callback-error-return) ,@params ,resulttype)
    14041421                  (declare (ignorable ,_cmd))
    14051422                  ,@decls
    14061423                  (rlet ((,super :objc_super
    1407                            :receiver ,self
     1424                           #+apple-objc :receiver #+gnu-objc :self ,self
    14081425                           :class
    14091426                           ,@(if class-p
    14101427                                 `((pref
    14111428                                    (pref (@class ,class-name)
    1412                                      :objc_class.isa)
     1429                                     #+apple-objc :objc_class.isa
     1430                                     #+gnu-objc :objc_class.super_class )
    14131431                                    :objc_class.super_class))
    14141432                                 `((pref (@class ,class-name) :objc_class.super_class)))))
    … …  
    15031521   (error "Unknown instance variable: ~s" varname)))
    15041522
    1505 
    1506 
    1507 
    1508          
     1523;;; Return a typestring and offset as multiple values.
     1524
     1525(defun objc-get-method-argument-info (m i)
     1526  #+apple-objc
     1527  (%stack-block ((type 4) (offset 4))
     1528    (#_method_getArgumentInfo m i type offset)
     1529    (values (%get-cstring (%get-ptr type)) (%get-signed-long offset)))
     1530  #+gnu-objc
     1531  (progn
     1532    (with-macptrs ((typespec (#_objc_skip_argspec (pref m :objc_method.method_types))))
     1533      (dotimes (j i (values (%get-cstring typespec)
     1534                            (#_strtol (#_objc_skip_typespec typespec)
     1535                                      (%null-ptr)
     1536                                      10.)))
     1537        (%setf-macptr typespec (#_objc_skip_argspec typespec))))))
     1538
     1539 
    15091540
    15101541
    … …  
    15821613            (declare (fixnum i))
    15831614            (map-objc-class
    1584              (%get-ptr buffer (the fixnum  (ash i ppc32::word-shift)))
    1585              t)))))))
     1615             (%get-ptr buffer (the fixnum  (ash i ppc32::word-shift))))))))))
    15861616  (def-ccl-pointers revive-objc-classes ()
    15871617    (reset-objc-class-count)
    15881618    (map-objc-classes)))
    1589    
     1619
     1620#+gnu-objc
     1621(defun iterate-over-class-methods (class method-function)
     1622  (do* ((mlist (pref class :objc_class.methods)
     1623               (pref mlist :objc_method_list.method_next)))
     1624       ((%null-ptr-p mlist))
     1625    (do* ((n (pref mlist :objc_method_list.method_count))
     1626          (i 0 (1+ i))
     1627          (method (pref mlist :objc_method_list.method_list)
     1628                  (%incf-ptr method (record-length :objc_method))))
     1629         ((= i n))
     1630      (declare (fixnum i n))
     1631      (funcall method-function method class))))
     1632
     1633#+gnu-objc
     1634(progn
     1635  (let* ((objc-class-count 0))
     1636    (defun reset-objc-class-count () (setq objc-class-count 0))
     1637    (defun note-all-library-methods (method-function)
     1638      (do* ((i objc-class-count (1+ i))
     1639            (class (id->objc-class i) (id->objc-class i)))
     1640           ((eq class 0))
     1641        (iterate-over-class-methods class method-function)
     1642        (iterate-over-class-methods (id->objc-metaclass i) method-function))))
     1643  (def-ccl-pointers revive-objc-classes ()
     1644    (reset-objc-class-count)))
     1645
Note: See TracChangeset for help on using the changeset viewer.