Index: anches/ide-1.0/ccl/cocoa-bridge/bridge.lisp =================================================================== --- /branches/ide-1.0/ccl/cocoa-bridge/bridge.lisp (revision 6863) +++ (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") Index: anches/ide-1.0/ccl/cocoa-bridge/fake-cfbundle-path.lisp =================================================================== --- /branches/ide-1.0/ccl/cocoa-bridge/fake-cfbundle-path.lisp (revision 6863) +++ (revision ) @@ -1,46 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- - -(in-package "CCL") - -;;; Before loading any Cocoa code which depends on CFBundle/NSBundle -;;; being able to find an application bundle, it -may- be neccessary -;;; to point the environment variable "CFProcessPath" to some file -;;; that's where the bundle's executable would be. -;;; This should only be necessary if the current application isn't -;;; already "inside a bundle". If it is necessary, it has to happen -;;; before the CoreFoundation library's initialized. - -(defun fake-cfbundle-path (bundle-root) - (let* ((kernel-name (standard-kernel-name)) - (needle "OPENMCL-KERNEL") - (translated-root (translate-logical-pathname bundle-root)) - (executable-path (merge-pathnames - (make-pathname :directory "Contents/MacOS/" - :name kernel-name) - translated-root)) - (info-plist-proto-path (merge-pathnames "Contents/Info.plist-proto" - translated-root))) - (unless (probe-file info-plist-proto-path) - (error "Can't find Info.plist prototype in ~s" info-plist-proto-path)) - (with-open-file (in info-plist-proto-path - :direction :input - :external-format :utf-8) - (with-open-file (out (make-pathname :directory (pathname-directory info-plist-proto-path) - :name "Info" - :type "plist") - :direction :output - :if-does-not-exist :create - :if-exists :supersede - :external-format :utf-8) - (do* ((line (read-line in nil nil) (read-line in nil nil))) - ((null line)) - (let* ((pos (search needle line))) - (when pos - (setq line - (concatenate 'string - (subseq line 0 pos) - kernel-name - (subseq line (+ pos (length needle))))))) - (write-line line out)))) - (touch executable-path) - (setenv "CFProcessPath" (native-translated-namestring executable-path)))) Index: anches/ide-1.0/ccl/cocoa-bridge/objc-clos.lisp =================================================================== --- /branches/ide-1.0/ccl/cocoa-bridge/objc-clos.lisp (revision 6863) +++ (revision ) @@ -1,918 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2003-2004 Clozure Associates and contributors. -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html -;;; -;;; TO DO -;;; - Both method creation and invocation should be faster and cons less -;;; - Resolve messages with repeated keywords -;;; (rename them to :range1:range2 or don't use &key in GFs and methods) -;;; - How to integrate SEND-SUPER with CALL-NEXT-METHOD? -;;; - Variable arity ObjC methods -;;; - Pass-by-ref structures need to keep track of IN, OUT, IN/OUT info -;;; - Need to canonicalize and retain every returned :ID -;;; - Support :BEFORE, :AFTER and :AROUND for ObjC methods -;;; - User-defined ObjC methods via DEFMETHOD (or DEFINE-OBJ-METHOD) -;;; - Need to fully handle init keywords and ObjC init messages - -;;; Package and module stuff - -(in-package "CCL") - -(eval-when (:compile-toplevel :execute) - #+apple-objc - (use-interface-dir :cocoa) - #+gnu-objc - (use-interface-dir :gnustep)) - -;;; We need OBJC-FOREIGN-ARG-TYPE from the bridge to process ivar types - -(require "BRIDGE") - - -(defparameter *objc-import-private-ivars* t "When true, the CLASS-DIRECT-SLOTS of imported ObjC classes will contain slot definitions for instance variables whose name starts with an underscore. Note that this may exacerbate compatibility problems.") - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Testing ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Enable some debugging output. -(defparameter *objc-clos-debug* nil) - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; OBJC Foreign Object Domain ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconstant objc-type-flags (byte 3 20)) -(defconstant objc-type-index (byte 20 0)) -(defconstant objc-flag-instance 0) -(defconstant objc-flag-class 1) -(defconstant objc-flag-metaclass 2) - -(defvar *objc-class-class*) -(defvar *objc-metaclass-class*) - -(defvar *objc-object-slot-vectors* (make-hash-table :test #'eql)) -(defvar *objc-canonical-instances* (make-hash-table :test #'eql :weak :value)) - -(defun raw-macptr-for-instance (instance) - (let* ((p (%null-ptr))) - (%set-macptr-domain p 1) ; not an ObjC object, but EQL to one - (%setf-macptr p instance) - p)) - -(defun register-canonical-objc-instance (instance raw-ptr) - ;(terminate-when-unreachable instance) - ;(retain-objc-instance instance) - (setf (gethash raw-ptr *objc-canonical-instances*) instance)) - -(defun canonicalize-objc-instance (instance) - (or (gethash instance *objc-canonical-instances*) - (register-canonical-objc-instance - (setq instance (%inc-ptr instance 0)) - (raw-macptr-for-instance instance)))) - - -(defun recognize-objc-object (p) - (labels ((recognize (p mapped) - (let* ((idx (objc-class-id p))) - (if idx - (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx)) - (if (setq idx (objc-metaclass-id p)) - (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx)) - (if (setq idx (%objc-instance-class-index p)) - (%set-macptr-type p idx) - (unless mapped - (if (maybe-map-objc-classes) - (recognize p t))))))))) - (recognize p nil))) - -(defun release-canonical-nsobject (object) - object) - - - -(defun %objc-domain-class-of (p) - (let* ((type (%macptr-type p)) - (flags (ldb objc-type-flags type)) - (index (ldb objc-type-index type))) - (declare (fixnum type flags index)) - (ecase flags - (#.objc-flag-instance (id->objc-class index)) - (#.objc-flag-class (objc-class-id->objc-metaclass index)) - (#.objc-flag-metaclass *objc-metaclass-class*)))) - -(defun %objc-domain-classp (p) - (let* ((type (%macptr-type p)) - (flags (ldb objc-type-flags type))) - (declare (fixnum type flags)) - (not (= flags objc-flag-instance)))) - -(defun %objc-domain-instance-class-wrapper (p) - (let* ((type (%macptr-type p)) - (flags (ldb objc-type-flags type)) - (index (ldb objc-type-index type))) - (declare (fixnum type flags index)) - (ecase flags - (#.objc-flag-instance (id->objc-class-wrapper index)) - (#.objc-flag-class (id->objc-metaclass-wrapper (objc-class-id->objc-metaclass-id index))) - (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*))))) - -(defun %objc-domain-class-own-wrapper (p) - (let* ((type (%macptr-type p)) - (flags (ldb objc-type-flags type)) - (index (ldb objc-type-index type))) - (declare (fixnum type flags index)) - (ecase flags - (#.objc-flag-instance nil) - (#.objc-flag-class (id->objc-class-wrapper index)) - (#.objc-flag-metaclass (id->objc-metaclass-wrapper index))))) - -(defun %objc-domain-slots-vector (p) - (let* ((type (%macptr-type p)) - (flags (ldb objc-type-flags type)) - (index (ldb objc-type-index type))) - (declare (fixnum type flags index)) - (ecase flags - (#.objc-flag-instance (or (gethash p *objc-object-slot-vectors*) - ; try to allocate the slot vector on demand - (let* ((raw-ptr (raw-macptr-for-instance p)) - (slot-vector (create-foreign-instance-slot-vector (class-of p)))) - (when slot-vector - (setf (slot-vector.instance slot-vector) raw-ptr) - (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector) - (register-canonical-objc-instance p raw-ptr) - (initialize-instance p)) - slot-vector) - (error "~s has no slots." p))) - (#.objc-flag-class (id->objc-class-slots-vector index)) - (#.objc-flag-metaclass (id->objc-metaclass-slots-vector index))))) - -(defloadvar *objc-object-domain* - (register-foreign-object-domain :objc - :recognize #'recognize-objc-object - :class-of #'%objc-domain-class-of - :classp #'%objc-domain-classp - :instance-class-wrapper - #'%objc-domain-instance-class-wrapper - :class-own-wrapper - #'%objc-domain-class-own-wrapper - :slots-vector #'%objc-domain-slots-vector)) - -;;; P is known to be a (possibly null!) instance of some ObjC class. -(defun %set-objc-instance-type (p) - (unless (%null-ptr-p p) - (let* ((parent (pref p :objc_object.isa)) - (id (objc-class-id parent))) - (when id - (%set-macptr-domain p *objc-object-domain*) - (%set-macptr-type p id))))) - -;;; P is known to be of type :ID. It may be null. -(defun %set-objc-id-type (p) - (let* ((idx (objc-class-id p))) - (if idx - (progn - (%set-macptr-domain p *objc-object-domain*) - (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx))) - (if (setq idx (objc-metaclass-id p)) - (progn - (%set-macptr-domain p *objc-object-domain*) - (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx))) - (%set-objc-instance-type p))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; ObjC Objects, Classes and Metaclasses ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass objc:objc-object (foreign-standard-object) - ()) - -;;; "Real" OBJC-CLASSes and OBJC-METACLASSEs are subtypes of this -;;; abstract class. We need to keep track of those classes that're -;;; implemented in lisp separately (so that they can be restored after -;;; SAVE-APPLICATION). - -(defclass objc:objc-class-object (foreign-class objc:objc-object) - ((foreign :initform nil :initarg :foreign) - (peer :initform nil :initarg :peer))) - -(defclass objc:objc-metaclass (objc:objc-class-object) - ()) - -(setq *objc-metaclass-class* (find-class 'objc:objc-metaclass)) - -(defclass objc:objc-class (objc:objc-class-object) - ()) - -(setq *objc-class-class* (find-class 'objc:objc-class)) - -(defmethod objc-metaclass-p ((c class)) - nil) - -(defmethod objc-metaclass-p ((c objc:objc-class-object)) - (%objc-metaclass-p c)) - - -(defmethod print-object ((c objc:objc-class) stream) - (print-unreadable-object (c stream) - (format stream "~s ~:[~;[MetaClass] ~]~s (#x~x)" - 'objc:objc-class - (objc-metaclass-p c) - (if (slot-boundp c 'name) - (class-name c) - "") - (%ptr-to-int c)))) - -(defmethod print-object ((c objc:objc-metaclass) stream) - (print-unreadable-object (c stream) - (format stream "~s ~s (#x~x)" - 'objc:objc-metaclass - (if (slot-boundp c 'name) - (class-name c) - "") - (%ptr-to-int c)))) - -(defmethod print-object ((o objc:objc-object) stream) - (if (objc-object-p o) - (print-unreadable-object (o stream :type t) - (format stream - (if (typep o 'ns::ns-string) - "~s (#x~x)" - "~a (#x~x)") - (nsobject-description o) (%ptr-to-int o))) - (format stream "#" (%ptr-to-int o)))) - - - - - - -(defun make-objc-class-object-slots-vector (class meta) - (let* ((n (1+ (length (extract-instance-effective-slotds meta)))) - (slots (allocate-typed-vector :slot-vector n (%slot-unbound-marker)))) - (setf (slot-vector.instance slots) class) - slots)) - -(defun make-objc-metaclass-slots-vector (metaclass) - (make-objc-class-object-slots-vector metaclass *objc-metaclass-class*)) - -(defun make-objc-class-slots-vector (class) - (make-objc-class-object-slots-vector class *objc-class-class*)) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Slot Protocol ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Accessing Lisp slots - -(defmethod slot-boundp-using-class ((class objc:objc-class-object) - instance - (slotd standard-effective-slot-definition)) - (%std-slot-vector-boundp (%objc-domain-slots-vector instance) slotd)) - -(defmethod slot-value-using-class ((class objc:objc-class-object) - instance - (slotd standard-effective-slot-definition)) - (%std-slot-vector-value (%objc-domain-slots-vector instance) slotd)) - -(defmethod (setf slot-value-using-class) - (new - (class objc:objc-class-object) - instance - (slotd standard-effective-slot-definition)) - (%set-std-slot-vector-value (%objc-domain-slots-vector instance) slotd new)) - - -;;; Metaclasses for foreign slots - -(defclass foreign-direct-slot-definition (direct-slot-definition) - ((foreign-type :initform :id :accessor foreign-slot-definition-foreign-type) - (bit-offset :initarg :bit-offset - :initform nil - :accessor foreign-direct-slot-definition-bit-offset - :documentation "A bit-offset, relative to the start of the - instance's slots. The corresponding effective slot definition's - offset is strictly determined by this value"))) - -(defmethod shared-initialize :after ((slotd foreign-direct-slot-definition) - slot-names - &key (foreign-type :id)) - (declare (ignore slot-names)) - (unless (typep foreign-type 'foreign-type) - (setq foreign-type (parse-foreign-type foreign-type))) - (setf (foreign-slot-definition-foreign-type slotd) foreign-type)) - - -(defclass foreign-effective-slot-definition (effective-slot-definition) - ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type) - (getter :type function :accessor foreign-slot-definition-getter) - (setter :type function :accessor foreign-slot-definition-setter))) - - -;;; Use the foreign slot metaclasses if the slot has a :FOREIGN-TYPE attribute -;; - -(defmethod direct-slot-definition-class ((class objc:objc-class-object) - &rest initargs) - (if (getf initargs :foreign-type) - (find-class 'foreign-direct-slot-definition) - (find-class 'standard-direct-slot-definition))) - -(defmethod effective-slot-definition-class ((class objc:objc-class-object) - &rest initargs) - (if (getf initargs :foreign-type) - (find-class 'foreign-effective-slot-definition) - (find-class 'standard-effective-slot-definition))) - - -(defun set-objc-foreign-direct-slot-offsets (dslotds bit-offset) - (dolist (d dslotds) - (let* ((ftype (foreign-slot-definition-foreign-type d)) - (type-alignment (progn (ensure-foreign-type-bits ftype) - (foreign-type-alignment ftype)))) - (setf (foreign-direct-slot-definition-bit-offset d) - (setq bit-offset - (align-offset bit-offset type-alignment))) - (setq bit-offset (+ bit-offset (foreign-type-bits ftype)))))) - -(defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class)) - #-apple-objc-2.0 - (let* ((foreign-dslotds - (loop for d in dslotds - when (typep d 'foreign-direct-slot-definition) - collect d)) - (bit-offset (dolist (c (class-direct-superclasses class) 0) - (when (typep c 'objc::objc-class) - (return - (ash (%objc-class-instance-size c) - 3)))))) - (unless - (dolist (d foreign-dslotds t) - (if (not (foreign-direct-slot-definition-bit-offset d)) - (return nil))) - (set-objc-foreign-direct-slot-offsets foreign-dslotds bit-offset))) - #+apple-objc-2.0 - ;; Add ivars for each foreign direct slot, then ask the runtime for - ;; the ivar's byte offset. (Note that the ObjC 2.0 ivar initialization - ;; protocol doesn't seem to offer support for bitfield-valued ivars.) - (dolist (dslotd dslotds) - (when (typep dslotd 'foreign-direct-slot-definition) - (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd))) - (type (foreign-slot-definition-foreign-type dslotd)) - (encoding (progn - (ensure-foreign-type-bits type) - (encode-objc-type type))) - (size (ceiling (foreign-type-bits type) 8)) - (align (round (log (ceiling (foreign-type-alignment type) 8) 2)))) - (with-cstrs ((name string) - (encoding encoding)) - (#_class_addIvar class name size align encoding) - (with-macptrs ((ivar (#_class_getInstanceVariable class name))) - (unless (%null-ptr-p ivar) - (let* ((offset (#_ivar_getOffset ivar))) - (setf (foreign-direct-slot-definition-bit-offset dslotd) - (ash offset 3)))))))))) - - -#+apple-objc-2.0 -(defun %revive-foreign-slots (class) - (dolist (dslotd (class-direct-slots class)) - (when (typep dslotd 'foreign-direct-slot-definition) - (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd))) - (type (foreign-slot-definition-foreign-type dslotd)) - (encoding (progn - (ensure-foreign-type-bits type) - (encode-objc-type type))) - (size (ceiling (foreign-type-bits type) 8)) - (align (round (log (ceiling (foreign-type-alignment type) 8) 2)))) - (with-cstrs ((name string) - (encoding encoding)) - (#_class_addIvar class name size align encoding) - (with-macptrs ((ivar (#_class_getInstanceVariable class name))) - (unless (%null-ptr-p ivar) - (let* ((offset (#_ivar_getOffset ivar))) - (unless (eql (foreign-direct-slot-definition-bit-offset dslotd) - (ash offset 3)) - (dbg)))))))))) - -(defun lisp-defined-slot-name-to-objc-slot-name (lisp-name) - (lisp-to-objc-message (list lisp-name))) - -;;; This is only going to be called on a class created by the user; -;;; each foreign direct slotd's offset field should already have been -;;; set to the slot's bit offset. -#-apple-objc-2.0 -(defun %make-objc-ivars (class) - (let* ((start-offset (superclass-instance-size class)) - (foreign-dslotds (loop for s in (class-direct-slots class) - when (typep s 'foreign-direct-slot-definition) - collect s))) - (if (null foreign-dslotds) - (values (%null-ptr) start-offset) - (let* ((n (length foreign-dslotds)) - (offset start-offset) - (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size - :objc_ivar :bytes)))))) - (setf (pref ivars :objc_ivar_list.ivar_count) n) - (do* ((l foreign-dslotds (cdr l)) - (dslotd (car l) (car l)) - (ivar (pref ivars :objc_ivar_list.ivar_list) - (%inc-ptr ivar (%foreign-type-or-record-size - :objc_ivar :bytes)))) - ((null l) (values ivars (ash (align-offset offset 32) 3))) - (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd))) - (type (foreign-slot-definition-foreign-type dslotd)) - (encoding (progn - (ensure-foreign-type-bits type) - (encode-objc-type type)))) - (setq offset (foreign-direct-slot-definition-bit-offset dslotd)) - (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string) - (pref ivar :objc_ivar.ivar_type) (make-cstring encoding) - (pref ivar :objc_ivar.ivar_offset) (ash offset -3)) - (incf offset (foreign-type-bits type)))))))) - - - -(defun %objc-ivar-offset-in-class (name c) - ;; If C is a non-null ObjC class that contains an instance variable - ;; named NAME, return that instance variable's offset, else return - ;; NIL. - #+apple-objc-2.0 - (with-cstrs ((name name)) - (with-macptrs ((ivar (#_class_getInstanceVariable c name))) - (unless (%null-ptr-p ivar) - (#_ivar_getOffset ivar)))) - #-apple-objc-2.0 - (when (objc-class-p c) - (with-macptrs ((ivars (pref c :objc_class.ivars))) - (unless (%null-ptr-p ivars) - (loop with n = (pref ivars :objc_ivar_list.ivar_count) - for i from 1 to n - for ivar = (pref ivars :objc_ivar_list.ivar_list) - then (%inc-ptr ivar (record-length :objc_ivar)) - when (string= name (%get-cstring (pref ivar :objc_ivar.ivar_name))) - do (return-from %objc-ivar-offset-in-class (pref ivar :objc_ivar.ivar_offset))))))) - -(defun %objc-ivar-offset (name c) - (labels ((locate-objc-slot (name class) - (unless (%null-ptr-p class) - (or (%objc-ivar-offset-in-class name class) - (with-macptrs ((super #+apple-objc-2.0 - (#_class_getSuperclass class) - #-apple-objc-2.0 - (pref class :objc_class.super_class))) - (unless (or (%null-ptr-p super) (eql super class)) - (locate-objc-slot name super))))))) - (when (objc-class-p c) - (or (locate-objc-slot name c) - (error "No ObjC instance variable named ~S in ~S" name c))))) - -;;; Maintain the class wrapper of an ObjC class or metaclass. - -(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-metaclass)) - (setf (id->objc-metaclass-wrapper (objc-metaclass-id class)) wrapper)) - -(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-class)) - (setf (id->objc-class-wrapper (objc-class-id class)) wrapper)) - -;;; Return the getter and setter functions for a foreign slot -;;; NOTE: Should be changed to use FOREIGN-TYPE-TO-REPRESENTATION-TYPE - -(defun compute-foreign-slot-accessors (eslotd) - (let* ((ftype (foreign-slot-definition-foreign-type eslotd)) - (ordinal (foreign-type-ordinal ftype))) - (etypecase ftype - (foreign-integer-type - (let* ((bits (foreign-integer-type-bits ftype)) - (align (foreign-integer-type-alignment ftype)) - (signed (foreign-integer-type-signed ftype))) - (if (= bits align) - (ecase bits - (1 (values #'%get-bit #'%set-bit)) - (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte) - #'%set-byte)) - (16 (values (if signed #'%get-signed-word #'%get-unsigned-word) - #'%set-word)) - (32 (values (if signed #'%get-signed-long #'%get-unsigned-long) - #'%set-long)) - (64 (if signed - (values #'%%get-signed-longlong #'%%set-signed-longlong) - (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong)))) - (values #'(lambda (ptr offset) - (%get-bitfield ptr offset bits)) - #'(lambda (ptr offset new) - (setf (%get-bitfield ptr offset bits) new)))))) - (foreign-double-float-type - (values #'%get-double-float #'%set-double-float)) - (foreign-single-float-type - (values #'%get-single-float #'%set-single-float)) - (foreign-pointer-type - (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 #'(lambda (ptr offset) - (let* ((p (%inc-ptr ptr offset))) - (%set-macptr-type p ordinal) - p)) - #'(lambda (pointer offset new) - (setf (%composite-pointer-ref - nbytes - pointer - offset) - new)))))))) - - - -;;; Shadow SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with a -;;; method for OBJC-CLASSes that sets up foreign slot info. - -(defmethod compute-effective-slot-definition :around ((class objc:objc-class-object) - name - direct-slots) - (let* ((first (first direct-slots))) - (if (not (typep first 'foreign-direct-slot-definition)) - (call-next-method) - (let* ((initer (dolist (s direct-slots) - (when (%slot-definition-initfunction s) - (return s)))) - (documentor (dolist (s direct-slots) - (when (%slot-definition-documentation s) - (return s)))) - (initargs (let* ((initargs nil)) - (dolist (dslot direct-slots initargs) - (dolist (dslot-arg (%slot-definition-initargs dslot)) - (pushnew dslot-arg initargs :test #'eq))))) - (eslotd - (make-effective-slot-definition - class - :name name - :allocation :instance - :type (or (%slot-definition-type first) t) - :documentation (when documentor (nth-value - 1 - (%slot-definition-documentation - documentor))) - :class (%slot-definition-class first) - :initargs initargs - :initfunction (if initer - (%slot-definition-initfunction initer)) - :initform (if initer (%slot-definition-initform initer)) - :foreign-type (foreign-slot-definition-foreign-type first)))) - (multiple-value-bind (getter setter) (compute-foreign-slot-accessors eslotd) - (setf (foreign-slot-definition-getter eslotd) getter) - (setf (foreign-slot-definition-setter eslotd) setter)) - eslotd)))) - -(defun bit-offset-to-location (bit-offset foreign-type) - (ensure-foreign-type-bits foreign-type) - (let* ((bits (foreign-type-bits foreign-type))) - (if (or (= bits 1) - (not (= bits (foreign-type-alignment foreign-type)))) - bit-offset - (ash bit-offset -3)))) - -;;; Determine the location of each slot -;;; An effective slot's location is -;;; a) a function of the class's origin (superclass-instance-size) -;;; and the corresponding direct class's offset, if it's defined in the -;;; class (has a corresponding direct-slot-definition in the class) -;;; b) Exactly the same as the superclass's version's location, because -;;; of single inheritance. - -(defun determine-foreign-slot-location (class slot-name) - (or - (dolist (d (class-direct-slots class)) - (when (and (eq slot-name (slot-definition-name d)) - (typep d 'foreign-direct-slot-definition)) - (return (bit-offset-to-location - (foreign-direct-slot-definition-bit-offset d) - (foreign-slot-definition-foreign-type d ))))) - (dolist (super (class-direct-superclasses class)) - (when (typep super 'objc:objc-class) ; can be at most 1 - (let* ((e (find slot-name (class-slots super) :key #'slot-definition-name))) - (when e (return (slot-definition-location e)))))) - (error "Can't find slot definition for ~s in ~s" slot-name class))) - - -(defmethod compute-slots :around ((class objc:objc-class-object)) - (flet ((foreign-slot-p (s) (typep s 'foreign-effective-slot-definition))) - (let* ((cpl (%class-precedence-list class)) - (slots (call-next-method)) - (instance-slots - (remove-if #'foreign-slot-p - (remove :class slots :key #'%slot-definition-allocation))) - (class-slots (remove :instance slots :key #'%slot-definition-allocation)) - (foreign-slots (remove-if-not #'foreign-slot-p slots))) - (setq instance-slots - (sort-effective-instance-slotds instance-slots class cpl)) - (when *objc-clos-debug* - (format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%" - instance-slots class-slots foreign-slots)) - (loop for islot in instance-slots - for loc = 1 then (1+ loc) - do (setf (%slot-definition-location islot) loc)) - (dolist (cslot class-slots) - (setf (%slot-definition-location cslot) - (assoc (%slot-definition-name cslot) - (%class-get (%slot-definition-class cslot) :class-slots) - :test #'eq))) - (dolist (fslot foreign-slots) - (setf (%slot-definition-location fslot) - (determine-foreign-slot-location - class - (%slot-definition-name fslot)))) - (append instance-slots class-slots foreign-slots)))) - - -;;; Accessing foreign slots - -(defmethod slot-boundp-using-class ((class objc:objc-class-object) - instance - (slotd foreign-effective-slot-definition)) - (declare (ignore class instance slotd)) - ;; foreign slots are always bound - t) - -(defmethod slot-makunbound-using-class ((class objc:objc-class-object) - instance - (slotd foreign-effective-slot-definition)) - (declare (ignore instance)) - (error "Foreign slots cannot be unbound: ~S" (slot-definition-name slotd))) - -(defmethod slot-value-using-class ((class objc:objc-class-object) - instance - (slotd foreign-effective-slot-definition)) - (funcall (foreign-slot-definition-getter slotd) - instance - (slot-definition-location slotd))) - -(defmethod (setf slot-value-using-class) (value - (class objc:objc-class-object) - instance - (slotd foreign-effective-slot-definition)) - (funcall (foreign-slot-definition-setter slotd) - instance - (slot-definition-location slotd) - value)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Instance Allocation and Initialization Protocols ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod make-instance ((class objc:objc-class-object) &rest initargs) - (let ((instance (apply #'allocate-instance class initargs))) - (apply #'initialize-instance instance initargs))) - - -(defun remove-slot-initargs (class initargs) - (let* ((slot-initargs (class-slot-initargs class))) ; cache this, maybe - (collect ((new-initargs)) - (loop for l = initargs then (cddr l) - when (null l) do (return-from remove-slot-initargs (new-initargs)) - unless (member (first l) slot-initargs :test #'eq) - do - (new-initargs (car l)) - (new-initargs (cadr l)))))) - -(defun create-foreign-instance-slot-vector (class) - (let* ((max 0)) - (dolist (slotd (class-slots class) - (unless (zerop max) - (allocate-typed-vector :slot-vector (1+ max) (%slot-unbound-marker)))) - (when (typep slotd 'standard-effective-slot-definition) - (let* ((loc (slot-definition-location slotd))) - (if (> loc max) - (setq max loc))))))) - - - -(defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (let* ((instance - (multiple-value-bind (ks vs) (keys-and-vals (remove-slot-initargs - class - initargs)) - (send-objc-init-message (allocate-objc-object class) ks vs)))) - (unless (%null-ptr-p instance) - (or (gethash instance *objc-object-slot-vectors*) - (let* ((slot-vector (create-foreign-instance-slot-vector class))) - (when slot-vector - (let* ((raw-ptr (raw-macptr-for-instance instance))) - (setf (slot-vector.instance slot-vector) raw-ptr) - (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector) - (register-canonical-objc-instance instance raw-ptr)))))) - instance)) - -(defmethod terminate ((instance objc:objc-object)) - (objc-message-send instance "release")) - - - -(defmethod initialize-instance ((instance objc:objc-object) &rest initargs) - (apply #'shared-initialize instance t initargs)) - -(defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs) - (apply #'shared-initialize instance nil initargs)) - -(defmethod initialize-instance :after ((class objc:objc-class) &rest initargs) - (declare (ignore initargs)) - (unless (slot-value class 'foreign) - #-apple-objc-2.0 - (multiple-value-bind (ivars instance-size) - (%make-objc-ivars class) - (%add-objc-class class ivars instance-size)) - #+apple-objc-2.0 - (%add-objc-class class))) - -(defmethod shared-initialize ((instance objc:objc-object) slot-names - &rest initargs) - (let ((class (class-of instance))) - ;; Initialize CLOS slots - (dolist (slotd (class-slots class)) - (when (not (typep slotd 'foreign-effective-slot-definition)) ; For now - (let ((sname (slot-definition-name slotd)) - (slot-type (slot-definition-type slotd)) - (typepred (slot-value slotd 'type-predicate)) - (initfunction (slot-definition-initfunction slotd))) - (multiple-value-bind (ignore newval foundp) - (get-properties initargs - (slot-definition-initargs slotd)) - (declare (ignore ignore)) - (if foundp - (if (funcall typepred newval) - (setf (slot-value instance sname) newval) - (report-bad-arg newval slot-type)) - (let* ((loc (slot-definition-location slotd)) - (curval (%standard-instance-instance-location-access - instance loc))) - (when (and (or (eq slot-names t) - (member sname slot-names :test #'eq)) - (eq curval (%slot-unbound-marker)) - initfunction) - (let ((newval (funcall initfunction))) - (unless (funcall typepred newval) - (report-bad-arg newval slot-type)) - (setf (%standard-instance-instance-location-access - instance loc) - newval))))))))) - instance)) - -(defmethod shared-initialize :after ((spec foreign-effective-slot-definition) - slot-names - &key &allow-other-keys) - (declare (ignore slot-names)) - (setf (slot-value spec 'type-predicate) #'true)) - -;;; The CLASS-OF an existing OBJC:OBJC-CLASS is an OBJC:OBJC-METACLASS, -;;; but not necessarily the one specified as a :metaclass option to -;;; DEFCLASS or ENSURE-CLASS. Allow an existing class to be reinitialized, -;;; as long as the specified :metaclass and the class's own class have -;;; the same metaclass and specified metaclass is a root class. - -(defmethod ensure-class-using-class ((class objc:objc-class) - name - &rest keys &key) - (multiple-value-bind (metaclass initargs) - (ensure-class-metaclass-and-initargs class keys) - (let* ((existing-metaclass (class-of class))) - (if (and (eq (class-of metaclass) - (class-of existing-metaclass)) - ;; A root metaclass has the corresponding class as - ;; its superclass, and that class has no superclass. - (with-macptrs ((super #+apple-objc-2.0 - (#_class_getSuperclass metaclass) - #-apple-objc-2.0 - (pref metaclass :objc_class.super_class))) - (and (not (%null-ptr-p super)) - (not (%objc-metaclass-p super)) - (%null-ptr-p - #+apple-objc-2.0 - (#_class_getSuperclass super) - #-apple-objc-2.0 - (pref super :objc_class.super_class))))) - ;; Whew! it's ok to reinitialize the class. - (progn - (apply #'reinitialize-instance class initargs) - (setf (find-class name) class)) - (error "Can't change metaclass of ~s to ~s." class metaclass))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Class Definition and Finalization Protocols ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Create the ObjC class/metaclass pair and dress it up in its minimal CLOS garb -;;; This currently requires that exactly one of DIRECT-SUPERCLASSES be a -;;; already existing subclass of OBJC:OBJC-CLASS - -(defun compute-objc-variable-name (sym) - (let* ((pname (string sym)) - (first-alpha (position-if #'alpha-char-p pname))) - (string-downcase - (apply #'string-cat - (mapcar #'string-capitalize (split-if-char #\- pname :elide))) - :end (if first-alpha (1+ first-alpha) 1)))) - -(defmethod allocate-instance ((metaclass objc:objc-metaclass) - &key name direct-superclasses - &allow-other-keys) - (let ((superclass - (loop for s in direct-superclasses - when (typep s 'objc:objc-class) - collect s into objc-supers - finally - (if (= (length objc-supers) 1) - (return (first objc-supers)) - (error "Exactly one OBJC:OBJC-CLASS must appear in ~S, found ~S" - direct-superclasses - (length objc-supers)))))) - (%allocate-objc-class name superclass))) - -(defmethod shared-initialize ((class objc:objc-class-object) slot-names &rest initargs) - (%shared-initialize class slot-names initargs)) - -(defmethod validate-superclass ((c1 objc:objc-class) (c2 objc:objc-class)) - t) - -(defmethod make-instances-obsolete ((class objc:objc-class)) - class) - -;;; Reader/writer methods for instances of OBJC:OBJC-CLASS -(defmethod reader-method-class ((class objc:objc-class) - (dslotd direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - (find-class 'standard-reader-method)) - -(defmethod writer-method-class ((class objc:objc-class) - (dslotd direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - (find-class 'standard-writer-method)) - - -;;; 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)) - - Index: anches/ide-1.0/ccl/cocoa-bridge/objc-package.lisp =================================================================== --- /branches/ide-1.0/ccl/cocoa-bridge/objc-package.lisp (revision 6863) +++ (revision ) @@ -1,59 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2007 Clozure Associates and contributors. -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html -;;; - -(in-package "CCL") - -;;; All class names and instance variable names are interned in the NS package -;;; Force all symbols interned in the NS package to be external - -(defpackage "NS" - (:use) - (:export "+CGFLOAT-ZERO+" "CGFLOAT")) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (package-force-export "NS")) - -;;; ObjC function names (as produced by #/) are interned in NSF. -(defpackage "NEXTSTEP-FUNCTIONS" - (:use) - (:nicknames "NSFUN")) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (package-force-export "NSFUN")) - -(defpackage "OBJC" - (:use) - (:export "OBJC-OBJECT" "OBJC-CLASS-OBJECT" "OBJC-CLASS" "OBJC-METACLASS" - "@CLASS" "@SELECTOR" "MAKE-OBJC-INSTANCE" "RETURNING-FOREIGN-STRUCT" - "DEFMETHOD" "SLET" "SEND" "SEND/STRET" "SEND-SUPER" "SEND-SUPER/STRET" - "DEFINE-OBJC-METHOD" "DEFINE-OBJC-CLASS-METHOD" - "OBJC-MESSAGE-SEND" "OBJC-MESSAGE-SEND-STRET" - "OBJC-MESSAGE-SEND-SUPER" "OBJC-MESSAGE-SEND-SUPER-STRET" - "LOAD-FRAMEWORK")) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (import '(objc:@class objc:@selector objc:make-objc-instance - objc:send objc:send/stret objc:send-super objc:send-super/stret - ns:+cgfloat-zero+ ns:cgfloat - objc:define-objc-method objc:define-objc-class-method - objc:objc-message-send objc:objc-message-send-stret - objc:objc-message-send-super objc:objc-message-send-super-stret - ) - "CCL")) - -(provide "OBJC-PACKAGE") Index: anches/ide-1.0/ccl/cocoa-bridge/objc-runtime.lisp =================================================================== --- /branches/ide-1.0/ccl/cocoa-bridge/objc-runtime.lisp (revision 6863) +++ (revision ) @@ -1,2884 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2002-2003 Clozure Associates -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html - - -(in-package "CCL") - - -;;; Utilities for interacting with the Apple/GNU Objective-C runtime -;;; systems. - -(eval-when (:compile-toplevel :load-toplevel :execute) - #+darwin-target (pushnew :apple-objc *features*) - #+(and darwin-target 64-bit-target) (pushnew :apple-objc-2.0 *features*) - #-darwin-target (pushnew :gnu-objc *features*)) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (set-dispatch-macro-character - #\# - #\@ - (nfunction - |objc-#@-reader| - (lambda (stream subchar numarg) - (declare (ignore subchar numarg)) - (let* ((string (read stream))) - (unless *read-suppress* - (check-type string string) - `(@ ,string))))))) - -(eval-when (:compile-toplevel :execute) - #+apple-objc - (progn - (use-interface-dir :cocoa) - (use-interface-dir :carbon)) ; need :carbon for things in this file - #+gnu-objc - (use-interface-dir :gnustep)) - - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "OBJC-PACKAGE") - (require "SPLAY-TREE") - (require "NAME-TRANSLATION") - (require "OBJC-CLOS")) - -(defloadvar *NSApp* nil ) - -;;; Apple ObjC 2.0 provides (#_objc_getProtocol name). In other -;;; runtimes, there doesn't seem to be any way to find a Protocol -;;; object given its name. We need to be able to ask at runtime -;;; whether a given object conforms to a protocol in order to -;;; know when a protocol method is ambiguous, at least when the -;;; message contains ambiguous methods and some methods are protocol -;;; methods -(defvar *objc-protocols* (make-hash-table :test #'equal)) - - -(defstruct objc-protocol - name - address) - - -(defun clear-objc-protocols () - (maphash #'(lambda (name proto) - (declare (ignore name)) - (setf (objc-protocol-address proto) nil)) - *objc-protocols*)) - -(defun lookup-objc-protocol (name) - (values (gethash name *objc-protocols*))) - -(defun ensure-objc-classptr-resolved (classptr) - #+apple-objc (declare (ignore classptr)) - #+gnu-objc - (unless (logtest #$_CLS_RESOLV (pref classptr :objc_class.info)) - (external-call "__objc_resolve_class_links" :void))) - - - -(defstruct private-objc-class-info - name - declared-ancestor) - -(defun compute-objc-direct-slots-from-info (info class) - (let* ((ns-package (find-package "NS"))) - (mapcar #'(lambda (field) - (let* ((name (compute-lisp-name (unescape-foreign-name - (foreign-record-field-name - field)) - ns-package)) - - (type (foreign-record-field-type field)) - (offset (progn - (ensure-foreign-type-bits type) - (foreign-record-field-offset field)))) - (make-instance 'foreign-direct-slot-definition - :initfunction #'false - :initform nil - :name name - :foreign-type type - :class class - :bit-offset offset - :allocation :instance))) - (db-objc-class-info-ivars info)))) - - -(defun %ptr< (x y) - (< (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32) - (%ptr-to-int x)) - (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32) - (%ptr-to-int Y)))) - -(let* ((objc-class-map (make-splay-tree #'%ptr-eql #'%ptr<)) - (objc-metaclass-map (make-splay-tree #'%ptr-eql #'%ptr<)) - ;;; These are NOT lisp classes; we mostly want to keep track - ;;; of them so that we can pretend that instances of them - ;;; are instances of some known (declared) superclass. - (private-objc-classes (make-splay-tree #'%ptr-eql #'%ptr<)) - (objc-class-lock (make-lock)) - (next-objc-class-id 0) - (next-objc-metaclass-id 0) - (class-table-size 1024) - (c (make-array class-table-size)) - (m (make-array class-table-size)) - (cw (make-array 1024 :initial-element nil)) - (mw (make-array 1024 :initial-element nil)) - (csv (make-array 1024)) - (msv (make-array 1024)) - (class-id->metaclass-id (make-array 1024 :initial-element nil)) - (class-foreign-names (make-array 1024)) - (metaclass-foreign-names (make-array 1024)) - ) - - (flet ((grow-vectors () - (let* ((old-size class-table-size) - (new-size (* 2 old-size))) - (declare (fixnum old-size new-size)) - (macrolet ((extend (v) - `(setq ,v (%extend-vector old-size ,v new-size)))) - (extend c) - (extend m) - (extend cw) - (extend mw) - (fill cw nil :start old-size :end new-size) - (fill mw nil :start old-size :end new-size) - (extend csv) - (extend msv) - (extend class-id->metaclass-id) - (fill class-id->metaclass-id nil :start old-size :end new-size) - (extend class-foreign-names) - (extend metaclass-foreign-names)) - (setq class-table-size new-size)))) - (flet ((assign-next-class-id () - (let* ((id next-objc-class-id)) - (if (= (incf next-objc-class-id) class-table-size) - (grow-vectors)) - id)) - (assign-next-metaclass-id () - (let* ((id next-objc-metaclass-id)) - (if (= (incf next-objc-metaclass-id) class-table-size) - (grow-vectors)) - id))) - (defun id->objc-class (i) - (svref c i)) - (defun (setf id->objc-class) (new i) - (setf (svref c i) new)) - (defun id->objc-metaclass (i) - (svref m i)) - (defun (setf id->objc-metaclass) (new i) - (setf (svref m i) new)) - (defun id->objc-class-wrapper (i) - (svref cw i)) - (defun (setf id->objc-class-wrapper) (new i) - (setf (svref cw i) new)) - (defun id->objc-metaclass-wrapper (i) - (svref mw i)) - (defun (setf id->objc-metaclass-wrapper) (new i) - (setf (svref mw i) new)) - (defun id->objc-class-slots-vector (i) - (svref csv i)) - (defun (setf id->objc-class-slots-vector) (new i) - (setf (svref csv i) new)) - (defun id->objc-metaclass-slots-vector (i) - (svref msv i)) - (defun (setf id->objc-metaclass-slots-vector) (new i) - (setf (svref msv i) new)) - (defun objc-class-id-foreign-name (i) - (svref class-foreign-names i)) - (defun (setf objc-class-id-foreign-name) (new i) - (setf (svref class-foreign-names i) new)) - (defun objc-metaclass-id-foreign-name (i) - (svref metaclass-foreign-names i)) - (defun (setf objc-metaclass-id-foreign-name) (new i) - (setf (svref metaclass-foreign-names i) new)) - (defun %clear-objc-class-maps () - (with-lock-grabbed (objc-class-lock) - (setf (splay-tree-root objc-class-map) nil - (splay-tree-root objc-metaclass-map) nil - (splay-tree-root private-objc-classes) nil - (splay-tree-count objc-class-map) 0 - (splay-tree-count objc-metaclass-map) 0 - (splay-tree-count private-objc-classes) 0))) - (flet ((install-objc-metaclass (meta) - (or (splay-tree-get objc-metaclass-map meta) - (let* ((id (assign-next-metaclass-id)) - (meta (%inc-ptr meta 0))) - (splay-tree-put objc-metaclass-map meta id) - (setf (svref m id) meta - (svref msv id) - (make-objc-metaclass-slots-vector meta)) - id)))) - (defun register-objc-class (class) - "ensure that the class is mapped to a small integer and associate a slots-vector with it." - (with-lock-grabbed (objc-class-lock) - (ensure-objc-classptr-resolved class) - (or (splay-tree-get objc-class-map class) - (let* ((id (assign-next-class-id)) - (class (%inc-ptr class 0)) - (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer))) - (splay-tree-put objc-class-map class id) - (setf (svref c id) class - (svref csv id) - (make-objc-class-slots-vector class) - (svref class-id->metaclass-id id) - (install-objc-metaclass meta)) - id))))) - (defun objc-class-id (class) - (with-lock-grabbed (objc-class-lock) - (splay-tree-get objc-class-map class))) - (defun objc-metaclass-id (meta) - (with-lock-grabbed (objc-class-lock) - (splay-tree-get objc-metaclass-map meta))) - (defun objc-class-id->objc-metaclass-id (class-id) - (svref class-id->metaclass-id class-id)) - (defun objc-class-id->objc-metaclass (class-id) - (svref m (svref class-id->metaclass-id class-id))) - (defun objc-class-map () objc-class-map) - (defun %objc-class-count () next-objc-class-id) - (defun objc-metaclass-map () objc-metaclass-map) - (defun %objc-metaclass-count () next-objc-metaclass-id) - (defun %register-private-objc-class (c name) - (splay-tree-put private-objc-classes c (make-private-objc-class-info :name name))) - (defun %get-private-objc-class (c) - (splay-tree-get private-objc-classes c)) - (defun (setf %get-private-objc-class) (public c) - (let* ((node (binary-tree-get private-objc-classes c))) - (if node - (setf (tree-node-value node) public) - (error "Private class ~s not found" c)))) - (defun private-objc-classes () - private-objc-classes)))) - -(pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq - :key #'function-name) - -(defun do-all-objc-classes (f) - (map-splay-tree (objc-class-map) #'(lambda (id) - (funcall f (id->objc-class id))))) - -(defun canonicalize-registered-class (c) - (let* ((id (objc-class-id c))) - (if id - (id->objc-class id) - (error "Class ~S isn't recognized." c)))) - -(defun canonicalize-registered-metaclass (m) - (let* ((id (objc-metaclass-id m))) - (if id - (id->objc-metaclass id) - (error "Class ~S isn't recognized." m)))) - -(defun canonicalize-registered-class-or-metaclass (x) - (if (%objc-metaclass-p x) - (canonicalize-registered-metaclass x) - (canonicalize-registered-class x))) - - -;;; Open shared libs. -#+darwin-target -(progn -(defloadvar *cocoa-event-process* *initial-process*) - - -(defun current-ns-thread () - (with-cstrs ((class-name "NSThread") - (message-selector-name "currentThread")) - (let* ((nsthread-class (#_objc_lookUpClass class-name)) - (message-selector (#_sel_getUid message-selector-name))) - (#_objc_msgSend nsthread-class message-selector) - nil))) - -(defun create-void-nsthread () - ;; Create an NSThread which does nothing but exit. - ;; This'll help to convince the AppKit that we're - ;; multitheaded. (A lot of other things, including - ;; the ObjC runtime, seem to have already noticed.) - (with-cstrs ((thread-class-name "NSThread") - (pool-class-name "NSAutoreleasePool") - (thread-message-selector-name "detachNewThreadSelector:toTarget:withObject:") - (exit-selector-name "exit") - (alloc-selector-name "alloc") - (init-selector-name "init") - (release-selector-name "release")) - (let* ((nsthread-class (#_objc_lookUpClass thread-class-name)) - (pool-class (#_objc_lookUpClass pool-class-name)) - (thread-message-selector (#_sel_getUid thread-message-selector-name)) - (exit-selector (#_sel_getUid exit-selector-name)) - (alloc-selector (#_sel_getUid alloc-selector-name)) - (init-selector (#_sel_getUid init-selector-name)) - (release-selector (#_sel_getUid release-selector-name)) - (pool (#_objc_msgSend - (#_objc_msgSend pool-class - alloc-selector) - init-selector))) - (unwind-protect - (#_objc_msgSend nsthread-class thread-message-selector - :address exit-selector - :address nsthread-class - :address (%null-ptr)) - (#_objc_msgSend pool release-selector)) - nil))) - -(defun run-in-cocoa-process-and-wait (f) - (let* ((process *cocoa-event-process*) - (success (cons nil nil)) - (done (make-semaphore))) - (process-interrupt process #'(lambda () - (unwind-protect - (progn - (setf (car success) (funcall f))) - (signal-semaphore done)))) - (wait-on-semaphore done) - (car success))) - - -(def-ccl-pointers cocoa-framework () - (run-in-cocoa-process-and-wait - #'(lambda () - ;; We need to load and "initialize" the CoreFoundation library - ;; in the thread that's going to process events. Looking up a - ;; symbol in the library should cause it to be initialized - (open-shared-library "/System/Library/Frameworks/Cocoa.framework/Cocoa") - ;(#_GetCurrentEventQueue) - (current-ns-thread) - (create-void-nsthread)))) - - -(defun find-cfstring-sections () - (warn "~s is obsolete" 'find-cfstring-sections)) - -) - -#+gnu-objc -(progn -(defparameter *gnustep-system-root* "/usr/GNUstep/" "The root of all evil.") -(defparameter *gnustep-libraries-pathname* - (merge-pathnames "System/Library/Libraries/" *gnustep-system-root*)) - -(defloadvar *pending-loaded-classes* ()) - -(defcallback register-class-callback (:address class :address category :void) - (let* ((id (map-objc-class class))) - (unless (%null-ptr-p category) - (let* ((cell (or (assoc id *pending-loaded-classes*) - (let* ((c (list id))) - (push c *pending-loaded-classes*) - c)))) - (push (%inc-ptr category 0) (cdr cell)))))) - -;;; Shouldn't really be GNU-objc-specific. - -(defun get-c-format-string (c-format-ptr c-arg-ptr) - (do* ((n 128)) - () - (declare (fixnum n)) - (%stack-block ((buf n)) - (let* ((m (#_vsnprintf buf n c-format-ptr c-arg-ptr))) - (declare (fixnum m)) - (cond ((< m 0) (return nil)) - ((< m n) (return (%get-cstring buf))) - (t (setq n m))))))) - - - -(defun init-gnustep-framework () - (or (getenv "GNUSTEP_SYSTEM_ROOT") - (setenv "GNUSTEP_SYSTEM_ROOT" *gnustep-system-root*)) - (open-shared-library "libobjc.so.1") - (setf (%get-ptr (foreign-symbol-address "_objc_load_callback")) - register-class-callback) - (open-shared-library (namestring (merge-pathnames "libgnustep-base.so" - *gnustep-libraries-pathname*))) - (open-shared-library (namestring (merge-pathnames "libgnustep-gui.so" - *gnustep-libraries-pathname*)))) - -(def-ccl-pointers gnustep-framework () - (init-gnustep-framework)) -) - -(defun get-appkit-version () - #+apple-objc - #&NSAppKitVersionNumber - #+gnu-objc - (get-foundation-version)) - -(defun get-foundation-version () - #&NSFoundationVersionNumber - #+gnu-objc (%get-cstring (foreign-symbol-address "gnustep_base_version"))) - -(defparameter *appkit-library-version-number* (get-appkit-version)) -(defparameter *foundation-library-version-number* (get-foundation-version)) - -(defparameter *extension-framework-paths* ()) - -;;; An instance of NSConstantString (which is a subclass of NSString) -;;; consists of a pointer to the NSConstantString class (which the -;;; global "_NSConstantStringClassReference" conveniently refers to), a -;;; pointer to an array of 8-bit characters (doesn't have to be #\Nul -;;; terminated, but doesn't hurt) and the length of that string (not -;;; counting any #\Nul.) -;;; The global reference to the "NSConstantString" class allows us to -;;; make instances of NSConstantString, ala the @"foo" construct in -;;; ObjC. Sure it's ugly, but it seems to be exactly what the ObjC -;;; compiler does. - - -(defloadvar *NSConstantString-class* - (with-cstrs ((name "NSConstantString")) - #+apple-objc (#_objc_lookUpClass name) - #+gnu-objc (#_objc_lookup_class name))) - - - - -#+apple-objc -(progn -;;; NSException-handling stuff. -;;; First, we have to jump through some hoops so that #_longjmp can -;;; jump through some hoops (a jmp_buf) and wind up throwing to a -;;; lisp catch tag. - -;;; These constants (offsets in the jmp_buf structure) come from -;;; the _setjmp.h header file in the Darwin LibC source. - -#+ppc32-target -(progn -(defconstant JMP-lr #x54 "link register (return address) offset in jmp_buf") -#|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|# -(defconstant JMP-sp 0 "stack pointer offset in jmp_buf") -(defconstant JMP-r14 12 "offset of r14 (which we clobber) in jmp_buf") -(defconstant JMP-r15 16 "offset of r14 (which we also clobber) in jmp_buf")) - -#+ppc64-target -(progn -(defconstant JMP-lr #xa8 "link register (return address) offset in jmp_buf") -#|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|# -(defconstant JMP-sp 0 "stack pointer offset in jmp_buf") -(defconstant JMP-r13 #x10 "offset of r13 (which we preserve) in jmp_buf") -(defconstant JMP-r14 #x18 "offset of r14 (which we clobber) in jmp_buf") -(defconstant JMP-r15 #x20 "offset of r15 (which we also clobber) in jmp_buf")) - -;;; These constants also come from Libc sources. Hey, who needs -;;; header files ? -#+x8664-target -(progn -(defconstant JB-RBX 0) -(defconstant JB-RBP 8) -(defconstant JB-RSP 16) -(defconstant JB-R12 24) -(defconstant JB-R13 32) -(defconstant JB-R14 40) -(defconstant JB-R15 48) -(defconstant JB-RIP 56) -(defconstant JB-RFLAGS 64) -(defconstant JB-MXCSR 72) -(defconstant JB-FPCONTROL 76) -(defconstant JB-MASK 80) -) - - - - -;;; A malloc'ed pointer to thre words of machine code. The first -;;; instruction copies the address of the trampoline callback from r14 -;;; to the count register. The second instruction (rather obviously) -;;; copies r15 to r4. A C function passes its second argument in r4, -;;; but since r4 isn't saved in a jmp_buf, we have to do this copy. -;;; The second instruction just jumps to the address in the count -;;; register, which is where we really wanted to go in the first -;;; place. - -#+ppc-target -(macrolet ((ppc-lap-word (instruction-form) - (uvref (uvref (compile nil - `(lambda (&lap 0) - (ppc-lap-function () ((?? 0)) - ,instruction-form))) - 0) #+ppc64-target 1 #+ppc32-target 0))) - (defloadvar *setjmp-catch-lr-code* - (let* ((p (malloc 12))) - (setf (%get-unsigned-long p 0) (ppc-lap-word (mtctr 14)) - (%get-unsigned-long p 4) (ppc-lap-word (mr 4 15)) - (%get-unsigned-long p 8) (ppc-lap-word (bctr))) - ;;; Force this code out of the data cache and into memory, so - ;;; that it'll get loaded into the icache. - (ff-call (%kernel-import #.target::kernel-import-makedataexecutable) - :address p - :unsigned-fullword 12 - :void) - p))) - -#+x8664-target -(defloadvar *setjmp-catch-rip-code* - (let* ((code-bytes '(#x4c #x89 #xe6 ; movq %r12, %rsi - #xff #xd3)) ; call *%rbx - (nbytes (length code-bytes)) - (p (malloc nbytes))) - (dotimes (i nbytes p) - (setf (%get-unsigned-byte p i) (pop code-bytes))))) - - -;;; Catch frames are allocated on a stack, so it's OK to pass their -;;; addresses around to foreign code. -(defcallback throw-to-catch-frame (:signed-fullword value - :address frame - :void) - (throw (%get-object frame target::catch-frame.catch-tag) value)) - -;;; Initialize a jmp_buf so that when it's #_longjmp-ed to, it'll -;;; wind up calling THROW-TO-CATCH-FRAME with the specified catch -;;; frame as its second argument. The C frame used here is just -;;; an empty C stack frame from which the callback will be called. - -#+ppc-target -(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame) - (%set-object jmp-buf JMP-sp c-frame) - (%set-object jmp-buf JMP-r15 catch-frame) - #+ppc64-target - (%set-object jmp-buf JMP-r13 (%get-os-context)) - (setf (%get-ptr jmp-buf JMP-lr) *setjmp-catch-lr-code* - (%get-ptr jmp-buf JMP-r14) throw-to-catch-frame) - t) - -#+x8664-target -(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame) - (setf (%get-ptr jmp-buf JB-rbx) throw-to-catch-frame - (%get-ptr jmp-buf JB-rip) *setjmp-catch-rip-code*) - (setf (%get-unsigned-long jmp-buf JB-mxcsr) #x1f80 - (%get-unsigned-long jmp-buf JB-fpcontrol) #x37f) - (%set-object jmp-buf JB-RSP c-frame) - (%set-object jmp-buf JB-RBP c-frame) - (%set-object jmp-buf JB-r12 catch-frame) - t) - - -) - -;;; When starting up an image that's had ObjC classes in it, all of -;;; those canonical classes (and metaclasses) will have had their type -;;; changed (by SAVE-APPLICATION) to, CCL::DEAD-MACPTR and the addresses -;;; of those classes may be bogus. The splay trees (objc-class/metaclass-map) -;;; should be empty. -;;; For each class that -had- had an assigned ID, determine its ObjC -;;; class name, and ask ObjC where (if anywhere) the class is now. -;;; If we get a non-null answer, revive the class pointer and set its -;;; address appropriately, then add an entry to the splay tree; this -;;; means that classes that existed on both sides of SAVE-APPLICATION -;;; will retain the same ID. - -(defun revive-objc-classes () - ;; We need to do some things so that we can use (@class ...) - ;; and (@selector ...) early. - (invalidate-objc-class-descriptors) - (clear-objc-selectors) - (clear-objc-protocols) - (reset-objc-class-count) - ;; Ensure that any addon frameworks are loaded. - (dolist (path *extension-framework-paths*) - (%reload-objc-framework path)) - ;; Make a first pass over the class and metaclass tables; - ;; resolving those foreign classes that existed in the old - ;; image and still exist in the new. - (let* ((class-map (objc-class-map)) - (metaclass-map (objc-metaclass-map)) - (nclasses (%objc-class-count))) - (dotimes (i nclasses) - (let* ((c (id->objc-class i)) - (meta-id (objc-class-id->objc-metaclass-id i)) - (m (id->objc-metaclass meta-id))) - (%revive-macptr c) - (%revive-macptr m) - (unless (splay-tree-get class-map c) - (%set-pointer-to-objc-class-address (objc-class-id-foreign-name i) c) - ;; If the class is valid and the metaclass is still - ;; unmapped, set the metaclass pointer's address and map it. - (unless (%null-ptr-p c) - (splay-tree-put class-map c i) - (unless (splay-tree-get metaclass-map m) - (%setf-macptr m (pref c #+apple-objc :objc_class.isa - #+gnu-objc :objc_class.class_pointer)) - (splay-tree-put metaclass-map m meta-id)) - (note-class-protocols c))))) - ;; Second pass: install class objects for user-defined classes, - ;; assuming the superclasses are already "revived". If the - ;; superclass is itself user-defined, it'll appear first in the - ;; class table; that's an artifact of the current implementation. - (dotimes (i nclasses) - (let* ((c (id->objc-class i))) - (when (and (%null-ptr-p c) - (not (slot-value c 'foreign))) - (let* ((super (dolist (s (class-direct-superclasses c) - (error "No ObjC superclass of ~s" c)) - (when (objc-class-p s) (return s)))) - (meta-id (objc-class-id->objc-metaclass-id i)) - (m (id->objc-metaclass meta-id))) - (let* ((class (make-objc-class-pair super (make-cstring (objc-class-id-foreign-name i)))) - (meta (pref class #+apple-objc :objc_class.isa - #+gnu-objc :objc-class.class_pointer))) - (unless (splay-tree-get metaclass-map m) - (%revive-macptr m) - (%setf-macptr m meta) - (splay-tree-put metaclass-map m meta-id)) - (%setf-macptr c class)) - #+apple-objc-2.0 - (%revive-foreign-slots c) - #+apple-objc-2.0 - (%add-objc-class c) - #-apple-objc-2.0 - (multiple-value-bind (ivars instance-size) - (%make-objc-ivars c) - (%add-objc-class c ivars instance-size)) - (splay-tree-put class-map c i))))) - ;; Finally, iterate over all classes in the runtime world. - ;; Register any class that's not found in the class map - ;; as a "private" ObjC class. - ;; Iterate over all classes in the runtime. Those that - ;; aren't already registered will get identified as - ;; "private" (undeclared) ObjC classes. - ;; Note that this means that if an application bundle - ;; was saved on (for instance) Panther and Tiger interfaces - ;; were used, and then the application is run on Tiger, any - ;; Tiger-specific classes will not be magically integrated - ;; into CLOS in the running application. - ;; A development envronment might want to provide such a - ;; mechanism; it would need access to Panther class - ;; declarations, and - in the general case - a standalone - ;; application doesn't necessarily have access to the - ;; interface database. - (map-objc-classes nil) - )) - -(pushnew #'revive-objc-classes *lisp-system-pointer-functions* - :test #'eq - :key #'function-name) - - -(defun %objc-class-instance-size (c) - #+apple-objc-2.0 - (#_class_getInstanceSize c) - #-apple-objc-2.0 - (pref c :objc_class.instance_size)) - -(defun find-named-objc-superclass (class string) - (unless (or (null string) (%null-ptr-p class)) - (with-macptrs ((name #+apple-objc-2.0 (#_class_getName class) - #-apple-objc-2.0 (pref class :objc_class.name))) - (or - (dotimes (i (length string) class) - (let* ((b (%get-unsigned-byte name i))) - (unless (eq b (char-code (schar string i))) - (return)))) - (find-named-objc-superclass #+apple-objc-2.0 (#_class_getSuperclass class) - #-apple-objc-2.0 (pref class :objc_class.super_class) - string))))) - -(defun install-foreign-objc-class (class &optional (use-db t)) - (let* ((id (objc-class-id class))) - (unless id - (let* ((name (%get-cstring #+apple-objc-2.0 (#_class_getName class) - #-apple-objc-2.0 (pref class :objc_class.name))) - (decl (get-objc-class-decl name use-db))) - (if (null decl) - (or (%get-private-objc-class class) - (%register-private-objc-class class name)) - (progn - (setq id (register-objc-class class) - class (id->objc-class id)) - ;; If not mapped, map the superclass (if there is one.) - (let* ((super (find-named-objc-superclass - #+apple-objc-2.0 - (#_class_getSuperclass class) - #-apple-objc-2.0 - (pref class :objc_class.super_class) - (db-objc-class-info-superclass-name decl)))) - (unless (null super) - (install-foreign-objc-class super)) - (let* ((class-name - (objc-to-lisp-classname - name - "NS")) - (meta-id - (objc-class-id->objc-metaclass-id id)) - (meta (id->objc-metaclass meta-id))) - ;; Metaclass may already be initialized. It'll have a - ;; class wrapper if so. - (unless (id->objc-metaclass-wrapper meta-id) - (let* ((meta-foreign-name - (%get-cstring - #+apple-objc-2.0 - (#_class_getName meta) - #-apple-objc-2.0 - (pref meta :objc_class.name))) - (meta-name - (intern - (concatenate 'string - "+" - (string - (objc-to-lisp-classname - meta-foreign-name - "NS"))) - "NS")) - (meta-super - (if super (pref super #+apple-objc :objc_class.isa - #+gnu-objc :objc_class.class_pointer)))) - ;; It's important (here and when initializing the - ;; class below) to use the "canonical" - ;; (registered) version of the class, since some - ;; things in CLOS assume EQness. We probably - ;; don't want to violate that assumption; it'll be - ;; easier to revive a saved image if we don't have - ;; a lot of EQL-but-not-EQ class pointers to deal - ;; with. - (initialize-instance - meta - :name meta-name - :direct-superclasses - (list - (if (or (null meta-super) - (not (%objc-metaclass-p meta-super))) - (find-class 'objc:objc-class) - (canonicalize-registered-metaclass meta-super))) - :peer class - :foreign t) - (setf (objc-metaclass-id-foreign-name meta-id) - meta-foreign-name) - (setf (find-class meta-name) meta) - (%defglobal meta-name meta))) - (setf (slot-value class 'direct-slots) - (compute-objc-direct-slots-from-info decl class)) - (initialize-instance - class - :name class-name - :direct-superclasses - (list - (if (null super) - (find-class 'objc:objc-object) - (canonicalize-registered-class super))) - :peer meta - :foreign t) - (setf (objc-class-id-foreign-name id) - name) - (setf (find-class class-name) class) - (%defglobal class-name class) - class)))))))) - - - -;;; Execute the body with the variable NSSTR bound to a -;;; stack-allocated NSConstantString instance (made from -;;; *NSConstantString-class*, CSTRING and LEN). -(defmacro with-nsstr ((nsstr cstring len) &body body) - #+apple-objc - `(rlet ((,nsstr :onstanttring - :isa *NSConstantString-class* - :bytes ,cstring - :numytes ,len)) - ,@body) - #+gnu-objc - `(rlet ((,nsstr :onstanttring - :isa *NSConstantString-class* - :c_string ,cstring - :len ,len)) - ,@body)) - -;;; Make a persistent (heap-allocated) NSConstantString. - -(defun %make-constant-nsstring (string) - "Make a persistent (heap-allocated) NSConstantString from the -argument lisp string." - #+apple-objc - (make-record :onstanttring - :isa *NSConstantString-Class* - :bytes (make-cstring string) - :numytes (length string)) - #+gnu-objc - (make-record :onstanttring - :isa *NSConstantString-Class* - :c_string (make-cstring string) - :len (length string)) - ) - -;;; Class declarations -(defparameter *objc-class-declarations* (make-hash-table :test #'equal)) - -(defun register-objc-class-decls () - (do-interface-dirs (d) - (dolist (class-name (cdb-enumerate-keys (db-objc-classes d))) - (get-objc-class-decl class-name t)))) - - -(defun get-objc-class-decl (class-name &optional (use-db nil)) - (or (gethash class-name *objc-class-declarations*) - (and use-db - (let* ((decl (%find-objc-class-info class-name))) - (when decl - (setf (gethash class-name *objc-class-declarations*) decl)))))) - -(defun %ensure-class-declaration (name super-name) - (unless (get-objc-class-decl name) - (setf (gethash name *objc-class-declarations*) - (make-db-objc-class-info :class-name (string name) - :superclass-name (string super-name)))) - name) - -;;; It's hard (and questionable) to allow ivars here. -(defmacro declare-objc-class (name super-name) - `(%ensure-class-declaration ',name ',super-name)) - -;;; Intern NSConstantString instances. -(defvar *objc-constant-strings* (make-hash-table :test #'equal)) - -(defstruct objc-constant-string - string - nsstringptr) - -(defun ns-constant-string (string) - (or (gethash string *objc-constant-strings*) - (setf (gethash string *objc-constant-strings*) - (make-objc-constant-string :string string - :nsstringptr (%make-constant-nsstring string))))) - -(def-ccl-pointers objc-strings () - (maphash #'(lambda (string cached) - (setf (objc-constant-string-nsstringptr cached) - (%make-constant-nsstring string))) - *objc-constant-strings*)) - -(defmethod make-load-form ((s objc-constant-string) &optional env) - (declare (ignore env)) - `(ns-constant-string ,(objc-constant-string-string s))) - -(defmacro @ (string) - `(objc-constant-string-nsstringptr ,(ns-constant-string string))) - -#+gnu-objc -(progn - (defcallback lisp-objc-error-handler (:id receiver :int errcode (:* :char) format :address argptr :) - (let* ((message (get-c-format-string format argptr))) - (error "ObjC runtime error ~d, receiver ~s :~& ~a" - errcode receiver message)) - #$YES) - - (def-ccl-pointers install-lisp-objc-error-handler () - (#_objc_set_error_handler lisp-objc-error-handler))) - - - - - - -;;; Registering named objc classes. - - -(defun objc-class-name-string (name) - (etypecase name - (symbol (lisp-to-objc-classname name)) - (string name))) - -;;; We'd presumably cache this result somewhere, so we'd only do the -;;; lookup once per session (in general.) -(defun lookup-objc-class (name &optional error-p) - (with-cstrs ((cstr (objc-class-name-string name))) - (let* ((p (#+apple-objc #_objc_lookUpClass - #+gnu-objc #_objc_lookup_class - cstr))) - (if (%null-ptr-p p) - (if error-p - (error "ObjC class ~a not found" name)) - p)))) - -(defun %set-pointer-to-objc-class-address (class-name-string ptr) - (with-cstrs ((cstr class-name-string)) - (%setf-macptr ptr - (#+apple-objc #_objc_lookUpClass - #+gnu-objc #_objc_lookup_class - cstr))) - nil) - - - -(defvar *objc-class-descriptors* (make-hash-table :test #'equal)) - - -(defstruct objc-class-descriptor - name - classptr) - -(defun invalidate-objc-class-descriptors () - (maphash #'(lambda (name descriptor) - (declare (ignore name)) - (setf (objc-class-descriptor-classptr descriptor) nil)) - *objc-class-descriptors*)) - -(defun %objc-class-classptr (class-descriptor &optional (error-p t)) - (or (objc-class-descriptor-classptr class-descriptor) - (setf (objc-class-descriptor-classptr class-descriptor) - (lookup-objc-class (objc-class-descriptor-name class-descriptor) - error-p)))) - -(defun load-objc-class-descriptor (name) - (let* ((descriptor (or (gethash name *objc-class-descriptors*) - (setf (gethash name *objc-class-descriptors*) - (make-objc-class-descriptor :name name))))) - (%objc-class-classptr descriptor nil) - descriptor)) - -(defmacro objc-class-descriptor (name) - `(load-objc-class-descriptor ,name)) - -(defmethod make-load-form ((o objc-class-descriptor) &optional env) - (declare (ignore env)) - `(load-objc-class-descriptor ,(objc-class-descriptor-name o))) - -(defmacro @class (name) - (let* ((name (objc-class-name-string name))) - `(the (@metaclass ,name) (%objc-class-classptr ,(objc-class-descriptor name))))) - -;;; This isn't quite the inverse operation of LOOKUP-OBJC-CLASS: it -;;; returns a simple C string. and can be applied to a class or any -;;; instance (returning the class name.) -(defun objc-class-name (object) - #+apple-objc - (with-macptrs (p) - (%setf-macptr p (#_object_getClassName object)) - (unless (%null-ptr-p p) - (%get-cstring p))) - #+gnu-objc - (unless (%null-ptr-p object) - (with-macptrs ((parent (pref object :objc_object.class_pointer))) - (unless (%null-ptr-p parent) - (if (logtest (pref parent :objc_class.info) #$_CLS_CLASS) - (%get-cstring (pref parent :objc_class.name)) - (%get-cstring (pref object :objc_class.name))))))) - - -;;; Likewise, we want to cache the selectors ("SEL"s) which identify -;;; method names. They can vary from session to session, but within -;;; a session, all methods with a given name (e.g, "init") will be -;;; represented by the same SEL. -(defun get-selector-for (method-name &optional error) - (with-cstrs ((cmethod-name method-name)) - (let* ((p (#+apple-objc #_sel_getUid - #+gnu-objc #_sel_get_uid - cmethod-name))) - (if (%null-ptr-p p) - (if error - (error "Can't find ObjC selector for ~a" method-name)) - p)))) - -(defvar *objc-selectors* (make-hash-table :test #'equal)) - -(defstruct objc-selector - name - %sel) - -(defun %get-SELECTOR (selector &optional (error-p t)) - (or (objc-selector-%sel selector) - (setf (objc-selector-%sel selector) - (get-selector-for (objc-selector-name selector) error-p)))) - -(defun clear-objc-selectors () - (maphash #'(lambda (name sel) - (declare (ignore name)) - (setf (objc-selector-%sel sel) nil)) - *objc-selectors*)) - -;;; Find or create a SELECTOR; don't bother resolving it. -(defun ensure-objc-selector (name) - (setq name (string name)) - (or (gethash name *objc-selectors*) - (setf (gethash name *objc-selectors*) - (make-objc-selector :name name)))) - -(defun load-objc-selector (name) - (let* ((selector (ensure-objc-selector name))) - (%get-SELECTOR selector nil) - selector)) - -(defmacro @SELECTOR (name) - `(%get-selector ,(load-objc-selector name))) - -(defmethod make-load-form ((s objc-selector) &optional env) - (declare (ignore env)) - `(load-objc-selector ,(objc-selector-name s))) - - -;;; Convert a Lisp object X to a desired foreign type FTYPE -;;; The following conversions are currently done: -;;; - T/NIL => #$YES/#$NO -;;; - NIL => (%null-ptr) -;;; - Lisp string => NSString -;;; - Lisp numbers => SINGLE-FLOAT when possible - -(defun coerce-to-bool (x) - (let ((x-temp (gensym))) - `(let ((,x-temp ,x)) - (if (or (eq ,x-temp 0) (null ,x-temp)) - #.#$NO - #.#$YES)))) - -(declaim (inline %coerce-to-bool)) -(defun %coerce-to-bool (x) - (if (and x (not (eql x 0))) - #$YES - #$NO)) - -(defun coerce-to-address (x) - (let ((x-temp (gensym))) - `(let ((,x-temp ,x)) - (cond ((null ,x-temp) +null-ptr+) - ((stringp ,x-temp) (%make-nsstring ,x-temp)) - (t ,x-temp))))) - -;;; This is generally a bad idea; it forces us to -;;; box intermediate pointer arguments in order -;;; to typecase on them, and it's not clear to -;;; me that it offers much in the way of additional -;;; expressiveness. -(declaim (inline %coerce-to-address)) -(defun %coerce-to-address (x) - (etypecase x - (macptr x) - (string (%make-nsstring x)) ; does this ever get released ? - (null (%null-ptr)))) - -(defun coerce-to-foreign-type (x ftype) - (cond ((and (constantp x) (constantp ftype)) - (case ftype - (:id (if (null x) `(%null-ptr) (coerce-to-address x))) - (: (coerce-to-bool (eval x))) - (t x))) - ((constantp ftype) - (case ftype - (:id `(%coerce-to-address ,x)) - (: `(%coerce-to-bool ,x)) - (t x))) - (t `(case ,(if (atom ftype) ftype) - (:id (%coerce-to-address ,x)) - (: (%coerce-to-bool ,x)) - (t ,x))))) - -(defun objc-arg-coerce (typespec arg) - (case typespec - (: `(%coerce-to-bool ,arg)) - (:id `(%coerce-to-address ,arg)) - (t arg))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Boolean Return Hackery ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Convert a foreign object X to T or NIL - -(defun coerce-from-bool (x) - (cond - ((eq x #$NO) nil) - ((eq x #$YES) t) - (t (error "Cannot coerce ~S to T or NIL" x)))) - -(defun objc-result-coerce (type result) - (cond ((eq type :) - `(coerce-from-bool ,result)) - (t result))) - -;;; Add a faster way to get the message from a SEL by taking advantage of the -;;; fact that a selector is really just a canonicalized, interned C string -;;; containing the message. (This is an admitted modularity violation; -;;; there's a more portable but slower way to do this if we ever need to.) - - -(defun lisp-string-from-sel (sel) - (%get-cstring - #+apple-objc sel - #+gnu-objc (#_sel_get_name sel))) - -;;; #_objc_msgSend takes two required arguments (the receiving object -;;; and the method selector) and 0 or more additional arguments; -;;; there'd have to be some macrology to handle common cases, since we -;;; want the compiler to see all of the args in a foreign call. - -;;; I don't remmber what the second half of the above comment might -;;; have been talking about. - -(defmacro objc-message-send (receiver selector-name &rest argspecs) - (when (evenp (length argspecs)) - (setq argspecs (append argspecs '(:id)))) - #+apple-objc - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend")))) - `(:address ,receiver : (@selector ,selector-name) ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce) - #+gnu-objc - (let* ((r (gensym)) - (s (gensym)) - (imp (gensym))) - `(with-macptrs ((,r ,receiver) - (,s (@selector ,selector-name)) - (,imp (external-call "objc_msg_lookup" - :id ,r - : ,s - :))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - `(:address ,receiver : (@selector ,selector-name) ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)))) - -(defmacro objc-message-send-with-selector (receiver selector &rest argspecs) - (when (evenp (length argspecs)) - (setq argspecs (append argspecs '(:id)))) - #+apple-objc - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend")))) - `(:address ,receiver : (%get-selector ,selector) ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce) - #+gnu-objc - (let* ((r (gensym)) - (s (gensym)) - (imp (gensym))) - `(with-macptrs ((,r ,receiver) - (,s (%get-selector ,selector)) - (,imp (external-call "objc_msg_lookup" - :id ,r - : ,s - :))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - `(:address ,receiver : ,s ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)))) - -;;; A method that returns a structure does so by platform-dependent -;;; means. One of those means (which is fairly common) is to pass a -;;; pointer to an instance of a structure type as a first argument to -;;; the method implementation function (thereby making SELF the second -;;; argument, etc.), but whether or not it's actually done that way -;;; depends on the platform and on the structure type. The special -;;; variable CCL::*TARGET-FTD* holds a structure (of type -;;; CCL::FOREIGN-TYPE-DATA) which describes some static attributes of -;;; the foreign type system on the target platform and contains some -;;; functions which can determine dynamic ABI attributes. One such -;;; function can be used to determine whether or not the "invisible -;;; first arg" convention is used to return structures of a given -;;; foreign type; another function in *TARGET-FTD* can be used to -;;; construct a foreign function call form that handles -;;; structure-return and structure-types-as-arguments details. In the -;;; Apple ObjC runtime, #_objc_msgSend_stret must be used if the -;;; invisible-first-argument convention is used to return a structure -;;; and must NOT be used otherwise. (The Darwin ppc64 and all -;;; supported x86-64 ABIs often use more complicated structure return -;;; conventions than ppc32 Darwin or ppc Linux.) We should use -;;; OBJC-MESSAGE-SEND-STRET to send any message that returns a -;;; structure or union, regardless of how that structure return is -;;; actually implemented. - -(defmacro objc-message-send-stret (structptr receiver selector-name &rest argspecs) - #+apple-objc - (let* ((return-typespec (car (last argspecs))) - (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) - "_objc_msgSend_stret" - "_objc_msgSend"))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) - `(,structptr :address ,receiver : (@selector ,selector-name) ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)) - #+gnu-objc - (let* ((r (gensym)) - (s (gensym)) - (imp (gensym))) - `(with-macptrs ((,r ,receiver) - (,s (@selector ,selector-name)) - (,imp (external-call "objc_msg_lookup" - :id ,r - : ,s - :))) - , (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - `(,structptr :address ,receiver : ,s ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)))) - -(defmacro objc-message-send-stret-with-selector (structptr receiver selector &rest argspecs) - #+apple-objc - (let* ((return-typespec (car (last argspecs))) - (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) - "_objc_msgSend_stret" - "_objc_msgSend"))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) - `(,structptr :address ,receiver : (%get-selector ,selector) ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)) - #+gnu-objc - (let* ((r (gensym)) - (s (gensym)) - (imp (gensym))) - `(with-macptrs ((,r ,receiver) - (,s (%get-selector ,selector)) - (,imp (external-call "objc_msg_lookup" - :id ,r - : ,s - :))) - , (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - `(,structptr :address ,receiver : ,s ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)))) - -;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument -;;; is a pointer to a structure of type objc_super {self, the defining -;;; class's superclass}. It only makes sense to use this inside an -;;; objc method. -(defmacro objc-message-send-super (super selector-name &rest argspecs) - (when (evenp (length argspecs)) - (setq argspecs (append argspecs '(:id)))) - #+apple-objc - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper")))) - `(:address ,super : (@selector ,selector-name) ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce) - #+gnu-objc - (let* ((sup (gensym)) - (sel (gensym)) - (imp (gensym))) - `(with-macptrs ((,sup ,super) - (,sel (@selector ,selector-name)) - (,imp (external-call "objc_msg_lookup_super" - :uper_t ,sup - : ,sel - :))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - `(:id (pref ,sup :uper.self) - : ,sel - ,@argspecs))))) - -(defmacro objc-message-send-super-with-selector (super selector &rest argspecs) - (when (evenp (length argspecs)) - (setq argspecs (append argspecs '(:id)))) - #+apple-objc - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper")))) - `(:address ,super : ,selector ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce) - #+gnu-objc - (let* ((sup (gensym)) - (sel (gensym)) - (imp (gensym))) - `(with-macptrs ((,sup ,super) - (,sel ,selector) - (,imp (external-call "objc_msg_lookup_super" - :uper_t ,sup - : ,sel - :))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - `(:id (pref ,sup :uper.self) - : ,sel - ,@argspecs))))) - -;;; Send to superclass method, returning a structure. See above. -(defmacro objc-message-send-super-stret - (structptr super selector-name &rest argspecs) - #+apple-objc - (let* ((return-typespec (car (last argspecs))) - (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) - "_objc_msgSendSuper_stret" - "_objc_msgSendSuper"))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) - `(,structptr :address ,super : (@selector ,selector-name) ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)) - #+gnu-objc - (let* ((sup (gensym)) - (sel (gensym)) - (imp (gensym))) - `(with-macptrs ((,sup ,super) - (,sel (@selector ,selector-name)) - (,imp (external-call "objc_msg_lookup_super" - :uper_t ,sup - : ,sel - :))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - ,structptr - :id (pref ,sup :uper.self) - : ,sel - ,@argspecs)))) - -(defmacro objc-message-send-super-stret-with-selector - (structptr super selector &rest argspecs) - #+apple-objc - (let* ((return-typespec (car (last argspecs))) - (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) - "_objc_msgSendSuper_stret" - "_objc_msgSendSuper"))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) - `(,structptr :address ,super : ,selector ,@argspecs) - :arg-coerce 'objc-arg-coerce - :result-coerce 'objc-result-coerce)) - #+gnu-objc - (let* ((sup (gensym)) - (sel (gensym)) - (imp (gensym))) - `(with-macptrs ((,sup ,super) - (,sel ,selector) - (,imp (external-call "objc_msg_lookup_super" - :uper_t ,sup - : ,sel - :))) - (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call ,imp) - ,structptr - :id (pref ,sup :uper.self) - : ,sel - ,@argspecs)))) - -(defun message-send-form-for-call (receiver selector args super-p struct-return-var) - (if struct-return-var - (if super-p - `(objc-message-send-super-stret-with-selector ,struct-return-var ,receiver ,selector ,@args) - `(objc-message-send-stret-with-selector ,struct-return-var ,receiver ,selector ,@args)) - (if super-p - `(objc-message-send-super-with-selector ,receiver ,selector ,@args) - `(objc-message-send-with-selector ,receiver ,selector ,@args)))) - - -#+(and apple-objc x8664-target) -(defun %process-varargs-list (gpr-pointer fpr-pointer stack-pointer ngprs nfprs nstackargs arglist) - (dolist (arg-temp arglist) - (typecase arg-temp - ((signed-byte 64) - (if (< ngprs 6) - (progn - (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp) - (incf ngprs)) - (progn - (setf (paref stack-pointer (:* (:signed 64)) nstackargs) arg-temp) - (incf nstackargs)))) - ((unsigned-byte 64) - (if (< ngprs 6) - (progn - (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp) - (incf ngprs)) - (progn - (setf (paref stack-pointer (:* (:unsigned 64)) nstackargs) arg-temp) - (incf nstackargs)))) - (macptr - (if (< ngprs 6) - (progn - (setf (paref gpr-pointer (:* :address) ngprs) arg-temp) - (incf ngprs)) - (progn - (setf (paref stack-pointer (:* :address) nstackargs) arg-temp) - (incf nstackargs)))) - (single-float - (if (< nfprs 8) - (progn - (setf (%get-single-float fpr-pointer (* nfprs 16)) - arg-temp) - (incf nfprs)) - (progn - (setf (paref stack-pointer (:* :float) (* 2 nstackargs)) arg-temp) - (incf nstackargs)))) - (double-float - (if (< nfprs 8) - (progn - (setf (%get-double-float fpr-pointer (* nfprs 16)) - arg-temp) - (incf nfprs)) - (progn - (setf (paref stack-pointer (:* :double) nstackargs) - arg-temp) - (incf nstackargs))))))) - -#+(and apple-objc ppc32-target) -(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist) - (dolist (arg-temp arglist) - (typecase arg-temp - ((signed-byte 32) - (setf (paref gpr-pointer (:* (:signed 32)) ngprs) arg-temp) - (incf ngprs)) - ((unsigned-byte 32) - (setf (paref gpr-pointer (:* (:unsigned 32)) ngprs) arg-temp) - (incf ngprs)) - (macptr - (setf (paref gpr-pointer (:* :address) ngprs) arg-temp) - (incf ngprs)) - (single-float - (when (< nfprs 13) - (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0)) - (incf nfprs)) - (setf (paref gpr-pointer (:* :single-float) ngprs) arg-temp) - (incf ngprs)) - (double-float - (when (< nfprs 13) - (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp) - (incf nfprs)) - (multiple-value-bind (high low) (double-float-bits arg-temp) - (setf (paref gpr-pointer (:* :unsigned) ngprs) high) - (incf ngprs) - (setf (paref gpr-pointer (:* :unsigned) ngprs) low) - (incf nfprs))) - ((or (signed-byte 64) - (unsigned-byte 64)) - (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 32) arg-temp)) - (incf ngprs) - (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 0) arg-temp)) - (incf ngprs))))) - -#+(and apple-objc ppc64-target) -(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist) - (dolist (arg-temp arglist) - (typecase arg-temp - ((signed-byte 64) - (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp) - (incf ngprs)) - ((unsigned-byte 64) - (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp) - (incf ngprs)) - (macptr - (setf (paref gpr-pointer (:* :address) ngprs) arg-temp) - (incf ngprs)) - (single-float - (when (< nfprs 13) - (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0)) - (incf nfprs)) - (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) (single-float-bits arg-temp)) - (incf ngprs)) - (double-float - (when (< nfprs 13) - (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp) - (incf nfprs)) - (setf (paref gpr-pointer (:* :double-float) ngprs) arg-temp) - (incf ngprs))))) - - -#+apple-objc -(eval-when (:compile-toplevel :execute) - #+(and ppc-target (not apple-objc-2.0)) - (def-foreign-type : - (:struct nil - (:fp

arams (:array :double 13)) - (:linkage (:array :uintptr_t 6)) - (:reg

arams (:array :uintptr_t 8)) - (:stack

arams (:array :uintptr_t) 0))) - ) - - -#+(and apple-objc-2.0 x8664-target) -(defun %compile-varargs-send-function-for-signature (sig) - (let* ((return-type-spec (foreign-type-to-representation-type (car sig))) - (op (case return-type-spec - (:address '%get-ptr) - (:unsigned-byte '%get-unsigned-byte) - (:signed-byte '%get-signed-byte) - (:unsigned-halfword '%get-unsigned-word) - (:signed-halfword '%get-signed-word) - (:unsigned-fullword '%get-unsigned-long) - (:signed-fullword '%get-signed-long) - (:unsigned-doubleword '%get-natural) - (:signed-doubleword '%get-signed-natural) - (:single-float '%get-single-float) - (:double-float '%get-double-float))) - (result-offset - (case op - ((:single-float :double-float) 0) - (t -8))) - (arg-type-specs (butlast (cdr sig))) - (args (objc-gen-message-arglist (length arg-type-specs))) - (receiver (gensym)) - (selector (gensym)) - (rest-arg (gensym)) - (arg-temp (gensym)) - (regparams (gensym)) - (stackparams (gensym)) - (fpparams (gensym)) - (cframe (gensym)) - (selptr (gensym)) - (gpr-total (gensym)) - (fpr-total (gensym)) - (stack-total (gensym)) - (n-static-gprs 2) ;receiver, selptr - (n-static-fprs 0) - (n-static-stack-args 0)) - (collect ((static-arg-forms)) - (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver)) - (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr)) - (do* ((args args (cdr args)) - (arg-type-specs arg-type-specs (cdr arg-type-specs))) - ((null args)) - (let* ((arg (car args)) - (spec (car arg-type-specs)) - (static-arg-type (parse-foreign-type spec)) - (gpr-base (if (< n-static-gprs 6) regparams stackparams)) - (fpr-base (if (< n-static-fprs 8) fpparams stackparams)) - (gpr-offset (if (< n-static-gprs 6) n-static-gprs n-static-stack-args)) - (fpr-offset (if (< n-static-fprs 8) - (* 8 n-static-fprs) - (* 8 n-static-stack-args)))) - (etypecase static-arg-type - (foreign-integer-type - (if (eq spec :) - (setq arg `(%coerce-to-bool ,arg))) - (static-arg-forms - `(setf (paref ,gpr-base (:* ( - ,(if (foreign-integer-type-signed static-arg-type) - :signed - :unsigned) - ,(foreign-integer-type-bits static-arg-type))) ,gpr-offset) - ,arg)) - (if (< n-static-gprs 6) - (incf n-static-gprs) - (incf n-static-stack-args))) - (foreign-single-float-type - (static-arg-forms - `(setf (%get-single-float ,fpr-base ,fpr-offset) ,arg)) - (if (< n-static-fprs 8) - (incf n-static-fprs) - (incf n-static-stack-args))) - (foreign-double-float-type - (static-arg-forms - `(setf (%get-double-float ,fpr-base ,fpr-offset) ,arg)) - (if (< n-static-fprs 8) - (incf n-static-fprs) - (incf n-static-stack-args))) - (foreign-pointer-type - (static-arg-forms - `(setf (paref ,gpr-base (:* address) ,gpr-offset) ,arg)) - (if (< n-static-gprs 6) - (incf n-static-gprs) - (incf n-static-stack-args)))))) - (compile - nil - `(lambda (,receiver ,selector ,@args &rest ,rest-arg) - (declare (dynamic-extent ,rest-arg)) - (let* ((,selptr (%get-selector ,selector)) - (,gpr-total ,n-static-gprs) - (,fpr-total ,n-static-fprs) - (,stack-total ,n-static-stack-args)) - (dolist (,arg-temp ,rest-arg) - (if (or (typep ,arg-temp 'double-float) - (typep ,arg-temp 'single-float)) - (if (< ,fpr-total 8) - (incf ,fpr-total) - (incf ,stack-total)) - (if (< ,gpr-total 6) - (incf ,gpr-total) - (incf ,stack-total)))) - (%stack-block ((,fpparams (* 8 8))) - (with-macptrs (,regparams ,stackparams) - (with-variable-c-frame - (+ 8 ,stack-total) ,cframe - (%setf-macptr-to-object ,regparams (+ ,cframe 2)) - (%setf-macptr-to-object ,stackparams (+ ,cframe 8)) - (progn ,@(static-arg-forms)) - (%process-varargs-list ,regparams ,fpparams ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg) - (%do-ff-call ,fpr-total ,cframe ,fpparams (%reference-external-entry-point (load-time-value (external "_objc_msgSend")))) - ,@(if op - `((,op ,regparams ,result-offset)) - `(()))))))))))) - - -#+(and apple-objc ppc32-target) -(defun %compile-varargs-send-function-for-signature (sig) - (let* ((return-type-spec (car sig)) - (arg-type-specs (butlast (cdr sig))) - (args (objc-gen-message-arglist (length arg-type-specs))) - (receiver (gensym)) - (selector (gensym)) - (rest-arg (gensym)) - (arg-temp (gensym)) - (marg-ptr (gensym)) - (regparams (gensym)) - (selptr (gensym)) - (gpr-total (gensym)) - (n-static-gprs 2) ;receiver, selptr - (n-static-fprs 0)) - (collect ((static-arg-forms)) - (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver)) - (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr)) - (do* ((args args (cdr args)) - (arg-type-specs arg-type-specs (cdr arg-type-specs))) - ((null args)) - (let* ((arg (car args)) - (spec (car arg-type-specs)) - (static-arg-type (parse-foreign-type spec)) - (gpr-base regparams) - (fpr-base marg-ptr) - (gpr-offset (* n-static-gprs 4))) - (etypecase static-arg-type - (foreign-integer-type - (let* ((bits (foreign-type-bits static-arg-type)) - (signed (foreign-integer-type-signed static-arg-type))) - (if (> bits 32) - (progn - (static-arg-forms - `(setf (,(if signed '%%get-signed-longlong '%%get-unsigned-long-long) - ,gpr-base ,gpr-offset) - ,arg)) - (incf n-static-gprs 2)) - (progn - (if (eq spec :) - (setq arg `(%coerce-to-bool ,arg))) - (static-arg-forms - `(setf (paref ,gpr-base (:* ( - ,(if (foreign-integer-type-signed static-arg-type) - :signed - :unsigned) - 32)) ,gpr-offset) - ,arg)) - (incf n-static-gprs))))) - (foreign-single-float-type - (static-arg-forms - `(setf (paref ,gpr-base (:* :single-float) ,n-static-gprs) ,arg)) - (when (< n-static-fprs 13) - (static-arg-forms - `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) - (float (paref ,gpr-base (:* :single-float) ,n-static-gprs) 0.0d0))) - (incf n-static-fprs)) - (incf n-static-gprs)) - (foreign-double-float-type - (static-arg-forms - `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg)) - (when (< n-static-fprs 13) - (static-arg-forms - `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) - (%get-double-float ,gpr-base ,gpr-offset))) - (incf n-static-fprs)) - (incf n-static-gprs 2)) - (foreign-pointer-type - (static-arg-forms - `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg)) - (incf n-static-gprs))))) - (compile - nil - `(lambda (,receiver ,selector ,@args &rest ,rest-arg) - (declare (dynamic-extent ,rest-arg)) - (let* ((,selptr (%get-selector ,selector)) - (,gpr-total ,n-static-gprs)) - (dolist (,arg-temp ,rest-arg) - (if (or (typep ,arg-temp 'double-float) - (and (typep ,arg-temp 'integer) - (if (< ,arg-temp 0) - (>= (integer-length ,arg-temp) 32) - (> (integer-length ,arg-temp) 32)))) - (incf ,gpr-total 2) - (incf ,gpr-total 1))) - (if (> ,gpr-total 8) - (setq ,gpr-total (- ,gpr-total 8)) - (setq ,gpr-total 0)) - (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size - : :bytes) - (* 4 ,gpr-total)))) - - (with-macptrs ((,regparams (pref ,marg-ptr :.reg

