Index: /trunk/ccl/objc-bridge/CocoaBridgeDoc.txt =================================================================== --- /trunk/ccl/objc-bridge/CocoaBridgeDoc.txt (revision 6898) +++ /trunk/ccl/objc-bridge/CocoaBridgeDoc.txt (revision 6898) @@ -0,0 +1,289 @@ +A Cocoa Bridge for OpenMCL + +Randall D. Beer +beer@eecs.cwru.edu +http://vorlon.cwru.edu/~beer + + +INTRODUCTION + +The purpose of CocoaBridge is to make Cocoa as easy as possible to use +from OpenMCL, in order to support GUI application and development +environment activities. It builds on the capabilities provided in the +APPLE-OBJC example. The eventual goal is complete integration of +Cocoa into CLOS. The current release provides Lisp-like syntax and +naming conventions for ObjC object creation and message sending, with +automatic type processing and compile-time checking of message +sends. It also provides some convenience facilities for working with +Cocoa. + +A small sample Cocoa program can be invoked by evaluating (REQUIRE +'TINY) and then (CCL::TINY-SETUP). This program provides a simple example +of using several of the bridge's capabilities + + +BASICS + +The main things you need to know are: + +1) You create and initialize ObjC objects using +MAKE-OBJC-INSTANCE. This should be replaced by MAKE-INSTANCE as CLOS +integration improves + +Example: +[[NSNumber alloc] initWithFloat: 2.7] in ObjC becomes +(MAKE-OBJC-INSTANCE 'NS-NUMBER :INIT-WITH-FLOAT 2.7) in Lisp + +Note that class names and init keywords are translated from ObjC to Lisp in +pretty much the obvious way + +2) You send messages to ObjC objects using SEND + +Examples: +[w alphaValue] becomes (SEND W 'ALPHA-VALUE) +[w setAlphaValue: 0.5] becomes (SEND W :SET-ALPHA-VALUE 0.5) +[v mouse: p inRect: r] becomes (SEND V :MOUSE P :IN-RECT R) + +Note that message keywords are translated to Lisp in pretty much the obvious +way. From within a method, you can also use SEND-SUPER. + + +3) The @CLASS macro from APPLE-OBJC is currently used to refer to named ObjC +classes, which can also be sent messages via SEND. This should be replaced by +FIND-CLASS as CLOS integration improves. + +Example: +[NSColor whiteColor] becomes (SEND (@CLASS NS-COLOR) 'WHITE-COLOR) + + +4) New ObjC classes and methods are currently defined using DEF-OBJC-CLASS and +DEFINE-OBJC-METHOD from APPLE-OBJC. This should be replaced by DEFCLASS and +DEFMETHOD as CLOS integration improves. + + +NAME TRANSLATION + +There are a standard set of naming conventions for Cocoa classes, + messages, etc. As long as these are followed, the bridge is fairly + good at automaticallly translating between ObjC and Lisp names. + +Examples: +"NSURLHandleClient" <==> NS-URL-HANDLE-CLIENT +"NSOpenGLView" <==> NS-OPENGL-VIEW +"nextEventMatchingMask:untilDate:inMode:dequeue:" <==> +(:NEXT-EVENT-MATCHING-MASK :UNTIL-DATE :IN-MODE :DEQUEUE) + +To see how a given ObjC or Lisp name will be translated by the bridge, you can +use the following functions: + +OBJC-TO-LISP-CLASSNAME string +LISP-TO-OBJC-CLASSNAME symbol +OBJC-TO-LISP-MESSAGE string +LISP-TO-OBJC-MESSAGE keyword-list +OBJC-TO-LISP-INIT string +LISP-TO-OBJC-INIT keyword-list + +Of course, there will always be exceptions to any naming convention. +Please let me know if you come across any name translation problems +that seem to be bugs. Otherwise, the bridge provides two ways of +dealing with exceptions: + +1) You can pass a string as the class name of MAKE-OBJC-INSTANCE and +as the message to SEND. These strings will be directly interpreted as +ObjC names, with no translation. This is useful for a one-time +exception. + +Examples: +(MAKE-OBJC-INSTANCE "WiErDclass") +(SEND o "WiErDmEsSaGe:WithARG:" x y) + +2) You can define a special translation rule for your exception. This is useful +for an exceptional name that you need to use throughout your code. + +Examples: +(DEFINE-CLASSNAME-TRANSLATION "WiErDclass" WEIRD-CLASS) +(DEFINE-MESSAGE-TRANSLATION "WiErDmEsSaGe:WithARG:" (:WEIRD-MESSAGE :WITH-ARG)) +(DEFINE-INIT-TRANSLATION "WiErDiNiT:WITHOPTION:" (:WEIRD-INIT :OPTION) + +The normal rule in ObjC names is that each word begins with a capital letter +(except possibly the first). Using this rule literally, "NSWindow" would be +translated as N-S-WINDOW, which seems wrong. "NS" is a special word in ObjC +that should not be broken at each capital letter. Likewise "URL", "PDF", +"OpenGL", etc. Most common special words used in Cocoa are already defined in +the bridge, but you can define new ones as follows: (DEFINE-SPECIAL-OBJC-WORD +"QuickDraw") + +Note that message keywords in a SEND such as (SEND V :MOUSE P :IN-RECT R) may +look like Lisp keyword args, but they really aren't. All keywords must be +present and the order is significant. Neither (:IN-RECT :MOUSE) nor (:MOUSE) +translate to "mouse:inRect:" + +Note that an "init" prefix is optional in the initializer keywords, so +(MAKE-OBJC-INSTANCE 'NS-NUMBER :INIT-WITH-FLOAT 2.7) can also be expressed as +(MAKE-OBJC-INSTANCE 'NS-NUMBER :WITH-FLOAT 2.7) + + +STRETS + +Some Cocoa methods return small structures (such as those used to represent +points, rects, sizes and ranges). Although this is normally hidden by the ObjC +compiler, such messages are sent in a special way, with the storage for the +STructure RETurn (STRET) passed as an extra argument. This STRET and special +SEND must normally be made explicit in Lisp. Thus + +NSRect r = [v1 bounds]; +[v2 setBounds r]; + +in ObjC becomes + +(RLET ((R :ect)) + (SEND/STRET R V1 'BOUNDS) + (SEND V2 :SET-BOUNDS R)) + +In order to make STRETs easier to use, the bridge provides two conveniences: + +1) The SLET and SLET* macros may be used to define local variables that are +initialized to STRETs using a normal SEND syntax. Thus, the following is +equivalent to the above RLET: + +(SLET ((R (SEND V 'BOUNDS))) + (SEND V2 :SET-BOUNDS R)) + +2) The arguments to a SEND are evaluated inside an implicit SLET, so instead of +the above, one could in fact just write: + +(SEND V1 :SET-BOUNDS (SEND V2 'BOUNDS)) + +There are also several psuedo-functions provided for convenience by the ObjC +compiler. The following are currently supported by the bridge: NS-MAKE-POINT, +NS-MAKE-RANGE, NS-MAKE-RECT, and NS-MAKE-SIZE. These can be used within a SLET +initform or within a message send: + +(SLET ((P (NS-MAKE-POINT 100.0 200.0))) + (SEND W :SET-FRAME-ORIGIN P)) + +or + +(SEND W :SET-ORIGIN (NS-MAKE-POINT 100.0 200.0)) + +However, since these aren't real functions, a call like the following won't +work: + +(SETQ P (NS-MAKE-POINT 100.0 200.0)) + +The following convenience macros are also provided: NS-MAX-RANGE, NS-MIN-X, +NS-MIN-Y, NS-MAX-X, NS-MAX-Y, NS-MID-X, NS-MID-Y, NS-HEIGHT, and NS-WIDTH. + +Note that there is also a SEND-SUPER/STRET for use within methods. + + +OPTIMIZATION + +The bridge works fairly hard to optimize message sends under two conditions. In +both of these cases, a message send should be nearly as efficient as in ObjC: + +1) When both the message and the receiver's class are known at compile-time. In +general, the only way the receiver's class is known is if you declare it, which +you can do either via a DECLARE or THE form. For example: + +(SEND (THE NS-WINDOW W) 'CENTER) + +Note that there is no way in ObjC to name the class of a class. Thus +the bridge provides a @METACLASS declaration. The type of an instance +of "NSColor" is NS-COLOR. The type of the *class* "NSColor" is +(@METACLASS NS-COLOR): + +(LET ((C (@CLASS NS-COLOR))) + (DECLARE ((@METACLASS NS-COLOR) C)) + (SEND C 'WHITE-COLOR)) + +2) When only the message is known at compile-time, but its type +signature is unique. Of the over 6000 messages currently provided by +Cocoa, only about 50 of them have nonunique type signatures. An +example of a message whose type signature is not unique is SET. It +returns VOID for NSColor, but ID for NSSet. In order to optimize +sends of messages with nonunique type signatures, the class of the +receiver must be declared at compile-time. + +If the type signature is nonunique or the message is unknown at compile-time, +then a slower runtime call must be used. + +The ability of the bridge to optimize most constant message sends even +when the receiver's class is unknown crucially depends on a type +signature table that the bridge maintains. When the bridge is first +loaded, it initializes this table by scanning all methods of all ObjC +classes defined in the environment. If new methods are later defined, +this table must be updated. After a major change (such as loading a +new framework with many classes), you should evaluate +(UPDATE-TYPE-SIGNATURES) to rebuild the type signature table. + +Because SEND, SEND-SUPER, SEND/STRET and SEND-SUPER/STRET are macros, +they cannot be FUNCALLed, APPLYed or passed as functional arguments. +The functions %SEND and %SEND/STRET are provided for this +purpose. There are also %SEND-SUPER and %SEND-SUPER/STRET functions +for use within methods. However, these functions should be used only +when necessary since they perform general (nonoptimized) message +sends. + + +VARIABLE ARITY MESSAGES + +There are a few messages in Cocoa that take variable numbers of arguments. +Perhaps the most common examples involve formatted strings: + +[NSClass stringWithFormat: "%f %f" x y] + +In the bridge, this would be written as follows: + +(SEND (@CLASS NS-STRING) + :STRING-WITH-FORMAT #@"%f %f" + (:DOUBLE-FLOAT X :DOUBLE-FLOAT Y)) + +Note that the types of the variable arguments must be given, since the compiler +has no way of knowing these types in general. + +Variable arity messages can also be sent with the %SEND function: + +(%SEND (@CLASS NS-STRING) + :STRING-WITH-FORMAT #@"%f %f" + (LIST :DOUBLE-FLOAT X :DOUBLE-FLOAT Y)) + +Because the ObjC runtime system does not provide any information on +which messages are variable arity, they must be explicitly defined. +The standard variable arity messages in Cocoa are predefined. If you +need to define a new variable arity message, use +(DEFINE-VARIABLE-ARITY-MESSAGE "myVariableArityMessage:") + + +TYPE COERCION + +OpenMCL's FFI handles many common conversions between Lisp and foreign data, +such as unboxing floating-point args and boxing floating-point results. The +bridge adds a few more automatic conversions: + +1) NIL is equivalent to (%NULL-PTR) for any message argument that requires a +pointer + +2) T/NIL are equivalent to #$YES/#$NO for any boolean argument + +3) A #$YES/#$NO returned by any method that returns BOOL will be automatically +converted to T/NIL + +To make this last conversion work, the bridge has to engage in a bit +of hackery. The bridge uses ObjC run-time type info. Unfortunately, +BOOL is typed as CHAR by ObjC. Thus, a method that returns CHAR might +actually return only BOOL, or it might return any CHAR. The bridge +currently assumes that any method that returns CHAR actually returns +BOOL. But it provides a facility for defining exceptions to this +assumption: (DEFINE-RETURNS-BOOLEAN-EXCEPTION "charValue"). +Eventually, the best way to handle issues like this is probably to get +our method type info directly from the header files rather than using +ObjC's runtime type system. + +Note that no automatic conversion is currently performed between Lisp +strings and NSStrings. However, APPLE-OBJ provides a convenient +syntax for creating constant NSStrings: (SEND W :SET-TITLE #@"My +Window"), as well as facilities for converting between Lisp strings +and NSStrings. Note that #@"Hello" is a full ObjC object, so messages +can be sent to it: (SEND #@"Hello" 'LENGTH) + Index: /trunk/ccl/objc-bridge/bridge.lisp =================================================================== --- /trunk/ccl/objc-bridge/bridge.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/bridge.lisp (revision 6898) @@ -0,0 +1,1437 @@ +;;;; -*- 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: /trunk/ccl/objc-bridge/fake-cfbundle-path.lisp =================================================================== --- /trunk/ccl/objc-bridge/fake-cfbundle-path.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/fake-cfbundle-path.lisp (revision 6898) @@ -0,0 +1,46 @@ +;;;-*-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 info-plist-proto-path) + (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))) + (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 (merge-pathnames + (make-pathname :directory "Contents/" + :name "Info" + :type "plist") + translated-root) + :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: /trunk/ccl/objc-bridge/name-translation.lisp =================================================================== --- /trunk/ccl/objc-bridge/name-translation.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/name-translation.lisp (revision 6898) @@ -0,0 +1,444 @@ +;;;; -*- Mode: Lisp; Package: CCL -*- +;;;; name-translation.lisp +;;;; +;;;; Handles the translation between ObjC and Lisp names +;;;; +;;;; 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 stuff + +(in-package "CCL") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Special ObjC Words ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Special character sequences that should be treated as words in ObjC +;;; names even though they do not follow the normal naming conventions + +(defvar *special-objc-words* nil) + + +;;; Add a special word to *SPECIAL-OBJC-WORDS*, keeping the words sorted +;;; from longest to shortest + +(defmacro define-special-objc-word (str) + `(setf *special-objc-words* + (sort (pushnew ,str *special-objc-words* :test #'equal) + #'> + :key #'length))) + + +;;; Known special words used in Cocoa names + +(define-special-objc-word "AB") +(define-special-objc-word "AE") +(define-special-objc-word "ATS") +(define-special-objc-word "BMP") +(define-special-objc-word "CF") +(define-special-objc-word "CG") +(define-special-objc-word "CMYK") +(define-special-objc-word "MIME") +(define-special-objc-word "DR") +(define-special-objc-word "EPS") +(define-special-objc-word "FTP") +(define-special-objc-word "GMT") +(define-special-objc-word "objC") +(define-special-objc-word "OpenGL") +(define-special-objc-word "HTML") +(define-special-objc-word "HTTP") +(define-special-objc-word "HTTPS") +(define-special-objc-word "IB") +(define-special-objc-word "ID") +(define-special-objc-word "INT64") +(define-special-objc-word "NS") +(define-special-objc-word "MIME") +(define-special-objc-word "PDF") +(define-special-objc-word "PICT") +(define-special-objc-word "PNG") +(define-special-objc-word "QD") +(define-special-objc-word "RGB") +(define-special-objc-word "RTFD") +(define-special-objc-word "RTF") +(define-special-objc-word "TCP") +(define-special-objc-word "TIFF") +(define-special-objc-word "UI") +(define-special-objc-word "UID") +(define-special-objc-word "UTF8") +(define-special-objc-word "URL") +(define-special-objc-word "XOR") +(define-special-objc-word "XML") +(define-special-objc-word "1970") +#+gnu-objc +(define-special-objc-word "GS") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Utilities ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Concatenate all of the simple strings STRS + +(defun string-cat (&rest strs) + (apply #'concatenate 'simple-string strs)) + + +;;; Split a sequence SEQ at each point where TEST is true +;;; DIR should be one of :BEFORE, :AFTER or :ELIDE + +(defun split-if (test seq &optional (dir :before)) + (remove-if + #'(lambda (x) (equal x (subseq seq 0 0))) + (loop for start fixnum = 0 + then (if (eq dir :before) stop (the fixnum (1+ (the fixnum stop)))) + while (< start (length seq)) + for stop = (position-if + test seq + :start (if (eq dir :elide) start (the fixnum (1+ start)))) + collect (subseq + seq start + (if (and stop (eq dir :after)) + (the fixnum (1+ (the fixnum stop))) + stop)) + while stop))) + +(defun split-if-char (char seq &optional dir) + (split-if #'(lambda (ch) (eq ch char)) seq dir)) + + +;;; Collapse all prefixes of L that correspond to known special ObjC words + +(defun collapse-prefix (l) + (unless (null l) + (multiple-value-bind (newpre skip) (check-prefix l) + (cons newpre (collapse-prefix (nthcdr skip l)))))) + +(defun check-prefix (l) + (let ((pl (prefix-list l))) + (loop for w in *special-objc-words* + for p = (position-if #'(lambda (s) (string= s w)) pl) + when p do (return-from check-prefix (values (nth p pl) (1+ p)))) + (values (first l) 1))) + +(defun prefix-list (l) + (loop for i from (1- (length l)) downto 0 + collect (apply #'string-cat (butlast l i)))) + + +;;; Concatenate a list of strings with optional separator into a symbol + +(defun symbol-concatenate (slist &optional (sep "") (package *package*)) + (values + (intern + (reduce #'(lambda (s1 s2) (string-cat s1 sep s2)) + (mapcar #'string-upcase slist)) + package))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Implementation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Convert an ObjC name to a corresponding Lisp name +;;; Example: "NSURLHandleClient" ==> ns-url-handle-client +;;; +;;; 1) Break the string at each uppercase letter +;;; e.g., "NSWindow" ==> ("N" "S" "Window") +;;; 2) Collapse known sequences of letters +;;; e.g., ("N" "S" "Window") ==> ("NS" "Window") +;;; 3) Uppercase and concatenate with hyphens into a symbol +;;; e.g., ("NS" "Window") ==> NS-WINDOW + +(defun compute-lisp-name (str &optional (package *package*)) + (symbol-concatenate + (collapse-prefix + (split-if #'(lambda (ch) (or (upper-case-p ch) (digit-char-p ch))) str)) + "-" + package)) + + +;;; Convert a Lisp classname into a corresponding ObjC classname +;;; Example: ns-url-handle-client ==> "NSURLHandleClient" + +(defun compute-objc-classname (sym) + (apply #'string-cat + (loop for str in (split-if-char #\- (string sym) :elide) + for e = (member str *special-objc-words* + :test #'equal + :key #'string-upcase) + collect (if e (first e) (string-capitalize str))))) + + +;;; Convert an ObjC method selector to a set of Lisp keywords +;;; Example: "nextEventMatchingMask:untilDate:inMode:dequeue:" ==> +;;; (:next-event-matching-mask :until-date :in-mode :dequeue) + +(defun compute-objc-to-lisp-message (str) + (mapcar #'(lambda (s) (compute-lisp-name s (find-package "KEYWORD"))) + (split-if-char #\: str :elide))) + + +(defparameter *objc-colon-replacement-character* #\.) + + +(defun compute-objc-to-lisp-function-name (str &optional (package "NSFUN")) + #-nil + (intern str package) + #+nil + (let* ((n (length str)) + (i 0) + (trailing t)) + (let* ((subs (if (not (position #\: str)) + (progn (setq trailing nil) + (list str)) + (collect ((substrings)) + (do* () + ((= i n) (substrings)) + (let* ((pos (position #\: str :start i))) + (unless pos + (break "Huh?")) + (substrings (subseq str i pos)) + (setq i (1+ pos))))))) + (split + (mapcar #'(lambda (s) + (collapse-prefix + (split-if #'(lambda (ch) + (or (upper-case-p ch) (digit-char-p ch))) + s))) + + subs)) + (namelen (+ (if trailing (length split) 0) + (let* ((c 0)) + (dolist (s split c) + (if s (incf c (1- (length s)))))) + (let* ((c 0)) + (dolist (s split c) + (dolist (sub s) + (incf c (length sub))))))) + (name (make-string namelen))) + (declare (dynamic-extent name)) + (let* ((p 0)) + (flet ((out-ch (ch) + (setf (schar name p) ch) + (incf p))) + (dolist (sub split) + (when sub + (do* ((string (pop sub) (pop sub))) + ((null string)) + (dotimes (i (length string)) + (out-ch (char-upcase (schar string i)))) + (when sub + (out-ch #\-)))) + (when trailing (out-ch *objc-colon-replacement-character*))))) + (values + (or (find-symbol name package) + (intern (copy-seq name) package)))))) + + +;;; Convert a Lisp list of keywords into an ObjC method selector string +;;; Example: (:next-event-matching-mask :until-date :in-mode :dequeue) ==> +;;; "nextEventMatchingMask:untilDate:inMode:dequeue:" + +(defun compute-lisp-to-objc-message (klist) + (flet ((objcify (sym) + (apply + #'string-cat + (loop for str in (split-if-char #\- (string sym) :elide) + for first-word-flag = t then nil + for e = (member str *special-objc-words* + :test #'equal + :key #'string-upcase) + collect + (cond (e (first e)) + (first-word-flag (string-downcase str)) + (t (string-capitalize str))))))) + (if (and (= (length klist) 1) + (neq (symbol-package (first klist)) (find-package :keyword))) + (objcify (first klist)) + (apply #'string-cat + (mapcar #'(lambda (sym) (string-cat (objcify sym) ":")) klist))))) + + +;;; Convert an ObjC initializer to a list of corresponding initargs, +;;; stripping off any initial "init" +;;; Example: "initWithCString:length:" ==> (:with-c-string :length) + +(defun compute-objc-to-lisp-init (init) + (cond + ((= (length init) 0) nil) + ((and (> (length init) 3) (string= init "init" :start1 0 :end1 4)) + (mapcar #'(lambda (s) (compute-lisp-name s (find-package "KEYWORD"))) + (split-if-char #\: (subseq init 4 (length init)) :elide))) + (t (error "~S is not a valid initializer" init)))) + + +;;; Convert a list of initargs into an ObjC initilizer, adding an "init" +;;; prefix if necessary +;;; Example: (:with-c-string :length) ==> "initWithCString:length:" + +(defun compute-lisp-to-objc-init (initargs) + (if (null initargs) + "init" + (let ((str (compute-lisp-to-objc-message initargs))) + (if (string/= (first (split-if-char #\- (string (first initargs)))) + "INIT") + (string-cat "init" (nstring-upcase str :start 0 :end 1)) + str)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Class Name Translation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Hash tables for caching class name translations + +(defvar *lisp-classname-table* (make-hash-table :test #'equal)) +(defvar *objc-classname-table* (make-hash-table :test #'eq)) + + +;;; Define a hard-wired ObjC class name translation (if the automatic +;;; translation doesn't apply) + +(defmacro define-classname-translation (str sym) + (let ((str-temp (gensym)) + (sym-temp (gensym)) + (old-str-temp (gensym)) + (old-sym-temp (gensym))) + `(let* ((,str-temp ',str) + (,sym-temp ',sym) + (,old-sym-temp (gethash ,str-temp *lisp-classname-table*)) + (,old-str-temp (gethash ,sym-temp *objc-classname-table*))) + (remhash ,old-str-temp *lisp-classname-table*) + (remhash ,old-sym-temp *objc-classname-table*) + (setf (gethash ,str-temp *lisp-classname-table*) ,sym-temp) + (setf (gethash ,sym-temp *objc-classname-table*) ,str-temp) + (values)))) + + +;;; Translate an ObjC class name to a Lisp class name + +(defun objc-to-lisp-classname (str &optional (package *package*)) + (let ((sym + (or (gethash str *lisp-classname-table*) + (compute-lisp-name str package)))) + (setf (gethash sym *objc-classname-table*) str) + (setf (gethash str *lisp-classname-table*) sym))) + + +;;; Translate a Lisp class name to an ObjC class name + +(defun lisp-to-objc-classname (sym) + (let ((str + (or (gethash sym *objc-classname-table*) + (compute-objc-classname sym)))) + (setf (gethash str *lisp-classname-table*) sym) + (setf (gethash sym *objc-classname-table*) str))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Message Keyword Translation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Hash tables for caching initializer translations + +(defvar *lisp-message-table* (make-hash-table :test #'equal)) +(defvar *objc-message-table* (make-hash-table :test #'equal)) + + +;;; Define a hard-wired message-keyword translation (if the automatic +;;; translation doesn't apply) + +(defmacro define-message-translation (message msg-keywords) + (let ((message-temp (gensym)) + (msg-keywords-temp (gensym)) + (old-message-temp (gensym)) + (old-msg-keywords-temp (gensym))) + `(let* ((,message-temp ',message) + (,msg-keywords-temp ',msg-keywords) + (,old-message-temp + (gethash ,message-temp *lisp-message-table*)) + (,old-msg-keywords-temp + (gethash ,msg-keywords-temp *objc-message-table*))) + (remhash ,old-message-temp *lisp-message-table*) + (remhash ,old-msg-keywords-temp *objc-message-table*) + (setf (gethash ,message-temp *lisp-message-table*) ,msg-keywords-temp) + (setf (gethash ,msg-keywords-temp *objc-message-table*) ,message-temp) + (values)))) + + +;;; Translate an ObjC message to a list of Lisp message keywords + +(defun objc-to-lisp-message (message) + (let ((msg-keywords + (or (gethash message *lisp-message-table*) + (compute-objc-to-lisp-message message)))) + (setf (gethash msg-keywords *objc-message-table*) message) + (setf (gethash message *lisp-message-table*) msg-keywords))) + + +;;; Translate a set of Lisp message keywords to an ObjC message + +(defun lisp-to-objc-message (msg-keywords) + (let ((message + (or (gethash msg-keywords *objc-message-table*) + (compute-lisp-to-objc-message msg-keywords)))) + (setf (gethash message *lisp-message-table*) msg-keywords) + (setf (gethash msg-keywords *objc-message-table*) message))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Initializer Translation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Hash tables for caching initializer translations + +(defvar *lisp-initializer-table* (make-hash-table :test #'equal)) +(defvar *objc-initializer-table* (make-hash-table :test #'equal)) + + +;;; Define a hard-wired init-keyword translation (if the automatic +;;; translation doesn't apply) + +(defmacro define-init-translation (initmsg initargs) + (let ((initmsg-temp (gensym)) + (initargs-temp (gensym)) + (old-initmsg-temp (gensym)) + (old-initargs-temp (gensym))) + `(let* ((,initmsg-temp ',initmsg) + (,initargs-temp ',initargs) + (,old-initmsg-temp + (gethash ,initmsg-temp *lisp-initializer-table*)) + (,old-initargs-temp + (gethash ,initargs-temp *objc-initializer-table*))) + (remhash ,old-initmsg-temp *lisp-initializer-table*) + (remhash ,old-initargs-temp *objc-initializer-table*) + (setf (gethash ,initmsg-temp *lisp-initializer-table*) ,initargs-temp) + (setf (gethash ,initargs-temp *objc-initializer-table*) ,initmsg-temp) + (values)))) + + +;;; Translate an ObjC initializer to a list of Lisp initargs + +(defun objc-to-lisp-init (initmsg) + (let ((initargs + (or (gethash initmsg *lisp-initializer-table*) + (compute-objc-to-lisp-init initmsg)))) + (setf (gethash initargs *objc-initializer-table*) initmsg) + (setf (gethash initmsg *lisp-initializer-table*) initargs))) + + +;;; Translate a set of Lisp initargs to an ObjC initializer + +(defun lisp-to-objc-init (initargs) + (let ((initmsg + (or (gethash initargs *objc-initializer-table*) + (compute-lisp-to-objc-init initargs)))) + (setf (gethash initmsg *lisp-initializer-table*) initargs) + (setf (gethash initargs *objc-initializer-table*) initmsg))) Index: /trunk/ccl/objc-bridge/objc-clos.lisp =================================================================== --- /trunk/ccl/objc-bridge/objc-clos.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/objc-clos.lisp (revision 6898) @@ -0,0 +1,918 @@ +;;;-*-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: /trunk/ccl/objc-bridge/objc-package.lisp =================================================================== --- /trunk/ccl/objc-bridge/objc-package.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/objc-package.lisp (revision 6898) @@ -0,0 +1,59 @@ +;;;-*-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: /trunk/ccl/objc-bridge/objc-readtable.lisp =================================================================== --- /trunk/ccl/objc-bridge/objc-readtable.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/objc-readtable.lisp (revision 6898) @@ -0,0 +1,65 @@ +;;;-*-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") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *objc-readtable* (copy-readtable nil)) + (set-syntax-from-char #\] #\) *objc-readtable*)) + + + +;;; We use the convention that [:super ....] denotes a send to the +;;; defining object's superclass's method, and that a return value +;;; specification of the form (:-> ... x) indicates a message send +;;; that returns a structure (by reference) via the pointer x. + +(set-macro-character + #\[ + (nfunction + |objc-[-reader| + (lambda (stream ignore) + (declare (ignore ignore)) + (let* ((tail (read-delimited-list #\] stream)) + (structptr nil)) + (unless *read-suppress* + (let* ((return (car (last tail)))) + (when (and (consp return) (eq (car return) :->)) + (rplaca (last tail) :void) + (setq structptr (car (last return))))) + (if (eq (car tail) :super) + (if structptr + `(objc-message-send-super-stret ,structptr (super) ,@(cdr tail)) + `(objc-message-send-super (super) ,@(cdr tail))) + (if structptr + `(objc-message-send-stret ,structptr ,@tail) + `(objc-message-send ,@tail))))))) + nil + *objc-readtable*) + +(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))))) + *objc-readtable*) + Index: /trunk/ccl/objc-bridge/objc-runtime.lisp =================================================================== --- /trunk/ccl/objc-bridge/objc-runtime.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/objc-runtime.lisp (revision 6898) @@ -0,0 +1,2884 @@ +;;;-*-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: /trunk/ccl/objc-bridge/objc-support.lisp =================================================================== --- /trunk/ccl/objc-bridge/objc-support.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/objc-support.lisp (revision 6898) @@ -0,0 +1,490 @@ +;;;-*-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") Index: /trunk/ccl/objc-bridge/process-objc-modules.lisp =================================================================== --- /trunk/ccl/objc-bridge/process-objc-modules.lisp (revision 6898) +++ /trunk/ccl/objc-bridge/process-objc-modules.lisp (revision 6898) @@ -0,0 +1,217 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 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") + +(#-(or apple-objc gnu-objc) + (eval-when (:compile-toplevel :load-toplevel :execute) + #+darwinppc-target (pushnew :apple-objc *features*) + #+linuxppc-target (pushnew :gnu-objc *features*) + #-(or darwinppc-target linuxppc-target) + (error "Not sure what ObjC runtime system to use."))) + +#+apple-objc +(progn +(defvar *objc-module-verbose* nil) + + +(defun process-section-in-all-libraries (segname sectionname function) + "For every loaded shared library, find the section named SECTIONNAME +in the segment named SEGNAME. If this section exists, call FUNCTION with +a pointer to the section data and the section's size in bytes as arguments." + (with-cstrs ((seg segname) + (sect sectionname)) + (rlet ((size :unsigned)) + (with-macptrs (mach-header sectdata) + (dotimes (i (#_ _dyld_image_count)) + (%setf-macptr mach-header (#_ _dyld_get_image_header i)) + ;; Paranoia: this should never be null + (unless (%null-ptr-p mach-header) + ;; The one instance of an MH_BUNDLE I've encountered + ;; hasn't had its section data relocated. I'm not sure + ;; if that's generally true of MH_BUNDLEs; for the time + ;; being, ignore them and concentrate on MH_DYLIBs. + (when (eql (pref mach-header :mach_header.filetype) #$MH_DYLIB) + (%setf-macptr sectdata (#_getsectdatafromheader + mach-header + seg + sect + size)) + ;; This pointer may be null, unless the shared object + ;; file denoted by "mach_header" contains a segment and + ;; section matching those we're looking for. + (unless (%null-ptr-p sectdata) + (funcall function sectdata (pref size :unsigned)))))))))) + +(defun process-objc-modules (f) + (process-section-in-all-libraries #$SEG_OBJC #$SECT_OBJC_MODULES f)) + +;;; A not-too-interesting test of the mechanism. +(defun show-objc-module-sections () + (process-objc-modules #'(lambda (sect size) + (format t "~& module section @~s, size = ~d" + sect size)))) + +(defun process-module-classes (module classfn) + (when *objc-module-verbose* + (format t "~& processing classes in module ~s" module) + (force-output t)) + (with-macptrs ((symtab (pref module :objc_module.symtab))) + (with-macptrs ((defsptr (pref symtab :objc_symtab.defs)) + (classptr)) + (dotimes (i (pref symtab :objc_symtab.cls_def_cnt)) + (%setf-macptr classptr (%get-ptr defsptr (* i (record-length :address)))) + (when *objc-module-verbose* + (format t "~& processing class ~a, info = #x~8,'0x" + (%get-cstring (pref classptr :objc_class.name)) + (pref classptr :objc_class.info)) + (force-output t)) + ;; process the class + (funcall classfn classptr) + ;; process the metaclass + (funcall classfn (pref classptr :objc_class.isa)))))) + +(defun process-module-categories (module catfn) + (with-macptrs ((symtab (pref module :objc_module.symtab))) + (with-macptrs ((catptr + (%inc-ptr (pref symtab :objc_symtab.defs) + (* (pref symtab :objc_symtab.cls_def_cnt) + (record-length :address))))) + (dotimes (i (pref symtab :objc_symtab.cat_def_cnt)) + (when *objc-module-verbose* + (format t "~& processing category ~s " + (%get-cstring (pref (%get-ptr catptr) + :objc_category.category_name)))) + (funcall catfn (%get-ptr catptr)) + (%incf-ptr catptr (record-length :address)))))) + + +;;; This is roughly equivalent to the inner loop in DO-OBJC-METHODS. +(defun process-methods-in-method-list (mlist class mfun) + (unless (%null-ptr-p mlist) + (with-macptrs ((method (pref mlist :objc_method_list.method_list))) + (dotimes (i (pref mlist :objc_method_list.method_count)) + (funcall mfun method class) + (%incf-ptr method (record-length :objc_method)))))) + +;;; Categories push method lists onto the "front" of the class. +;;; The methods that belong to the class are in the last method list, +;;; so we skip everything else here. +(defun process-class-methods (class methodfun) + (%stack-block ((iter 4)) + (setf (%get-ptr iter) (%null-ptr)) + (with-macptrs ((next) + (mlist )) + (loop + (%setf-macptr next (#_class_nextMethodList class iter)) + (when (%null-ptr-p next) + (process-methods-in-method-list mlist class methodfun) + (return)) + (%setf-macptr mlist next))))) + +(defun process-category-methods (category methodfun) + (with-macptrs ((classname (pref category :objc_category.class_name)) + (class (#_objc_lookUpClass classname)) + (metaclass (pref class :objc_class.isa)) + (instance-methods + (pref category :objc_category.instance_methods)) + (class-methods + (pref category :objc_category.class_methods))) + (process-methods-in-method-list instance-methods class methodfun) + (process-methods-in-method-list class-methods metaclass methodfun))) + +(defun process-module-methods (sectptr size methodfun) + "Process all modules in the ObjC module section SECTPTR, whose size +in bytes is SIZE. For each class and each category in each module, +call METHODFUN on each method defined in a class or category. The +METHODFUN will be called with a stack-allocated/mutable pointer to the +method, and a stack-allocated/mutable pointer to the method receiver's +class or metaclass object." + (when *objc-module-verbose* + (format t "~& processing classes in section ~s" sectptr) + (force-output t)) + (with-macptrs ((module sectptr)) + (let* ((nmodules (/ size (record-length :objc_module)))) + (dotimes (i nmodules) + (process-module-classes + module + #'(lambda (class) + (when *objc-module-verbose* + (format t "~& == processing class #x~8,'0x ~a, (#x~8,'0x) info = #x~8,'0x" + (%ptr-to-int class) + (%get-cstring (pref class :objc_class.name)) + (%ptr-to-int (pref class :objc_class.name)) + (pref class :objc_class.info))) + #+nope + (unless (logtest #$CLS_META (pref class :objc_class.info)) + (map-objc-class class)) + (process-class-methods class methodfun))) + (process-module-categories + module + #'(lambda (category) + (process-category-methods category methodfun))) + (%incf-ptr module (record-length :objc_module)))))) + +(defun iterate-over-module-classes (sectptr size classfn) + (when *objc-module-verbose* + (format t "~& processing classes in section ~s" sectptr) + (force-output t)) + (with-macptrs ((module sectptr)) + (let* ((nmodules (/ size (record-length :objc_module)))) + (dotimes (i nmodules) + (process-module-classes module classfn) + (%incf-ptr module (record-length :objc_module)))))) + + +(defun process-section-methods (sectptr size methodfun &optional + (section-check-fun #'true)) + "If SECTION-CHECK-FUN returns true when called with the (stack-allocated, +mutable) Objc modules section SECTPTR, process all methods defined +in all classes/categories in all modules in the section." + (when (funcall section-check-fun sectptr) + (process-module-methods sectptr size methodfun))) + +(defloadvar *sections-already-scanned-for-methods* ()) + +(defun check-if-section-already-scanned (sectptr) + (unless (member sectptr *sections-already-scanned-for-methods* + :test #'eql) + (push (%inc-ptr sectptr 0) ;make a heap-allocated copy! + *sections-already-scanned-for-methods*) + t)) + +(defun note-all-library-methods (method-function) + "For all methods defined in all classes and categories defined in all +ObjC module sections in all loaded shared libraries, call METHOD-FUNCTION +with the method and defining class as arguments. (Both of these arguments +may have been stack-allocated by the caller, and may be destructively +modified by the caller after the METHOD-FUNCTION returns.) + Sections that have already been scanned in the current lisp session are +ignored." + (process-objc-modules + #'(lambda (sectptr size) + (process-section-methods + sectptr + size + method-function + #'check-if-section-already-scanned)))) + + + + +) +(provide "PROCESS-OBJC-MODULES") +