Changeset 11358


Ignore:
Timestamp:
Nov 13, 2008, 4:47:00 AM (11 years ago)
Author:
rme
Message:

Compile send functions for varargs method signatures. It might be
close to right...

File:
1 edited

Legend:

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

    r10781 r11358  
    15211521           (incf nstackargs)))))))
    15221522
     1523#+(and apple-objc x8632-target)
     1524(defun %process-varargs-list (ptr index arglist)
     1525  (dolist (arg-temp arglist)
     1526    (typecase arg-temp
     1527      ((signed-byte 32)
     1528       (setf (paref ptr (:* (:signed 32)) index) arg-temp)
     1529       (incf index))
     1530      ((unsigned-byte 32)
     1531       (setf (paref ptr (:* (:unsigned 32)) index) arg-temp)
     1532       (incf index))
     1533      (macptr
     1534       (setf (paref ptr (:* :address) index) arg-temp)
     1535       (incf index))
     1536      (single-float
     1537       (setf (paref ptr (:* :single-float) index) arg-temp)
     1538       (incf index))
     1539      (double-float
     1540       (setf (paref ptr (:* :double-float) index) arg-temp)
     1541       (incf index 2))
     1542      ((or (signed-byte 64)
     1543           (unsigned-byte 64))
     1544       (setf (paref ptr (:* :unsigned) index) (ldb (byte 32 32) arg-temp))
     1545       (incf index)
     1546       (setf (paref ptr (:* :unsigned) index) (ldb (byte 32 0) arg-temp))
     1547       (incf index)))))
     1548
    15231549#+(and apple-objc ppc32-target)
    15241550(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist)
     
    18111837                              ,return-type-spec)))))))))
    18121838
     1839#+(and apple-objc x8632-target)
     1840(defun %compile-varargs-send-function-for-signature (sig)
     1841  (let* ((return-type-spec (car sig))
     1842         (arg-type-specs (butlast (cdr sig)))
     1843         (args (objc-gen-message-arglist (length arg-type-specs)))
     1844         (receiver (gensym))
     1845         (selector (gensym))
     1846         (rest-arg (gensym))
     1847         (arg-temp (gensym))
     1848         (marg-ptr (gensym))
     1849         (static-arg-words 2)           ;receiver, selptr
     1850         (marg-words (gensym))
     1851         (selptr (gensym)))
     1852    (collect ((static-arg-forms))
     1853      (static-arg-forms `(setf (paref ,marg-ptr (:* address) 0) ,receiver))
     1854      (static-arg-forms `(setf (paref ,marg-ptr (:* address) 1) ,selptr))
     1855      (do* ((args args (cdr args))
     1856            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
     1857           ((null args))
     1858        (let* ((arg (car args))
     1859               (spec (car arg-type-specs))
     1860               (static-arg-type (parse-foreign-type spec)))
     1861          (etypecase static-arg-type
     1862            (foreign-integer-type
     1863             (let* ((bits (foreign-type-bits static-arg-type))
     1864                    (signed (foreign-integer-type-signed static-arg-type)))
     1865               (if (> bits 32)
     1866                 (progn
     1867                   (static-arg-forms
     1868                    `(setf (,(if signed '%%get-signed-longlong '%%get-unsigned-long-long)
     1869                             ,marg-ptr (* 4 ,static-arg-words))
     1870                           ,arg))
     1871                   (incf static-arg-words 2))
     1872                 (progn
     1873                   (if (eq spec :<BOOL>)
     1874                     (setq arg `(%coerce-to-bool ,arg)))
     1875                   (static-arg-forms
     1876                    `(setf (paref ,marg-ptr (:*
     1877                                             (,(if (foreign-integer-type-signed
     1878                                                    static-arg-type)
     1879                                                   :signed
     1880                                                   :unsigned)
     1881                                               32)) ,static-arg-words)
     1882                           ,arg))
     1883                   (incf static-arg-words)))))
     1884            (foreign-single-float-type
     1885             (static-arg-forms
     1886              `(setf (paref ,marg-ptr (:* :single-float) ,static-arg-words) ,arg))
     1887             (incf static-arg-words))
     1888            (foreign-double-float-type
     1889             (static-arg-forms
     1890              `(setf (%get-double-float ,marg-ptr (* 4 ,static-arg-words)) ,arg))
     1891             (incf static-arg-words 2))
     1892            (foreign-pointer-type
     1893             (static-arg-forms
     1894              `(setf (paref ,marg-ptr (:* address) ,static-arg-words) ,arg))
     1895             (incf static-arg-words)))))
     1896      (compile
     1897       nil
     1898       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
     1899          (declare (dynamic-extent ,rest-arg))
     1900          (let* ((,selptr (%get-selector ,selector))
     1901                 (,marg-words ,static-arg-words))
     1902            (dolist (,arg-temp ,rest-arg)
     1903              (if (or (typep ,arg-temp 'double-float)
     1904                      (and (typep ,arg-temp 'integer)
     1905                           (if (< ,arg-temp 0)
     1906                             (>= (integer-length ,arg-temp) 32)
     1907                             (> (integer-length ,arg-temp) 32))))
     1908                (incf ,marg-words 2)
     1909                (incf ,marg-words 1)))
     1910            (%stack-block ((,marg-ptr ,marg-words))
     1911              (progn ,@(static-arg-forms))
     1912              (%process-varargs-list ,marg-ptr ,static-arg-words ,rest-arg)
     1913              (external-call "_objc_msgSendv"
     1914                             :address ,receiver
     1915                             :address ,selptr
     1916                             :size_t (* 4 ,marg-words)
     1917                             :address ,marg-ptr
     1918                             ,return-type-spec))))))))
     1919
    18131920#+(and apple-objc ppc64-target)
    18141921(defun %compile-varargs-send-function-for-signature (sig)
     
    18992006                               ,return-type-spec)))))))))
    19002007
    1901 #-(and apple-objc (or x8664-target ppc-target))
    1902 (defun %compile-varargs-send-function-for-signature (sig)
    1903   (warn "Varargs function for signature ~s NYI" sig))
    19042008
    19052009
Note: See TracChangeset for help on using the changeset viewer.