arams))) - (progn ,@(static-arg-forms)) - (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs ,rest-arg) - (external-call "_objc_msgSendv" - :address ,receiver - :address ,selptr - :size_t (+ 32 (* 4 ,gpr-total)) - :address ,marg-ptr - ,return-type-spec))))))))) - -#+(and apple-objc ppc64-target) -(defun %compile-varargs-send-function-for-signature (sig) - (let* ((return-type-spec (car sig)) - (arg-type-specs (butlast (cdr sig))) - (args (objc-gen-message-arglist (length arg-type-specs))) - (receiver (gensym)) - (selector (gensym)) - (rest-arg (gensym)) - (arg-temp (gensym)) - (marg-ptr (gensym)) - (regparams (gensym)) - (selptr (gensym)) - (gpr-total (gensym)) - (n-static-gprs 2) ;receiver, selptr - (n-static-fprs 0)) - (collect ((static-arg-forms)) - (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver)) - (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr)) - (do* ((args args (cdr args)) - (arg-type-specs arg-type-specs (cdr arg-type-specs))) - ((null args)) - (let* ((arg (car args)) - (spec (car arg-type-specs)) - (static-arg-type (parse-foreign-type spec)) - (gpr-base regparams) - (fpr-base marg-ptr) - (gpr-offset (* n-static-gprs 8))) - (etypecase static-arg-type - (foreign-integer-type - (if (eq spec :) - (setq arg `(%coerce-to-bool ,arg))) - (static-arg-forms - `(setf (paref ,gpr-base (:* ( - ,(if (foreign-integer-type-signed static-arg-type) - :signed - :unsigned) - 64)) ,gpr-offset) - ,arg)) - (incf n-static-gprs)) - (foreign-single-float-type - (static-arg-forms - `(setf (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) ,arg)) - (when (< n-static-fprs 13) - (static-arg-forms - `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) - (float (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) 0.0d0))) - (incf n-static-fprs)) - (incf n-static-gprs)) - (foreign-double-float-type - (static-arg-forms - `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg)) - (when (< n-static-fprs 13) - (static-arg-forms - `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) - (%get-double-float ,gpr-base ,gpr-offset))) - (incf n-static-fprs)) - (incf n-static-gprs 1)) - (foreign-pointer-type - (static-arg-forms - `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg)) - (incf n-static-gprs))))) - - (progn - nil - `(lambda (,receiver ,selector ,@args &rest ,rest-arg) - (declare (dynamic-extent ,rest-arg)) - (let* ((,selptr (%get-selector ,selector)) - (,gpr-total ,n-static-gprs)) - (dolist (,arg-temp ,rest-arg) - (declare (ignore ,arg-temp)) - (incf ,gpr-total 1)) - (if (> ,gpr-total 8) - (setq ,gpr-total (- ,gpr-total 8)) - (setq ,gpr-total 0)) - (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size - : :bytes) - (* 8 ,gpr-total)))) - - (with-macptrs ((,regparams (pref ,marg-ptr :.reg

