Changeset 6106


Ignore:
Timestamp:
Mar 28, 2007, 6:59:38 AM (12 years ago)
Author:
gb
Message:

Fixes to signature-calling functions; do something like OBJC-MESSAGE-SEND,
with the selector handled differently.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/examples/objc-runtime.lisp

    r6081 r6106  
    11211121       :result-coerce 'objc-result-coerce))))
    11221122
     1123(defmacro objc-message-send-with-selector (receiver selector &rest argspecs)
     1124  (when (evenp (length argspecs))
     1125    (setq argspecs (append argspecs '(:id))))
     1126  #+apple-objc
     1127  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1128           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
     1129           `(:address ,receiver :<SEL> (%get-selector ,selector) ,@argspecs)
     1130           :arg-coerce 'objc-arg-coerce
     1131           :result-coerce 'objc-result-coerce) 
     1132  #+gnu-objc
     1133    (let* ((r (gensym))
     1134         (s (gensym))
     1135         (imp (gensym)))
     1136    `(with-macptrs ((,r ,receiver)
     1137                    (,s (%get-selector ,selector))
     1138                    (,imp (external-call "objc_msg_lookup"
     1139                                        :id ,r
     1140                                        :<SEL> ,s
     1141                                        :<IMP>)))
     1142      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1143       `(%ff-call ,imp)
     1144       `(:address ,receiver :<SEL> ,s ,@argspecs)
     1145       :arg-coerce 'objc-arg-coerce
     1146       :result-coerce 'objc-result-coerce))))
     1147
    11231148;;; A method that returns a structure does so by platform-dependent
    11241149;;; means.  One of those means (which is fairly common) is to pass a
     
    11721197               :result-coerce 'objc-result-coerce))))
    11731198
     1199(defmacro objc-message-send-stret-with-selector (structptr receiver selector &rest argspecs)
     1200    #+apple-objc
     1201    (let* ((return-typespec (car (last argspecs)))
     1202           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
     1203                         "_objc_msgSend_stret"
     1204                         "_objc_msgSend")))
     1205      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1206               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     1207        `(,structptr :address ,receiver :<SEL> (%get-selector ,selector) ,@argspecs)
     1208               :arg-coerce 'objc-arg-coerce
     1209               :result-coerce 'objc-result-coerce))
     1210    #+gnu-objc
     1211    (let* ((r (gensym))
     1212         (s (gensym))
     1213         (imp (gensym)))
     1214    `(with-macptrs ((,r ,receiver)
     1215                    (,s (%get-selector ,selector))
     1216                    (,imp (external-call "objc_msg_lookup"
     1217                                         :id ,r
     1218                                         :<SEL> ,s
     1219                                         :<IMP>)))
     1220      ,      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1221               `(%ff-call ,imp)
     1222              `(,structptr :address ,receiver :<SEL> ,s ,@argspecs)
     1223               :arg-coerce 'objc-arg-coerce
     1224               :result-coerce 'objc-result-coerce))))
     1225
    11741226;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument
    11751227;;; is a pointer to a structure of type objc_super {self,  the defining
     
    11911243    `(with-macptrs ((,sup ,super)
    11921244                    (,sel (@selector ,selector-name))
     1245                    (,imp (external-call "objc_msg_lookup_super"
     1246                                         :<S>uper_t ,sup
     1247                                         :<SEL> ,sel
     1248                                         :<IMP>)))
     1249  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1250   `(%ff-call ,imp)
     1251   `(:id (pref ,sup :<S>uper.self)
     1252     :<SEL> ,sel
     1253     ,@argspecs)))))
     1254
     1255(defmacro objc-message-send-super-with-selector (super selector &rest argspecs)
     1256  (when (evenp (length argspecs))
     1257    (setq argspecs (append argspecs '(:id))))
     1258  #+apple-objc
     1259  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1260           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
     1261           `(:address ,super :<SEL> (%get-selector ,selector) ,@argspecs)
     1262           :arg-coerce 'objc-arg-coerce
     1263           :result-coerce 'objc-result-coerce)
     1264  #+gnu-objc
     1265  (let* ((sup (gensym))
     1266         (sel (gensym))
     1267         (imp (gensym)))
     1268    `(with-macptrs ((,sup ,super)
     1269                    (,sel (%get-selector ,selector))
    11931270                    (,imp (external-call "objc_msg_lookup_super"
    11941271                                         :<S>uper_t ,sup
     
    12311308       ,@argspecs))))
    12321309
    1233 (defun message-send-form-for-call (args result-spec super-p)
    1234   (let* ((form
    1235           #+apple-objc
    1236            (let* ((entry (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) result-spec)
    1237                            (if super-p
    1238                              "_objc_msgSendSuper_stret"
    1239                              "_objc_msgSend_stret")
    1240                            (if super-p
    1241                              "_objc_msgSendSuper"
    1242                              "_objc_msgSend"))))
    1243              `(external-call ,entry ,@args))
    1244            #+gnu-objc
    1245            (break)))
    1246     (if (eq result-spec :<BOOL>)
    1247       `(coerce-from-bool ,form)
    1248       form)))
     1310(defmacro objc-message-send-super-stret-with-selector
     1311    (structptr super selector &rest argspecs)
     1312  #+apple-objc
     1313    (let* ((return-typespec (car (last argspecs)))
     1314           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
     1315                         "_objc_msgSendSuper_stret"
     1316                         "_objc_msgSendSuper")))
     1317      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1318               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     1319               `(,structptr :address ,super :<SEL> (%get-selector ,selector) ,@argspecs)
     1320               :arg-coerce 'objc-arg-coerce
     1321               :result-coerce 'objc-result-coerce))
     1322  #+gnu-objc
     1323  (let* ((sup (gensym))
     1324         (sel (gensym))
     1325         (imp (gensym)))
     1326    `(with-macptrs ((,sup ,super)
     1327                    (,sel (%get-selector ,selector))
     1328                    (,imp (external-call "objc_msg_lookup_super"
     1329                                         :<S>uper_t ,sup
     1330                                         :<SEL> ,sel
     1331                                         :<IMP>)))
     1332      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1333       `(%ff-call ,imp)
     1334       ,structptr
     1335       :id (pref ,sup :<S>uper.self)
     1336       :<SEL> ,sel
     1337       ,@argspecs))))
     1338
     1339(defun message-send-form-for-call (receiver selector args super-p struct-return-var)
     1340  (if struct-return-var
     1341    (if super-p
     1342      `(objc-message-send-super-stret-with-selector ,struct-return-var ,receiver ,selector ,@args)
     1343      `(objc-message-send-stret-with-selector ,struct-return-var ,receiver ,selector ,@args))
     1344    (if super-p
     1345      `(objc-message-send-super-with-selector ,receiver ,selector ,@args)
     1346      `(objc-message-send-with-selector ,receiver ,selector ,@args))))
     1347
    12491348
    12501349#+(and apple-objc x8664-target)
     
    14221521            (when (typep result-type 'foreign-record-type)
    14231522              (setq struct-return-var (gensym))
    1424               (lets `(struct-return-var (make-gcable-record ,return-type-spec)))
    1425               (call struct-return-var))
    1426             (call :id)
    1427             (call receiver)
    1428             (call :<SEL>)
    1429             (call `(%get-selector ,selector))
     1523              (lets `(,struct-return-var (make-gcable-record ,return-type-spec))))
     1524
    14301525            (do ((args args (cdr args))
    14311526                 (spec (pop arg-type-specs) (pop arg-type-specs)))
     
    14401535            (let* ((call (call))
    14411536                   (lets (lets))
    1442                    (body (message-send-form-for-call call return-type-spec super-p)))
     1537                   (body (message-send-form-for-call receiver selector call super-p struct-return-var)))
    14431538              (if struct-return-var
    14441539                (setq body `(progn ,body ,struct-return-var)))
     
    21992294                          class-name
    22002295                          class-p
    2201                           (parse-foreign-type resulttype)
     2296                          (concise-foreign-type resulttype)
    22022297                          (collect ((argtypes))
    22032298                            (do* ((argspecs argspecs (cddr argspecs)))
    2204                                  ((null argspecs) (mapcar #'parse-foreign-type (argtypes)))
     2299                                 ((null argspecs) (mapcar #'concise-foreign-type (argtypes)))
    22052300                              (argtypes (car argspecs)))))
    22062301    (let* ((self (intern "SELF")))
Note: See TracChangeset for help on using the changeset viewer.