Changeset 5865


Ignore:
Timestamp:
Feb 2, 2007, 1:32:47 AM (18 years ago)
Author:
Gary Byers
Message:

Start to integrate with FFI changes. No more %SEND, process and
precompile "init" messages when interfaces are accessed.
(Note: should try to handle varargs init messages, even if we have
to call %FF-CALL at runtime.)

Location:
trunk/ccl/examples
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/examples/bridge.lisp

    r5733 r5865  
    359359
    360360(defun result-type-requires-structure-return (result-type)
    361   (and (typep result-type 'foreign-record-type)
    362        (> (ensure-foreign-type-bits result-type) 32)))
     361  ;; Use objc-msg-send-stret for all methods that return
     362  ;; record types.
     363  (typep result-type 'foreign-record-type))
    363364
    364365(defun postprocess-objc-message-info (message-info)
    … …  
    455456               (lookup-objc-message-info message-name info)
    456457               (postprocess-objc-message-info info))
    457            *objc-message-info*))
     458           *objc-message-info*)
     459  ;; Update info about init messages.
     460  (register-objc-init-messages))
    458461
    459462
    … …  
    496499
    497500
    498 
    499 
    500 
    501501;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID
    502502
    … …  
    508508
    509509
    510 ;;; Convert a Lisp object X to a desired foreign type FTYPE
    511 ;;; The following conversions are currently done:
    512 ;;;   - T/NIL => #$YES/#$NO
    513 ;;;   - NIL => (%null-ptr)
    514 ;;;   - Lisp string => NSString
    515 ;;;   - Lisp numbers  => SINGLE-FLOAT when possible
    516 
    517 (defmacro coerce-to-bool (x)
    518   (let ((x-temp (gensym)))
    519     `(let ((,x-temp ,x))
    520        (if (or (eq ,x-temp 0) (null ,x-temp)) #$NO #$YES))))
    521 
    522 (defmacro coerce-to-address (x)
    523   (let ((x-temp (gensym)))
    524     `(let ((,x-temp ,x))
    525        (cond ((null ,x-temp) (%null-ptr))
    526              ((stringp ,x-temp) (%make-nsstring ,x-temp))
    527              (t ,x-temp)))))
    528 
    529 (defmacro coerce-to-foreign-type (x ftype)
    530    (cond ((and (constantp x) (constantp ftype))
    531           (case ftype
    532             (:id (if (null x) `(%null-ptr) (coerce-to-address x)))
    533             (:<BOOL> (coerce-to-bool (eval x)))
    534             (t x)))
    535          ((constantp ftype)
    536           (case ftype
    537             (:id `(coerce-to-address ,x))
    538             (:<BOOL> `(coerce-to-bool ,x))
    539             (t x)))
    540          (t `(case ,(if (atom ftype) ftype)
    541                (:id (coerce-to-address ,x))
    542                (:<BOOL> (coerce-to-bool ,x))
    543                (t ,x)))))
    544 
    545 ;;; Convert a foreign object X to T or NIL
    546 
    547 (defun coerce-from-bool (x)
    548   (cond
    549    ((eq x #$NO) nil)
    550    ((eq x #$YES) t)
    551    (t (error "Cannot coerce ~S to T or NIL" x))))
    552 
    553 
    554 ;;; Convert a set of ARGS with given foreign types to an argspec suitable
    555 ;;; for %FF-CALL
    556 
    557 (defun convert-to-argspecs (argtypes result-ftype args evalargs)
    558   (setq argtypes (mapcar #'fudge-objc-type argtypes))
    559   (setq result-ftype (fudge-objc-type result-ftype))
    560   (flet ((foo (ftype &optional for-result)
    561            (let* ((translated
    562                    (if (member ftype
    563                                '(:unsigned-doubleword :signed-doubleword)
    564                                :test #'eq)
    565                        ftype
    566                      (if for-result
    567                          (translate-foreign-result-type ftype)
    568                        (translate-foreign-arg-type ftype)))))
    569              (if (and (consp translated) (eq (first translated) :record))
    570                #+apple-objc
    571                (ceiling (second translated) target::nbits-in-word)
    572                #+gnu-objc `(:* ,ftype)
    573                translated))))
    574     (nconc
    575      (loop
    576        for a in args
    577        for ftype in argtypes
    578        do (ensure-foreign-type-bits (parse-foreign-type ftype))
    579        append (list (foo ftype)
    580                     (if evalargs
    581                       (coerce-to-foreign-type a
    582                                               #+apple-objc ftype
    583                                               #+gnu-objc (foo ftype))
    584                       `(coerce-to-foreign-type ,a #+apple-objc ,ftype #+gnu-objc ,(foo ftype)))))
    585      (list (foo result-ftype t)))))
    586  
    587 
    588 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    589 ;;;;                       Boolean Return Hackery                           ;;;;
    590 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     510
     511
    591512
    592513;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    … …  
    827748               (arg (car args)))
    828749          (specs reptype)
    829           (case reptype
    830             (:<BOOL> (specs `(coerce-to-bool ,arg)))
    831             (:id (specs `(coerce-to-address ,arg)))
    832             (t (specs arg)))))
     750          (specs arg)))
    833751      ;;(break "~& arglist = ~s" arglist)
    834752      (if (result-type-requires-structure-return
    … …  
    847765                         `(objc-message-send-super ,super ,msg ,@arglist ,result-spec)
    848766                         `(objc-message-send ,o ,msg ,@arglist ,result-spec))))
    849             (if (eq result-spec :<BOOL>)
    850               `(coerce-from-bool ,form)
    851               form)))))))
     767            form))))))
    852768 
    853769(defun build-call-from-method-info (method-info args vargs o  msg  svarforms sinitforms s super)
    … …  
    864780        super))))
    865781
    866 
    867 
    868 ;;; The %SEND and %SEND/STRET functions for sending general messages
    869 
    870 (defmacro make-general-send (o msg args &optional s super sclassname)
    871   (declare (ignorable sclassname))
    872   `(let ((vargs nil))
    873      (with-ns-exceptions-as-errors
    874       ;; Ensure that MSG is a string
    875       (multiple-value-setq (msg args vargs) (%parse-message (cons ,msg ,args)))
    876       (check-type ,msg string)          ; What else could it be ?
    877       (let* ((message-info (get-objc-message-info ,msg))
    878              (message-accepts-varargs
    879               (getf (objc-message-info-flags message-info)
    880                                     :accepts-varargs)))
    881         ;; If a vararg exists, make sure that the message can accept it
    882         (when (and vargs (not message-accepts-varargs))
    883           (error "Message ~S cannot accept a variable number of arguments" msg))
    884         ;; Lookup method signature.  We can do a runtime type dispatch
    885         ;; on the receiver (if there's any ambiguity) even if we're doing
    886         ;; some flavor of SEND-SUPER, since the next method must have
    887         ;; the same type signature as the receiver.
    888         (let* ((method-info (%lookup-objc-method-info message-info ,o))
    889                (sel (get-selector ,msg)))
    890           ;; Check arg count
    891           (unless (= (length ,args) (objc-message-info-req-args message-info))
    892             (error "Message ~S requires ~a ~d args, but ~d were provided."
    893                    (if vargs "at least" "exactly")
    894                    (objc-message-info-req-args message-info)
    895                    (length args)))
    896           ;; Get method type signature
    897           (let* ((mtsig (objc-method-info-signature method-info))
    898                  (argtypes (rest mtsig))
    899                  (result-type (first mtsig))
    900                  (argspecs1 (convert-to-argspecs argtypes result-type ,args t))
    901                  (argspecs (append (butlast argspecs1) vargs (last argspecs1)))
    902                  (result-spec (first (last argspecs))))
    903             ;; Yes, we're doing all of this at runtime.  Don't even get
    904             ;; me started on %FF-CALL.
    905             ;; Call method
    906             (if (requires-stret-p result-spec)
    907               ,(if (null s)
    908                    ;; STRET required but not provided
    909                    `(error "The message ~S must be sent using SEND/STRET" ,msg)
    910                    ;; STRET required and provided
    911                    (if (null super)
    912                      ;; Regular stret send, invoke objc_msgSend_stret
    913                      `(progn
    914                        (apply #'%ff-call
    915                         (%reference-external-entry-point
    916                          (load-time-value
    917                           (external "_objc_msgSend_stret")))
    918                         :address ,s
    919                         :address ,o
    920                         :address sel
    921                         (progn (setf (car (last argspecs)) :void) argspecs))
    922                        ,s)
    923                      ;; Stret send to super, invoke objc_msgSendSuper_stret
    924                      `(progn
    925                        (apply #'%ff-call
    926                         (%reference-external-entry-point
    927                          (load-time-value
    928                           (external "_objc_msgSendSuper_stret")))
    929                         :address ,s
    930                         :address ,super
    931                         :address sel
    932                         (progn (setf (car (last argspecs)) :void) argspecs)))))
    933               ,(if (null s)
    934                    ;; STRET not required and not provided
    935                    (if (null super)
    936                      ;; Regular send, invoke objc_msgSend
    937                      `(let ((r (apply #'%ff-call
    938                                       (%reference-external-entry-point
    939                                        (load-time-value
    940                                         (external "_objc_msgSend")))
    941                                       :address ,o
    942                                       :address sel
    943                                       argspecs)))
    944                        (if (eq result-type :<BOOL>)
    945                          (coerce-from-bool r)
    946                          r))
    947                   ;;; Send to super, invoke objc_msgSendSuper
    948                      `(let ((r (apply #'%ff-call
    949                                       (%reference-external-entry-point
    950                                        (load-time-value
    951                                         (external "_objc_msgSendSuper")))
    952                                       :address ,super
    953                                       :address sel
    954                                       argspecs)))
    955                        (if (eq result-type :<BOOL>)
    956                          (coerce-from-bool r)
    957                          r)))
    958                    ;; STRET not required but provided
    959                    `(error "The message ~S must be sent using SEND" msg)))))))))
    960 
    961 (defun %send (o msg &rest args)
    962   (declare (optimize (speed 3)) (dynamic-extent args))
    963   (make-general-send o msg args))
    964  
    965 (defun %send/stret (s o msg &rest args)
    966   (declare (optimize (speed 3)) (dynamic-extent args))
    967   (make-general-send o msg args s))
    968782 
    969783
    … …  
    980794    (when (not (stringp cname))
    981795      (setf cname (lisp-to-objc-classname cname)))
    982     (apply #'%send
    983            (send (find-objc-class cname) 'alloc)
    984            (lisp-to-objc-init ks)
    985            vs)))
    986 
    987 
     796    (send-objc-init-message (send (find-objc-class cname) 'alloc)
     797                            ks
     798                            vs)))
    988799
    989800;;; Provide the BRIDGE module

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

    r5729 r5865  
    747747                                                       class
    748748                                                       initargs))
    749             ; The second %SEND below should be SEND eventually
    750             (apply #'%send (%send class 'alloc) (lisp-to-objc-init ks) vs))))
     749            (send-objc-init-message (allocate-objc-object class) ks vs))))
    751750    (unless (%null-ptr-p instance)
    752751      (let* ((raw-ptr (raw-macptr-for-instance instance))

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

    r5728 r5865  
    954954  `(load-objc-selector ,(objc-selector-name s)))
    955955
     956
     957;;; Convert a Lisp object X to a desired foreign type FTYPE
     958;;; The following conversions are currently done:
     959;;;   - T/NIL => #$YES/#$NO
     960;;;   - NIL => (%null-ptr)
     961;;;   - Lisp string => NSString
     962;;;   - Lisp numbers  => SINGLE-FLOAT when possible
     963
     964(defmacro coerce-to-bool (x)
     965  (let ((x-temp (gensym)))
     966    `(let ((,x-temp ,x))
     967       (if (or (eq ,x-temp 0) (null ,x-temp)) #.#$NO #.#$YES))))
     968
     969(defmacro coerce-to-address (x)
     970  (let ((x-temp (gensym)))
     971    `(let ((,x-temp ,x))
     972       (cond ((null ,x-temp) (%null-ptr))
     973             ((stringp ,x-temp) (%make-nsstring ,x-temp))
     974             (t ,x-temp)))))
     975
     976(defmacro coerce-to-foreign-type (x ftype)
     977   (cond ((and (constantp x) (constantp ftype))
     978          (case ftype
     979            (:id (if (null x) `(%null-ptr) (coerce-to-address x)))
     980            (:<BOOL> (coerce-to-bool (eval x)))
     981            (t x)))
     982         ((constantp ftype)
     983          (case ftype
     984            (:id `(coerce-to-address ,x))
     985            (:<BOOL> `(coerce-to-bool ,x))
     986            (t x)))
     987         (t `(case ,(if (atom ftype) ftype)
     988               (:id (coerce-to-address ,x))
     989               (:<BOOL> (coerce-to-bool ,x))
     990               (t ,x)))))
     991
     992(defun objc-arg-coerce (typespec arg)
     993  (coerce-to-foreign-type arg typespec))
     994
     995
     996;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     997;;;;                       Boolean Return Hackery                           ;;;;
     998;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     999
     1000;;; Convert a foreign object X to T or NIL
     1001
     1002(defun coerce-from-bool (x)
     1003  (cond
     1004   ((eq x #$NO) nil)
     1005   ((eq x #$YES) t)
     1006   (t (error "Cannot coerce ~S to T or NIL" x))))
     1007
     1008(defun objc-result-coerce (type result)
     1009  (cond ((eq type :<BOOL>)
     1010         `(coerce-from-bool ,result))
     1011        (t result)))
     1012
    9561013;;; Add a faster way to get the message from a SEL by taking advantage of the
    9571014;;; fact that a selector is really just a canonicalized, interned C string
    … …  
    9771034    (setq argspecs (append argspecs '(:id))))
    9781035  #+apple-objc
    979   `(external-call "_objc_msgSend"
    980     :id ,receiver
    981     :<SEL> (@selector ,selector-name)
    982     ,@argspecs)
     1036  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1037           `(external-call "_objc_msgSend")
     1038           `(:id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
     1039           :arg-coerce 'objc-arg-coerce
     1040           :result-coerce 'objc-result-coerce) 
    9831041  #+gnu-objc
    9841042    (let* ((r (gensym))
    … …  
    9911049                                        :<SEL> ,s
    9921050                                        :<IMP>)))
    993       (ff-call ,imp :id ,r :<SEL> ,s ,@argspecs))))
    994 
    995 ;;; A method that returns a structure (whose size is > 4 bytes on
    996 ;;; darwin, in all cases on linuxppc) does so by copying the structure
    997 ;;; into a pointer passed as its first argument; that means that we
    998 ;;; have to invoke the method via #_objc_msgSend_stret in the #+apple-objc
    999 ;;; case.
     1051      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1052       `(%ff-call ,imp)
     1053       `(:id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
     1054       :arg-coerce 'objc-arg-coerce
     1055       :result-coerce 'objc-result-coerce))))
     1056
     1057;;; A method that returns a structure does so by platform-dependent
     1058;;; means.  One of those means (which is fairly common) is to pass a
     1059;;; pointer to an instance of a structure type as a first argument to
     1060;;; the method implementation function (thereby making SELF the second
     1061;;; argument, etc.), but whether or not it's actually done that way
     1062;;; depends on the platform and on the structure type.  The special
     1063;;; variable CCL::*TARGET-FTD* holds a structure (of type
     1064;;; CCL::FOREIGN-TYPE-DATA) which describes some static attributes of
     1065;;; the foreign type system on the target platform and contains some
     1066;;; functions which can determine dynamic ABI attributes.  One such
     1067;;; function can be used to determine whether or not the "invisible
     1068;;; first arg" convention is used to return structures of a given
     1069;;; foreign type; another function in *TARGET-FTD* can be used to
     1070;;; construct a foreign function call form that handles
     1071;;; structure-return and structure-types-as-arguments details.  In the
     1072;;; Apple ObjC runtime, #_objc_msgSend_stret must be used if the
     1073;;; invisible-first-argument convention is used to return a structure
     1074;;; and must NOT be used otherwise. (The Darwin ppc64 and all
     1075;;; supported x86-64 ABIs often use more complicated structure return
     1076;;; conventions than ppc32 Darwin or ppc Linux.)  We should use
     1077;;; OBJC-MESSAGE-SEND-STRET to send any message that returns a
     1078;;; structure or union, regardless of how that structure return is
     1079;;; actually implemented.
    10001080
    10011081(defmacro objc-message-send-stret (structptr receiver selector-name &rest argspecs)
    1002   (if (evenp (length argspecs))
    1003     (setq argspecs (append argspecs '(:void)))
    1004     (unless (member (car (last argspecs)) '(:void nil))
    1005       (error "Invalid result spec for structure return: ~s"
    1006              (car (last argspecs)))))
    1007   #+apple-objc
    1008   `(external-call "_objc_msgSend_stret"
    1009     :address ,structptr
    1010     :id ,receiver
    1011     :<SEL> (@selector ,selector-name)
    1012     ,@argspecs)
     1082    #+apple-objc
     1083    (let* ((return-typespec (car (last argspecs)))
     1084           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
     1085                         "_objc_msgSend_stret"
     1086                         "_objc-msgSend")))
     1087      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1088               `(%ff-call (external ,entry-name))
     1089               `(,structptr :id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
     1090               :arg-coerce 'objc-arg-coerce
     1091               :result-coerce 'objc-result-coerce))
    10131092    #+gnu-objc
    10141093    (let* ((r (gensym))
    … …  
    10211100                                         :<SEL> ,s
    10221101                                         :<IMP>)))
    1023       (ff-call ,imp :address ,structptr :id ,r :<SEL> ,s ,@argspecs))))
     1102      ,      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1103               `(%ff-call ,imp)
     1104              `(,structptr :id , :<SEL> ,s ,@argspecs)
     1105               :arg-coerce 'objc-arg-coerce
     1106               :result-coerce 'objc-result-coerce))))
    10241107
    10251108;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument
    … …  
    10311114    (setq argspecs (append argspecs '(:id))))
    10321115  #+apple-objc
    1033   `(external-call "_objc_msgSendSuper"
    1034     :address ,super
    1035     :<SEL> (@selector ,selector-name)
    1036     ,@argspecs)
     1116  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1117           `(%ff-call (external "_objc_msgSendSuper"))
     1118           `(:address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
     1119           :arg-coerce 'objc-arg-coerce
     1120           :result-coerce 'objc-result-coerce)
    10371121  #+gnu-objc
    10381122  (let* ((sup (gensym))
    … …  
    10451129                                         :<SEL> ,sel
    10461130                                         :<IMP>)))
    1047       (ff-call ,imp
    1048        :id (pref ,sup :<S>uper.self)
    1049        :<SEL> ,sel
    1050        ,@argspecs))))
    1051 
    1052 ;;; Send to superclass method, returning a structure.
     1131  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1132   `(%ff-call ,imp)
     1133   `(:id (pref ,sup :<S>uper.self)
     1134     :<SEL> ,sel
     1135     ,@argspecs)))))
     1136
     1137;;; Send to superclass method, returning a structure. See above.
    10531138(defmacro objc-message-send-super-stret
    10541139    (structptr super selector-name &rest argspecs)
    1055   (if (evenp (length argspecs))
    1056     (setq argspecs (append argspecs '(:void)))
    1057     (unless (member (car (last argspecs)) '(:void nil))
    1058       (error "Invalid result spec for structure return: ~s"
    1059              (car (last argspecs)))))
    10601140  #+apple-objc
    1061   `(external-call "_objc_msgSendSuper_stret"
    1062     :address ,structptr
    1063     :address ,super
    1064     :<SEL> (@selector ,selector-name)
    1065     ,@argspecs)
     1141    (let* ((return-typespec (car (last argspecs)))
     1142           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
     1143                         "_objc_msgSendSuper_stret"
     1144                         "_objc-msgSendSuper")))
     1145      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1146               `(%ff-call (external ,entry-name))
     1147               `(,structptr :address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
     1148               :arg-coerce 'objc-arg-coerce
     1149               :result-coerce 'objc-result-coerce))
    10661150  #+gnu-objc
    10671151  (let* ((sup (gensym))
    … …  
    10741158                                         :<SEL> ,sel
    10751159                                         :<IMP>)))
    1076       (ff-call ,imp
    1077        :address ,structptr
     1160      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1161       `(%ff-call ,imp)
     1162       ,structptr
    10781163       :id (pref ,sup :<S>uper.self)
    10791164       :<SEL> ,sel
    … …  
    14301515     "initWithCString:" :address s)))
    14311516
     1517
     1518(let* ((objc-init-message-args (make-array 10 :fill-pointer 0 :adjustable t)))
     1519  (defun %objc-init-message-arg (n)
     1520    (let* ((len (length objc-init-message-args)))
     1521      (do* ((i len (1+ i)))
     1522           ((> i n) (aref objc-init-message-args n))
     1523        (vector-push-extend (intern (format nil "ARG~d" i)) objc-init-message-args)))))
     1524
     1525(defun objc-init-message-arglist (n)
     1526  (collect ((args))
     1527    (dotimes (i n (args)) (args (%objc-init-message-arg i)))))
     1528
     1529
     1530(defun %make-objc-init-function-for-signature (signature)
     1531  ;; No structure returns or send-supers involved.
     1532  (let* ((types (cdr signature))
     1533         (args (objc-init-message-arglist (length types))))
     1534    (collect ((call))
     1535      (dolist (arg args)
     1536        (let* ((type (pop types)))
     1537          (call type)
     1538          (case type
     1539            (:<BOOL> (call `(coerce-to-bool ,arg)))
     1540            (:id (call `(coerce-to-address ,arg)))
     1541            (otherwise (call arg)))))
     1542      ;; all "init" messages return :id
     1543      (call :id)
     1544      (compile nil
     1545               `(lambda (self selector ,@args)
     1546                 #+apple-objc
     1547                 (external-call "_objc_msgSend"
     1548                  :id self
     1549                  :<SEL> (%get-selector selector)
     1550                  ,@(call))
     1551                 #+gnu-objc
     1552                 (let* ((s (%get-selector selector))
     1553                        (imp (external-call "objc_msg_lookup"
     1554                                            :id self
     1555                                            :<SEL> s
     1556                                            :<IMP>)))
     1557                   (ff-call imp :id self :<SEL> s ,@(call))))))))
     1558
     1559(defstruct objc-init-method-signature-info
     1560  signature
     1561  function)
     1562
     1563(defvar *objc-init-method-signatures* (make-hash-table :test #'equal)
     1564  "Maps signature lists to OBJC-INIT-METHOD-SIGNATURE-INFO structures.")
     1565
     1566(defun get-objc-init-method-signature-info (list)
     1567  (or (gethash list *objc-init-method-signatures*)
     1568      (setf (gethash list *objc-init-method-signatures*)
     1569            (make-objc-init-method-signature-info
     1570             :signature list
     1571             :function (%make-objc-init-function-for-signature list)))))
     1572
     1573(defstruct objc-init-message-info
     1574  selector
     1575  method-signature-alist
     1576  )
     1577
     1578(defvar  *objc-init-messages-for-message-names* (make-hash-table :test #'equal)
     1579  "Maps from init message names to OBJC-INIT-MESSAGE-INFO structures.")
     1580
     1581(defun register-objc-init-message (message-info)
     1582  (when (dolist (m (objc-message-info-methods message-info))
     1583          (unless (getf (objc-method-info-flags m) :protocol)
     1584            (let* ((sig (objc-method-info-signature m)))
     1585              (unless (eq (car (last sig)) :void)
     1586                (when (eq :id (car (objc-method-info-signature m)))
     1587                  (return t))))))
     1588    (let* ((name (objc-message-info-message-name message-info))
     1589           (init-info
     1590            (or (gethash name *objc-init-messages-for-message-names*)
     1591                (setf (gethash name *objc-init-messages-for-message-names*)
     1592                      (make-objc-init-message-info
     1593                       :selector (load-objc-selector name)
     1594                       :method-signature-alist nil))))
     1595           (alist (objc-init-message-info-method-signature-alist init-info)))
     1596      (dolist (m (objc-message-info-methods message-info))
     1597        (let* ((sig (objc-method-info-signature m)))
     1598          (when (and (eq :id (car sig))
     1599                     (not (getf (objc-method-info-flags m) :protocol)))
     1600            ;; Looks like a real init method.
     1601            (let* ((class (canonicalize-registered-class (lookup-objc-class (objc-method-info-class-name m))))
     1602                   (siginfo (get-objc-init-method-signature-info sig))
     1603                   (pair (assoc siginfo alist :test #'eq)))
     1604              (if (null pair)
     1605                (push (cons siginfo (list class)) alist)
     1606                (pushnew class (cdr pair) :test #'eq))))))
     1607      (setf (objc-init-message-info-method-signature-alist init-info) alist)
     1608      init-info)))
     1609
     1610(defun send-init-message-with-info (instance init-info args)
     1611  (let* ((selector (objc-init-message-info-selector init-info))
     1612         (alist (objc-init-message-info-method-signature-alist init-info))
     1613         (pair (do* ((alist alist (cdr alist)))
     1614                    ((null (cdr alist))
     1615                     (car alist)
     1616                     (let* ((pair (car alist)))
     1617                       (dolist (class (cdr pair))
     1618                         (when (typep instance class)
     1619                           (return pair))))))))
     1620    (with-ns-exceptions-as-errors
     1621        (apply (objc-init-method-signature-info-function (car pair))
     1622               instance
     1623               selector
     1624               args))))
     1625                                                       
     1626
     1627;;; Register init-message-info for all known init messages.  (A
     1628;;; message is an "init message" if it starts with the string "init",
     1629;;; accepts a fixed number of arguments, and has at least one declared
     1630;;; method that returns :ID and is not a protocol method.
     1631(defun register-objc-init-messages ()
     1632  (do-interface-dirs (d)
     1633    (dolist (init (cdb-enumerate-keys (db-objc-methods d)
     1634                                      #'(lambda (string)
     1635                                          (string= string "init" :end1 (min (length string) 4)))))
     1636      (register-objc-init-message (get-objc-message-info init)))))
     1637
     1638   
     1639(defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal)
     1640  "Maps from lists of init keywords to OBJC-INIT-MESSAGE structures")
     1641
     1642(defun send-objc-init-message-with-info (instance init-info args)
     1643  (let* ((selector (objc-init-message-info-selector init-info))
     1644         (alist (objc-init-message-info-method-signature-alist init-info))
     1645         (pair (do* ((alist alist (cdr alist)))
     1646                    ((null (cdr alist))
     1647                     (car alist)
     1648                     (let* ((pair (car alist)))
     1649                       (dolist (class (cdr pair))
     1650                         (when (typep instance class)
     1651                           (return pair))))))))
     1652    (with-ns-exceptions-as-errors
     1653        (apply (objc-init-method-signature-info-function (car pair))
     1654               instance
     1655               selector
     1656               args))))
     1657
     1658
     1659(defun send-objc-init-message (instance init-keywords args)
     1660  (let* ((info (gethash init-keywords *objc-init-messages-for-init-keywords*)))
     1661    (unless info
     1662      (let* ((name (lisp-to-objc-init init-keywords))
     1663             (name-info (gethash name *objc-init-messages-for-message-names*)))
     1664        (unless name-info
     1665          (error "Unknown ObjC init message: ~s" name))
     1666        (setf (gethash init-keywords *objc-init-messages-for-init-keywords*)
     1667              (setq info name-info))))
     1668    (send-objc-init-message-with-info instance info args)))   
     1669                   
     1670(defun allocate-objc-object (class)
     1671  (send class 'alloc))
     1672 
     1673
     1674                 
     1675
    14321676;;; Return the "canonical" version of P iff it's a known ObjC class
    14331677(defun objc-class-p (p)
    … …  
    17101954        (t (bad-selector "general failure")))
    17111955      ;; If the result type is of the form (:STRUCT <typespec> <name>),
    1712       ;; make <name> be the first argument (of type :address) and
    1713       ;; make the resulttype :void
     1956      ;; make <name> be the first argument.
    17141957      (when (and (consp resulttype)
    17151958                 (eq (car resulttype) :struct))
    17161959        (destructuring-bind (typespec name) (cdr resulttype)
    1717         (if (and (typep name 'symbol)
    1718                  (typep (parse-foreign-type `(:struct ,typespec))
    1719                         'foreign-record-type))
    1720           (setq struct-return name
    1721                 resulttype `(:struct ,typespec))
    1722           (bad-selector "Bad struct return type"))))
     1960          (let* ((rtype (%foreign-type-or-record typespec)))
     1961            (if (and (typep name 'symbol)
     1962                     (typep rtype 'foreign-record-type))
     1963              (setq struct-return name
     1964                    resulttype (unparse-foreign-type rtype))
     1965              (bad-selector "Bad struct return type")))))
    17231966      (values selector
    17241967              class-name
    … …  
    17662009               (params `(:id ,self :<sel> ,_cmd)))
    17672010          (when struct-return
    1768             (setq params `(:address ,struct-return ,@params)
    1769                   resulttype :void))
     2011            (push struct-return params))
    17702012          (setq params (nconc params argspecs))
    17712013          `(progn
    … …  
    17982040                           (send-super/stret (s msg &rest args &environment env)
    17992041                             (make-optimized-send nil msg args env s ',super ,class-name)))
    1800                   (flet ((%send-super (msg &rest args)
    1801                            (make-general-send nil msg args nil ,super ,class-name))
    1802                          (%send-super/stret (s msg &rest args)
    1803                            (make-general-send nil msg args s ,super ,class-name))
    1804                          (super () ,super))
    1805                     ,@body))))
     2042                  ,@body)))
    18062043            (%define-lisp-objc-method
    18072044             ',impname

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

    r5727 r5865  
    7474
    7575(map-objc-classes)
     76(register-objc-init-messages)
    7677
    7778#+gnu-objc
Note: See TracChangeset for help on using the changeset viewer.