arams))) - (progn ,@(static-arg-forms)) - (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs ,rest-arg) - (external-call "_objc_msgSendv" - :address ,receiver - :address ,selptr - :size_t (+ 64 (* 8 ,gpr-total)) - :address ,marg-ptr - ,return-type-spec))))))))) - -#-(and apple-objc (or x8664-target ppc-target)) -(defun %compile-varargs-send-function-for-signature (sig) - (warn "Varargs function for signature ~s NYI" sig)) - - - -(defun %compile-send-function-for-signature (sig &optional super-p) - (let* ((return-type-spec (car sig)) - (arg-type-specs (cdr sig))) - (if (eq (car (last arg-type-specs)) :void) - (%compile-varargs-send-function-for-signature sig) - (let* ((args (objc-gen-message-arglist (length arg-type-specs))) - (struct-return-var nil) - (receiver (gensym)) - (selector (gensym))) - (collect ((call) - (lets)) - (let* ((result-type (parse-foreign-type return-type-spec))) - (when (typep result-type 'foreign-record-type) - (setq struct-return-var (gensym)) - (lets `(,struct-return-var (make-gcable-record ,return-type-spec)))) - - (do ((args args (cdr args)) - (spec (pop arg-type-specs) (pop arg-type-specs))) - ((null args) (call return-type-spec)) - (let* ((arg (car args))) - (call spec) - (case spec - (: (call `(%coerce-to-bool ,arg))) - (:id (call `(%coerce-to-address ,arg))) - (t - (call arg))))) - (let* ((call (call)) - (lets (lets)) - (body (message-send-form-for-call receiver selector call super-p struct-return-var))) - (if struct-return-var - (setq body `(progn ,body ,struct-return-var))) - (if lets - (setq body `(let* ,lets - ,body))) - (compile nil - `(lambda (,receiver ,selector ,@args) - ,body))))))))) - -(defun compile-send-function-for-signature (sig) - (%compile-send-function-for-signature sig nil)) - - - - -;;; The first 8 words of non-fp arguments get passed in R3-R10 -#+ppc-target -(defvar *objc-gpr-offsets* - #+32-bit-target - #(4 8 12 16 20 24 28 32) - #+64-bit-target - #(8 16 24 32 40 48 56 64) - ) - - - -;;; The first 13 fp arguments get passed in F1-F13 (and also "consume" -;;; a GPR or two.) It's certainly possible for an FP arg and a non- -;;; FP arg to share the same "offset", and parameter offsets aren't -;;; strictly increasing. -#+ppc-target -(defvar *objc-fpr-offsets* - #+32-bit-target - #(36 44 52 60 68 76 84 92 100 108 116 124 132) - #+64-bit-target - #(68 76 84 92 100 108 116 124 132 140 148 156 164)) - -;;; Just to make things even more confusing: once we've filled in the -;;; first 8 words of the parameter area, args that aren't passed in -;;; FP-regs get assigned offsets starting at 32. That almost makes -;;; sense (even though it conflicts with the last offset in -;;; *objc-gpr-offsets* (assigned to R10), but we then have to add -;;; this constant to the memory offset. -(defconstant objc-forwarding-stack-offset 8) - -(defvar *objc-id-type* (parse-foreign-type :id)) -(defvar *objc-sel-type* (parse-foreign-type :)) -(defvar *objc-char-type* (parse-foreign-type :char)) - -(defun encode-objc-type (type &optional for-ivar) - (if (or (eq type *objc-id-type*) - (foreign-type-= type *objc-id-type*)) - "@" - (if (or (eq type *objc-sel-type*) - (foreign-type-= type *objc-sel-type*)) - ":" - (if (eq (foreign-type-class type) 'root) - "v" - (typecase type - (foreign-pointer-type - (let* ((target (foreign-pointer-type-to type))) - (if (or (eq target *objc-char-type*) - (foreign-type-= target *objc-char-type*)) - "*" - (format nil "^~a" (encode-objc-type target))))) - (foreign-double-float-type "d") - (foreign-single-float-type "f") - (foreign-integer-type - (let* ((signed (foreign-integer-type-signed type)) - (bits (foreign-integer-type-bits type))) - (if (eq (foreign-integer-type-alignment type) 1) - (format nil "b~d" bits) - (cond ((= bits 8) - (if signed "c" "C")) - ((= bits 16) - (if signed "s" "S")) - ((= bits 32) - ;; Should be some way of noting "longness". - (if signed "i" "I")) - ((= bits 64) - (if signed "q" "Q")))))) - (foreign-record-type - (ensure-foreign-type-bits type) - (let* ((name (unescape-foreign-name - (or (foreign-record-type-name type) "?"))) - (kind (foreign-record-type-kind type)) - (fields (foreign-record-type-fields type))) - (with-output-to-string (s) - (format s "~c~a=" (if (eq kind :struct) #\{ #\() name) - (dolist (f fields (format s "~a" (if (eq kind :struct) #\} #\)))) - (when for-ivar - (format s "\"~a\"" - (unescape-foreign-name - (or (foreign-record-field-name f) ""))) - (format s "~a" (encode-objc-type - (foreign-record-field-type f)))))))) - (foreign-array-type - (ensure-foreign-type-bits type) - (let* ((dims (foreign-array-type-dimensions type)) - (element-type (foreign-array-type-element-type type))) - (if dims (format nil "[~d~a]" - (car dims) - (encode-objc-type element-type)) - (if (or (eq element-type *objc-char-type*) - (foreign-type-= element-type *objc-char-type*)) - "*" - (format nil "^~a" (encode-objc-type element-type)))))) - (t (break "type = ~s" type))))))) - -#+ppc-target -(defun encode-objc-method-arglist (arglist result-spec) - (let* ((gprs-used 0) - (fprs-used 0) - (arg-info - (flet ((current-memory-arg-offset () - (+ 32 (* 4 (- gprs-used 8)) - objc-forwarding-stack-offset))) - (flet ((current-gpr-arg-offset () - (if (< gprs-used 8) - (svref *objc-gpr-offsets* gprs-used) - (current-memory-arg-offset))) - (current-fpr-arg-offset () - (if (< fprs-used 13) - (svref *objc-fpr-offsets* fprs-used) - (current-memory-arg-offset)))) - (let* ((result nil)) - (dolist (argspec arglist (nreverse result)) - (let* ((arg (parse-foreign-type argspec)) - (offset 0) - (size 0)) - (typecase arg - (foreign-double-float-type - (setq size 8 offset (current-fpr-arg-offset)) - (incf fprs-used) - (incf gprs-used 2)) - (foreign-single-float-type - (setq size target::node-size offset (current-fpr-arg-offset)) - (incf fprs-used) - (incf gprs-used 1)) - (foreign-pointer-type - (setq size target::node-size offset (current-gpr-arg-offset)) - (incf gprs-used)) - (foreign-integer-type - (let* ((bits (foreign-type-bits arg))) - (setq size (ceiling bits 8) - offset (current-gpr-arg-offset)) - (incf gprs-used (ceiling bits target::nbits-in-word)))) - ((or foreign-record-type foreign-array-type) - (let* ((bits (ensure-foreign-type-bits arg))) - (setq size (ceiling bits 8) - offset (current-gpr-arg-offset)) - (incf gprs-used (ceiling bits target::nbits-in-word)))) - (t (break "argspec = ~s, arg = ~s" argspec arg))) - (push (list (encode-objc-type arg) offset size) result)))))))) - (declare (fixnum gprs-used fprs-used)) - (let* ((max-parm-end - (- (apply #'max (mapcar #'(lambda (i) (+ (cadr i) (caddr i))) - arg-info)) - objc-forwarding-stack-offset))) - (format nil "~a~d~:{~a~d~}" - (encode-objc-type - (parse-foreign-type result-spec)) - max-parm-end - arg-info)))) - -#+x8664-target -(defun encode-objc-method-arglist (arglist result-spec) - (let* ((offset 0) - (arg-info - (let* ((result nil)) - (dolist (argspec arglist (nreverse result)) - (let* ((arg (parse-foreign-type argspec)) - (delta 8)) - (typecase arg - (foreign-double-float-type) - (foreign-single-float-type) - ((or foreign-pointer-type foreign-array-type)) - (foreign-integer-type) - (foreign-record-type - (let* ((bits (ensure-foreign-type-bits arg))) - (setq delta (ceiling bits 8)))) - (t (break "argspec = ~s, arg = ~s" argspec arg))) - (push (list (encode-objc-type arg) offset) result) - (setq offset (* 8 (ceiling (+ offset delta) 8)))))))) - (let* ((max-parm-end offset)) - (format nil "~a~d~:{~a~d~}" - (encode-objc-type - (parse-foreign-type result-spec)) - max-parm-end - arg-info)))) - -;;; In Apple Objc, a class's methods are stored in a (-1)-terminated -;;; vector of method lists. In GNU ObjC, method lists are linked -;;; together. -(defun %make-method-vector () - #+apple-objc - (let* ((method-vector (malloc 16))) - (setf (%get-signed-long method-vector 0) 0 - (%get-signed-long method-vector 4) 0 - (%get-signed-long method-vector 8) 0 - (%get-signed-long method-vector 12) -1) - method-vector)) - - -;;; Make a meta-class object (with no instance variables or class -;;; methods.) -#-apple-objc-2.0 -(defun %make-basic-meta-class (nameptr superptr rootptr) - #+apple-objc - (let* ((method-vector (%make-method-vector))) - (make-record :objc_class - :isa (pref rootptr :objc_class.isa) - :super_class (pref superptr :objc_class.isa) - :name nameptr - :version 0 - :info #$CLS_META - :instance_size 0 - :ivars (%null-ptr) - :methodists method-vector - :cache (%null-ptr) - :protocols (%null-ptr))) - #+gnu-objc - (make-record :objc_class - :class_pointer (pref rootptr :objc_class.class_pointer) - :super_class (pref superptr :objc_class.class_pointer) - :name nameptr - :version 0 - :info #$_CLS_META - :instance_size 0 - :ivars (%null-ptr) - :methods (%null-ptr) - :dtable (%null-ptr) - :subclass_list (%null-ptr) - :sibling_class (%null-ptr) - :protocols (%null-ptr) - :gc_object_type (%null-ptr))) - -#-apple-objc-2.0 -(defun %make-class-object (metaptr superptr nameptr ivars instance-size) - #+apple-objc - (let* ((method-vector (%make-method-vector))) - (make-record :objc_class - :isa metaptr - :super_class superptr - :name nameptr - :version 0 - :info #$CLS_CLASS - :instance_size instance-size - :ivars ivars - :methodists method-vector - :cache (%null-ptr) - :protocols (%null-ptr))) - #+gnu-objc - (make-record :objc_class - :class_pointer metaptr - :super_class superptr - :name nameptr - :version 0 - :info #$_CLS_CLASS - :instance_size instance-size - :ivars ivars - :methods (%null-ptr) - :dtable (%null-ptr) - :protocols (%null-ptr))) - -(defun make-objc-class-pair (superptr nameptr) - #+apple-objc-2.0 - (#_objc_allocateClassPair superptr nameptr 0) - #-apple-objc-2.0 - (%make-class-object - (%make-basic-meta-class nameptr superptr (@class "NSObject")) - superptr - nameptr - (%null-ptr) - 0)) - -(defun superclass-instance-size (class) - (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass class) - #-apple-objc-2.0 (pref class :objc_class.super_class))) - (if (%null-ptr-p super) - 0 - (%objc-class-instance-size super)))) - - - - -#+gnu-objc -(progn -(defloadvar *gnu-objc-runtime-mutex* - (%get-ptr (foreign-symbol-address "__objc_runtime_mutex"))) -(defmacro with-gnu-objc-mutex-locked ((mutex) &body body) - (let* ((mname (gensym))) - `(let ((,mname ,mutex)) - (unwind-protect - (progn - (external-call "objc_mutex_lock" :address ,mname :void) - ,@body) - (external-call "objc_mutex_lock" :address ,mname :void))))) -) - -(defun %objc-metaclass-p (class) - #+apple-objc-2.0 (not (eql #$NO (#_class_isMetaClass class))) - #-apple-objc-2.0 - (logtest (pref class :objc_class.info) - #+apple-objc #$CLS_META - #+gnu-objc #$_CLS_META)) - -;; No way to tell in Objc-2.0. Does anything care ? -#-apple-objc-2.0 -(defun %objc-class-posing-p (class) - (logtest (pref class :objc_class.info) - #+apple-objc #$CLS_POSING - #+gnu-objc #$_CLS_POSING)) - - - - -;;; Create (malloc) class and metaclass objects with the specified -;;; name (string) and superclass name. Initialize the metaclass -;;; instance, but don't install the class in the ObjC runtime system -;;; (yet): we don't know anything about its ivars and don't know -;;; how big instances will be yet. -;;; If an ObjC class with this name already exists, we're very -;;; confused; check for that case and error out if it occurs. -(defun %allocate-objc-class (name superptr) - (let* ((class-name (compute-objc-classname name))) - (if (lookup-objc-class class-name nil) - (error "An Objective C class with name ~s already exists." class-name)) - (let* ((nameptr (make-cstring class-name)) - (id (register-objc-class - (make-objc-class-pair superptr nameptr) -)) - (meta-id (objc-class-id->objc-metaclass-id id)) - (meta (id->objc-metaclass meta-id)) - (class (id->objc-class id)) - (meta-name (intern (format nil "+~a" name) - (symbol-package name))) - (meta-super (canonicalize-registered-metaclass - #+apple-objc-2.0 - (#_class_getSuperclass meta) - #-apple-objc-2.0 - (pref meta :objc_class.super_class)))) - (initialize-instance meta - :name meta-name - :direct-superclasses (list meta-super)) - (setf (objc-class-id-foreign-name id) class-name - (objc-metaclass-id-foreign-name meta-id) class-name - (find-class meta-name) meta) - (%defglobal name class) - (%defglobal meta-name meta) - class))) - -;;; Set up the class's ivar_list and instance_size fields, then -;;; add the class to the ObjC runtime. -#-apple-objc-2.0 -(defun %add-objc-class (class ivars instance-size) - (setf - (pref class :objc_class.ivars) ivars - (pref class :objc_class.instance_size) instance-size) - #+apple-objc - (#_objc_addClass class) - #+gnu-objc - ;; Why would anyone want to create a class without creating a Module ? - ;; Rather than ask that vexing question, let's create a Module with - ;; one class in it and use #___objc_exec_class to add the Module. - ;; (I mean "... to add the class", of course. - ;; It appears that we have to heap allocate the module, symtab, and - ;; module name: the GNU ObjC runtime wants to add the module to a list - ;; that it subsequently ignores. - (let* ((name (make-cstring "Phony Module")) - (symtab (malloc (+ (record-length :objc_symtab) (record-length (:* :void))))) - (m (make-record :objc_module - :version 8 #|OBJC_VERSION|# - :size (record-length :odule) - :name name - :symtab symtab))) - (setf (%get-ptr symtab (record-length :objc_symtab)) (%null-ptr)) - (setf (pref symtab :objc_symtab.sel_ref_cnt) 0 - (pref symtab :objc_symtab.refs) (%null-ptr) - (pref symtab :objc_symtab.cls_def_cnt) 1 - (pref symtab :objc_symtab.cat_def_cnt) 0 - (%get-ptr (pref symtab :objc_symtab.defs)) class - (pref class :objc_class.info) (logior #$_CLS_RESOLV (pref class :objc_class.info))) - (#___objc_exec_class m))) - -#+apple-objc-2.0 -(defun %add-objc-class (class) - (#_objc_registerClassPair class)) - - - - - - - -(let* ((objc-gen-message-args (make-array 10 :fill-pointer 0 :adjustable t))) - (defun %objc-gen-message-arg (n) - (let* ((len (length objc-gen-message-args))) - (do* ((i len (1+ i))) - ((> i n) (aref objc-gen-message-args n)) - (vector-push-extend (intern (format nil "ARG~d" i)) objc-gen-message-args))))) - -(defun objc-gen-message-arglist (n) - (collect ((args)) - (dotimes (i n (args)) (args (%objc-gen-message-arg i))))) - - - -;;; Call get-objc-message-info for all known init messages. (A -;;; message is an "init message" if it starts with the string "init", -;;; and has at least one declared method that returns :ID and is not a -;;; protocol method. -(defun register-objc-init-messages () - (do-interface-dirs (d) - (dolist (init (cdb-enumerate-keys (db-objc-methods d) - #'(lambda (string) - (string= string "init" :end1 (min (length string) 4))))) - (get-objc-message-info init)))) - - -(defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal) - "Maps from lists of init keywords to dispatch-functions for init messages") - - - -(defun send-objc-init-message (instance init-keywords args) - (let* ((info (gethash init-keywords *objc-init-messages-for-init-keywords*))) - (unless info - (let* ((name (lisp-to-objc-init init-keywords)) - (name-info (get-objc-message-info name nil))) - (unless name-info - (error "Unknown ObjC init message: ~s" name)) - (setf (gethash init-keywords *objc-init-messages-for-init-keywords*) - (setq info name-info)))) - (apply (objc-message-info-lisp-name info) instance args))) - - - - - - -;;; Return the "canonical" version of P iff it's a known ObjC class -(defun objc-class-p (p) - (if (typep p 'macptr) - (let* ((id (objc-class-id p))) - (if id (id->objc-class id))))) - -;;; Return the canonical version of P iff it's a known ObjC metaclass -(defun objc-metaclass-p (p) - (if (typep p 'macptr) - (let* ((id (objc-metaclass-id p))) - (if id (id->objc-metaclass id))))) - -;;; If P is an ObjC instance, return a pointer to its class. -;;; This assumes that all instances are allocated via something that's -;;; ultimately malloc-based. -(defun objc-instance-p (p) - (when (typep p 'macptr) - (let* ((idx (%objc-instance-class-index p))) - (if idx (id->objc-class idx))))) - - - - -(defun objc-private-class-id (classptr) - (let* ((info (%get-private-objc-class classptr))) - (when info - (or (private-objc-class-info-declared-ancestor info) - (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass classptr) - #-apple-objc-2.0 (pref classptr :objc_class.super_class))) - (loop - (when (%null-ptr-p super) - (return)) - (let* ((id (objc-class-id super))) - (if id - (return (setf (private-objc-class-info-declared-ancestor info) - id)) - (%setf-macptr super #+apple-objc-2.0 (#_class_getSuperclass super) - #-apple-objc-2.0 (pref super :objc_class.super_class)))))))))) - -(defun objc-class-or-private-class-id (classptr) - (or (objc-class-id classptr) - (objc-private-class-id classptr))) - - -(defun %objc-instance-class-index (p) - (unless (%null-ptr-p p) - (if (with-macptrs (q) - (safe-get-ptr p q) - (not (%null-ptr-p q))) - (with-macptrs ((parent #+apple-objc (pref p :objc_object.isa) - #+gnu-objc (pref p :objc_object.class_pointer))) - (or - (objc-class-id parent) - (objc-private-class-id parent)))))) - - -;;; If an instance, return (values :INSTANCE ) -;;; If a class, return (values :CLASS ). -;;; If a metaclass, return (values :METACLASS ). -;;; Else return (values NIL NIL). -(defun objc-object-p (p) - (let* ((instance-p (objc-instance-p p))) - (if instance-p - (values :instance instance-p) - (let* ((class-p (objc-class-p p))) - (if class-p - (values :class class-p) - (let* ((metaclass-p (objc-metaclass-p p))) - (if metaclass-p - (values :metaclass metaclass-p) - (values nil nil)))))))) - - - - - -;;; If the class contains an mlist that contains a method that -;;; matches (is EQL to) the selector, remove the mlist and -;;; set its IMP; return the containing mlist. -;;; If the class doesn't contain any matching mlist, create -;;; an mlist with one method slot, initialize the method, and -;;; return the new mlist. Doing it this way ensures -;;; that the objc runtime will invalidate any cached references -;;; to the old IMP, at least as far as objc method dispatch is -;;; concerned. -#-apple-objc-2.0 -(defun %mlist-containing (classptr selector typestring imp) - #-apple-objc (declare (ignore classptr selector typestring imp)) - #+apple-objc - (%stack-block ((iter 4)) - (setf (%get-ptr iter) (%null-ptr)) - (loop - (let* ((mlist (#_class_nextMethodList classptr iter))) - (when (%null-ptr-p mlist) - (let* ((mlist (make-record :objc_method_list - :method_count 1)) - (method (pref mlist :objc_method_list.method_list))) - (setf (pref method :objc_method.method_name) selector - (pref method :objc_method.method_types) - (make-cstring typestring) - (pref method :objc_method.method_imp) imp) - (return mlist))) - (do* ((n (pref mlist :objc_method_list.method_count)) - (i 0 (1+ i)) - (method (pref mlist :objc_method_list.method_list) - (%incf-ptr method (record-length :objc_method)))) - ((= i n)) - (declare (fixnum i n)) - (when (eql selector (pref method :objc_method.method_name)) - (#_class_removeMethods classptr mlist) - (setf (pref method :objc_method.method_imp) imp) - (return-from %mlist-containing mlist))))))) - - -(defun %add-objc-method (classptr selector typestring imp) - #+apple-objc-2.0 - (with-cstrs ((typestring typestring)) - (or (not (eql #$NO (#_class_addMethod classptr selector imp typestring))) - (let* ((m (if (objc-metaclass-p classptr) - (#_class_getClassMethod classptr selector) - (#_class_getInstanceMethod classptr selector)))) - (if (not (%null-ptr-p m)) - (#_method_setImplementation m imp) - (error "Can't add ~s method to class ~s" selector typestring))))) - #-apple-objc-2.0 - (progn - #+apple-objc - (#_class_addMethods classptr - (%mlist-containing classptr selector typestring imp)) - #+gnu-objc - ;;; We have to do this ourselves, and have to do it with the runtime - ;;; mutex held. - (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*) - (let* ((ctypestring (make-cstring typestring)) - (new-mlist nil)) - (with-macptrs ((method (external-call "search_for_method_in_list" - :address (pref classptr :objc_class.methods) - :address selector - :address))) - (when (%null-ptr-p method) - (setq new-mlist (make-record :objc_method_list :method_count 1)) - (%setf-macptr method (pref new-mlist :objc_method_list.method_list))) - (setf (pref method :objc_method.method_name) selector - (pref method :objc_method.method_types) ctypestring - (pref method :objc_method.method_imp) imp) - (if new-mlist - (external-call "GSObjCAddMethods" - :address classptr - :address new-mlist - :void) - (external-call "__objc_update_dispatch_table_for_class" - :address classptr - :void))))))) - -(defvar *lisp-objc-methods* (make-hash-table :test #'eq)) - -(defstruct lisp-objc-method - class-descriptor - sel - typestring - class-p ;t for class methods - imp ; callback ptr - ) - -(defun %add-lisp-objc-method (m) - (let* ((class (%objc-class-classptr (lisp-objc-method-class-descriptor m))) - (sel (%get-selector (lisp-objc-method-sel m))) - (typestring (lisp-objc-method-typestring m)) - (imp (lisp-objc-method-imp m))) - (%add-objc-method - (if (lisp-objc-method-class-p m) - (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) - class) - sel - typestring - imp))) - -(def-ccl-pointers add-objc-methods () - (maphash #'(lambda (impname m) - (declare (ignore impname)) - (%add-lisp-objc-method m)) - *lisp-objc-methods*)) - -(defun %define-lisp-objc-method (impname classname selname typestring imp - &optional class-p) - (%add-lisp-objc-method - (setf (gethash impname *lisp-objc-methods*) - (make-lisp-objc-method - :class-descriptor (load-objc-class-descriptor classname) - :sel (load-objc-selector selname) - :typestring typestring - :imp imp - :class-p class-p))) - impname) - - - - - -;;; If any of the argspecs denote a value of type :, push an -;;; appropriate SETQ on the front of the body. (Order doesn't matter.) -(defun coerce-foreign-boolean-args (argspecs body) - (do* ((argspecs argspecs (cddr argspecs)) - (type (car argspecs) (car argspecs)) - (var (cadr argspecs) (cadr argspecs))) - ((null argspecs) body) - (when (eq type :) - (push `(setq ,var (not (eql ,var 0))) body)))) - -(defun lisp-boolean->foreign-boolean (form) - (let* ((val (gensym))) - `((let* ((,val (progn ,@form))) - (if (and ,val (not (eql 0 ,val))) 1 0))))) - -;;; Return, as multiple values: -;;; the selector name, as a string -;;; the ObjC class name, as a string -;;; the foreign result type -;;; the foreign argument type/argument list -;;; the body -;;; a string which encodes the foreign result and argument types -(defun parse-objc-method (selector-arg class-arg body) - (let* ((class-name (objc-class-name-string class-arg)) - (selector-form selector-arg) - (selector nil) - (argspecs nil) - (resulttype nil) - (struct-return nil)) - (flet ((bad-selector (why) (error "Can't parse method selector ~s : ~a" - selector-arg why))) - (typecase selector-form - (string - (let* ((specs (pop body))) - (setq selector selector-form) - (if (evenp (length specs)) - (setq argspecs specs resulttype :id) - (setq resulttype (car (last specs)) - argspecs (butlast specs))))) - (cons ;sic - (setq resulttype (pop selector-form)) - (unless (consp selector-form) - (bad-selector "selector-form not a cons")) - (ccl::collect ((components) - (specs)) - ;; At this point, selector-form should be either a list of - ;; a single symbol (a lispified version of the selector name - ;; of a selector that takes no arguments) or a list of keyword/ - ;; variable pairs. Each keyword is a lispified component of - ;; the selector name; each "variable" is either a symbol - ;; or a list of the form ( ), where - ;; an atomic variable is shorthand for (:id ). - (if (and (null (cdr selector-form)) - (car selector-form) - (typep (car selector-form) 'symbol) - (not (typep (car selector-form) 'keyword))) - (components (car selector-form)) - (progn - (unless (evenp (length selector-form)) - (bad-selector "Odd length")) - (do* ((s selector-form (cddr s)) - (comp (car s) (car s)) - (var (cadr s) (cadr s))) - ((null s)) - (unless (typep comp 'keyword) (bad-selector "not a keyword")) - (components comp) - (cond ((atom var) - (unless (and var (symbolp var)) - (bad-selector "not a non-null symbol")) - (specs :id) - (specs var)) - ((and (consp (cdr var)) - (null (cddr var)) - (cadr var) - (symbolp (cadr var))) - (specs (car var)) - (specs (cadr var))) - (t (bad-selector "bad variable/type clause")))))) - (setq argspecs (specs) - selector (lisp-to-objc-message (components))))) - (t (bad-selector "general failure"))) - ;; If the result type is of the form (:STRUCT ), - ;; make be the first argument. - (when (and (consp resulttype) - (eq (car resulttype) :struct)) - (destructuring-bind (typespec name) (cdr resulttype) - (let* ((rtype (%foreign-type-or-record typespec))) - (if (and (typep name 'symbol) - (typep rtype 'foreign-record-type)) - (setq struct-return name - resulttype (unparse-foreign-type rtype)) - (bad-selector "Bad struct return type"))))) - (values selector - class-name - resulttype - argspecs - body - (do* ((argtypes ()) - (argspecs argspecs (cddr argspecs))) - ((null argspecs) (encode-objc-method-arglist - `(:id : ,@(nreverse argtypes)) - resulttype)) - (push (car argspecs) argtypes)) - struct-return)))) - -(defun objc-method-definition-form (class-p selector-arg class-arg body env) - (multiple-value-bind (selector-name - class-name - resulttype - argspecs - body - typestring - struct-return) - (parse-objc-method selector-arg class-arg body) - (%declare-objc-method selector-name - class-name - class-p - (concise-foreign-type resulttype) - (collect ((argtypes)) - (do* ((argspecs argspecs (cddr argspecs))) - ((null argspecs) (mapcar #'concise-foreign-type (argtypes))) - (argtypes (car argspecs))))) - (let* ((self (intern "SELF"))) - (multiple-value-bind (body decls) (parse-body body env) - (unless class-p - (push `(%set-objc-instance-type ,self) body)) - (setq body (coerce-foreign-boolean-args argspecs body)) - (if (eq resulttype :) - (setq body (lisp-boolean->foreign-boolean body))) - (let* ((impname (intern (format nil "~c[~a ~a]" - (if class-p #\+ #\-) - class-name - selector-name))) - (_cmd (intern "_CMD")) - (super (gensym "SUPER")) - (params `(:id ,self : ,_cmd))) - (when struct-return - (push struct-return params)) - (setq params (nconc params argspecs)) - `(progn - (defcallback ,impname - (:without-interrupts nil - #+(and openmcl-native-threads apple-objc) :error-return - #+(and openmcl-native-threads apple-objc) (condition objc-callback-error-return) ,@params ,resulttype) - (declare (ignorable ,_cmd)) - ,@decls - (rlet ((,super :objc_super - #+apple-objc :receiver #+gnu-objc :self ,self - #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class - ,@(if class-p - #+apple-objc-2.0 - `((external-call "_class_getSuperclass" - :address (pref (@class ,class-name) :objc_class.isa) :address)) - #-apple-objc-2.0 - `((pref - (pref (@class ,class-name) - #+apple-objc :objc_class.isa - #+gnu-objc :objc_class.class_pointer) - :objc_class.super_class)) - #+apple-objc-2.0 - `((external-call "_class_getSuperclass" - :address (@class ,class-name) :address)) - #-apple-objc-2.0 - `((pref (@class ,class-name) :objc_class.super_class))))) - (macrolet ((send-super (msg &rest args &environment env) - (make-optimized-send nil msg args env nil ',super ,class-name)) - (send-super/stret (s msg &rest args &environment env) - (make-optimized-send nil msg args env s ',super ,class-name))) - ,@body))) - (%define-lisp-objc-method - ',impname - ,class-name - ,selector-name - ,typestring - ,impname - ,class-p))))))) - -(defmacro define-objc-method ((selector-arg class-arg) - &body body &environment env) - (objc-method-definition-form nil selector-arg class-arg body env)) - -(defmacro define-objc-class-method ((selector-arg class-arg) - &body body &environment env) - (objc-method-definition-form t selector-arg class-arg body env)) - - -(declaim (inline %objc-struct-return)) - -(defun %objc-struct-return (return-temp size value) - (unless (eq return-temp value) - (#_bcopy value return-temp size))) - -(defmacro objc:defmethod (name (self-arg &rest other-args) &body body &environment env) - (collect ((arglist) - (arg-names) - (arg-types) - (bool-args) - (type-assertions)) - (let* ((result-type nil) - (struct-return-var nil) - (struct-return-size nil) - (selector nil) - (cmd (intern "_CMD")) - (class-p nil) - (objc-class-name nil)) - (if (atom name) - (setq selector (string name) result-type :id) - (setq selector (string (car name)) result-type (concise-foreign-type (or (cadr name) :id)))) - (destructuring-bind (self-name lisp-class-name) self-arg - (arg-names self-name) - (arg-types :id) - ;; Hack-o-rama - (let* ((lisp-class-name (string lisp-class-name))) - (if (eq (schar lisp-class-name 0) #\+) - (setq class-p t lisp-class-name (subseq lisp-class-name 1))) - (setq objc-class-name (lisp-to-objc-classname lisp-class-name))) - (let* ((rtype (parse-foreign-type result-type))) - (when (typep rtype 'foreign-record-type) - (setq struct-return-var (gensym)) - (setq struct-return-size (ceiling (foreign-type-bits rtype) 8)) - (arglist struct-return-var))) - (arg-types :) - (arg-names cmd) - (dolist (arg other-args) - (if (atom arg) - (progn - (arg-types :id) - (arg-names arg)) - (destructuring-bind (arg-name arg-type) arg - (let* ((concise-type (concise-foreign-type arg-type))) - (unless (eq concise-type :id) - (let* ((ftype (parse-foreign-type concise-type))) - (if (typep ftype 'foreign-pointer-type) - (setq ftype (foreign-pointer-type-to ftype))) - (if (and (typep ftype 'foreign-record-type) - (foreign-record-type-name ftype)) - (type-assertions `(%set-macptr-type ,arg-name - (foreign-type-ordinal (load-time-value (%foreign-type-or-record ,(foreign-record-type-name ftype))))))))) - (arg-types concise-type) - (arg-names arg-name))))) - (let* ((arg-names (arg-names)) - (arg-types (arg-types))) - (do* ((names arg-names) - (types arg-types)) - ((null types) (arglist result-type)) - (let* ((name (pop names)) - (type (pop types))) - (arglist type) - (arglist name) - (if (eq type :) - (bool-args `(setq ,name (not (eql ,name 0))))))) - (let* ((impname (intern (format nil "~c[~a ~a]" - (if class-p #\+ #\-) - objc-class-name - selector))) - (typestring (encode-objc-method-arglist arg-types result-type)) - (signature (cons result-type (cddr arg-types)))) - (multiple-value-bind (body decls) (parse-body body env) - - (setq body `((progn ,@(bool-args) ,@(type-assertions) ,@body))) - (if (eq result-type :) - (setq body `((%coerce-to-bool ,@body)))) - (when struct-return-var - (setq body `((%objc-struct-return ,struct-return-var ,struct-return-size ,@body))) - (setq body `((flet ((struct-return-var-function () - ,struct-return-var)) - (declaim (inline struct-return-var-function)) - ,@body))) - (setq body `((macrolet ((objc:returning-foreign-struct ((var) &body body) - `(let* ((,var (struct-return-var-function))) - ,@body))) - ,@body)))) - (setq body `((flet ((call-next-method (&rest args) - (declare (dynamic-extent args)) - (apply (function ,(if class-p - '%call-next-objc-class-method - '%call-next-objc-method)) - ,self-name - (@class ,objc-class-name) - (@selector ,selector) - ',signature - args))) - (declare (inline call-next-method)) - ,@body))) - `(progn - (%declare-objc-method - ',selector - ',objc-class-name - ,class-p - ',result-type - ',(cddr arg-types)) - (defcallback ,impname ( :error-return (condition objc-callback-error-return) ,@(arglist)) - (declare (ignorable ,self-name ,cmd) - (unsettable ,self-name) - ,@(unless class-p `((type ,lisp-class-name ,self-name)))) - ,@decls - ,@body) - (%define-lisp-objc-method - ',impname - ,objc-class-name - ,selector - ,typestring - ,impname - ,class-p))))))))) - - - - - -(defun class-get-instance-method (class sel) - #+apple-objc (#_class_getInstanceMethod class sel) - #+gnu-objc (#_class_get_instance_method class sel)) - -(defun class-get-class-method (class sel) - #+apple-objc (#_class_getClassMethod class sel) - #+gnu-objc (#_class_get_class_method class sel)) - -(defun method-get-number-of-arguments (m) - #+apple-objc (#_method_getNumberOfArguments m) - #+gnu-objc (#_method_get_number_of_arguments m)) - -#+(and apple-objc (not apple-objc-2.0)) -(progn -(defloadvar *original-deallocate-hook* - #&_dealloc) - -(defcallback deallocate-nsobject (:address obj :int) - (unless (%null-ptr-p obj) - (remhash obj *objc-object-slot-vectors*)) - (ff-call *original-deallocate-hook* :address obj :int)) - -(defun install-lisp-deallocate-hook () - (setf #&_dealloc deallocate-nsobject)) - -#+later -(def-ccl-pointers install-deallocate-hook () - (install-lisp-deallocate-hook)) - -(defun uninstall-lisp-deallocate-hook () - (clrhash *objc-object-slot-vectors*) - (setf #&_dealloc *original-deallocate-hook*)) - -(pushnew #'uninstall-lisp-deallocate-hook *save-exit-functions* :test #'eq - :key #'function-name) -) - - - - - -(defloadvar *nsstring-newline* #@" -") - - -;;; Execute BODY with an autorelease pool - -(defmacro with-autorelease-pool (&body body) - (let ((pool-temp (gensym))) - `(let ((,pool-temp (create-autorelease-pool))) - (unwind-protect - (progn ,@body) - (release-autorelease-pool ,pool-temp))))) - - -(defun %make-nsstring (string) - (with-encoded-cstrs :utf-8 ((s string)) - (%make-nsstring-from-utf8-c-string s))) - - - -#+apple-objc-2.0 -;;; New!!! Improved!!! At best, half-right!!! -(defmacro with-ns-exceptions-as-errors (&body body) - `(progn ,@body)) - - - -#-apple-objc-2.0 -(defmacro with-ns-exceptions-as-errors (&body body) - #+apple-objc - (let* ((nshandler (gensym)) - (cframe (gensym))) - `(rletZ ((,nshandler :andler2)) - (unwind-protect - (progn - (external-call "__NSAddHandler2" :address ,nshandler :void) - (catch ,nshandler - (with-c-frame ,cframe - (%associate-jmp-buf-with-catch-frame - ,nshandler - (%fixnum-ref (%current-tcr) target::tcr.catch-top) - ,cframe) - (progn - ,@body)))) - (check-ns-exception ,nshandler)))) - #+gnu-objc - `(progn ,@body) - ) - - - - - -#+(and apple-objc (not apple-objc-2.0)) -(defun check-ns-exception (nshandler) - (with-macptrs ((exception (external-call "__NSExceptionObjectFromHandler2" - :address nshandler - :address))) - (if (%null-ptr-p exception) - (external-call "__NSRemoveHandler2" :address nshandler :void) - (error (ns-exception->lisp-condition (%inc-ptr exception 0)))))) - - - - Index: anches/ide-1.0/ccl/cocoa-bridge/objc-support.lisp =================================================================== --- /branches/ide-1.0/ccl/cocoa-bridge/objc-support.lisp (revision 6863) +++ (revision ) @@ -1,490 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- - -(in-package "CCL") - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "BRIDGE")) - -(defun allocate-objc-object (class) - (#/alloc class)) - -(defun conforms-to-protocol (thing protocol) - (#/conformsToProtocol: thing (objc-protocol-address protocol))) - - - - -#+apple-objc -(defun iterate-over-objc-classes (fn) - (let* ((n (#_objc_getClassList (%null-ptr) 0))) - (declare (fixnum n)) - (%stack-block ((buffer (the fixnum (ash n target::word-shift)))) - (#_objc_getClassList buffer n) - (do* ((i 0 (1+ i))) - ((= i n) (values)) - (declare (fixnum i)) - (funcall fn (paref buffer (:* :id) i)))))) - -#+apple-objc -(defun count-objc-classes () - (#_objc_getClassList (%null-ptr) 0)) - -#+gnu-objc -(defun iterate-over-objc-classes (fn) - (rletZ ((enum-state :address)) - (loop - (let* ((class (#_objc_next_class enum-state))) - (if (%null-ptr-p class) - (return) - (funcall fn class)))))) - -#+gnu-objc -(defun count-objc-classes () - (let* ((n 0)) - (declare (fixnum n)) - (rletZ ((enum-state :address)) - (if (%null-ptr-p (#_objc_next_class enum-state)) - (return n) - (incf n))))) - -(defun %note-protocol (p) - (with-macptrs ((cname (objc-message-send p "name" :address))) - (let* ((namelen (%cstrlen cname)) - (name (make-string namelen))) - (declare (dynamic-extent name)) - (%str-from-ptr cname namelen name) - (let* ((proto (or (gethash name *objc-protocols*) - (progn - (setq name (subseq name 0)) - (setf (gethash name *objc-protocols*) - (make-objc-protocol :name name)))))) - (unless (objc-protocol-address proto) - (setf (objc-protocol-address proto) (%inc-ptr p 0))) - proto)))) - -(defun note-class-protocols (class) - #-apple-objc-2.0 - (do* ((protocols (pref class :objc_class.protocols) - (pref protocols :objc_protocol_list.next))) - ((%null-ptr-p protocols)) - (let* ((count (pref protocols :objc_protocol_list.count))) - (with-macptrs ((list (pref protocols :objc_protocol_list.list))) - (dotimes (i count) - (with-macptrs ((p (paref list (:* (:* (:struct :

