Changeset 6228


Ignore:
Timestamp:
Apr 8, 2007, 4:46:02 PM (13 years ago)
Author:
gb
Message:

Compile message send functions per signature.
Handle vararg message sends, partly at runtime.
INIT messages just have their signature info precomputed.
Defining a named OBJC-CLASS makes the class name a static
variable whose value is the class (and likewise for the
metaclass.)
%DECLARE-OBJC-MESSAGE notes method redefinition, cerrors.
OBJC:DEFMETHOD and support for it.

File:
1 edited

Legend:

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

    r5912 r6228  
    4949  (use-interface-dir :gnustep))
    5050
    51 (defpackage "OBJC"
    52   (:use)
    53   (:export "OBJC-OBJECT" "OBJC-CLASS-OBJECT" "OBJC-CLASS" "OBJC-METACLASS"))
     51
    5452
    5553(eval-when (:compile-toplevel :load-toplevel :execute)
     54  (require "OBJC-PACKAGE")
    5655  (require "SPLAY-TREE")
    5756  (require "NAME-TRANSLATION")
    58   ;(require "PROCESS-OBJC-MODULES")
    5957  (require "OBJC-CLOS"))
    6058
     
    6967;;; methods
    7068(defloadvar *objc-protocols* (make-hash-table :test #'equal))
     69
     70(defstruct objc-protocol
     71  name
     72  address)
    7173
    7274(defun lookup-objc-protocol (name)
     
    719721                           "NS"))
    720722                         (meta-super
    721                           (if super (pref super :objc_class.isa))))
     723                          (if super (pref super #+apple-objc :objc_class.isa
     724                                          #+gnu-objc :objc_class.class_pointer))))
    722725                    ;; It's important (here and when initializing the
    723726                    ;; class below) to use the "canonical"
     
    741744                    (setf (objc-metaclass-id-foreign-name meta-id)
    742745                          meta-foreign-name)
    743                     (setf (find-class meta-name) meta)))
     746                    (setf (find-class meta-name) meta)
     747                    (%defglobal meta-name meta)))
    744748                (setf (slot-value class 'direct-slots)
    745749                      (compute-objc-direct-slots-from-info decl class))
     
    756760                (setf (objc-class-id-foreign-name id)
    757761                      name)
    758                 (setf (find-class class-name) class)))))))))
     762                (setf (find-class class-name) class)
     763                (%defglobal class-name class)
     764                class))))))))
    759765                               
    760766
     
    973979           *objc-selectors*))
    974980
     981;;; Find or create a SELECTOR; don't bother resolving it.
     982(defun ensure-objc-selector (name)
     983  (setq name (string name))
     984  (or (gethash name *objc-selectors*)
     985      (setf (gethash name *objc-selectors*)
     986            (make-objc-selector :name name))))
     987
    975988(defun load-objc-selector (name)
    976   (let* ((selector (or (gethash name *objc-selectors*)
    977                        (setf (gethash name *objc-selectors*)
    978                              (make-objc-selector :name name)))))
     989  (let* ((selector (ensure-objc-selector name)))
    979990    (%get-SELECTOR selector nil)
    980991    selector))
     
    10111022  (let ((x-temp (gensym)))
    10121023    `(let ((,x-temp ,x))
    1013        (cond ((null ,x-temp) (%null-ptr))
     1024       (cond ((null ,x-temp) +null-ptr+)
    10141025             ((stringp ,x-temp) (%make-nsstring ,x-temp))
    10151026             (t ,x-temp)))))
     
    11081119       `(%ff-call ,imp)
    11091120       `(:address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
     1121       :arg-coerce 'objc-arg-coerce
     1122       :result-coerce 'objc-result-coerce))))
     1123
     1124(defmacro objc-message-send-with-selector (receiver selector &rest argspecs)
     1125  (when (evenp (length argspecs))
     1126    (setq argspecs (append argspecs '(:id))))
     1127  #+apple-objc
     1128  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1129           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
     1130           `(:address ,receiver :<SEL> (%get-selector ,selector) ,@argspecs)
     1131           :arg-coerce 'objc-arg-coerce
     1132           :result-coerce 'objc-result-coerce) 
     1133  #+gnu-objc
     1134    (let* ((r (gensym))
     1135         (s (gensym))
     1136         (imp (gensym)))
     1137    `(with-macptrs ((,r ,receiver)
     1138                    (,s (%get-selector ,selector))
     1139                    (,imp (external-call "objc_msg_lookup"
     1140                                        :id ,r
     1141                                        :<SEL> ,s
     1142                                        :<IMP>)))
     1143      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1144       `(%ff-call ,imp)
     1145       `(:address ,receiver :<SEL> ,s ,@argspecs)
    11101146       :arg-coerce 'objc-arg-coerce
    11111147       :result-coerce 'objc-result-coerce))))
     
    11621198               :result-coerce 'objc-result-coerce))))
    11631199
     1200(defmacro objc-message-send-stret-with-selector (structptr receiver selector &rest argspecs)
     1201    #+apple-objc
     1202    (let* ((return-typespec (car (last argspecs)))
     1203           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
     1204                         "_objc_msgSend_stret"
     1205                         "_objc_msgSend")))
     1206      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1207               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     1208        `(,structptr :address ,receiver :<SEL> (%get-selector ,selector) ,@argspecs)
     1209               :arg-coerce 'objc-arg-coerce
     1210               :result-coerce 'objc-result-coerce))
     1211    #+gnu-objc
     1212    (let* ((r (gensym))
     1213         (s (gensym))
     1214         (imp (gensym)))
     1215    `(with-macptrs ((,r ,receiver)
     1216                    (,s (%get-selector ,selector))
     1217                    (,imp (external-call "objc_msg_lookup"
     1218                                         :id ,r
     1219                                         :<SEL> ,s
     1220                                         :<IMP>)))
     1221      ,      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1222               `(%ff-call ,imp)
     1223              `(,structptr :address ,receiver :<SEL> ,s ,@argspecs)
     1224               :arg-coerce 'objc-arg-coerce
     1225               :result-coerce 'objc-result-coerce))))
     1226
    11641227;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument
    11651228;;; is a pointer to a structure of type objc_super {self,  the defining
     
    11811244    `(with-macptrs ((,sup ,super)
    11821245                    (,sel (@selector ,selector-name))
     1246                    (,imp (external-call "objc_msg_lookup_super"
     1247                                         :<S>uper_t ,sup
     1248                                         :<SEL> ,sel
     1249                                         :<IMP>)))
     1250  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1251   `(%ff-call ,imp)
     1252   `(:id (pref ,sup :<S>uper.self)
     1253     :<SEL> ,sel
     1254     ,@argspecs)))))
     1255
     1256(defmacro objc-message-send-super-with-selector (super selector &rest argspecs)
     1257  (when (evenp (length argspecs))
     1258    (setq argspecs (append argspecs '(:id))))
     1259  #+apple-objc
     1260  (funcall (ftd-ff-call-expand-function *target-ftd*)
     1261           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
     1262           `(:address ,super :<SEL> ,selector ,@argspecs)
     1263           :arg-coerce 'objc-arg-coerce
     1264           :result-coerce 'objc-result-coerce)
     1265  #+gnu-objc
     1266  (let* ((sup (gensym))
     1267         (sel (gensym))
     1268         (imp (gensym)))
     1269    `(with-macptrs ((,sup ,super)
     1270                    (,sel ,selector)
    11831271                    (,imp (external-call "objc_msg_lookup_super"
    11841272                                         :<S>uper_t ,sup
     
    12211309       ,@argspecs))))
    12221310
     1311(defmacro objc-message-send-super-stret-with-selector
     1312    (structptr super selector &rest argspecs)
     1313  #+apple-objc
     1314    (let* ((return-typespec (car (last argspecs)))
     1315           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
     1316                         "_objc_msgSendSuper_stret"
     1317                         "_objc_msgSendSuper")))
     1318      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1319               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     1320               `(,structptr :address ,super :<SEL> ,selector ,@argspecs)
     1321               :arg-coerce 'objc-arg-coerce
     1322               :result-coerce 'objc-result-coerce))
     1323  #+gnu-objc
     1324  (let* ((sup (gensym))
     1325         (sel (gensym))
     1326         (imp (gensym)))
     1327    `(with-macptrs ((,sup ,super)
     1328                    (,sel ,selector)
     1329                    (,imp (external-call "objc_msg_lookup_super"
     1330                                         :<S>uper_t ,sup
     1331                                         :<SEL> ,sel
     1332                                         :<IMP>)))
     1333      (funcall (ftd-ff-call-expand-function *target-ftd*)
     1334       `(%ff-call ,imp)
     1335       ,structptr
     1336       :id (pref ,sup :<S>uper.self)
     1337       :<SEL> ,sel
     1338       ,@argspecs))))
     1339
     1340(defun message-send-form-for-call (receiver selector args super-p struct-return-var)
     1341  (if struct-return-var
     1342    (if super-p
     1343      `(objc-message-send-super-stret-with-selector ,struct-return-var ,receiver ,selector ,@args)
     1344      `(objc-message-send-stret-with-selector ,struct-return-var ,receiver ,selector ,@args))
     1345    (if super-p
     1346      `(objc-message-send-super-with-selector ,receiver ,selector ,@args)
     1347      `(objc-message-send-with-selector ,receiver ,selector ,@args))))
     1348
     1349
     1350#+(and apple-objc x8664-target)
     1351(defun %process-varargs-list (gpr-pointer fpr-pointer stack-pointer ngprs nfprs nstackargs arglist)
     1352  (dolist (arg-temp arglist)
     1353    (typecase arg-temp
     1354      ((signed-byte 64)
     1355       (if (< ngprs 6)
     1356         (progn
     1357           (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp)
     1358           (incf ngprs))
     1359         (progn
     1360           (setf (paref stack-pointer (:* (:signed 64)) nstackargs) arg-temp)
     1361           (incf nstackargs))))
     1362      ((unsigned-byte 64)
     1363       (if (< ngprs 6)
     1364         (progn
     1365           (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp)
     1366           (incf ngprs))
     1367         (progn
     1368           (setf (paref stack-pointer (:* (:unsigned 64)) nstackargs) arg-temp)
     1369           (incf nstackargs))))
     1370      (macptr
     1371       (if (< ngprs 6)
     1372         (progn
     1373           (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
     1374           (incf ngprs))
     1375         (progn
     1376           (setf (paref stack-pointer (:* :address) nstackargs) arg-temp)
     1377           (incf nstackargs))))
     1378      (single-float
     1379       (if (< nfprs 8)
     1380         (progn
     1381           (setf (%get-single-float fpr-pointer (* nfprs 16))
     1382                 arg-temp)
     1383           (incf nfprs))
     1384         (progn
     1385           (setf (paref stack-pointer (:* :float) (* 2 nstackargs)) arg-temp)
     1386           (incf nstackargs))))
     1387      (double-float
     1388       (if (< nfprs 8)
     1389         (progn
     1390           (setf (%get-double-float fpr-pointer (* nfprs 16))
     1391                 arg-temp)
     1392           (incf nfprs))
     1393         (progn
     1394           (setf (paref stack-pointer (:* :double) nstackargs)
     1395                 arg-temp)
     1396           (incf nstackargs)))))))
     1397
     1398#+(and apple-objc ppc32-target)
     1399(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist)
     1400  (dolist (arg-temp arglist)
     1401    (typecase arg-temp
     1402      ((signed-byte 32)
     1403       (setf (paref gpr-pointer (:* (:signed 32)) ngprs) arg-temp)
     1404       (incf ngprs))
     1405      ((unsigned-byte 32)
     1406       (setf (paref gpr-pointer (:* (:unsigned 32)) ngprs) arg-temp)
     1407       (incf ngprs))
     1408      (macptr
     1409       (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
     1410       (incf ngprs))
     1411      (single-float
     1412       (when (< nfprs 13)
     1413         (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0))
     1414         (incf nfprs))
     1415       (setf (paref gpr-pointer (:* :single-float) ngprs) arg-temp)
     1416       (incf ngprs))
     1417      (double-float
     1418       (when (< nfprs 13)
     1419         (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp)
     1420         (incf nfprs))
     1421       (multiple-value-bind (high low) (double-float-bits arg-temp)
     1422         (setf (paref gpr-pointer (:* :unsigned) ngprs) high)
     1423         (incf ngprs)
     1424         (setf (paref gpr-pointer (:* :unsigned) ngprs) low)
     1425         (incf nfprs)))
     1426      ((or (signed-byte 64)
     1427           (unsigned-byte 64))
     1428       (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 32) arg-temp))
     1429       (incf ngprs)
     1430       (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 0) arg-temp))
     1431       (incf ngprs)))))
     1432
     1433#+(and apple-objc ppc64-target)
     1434(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist)
     1435  (dolist (arg-temp arglist)
     1436    (typecase arg-temp
     1437      ((signed-byte 64)
     1438       (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp)
     1439       (incf ngprs))
     1440      ((unsigned-byte 64)
     1441       (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp)
     1442       (incf ngprs))
     1443      (macptr
     1444       (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
     1445       (incf ngprs))
     1446      (single-float
     1447       (when (< nfprs 13)
     1448         (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0))
     1449         (incf nfprs))
     1450       (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) (single-float-bits arg-temp))
     1451       (incf ngprs))
     1452      (double-float
     1453       (when (< nfprs 13)
     1454         (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp)
     1455         (incf nfprs))
     1456       (setf (paref gpr-pointer (:* :double-float) ngprs) arg-temp)
     1457       (incf ngprs)))))
     1458
     1459                         
     1460#+apple-objc
     1461(eval-when (:compile-toplevel :execute)
     1462  #+x8664-target
     1463  (%def-foreign-type :<MARG> (foreign-pointer-type-to (parse-foreign-type :x86_64_marg_list)))
     1464  #+ppc-target
     1465  (def-foreign-type :<MARG>
     1466      (:struct nil
     1467               (:fp<P>arams (:array :double 13))
     1468               (:linkage (:array :uintptr_t 6))
     1469               (:reg<P>arams (:array :uintptr_t 8))
     1470               (:stack<P>arams (:array :uintptr_t) 0)))
     1471  )
     1472
     1473 
     1474#+(and apple-objc x8664-target)
     1475(defun %compile-varargs-send-function-for-signature (sig)
     1476  (let* ((return-type-spec (car sig))
     1477         (arg-type-specs (butlast (cdr sig)))
     1478         (args (objc-gen-message-arglist (length arg-type-specs)))
     1479         (receiver (gensym))
     1480         (selector (gensym))
     1481         (rest-arg (gensym))
     1482         (arg-temp (gensym))
     1483         (marg-ptr (gensym))
     1484         (regparams (gensym))
     1485         (stackparams (gensym))
     1486         (selptr (gensym))
     1487         (gpr-total (gensym))
     1488         (fpr-total (gensym))
     1489         (stack-total (gensym))
     1490         (n-static-gprs 2)              ;receiver, selptr
     1491         (n-static-fprs 0)
     1492         (n-static-stack-args 0))
     1493    (collect ((static-arg-forms))
     1494      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
     1495      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
     1496      (do* ((args args (cdr args))
     1497            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
     1498           ((null args))
     1499        (let* ((arg (car args))
     1500               (spec (car arg-type-specs))
     1501               (static-arg-type (parse-foreign-type spec))
     1502               (gpr-base (if (< n-static-gprs 6) regparams stackparams))
     1503               (fpr-base (if (< n-static-fprs 8) marg-ptr stackparams))
     1504               (gpr-offset (if (< n-static-gprs 6) n-static-gprs n-static-stack-args))
     1505               (fpr-offset (if (< n-static-fprs 8)
     1506                             (* 16 n-static-fprs)
     1507                             (* 8 n-static-stack-args))))
     1508          (etypecase static-arg-type
     1509            (foreign-integer-type
     1510             (if (eq spec :<BOOL>)
     1511               (setq arg `(%coerce-to-bool ,arg)))
     1512             (static-arg-forms
     1513              `(setf (paref ,gpr-base (:* (
     1514                                           ,(if (foreign-integer-type-signed static-arg-type)
     1515                                                :signed
     1516                                                :unsigned)
     1517                                           ,(foreign-integer-type-bits static-arg-type))) ,gpr-offset)
     1518                ,arg))
     1519             (if (< n-static-gprs 6)
     1520               (incf n-static-gprs)
     1521               (incf n-static-stack-args)))
     1522            (foreign-single-float-type
     1523             (if (eq fpr-base stackparams)
     1524               (setq fpr-offset (* 2 fpr-offset)))
     1525             (static-arg-forms
     1526              `(setf (%get-single-float ,fpr-base ,fpr-offset) ,arg))
     1527             (if (< n-static-fprs 8)
     1528               (incf n-static-fprs)
     1529               (incf n-static-stack-args)))
     1530            (foreign-double-float-type
     1531             (static-arg-forms
     1532              `(setf (%get-double-float ,fpr-base ,fpr-offset) ,arg))
     1533             (if (< n-static-fprs 8)
     1534               (incf n-static-fprs)
     1535               (incf n-static-stack-args)))
     1536            (foreign-pointer-type
     1537             (static-arg-forms
     1538              `(setf (paref ,gpr-base (:* address) ,gpr-offset) ,arg))
     1539             (if (< n-static-gprs 6)
     1540               (incf n-static-gprs)
     1541               (incf n-static-stack-args))))))
     1542      (compile
     1543       nil
     1544       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
     1545         (declare (dynamic-extent ,rest-arg))
     1546         (let* ((,selptr (%get-selector ,selector))
     1547                (,gpr-total ,n-static-gprs)
     1548                (,fpr-total ,n-static-fprs)
     1549                (,stack-total ,n-static-stack-args))
     1550           (dolist (,arg-temp ,rest-arg)
     1551             (if (or (typep ,arg-temp 'double-float)
     1552                     (typep ,arg-temp 'single-float))
     1553               (if (< ,fpr-total 8)
     1554                 (incf ,fpr-total)
     1555                 (incf ,stack-total))
     1556               (if (< ,gpr-total 6)
     1557                 (incf ,gpr-total)
     1558                 (incf ,stack-total))))
     1559           (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size
     1560                                          :<MARG> :bytes)
     1561                                        (* 8 ,stack-total))))
     1562             
     1563             (setf (pref ,marg-ptr :<MARG>.rax) ,fpr-total)
     1564             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams))
     1565                            (,stackparams (pref ,marg-ptr :<MARG>.stack<P>arams)))
     1566               (progn ,@(static-arg-forms))
     1567               (%process-varargs-list ,regparams ,marg-ptr ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg)
     1568               (external-call "_objc_msgSendv"
     1569                              :address ,receiver
     1570                              :address ,selptr
     1571                              :size_t (+ 48 (* 8 ,stack-total))
     1572                              :address ,marg-ptr
     1573                              ,return-type-spec)))))))))
     1574
     1575#+(and apple-objc ppc32-target)
     1576(defun %compile-varargs-send-function-for-signature (sig)
     1577  (let* ((return-type-spec (car sig))
     1578         (arg-type-specs (butlast (cdr sig)))
     1579         (args (objc-gen-message-arglist (length arg-type-specs)))
     1580         (receiver (gensym))
     1581         (selector (gensym))
     1582         (rest-arg (gensym))
     1583         (arg-temp (gensym))
     1584         (marg-ptr (gensym))
     1585         (regparams (gensym))
     1586         (selptr (gensym))
     1587         (gpr-total (gensym))
     1588         (n-static-gprs 2)              ;receiver, selptr
     1589         (n-static-fprs 0))
     1590    (collect ((static-arg-forms))
     1591      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
     1592      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
     1593      (do* ((args args (cdr args))
     1594            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
     1595           ((null args))
     1596        (let* ((arg (car args))
     1597               (spec (car arg-type-specs))
     1598               (static-arg-type (parse-foreign-type spec))
     1599               (gpr-base regparams)
     1600               (fpr-base marg-ptr)
     1601               (gpr-offset (* n-static-gprs 4)))
     1602          (etypecase static-arg-type
     1603            (foreign-integer-type
     1604             (let* ((bits (foreign-type-bits static-arg-type))
     1605                    (signed (foreign-integer-type-signed static-arg-type)))
     1606               (if (> bits 32)
     1607                 (progn
     1608                   (static-arg-forms
     1609                    `(setf (,(if signed '%%get-signed-longlong '%%get-unsigned-long-long)
     1610                            ,gpr-base ,gpr-offset)
     1611                      ,arg))
     1612                   (incf n-static-gprs 2))
     1613                 (progn
     1614                   (if (eq spec :<BOOL>)
     1615                     (setq arg `(%coerce-to-bool ,arg)))
     1616                   (static-arg-forms
     1617                    `(setf (paref ,gpr-base (:* (
     1618                                                 ,(if (foreign-integer-type-signed static-arg-type)
     1619                                                      :signed
     1620                                                      :unsigned)
     1621                                           32)) ,gpr-offset)
     1622                ,arg))
     1623                   (incf n-static-gprs)))))
     1624            (foreign-single-float-type
     1625             (static-arg-forms
     1626              `(setf (paref ,gpr-base (:* :single-float) ,n-static-gprs) ,arg))
     1627             (when (< n-static-fprs 13)
     1628               (static-arg-forms
     1629                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1630                  (float (paref ,gpr-base (:* :single-float) ,n-static-gprs) 0.0d0)))
     1631               (incf n-static-fprs))
     1632             (incf n-static-gprs))
     1633            (foreign-double-float-type
     1634             (static-arg-forms
     1635              `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg))
     1636             (when (< n-static-fprs 13)
     1637               (static-arg-forms
     1638                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1639                  (%get-double-float ,gpr-base ,gpr-offset)))
     1640               (incf n-static-fprs))
     1641             (incf n-static-gprs 2))
     1642            (foreign-pointer-type
     1643             (static-arg-forms
     1644              `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg))
     1645               (incf n-static-gprs)))))
     1646      (compile
     1647       nil
     1648       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
     1649         (declare (dynamic-extent ,rest-arg))
     1650         (let* ((,selptr (%get-selector ,selector))
     1651                (,gpr-total ,n-static-gprs))
     1652           (dolist (,arg-temp ,rest-arg)
     1653             (if (or (typep ,arg-temp 'double-float)
     1654                     (and (typep ,arg-temp 'integer)
     1655                          (if (< ,arg-temp 0)
     1656                            (>= (integer-length ,arg-temp) 32)
     1657                            (> (integer-length ,arg-temp) 32))))
     1658               (incf ,gpr-total 2)
     1659               (incf ,gpr-total 1)))
     1660           (if (> ,gpr-total 8)
     1661             (setq ,gpr-total (- ,gpr-total 8))
     1662             (setq ,gpr-total 0))           
     1663           (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size
     1664                                          :<MARG> :bytes)
     1665                                        (* 4 ,gpr-total))))
     1666             
     1667             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams)))
     1668               (progn ,@(static-arg-forms))
     1669               (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg)
     1670               (external-call "_objc_msgSendv"
     1671                              :address ,receiver
     1672                              :address ,selptr
     1673                              :size_t (+ 32 (* 4 ,gpr-total))
     1674                              :address ,marg-ptr
     1675                              ,return-type-spec)))))))))
     1676
     1677#+(and apple-objc ppc64-target)
     1678(defun %compile-varargs-send-function-for-signature (sig)
     1679  (let* ((return-type-spec (car sig))
     1680         (arg-type-specs (butlast (cdr sig)))
     1681         (args (objc-gen-message-arglist (length arg-type-specs)))
     1682         (receiver (gensym))
     1683         (selector (gensym))
     1684         (rest-arg (gensym))
     1685         (arg-temp (gensym))
     1686         (marg-ptr (gensym))
     1687         (regparams (gensym))
     1688         (selptr (gensym))
     1689         (gpr-total (gensym))
     1690         (n-static-gprs 2)              ;receiver, selptr
     1691         (n-static-fprs 0))
     1692    (collect ((static-arg-forms))
     1693      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
     1694      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
     1695      (do* ((args args (cdr args))
     1696            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
     1697           ((null args))
     1698        (let* ((arg (car args))
     1699               (spec (car arg-type-specs))
     1700               (static-arg-type (parse-foreign-type spec))
     1701               (gpr-base regparams)
     1702               (fpr-base marg-ptr)
     1703               (gpr-offset (* n-static-gprs 8)))
     1704          (etypecase static-arg-type
     1705            (foreign-integer-type
     1706             (if (eq spec :<BOOL>)
     1707               (setq arg `(%coerce-to-bool ,arg)))
     1708             (static-arg-forms
     1709              `(setf (paref ,gpr-base (:* (
     1710                                           ,(if (foreign-integer-type-signed static-arg-type)
     1711                                                :signed
     1712                                                :unsigned)
     1713                                           64)) ,gpr-offset)
     1714                ,arg))
     1715             (incf n-static-gprs))
     1716            (foreign-single-float-type
     1717             (static-arg-forms
     1718              `(setf (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) ,arg))
     1719             (when (< n-static-fprs 13)
     1720               (static-arg-forms
     1721                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1722                  (float (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) 0.0d0)))
     1723               (incf n-static-fprs))
     1724             (incf n-static-gprs))
     1725            (foreign-double-float-type
     1726             (static-arg-forms
     1727              `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg))
     1728             (when (< n-static-fprs 13)
     1729               (static-arg-forms
     1730                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1731                  (%get-double-float ,gpr-base ,gpr-offset)))
     1732               (incf n-static-fprs))
     1733             (incf n-static-gprs 1))
     1734            (foreign-pointer-type
     1735             (static-arg-forms
     1736              `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg))
     1737             (incf n-static-gprs)))))
     1738     
     1739      (progn
     1740        nil
     1741        `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
     1742          (declare (dynamic-extent ,rest-arg))
     1743          (let* ((,selptr (%get-selector ,selector))
     1744                 (,gpr-total ,n-static-gprs))
     1745            (dolist (,arg-temp ,rest-arg)
     1746              (declare (ignore ,arg-temp))
     1747              (incf ,gpr-total 1))
     1748            (if (> ,gpr-total 8)
     1749              (setq ,gpr-total (- ,gpr-total 8))
     1750              (setq ,gpr-total 0))           
     1751            (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size
     1752                                           :<MARG> :bytes)
     1753                                         (* 8 ,gpr-total))))
     1754             
     1755              (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams)))
     1756                (progn ,@(static-arg-forms))
     1757                (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg)
     1758                (external-call "_objc_msgSendv"
     1759                               :address ,receiver
     1760                               :address ,selptr
     1761                               :size_t (+ 64 (* 8 ,gpr-total))
     1762                               :address ,marg-ptr
     1763                               ,return-type-spec)))))))))
     1764
     1765#-(and apple-objc (or x8664-target ppc-target))
     1766(defun %compile-varargs-send-function-for-signature (sig)
     1767  (warn "Varargs function for signature ~s NYI" sig))
     1768
     1769
     1770
     1771(defun %compile-send-function-for-signature (sig &optional super-p)
     1772  (let* ((return-type-spec (car sig))
     1773         (arg-type-specs (cdr sig)))
     1774    (if (eq (car (last arg-type-specs)) :void)
     1775      (%compile-varargs-send-function-for-signature sig)
     1776      (let* ((args (objc-gen-message-arglist (length arg-type-specs)))
     1777             (struct-return-var nil)
     1778             (receiver (gensym))
     1779             (selector (gensym)))
     1780        (collect ((call)
     1781                  (lets))
     1782          (let* ((result-type (parse-foreign-type return-type-spec)))
     1783            (when (typep result-type 'foreign-record-type)
     1784              (setq struct-return-var (gensym))
     1785              (lets `(,struct-return-var (make-gcable-record ,return-type-spec))))
     1786
     1787            (do ((args args (cdr args))
     1788                 (spec (pop arg-type-specs) (pop arg-type-specs)))
     1789                ((null args) (call return-type-spec))
     1790              (let* ((arg (car args)))
     1791                 (call spec)
     1792                 (case spec
     1793                   (:<BOOL> (call `(%coerce-to-bool ,arg)))
     1794                   (:id (call `(%coerce-to-address ,arg)))
     1795                   (t
     1796                    (call arg)))))
     1797            (let* ((call (call))
     1798                   (lets (lets))
     1799                   (body (message-send-form-for-call receiver selector call super-p struct-return-var)))
     1800              (if struct-return-var
     1801                (setq body `(progn ,body ,struct-return-var)))
     1802              (if lets
     1803                (setq body `(let* ,lets
     1804                             ,body)))
     1805              (compile nil
     1806                       `(lambda (,receiver ,selector ,@args)
     1807                         ,body)))))))))
     1808
     1809(defun compile-send-function-for-signature (sig)
     1810  (%compile-send-function-for-signature sig nil))
     1811                           
     1812                   
    12231813
    12241814
     
    15562146            (objc-metaclass-id-foreign-name meta-id) class-name
    15572147            (find-class meta-name) meta)
     2148      (%defglobal name class)
     2149      (%defglobal meta-name meta)
    15582150    class)))
    15592151
     
    15952187  (#_objc_registerClassPair class))
    15962188
    1597 (defun %make-nsstring (string)
    1598   (with-cstrs ((s string))
    1599     (objc-message-send
    1600      (objc-message-send (find-class 'ns:ns-string) "alloc")
    1601      "initWithCString:" :address s)))
    1602 
    1603 
    1604 (let* ((objc-init-message-args (make-array 10 :fill-pointer 0 :adjustable t)))
    1605   (defun %objc-init-message-arg (n)
    1606     (let* ((len (length objc-init-message-args)))
     2189
     2190
     2191
     2192
     2193
     2194
     2195(let* ((objc-gen-message-args (make-array 10 :fill-pointer 0 :adjustable t)))
     2196  (defun %objc-gen-message-arg (n)
     2197    (let* ((len (length objc-gen-message-args)))
    16072198      (do* ((i len (1+ i)))
    1608            ((> i n) (aref objc-init-message-args n))
    1609         (vector-push-extend (intern (format nil "ARG~d" i)) objc-init-message-args)))))
    1610 
    1611 (defun objc-init-message-arglist (n)
     2199           ((> i n) (aref objc-gen-message-args n))
     2200        (vector-push-extend (intern (format nil "ARG~d" i)) objc-gen-message-args)))))
     2201
     2202(defun objc-gen-message-arglist (n)
    16122203  (collect ((args))
    1613     (dotimes (i n (args)) (args (%objc-init-message-arg i)))))
    1614 
    1615 
    1616 (defun %make-objc-init-function-for-signature (signature)
    1617   ;; No structure returns or send-supers involved.
    1618   (let* ((types (cdr signature))
    1619          (args (objc-init-message-arglist (length types))))
    1620     (collect ((call))
    1621       (dolist (arg args)
    1622         (let* ((type (pop types)))
    1623           (call type)
    1624           (case type
    1625             (:<BOOL> (call `(%coerce-to-bool ,arg)))
    1626             (:id (call `(%coerce-to-address ,arg)))
    1627             (otherwise (call arg)))))
    1628       ;; all "init" messages return :id
    1629       (call :id)
    1630       (compile nil
    1631                `(lambda (self selector ,@args)
    1632                  #+apple-objc
    1633                  (external-call "_objc_msgSend"
    1634                   :id self
    1635                   :<SEL> (%get-selector selector)
    1636                   ,@(call))
    1637                  #+gnu-objc
    1638                  (let* ((s (%get-selector selector))
    1639                         (imp (external-call "objc_msg_lookup"
    1640                                             :id self
    1641                                             :<SEL> s
    1642                                             :<IMP>)))
    1643                    (ff-call imp :id self :<SEL> s ,@(call))))))))
    1644 
    1645 (defstruct objc-init-method-signature-info
    1646   signature
    1647   function)
    1648 
    1649 (defvar *objc-init-method-signatures* (make-hash-table :test #'equal)
    1650   "Maps signature lists to OBJC-INIT-METHOD-SIGNATURE-INFO structures.")
    1651 
    1652 (defun get-objc-init-method-signature-info (list)
    1653   (or (gethash list *objc-init-method-signatures*)
    1654       (setf (gethash list *objc-init-method-signatures*)
    1655             (make-objc-init-method-signature-info
    1656              :signature list
    1657              :function (%make-objc-init-function-for-signature list)))))
    1658 
    1659 (defstruct objc-init-message-info
    1660   selector
    1661   method-signature-alist
    1662   )
    1663 
    1664 (defvar  *objc-init-messages-for-message-names* (make-hash-table :test #'equal)
    1665   "Maps from init message names to OBJC-INIT-MESSAGE-INFO structures.")
    1666 
    1667 (defun register-objc-init-message (message-info)
    1668   (when (dolist (m (objc-message-info-methods message-info))
    1669           (unless (getf (objc-method-info-flags m) :protocol)
    1670             (let* ((sig (objc-method-info-signature m)))
    1671               (unless (eq (car (last sig)) :void)
    1672                 (when (eq :id (car (objc-method-info-signature m)))
    1673                   (return t))))))
    1674     (let* ((name (objc-message-info-message-name message-info))
    1675            (init-info
    1676             (or (gethash name *objc-init-messages-for-message-names*)
    1677                 (setf (gethash name *objc-init-messages-for-message-names*)
    1678                       (make-objc-init-message-info
    1679                        :selector (load-objc-selector name)
    1680                        :method-signature-alist nil))))
    1681            (alist (objc-init-message-info-method-signature-alist init-info)))
    1682       (dolist (m (objc-message-info-methods message-info))
    1683         (let* ((sig (objc-method-info-signature m)))
    1684           (when (and (eq :id (car sig))
    1685                      (not (getf (objc-method-info-flags m) :protocol)))
    1686             ;; Looks like a real init method.
    1687             (let* ((class (canonicalize-registered-class (lookup-objc-class (objc-method-info-class-name m))))
    1688                    (siginfo (get-objc-init-method-signature-info sig))
    1689                    (pair (assoc siginfo alist :test #'eq)))
    1690               (if (null pair)
    1691                 (push (cons siginfo (list class)) alist)
    1692                 (pushnew class (cdr pair) :test #'eq))))))
    1693       (setf (objc-init-message-info-method-signature-alist init-info) alist)
    1694       init-info)))
    1695 
    1696 
    1697                                                        
    1698 
    1699 ;;; Register init-message-info for all known init messages.  (A
     2204    (dotimes (i n (args)) (args (%objc-gen-message-arg i)))))
     2205
     2206
     2207
     2208;;; Call get-objc-message-info for all known init messages.  (A
    17002209;;; message is an "init message" if it starts with the string "init",
    1701 ;;; accepts a fixed number of arguments, and has at least one declared
    1702 ;;; method that returns :ID and is not a protocol method.
     2210;;; and has at least one declared method that returns :ID and is not a
     2211;;; protocol method.
    17032212(defun register-objc-init-messages ()
    17042213  (do-interface-dirs (d)
     
    17062215                                      #'(lambda (string)
    17072216                                          (string= string "init" :end1 (min (length string) 4)))))
    1708       (register-objc-init-message (get-objc-message-info init)))))
     2217      (get-objc-message-info init))))
    17092218
    17102219   
    17112220(defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal)
    1712   "Maps from lists of init keywords to OBJC-INIT-MESSAGE structures")
    1713 
    1714 
    1715 
     2221  "Maps from lists of init keywords to dispatch-functions for init messages")
    17162222
    17172223
     
    17212227    (unless info
    17222228      (let* ((name (lisp-to-objc-init init-keywords))
    1723              (name-info (gethash name *objc-init-messages-for-message-names*)))
     2229             (name-info (get-objc-message-info name nil)))
    17242230        (unless name-info
    17252231          (error "Unknown ObjC init message: ~s" name))
    17262232        (setf (gethash init-keywords *objc-init-messages-for-init-keywords*)
    17272233              (setq info name-info))))
    1728     (send-objc-init-message-with-info instance info args)))   
     2234    (apply (objc-message-info-lisp-name info) instance args)))
    17292235                   
    17302236
     
    20492555                          class-name
    20502556                          class-p
    2051                           (parse-foreign-type resulttype)
     2557                          (concise-foreign-type resulttype)
    20522558                          (collect ((argtypes))
    20532559                            (do* ((argspecs argspecs (cddr argspecs)))
    2054                                  ((null argspecs) (mapcar #'parse-foreign-type (argtypes)))
     2560                                 ((null argspecs) (mapcar #'concise-foreign-type (argtypes)))
    20552561                              (argtypes (car argspecs)))))
    20562562    (let* ((self (intern "SELF")))
     
    20892595                                (pref (@class ,class-name)
    20902596                                 #+apple-objc :objc_class.isa
    2091                                  #+gnu-objc :objc_class.super_class )
     2597                                 #+gnu-objc :objc_class.class_pointer)
    20922598                                :objc_class.super_class))
    20932599                             #+apple-objc-2.0
     
    21172623  (objc-method-definition-form t selector-arg class-arg body env))
    21182624
     2625
     2626(declaim (inline %objc-struct-return))
     2627
     2628(defun %objc-struct-return (return-temp size value)
     2629  (unless (eq return-temp value)
     2630    (#_bcopy value return-temp size)))
     2631
     2632(defmacro objc:defmethod (name (self-arg &rest other-args) &body body &environment env)
     2633  (collect ((arglist)
     2634            (arg-names)
     2635            (arg-types)
     2636            (bool-args)
     2637            (type-assertions))
     2638    (let* ((result-type nil)
     2639           (struct-return-var nil)
     2640           (struct-return-size nil)
     2641           (selector nil)
     2642           (cmd (intern "_CMD"))
     2643           (class-p nil)
     2644           (objc-class-name nil))
     2645      (if (atom name)
     2646        (setq selector (string name) result-type :id)
     2647        (setq selector (string (car name)) result-type (concise-foreign-type (or (cadr name) :id))))
     2648      (destructuring-bind (self-name lisp-class-name) self-arg
     2649        (arg-names self-name)
     2650        (arg-types :id)
     2651        ;; Hack-o-rama
     2652        (let* ((lisp-class-name (string lisp-class-name)))
     2653          (if (eq (schar lisp-class-name 0) #\+)
     2654            (setq class-p t lisp-class-name (subseq lisp-class-name 1)))
     2655          (setq objc-class-name (lisp-to-objc-classname lisp-class-name)))
     2656        (let* ((rtype (parse-foreign-type result-type)))
     2657          (when (typep rtype 'foreign-record-type)
     2658            (setq struct-return-var (gensym))
     2659            (setq struct-return-size (ceiling (foreign-type-bits rtype) 8))
     2660            (arglist struct-return-var)))
     2661        (arg-types :<SEL>)
     2662        (arg-names cmd)
     2663        (dolist (arg other-args)
     2664          (if (atom arg)
     2665            (progn
     2666              (arg-types :id)
     2667              (arg-names arg))
     2668            (destructuring-bind (arg-name arg-type) arg
     2669              (let* ((concise-type (concise-foreign-type arg-type)))
     2670                (unless (eq concise-type :id)
     2671                  (let* ((ftype (parse-foreign-type concise-type)))
     2672                    (if (typep ftype 'foreign-pointer-type)
     2673                      (setq ftype (foreign-pointer-type-to ftype)))
     2674                    (if (and (typep ftype 'foreign-record-type)
     2675                             (foreign-record-type-name ftype))
     2676                      (type-assertions `(%set-macptr-type ,arg-name
     2677                                         (foreign-type-ordinal (load-time-value (%foreign-type-or-record ,(foreign-record-type-name ftype)))))))))
     2678                (arg-types concise-type)
     2679                (arg-names arg-name)))))
     2680        (let* ((arg-names (arg-names))
     2681               (arg-types (arg-types)))
     2682          (do* ((names arg-names)
     2683                (types arg-types))
     2684               ((null types) (arglist result-type))
     2685            (let* ((name (pop names))
     2686                   (type (pop types)))
     2687              (arglist type)
     2688              (arglist name)
     2689              (if (eq type :<BOOL>)
     2690                (bool-args `(setq ,name (not (eql ,name 0)))))))
     2691          (let* ((impname (intern (format nil "~c[~a ~a]"
     2692                                          (if class-p #\+ #\-)
     2693                                          objc-class-name
     2694                                          selector)))
     2695                 (typestring (encode-objc-method-arglist arg-types result-type))
     2696                 (signature (cons result-type (cddr arg-types))))
     2697            (multiple-value-bind (body decls) (parse-body body env)
     2698             
     2699              (setq body `((progn ,@(bool-args) ,@(type-assertions) ,@body)))
     2700              (if (eq result-type :<BOOL>)
     2701                (setq body `((%coerce-to-bool ,@body))))
     2702              (when struct-return-var
     2703                (setq body `((%objc-struct-return ,struct-return-var ,struct-return-size ,@body)))
     2704                (setq body `((flet ((struct-return-var-function ()
     2705                                      ,struct-return-var))
     2706                               (declaim (inline struct-return-var-function))
     2707                               ,@body)))
     2708                (setq body `((macrolet ((objc:returning-foreign-struct ((var) &body body)
     2709                                          `(let* ((,var (struct-return-var-function)))
     2710                                            ,@body)))
     2711                               ,@body))))
     2712              (setq body `((flet ((call-next-method (&rest args)
     2713                                  (declare (dynamic-extent args))
     2714                                  (apply (function ,(if class-p
     2715                                                        '%call-next-objc-class-method
     2716                                                        '%call-next-objc-method))
     2717                                         ,self-name
     2718                                         (@class ,objc-class-name)
     2719                                         (@selector ,selector)
     2720                                         ',signature
     2721                                         args)))
     2722                                 (declare (inline call-next-method))
     2723                                 ,@body)))
     2724              `(progn
     2725                (%declare-objc-method
     2726                 ',selector
     2727                 ',objc-class-name
     2728                 ,class-p
     2729                 ',result-type
     2730                 ',(cddr arg-types))
     2731                (defcallback ,impname ( :error-return (condition objc-callback-error-return) ,@(arglist))
     2732                  (declare (ignorable ,self-name ,cmd)
     2733                           (unsettable ,self-name))
     2734                  ,@decls
     2735                  ,@body)
     2736                (%define-lisp-objc-method
     2737                 ',impname
     2738                 ,objc-class-name
     2739                 ,selector
     2740                 ,typestring
     2741                 ,impname
     2742                 ,class-p)))))))))
     2743
     2744     
     2745           
     2746 
     2747
    21192748(defun class-get-instance-method (class sel)
    21202749  #+apple-objc (#_class_getInstanceMethod class sel)
     
    21622791
    21632792
    2164 (defun retain-objc-instance (instance)
    2165   (objc-message-send instance "retain"))
    2166 
    21672793;;; Execute BODY with an autorelease pool
    2168 
    2169 (defun create-autorelease-pool ()
    2170   (objc-message-send
    2171    (objc-message-send (@class "NSAutoreleasePool") "alloc") "init"))
    2172 
    2173 (defun release-autorelease-pool (p)
    2174   (objc-message-send p "release"))
    21752794
    21762795(defmacro with-autorelease-pool (&body body)
     
    21812800        (release-autorelease-pool ,pool-temp)))))
    21822801
    2183 ;;; This can fail if the nsstring contains non-8-bit characters.
    2184 (defun lisp-string-from-nsstring (nsstring)
    2185   (with-macptrs (cstring)
    2186     (%setf-macptr cstring (objc-message-send nsstring "cString" (* :char)))
    2187     (unless (%null-ptr-p cstring)
    2188       (%get-cstring cstring))))
     2802(defun %make-nsstring (string)
     2803  (with-cstrs ((s string))
     2804    (%make-nsstring-from-c-string s)))
    21892805
    21902806#+apple-objc-2.0
     
    22572873
    22582874
    2259 (defun send-objc-init-message-with-info (instance init-info args)
    2260   (let* ((selector (objc-init-message-info-selector init-info))
    2261          (alist (objc-init-message-info-method-signature-alist init-info))
    2262          (pair (do* ((alist alist (cdr alist)))
    2263                     ((null (cdr alist))
    2264                      (car alist)
    2265                      (let* ((pair (car alist)))
    2266                        (dolist (class (cdr pair))
    2267                          (when (typep instance class)
    2268                            (return pair))))))))
    2269     (with-ns-exceptions-as-errors
    2270         (apply (objc-init-method-signature-info-function (car pair))
    2271                instance
    2272                selector
    2273                args))))
     2875
     2876
Note: See TracChangeset for help on using the changeset viewer.