Index: /branches/ide-1.0/ccl/examples/objc-clos.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/objc-clos.lisp (revision 6683) +++ /branches/ide-1.0/ccl/examples/objc-clos.lisp (revision 6684) @@ -511,5 +511,6 @@ (defun compute-foreign-slot-accessors (eslotd) - (let* ((ftype (foreign-slot-definition-foreign-type eslotd))) + (let* ((ftype (foreign-slot-definition-foreign-type eslotd)) + (ordinal (foreign-type-ordinal ftype))) (etypecase ftype (foreign-integer-type @@ -538,35 +539,21 @@ (values #'%get-single-float #'%set-single-float)) (foreign-pointer-type - ;; If we're pointing to a structure whose first field is - ;; a pointer to a structure named :OBJC_CLASS, we're of - ;; type :ID and can (fairly) safely use %GET-PTR. - ;; Otherwise, reference the field as a raw macptr. - (let* ((to (foreign-pointer-type-to ftype))) - (if - (and (typep to 'foreign-record-type) - (eq :struct (foreign-record-type-kind to)) - (progn - (ensure-foreign-type-bits to) - (let* ((first-field (car (foreign-record-type-fields to))) - (first-field-type - (if first-field - (foreign-record-field-type first-field)))) - (and (typep first-field-type 'foreign-pointer-type) - (let* ((first-to (foreign-pointer-type-to - first-field-type))) - (and (typep first-to 'foreign-record-type) - (eq :struct - (foreign-record-type-kind first-to)) - (eq :objc_class - (foreign-record-type-name first-to)))))))) - (values #'%get-ptr #'%set-ptr) - (values #'(lambda (ptr offset) - (let* ((p (%null-ptr))) - (%set-macptr-domain p 1) - (%setf-macptr p (%get-ptr ptr offset)))) - #'%set-ptr)))) + (if (objc-id-type-p ftype) + (values #'%get-ptr #'%set-ptr) + (let* ((to (foreign-pointer-type-to ftype)) + (to-ordinal (if to (foreign-type-ordinal to) 0))) + (values #'(lambda (ptr offset) + (let* ((p (%null-ptr))) + (%set-macptr-domain p 1) + (%set-macptr-type p to-ordinal) + (%setf-macptr p (%get-ptr ptr offset)))) + #'%set-ptr)))) (foreign-mem-block-type (let* ((nbytes (%foreign-type-or-record-size ftype :bytes))) - (values #'%inc-ptr #'(lambda (pointer offset new) + (values #'(lambda (ptr offset) + (let* ((p (%inc-ptr ptr offset))) + (%set-macptr-type p ordinal) + p)) + #'(lambda (pointer offset new) (setf (%composite-pointer-ref nbytes @@ -905,350 +892,33 @@ -;;; This (interesting) code has never been enabled, and is (slightly) -;;; broken by the new (lazy, declaration-based) implementation of SEND -;;; and friends. -;;; We probably want to un-break this (and figure out how to define -;;; ObjC gf's in the new world), and some of the code for compiling -;;; arbitrary message sends may be useful in other contexts. - -#+objc-generic-functions -(progn -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Generic Function and Method Protocols ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The classes of ObjC generic functions and methods - -(defclass objc-generic-function (standard-generic-function) - () - (:metaclass funcallable-standard-class)) - -(defclass objc-method (standard-method) ()) - - -;;; Return the generic function name, lambda list and keywords corresponding -;;; to a given ObjC MSG - -(defun gfify (msg) - (let* ((mcomps (split-if-char #\: msg :elide)) - (ncolons (count #\: msg)) - (prefix (if (zerop ncolons) "@" ""))) - (values (compute-lisp-name - (if (zerop ncolons) - (string-cat prefix (first mcomps)) - (first mcomps)) - (find-package "NS")) - (if (zerop ncolons) '(%self) '(%self %arg &key)) - (mapcar #'compute-lisp-name (rest mcomps))))) - - -;;; Special dcode for ObjC generic functions -;;; Currently, the list of keywords is used as the qualifier for an ObjC method -;;; This dcode just scans the list of methods looking for one whose qualifer -;;; matches the keywords in this call - -(defun %%objc-dcode (dt args) - (flet ((invoke-method (largs) - (multiple-value-bind (keys vals) (keys-and-vals (cddr largs)) - (declare (ignore vals)) - (dolist (m (%gf-dispatch-table-methods dt)) - (when (equal (method-qualifiers m) keys) - (return-from %%objc-dcode (apply (method-function m) largs)))) - (apply #'no-applicable-method (%gf-dispatch-table-gf dt) largs)))) - ;; If only one arg is present, ARGS is apparently not encoded - (if (numberp args) - (with-list-from-lexpr (l args) (invoke-method l)) - (invoke-method (list args))))) - - -;;; Ensure that the generic function corresponding to MSG exists - -(defun ensure-objc-generic-function (msg) - (cond - ((null (message-descriptors msg)) - (error "Unknown ObjC message: ~S" msg)) - ((troublesome-message-p msg) nil) - (t - (multiple-value-bind (gf-name lambda-list) (gfify msg) - (let ((gf (ensure-generic-function - gf-name - :lambda-list lambda-list - :generic-function-class (find-class 'objc-generic-function) - :method-class (find-class 'objc-method)))) - (setf (%gf-dcode gf) #'%%objc-dcode) - gf))))) - - -;;; Create the method function corresponding to the given ObjC MSG - -(defun make-objc-method-function (msg lambda-list keys) - (let ((msgdescs (message-descriptors msg))) - (compile - nil - (if (= (length msgdescs) 1) - ;; The type signature is unique - `(lambda ,lambda-list - ,(build-message-send - msg (msg-desc-type-signature (first msgdescs)) keys)) - ;; The type signature is ambiguous - `(lambda ,lambda-list - (cond - ,@(loop for md in msgdescs - collect - `((or - ,@(loop for c in (msg-desc-classes md) - collect - `(typep %self ',(class-name c)))) - (locally - (declare (,(class-name (first (msg-desc-classes md))) - %self)) - ,(build-message-send - msg (msg-desc-type-signature md) keys)))))))))) - - -;;; Build the message-sending code for the given message with the given -;;; type signature and keys - -(defun build-message-send (msg tsig keys) - (let* ((rvars nil) - (args (if (zerop (count #\: msg)) - nil - (loop - for a in (cons '%arg keys) - for ftype in (rest tsig) - for r/s-assoc = (coerceable-foreign-record-p ftype) - for sname = (gensym) - if r/s-assoc - do (push (list sname (fudge-objc-type ftype)) rvars) - and collect - (generate-structure-to-foreign-record-copier-form - (record-structure-association-structure-name r/s-assoc) - (record-structure-association-record-name r/s-assoc) - :struct-name a :record-name sname) - else collect a)))) - (if (requires-stret-p (first tsig)) - ;; STRET message send - (let ((r (gensym))) - `(rlet ((,r ,(fudge-objc-type (first tsig))) ,@rvars) - (send/stret ,r %self ,msg ,@args) - ,(create-structure-from-record-form r (cadar tsig)))) - ;; Normal message send - `(rlet ,rvars - (send %self ,msg ,@args))))) - - -;;; Ensure that the method corresponding to CLASS's method for MSG exists - -(defun ensure-objc-method (msg) - (cond - ((null (message-descriptors msg)) - (error "Unknown ObjC message: ~S" msg)) - ((troublesome-message-p msg) nil) - (t - (flet ((keywordify (sym) - (intern (string sym) (find-package 'keyword)))) - (multiple-value-bind (gf-name lambda-list keys) (gfify msg) - (let* ((gf (ensure-objc-generic-function msg)) - (lambda-list (append lambda-list keys)) - (m - (ensure-method - gf-name - nil - :function (make-objc-method-function msg lambda-list keys) - :qualifiers (mapcar #'keywordify keys) - :lambda-list lambda-list))) - (setf (%gf-dcode gf) #'%%objc-dcode) - m)))))) - - -;;; Generate ObjC methods for all messages in *TYPE-SIGNATURE-TABLE* - -(defun define-all-objc-methods () - (declare (special *type-signature-table*)) - (maphash #'(lambda (msg ignore) - (declare (ignore ignore)) - (ensure-objc-method msg)) - *type-signature-table*)) - - -;;; Lisp structures analogous to common Cocoa records - -(defstruct (ns-range (:constructor make-ns-range (location length))) - location - length) - -(defun ns-make-range (loc len) - (make-ns-range loc len)) - -(defstruct (ns-point (:constructor make-ns-point (x y))) - x - y) - -(defun ns-make-point (x y) - (make-ns-point (coerce x 'single-float) (coerce y 'single-float))) - -(defstruct (ns-size (:constructor make-ns-size (width height))) - width - height) - -(defun ns-make-size (w h) - (make-ns-size - (coerce w 'single-float) - (coerce h 'single-float))) - -;;; Note that this is linear: four fields, rather than an ns-point -;;; and an ns-size. -(defstruct (ns-rect - (:constructor make-ns-rect - (origin.x origin.y size.width size.height))) - origin.x - origin.y - size.width - size.height) - -(defun ns-make-rect (ox oy sw sh) - (make-ns-rect - (coerce ox 'single-float) - (coerce oy 'single-float) - (coerce sw 'single-float) - (coerce sh 'single-float))) - -(defstruct (ns-decimal - (:constructor make-ns-decimal - (_exponent _length _is-negative _is-compact _reserved _mantissa))) - _exponent - _length - _is-negative - _is-compact - _reserved - _mantissa) - -;;; Also linear -(defstruct (cg-rect - (:constructor make-cg-rect - (origin.x origin.y size.width size.height))) - origin.x - origin.y - size.width - size.height) - -(defstruct (ns-affine-transform-struct - (:constructor make-ns-affine-transform-struct - (m11 m12 m21 m22 tx ty))) - m11 m12 m21 m22 tx ty) - - -(defun generate-foreign-record-to-structure-copier-form (record-type-name structure-class-name &key (struct-name (gensym)) (record-name (gensym))) - (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name)))) - (record-type (%foreign-type-or-record record-type-name)) - (accessor-names (foreign-record-accessor-names record-type))) - (unless (eq (length slot-names) (length accessor-names)) - (error "Slot names ~s don't match record accessors ~s" - slot-names accessor-names)) - (let* ((body (mapcar #'(lambda (slot-name accessor) - `(setf (slot-value ,struct-name ',slot-name) - ,(%foreign-access-form record-name - record-type - 0 - accessor))) - slot-names accessor-names))) - `(progn ,@body ,struct-name)))) - -(defun generate-structure-to-foreign-record-copier-form - (structure-class-name record-type-name - &key - (struct-name (gensym)) - (record-name (gensym))) - (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name)))) - (record-type (%foreign-type-or-record record-type-name)) - (accessor-names (foreign-record-accessor-names record-type))) - (unless (eq (length slot-names) (length accessor-names)) - (error "Slot names ~s don't match record accessors ~s" - slot-names accessor-names)) - (let* ((body (mapcar #'(lambda (slot-name accessor) - `(setf ,(%foreign-access-form record-name - record-type - 0 - accessor) - (slot-value ,struct-name ',slot-name))) - slot-names accessor-names))) - `(progn ,@body ,record-name)))) - -(defun generate-foreign-record-to-structure-creator-form - (record-type-name constructor-name &key (record-name (gensym))) - (let* ((record-type (%foreign-type-or-record record-type-name)) - (accessor-names (foreign-record-accessor-names record-type)) - (args (mapcar #'(lambda (accessor) - (%foreign-access-form record-name - record-type - 0 - accessor)) - accessor-names))) - `(,constructor-name ,@args))) - - -(defstruct record-structure-association - record-name - structure-name - structure-constructor-name) - -(defparameter *record-structure-associations* ()) - -(defun record-structure-association-from-record-name (r) - (find r *record-structure-associations* :key #'record-structure-association-record-name)) - -(defun need-record-structure-association-from-record-name (r) - (or (record-structure-association-from-record-name r) - (error "No lisp structure associated with foreign record named ~s" r))) - -(defun record-structure-association-from-structure-name (r) - (find r *record-structure-associations* :key #'record-structure-association-structure-name)) - -(defun associate-record-with-structure (record-name structure-name constructor-name) - (let* ((already-r (record-structure-association-from-record-name record-name)) - (already-s (record-structure-association-from-structure-name structure-name)) - (already (or already-r already-s)) - (different (not (eq already-r already-s)))) - (if already - (if different - (if already-r - (error "~&Record named ~s is already associated with structure named ~s" - (record-structure-association-record-name already-r) - (record-structure-association-structure-name already-r)) - (if already-s - (error "~&Structure named ~s is already associated with record named ~s" - (record-structure-association-structure-name already-s) - (record-structure-association-record-name already-s)))) - (setf (record-structure-association-structure-constructor-name already) - constructor-name)) - (push (make-record-structure-association - :record-name record-name - :structure-name structure-name - :structure-constructor-name constructor-name) - *record-structure-associations*)) - t)) - -(defun create-structure-from-record-form (var record-type) - (let* ((a (need-record-structure-association-from-record-name - record-type)) - (constructor - (record-structure-association-structure-constructor-name a))) - (generate-foreign-record-to-structure-creator-form - record-type constructor :record-name var))) - -(defun coerceable-foreign-record-p (ftype) - (and (consp ftype) - (eq (first ftype) :struct) - (find (second ftype) *record-structure-associations* - :key #'record-structure-association-record-name))) - -(associate-record-with-structure :_ect 'ns-rect 'make-ns-rect) -(associate-record-with-structure :_oint 'ns-point 'make-ns-point) -(associate-record-with-structure :_ize 'ns-size 'make-ns-size) -(associate-record-with-structure :_ange 'ns-range 'make-ns-range) -(associate-record-with-structure :ecimal 'ns-decimal 'make-ns-decimal) -(associate-record-with-structure :ect 'cg-rect 'make-cg-rect) -(associate-record-with-structure :_ffineransformtruct - 'ns-affine-transform-struct - 'make-ns-affine-transform-struct) -) ; #+objc-generic-functions +;;; By the time we see this, the slot name has been transformed to the form +;;; "(load-time-value (ensure-slot-id ))". +;;; This only works if the setter is SETF inverse of the getter. +(define-compiler-macro slot-id-value (&whole call instance slot-name &environment env) + (or + (let* ((type nil)) + (if (and (symbolp instance) + (subtypep (setq type (cdr (assq 'type (nth-value 2 (variable-information instance env))))) + 'objc:objc-object) + (consp slot-name) + (eq (car slot-name) 'load-time-value) + (consp (cdr slot-name)) + (null (cddr slot-name)) + (eq (caadr slot-name) 'ensure-slot-id) + (consp (cdadr slot-name)) + (null (cddadr slot-name)) + (setq slot-name (cadadr slot-name)) + (quoted-form-p slot-name) + (setq slot-name (cadr slot-name))) + (let* ((class (find-class type nil)) + (eslotd (when class (find slot-name (class-slots class) + :key #'slot-definition-name)))) + (when (typep eslotd 'foreign-effective-slot-definition) + (let* ((getter (foreign-slot-definition-getter eslotd)) + (name (if (typep getter 'compiled-function) + (function-name getter)))) + (when name + `(,name ,instance ,(slot-definition-location eslotd)))))))) + call)) + +