rotocol))) i))) - (%note-protocol p)))))) - #+apple-objc-2.0 - (rlet ((p-out-count :int)) - (with-macptrs ((protocols (#_class_copyProtocolList class p-out-count))) - (let* ((n (pref p-out-count :int))) - (dotimes (i n) - (with-macptrs ((p (paref protocols (:* (:* (:struct :

rotocol))) i))) - (%note-protocol p)))) - (unless (%null-ptr-p protocols) (#_free protocols))))) - - -(defun map-objc-classes (&optional (lookup-in-database-p t)) - (iterate-over-objc-classes - #'(lambda (class) - (note-class-protocols class) - (install-foreign-objc-class class lookup-in-database-p)))) - -(let* ((nclasses 0)) - (declare (fixnum nclasses)) - (defun maybe-map-objc-classes () - (let* ((new (count-objc-classes))) - (declare (fixnum new)) - (unless (= nclasses new) - (setq nclasses new) - (map-objc-classes) - t))) - (defun reset-objc-class-count () - (setq nclasses 0))) - -(register-objc-class-decls) -(maybe-map-objc-classes) -(register-objc-init-messages) - -#+gnu-objc -(defun iterate-over-class-methods (class method-function) - (do* ((mlist (pref class :objc_class.methods) - (pref mlist :objc_method_list.method_next))) - ((%null-ptr-p mlist)) - (do* ((n (pref mlist :objc_method_list.method_count)) - (i 0 (1+ i)) - (method (pref mlist :objc_method_list.method_list) - (%incf-ptr method (record-length :objc_method)))) - ((= i n)) - (declare (fixnum i n)) - (funcall method-function method class)))) - -#+gnu-objc -(progn - ;; Er, um ... this needs lots-o-work. - (let* ((objc-class-count 0)) - (defun reset-objc-class-count () (setq objc-class-count 0)) - (defun note-all-library-methods (method-function) - (do* ((i objc-class-count (1+ i)) - (class (id->objc-class i) (id->objc-class i))) - ((eq class 0)) - (iterate-over-class-methods class method-function) - (iterate-over-class-methods (id->objc-metaclass i) method-function)))) - (def-ccl-pointers revive-objc-classes () - (reset-objc-class-count))) - -(defun retain-obcj-object (x) - (objc-message-send x "retain")) - - -#+apple-objc-2.0 -(progn -(defun setup-objc-exception-globals () - (flet ((set-global (offset name) - (setf (%get-ptr (%int-to-ptr (+ target::nil-value (%kernel-global-offset offset)))) - (foreign-symbol-address name)))) - (set-global 'x86::objc-2-personality "___objc_personality_v0") - (set-global 'x86::objc-2-begin-catch "_objc_begin_catch") - (set-global 'x86::objc-2-end-catch "_objc_end_catch") - (set-global 'x86::unwind-resume "__Unwind_Resume"))) - - -(def-ccl-pointers setup-objc-exception-handling () - (setup-objc-exception-globals)) - -(setup-objc-exception-globals) -) - - -(defvar *condition-id-map* (make-id-map) "Map lisp conditions to small integers") - -;;; Encapsulate an NSException in a lisp condition. -(define-condition ns-exception (error) - ((ns-exception :initarg :ns-exception :accessor ns-exception)) - (:report (lambda (c s) - (format s "Objective-C runtime exception: ~&~a" - (nsobject-description (ns-exception c)))))) - - - -(defclass ns-lisp-exception (ns::ns-exception) - ((condition :initarg :condition :initform nil :reader ns-lisp-exception-condition)) - (:metaclass ns::+ns-object)) - -(objc:defmethod #/init ((self ns-lisp-exception)) - (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" +null-ptr+)) - - -(defun recognize-objc-exception (x) - (if (typep x 'ns:ns-exception) - (ns-exception->lisp-condition x))) - -(pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*) - -(defun %make-nsstring-from-utf8-c-string (s) - (#/initWithUTF8String: (#/alloc ns:ns-string) s)) - - -(defun retain-objc-instance (instance) - (#/retain instance)) - - -(defun create-autorelease-pool () - (#/init (#/alloc ns:ns-autorelease-pool))) - -(defun release-autorelease-pool (p) - (#/release p)) - - -#-ascii-only -(defun lisp-string-from-nsstring (nsstring) - ;; The NSData object created here is autoreleased. - (let* ((data (#/dataUsingEncoding:allowLossyConversion: - nsstring - #+little-endian-target #x9c000100 - #+big-endian-target #x98000100 - nil))) - (unless (%null-ptr-p data) - (let* ((nbytes (#/length data)) - (string (make-string (ash nbytes -2)))) - ;; BLT the 4-byte code-points from the NSData object - ;; to the string, return the string. - (%copy-ptr-to-ivector (#/bytes data) 0 string 0 nbytes))))) - - - -#+ascii-only -(defun lisp-string-from-nsstring (nsstring) - (with-macptrs (cstring) - (%setf-macptr cstring - (#/cStringUsingEncoding: nsstring #$NSASCIIStringEncoding)) - (unless (%null-ptr-p cstring) - (%get-cstring cstring)))) - - -(objc:defmethod #/reason ((self ns-lisp-exception)) - (with-slots (condition) self - (if condition - (%make-nsstring (format nil "~A" condition)) - (call-next-method)))) - -(objc:defmethod #/description ((self ns-lisp-exception)) - (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self))) - - - -(defun ns-exception->lisp-condition (nsexception) - (if (typep nsexception 'ns-lisp-exception) - (ns-lisp-exception-condition nsexception) - (make-condition 'ns-exception :ns-exception nsexception))) - - -(defmethod ns-exception ((c condition)) - "Map a lisp condition object to an NSException. Note that instances -of the NS-EXCEPTION condition class implement this by accessing an -instance variable." - ;;; Create an NSLispException with a lispid that encapsulates - ;;; this condition. - - ;; (dbg (format nil "~a" c)) - ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c))) - (make-instance 'ns-lisp-exception :condition c)) - - - -#+apple-objc -(progn - - -#+ppc-target -(defun objc-callback-error-return (condition return-value-pointer return-address-pointer) - ;; On PPC, the "address" of an external entry point is always - ;; aligned on a 32-bit word boundary. On PPC32, it can always - ;; be represented as a fixnum; on PPC64, it might be a pointer - ;; instead. - ;; Note that this clobbers the actual (foreign) return address, - ;; replacing it with the address of #__NSRaiseError. Note also - ;; that storing the NSException object as the return value has - ;; the desired effect of causing #__NSRaiseError to be called - ;; with that NSException as its argument (because r3 is used both - ;; as the canonical return value register and used to pass the - ;; first argument on PPC.) - (process-debug-condition *current-process* condition (%get-frame-ptr)) - (let* ((addr (%reference-external-entry-point (load-time-value (external "__NSRaiseError"))))) - (if (typep addr 'fixnum) - (%set-object return-address-pointer 0 addr) - (setf (%get-ptr return-address-pointer 0) addr))) - (setf (%get-ptr return-value-pointer 0) (ns-exception condition)) - nil) - -#+x8664-target -(progn -(defloadvar *x8664-objc-callback-error-return-trampoline* - (let* ((code-bytes '(#x48 #x89 #xc7 ; movq %rax %rdi - #x66 #x48 #x0f #x7e #xc0 ; movd %xmm0,%rax - #x52 ; pushq %rdx - #xff #xe0)) ; jmp *rax - (nbytes (length code-bytes)) - (ptr (%allocate-callback-pointer 16))) - (dotimes (i nbytes ptr) - (setf (%get-unsigned-byte ptr i) (pop code-bytes))))) - -(defun objc-callback-error-return (condition return-value-pointer return-address-pointer) - ;; The callback glue reserves space for %rax at return-value-pointer-8, - ;; for %rdx at -16, for %xmm0 at -24. Store NS-EXCEPTION in the - ;; %rax slot, the address of #_objc_exception_throw in the %rdx slot, the - ;; original return address in the %xmm0 slot, and force a return to - ;; the trampoline code above. - (process-debug-condition *current-process* condition (%get-frame-ptr)) - (setf (%get-ptr return-value-pointer -8) (ns-exception condition) - (%get-ptr return-value-pointer -16) (%get-ptr return-address-pointer 0) - (%get-ptr return-address-pointer 0) *x8664-objc-callback-error-return-trampoline*) - ;; A foreign entry point is always an integer on x8664. - (let* ((addr (%reference-external-entry-point (load-time-value (external "_objc_exception_throw"))))) - (if (< addr 0) ;unlikely - (setf (%%get-signed-longlong return-value-pointer -24) addr) - (setf (%%get-unsigned-longlong return-value-pointer -24) addr))) - nil) - - -) - - -) - - - -(defun open-main-bundle () - (#/mainBundle ns:ns-bundle)) - -;;; Create a new immutable dictionary just like src, replacing the -;;; value of each key in key-value-pairs with the corresponding value. -(defun copy-dictionary (src &rest key-value-pairs) - (declare (dynamic-extent key-value-pairs)) - ;(#_NSLog #@"src = %@" :id src) - (let* ((count (#/count src)) - (enum (#/keyEnumerator src)) - (keys (#/arrayWithCapacity: ns:ns-mutable-array count)) - (values (#/arrayWithCapacity: ns:ns-mutable-array count))) - (loop - (let* ((nextkey (#/nextObject enum))) - (when (%null-ptr-p nextkey) - (return)) - (do* ((kvps key-value-pairs (cddr kvps)) - (newkey (car kvps) (car kvps)) - (newval (cadr kvps) (cadr kvps))) - ((null kvps) - ;; Copy the key, value pair from the src dict - (#/addObject: keys nextkey) - (#/addObject: values (#/objectForKey: src nextkey))) - (when (#/isEqualToString: nextkey newkey) - (#/addObject: keys nextkey) - (#/addObject: values newval) - (return))))) - (make-instance 'ns:ns-dictionary - :with-objects values - :for-keys keys))) - - -(defun nsobject-description (nsobject) - "Returns a lisp string that describes nsobject. Note that some -NSObjects describe themselves in more detail than others." - (with-autorelease-pool - (lisp-string-from-nsstring (#/description nsobject)))) - - - - -;;; This can fail if the nsstring contains non-8-bit characters. -(defun lisp-string-from-nsstring-substring (nsstring start length) - (%stack-block ((cstring (1+ length))) - (#/getCString:maxLength:range:remainingRange: - nsstring cstring length (ns:make-ns-range start length) +null-ptr+) - (%get-cstring cstring))) - -(def-standard-initial-binding *listener-autorelease-pool* nil) - -(setq *listener-autorelease-pool* (create-autorelease-pool)) - -(define-toplevel-command :global rap () "Release and reestablish *LISTENER-AUTORELEASE-POOL*" - (when (eql *break-level* 0) - (without-interrupts - (when (boundp '*listener-autorelease-pool*) - (let* ((old *listener-autorelease-pool*)) - (if old (release-autorelease-pool old)) - (setq *listener-autorelease-pool* (create-autorelease-pool))))))) - -#+apple-objc -(defun show-autorelease-pools () - (objc-message-send (@class ns-autorelease-pool) "showPools" :void)) - -#+gnu-objc -(defun show-autorelease-pools () - (do* ((current (objc-message-send (@class ns-autorelease-pool) "currentPool") - (objc-message-send current "_parentAutoreleasePool")) - (i 0 (1+ i))) - ((%null-ptr-p current) (values)) - (format t "~& ~d : ~a [~d]" - i - (nsobject-description current) - (pref current :utorelease

ool._released_count)))) - -(define-toplevel-command :global sap () "Log information about current thread's autorelease-pool(s) to C's standard error stream" - (show-autorelease-pools)) - -(define-toplevel-command :global kap () "Release (but don't reestablish) *LISTENER-AUTORELEASE-POOL*" - (when (eql *break-level* 0) - (without-interrupts - (when (boundp '*listener-autorelease-pool*) - (let* ((p *listener-autorelease-pool*)) - (setq *listener-autorelease-pool* nil) - (release-autorelease-pool p)))))) - -;;; Use the interfaces for an add-on ObjC framework. We need to -;;; tell the bridge to reconsider what it knows about the type -;;; signatures of ObjC messages, since the new headers may define -;;; a method whose type signature differs from the message's existing -;;; methods. (This probably doesn't happen too often, but it's -;;; possible that some SENDs that have already been compiled would -;;; need to be recompiled with that augmented method type info, e.g., -;;; because ambiguity was introduced.) - -(defun augment-objc-interfaces (dirname) - (use-interface-dir dirname) - (register-objc-class-decls) - (update-objc-method-info)) - -;;; A list of "standard" locations which are known to contain -;;; framework bundles. We should look in ~/Library/Frameworks/" first, -;;; if it exists. -(defparameter *standard-framework-directories* - (list #p"/Library/Frameworks/" - #p"/System/Library/Frameworks/")) - - - -;;; This has to run during application (re-)initializtion, so it -;;; uses lower-level bridge features. -(defun %reload-objc-framework (path) - (when (probe-file path) - (let* ((namestring (native-translated-namestring path))) - (with-cstrs ((cnamestring namestring)) - (with-nsstr (nsnamestring cnamestring (length namestring)) - (with-autorelease-pool - (let* ((bundle (send (@class "NSBundle") - :bundle-with-path nsnamestring))) - (unless (%null-ptr-p bundle) - (coerce-from-bool - (objc-message-send bundle "load" :)))))))))) - - -(defun load-objc-extension-framework (name) - (let* ((dirs *standard-framework-directories*) - (home-frameworks (make-pathname :defaults nil - :directory - (append (pathname-directory - (user-homedir-pathname)) - '("Library" "Frameworks")))) - (fname (list (format nil "~a.framework" name)))) - (when (probe-file home-frameworks) - (pushnew home-frameworks dirs :test #'equalp)) - (dolist (d dirs) - (let* ((path (probe-file (make-pathname :defaults nil - :directory (append (pathname-directory d) - fname))))) - (when path - (let* ((namestring (native-translated-namestring path))) - (with-cstrs ((cnamestring namestring)) - (with-nsstr (nsnamestring cnamestring (length namestring)) - (with-autorelease-pool - (let* ((bundle (#/bundleWithPath: ns:ns-bundle nsnamestring)) - (winning (unless (%null-ptr-p bundle) - t))) - (when winning - (let* ((libpath (#/executablePath bundle))) - (unless (%null-ptr-p libpath) - (open-shared-library (lisp-string-from-nsstring - libpath)))) - (#/load bundle) - (pushnew path *extension-framework-paths* - :test #'equalp) - (map-objc-classes) - ;; Update info about init messages. - (register-objc-init-messages)) - (return winning))))))))))) - -(defun objc:load-framework (framework-name interfaces-name) - (use-interface-dir interfaces-name) - (or (load-objc-extension-framework framework-name) - (error "Can't load ObjC framework ~s" framework-name)) - (augment-objc-interfaces interfaces-name)) - - -(defmethod print-object ((p ns:protocol) stream) - (print-unreadable-object (p stream :type t) - (format stream "~a (#x~x)" - (%get-cstring (#/name p)) - (%ptr-to-int p)))) - - - - -(provide "OBJC-SUPPORT")