Changeset 6684


Ignore:
Timestamp:
Jun 8, 2007, 3:15:38 PM (17 years ago)
Author:
Gary Byers
Message:

open-code some cases of SLOT-VALUE on foreign slots.
non-:ID foreign pointers have their types asserted.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/ide-1.0/ccl/examples/objc-clos.lisp

    r6610 r6684  
    511511
    512512(defun compute-foreign-slot-accessors (eslotd)
    513   (let* ((ftype (foreign-slot-definition-foreign-type eslotd)))
     513  (let* ((ftype (foreign-slot-definition-foreign-type eslotd))
     514         (ordinal (foreign-type-ordinal ftype)))
    514515    (etypecase ftype
    515516      (foreign-integer-type
    … …  
    538539       (values #'%get-single-float #'%set-single-float))
    539540      (foreign-pointer-type
    540        ;; If we're pointing to a structure whose first field is
    541        ;; a pointer to a structure named :OBJC_CLASS, we're of
    542        ;; type :ID and can (fairly) safely use %GET-PTR.
    543        ;; Otherwise, reference the field as a raw  macptr.
    544        (let* ((to (foreign-pointer-type-to ftype)))
    545          (if
    546            (and (typep to 'foreign-record-type)
    547                 (eq :struct (foreign-record-type-kind to))
    548                 (progn
    549                   (ensure-foreign-type-bits to)
    550                   (let* ((first-field (car (foreign-record-type-fields to)))
    551                          (first-field-type
    552                           (if first-field
    553                             (foreign-record-field-type first-field))))
    554                     (and (typep first-field-type 'foreign-pointer-type)
    555                          (let* ((first-to (foreign-pointer-type-to
    556                                            first-field-type)))
    557                            (and (typep first-to 'foreign-record-type)
    558                                 (eq :struct
    559                                     (foreign-record-type-kind first-to))
    560                                 (eq :objc_class
    561                                     (foreign-record-type-name first-to))))))))
    562            (values #'%get-ptr #'%set-ptr)
    563            (values #'(lambda (ptr offset)
    564                        (let* ((p (%null-ptr)))
    565                          (%set-macptr-domain p 1)
    566                          (%setf-macptr p (%get-ptr ptr offset))))
    567                    #'%set-ptr))))
     541       (if (objc-id-type-p ftype)
     542         (values #'%get-ptr #'%set-ptr)
     543         (let* ((to (foreign-pointer-type-to ftype))
     544                (to-ordinal (if to (foreign-type-ordinal to) 0)))
     545           (values #'(lambda (ptr offset)
     546                       (let* ((p (%null-ptr)))
     547                         (%set-macptr-domain p 1)
     548                         (%set-macptr-type p to-ordinal)
     549                         (%setf-macptr p (%get-ptr ptr offset))))
     550                   #'%set-ptr))))
    568551      (foreign-mem-block-type
    569552       (let* ((nbytes (%foreign-type-or-record-size ftype :bytes)))
    570          (values #'%inc-ptr #'(lambda (pointer offset new)
     553         (values #'(lambda (ptr offset)
     554                     (let* ((p (%inc-ptr ptr offset)))
     555                       (%set-macptr-type p ordinal)
     556                       p))
     557                 #'(lambda (pointer offset new)
    571558                                (setf (%composite-pointer-ref
    572559                                       nbytes
    … …  
    905892
    906893
    907 ;;; This (interesting) code has never been enabled, and is (slightly)
    908 ;;; broken by the new (lazy, declaration-based) implementation of SEND
    909 ;;; and friends.
    910 ;;; We probably want to un-break this (and figure out how to define
    911 ;;; ObjC gf's in the new world), and some of the code for compiling
    912 ;;; arbitrary message sends may be useful in other contexts.
    913 
    914 #+objc-generic-functions
    915 (progn
    916 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    917 ;;;;                 Generic Function and Method  Protocols                 ;;;;
    918 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    919 
    920 ;;; The classes of ObjC generic functions and methods
    921 
    922 (defclass objc-generic-function (standard-generic-function)
    923   ()
    924   (:metaclass funcallable-standard-class))
    925 
    926 (defclass objc-method (standard-method) ())
    927 
    928 
    929 ;;; Return the generic function name, lambda list and keywords corresponding
    930 ;;; to a given ObjC MSG
    931 
    932 (defun gfify (msg)
    933   (let* ((mcomps (split-if-char #\: msg :elide))
    934          (ncolons (count #\: msg))
    935          (prefix (if (zerop ncolons) "@" "")))
    936     (values (compute-lisp-name
    937              (if (zerop ncolons)
    938                  (string-cat prefix (first mcomps))
    939                (first mcomps))
    940              (find-package "NS"))
    941             (if (zerop ncolons) '(%self) '(%self %arg &key))
    942             (mapcar #'compute-lisp-name (rest mcomps)))))
    943 
    944 
    945 ;;; Special dcode for ObjC generic functions
    946 ;;; Currently, the list of keywords is used as the qualifier for an ObjC method
    947 ;;; This dcode just scans the list of methods looking for one whose qualifer
    948 ;;; matches the keywords in this call
    949 
    950 (defun %%objc-dcode (dt args)
    951   (flet ((invoke-method (largs)
    952            (multiple-value-bind (keys vals) (keys-and-vals (cddr largs))
    953              (declare (ignore vals))
    954              (dolist (m (%gf-dispatch-table-methods dt))
    955                (when (equal (method-qualifiers m) keys)
    956                  (return-from %%objc-dcode (apply (method-function m) largs))))
    957              (apply #'no-applicable-method (%gf-dispatch-table-gf dt) largs))))
    958     ;; If only one arg is present, ARGS is apparently not encoded
    959     (if (numberp args)
    960         (with-list-from-lexpr (l args) (invoke-method l))
    961       (invoke-method (list args)))))
    962 
    963 
    964 ;;; Ensure that the generic function corresponding to MSG exists
    965 
    966 (defun ensure-objc-generic-function (msg)
    967   (cond
    968    ((null (message-descriptors msg))
    969     (error "Unknown ObjC message: ~S" msg))
    970    ((troublesome-message-p msg) nil)
    971    (t
    972     (multiple-value-bind (gf-name lambda-list) (gfify msg)         
    973       (let ((gf (ensure-generic-function
    974                  gf-name
    975                  :lambda-list lambda-list
    976                  :generic-function-class (find-class 'objc-generic-function)
    977                  :method-class (find-class 'objc-method))))
    978         (setf (%gf-dcode gf) #'%%objc-dcode)
    979         gf)))))
    980 
    981 
    982 ;;; Create the method function corresponding to the given ObjC MSG
    983 
    984 (defun make-objc-method-function (msg lambda-list keys)
    985   (let ((msgdescs (message-descriptors msg)))
    986     (compile
    987      nil
    988      (if (= (length msgdescs) 1)
    989          ;; The type signature is unique
    990          `(lambda ,lambda-list
    991             ,(build-message-send
    992               msg (msg-desc-type-signature (first msgdescs)) keys))
    993        ;; The type signature is ambiguous
    994        `(lambda ,lambda-list
    995           (cond
    996            ,@(loop for md in msgdescs
    997                   collect
    998                   `((or
    999                      ,@(loop for c in (msg-desc-classes md)
    1000                              collect
    1001                              `(typep %self ',(class-name c))))
    1002                     (locally
    1003                       (declare (,(class-name (first (msg-desc-classes md)))
    1004                                 %self))
    1005                       ,(build-message-send
    1006                         msg (msg-desc-type-signature md) keys))))))))))
    1007 
    1008 
    1009 ;;; Build the message-sending code for the given message with the given
    1010 ;;; type signature and keys
    1011 
    1012 (defun build-message-send (msg tsig keys)
    1013   (let* ((rvars nil)
    1014          (args (if (zerop (count #\: msg))
    1015                    nil
    1016                  (loop
    1017                   for a in (cons '%arg keys)
    1018                   for ftype in (rest tsig)
    1019                   for r/s-assoc = (coerceable-foreign-record-p ftype)
    1020                   for sname = (gensym)
    1021                   if r/s-assoc
    1022                     do (push (list sname (fudge-objc-type ftype)) rvars)
    1023                     and collect
    1024                     (generate-structure-to-foreign-record-copier-form
    1025                      (record-structure-association-structure-name r/s-assoc)
    1026                      (record-structure-association-record-name r/s-assoc)
    1027                      :struct-name a :record-name sname)
    1028                   else collect a))))
    1029        (if (requires-stret-p (first tsig))
    1030            ;; STRET message send
    1031            (let ((r (gensym)))
    1032              `(rlet ((,r ,(fudge-objc-type (first tsig))) ,@rvars)
    1033                 (send/stret ,r %self ,msg ,@args)
    1034                 ,(create-structure-from-record-form r (cadar tsig))))
    1035          ;; Normal message send
    1036          `(rlet ,rvars
    1037             (send %self ,msg ,@args)))))
    1038 
    1039 
    1040 ;;; Ensure that the method corresponding to CLASS's method for MSG exists
    1041 
    1042 (defun ensure-objc-method (msg)
    1043   (cond
    1044    ((null (message-descriptors msg))
    1045     (error "Unknown ObjC message: ~S" msg))
    1046    ((troublesome-message-p msg) nil)
    1047    (t
    1048     (flet ((keywordify (sym)
    1049              (intern (string sym) (find-package 'keyword))))
    1050       (multiple-value-bind (gf-name lambda-list keys) (gfify msg)
    1051         (let* ((gf (ensure-objc-generic-function msg))
    1052                (lambda-list (append lambda-list keys))
    1053                (m
    1054                 (ensure-method
    1055                  gf-name
    1056                  nil
    1057                  :function (make-objc-method-function msg lambda-list keys)
    1058                  :qualifiers (mapcar #'keywordify keys)
    1059                  :lambda-list lambda-list)))
    1060           (setf (%gf-dcode gf) #'%%objc-dcode)
    1061           m))))))
    1062 
    1063 
    1064 ;;; Generate ObjC methods for all messages in *TYPE-SIGNATURE-TABLE*
    1065 
    1066 (defun define-all-objc-methods ()
    1067   (declare (special *type-signature-table*))
    1068   (maphash #'(lambda (msg ignore)
    1069                (declare (ignore ignore))
    1070                (ensure-objc-method msg))
    1071            *type-signature-table*))
    1072 
    1073 
    1074 ;;; Lisp structures analogous to common Cocoa records
    1075 
    1076 (defstruct (ns-range (:constructor make-ns-range (location length)))
    1077   location
    1078   length)
    1079 
    1080 (defun ns-make-range (loc len)
    1081   (make-ns-range loc len))
    1082 
    1083 (defstruct (ns-point (:constructor make-ns-point (x y)))
    1084   x
    1085   y)
    1086 
    1087 (defun ns-make-point (x y)
    1088   (make-ns-point (coerce x 'single-float) (coerce y 'single-float)))
    1089 
    1090 (defstruct (ns-size (:constructor make-ns-size (width height)))
    1091   width
    1092   height)
    1093 
    1094 (defun ns-make-size (w h)
    1095   (make-ns-size
    1096    (coerce w 'single-float)
    1097    (coerce h 'single-float)))
    1098 
    1099 ;;; Note that this is linear: four fields, rather than an ns-point
    1100 ;;; and an ns-size.
    1101 (defstruct (ns-rect
    1102              (:constructor make-ns-rect
    1103                            (origin.x origin.y size.width size.height)))
    1104   origin.x
    1105   origin.y
    1106   size.width
    1107   size.height)
    1108 
    1109 (defun ns-make-rect (ox oy sw sh)
    1110   (make-ns-rect
    1111    (coerce ox 'single-float)
    1112    (coerce oy 'single-float)
    1113    (coerce sw 'single-float)
    1114    (coerce sh 'single-float)))
    1115 
    1116 (defstruct (ns-decimal
    1117             (:constructor make-ns-decimal
    1118                           (_exponent _length _is-negative _is-compact _reserved _mantissa)))
    1119   _exponent
    1120   _length
    1121   _is-negative
    1122   _is-compact
    1123   _reserved
    1124   _mantissa)
    1125 
    1126 ;;; Also linear
    1127 (defstruct (cg-rect
    1128             (:constructor make-cg-rect
    1129                           (origin.x origin.y size.width size.height)))
    1130   origin.x
    1131   origin.y
    1132   size.width
    1133   size.height)
    1134 
    1135 (defstruct (ns-affine-transform-struct
    1136             (:constructor make-ns-affine-transform-struct
    1137                           (m11 m12 m21 m22 tx ty)))
    1138   m11 m12 m21 m22 tx ty)
    1139 
    1140 
    1141 (defun generate-foreign-record-to-structure-copier-form (record-type-name structure-class-name &key (struct-name (gensym)) (record-name (gensym)))
    1142   (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name))))
    1143          (record-type (%foreign-type-or-record record-type-name))
    1144          (accessor-names (foreign-record-accessor-names record-type)))
    1145     (unless (eq (length slot-names) (length accessor-names))
    1146       (error "Slot names ~s don't match record accessors ~s"
    1147              slot-names accessor-names))
    1148     (let* ((body (mapcar #'(lambda (slot-name accessor)
    1149                              `(setf (slot-value ,struct-name ',slot-name)
    1150                                ,(%foreign-access-form record-name
    1151                                                       record-type
    1152                                                       0
    1153                                                       accessor)))
    1154                          slot-names accessor-names)))
    1155       `(progn ,@body ,struct-name))))
    1156 
    1157 (defun generate-structure-to-foreign-record-copier-form
    1158     (structure-class-name record-type-name
    1159                           &key
    1160                           (struct-name (gensym))
    1161                           (record-name (gensym)))
    1162   (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name))))
    1163          (record-type (%foreign-type-or-record record-type-name))
    1164          (accessor-names (foreign-record-accessor-names record-type)))
    1165     (unless (eq (length slot-names) (length accessor-names))
    1166       (error "Slot names ~s don't match record accessors ~s"
    1167              slot-names accessor-names))
    1168     (let* ((body (mapcar #'(lambda (slot-name accessor)
    1169                              `(setf ,(%foreign-access-form record-name
    1170                                                            record-type
    1171                                                            0
    1172                                                            accessor)
    1173                                (slot-value ,struct-name ',slot-name)))
    1174                          slot-names accessor-names)))
    1175       `(progn ,@body ,record-name))))
    1176 
    1177 (defun generate-foreign-record-to-structure-creator-form
    1178     (record-type-name constructor-name &key (record-name (gensym)))
    1179   (let* ((record-type (%foreign-type-or-record record-type-name))
    1180          (accessor-names (foreign-record-accessor-names record-type))
    1181          (args (mapcar #'(lambda (accessor)
    1182                            (%foreign-access-form record-name
    1183                                                  record-type
    1184                                                  0
    1185                                                  accessor))
    1186                        accessor-names)))
    1187     `(,constructor-name ,@args)))
    1188 
    1189            
    1190 (defstruct record-structure-association
    1191   record-name
    1192   structure-name
    1193   structure-constructor-name)
    1194 
    1195 (defparameter *record-structure-associations* ())
    1196 
    1197 (defun record-structure-association-from-record-name (r)
    1198   (find r *record-structure-associations* :key #'record-structure-association-record-name))
    1199 
    1200 (defun need-record-structure-association-from-record-name (r)
    1201   (or (record-structure-association-from-record-name r)
    1202       (error "No lisp structure associated with foreign record named ~s" r)))
    1203  
    1204 (defun record-structure-association-from-structure-name (r)
    1205   (find r *record-structure-associations* :key #'record-structure-association-structure-name))
    1206 
    1207 (defun associate-record-with-structure (record-name structure-name constructor-name)
    1208   (let* ((already-r (record-structure-association-from-record-name record-name))
    1209          (already-s (record-structure-association-from-structure-name structure-name))
    1210          (already (or already-r already-s))
    1211          (different (not (eq already-r already-s))))
    1212     (if already
    1213       (if different
    1214         (if already-r
    1215           (error "~&Record named ~s is already associated with structure named ~s"
    1216                  (record-structure-association-record-name already-r)
    1217                  (record-structure-association-structure-name already-r))
    1218           (if already-s
    1219             (error "~&Structure named ~s is already associated with record named ~s"
    1220                    (record-structure-association-structure-name already-s)
    1221                    (record-structure-association-record-name already-s))))
    1222         (setf (record-structure-association-structure-constructor-name already)
    1223               constructor-name))
    1224       (push (make-record-structure-association
    1225              :record-name record-name
    1226              :structure-name structure-name
    1227              :structure-constructor-name constructor-name)
    1228             *record-structure-associations*))
    1229     t))
    1230 
    1231 (defun create-structure-from-record-form (var record-type)
    1232   (let* ((a (need-record-structure-association-from-record-name
    1233              record-type))
    1234          (constructor
    1235           (record-structure-association-structure-constructor-name a)))
    1236     (generate-foreign-record-to-structure-creator-form
    1237      record-type constructor :record-name var)))
    1238 
    1239 (defun coerceable-foreign-record-p (ftype)
    1240   (and (consp ftype)
    1241        (eq (first ftype) :struct)
    1242        (find (second ftype) *record-structure-associations*
    1243              :key #'record-structure-association-record-name)))
    1244    
    1245 (associate-record-with-structure :_<NSR>ect 'ns-rect 'make-ns-rect)
    1246 (associate-record-with-structure :_<NSP>oint 'ns-point 'make-ns-point)
    1247 (associate-record-with-structure :_<NSS>ize 'ns-size 'make-ns-size)
    1248 (associate-record-with-structure :_<NSR>ange 'ns-range 'make-ns-range)
    1249 (associate-record-with-structure :<NSD>ecimal 'ns-decimal 'make-ns-decimal)
    1250 (associate-record-with-structure :<CGR>ect 'cg-rect 'make-cg-rect)
    1251 (associate-record-with-structure :_<NSA>ffine<T>ransform<S>truct
    1252                                  'ns-affine-transform-struct
    1253                                  'make-ns-affine-transform-struct)
    1254 ) ; #+objc-generic-functions
     894;;; By the time we see this, the slot name has been transformed to the form
     895;;; "(load-time-value (ensure-slot-id <slot-name>))".
     896;;; This only works if the setter is SETF inverse of the getter.
     897(define-compiler-macro slot-id-value (&whole call instance slot-name &environment env)
     898  (or
     899   (let* ((type nil))
     900     (if (and (symbolp instance)
     901              (subtypep (setq type (cdr (assq 'type (nth-value 2 (variable-information instance env)))))
     902                        'objc:objc-object)
     903              (consp slot-name)
     904              (eq (car slot-name) 'load-time-value)
     905              (consp (cdr slot-name))
     906              (null (cddr slot-name))
     907              (eq (caadr slot-name) 'ensure-slot-id)
     908              (consp (cdadr slot-name))
     909              (null (cddadr slot-name))
     910              (setq slot-name (cadadr slot-name))
     911              (quoted-form-p slot-name)
     912              (setq slot-name (cadr slot-name)))
     913       (let* ((class (find-class type nil))
     914              (eslotd (when class (find slot-name (class-slots class)
     915                                        :key #'slot-definition-name))))
     916         (when (typep eslotd 'foreign-effective-slot-definition)
     917           (let* ((getter (foreign-slot-definition-getter eslotd))
     918                  (name (if (typep getter 'compiled-function)
     919                          (function-name getter))))
     920             (when name
     921               `(,name ,instance ,(slot-definition-location eslotd))))))))
     922   call))
     923
     924
Note: See TracChangeset for help on using the changeset viewer.