Changeset 12438


Ignore:
Timestamp:
Jul 25, 2009, 8:15:02 AM (10 years ago)
Author:
gb
Message:

Conditionalize for Cocotron/Win32. Seems to mostly work (except for
some issue related to registering new selectors) and Cocotron issue #331.
Smoke-tested on OSX; seems to be OK, but there's a non-zero chance that
I broke something.

Location:
trunk/source/objc-bridge
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/objc-bridge/bridge.lisp

    r11216 r12438  
    174174
    175175
    176 
     176#+darwin-target
     177(progn
    177178;;; AEDesc (Apple Event Descriptor)
    178179
     
    189190              (ns::aedesc-data-handle a)))
    190191    (describe-macptr-allocation-and-address a stream)))
     192)
    191193
    192194;;; It's not clear how useful this would be; I think that it's
     
    233235    `(if ,form 1 0)))
    234236
    235 
     237#-cocotron-objc                         ;nyi
     238(progn
    236239;;; NSDecimal
    237240(define-typed-foreign-struct-class ns::ns-decimal (:<NSD>ecimal ns::ns-decimal-p nil nil nil)
     
    284287    (describe-macptr-allocation-and-address d stream)))
    285288
    286 
     289)
    287290
    288291   
     
    418421
    419422(defun method-typestring (method)
    420   (%get-cstring #+apple-objc-2.0
     423  (%get-cstring #+(or apple-objc-2.0 cocotron-objc)
    421424                (#_method_getTypeEncoding method)
    422                 #-apple-objc-2.0
     425                #-(or apple-objc-2.0 cocotron-objc)
    423426                (pref method :objc_method.method_types)))
    424427
     
    891894(defun %call-next-objc-method (self class selector sig &rest args)
    892895  (declare (dynamic-extent args))
    893   (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self
    894             #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class
    895             #+apple-objc-2.0 (#_class_getSuperclass class)
    896             #-apple-objc-2.0 (pref class :objc_class.super_class)))
     896  (rlet ((s :objc_super #+(or apple-objc cocotron-objc) :receiver #+gnu-objc :self self
     897            #+(or apple-objc-2.0 cocotron-objc)  :super_class #-(or apple-objc-2.0 cocotron-objc) :class
     898            #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass class)
     899            #-(or apple-objc-2.0 cocotron-objc) (pref class :objc_class.super_class)))
    897900    (let* ((siginfo (objc-method-signature-info sig))
    898901           (function (or (objc-method-signature-info-super-function siginfo)
     
    904907
    905908(defun %call-next-objc-class-method (self class selector sig &rest args)
    906   (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self
    907             #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class
    908             #+apple-objc-2.0 (#_class_getSuperclass (pref class :objc_class.isa))
    909             #-apple-objc-2.0 (pref (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) :objc_class.super_class)))
     909  (rlet ((s :objc_super #+(or apple-objc cocotron-objc) :receiver #+gnu-objc :self self
     910            #+(or apple-objc-2.0 cocotron-objc) :super_class #-(or apple-objc-2.0 cocotron-objc) :class
     911            #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass (pref class :objc_class.isa))
     912            #-(or apple-objc-2.0 cocotron-objc) (pref (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) :objc_class.super_class)))
    910913    (let* ((siginfo (objc-method-signature-info sig))
    911914           (function (or (objc-method-signature-info-super-function siginfo)
  • trunk/source/objc-bridge/objc-clos.lisp

    r12314 r12438  
    3232
    3333(eval-when (:compile-toplevel :execute)
    34   #+apple-objc
     34  #+(or apple-objc cocotron-objc)
    3535  (use-interface-dir :cocoa)
    3636  #+gnu-objc
     
    393393
    394394(defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class))
    395   #-apple-objc-2.0
     395  #-(or apple-objc-2.0 cocotron-objc)
    396396  (let* ((foreign-dslotds
    397397          (loop for d in dslotds
     
    408408            (return nil)))
    409409      (set-objc-foreign-direct-slot-offsets foreign-dslotds bit-offset)))
    410   #+apple-objc-2.0
     410  #+(or apple-objc-2.0 cocotron-objc)
    411411  ;; Add ivars for each foreign direct slot, then ask the runtime for
    412412  ;; the ivar's byte offset.  (Note that the ObjC 2.0 ivar initialization
     
    431431
    432432
    433 #+apple-objc-2.0
     433#+(or apple-objc-2.0 cocotron-objc)
    434434(defun %revive-foreign-slots (class)
    435435  (dolist (dslotd (class-direct-slots class))
     
    494494  ;; named NAME, return that instance variable's offset,  else return
    495495  ;; NIL.
    496   #+apple-objc-2.0
     496  #+(or apple-objc-2.0 cocotron-objc)
    497497  (with-cstrs ((name name))
    498498    (with-macptrs ((ivar (#_class_getInstanceVariable c name)))
    499499      (unless (%null-ptr-p ivar)
    500500        (#_ivar_getOffset ivar))))
    501   #-apple-objc-2.0
     501  #-(or apple-objc-2.0 cocotron-objc)
    502502  (when (objc-class-p c)
    503503    (with-macptrs ((ivars (pref c :objc_class.ivars)))
     
    514514             (unless (%null-ptr-p class)
    515515                 (or (%objc-ivar-offset-in-class name class)
    516                      (with-macptrs ((super #+apple-objc-2.0
     516                     (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc)
    517517                                           (#_class_getSuperclass class)
    518                                            #-apple-objc-2.0
     518                                           #-(or apple-objc-2.0 cocotron-objc)
    519519                                           (pref class :objc_class.super_class)))
    520520                       (unless (or (%null-ptr-p super) (eql super class))
     
    788788  (declare (ignore initargs))
    789789  (unless (slot-value class 'foreign)
    790     #-apple-objc-2.0
     790    #-(or apple-objc-2.0 cocotron-objc)
    791791    (multiple-value-bind (ivars instance-size)
    792792        (%make-objc-ivars class)
    793793      (%add-objc-class class ivars instance-size))
    794     #+apple-objc-2.0
     794    #+(or apple-objc-2.0 cocotron-objc)
    795795    (%add-objc-class class)))
    796796
     
    852852               ;; A root metaclass has the corresponding class as
    853853               ;; its superclass, and that class has no superclass.
    854                (with-macptrs ((super #+apple-objc-2.0
     854               (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc)
    855855                                     (#_class_getSuperclass metaclass)
    856                                      #-apple-objc-2.0
     856                                     #-(or apple-objc-2.0 cocotron-objc)
    857857                                     (pref metaclass :objc_class.super_class)))
    858858                 (and (not (%null-ptr-p super))
    859859                      (not (%objc-metaclass-p super))
    860860                      (%null-ptr-p
    861                        #+apple-objc-2.0
     861                       #+(or apple-objc-2.0 cocotron-objc)
    862862                       (#_class_getSuperclass super)
    863                        #-apple-objc-2.0
     863                       #-(or apple-objc-2.0 cocotron-objc)
    864864                       (pref super :objc_class.super_class)))))
    865865        ;; Whew! it's ok to reinitialize the class.
  • trunk/source/objc-bridge/objc-runtime.lisp

    r12372 r12438  
    2525  #+darwin-target (pushnew :apple-objc *features*)
    2626  #+(and darwin-target 64-bit-target) (pushnew :apple-objc-2.0 *features*)
    27   #-darwin-target (pushnew :gnu-objc *features*))
     27  #+win32-target (pushnew :cocotron-objc *features*)
     28  #-(or darwin-target win32-target) (pushnew :gnu-objc *features*))
    2829
    2930
     
    4748    #+nomore
    4849    (use-interface-dir :carbon))        ; need :carbon for things in this file
     50  #+cocotron-objc
     51  (use-interface-dir :cocoa)
    4952  #+gnu-objc
    5053  (use-interface-dir :gnustep))
     
    6063;;; CGFloat not so much.
    6164
    62 #-apple-objc-2.0
     65#-(or apple-objc-2.0 cocotron-objc)
    6366(progn
    64   (def-foreign-type :<CGF>loat :float)
    65   (def-foreign-type :<NSUI>nteger :unsigned)
    66   (def-foreign-type :<NSI>nteger :signed)
     67  (def-foreign-type #>CGFloat :float)
     68  (def-foreign-type #>NSUInteger :unsigned)
     69  (def-foreign-type #>NSInteger :signed)
    6770  )
    6871
    6972(defconstant +cgfloat-zero+
    70   #+(and apple-objc-2.0 64-bit-target) 0.0d0
    71   #-(and apple-objc-2.0 64-bit-target) 0.0f0)
     73  #+(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) 0.0d0
     74  #-(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) 0.0f0)
    7275
    7376(deftype cgfloat ()
    74   #+(and apple-objc-2.0 64-bit-target) 'double-float
    75   #-(and apple-objc-2.0 64-bit-target) 'single-float)
     77  #+(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) 'double-float
     78  #-(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) 'single-float)
    7679
    7780(deftype cg-float () 'cgfloat)
    7881
    7982(deftype nsuinteger ()
    80   #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64)
    81   #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32))
     83  #+(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) '(unsigned-byte 64)
     84  #-(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) '(unsigned-byte 32))
    8285
    8386(deftype nsinteger ()
    84   #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64)
    85   #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32))
     87  #+(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) '(signed-byte 64)
     88  #-(and (or apple-objc-2.0 cocotron-objc) 64-bit-target) '(signed-byte 32))
    8689
    8790
     
    113116
    114117(defun ensure-objc-classptr-resolved (classptr)
    115   #+apple-objc (declare (ignore classptr))
     118  #-gnu-objc (declare (ignore classptr))
    116119  #+gnu-objc
    117120  (unless (logtest #$_CLS_RESOLV (pref classptr :objc_class.info))
     
    265268                (let* ((id (assign-next-class-id))
    266269                       (class (%inc-ptr class 0))
    267                        (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
     270                       (meta (pref class #+(or apple-objc cocotron-objc) :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
    268271                  (setf (gethash class objc-class-map) id)
    269272                  (setf (svref c id) class
     
    328331
    329332;;; Open shared libs.
    330 #+darwin-target
     333#+(or darwin-target cocotron-objc)
    331334(progn
    332335(defloadvar *cocoa-event-process* *initial-process*)
     
    349352               (pool-class-name "NSAutoreleasePool")
    350353               (thread-message-selector-name "detachNewThreadSelector:toTarget:withObject:")
    351                (exit-selector-name "exit")
     354               (exit-selector-name "class")
    352355               (alloc-selector-name "alloc")
    353356               (init-selector-name "init")
     
    391394       ;; in the thread that's going to process events.  Looking up a
    392395       ;; symbol in the library should cause it to be initialized
     396       #+apple-objc
    393397       (open-shared-library "/System/Library/Frameworks/Cocoa.framework/Cocoa")
     398       #+cocotron-objc
     399       (open-shared-library (native-translated-namestring
     400                             (truename "ccl:Cocoa'.1'.0'.dll")))
    394401       ;(#_GetCurrentEventQueue)
    395402       (current-ns-thread)
     
    452459  #+apple-objc
    453460  #&NSAppKitVersionNumber
     461  #+cocotron-objc 1.0                   ; fix this
    454462  #+gnu-objc
    455463  (get-foundation-version))
    456464
    457465(defun get-foundation-version ()
    458   #&NSFoundationVersionNumber
     466  #+apple-objc #&NSFoundationVersionNumber
     467  #+cocotron-objc 1.0                   ; fix this
    459468  #+gnu-objc (%get-cstring (foreign-symbol-address "gnustep_base_version")))
    460469
     
    478487(defloadvar *NSConstantString-class*
    479488  (with-cstrs ((name "NSConstantString"))
    480     #+apple-objc (#_objc_lookUpClass name)
     489    #+(or apple-objc cocotron-objc) (#_objc_lookUpClass name)
    481490    #+gnu-objc (#_objc_lookup_class name)))
    482491
    483492
    484 
     493;;; Catch frames are allocated on a stack, so it's OK to pass their
     494;;; addresses around to foreign code.
     495(defcallback throw-to-catch-frame (:signed-fullword value
     496                                   :address frame
     497                                   :void)
     498  (throw (%get-object frame target::catch-frame.catch-tag) value))
     499
     500
     501#+(and x8632-target (or apple-objc cocotron-objc))
     502(defloadvar *setjmp-catch-rip-code*
     503    (let* ((code-bytes '(#x83 #xec #x10 ; subl $16,%esp
     504                         #x89 #x04 #x24 ; movl %eax,(%esp)
     505                         #x89 #x7c #x24 #x04   ; movl %edi,4(%esp)
     506                         #xff #xd3))    ; call *%ebx
     507           (nbytes (length code-bytes))
     508           (p (malloc nbytes)))
     509      (dotimes (i nbytes p)
     510        (setf (%get-unsigned-byte p i) (pop code-bytes)))))
    485511
    486512#+apple-objc
     
    595621        (setf (%get-unsigned-byte p i) (pop code-bytes)))))
    596622
    597 #+x8632-target
    598 (defloadvar *setjmp-catch-rip-code*
    599     (let* ((code-bytes '(#x83 #xec #x10 ; subl $16,%esp
    600                          #x89 #x04 #x24 ; movl %eax,(%esp)
    601                          #x89 #x7c #x24 #x04   ; movl %edi,4(%esp)
    602                          #xff #xd3))    ; call *%ebx
    603            (nbytes (length code-bytes))
    604            (p (malloc nbytes)))
    605       (dotimes (i nbytes p)
    606         (setf (%get-unsigned-byte p i) (pop code-bytes)))))
    607 
    608 ;;; Catch frames are allocated on a stack, so it's OK to pass their
    609 ;;; addresses around to foreign code.
    610 (defcallback throw-to-catch-frame (:signed-fullword value
    611                                    :address frame
    612                                    :void)
    613   (throw (%get-object frame target::catch-frame.catch-tag) value))
     623
     624
     625
    614626
    615627;;; Initialize a jmp_buf so that when it's #_longjmp-ed to, it'll
     
    663675
    664676)
     677
     678#+win32-target
     679(progn
     680  (eval-when (:compile-toplevel :execute)
     681    (progn
     682      (defconstant jb-ebp 0)
     683      (defconstant jb-ebx 4)
     684      (defconstant jb-edi 8)
     685      (defconstant jb-esi 12)
     686      (defconstant jb-esp 16)
     687      (defconstant jb-eip 20)
     688      (defconstant jb-seh 24)
     689      (defconstant jb-seh-info 28)))
     690
     691  (defx8632lapfunction set-jb-seh ((jb arg_z))
     692    (macptr-ptr arg_z temp0)             ;fixnum-aligned
     693    (movl (@ (% fs) 0) (% imm0))
     694    (movl (% imm0) (@ jb-seh (% temp0)))
     695    (cmpl ($ -1) (% imm0))
     696    (je @store)
     697    (movl (@ 12 (% imm0)) (% imm0))
     698    @store
     699    (movl (% imm0) (@ jb-seh-info (% temp0)))
     700    (single-value-return))
     701
     702(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame)
     703  (%set-object jmp-buf JB-ESP (1+ c-frame))
     704  (%set-object jmp-buf JB-EBP (1+ c-frame))
     705  (setf (%get-ptr jmp-buf JB-EBX) throw-to-catch-frame
     706        (%get-ptr jmp-buf JB-EIP) *setjmp-catch-rip-code*)
     707  (%set-object jmp-buf JB-EDI catch-frame)
     708  (set-jb-seh jmp-buf)
     709  t) 
     710
     711 
     712  )
    665713
    666714;;; When starting up an image that's had ObjC classes in it, all of
     
    709757            (setf (gethash c class-map) i)
    710758            (unless (gethash m metaclass-map)
    711               (%setf-macptr m (pref c #+apple-objc :objc_class.isa
     759              (%setf-macptr m (pref c #+(or apple-objc cocotron-objc) :objc_class.isa
    712760                                      #+gnu-objc :objc_class.class_pointer))
    713761              (setf (gethash m metaclass-map) meta-id))
     
    727775                 (m (id->objc-metaclass meta-id)))
    728776            (let* ((class (make-objc-class-pair super (make-cstring (objc-class-id-foreign-name i))))
    729                    (meta (pref class #+apple-objc :objc_class.isa
     777                   (meta (pref class #+(or apple-objc cocotron-objc) :objc_class.isa
    730778                               #+gnu-objc :objc-class.class_pointer)))
    731779            (unless (gethash m metaclass-map)
     
    734782              (setf (gethash m metaclass-map) meta-id))
    735783            (%setf-macptr c class))
    736             #+apple-objc-2.0
     784            #+(or apple-objc-2.0 cocotron-objc)
    737785            (%revive-foreign-slots c)
    738             #+apple-objc-2.0
     786            #+(or apple-objc-2.0 cocotron-objc)
    739787            (%add-objc-class c)
    740             #-apple-objc-2.0
     788            #-(or apple-objc-2.0 cocotron-objc)
    741789            (multiple-value-bind (ivars instance-size)
    742790                (%make-objc-ivars c)
     
    768816
    769817(defun %objc-class-instance-size (c)
    770   #+apple-objc-2.0
     818  #+(or apple-objc-2.0 cocotron-objc)
    771819  (#_class_getInstanceSize c)
    772   #-apple-objc-2.0
     820  #-(or apple-objc-2.0 cocotron-objc)
    773821  (pref c :objc_class.instance_size))
    774822
    775823(defun find-named-objc-superclass (class string)
    776824  (unless (or (null string) (%null-ptr-p class))
    777     (with-macptrs ((name #+apple-objc-2.0 (#_class_getName class)
    778                          #-apple-objc-2.0 (pref class :objc_class.name)))
     825    (with-macptrs ((name #+(or apple-objc-2.0 cocotron-objc) (#_class_getName class)
     826                         #-(or apple-objc-2.0 cocotron-objc) (pref class :objc_class.name)))
    779827      (or
    780828       (dotimes (i (length string) class)
     
    782830           (unless (eq b (char-code (schar string i)))
    783831             (return))))
    784        (find-named-objc-superclass #+apple-objc-2.0 (#_class_getSuperclass class)
    785                                    #-apple-objc-2.0 (pref class :objc_class.super_class)
     832       (find-named-objc-superclass #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass class)
     833                                   #-(or apple-objc-2.0 cocotron-objc) (pref class :objc_class.super_class)
    786834                                   string)))))
    787835
     
    789837  (let* ((id (objc-class-id class)))
    790838    (unless id
    791       (let* ((name (%get-cstring #+apple-objc-2.0 (#_class_getName class)
    792                                  #-apple-objc-2.0 (pref class :objc_class.name)))
     839      (let* ((name (%get-cstring #+(or apple-objc-2.0 cocotron-objc) (#_class_getName class)
     840                                 #-(or apple-objc-2.0 cocotron-objc) (pref class :objc_class.name)))
    793841             (decl (get-objc-class-decl name use-db)))
    794842        (if (null decl)
     
    800848            ;; If not mapped, map the superclass (if there is one.)
    801849            (let* ((super (find-named-objc-superclass
    802                            #+apple-objc-2.0
     850                           #+(or apple-objc-2.0 cocotron-objc)
    803851                           (#_class_getSuperclass class)
    804                            #-apple-objc-2.0
     852                           #-(or apple-objc-2.0 cocotron-objc)
    805853                           (pref class :objc_class.super_class)
    806854                           (db-objc-class-info-superclass-name decl))))
     
    819867                  (let* ((meta-foreign-name
    820868                          (%get-cstring
    821                            #+apple-objc-2.0
     869                           #+(or apple-objc-2.0 cocotron-objc)
    822870                           (#_class_getName meta)
    823                            #-apple-objc-2.0
     871                           #-(or apple-objc-2.0 cocotron-objc)
    824872                           (pref meta :objc_class.name)))
    825873                         (meta-name
     
    833881                           "NS"))
    834882                         (meta-super
    835                           (if super (pref super #+apple-objc :objc_class.isa
     883                          (if super (pref super #+(or apple-objc cocotron-objc) :objc_class.isa
    836884                                          #+gnu-objc :objc_class.class_pointer))))
    837885                    ;; It's important (here and when initializing the
     
    888936           :num<B>ytes ,len))
    889937      ,@body)
     938  #+cocotron-objc
     939    `(rlet ((,nsstr :<NSC>onstant<S>tring
     940           :isa *NSConstantString-class*
     941           :_bytes ,cstring
     942           :_length ,len))
     943      ,@body)
    890944  #+gnu-objc
    891945  `(rlet ((,nsstr :<NXC>onstant<S>tring
     
    905959               :bytes (make-cstring string)
    906960               :num<B>ytes (length string))
     961  #+cocotron-objc
     962    (make-record :<NSC>onstant<S>tring
     963               :isa *NSConstantString-Class*
     964               :_bytes (make-cstring string)
     965               :_length (length string))
    907966  #+gnu-objc
    908967  (make-record :<NXC>onstant<S>tring
     
    9931052(defun lookup-objc-class (name &optional error-p)
    9941053  (with-cstrs ((cstr (objc-class-name-string name)))
    995     (let* ((p (#+apple-objc #_objc_lookUpClass
     1054    (let* ((p (#+(or apple-objc cocotron-objc) #_objc_lookUpClass
    9961055               #+gnu-objc #_objc_lookup_class
    9971056               cstr)))
     
    10041063  (with-cstrs ((cstr class-name-string))
    10051064    (%setf-macptr ptr
    1006                   (#+apple-objc #_objc_lookUpClass
     1065                  (#+(or apple-objc cocotron-objc) #_objc_lookUpClass
    10071066                   #+gnu-objc #_objc_lookup_class
    10081067                   cstr)))
     
    10521111;;; instance (returning the class name.)
    10531112(defun objc-class-name (object)
    1054   #+apple-objc
     1113  #+(or apple-objc cocotron-objc)
    10551114  (with-macptrs (p)
    10561115    (%setf-macptr p (#_object_getClassName object))
     
    10721131(defun get-selector-for (method-name &optional error)
    10731132  (with-cstrs ((cmethod-name method-name))
    1074     (let* ((p (#+apple-objc #_sel_getUid
     1133    (let* ((p (#+(or apple-objc cocotron-objc) #_sel_getUid
    10751134               #+gnu-objc #_sel_get_uid
    10761135               cmethod-name)))
     
    12021261  (%get-cstring
    12031262   #+apple-objc sel
     1263   #+cocotron-objc (#_sel_getName sel)
    12041264   #+gnu-objc (#_sel_get_name sel)))
    12051265
     
    12151275  (when (evenp (length argspecs))
    12161276    (setq argspecs (append argspecs '(:id))))
    1217   #+apple-objc
     1277  #+(or apple-objc cocotron-objc)
    12181278  (funcall (ftd-ff-call-expand-function *target-ftd*)
    1219            `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
     1279           `(%ff-call (%reference-external-entry-point (load-time-value (external "objc_msgSend"))))
    12201280           `(:address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
    12211281           :arg-coerce 'objc-arg-coerce
     
    12401300  (when (evenp (length argspecs))
    12411301    (setq argspecs (append argspecs '(:id))))
    1242   #+apple-objc
     1302  #+(or apple-objc cocotron-objc)
    12431303  (funcall (ftd-ff-call-expand-function *target-ftd*)
    1244            `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
     1304           `(%ff-call (%reference-external-entry-point (load-time-value (external "objc_msgSend"))))
    12451305           `(:address ,receiver :<SEL> (%get-selector ,selector) ,@argspecs)
    12461306           :arg-coerce 'objc-arg-coerce
     
    12871347
    12881348(defmacro objc-message-send-stret (structptr receiver selector-name &rest argspecs)
    1289     #+apple-objc
     1349    #+(or apple-objc cocotron-objc)
    12901350    (let* ((return-typespec (car (last argspecs)))
    12911351           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
    1292                          "_objc_msgSend_stret"
    1293                          "_objc_msgSend")))
     1352                         "objc_msgSend_stret"
     1353                         "objc_msgSend")))
    12941354      (funcall (ftd-ff-call-expand-function *target-ftd*)
    12951355               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     
    13141374
    13151375(defmacro objc-message-send-stret-with-selector (structptr receiver selector &rest argspecs)
    1316     #+apple-objc
     1376    #+(or apple-objc cocotron-objc)
    13171377    (let* ((return-typespec (car (last argspecs)))
    13181378           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
    1319                          "_objc_msgSend_stret"
    1320                          "_objc_msgSend")))
     1379                         "objc_msgSend_stret"
     1380                         "objc_msgSend")))
    13211381      (funcall (ftd-ff-call-expand-function *target-ftd*)
    13221382               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     
    13471407  (when (evenp (length argspecs))
    13481408    (setq argspecs (append argspecs '(:id))))
    1349   #+apple-objc
     1409  #+(or apple-objc cocotron-objc)
    13501410  (funcall (ftd-ff-call-expand-function *target-ftd*)
    1351            `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
     1411           `(%ff-call (%reference-external-entry-point (load-time-value (external "objc_msgSendSuper"))))
    13521412           `(:address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
    13531413           :arg-coerce 'objc-arg-coerce
     
    13721432  (when (evenp (length argspecs))
    13731433    (setq argspecs (append argspecs '(:id))))
    1374   #+apple-objc
     1434  #+(or apple-objc cocotron-objc)
    13751435  (funcall (ftd-ff-call-expand-function *target-ftd*)
    1376            `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
     1436           `(%ff-call (%reference-external-entry-point (load-time-value (external "objc_msgSendSuper"))))
    13771437           `(:address ,super :<SEL> ,selector ,@argspecs)
    13781438           :arg-coerce 'objc-arg-coerce
     
    13971457(defmacro objc-message-send-super-stret
    13981458    (structptr super selector-name &rest argspecs)
    1399   #+apple-objc
     1459  #+(or apple-objc cocotron-objc)
    14001460    (let* ((return-typespec (car (last argspecs)))
    14011461           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
    1402                          "_objc_msgSendSuper_stret"
    1403                          "_objc_msgSendSuper")))
     1462                         "objc_msgSendSuper_stret"
     1463                         "objc_msgSendSuper")))
    14041464      (funcall (ftd-ff-call-expand-function *target-ftd*)
    14051465               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     
    14261486(defmacro objc-message-send-super-stret-with-selector
    14271487    (structptr super selector &rest argspecs)
    1428   #+apple-objc
     1488  #+(or apple-objc cocotron-objc)
    14291489    (let* ((return-typespec (car (last argspecs)))
    14301490           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
    1431                          "_objc_msgSendSuper_stret"
    1432                          "_objc_msgSendSuper")))
     1491                         "objc_msgSendSuper_stret"
     1492                         "objc_msgSendSuper")))
    14331493      (funcall (ftd-ff-call-expand-function *target-ftd*)
    14341494               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     
    15111571           (incf nstackargs)))))))
    15121572
    1513 #+(and apple-objc x8632-target)
     1573#+x8632-target
    15141574(defun %process-varargs-list (ptr index arglist)
    15151575  (dolist (arg-temp arglist)
     
    17191779                   (progn ,@(static-arg-forms))
    17201780                   (%process-varargs-list ,regparams ,fpparams ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg)
    1721                    (%do-ff-call ,fpr-total ,cframe ,fpparams (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
     1781                   (%do-ff-call ,fpr-total ,cframe ,fpparams (%reference-external-entry-point (load-time-value (external "objc_msgSend"))))
    17221782                   ,@(if op
    17231783                         `((,op ,regparams ,result-offset))
     
    18201880               (progn ,@(static-arg-forms))
    18211881               (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg)
    1822                (external-call "_objc_msgSendv"
     1882               (external-call "objc_msgSendv"
    18231883                              :address ,receiver
    18241884                              :address ,selptr
     
    18271887                              ,return-type-spec)))))))))
    18281888
    1829 #+(and apple-objc x8632-target)
     1889#+(and (or apple-objc cocotron-objc) x8632-target)
    18301890(defun %compile-varargs-send-function-for-signature (sig)
    18311891  (let* ((return-type-spec (car sig))
     
    19041964              (progn ,@(static-arg-forms))
    19051965              (%process-varargs-list ,marg-ptr ,static-arg-words ,rest-arg)
    1906               (external-call "_objc_msgSendv"
     1966              (external-call "objc_msgSendv"
    19071967                             :id ,receiver
    19081968                             :<SEL> ,selptr
     
    19862046                  (%load-fp-arg-regs (%process-varargs-list ,gen-arg-ptr ,fp-arg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg) ,fp-arg-ptr)
    19872047                 
    1988                   (%do-ff-call nil (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
     2048                  (%do-ff-call nil (%reference-external-entry-point (load-time-value (external "objc_msgSend"))))
    19892049                  ;; Using VALUES here is a hack: the multiple-value
    19902050                  ;; returning machinery clobbers imm0.
     
    22322292;;; Make a meta-class object (with no instance variables or class
    22332293;;; methods.)
    2234 #-apple-objc-2.0
     2294#-(or apple-objc-2.0 cocotron-objc)
    22352295(defun %make-basic-meta-class (nameptr superptr rootptr)
    22362296  #+apple-objc
     
    22632323               :gc_object_type (%null-ptr)))
    22642324
    2265 #-apple-objc-2.0
     2325#-(or apple-objc-2.0 cocotron-objc)
    22662326(defun %make-class-object (metaptr superptr nameptr ivars instance-size)
    22672327  #+apple-objc
     
    22922352
    22932353(defun make-objc-class-pair (superptr nameptr)
    2294   #+apple-objc-2.0
     2354  #+(or apple-objc-2.0 cocotron-objc)
    22952355  (#_objc_allocateClassPair superptr nameptr 0)
    2296   #-apple-objc-2.0
     2356  #-(or apple-objc-2.0 cocotron-objc)
    22972357  (%make-class-object
    22982358   (%make-basic-meta-class nameptr superptr (@class "NSObject"))
     
    23032363
    23042364(defun superclass-instance-size (class)
    2305   (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass class)
    2306                         #-apple-objc-2.0 (pref class :objc_class.super_class)))
     2365  (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass class)
     2366                        #-(or apple-objc-2.0 cocotron-objc) (pref class :objc_class.super_class)))
    23072367    (if (%null-ptr-p super)
    23082368      0
     
    23272387
    23282388(defun %objc-metaclass-p (class)
    2329   #+apple-objc-2.0 (not (eql #$NO (#_class_isMetaClass class)))
    2330   #-apple-objc-2.0
     2389  #+(or apple-objc-2.0 cocotron-objc) (not (eql #$NO (#_class_isMetaClass class)))
     2390  #-(or apple-objc-2.0 cocotron-objc)
    23312391  (logtest (pref class :objc_class.info)
    23322392           #+apple-objc #$CLS_META
     
    23342394
    23352395;; No way to tell in Objc-2.0.  Does anything care ?
    2336 #-apple-objc-2.0
     2396#-(or apple-objc-2.0 cocotron-objc)
    23372397(defun %objc-class-posing-p (class)
    23382398  (logtest (pref class :objc_class.info)
     
    23642424                              (symbol-package name)))
    23652425           (meta-super (canonicalize-registered-metaclass
    2366                         #+apple-objc-2.0
     2426                        #+(or apple-objc-2.0 cocotron-objc)
    23672427                        (#_class_getSuperclass meta)
    2368                         #-apple-objc-2.0
     2428                        #-(or apple-objc-2.0 cocotron-objc)
    23692429                        (pref meta :objc_class.super_class))))
    23702430      (initialize-instance meta
     
    23802440;;; Set up the class's ivar_list and instance_size fields, then
    23812441;;; add the class to the ObjC runtime.
    2382 #-apple-objc-2.0
     2442#-(or apple-objc-2.0 cocotron-objc)
    23832443(defun %add-objc-class (class ivars instance-size)
    23842444  (setf
     
    24112471    (#___objc_exec_class m)))
    24122472
    2413 #+apple-objc-2.0
     2473#+(or apple-objc-2.0 cocotron-objc)
    24142474(defun %add-objc-class (class)
    24152475  (#_objc_registerClassPair class))
     
    24942554    (when info
    24952555      (or (private-objc-class-info-declared-ancestor info)
    2496           (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass classptr)
    2497                                 #-apple-objc-2.0 (pref classptr :objc_class.super_class)))
     2556          (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass classptr)
     2557                                #-(or apple-objc-2.0 cocotron-objc) (pref classptr :objc_class.super_class)))
    24982558            (loop
    24992559              (when (%null-ptr-p super)
     
    25032563                  (return (setf (private-objc-class-info-declared-ancestor info)
    25042564                                id))
    2505                   (%setf-macptr super #+apple-objc-2.0 (#_class_getSuperclass super)
    2506                                 #-apple-objc-2.0 (pref super :objc_class.super_class))))))))))
     2565                  (%setf-macptr super #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass super)
     2566                                #-(or apple-objc-2.0 cocotron-objc) (pref super :objc_class.super_class))))))))))
    25072567
    25082568(defun objc-class-or-private-class-id (classptr)
     
    25162576          (safe-get-ptr p q)
    25172577          (not (%null-ptr-p q)))
    2518       (with-macptrs ((parent #+apple-objc (pref p :objc_object.isa)
     2578      (with-macptrs ((parent #+(or apple-objc cocotron-objc) (pref p :objc_object.isa)
    25192579                             #+gnu-objc (pref p :objc_object.class_pointer)))
    25202580        (or
     
    25522612;;; to the old IMP, at least as far as objc method dispatch is
    25532613;;; concerned.
    2554 #-apple-objc-2.0
     2614#-(or apple-objc-2.0 cocotron-objc)
    25552615(defun %mlist-containing (classptr selector typestring imp)
    25562616  #-apple-objc (declare (ignore classptr selector typestring imp))
     
    25822642
    25832643(defun %add-objc-method (classptr selector typestring imp)
    2584   #+apple-objc-2.0
     2644  #+(or apple-objc-2.0 cocotron-objc)
    25852645  (with-cstrs ((typestring typestring))
    25862646    (or (not (eql #$NO (#_class_addMethod classptr selector imp typestring)))
     
    25912651            (#_method_setImplementation m imp)
    25922652            (error "Can't add ~s method to class ~s" selector typestring)))))
    2593   #-apple-objc-2.0
     2653  #-(or apple-objc-2.0 cocotron-objc)
    25942654  (progn
    25952655    #+apple-objc
     
    26382698    (%add-objc-method
    26392699     (if (lisp-objc-method-class-p m)
    2640        (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)
     2700       (pref class #+(or apple-objc cocotron-objc) :objc_class.isa #+gnu-objc :objc_class.class_pointer)
    26412701       class)
    26422702     sel
     
    28082868            (defcallback ,impname
    28092869                (:without-interrupts nil
    2810                  #+(and openmcl-native-threads apple-objc) :error-return
    2811                  #+(and openmcl-native-threads apple-objc)  (condition objc-callback-error-return) ,@params ,resulttype)
     2870                 #+(and openmcl-native-threads (or apple-objc cocotron-objc)) :error-return
     2871                 #+(and openmcl-native-threads (or apple-objc cocotron-objc))  (condition objc-callback-error-return) ,@params ,resulttype)
    28122872              (declare (ignorable ,_cmd))
    28132873              ,@decls
    28142874              (rlet ((,super :objc_super
    2815                        #+apple-objc :receiver #+gnu-objc :self ,self
    2816                        #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class
     2875                       #+(or apple-objc coctron-objc) :receiver #+gnu-objc :self ,self
     2876                       #+(or apple-objc-2.0 cocotron-objc) :super_class #-(or apple-objc-2.0 cocotron-objc) :class
    28172877                       ,@(if class-p
    2818                              #+apple-objc-2.0
    2819                              `((external-call "_class_getSuperclass"
     2878                             #+(or apple-objc-2.0 cocotron-objc)
     2879                             `((external-call "class_getSuperclass"
    28202880                                :address (pref (@class ,class-name) :objc_class.isa) :address))
    2821                              #-apple-objc-2.0
     2881                             #-(or apple-objc-2.0 cocotron-objc)
    28222882                             `((pref
    28232883                                (pref (@class ,class-name)
     
    28252885                                 #+gnu-objc :objc_class.class_pointer)
    28262886                                :objc_class.super_class))
    2827                              #+apple-objc-2.0
    2828                              `((external-call "_class_getSuperclass"
     2887                             #+(or apple-objc-2.0 cocotron-objc)
     2888                             `((external-call "class_getSuperclass"
    28292889                                :address (@class ,class-name) :address))
    2830                              #-apple-objc-2.0
     2890                             #-(or apple-objc-2.0 cocotron-objc)
    28312891                             `((pref (@class ,class-name) :objc_class.super_class)))))
    28322892                (macrolet ((send-super (msg &rest args &environment env)
     
    28562916(defun %objc-struct-return (return-temp size value)
    28572917  (unless (eq return-temp value)
    2858     (#_bcopy value return-temp size)))
     2918    (#_memmove return-temp value size)))
    28592919
    28602920(defmacro objc:defmethod (name (self-arg &rest other-args) &body body &environment env)
     
    29763036
    29773037(defun class-get-instance-method (class sel)
    2978   #+apple-objc (#_class_getInstanceMethod class sel)
     3038  #+(or apple-objc cocotron-objc) (#_class_getInstanceMethod class sel)
    29793039  #+gnu-objc (#_class_get_instance_method class sel))
    29803040
    29813041(defun class-get-class-method (class sel)
    2982   #+apple-objc (#_class_getClassMethod class sel)
     3042  #+(or apple-objc cocotron-objc) (#_class_getClassMethod class sel)
    29833043  #+gnu-objc   (#_class_get_class_method class sel))
    29843044
    29853045(defun method-get-number-of-arguments (m)
    2986   #+apple-objc (#_method_getNumberOfArguments m)
     3046  #+(or apple-objc cocotron-objc) (#_method_getNumberOfArguments m)
    29873047  #+gnu-objc (#_method_get_number_of_arguments m))
    29883048
     
    30363096;;; The NSHandler2 type was visible in Tiger headers, but it's not
    30373097;;; in the Leopard headers.
    3038 #-apple-objc-2.0
     3098#+(and apple-objc (not apple-objc-2.0))
    30393099(def-foreign-type #>NSHandler2_private
    30403100  (:struct #>NSHandler2_private
     
    30633123                   ,@body))))
    30643124        (check-ns-exception ,nshandler))))
     3125  #+cocotron-objc
     3126  (let* ((xframe (gensym))
     3127         (cframe (gensym)))
     3128    `(rletZ ((,xframe #>NSExceptionFrame))
     3129      (unwind-protect
     3130           (progn
     3131             (external-call "__NSPushExceptionFrame" :address ,xframe :void)
     3132             (catch ,xframe
     3133               (with-c-frame ,cframe
     3134                 (%associate-jmp-buf-with-catch-frame
     3135                  ,xframe
     3136                  (%fixnum-ref (%current-tcr) target::tcr.catch-top)
     3137                  ,cframe)
     3138                 (progn
     3139                   ,@body))))
     3140        (check-ns-exception ,xframe))))
    30653141  #+gnu-objc
    30663142  `(progn ,@body)
     
    30803156      (error (ns-exception->lisp-condition (%inc-ptr exception 0))))))
    30813157
    3082 
    3083 
    3084 
     3158#+cocotron-objc
     3159(defun check-ns-exception (xframe)
     3160  (with-macptrs ((exception (pref xframe #>NSExceptionFrame.exception)))
     3161    (if (%null-ptr-p exception)
     3162      (external-call "__NSPopExceptionFrame" :address xframe :void)
     3163      (error (ns-exception->lisp-condition (%inc-ptr exception 0))))))
     3164
     3165
     3166
     3167
  • trunk/source/objc-bridge/objc-support.lisp

    r12313 r12438  
    1515
    1616
    17 #+apple-objc
     17#+(or apple-objc cocotron-objc)
    1818(defun iterate-over-objc-classes (fn)
    1919  (let* ((n (#_objc_getClassList (%null-ptr) 0)))
     
    2626        (funcall fn (paref buffer (:* :id) i))))))
    2727
    28 #+apple-objc
     28#+(or apple-objc cocotron-objc)
    2929(defun count-objc-classes ()
    3030  (#_objc_getClassList (%null-ptr) 0)) 
     
    6464
    6565(defun note-class-protocols (class)
    66   #-apple-objc-2.0
     66  #-(or apple-objc-2.0 cocotron-objc)
    6767  (do* ((protocols (pref class :objc_class.protocols)
    6868                   (pref protocols :objc_protocol_list.next)))
     
    7373          (with-macptrs ((p (paref list (:* (:* (:struct :<P>rotocol))) i)))
    7474            (%note-protocol p))))))
    75   #+apple-objc-2.0
    76   (rlet ((p-out-count :int))
     75  #+(or apple-objc-2.0 cocotron-objc)
     76  (rlet ((p-out-count :int 0))
    7777    (with-macptrs ((protocols (#_class_copyProtocolList class p-out-count)))
    7878      (let* ((n (pref p-out-count :int)))
     
    210210
    211211#-ascii-only
     212(progn
     213#-windows-target
    212214(defun lisp-string-from-nsstring (nsstring)
    213215  ;; The NSData object created here is autoreleased.
     
    223225        ;; to the string, return the string.
    224226        (%copy-ptr-to-ivector (#/bytes data) 0 string 0 nbytes)))))
     227
     228#+windows-target
     229(defun lisp-string-from-nsstring (nsstring)
     230  (let* ((n (#/length nsstring)))
     231    (%stack-block ((buf (* (1+ n) (record-length :unichar))))
     232      (#/getCharacters: nsstring buf)
     233      (setf (%get-unsigned-word buf (+ n n)) 0)
     234      (%get-native-utf-16-cstring buf))))
    225235       
    226 
     236)
    227237
    228238#+ascii-only
     
    265275
    266276
    267 #+apple-objc
     277#+(or apple-objc cocotron-objc)         ; not really
    268278(progn
    269279
     
    386396
    387397(defun %cf-instance-p (instance)
     398  #-apple-objc (declare (ignore instance))
     399  #+apple-objc
    388400  (> (objc-message-send instance "_cfTypeID" #>CFTypeID) 1))
    389401 
     
    394406      (has-lisp-slot-vector nsobject)
    395407      (let* ((cf-p (%cf-instance-p nsobject))
    396              (isize (if cf-p (#_malloc_size nsobject) (%objc-class-instance-size (#/class nsobject))))
     408             (isize (if cf-p (external-call "malloc_size" :address nsobject :size_t) (%objc-class-instance-size (#/class nsobject))))
    397409             (skip (if cf-p (+ (record-length :id) 4 #+64-bit-target 4) (record-length :id))))
    398410        (declare (fixnum isize skip))
     
    454466            (nsobject-description current)
    455467            (pref current :<NSA>utorelease<P>ool._released_count))))
     468
     469#+cocotron-objc
     470(defun show-autorelease-pools ()
     471  (%string-to-stderr  "No info about current thread's autorelease pools is available"))
    456472
    457473(define-toplevel-command :global sap () "Log information about current thread's autorelease-pool(s) to C's standard error stream"
Note: See TracChangeset for help on using the changeset viewer.