Index: anches/ide-1.0/ccl/cooca-bridge =================================================================== --- /branches/ide-1.0/ccl/cooca-bridge (revision 6861) +++ (revision ) @@ -1,1437 +1,0 @@ -;;;; -*- Mode: Lisp; Package: CCL -*- -;;;; bridge.lisp -;;;; -;;;; A Lisp bridge for Cocoa -;;;; -;;;; This provides: -;;;; (1) Convenient Lisp syntax for instantiating ObjC classes -;;;; (2) Convenient Lisp syntax for invoking ObjC methods -;;;; -;;;; Copyright (c) 2003 Randall D. Beer -;;;; -;;;; This software is licensed under the terms of the Lisp Lesser GNU Public -;;;; License, known as the LLGPL. The LLGPL consists of a preamble and -;;;; the LGPL. Where these conflict, the preamble takes precedence. The -;;;; LLGPL is available online at http://opensource.franz.com/preamble.html. -;;;; -;;;; Please send comments and bug reports to - -;;; Temporary package and module stuff - -(in-package "CCL") - -(require "OBJC-RUNTIME") -(require "NAME-TRANSLATION") - -#-apple-objc-2.0 -(progn - (def-foreign-type :loat :float) - (def-foreign-type :nteger :unsigned) - (def-foreign-type :nteger :signed) - ) - -(defconstant +cgfloat-zero+ - #+(and apple-objc-2.0 64-bit-target) 0.0d0 - #-(and apple-objc-2.0 64-bit-target) 0.0f0) - -(deftype cgfloat () - #+(and apple-objc-2.0 64-bit-target) 'double-float - #-(and apple-objc-2.0 64-bit-target) 'single-float) - -(deftype cg-float () 'cgfloat) - -(deftype nsuinteger () - #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64) - #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32)) - -(deftype nsinteger () - #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64) - #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32)) - -;;; Used in PRINT-OBJECT methods. - -(defun describe-macptr-allocation-and-address (p stream) - (format stream " ~@[~a ~](#x~x)" - (%macptr-allocation-string p) - (%ptr-to-int p))) - -(defstruct typed-foreign-struct-info - foreign-type - lisp-class-name - initializer - constructor - with-form-name - predicate-name) - -(defparameter *typed-foreign-struct-info* ()) - -(defun note-typed-foreign-struct-info (foreign-type lisp-class-name initializer constructor with-form-name predicate-name) - (let* ((info (find foreign-type *typed-foreign-struct-info* :test #'equal :key #'typed-foreign-struct-info-foreign-type))) - (unless info - (setq info (make-typed-foreign-struct-info :foreign-type foreign-type)) - (push info *typed-foreign-struct-info*)) - (setf (typed-foreign-struct-info-lisp-class-name info) lisp-class-name - (typed-foreign-struct-info-initializer info) initializer - (typed-foreign-struct-info-constructor info) constructor - (typed-foreign-struct-info-with-form-name info) with-form-name - (typed-foreign-struct-info-predicate-name info) predicate-name) - info)) - -;;; This gets installed as the COMPILER-MACRO-FUNCTION on any dispatch -;;; function associated with a method that passes structures by value. -(defun hoist-struct-constructors (whole env) - (declare (ignorable env)) - (destructuring-bind (operator receiver &rest args) whole - ;;See if any arguments are "obviously" known structure-creation forms. - (if (null (dolist (arg args) - (if (and (consp arg) - (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)) - (return t)))) - whole - ;;; Simplest to hoist one call, then let compiler-macroexpand - ;;; call us again. - (let* ((with-name nil) - (info nil) - (temp (gensym))) - (collect ((new-args)) - (new-args operator) - (new-args receiver) - (dolist (arg args) - (if (or info - (atom arg) - (not (setq info (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)))) - (new-args arg) - (progn - (setq with-name (typed-foreign-struct-info-with-form-name info)) - (if (cdr arg) - (new-args `(progn (,(typed-foreign-struct-info-initializer info) - ,temp - ,@(cdr arg)) - ,temp)) - (new-args temp))))) - `(,with-name (,temp) - (values ,(new-args)))))))) - - - -(defun define-typed-foreign-struct-accessor (type-name lisp-accessor-name foreign-accessor &optional (transform-output #'identity) (transform-input #'identity)) - (let* ((arg (gensym)) - (val (gensym))) - `(progn - (declaim (inline ,lisp-accessor-name)) - (defun ,lisp-accessor-name (,arg) - (if (typep ,arg ',type-name) - ,(funcall transform-input `(pref ,arg ,foreign-accessor)) - (report-bad-arg ,arg ',type-name))) - (declaim (inline (setf ,lisp-accessor-name))) - (defun (setf ,lisp-accessor-name) (,val ,arg) - (if (typep ,arg ',type-name) - (setf (pref ,arg ,foreign-accessor) ,(funcall transform-output val)) - (report-bad-arg ,arg ',type-name)))))) - -(defun define-typed-foreign-struct-accessors (type-name tuples) - (collect ((body)) - (dolist (tuple tuples `(progn ,@(body))) - (body (apply #'define-typed-foreign-struct-accessor type-name (cdr tuple)))))) - -(defun define-typed-foreign-struct-initializer (init-function-name tuples) - (when init-function-name - (let* ((struct (gensym))) - (collect ((initforms) - (args)) - (args struct) - (dolist (tuple tuples) - (destructuring-bind (arg-name lisp-accessor foreign-accessor &optional (transform #'identity)) tuple - (declare (ignore lisp-accessor)) - (args arg-name) - (initforms `(setf (pref ,struct ,foreign-accessor) ,(funcall transform arg-name))))) - `(progn - (declaim (inline ,init-function-name)) - (defun ,init-function-name ,(args) - (declare (ignorable ,struct)) - ,@(initforms) - ,struct)))))) - -(defun define-typed-foreign-struct-creation-function (creation-function-name init-function-name foreign-type accessors) - (when creation-function-name - (let* ((struct (gensym)) - (arg-names (mapcar #'car accessors))) - `(defun ,creation-function-name ,arg-names - (let* ((,struct (make-gcable-record ,foreign-type))) - (,init-function-name ,struct ,@arg-names) - ,struct))))) - -(defun define-typed-foreign-struct-class-with-form (with-form-name foreign-type init-function-name) - (declare (ignorable init-function-name)) - (when with-form-name - `(defmacro ,with-form-name ((instance &rest inits) &body body) - (multiple-value-bind (body decls) (parse-body body nil) - `(rlet ((,instance ,,foreign-type)) - ,@decls - ,@(when inits - `((,',init-function-name ,instance ,@inits))) - ,@body))))) - - -(defmacro define-typed-foreign-struct-class (class-name (foreign-type predicate-name init-function-name creation-function-name with-form-name) &rest accessors) - (let* ((arg (gensym))) - `(progn - (%register-type-ordinal-class (parse-foreign-type ',foreign-type) ',class-name) - (def-foreign-type ,class-name ,foreign-type) - (declaim (inline ,predicate-name)) - (note-typed-foreign-struct-info ',foreign-type ',class-name ',init-function-name ',creation-function-name ',with-form-name ',predicate-name) - (defun ,predicate-name (,arg) - (and (typep ,arg 'macptr) - (<= (the fixnum (%macptr-domain ,arg)) 1) - (= (the fixnum (%macptr-type ,arg)) - (foreign-type-ordinal (load-time-value (parse-foreign-type ',foreign-type)))))) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (type-predicate ',class-name) ',predicate-name)) - ,(define-typed-foreign-struct-initializer init-function-name accessors) - ,(define-typed-foreign-struct-creation-function creation-function-name init-function-name foreign-type accessors) - ,(define-typed-foreign-struct-class-with-form with-form-name foreign-type init-function-name) - ,(define-typed-foreign-struct-accessors class-name accessors) - ',class-name))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun wrap-cg-float (x) - `(float ,x +cgfloat-zero+))) - - - -;;; AEDesc (Apple Event Descriptor) - -(define-typed-foreign-struct-class ns::aedesc (:esc ns::aedesc-p ns::init-aedesc ns::make-aedesc ns::with-aedesc) - (descriptor-type ns::aedesc-descriptor-type :esc.descriptorype) - (data-handle ns::aedesc-data-handle :esc.dataandle)) - - -(defmethod print-object ((a ns::aedesc) stream) - (print-unreadable-object (a stream :type t :identity (%gcable-ptr-p a)) - (format stream "~s ~s" - (ns::aedesc-descriptor-type a) - (ns::aedesc-data-handle a)) - (describe-macptr-allocation-and-address a stream))) - -;;; It's not clear how useful this would be; I think that it's -;;; part of the ObjC 2.0 extensible iteration stuff ("foreach"). -#+apple-objc-2.0 -(define-typed-foreign-struct-class ns::ns-fast-enumeration-state (:astnumerationtate ns::ns-fast-enumeration-state-p ns::init-ns-fast-enumeration-state ns::make-ns-fast-enumeration-state ns::with-ns-fast-enumeration-state)) - -;;; NSAffineTransformStruct CGAffineTransform -(define-typed-foreign-struct-class ns::ns-affine-transform-struct (:ffineransformtruct ns::ns-affine-transform-struct-p ns::init-ns-affine-transform-struct ns::make-ns-affine-transform-struct ns::wint-ns-affine-transform-struct) - (m11 ns::ns-affine-transform-struct-m11 :ffineransformtruct.m11 wrap-cg-float) - (m12 ns::ns-affine-transform-struct-m12 :ffineransformtruct.m12 wrap-cg-float) - (m21 ns::ns-affine-transform-struct-m21 :ffineransformtruct.m21 wrap-cg-float) - (m22 ns::ns-affine-transform-struct-m22 :ffineransformtruct.m22 wrap-cg-float) - (tx ns::ns-affine-transform-struct-tx :ffineransformtruct.t wrap-cg-float) - (ty ns::ns-affine-transform-struct-ty :ffineransformtruct.t wrap-cg-float)) - - -(defmethod print-object ((transform ns::ns-affine-transform-struct) stream) - (print-unreadable-object (transform stream :type t :identity t) - (format stream "~s ~s ~s ~s ~s ~s" - (ns::ns-affine-transform-struct-m11 transform) - (ns::ns-affine-transform-struct-m12 transform) - (ns::ns-affine-transform-struct-m21 transform) - (ns::ns-affine-transform-struct-m22 transform) - (ns::ns-affine-transform-struct-tx transform) - (ns::ns-affine-transform-struct-ty transform)) - (describe-macptr-allocation-and-address transform stream))) - - - - - -;;; An ffineransformtruct is identical to a -;;; (:struct :ffineransform), except for the names of its fields. - -(setf (foreign-type-ordinal (parse-foreign-type '(:struct :ffineransform))) - (foreign-type-ordinal (parse-foreign-type :ffineransformtruct))) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun unwrap-boolean (form) - `(not (eql 0 ,form))) - (defun wrap-boolean (form) - `(if ,form 1 0))) - - -;;; NSDecimal -(define-typed-foreign-struct-class ns::ns-decimal (:ecimal ns::ns-decimal-p nil nil nil) - (nil ns::ns-decimal-exponent :ecimal._exponent) - (nil ns::ns-decimal-length :ecimal._length) - (nil ns::ns-decimal-is-negative :ecimal._isegative wrap-boolean unwrap-boolean) - (nil ns::ns-decimal-is-compact :ecimal._isompact wrap-boolean unwrap-boolean)) - - -(defun ns::init-ns-decimal (data exponent length is-negative is-compact mantissa) - (setf (pref data :ecimal._exponent) exponent - (pref data :ecimal._length) length - (pref data :ecimal._isegative) (if is-negative 1 0) - (pref data :ecimal._isompact) (if is-compact 1 0)) - (let* ((v (coerce mantissa '(vector (unsigned-byte 16) 8)))) - (declare (type (simple-array (unsigned-byte 16) (8)) v)) - (with-macptrs ((m (pref data :ecimal._mantissa))) - (dotimes (i 8) - (setf (paref m (:* (:unsigned 16)) i) (aref v i)))))) - -(defun ns::make-ns-decimal (exponent length is-negative is-compact mantissa) - (let* ((data (make-gcable-record :ecimal))) - (ns::init-ns-decimal data exponent length is-negative is-compact mantissa) - data)) - - - - -(defun ns::ns-decimal-mantissa (decimal) - (if (typep decimal 'ns::ns-decimal) - (let* ((dest (make-array 8 :element-type '(unsigned-byte 16)))) - (with-macptrs ((m (pref decimal :ecimal._mantissa))) - (dotimes (i 8 dest) - (setf (aref dest i) (paref m (:* (:unsigned 16)) i))))) - (report-bad-arg decimal 'ns::ns-decimal))) - -(defun (setf ns::ns-decimal-mantissa) (new decimal) - (if (typep decimal 'ns::ns-decimal) - (let* ((src (coerce new '(simple-array (unsigned-byte 16) (8))))) - (declare (type (simple-array (unsigned-byte 16) 8) src)) - (with-macptrs ((m (pref decimal :ecimal._mantissa))) - (dotimes (i 8 new) - (setf (paref m (:* (:unsigned 16)) i) (aref src i))))) - (report-bad-arg decimal 'ns::ns-decimal))) - -(defmethod print-object ((d ns::ns-decimal) stream) - (print-unreadable-object (d stream :type t :identity t) - (format stream "exponent = ~d, length = ~s, is-negative = ~s, is-compact = ~s, mantissa = ~s" (ns::ns-decimal-exponent d) (ns::ns-decimal-length d) (ns::ns-decimal-is-negative d) (ns::ns-decimal-is-compact d) (ns::ns-decimal-mantissa d)) - (describe-macptr-allocation-and-address d stream))) - - - - -;;; NSRect - -(define-typed-foreign-struct-class ns::ns-rect (:ect ns::ns-rect-p ns::init-ns-rect ns::make-ns-rect ns::with-ns-rect) - (x ns::ns-rect-x :ect.origin.x wrap-cg-float) - (y ns::ns-rect-y :ect.origin.y wrap-cg-float) - (width ns::ns-rect-width :ect.size.width wrap-cg-float) - (height ns::ns-rect-height :ect.size.height wrap-cg-float)) - - -(defmethod print-object ((r ns::ns-rect) stream) - (print-unreadable-object (r stream :type t :identity t) - (flet ((maybe-round (x) - (multiple-value-bind (q r) (round x) - (if (zerop r) q x)))) - (format stream "~s X ~s @ ~s,~s" - (maybe-round (ns::ns-rect-width r)) - (maybe-round (ns::ns-rect-height r)) - (maybe-round (ns::ns-rect-x r)) - (maybe-round (ns::ns-rect-y r))) - (describe-macptr-allocation-and-address r stream)))) - - - -;;; NSSize -(define-typed-foreign-struct-class ns::ns-size (:ize ns::ns-size-p ns::init-ns-size ns::make-ns-size ns::with-ns-size) - (width ns::ns-size-width :ize.width wrap-cg-float) - (height ns::ns-size-height :ize.height wrap-cg-float)) - - -(defmethod print-object ((s ns::ns-size) stream) - (flet ((maybe-round (x) - (multiple-value-bind (q r) (round x) - (if (zerop r) q x)))) - (print-unreadable-object (s stream :type t :identity t) - (format stream "~s X ~s" - (maybe-round (ns::ns-size-width s)) - (maybe-round (ns::ns-size-height s))) - (describe-macptr-allocation-and-address s stream)))) - - -;;; NSPoint -(define-typed-foreign-struct-class ns::ns-point (:oint ns::ns-point-p ns::init-ns-point ns::make-ns-point ns::with-ns-point) - (x ns::ns-point-x :oint.x wrap-cg-float) - (y ns::ns-point-y :oint.y wrap-cg-float)) - -(defmethod print-object ((p ns::ns-point) stream) - (flet ((maybe-round (x) - (multiple-value-bind (q r) (round x) - (if (zerop r) q x)))) - (print-unreadable-object (p stream :type t :identity t) - (format stream "~s,~s" - (maybe-round (ns::ns-point-x p)) - (maybe-round (ns::ns-point-y p))) - (describe-macptr-allocation-and-address p stream)))) - - -;;; NSRange -(define-typed-foreign-struct-class ns::ns-range (:ange ns::ns-range-p ns::init-ns-range ns::make-ns-range ns::with-ns-range) - (location ns::ns-range-location :ange.location) - (length ns::ns-range-length :ange.length )) - -(defmethod print-object ((r ns::ns-range) stream) - (print-unreadable-object (r stream :type t :identity t) - (format stream "~s/~s" - (ns::ns-range-location r) - (ns::ns-range-length r)) - (describe-macptr-allocation-and-address r stream))) - - -;;; String might be stack allocated; make a copy before complaining -;;; about it. -(defun check-objc-message-name (string) - (dotimes (i (length string)) - (let* ((ch (char string i))) - (unless (or (alpha-char-p ch) - (digit-char-p ch 10) - (eql ch #\:) - (eql ch #\_)) - (error "Illegal character ~s in ObjC message name ~s" - ch (copy-seq string))))) - (when (and (position #\: string) - (not (eql (char string (1- (length string))) #\:))) - (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string)))) - - -(setf (pkg.intern-hook (find-package "NSFUN")) - 'get-objc-message-info) - -(set-dispatch-macro-character #\# #\/ - (lambda (stream subchar numarg) - (declare (ignorable subchar numarg)) - (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t)) - (attrtab (rdtab.ttab *readtable*))) - (when (peek-char t stream nil nil) - (loop - (multiple-value-bind (char attr) - (%next-char-and-attr stream attrtab) - (unless (eql attr $cht_cnst) - (when char (unread-char char stream)) - (return)) - (vector-push-extend char token)))) - (unless *read-suppress* - (unless (> (length token) 0) - (signal-reader-error stream "Invalid token after #/.")) - (check-objc-message-name token) - (intern token "NSFUN"))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Utilities ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Return separate lists of the keys and values in a keyword/value list - -(defun keys-and-vals (klist) - (when (oddp (length klist)) - (error "Invalid keyword/value list: ~S" klist)) - (loop for l = klist then (cddr l) - until (null l) - collect (first l) into keys - collect (second l) into vals - finally (return (values keys vals)))) - - -;;; Return the typestring for an ObjC METHOD - -(defun method-typestring (method) - (%get-cstring #+apple-objc-2.0 - (#_method_getTypeEncoding method) - #-apple-objc-2.0 - (pref method :objc_method.method_types))) - - -;;; Parse the ObjC message from a SENDxxx macro - -(defun parse-message (args) - (let ((f (first args)) - (nargs (length args))) - (cond ((or (= nargs 1) (= nargs 2)) - ;; (THING {VARGS}) - (if (constantp f) - (%parse-message (cons (eval f) (rest args))) - (values f (rest args) nil))) - ;; (THING1 ARG1 ... THINGN ARGN) - ((evenp nargs) - (multiple-value-bind (ks vs) (keys-and-vals args) - (if (every #'constantp ks) - (%parse-message (mapcan #'list (mapcar #'eval ks) vs)) - (values f (rest args) nil)))) - ;; (THING1 ARG1 ... THINGN ARGN VARGS) - (t (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) - (if (every #'constantp ks) - (%parse-message - (nconc (mapcan #'list (mapcar #'eval ks) vs) (last args))) - (values f (rest args) nil))))))) - - -;;; Parse the ObjC message from the evaluated args of a %SENDxxx function - -(defun %parse-message (args) - (let ((f (first args)) - (l (first (last args)))) - (cond ((stringp f) - ;; (STRING-with-N-colons ARG1 ... ARGN {LIST}) - (let* ((n (count #\: (the simple-string f))) - (message-info (need-objc-message-info f)) - (args (rest args)) - (nargs (length args))) - (cond ((and (= nargs 1) - (getf (objc-message-info-flags message-info) - :accepts-varargs)) - (values f nil l)) - ((= nargs n) (values f args nil)) - ((= nargs (1+ n)) (values f (butlast args) l)) - (t (error "Improperly formatted argument list: ~S" args))))) - ((keywordp f) - ;; (KEY1 ARG1 ... KEYN ARGN {LIST}) or (KEY LIST) - (let ((nargs (length args))) - (cond ((and (= nargs 2) (consp l) - (let* ((info (need-objc-message-info - (lisp-to-objc-message (list f))))) - (getf (objc-message-info-flags info) - :accepts-varargs))) - (values (lisp-to-objc-message (list f)) nil l)) - ((evenp nargs) - (multiple-value-bind (ks vs) (keys-and-vals args) - (values (lisp-to-objc-message ks) vs nil))) - ((and (> nargs 1) (listp l)) - (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) - (values (lisp-to-objc-message ks) vs l))) - (t (error "Improperly formatted argument list: ~S" args))))) - ((symbolp f) - ;; (SYMBOL {LIST}) - (let ((nargs (length (rest args)))) - (cond ((= nargs 0) (values (lisp-to-objc-message (list f)) nil nil)) - ((= nargs 1) (values (lisp-to-objc-message (list f)) nil l)) - (t (error "Improperly formatted argument list: ~S" args))))) - (t (error "Improperly formatted argument list: ~S" args))))) - - -;;; Return the declared type of FORM in ENV - -(defun declared-type (form env) - (cond ((symbolp form) - (multiple-value-bind (ignore ignore decls) - (variable-information form env) - (declare (ignore ignore)) - (or (cdr (assoc 'type decls)) t))) - ((and (consp form) (eq (first form) 'the)) - (second form)) - (t t))) - - -;;; Return the current optimization setting of KEY in ENV - -(defun optimization-setting (key &optional env) - (cadr (assoc key (declaration-information 'optimize env)))) - - -;;; Return the ObjC class named CNAME - -(defun find-objc-class (cname) - (%objc-class-classptr - (if (symbolp cname) - (find-class cname) - (load-objc-class-descriptor cname)))) - - -;;; Return the class object of an ObjC object O, signalling an error -;;; if O is not an ObjC object - -(defun objc-class-of (o) - (if (objc-object-p o) - (class-of o) - (progn - #+debug - (#_NSLog #@"class name = %s" :address (pref (pref o :objc_object.isa) - :objc_class.name)) - (error "~S is not an ObjC object" o)))) - - -;;; Returns the ObjC class corresponding to the declared type OTYPE if -;;; possible, NIL otherwise - -(defun get-objc-class-from-declaration (otype) - (cond ((symbolp otype) (lookup-objc-class (lisp-to-objc-classname otype))) - ((and (consp otype) (eq (first otype) '@metaclass)) - (let* ((name (second otype)) - (c - (typecase name - (string (lookup-objc-class name)) - (symbol (lookup-objc-class (lisp-to-objc-classname name))) - (t (error "Improper metaclass typespec: ~S" otype))))) - (unless (null c) (objc-class-of c)))))) - - -;;; Returns the selector of MSG - -(defun get-selector (msg) - (%get-selector (load-objc-selector msg))) - - -;;; Get the instance method structure corresponding to SEL for CLASS - -(defun get-method (class sel) - (let ((m (class-get-instance-method class sel))) - (if (%null-ptr-p m) - (error "Instances of ObjC class ~S cannot respond to the message ~S" - (objc-class-name class) - (lisp-string-from-sel sel)) - m))) - - -;;; Get the class method structure corresponding to SEL for CLASS - -(defun get-class-method (class sel) - (let ((m (class-get-class-method class sel))) - (if (%null-ptr-p m) - (error "ObjC class ~S cannot respond to the message ~S" - (objc-class-name class) - (lisp-string-from-sel sel)) - m))) - - -;;; For some reason, these types sometimes show up as :STRUCTs even though they -;;; are not structure tags, but type names - -(defun fudge-objc-type (ftype) - (if (equal ftype '(:STRUCT :ecimal)) - :ecimal - ftype)) - - -;;; Returns T if the result spec requires a STRET for its return, NIL otherwise -;;; RSPEC may be either a number (in which case it is interpreted as a number -;;; of words) or a foreign type spec acceptable to PARSE-FOREIGN-TYPE. STRETS -;;; must be used when a structure larger than 4 bytes is returned - -(defun requires-stret-p (rspec) - (when (member rspec '(:DOUBLE-FLOAT :UNSIGNED-DOUBLEWORD :SIGNED-DOUBLEWORD) - :test #'eq) - (return-from requires-stret-p nil)) - (setq rspec (fudge-objc-type rspec)) - (if (numberp rspec) - (> rspec 1) - (> (ensure-foreign-type-bits (parse-foreign-type rspec)) target::nbits-in-word))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Stret Convenience Stuff ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Allocate any temporary storage necessary to hold strets required -;;; AT TOPLEVEL in the value forms. Special recognition is given to -;;; SENDs involving strets and to stret pseudo-functions -;;; NS-MAKE-POINT, NS-MAKE-RANGE, NS-MAKE-RECT and NS-MAKE-SIZE - -(defmacro slet (varforms &body body &environment env) - (multiple-value-bind (clean-body decls) (parse-body body env nil) - (loop with r and s - for (var val) in varforms - do (multiple-value-setq (r s) (sletify val t var)) - collect r into rvarforms - unless (null s) collect s into stretforms - finally - (return - `(rlet ,rvarforms - ,@decls - ,@stretforms - ,@clean-body))))) - - -;;; Note that SLET* does not allow declarations - -(defmacro slet* (varforms &body body &environment env) - (if (= (length varforms) 1) - `(slet ,varforms ,@body) - `(slet ,(list (first varforms)) - (slet* ,(rest varforms) ,@body)))) - - -;;; Collect the info necessary to transform a SLET into an RLET - -(defun sletify (form &optional errorp (var (gensym))) - (if (listp form) - (case (first form) - (ns-make-point - (assert (= (length form) 3)) - `(,var :oint :x ,(second form) :y ,(third form))) - (ns-make-rect - (assert (= (length form) 5)) - `(,var :ect :origin.x ,(second form) :origin.y ,(third form) - :size.width ,(fourth form) :size.height ,(fifth form))) - (ns-make-range - (assert (= (length form) 3)) - `(,var :ange :location ,(second form) :length ,(third form))) - (ns-make-size - (assert (= (length form) 3)) - `(,var :ize :width ,(second form) :height ,(third form))) - (send - (let* ((info (get-objc-message-info (parse-message (cddr form))))) - (if (null info) - (error "Can't determine message being sent in ~s" form)) - (let* ((rtype (objc-method-info-result-type - (car (objc-message-info-methods info))))) - (if (getf (objc-message-info-flags info) :returns-structure) - (values `(,var ,(if (typep rtype 'foreign-type) - (unparse-foreign-type rtype) - rtype)) - `(send/stret ,var ,@(rest form))) - (if errorp - (error "NonSTRET SEND in ~S" form) - form))))) - (send-super - (let* ((info (get-objc-message-info (parse-message (cddr form))))) - (if (null info) - (error "Can't determine message being sent in ~s" form)) - (let* ((rtype (objc-method-info-result-type - (car (objc-message-info-methods info))))) - (if (getf (objc-message-info-flags info) :returns-structure) - (values `(,var ,(if (typep rtype 'foreign-type) - (unparse-foreign-type rtype) - rtype)) - `(send-super/stret ,var ,@(rest form))) - (if errorp - (error "NonSTRET SEND-SUPER in ~S" form) - form))))) - (t (if errorp - (error "Unrecognized STRET call in ~S" form) - form))) - (if errorp - (error "Unrecognized STRET call in ~S" form) - form))) - - -;;; Process the arguments to a message send as an implicit SLET, collecting -;;; the info necessary to build the corresponding RLET - -(defun sletify-message-args (args) - (loop with svf and sif - for a in args - do (multiple-value-setq (svf sif) (sletify a)) - unless (null sif) collect sif into sifs - unless (equal svf a) - do (setf a (first svf)) - and collect svf into svfs - collect a into nargs - finally (return (values nargs svfs sifs)))) - - -;;; Convenience macros for some common Cocoa structures. More -;;; could be added - -(defmacro ns-max-range (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (+ (pref ,rtemp :ange.location) (pref ,rtemp :ange.length))))) -(defmacro ns-min-x (r) `(pref ,r :ect.origin.x)) -(defmacro ns-min-y (r) `(pref ,r :ect.origin.y)) -(defmacro ns-max-x (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (+ (pref ,r :ect.origin.x) - (pref ,r :ect.size.width))))) -(defmacro ns-max-y (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (+ (pref ,r :ect.origin.y) - (pref ,r :ect.size.height))))) -(defmacro ns-mid-x (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (* 0.5 (+ (ns-min-x ,rtemp) (ns-max-x ,rtemp)))))) -(defmacro ns-mid-y (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (* 0.5 (+ (ns-min-y ,rtemp) (ns-max-y ,rtemp)))))) -(defmacro ns-height (r) `(pref ,r :ect.size.height)) -(defmacro ns-width (r) `(pref ,r :ect.size.width)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Type Stuff ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - -(defvar *objc-message-info* (make-hash-table :test #'equal :size 500)) - -(defun result-type-requires-structure-return (result-type) - ;; Use objc-msg-send-stret for all methods that return - ;; record types. - (or (typep result-type 'foreign-record-type) - (and (not (typep result-type 'foreign-type)) - (typep (parse-foreign-type result-type) 'foreign-record-type)))) - -(defvar *objc-method-signatures* (make-hash-table :test #'equal)) - -(defstruct objc-method-signature-info - type-signature - function - super-function) - -(defun objc-method-signature-info (sig) - (or (gethash sig *objc-method-signatures*) - (setf (gethash sig *objc-method-signatures*) - (make-objc-method-signature-info :type-signature sig)))) - -(defun concise-foreign-type (ftype) - (if (typep ftype 'foreign-record-type) - (let* ((name (foreign-record-type-name ftype))) - (if name - `(,(foreign-record-type-kind ftype) ,name) - (unparse-foreign-type ftype))) - (if (objc-id-type-p ftype) - :id - (if (typep ftype 'foreign-pointer-type) - (let* ((to (foreign-pointer-type-to ftype))) - (if (null to) - '(:* :void) - `(:* ,(concise-foreign-type to)))) - (if (typep ftype 'foreign-type) - (unparse-foreign-type ftype) - ftype))))) - - -;;; Not a perfect mechanism. -(defclass objc-dispatch-function (funcallable-standard-object) - () - (:metaclass funcallable-standard-class)) - -(defmethod print-object ((o objc-dispatch-function) stream) - (print-unreadable-object (o stream :type t :identity t) - (let* ((name (function-name o))) - (when name - (format stream "~s" name))))) - - - - -(declaim (inline check-receiver)) - -;;; Return a NULL pointer if RECEIVER is a null pointer. -;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL. -(defun check-receiver (receiver) - (if (%null-ptr-p receiver) - (%null-ptr) - (let* ((domain (%macptr-domain receiver)) - (valid (eql domain *objc-object-domain*))) - (declare (fixnum domain)) - (when (zerop domain) - (if (recognize-objc-object receiver) - (progn (%set-macptr-domain receiver *objc-object-domain*) - (setq valid t)))) - (unless valid - (report-bad-arg receiver 'objc:objc-object))))) - -(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys) - (declare (ignore slot-names)) - (if message-info - (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous)) - (selector (objc-message-info-selector message-info)) - (first-method (car (objc-message-info-methods message-info)))) - (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info)) - $lfbits-numreq - (logior (ash - (if (getf (objc-message-info-flags message-info) - :accepts-varargs) - 1 - 0) - $lfbits-rest-bit) - (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit))))) - (flet ((signature-function-for-method (m) - (let* ((signature-info (objc-method-info-signature-info m))) - (or (objc-method-signature-info-function signature-info) - (setf (objc-method-signature-info-function signature-info) - (compile-send-function-for-signature - (objc-method-signature-info-type-signature signature-info))))))) - - (if (null ambiguous-methods) - ;; Pick an arbitrary method, since all methods have the same - ;; signature. - (let* ((function (signature-function-for-method first-method))) - (set-funcallable-instance-function - gf - (nfunction - send-unambiguous-message - (lambda (receiver &rest args) - (declare (dynamic-extent args)) - (or (check-receiver receiver) - (with-ns-exceptions-as-errors - (apply function receiver selector args))))))) - (let* ((protocol-pairs (mapcar #'(lambda (pm) - (cons (lookup-objc-protocol - (objc-method-info-class-name pm)) - (signature-function-for-method - pm))) - (objc-message-info-protocol-methods message-info))) - (method-pairs (mapcar #'(lambda (group) - (cons (mapcar #'(lambda (m) - (get-objc-method-info-class m)) - group) - (signature-function-for-method (car group)))) - (objc-message-info-ambiguous-methods message-info))) - (default-function (if method-pairs - (prog1 (cdar (last method-pairs)) - (setq method-pairs (nbutlast method-pairs))) - (prog1 (cdr (last protocol-pairs)) - (setq protocol-pairs (nbutlast protocol-pairs)))))) - (set-funcallable-instance-function - gf - (nfunction - send-unambiguous-message - (lambda (receiver &rest args) - (declare (dynamic-extent args)) - (or (check-receiver receiver) - (let* ((function - (or (dolist (pair protocol-pairs) - (when (conforms-to-protocol receiver (car pair)) - (return (cdr pair)))) - (block m - (dolist (pair method-pairs default-function) - (dolist (class (car pair)) - (when (typep receiver class) - (return-from m (cdr pair))))))))) - (with-ns-exceptions-as-errors - (apply function receiver selector args))))))))))) - (with-slots (name) gf - (set-funcallable-instance-function - gf - #'(lambda (&rest args) - (error "Unknown ObjC message ~a called with arguments ~s" - (symbol-name name) args)))))) - - -(defun %call-next-objc-method (self class selector sig &rest args) - (declare (dynamic-extent args)) - (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self - #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class - #+apple-objc-2.0 (#_class_getSuperclass class) - #-apple-objc-2.0 (pref class :objc_class.super_class))) - (let* ((siginfo (objc-method-signature-info sig)) - (function (or (objc-method-signature-info-super-function siginfo) - (setf (objc-method-signature-info-super-function siginfo) - (%compile-send-function-for-signature sig t))))) - (with-ns-exceptions-as-errors - (apply function s selector args))))) - - -(defun %call-next-objc-class-method (self class selector sig &rest args) - (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self - #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class - #+apple-objc-2.0 (#_class_getSuperclass (pref class :objc_class.isa)) - #-apple-objc-2.0 (pref (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) :objc_class.super_class))) - (let* ((siginfo (objc-method-signature-info sig)) - (function (or (objc-method-signature-info-super-function siginfo) - (setf (objc-method-signature-info-super-function siginfo) - (%compile-send-function-for-signature sig t))))) - (with-ns-exceptions-as-errors - (apply function s selector args))))) - -(defun postprocess-objc-message-info (message-info) - (let* ((objc-name (objc-message-info-message-name message-info)) - (lisp-name (or (objc-message-info-lisp-name message-info) - (setf (objc-message-info-lisp-name message-info) - (compute-objc-to-lisp-function-name objc-name)))) - (gf (or (fboundp lisp-name) - (setf (fdefinition lisp-name) - (make-instance 'objc-dispatch-function :name lisp-name))))) - - (unless (objc-message-info-selector message-info) - (setf (objc-message-info-selector message-info) - (ensure-objc-selector (objc-message-info-message-name message-info)))) - - (flet ((reduce-to-ffi-type (ftype) - (concise-foreign-type ftype))) - (flet ((ensure-method-signature (m) - (or (objc-method-info-signature m) - (setf (objc-method-info-signature m) - (let* ((sig - (cons (reduce-to-ffi-type - (objc-method-info-result-type m)) - (mapcar #'reduce-to-ffi-type - (objc-method-info-arglist m))))) - (setf (objc-method-info-signature-info m) - (objc-method-signature-info sig)) - sig))))) - (let* ((methods (objc-message-info-methods message-info)) - (signatures ()) - (protocol-methods) - (signature-alist ())) - (labels ((signatures-equal (xs ys) - (and xs - ys - (do* ((xs xs (cdr xs)) - (ys ys (cdr ys))) - ((null xs) (null ys)) - (unless (foreign-type-= (ensure-foreign-type (car xs)) - (ensure-foreign-type (car ys))) - (return nil)))))) - (dolist (m methods) - (let* ((signature (ensure-method-signature m))) - (pushnew signature signatures :test #'signatures-equal) - (if (getf (objc-method-info-flags m) :protocol) - (push m protocol-methods) - (let* ((pair (assoc signature signature-alist :test #'signatures-equal))) - (if pair - (push m (cdr pair)) - (push (cons signature (list m)) signature-alist))))))) - (setf (objc-message-info-ambiguous-methods message-info) - (mapcar #'cdr - (sort signature-alist - #'(lambda (x y) - (< (length (cdr x)) - (length (cdr y))))))) - (setf (objc-message-info-flags message-info) nil) - (setf (objc-message-info-protocol-methods message-info) - protocol-methods) - (when (cdr signatures) - (setf (getf (objc-message-info-flags message-info) :ambiguous) t)) - (let* ((first-method (car methods)) - (first-sig (objc-method-info-signature first-method)) - (first-sig-len (length first-sig))) - (setf (objc-message-info-req-args message-info) - (1- first-sig-len)) - ;; Whether some arg/result types vary or not, we want to insist - ;; on (a) either no methods take a variable number of arguments, - ;; or all do, and (b) either no method uses structure-return - ;; conventions, or all do. (It's not clear that these restrictions - ;; are entirely reasonable in the long run; in the short term, - ;; they'll help get things working.) - (flet ((method-returns-structure (m) - (result-type-requires-structure-return - (objc-method-info-result-type m))) - (method-accepts-varargs (m) - (eq (car (last (objc-method-info-arglist m))) - *void-foreign-type*)) - (method-has-structure-arg (m) - (dolist (arg (objc-method-info-arglist m)) - (when (typep (ensure-foreign-type arg) 'foreign-record-type) - (return t))))) - (when (dolist (method methods) - (when (method-has-structure-arg method) - (return t))) - (setf (compiler-macro-function lisp-name) - 'hoist-struct-constructors)) - (let* ((first-result-is-structure (method-returns-structure first-method)) - (first-accepts-varargs (method-accepts-varargs first-method))) - (if (dolist (m (cdr methods) t) - (unless (eq (method-returns-structure m) - first-result-is-structure) - (return nil))) - (if first-result-is-structure - (setf (getf (objc-message-info-flags message-info) - :returns-structure) t))) - (if (dolist (m (cdr methods) t) - (unless (eq (method-accepts-varargs m) - first-accepts-varargs) - (return nil))) - (if first-accepts-varargs - (progn - (setf (getf (objc-message-info-flags message-info) - :accepts-varargs) t) - (decf (objc-message-info-req-args message-info))))))))) - (reinitialize-instance gf :message-info message-info))))) - -;;; -may- need to invalidate cached info whenever new interface files -;;; are made accessible. Probably the right thing to do is to insist -;;; that (known) message signatures be updated in that case. -(defun get-objc-message-info (message-name &optional (use-database t)) - (setq message-name (string message-name)) - (or (gethash message-name *objc-message-info*) - (and use-database - (let* ((info (lookup-objc-message-info message-name))) - (when info - (setf (gethash message-name *objc-message-info*) info) - (postprocess-objc-message-info info) - info))))) - -(defun need-objc-message-info (message-name) - (or (get-objc-message-info message-name) - (error "Undeclared message: ~s" message-name))) - -;;; Should be called after using new interfaces that may define -;;; new methods on existing messages. -(defun update-objc-method-info () - (maphash #'(lambda (message-name info) - (lookup-objc-message-info message-name info) - (postprocess-objc-message-info info)) - *objc-message-info*)) - - -;;; Of the method declarations (OBJC-METHOD-INFO structures) associated -;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M, -;;; return the one that seems to be applicable for the object O. -;;; (If there's no ambiguity among the declared methods, any method -;;; will do; this just tells runtime %SEND functions how to compose -;;; an %FF-CALL). -(defun %lookup-objc-method-info (m o) - (let* ((methods (objc-message-info-methods m)) - (ambiguous (getf (objc-message-info-flags m) :ambiguous))) - (if (not ambiguous) - (car methods) - (or - (dolist (method methods) - (let* ((mclass (get-objc-method-info-class method))) - (if (typep o mclass) - (return method)))) - (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o))))) - -(defun resolve-existing-objc-method-info (message-info class-name class-p result-type args) - (let* ((method-info (dolist (m (objc-message-info-methods message-info)) - (when (and (eq (getf (objc-method-info-flags m) :class-p) - class-p) - (equal (objc-method-info-class-name m) - class-name)) - (return m))))) - (when method-info - (unless (and (foreign-type-= (ensure-foreign-type (objc-method-info-result-type method-info)) - (parse-foreign-type result-type)) - (do* ((existing (objc-method-info-arglist method-info) (cdr existing)) - (proposed args (cdr proposed))) - ((null existing) (null proposed)) - (unless (foreign-type-= (ensure-foreign-type (car existing)) - (parse-foreign-type (car proposed))) - (return nil)))) - (cerror "Redefine existing method to have new type signature." - "The method ~c[~a ~a] is already declared to have type signature ~s; the new declaration ~s is incompatible." (if class-p #\+ #\-) class-name (objc-message-info-message-name message-info) (objc-method-info-signature method-info) (cons result-type args)) - (setf (objc-method-info-arglist method-info) args - (objc-method-info-result-type method-info) result-type - (objc-method-info-signature method-info) nil - (objc-method-info-signature-info method-info) nil)) - method-info))) - -;;; Still not right; we have to worry about type conflicts with -;;; shadowed methods, as well. -(defun %declare-objc-method (message-name class-name class-p result-type args) - (let* ((info (get-objc-message-info message-name))) - (unless info - (format *error-output* "~&; Note: defining new ObjC message ~c[~a ~a]" (if class-p #\+ #\-) class-name message-name) - (setq info (make-objc-message-info :message-name message-name)) - (setf (gethash message-name *objc-message-info*) info)) - (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous)) - (method-info (or (resolve-existing-objc-method-info info class-name class-p result-type args) - (make-objc-method-info :message-info info - :class-name class-name - :result-type result-type - :arglist args - :flags (if class-p '(:class t)))))) - (pushnew method-info (objc-message-info-methods info)) - (postprocess-objc-message-info info) - (if (and (getf (objc-message-info-flags info) :ambiguous) - (not was-ambiguous)) - (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info)) - - (objc-method-info-signature method-info)))) - - - -;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID - -(defun translate-foreign-result-type (ftype) - (ensure-foreign-type-bits (parse-foreign-type ftype)) - (if (eq ftype :void) - :void - (translate-foreign-arg-type ftype))) - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Invoking ObjC Methods ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; The SEND and SEND/STRET macros - -(defmacro send (o msg &rest args &environment env) - (make-optimized-send o msg args env)) - -(defmacro send/stret (s o msg &rest args &environment env) - (make-optimized-send o msg args env s)) - - - - -;;; Optimize special cases of SEND and SEND/STRET - -(defun make-optimized-send (o msg args env &optional s super sclassname) - (multiple-value-bind (msg args vargs) (parse-message (cons msg args)) - (let* ((message-info (get-objc-message-info msg))) - (if (null message-info) - (error "Unknown message: ~S" msg)) - ;; If a vararg exists, make sure that the message can accept it - (when (and vargs (not (getf (objc-message-info-flags message-info) - :accepts-varargs))) - (error "Message ~S cannot accept a variable number of arguments" msg)) - (unless (= (length args) (objc-message-info-req-args message-info)) - (error "Message ~S requires ~a ~d args, but ~d were provided." - msg - (if vargs "at least" "exactly") - (objc-message-info-req-args message-info) - (length args))) - (multiple-value-bind (args svarforms sinitforms) (sletify-message-args args) - (let* ((ambiguous (getf (objc-message-info-flags message-info) :ambiguous)) - (methods (objc-message-info-methods message-info)) - (method (if (not ambiguous) (car methods)))) - (when ambiguous - (let* ((class (if sclassname - (find-objc-class sclassname) - (get-objc-class-from-declaration (declared-type o env))))) - (if class - (dolist (m methods) - (unless (getf (objc-method-info-flags m) :protocol) - (let* ((mclass (or (get-objc-method-info-class m) - (error "Can't find ObjC class named ~s" - (objc-method-info-class-name m))))) - (when (and class (subtypep class mclass)) - (return (setq method m))))))))) - (if method - (build-call-from-method-info method - args - vargs - o - msg - svarforms - sinitforms - s - super) - (build-ambiguous-send-form message-info - args - vargs - o - msg - svarforms - sinitforms - s - super))))))) - - -;;; WITH-NS-EXCEPTIONS-AS-ERRORS is only available in OpenMCL 0.14 and above - -#-openmcl-native-threads -(defmacro with-ns-exceptions-as-errors (&body body) - `(progn ,@body)) - - -;;; Return a call to the method specified by SEL on object O, with the args -;;; specified by ARGSPECS. This decides whether a normal or stret call is -;;; needed and, if the latter, uses the memory S to hold the result. If SUPER -;;; is nonNIL, then this builds a send to super. Finally, this also -;;; coerces return #$YES/#$NO values to T/NIL. The entire call takes place -;;; inside an implicit SLET. - -(defun build-call (o sel msg argspecs svarforms sinitforms &optional s super) - `(with-ns-exceptions-as-errors - (rlet ,svarforms - ,@sinitforms - ,(let ((rspec (first (last argspecs)))) - (if (requires-stret-p rspec) - (if (null s) - ;; STRET required but not provided - (error "The message ~S must be sent using SEND/STRET" msg) - ;; STRET required and provided, use stret send - (if (null super) - ;; Regular stret send - `(progn - (objc-message-send-stret ,s ,o ,(cadr sel) - ,@(append (butlast argspecs) (list :void))) - ,s) - ;; Super stret send - `(progn - (objc-message-send-super-stret ,s ,super ,(cadr sel) - ,@(append (butlast argspecs) (list :void))) - ,s))) - (if (null s) - ;; STRET not required and not provided, use send - (if (null super) - ;; Regular send - (if (eq rspec :) - `(coerce-from-bool - (objc-message-send ,o ,(cadr sel) ,@argspecs)) - `(objc-message-send ,o ,(cadr sel) ,@argspecs)) - ;; Super send - (if (eq rspec :) - `(coerce-from-bool - (objc-message-send-super ,super ,(cadr sel) ,@argspecs)) - `(objc-message-send-super ,super ,(cadr sel) ,@argspecs))) - ;; STRET not required but provided - (error "The message ~S must be sent using SEND" msg))))))) - -(defun objc-id-type-p (foreign-type) - (and (typep foreign-type 'foreign-pointer-type) - (let* ((to (foreign-pointer-type-to foreign-type))) - (and (typep to 'foreign-record-type) - (eq :struct (foreign-record-type-kind to)) - (not (null (progn (ensure-foreign-type-bits to) (foreign-record-type-fields to)))) - (let* ((target (foreign-record-field-type (car (foreign-record-type-fields to))))) - (and (typep target 'foreign-pointer-type) - (let* ((target-to (foreign-pointer-type-to target))) - (and (typep target-to 'foreign-record-type) - (eq :struct (foreign-record-type-kind target-to)) - (eq :objc_class (foreign-record-type-name target-to)))))))))) - -(defun unique-objc-classes-in-method-info-list (method-info-list) - (if (cdr method-info-list) ; if more than 1 class - (flet ((subclass-of-some-other-class (c) - (let* ((c-class (get-objc-method-info-class c))) - (dolist (other method-info-list) - (unless (eq other c) - (when (subtypep c-class (get-objc-method-info-class other)) - (return t))))))) - (remove-if #'subclass-of-some-other-class method-info-list)) - method-info-list)) - -(defun get-objc-method-info-class (method-info) - (or (objc-method-info-class-pointer method-info) - (setf (objc-method-info-class-pointer method-info) - (let* ((c (lookup-objc-class (objc-method-info-class-name method-info) nil))) - (when c - (let* ((meta-p (getf (objc-method-info-flags method-info) :class))) - (if meta-p - (with-macptrs ((m (pref c :objc_class.isa))) - (canonicalize-registered-metaclass m)) - (canonicalize-registered-class c)))))))) - -;;; Generate some sort of CASE or COND to handle an ambiguous message -;;; send (where the signature of the FF-CALL depends on the type of the -;;; receiver.) -;;; AMBIGUOUS-METHODS is a list of lists of OBJC-METHOD-INFO structures, -;;; where the methods in each sublist share the same type signature. It's -;;; sorted so that more unique method/signature combinations appear first -;;; (and are easier to special-case via TYPECASE.) -(defun build-send-case (ambiguous-methods - args - vargs - receiver - msg - s - super - protocol-methods) - (flet ((method-class-name (m) - (let* ((mclass (get-objc-method-info-class m))) - (unless mclass - (error "Can't find class with ObjC name ~s" - (objc-method-info-class-name m))) - (class-name mclass)))) - - (collect ((clauses)) - (let* ((protocol (gensym)) - (protocol-address (gensym))) - (dolist (method protocol-methods) - (let* ((protocol-name (objc-method-info-class-name method))) - (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name)) - (,protocol-address (and ,protocol (objc-protocol-address ,protocol)))) - (and ,protocol-address - (objc-message-send ,receiver - "conformsToProtocol:" - :address ,protocol-address - :))) - ,(build-internal-call-from-method-info - method args vargs receiver msg s super)))))) - (do* ((methods ambiguous-methods (cdr methods))) - ((null (cdr methods)) - (when ambiguous-methods - (clauses `(t - ,(build-internal-call-from-method-info - (caar methods) args vargs receiver msg s super))))) - (clauses `(,(if (cdar methods) - `(or ,@(mapcar #'(lambda (m) - `(typep ,receiver - ',(method-class-name m))) - (unique-objc-classes-in-method-info-list - (car methods)))) - `(typep ,receiver ',(method-class-name (caar methods)))) - ,(build-internal-call-from-method-info - (caar methods) args vargs receiver msg s super)))) - `(cond - ,@(clauses))))) - -(defun build-ambiguous-send-form (message-info args vargs o msg svarforms sinitforms s super) - (let* ((receiver (gensym)) - (caseform (build-send-case - (objc-message-info-ambiguous-methods message-info) - args - vargs - receiver - msg - s - super - (objc-message-info-protocol-methods message-info)))) - `(with-ns-exceptions-as-errors - (rlet ,svarforms - ,@sinitforms - (let* ((,receiver ,o)) - ,caseform))))) - - -;;; Generate the "internal" part of a method call; the "external" part -;;; has established ObjC exception handling and handled structure-return -;; details -(defun build-internal-call-from-method-info (method-info args vargs o msg s super) - (let* ((arglist ())) - (collect ((specs)) - (do* ((args args (cdr args)) - (argtypes (objc-method-info-arglist method-info) (cdr argtypes)) - (reptypes (cdr (objc-method-info-signature method-info)) (cdr reptypes))) - ((null args) (setq arglist (append (specs) vargs))) - (let* ((reptype (if (objc-id-type-p (car argtypes)) :id (car reptypes))) - (arg (car args))) - (specs reptype) - (specs arg))) - ;;(break "~& arglist = ~s" arglist) - (if (result-type-requires-structure-return - (objc-method-info-result-type method-info)) - (if (null s) - ;; STRET required but not provided - (error "The message ~S must be sent using SEND/STRET" msg) - (if (null super) - `(objc-message-send-stret ,s ,o ,msg ,@arglist ,(car (objc-method-info-signature method-info))) - `(objc-message-send-super-stret ,s ,super ,msg ,@arglist ,(car (objc-method-info-signature method-info))))) - (if s - ;; STRET provided but not required - (error "The message ~S must be sent using SEND" msg) - (let* ((result-spec (car (objc-method-info-signature method-info))) - (form (if super - `(objc-message-send-super ,super ,msg ,@arglist ,result-spec) - `(objc-message-send ,o ,msg ,@arglist ,result-spec)))) - form)))))) - -(defun build-call-from-method-info (method-info args vargs o msg svarforms sinitforms s super) - `(with-ns-exceptions-as-errors - (rlet ,svarforms - ,@sinitforms - ,(build-internal-call-from-method-info - method-info - args - vargs - o - msg - s - super)))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Instantiating ObjC Class ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; A MAKE-INSTANCE like interface to ObjC object creation - -(defun make-objc-instance (cname &rest initargs) - (declare (dynamic-extent initargs)) - (multiple-value-bind (ks vs) (keys-and-vals initargs) - (declare (dynamic-extent ks vs)) - (let* ((class (etypecase cname - (string (canonicalize-registered-class - (find-objc-class cname))) - (symbol (find-class cname)) - (class cname)))) - (send-objc-init-message (#/alloc class) ks vs)))) - -;;; Provide the BRIDGE module - -(provide "BRIDGE")