Index: unk/ccl/examples/CocoaBridgeDoc.txt =================================================================== --- /trunk/ccl/examples/CocoaBridgeDoc.txt (revision 6894) +++ (revision ) @@ -1,289 +1,0 @@ -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: unk/ccl/examples/bridge.lisp =================================================================== --- /trunk/ccl/examples/bridge.lisp (revision 6894) +++ (revision ) @@ -1,1437 +1,0 @@ -;;;; -*- Mode: Lisp; Package: CCL -*- -;;;; bridge.lisp -;;;; -;;;; A Lisp bridge for Cocoa -;;;; -;;;; This provides: -;;;; (1) Convenient Lisp syntax for instantiating ObjC classes -;;;; (2) Convenient Lisp syntax for invoking ObjC methods -;;;; -;;;; Copyright (c) 2003 Randall D. Beer -;;;; -;;;; This software is licensed under the terms of the Lisp Lesser GNU Public -;;;; License, known as the LLGPL. The LLGPL consists of a preamble and -;;;; the LGPL. Where these conflict, the preamble takes precedence. The -;;;; LLGPL is available online at http://opensource.franz.com/preamble.html. -;;;; -;;;; Please send comments and bug reports to - -;;; Temporary package and module stuff - -(in-package "CCL") - -(require "OBJC-RUNTIME") -(require "NAME-TRANSLATION") - -#-apple-objc-2.0 -(progn - (def-foreign-type :loat :float) - (def-foreign-type :nteger :unsigned) - (def-foreign-type :nteger :signed) - ) - -(defconstant +cgfloat-zero+ - #+(and apple-objc-2.0 64-bit-target) 0.0d0 - #-(and apple-objc-2.0 64-bit-target) 0.0f0) - -(deftype cgfloat () - #+(and apple-objc-2.0 64-bit-target) 'double-float - #-(and apple-objc-2.0 64-bit-target) 'single-float) - -(deftype cg-float () 'cgfloat) - -(deftype nsuinteger () - #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64) - #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32)) - -(deftype nsinteger () - #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64) - #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32)) - -;;; Used in PRINT-OBJECT methods. - -(defun describe-macptr-allocation-and-address (p stream) - (format stream " ~@[~a ~](#x~x)" - (%macptr-allocation-string p) - (%ptr-to-int p))) - -(defstruct typed-foreign-struct-info - foreign-type - lisp-class-name - initializer - constructor - with-form-name - predicate-name) - -(defparameter *typed-foreign-struct-info* ()) - -(defun note-typed-foreign-struct-info (foreign-type lisp-class-name initializer constructor with-form-name predicate-name) - (let* ((info (find foreign-type *typed-foreign-struct-info* :test #'equal :key #'typed-foreign-struct-info-foreign-type))) - (unless info - (setq info (make-typed-foreign-struct-info :foreign-type foreign-type)) - (push info *typed-foreign-struct-info*)) - (setf (typed-foreign-struct-info-lisp-class-name info) lisp-class-name - (typed-foreign-struct-info-initializer info) initializer - (typed-foreign-struct-info-constructor info) constructor - (typed-foreign-struct-info-with-form-name info) with-form-name - (typed-foreign-struct-info-predicate-name info) predicate-name) - info)) - -;;; This gets installed as the COMPILER-MACRO-FUNCTION on any dispatch -;;; function associated with a method that passes structures by value. -(defun hoist-struct-constructors (whole env) - (declare (ignorable env)) - (destructuring-bind (operator receiver &rest args) whole - ;;See if any arguments are "obviously" known structure-creation forms. - (if (null (dolist (arg args) - (if (and (consp arg) - (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)) - (return t)))) - whole - ;;; Simplest to hoist one call, then let compiler-macroexpand - ;;; call us again. - (let* ((with-name nil) - (info nil) - (temp (gensym))) - (collect ((new-args)) - (new-args operator) - (new-args receiver) - (dolist (arg args) - (if (or info - (atom arg) - (not (setq info (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)))) - (new-args arg) - (progn - (setq with-name (typed-foreign-struct-info-with-form-name info)) - (if (cdr arg) - (new-args `(progn (,(typed-foreign-struct-info-initializer info) - ,temp - ,@(cdr arg)) - ,temp)) - (new-args temp))))) - `(,with-name (,temp) - (values ,(new-args)))))))) - - - -(defun define-typed-foreign-struct-accessor (type-name lisp-accessor-name foreign-accessor &optional (transform-output #'identity) (transform-input #'identity)) - (let* ((arg (gensym)) - (val (gensym))) - `(progn - (declaim (inline ,lisp-accessor-name)) - (defun ,lisp-accessor-name (,arg) - (if (typep ,arg ',type-name) - ,(funcall transform-input `(pref ,arg ,foreign-accessor)) - (report-bad-arg ,arg ',type-name))) - (declaim (inline (setf ,lisp-accessor-name))) - (defun (setf ,lisp-accessor-name) (,val ,arg) - (if (typep ,arg ',type-name) - (setf (pref ,arg ,foreign-accessor) ,(funcall transform-output val)) - (report-bad-arg ,arg ',type-name)))))) - -(defun define-typed-foreign-struct-accessors (type-name tuples) - (collect ((body)) - (dolist (tuple tuples `(progn ,@(body))) - (body (apply #'define-typed-foreign-struct-accessor type-name (cdr tuple)))))) - -(defun define-typed-foreign-struct-initializer (init-function-name tuples) - (when init-function-name - (let* ((struct (gensym))) - (collect ((initforms) - (args)) - (args struct) - (dolist (tuple tuples) - (destructuring-bind (arg-name lisp-accessor foreign-accessor &optional (transform #'identity)) tuple - (declare (ignore lisp-accessor)) - (args arg-name) - (initforms `(setf (pref ,struct ,foreign-accessor) ,(funcall transform arg-name))))) - `(progn - (declaim (inline ,init-function-name)) - (defun ,init-function-name ,(args) - (declare (ignorable ,struct)) - ,@(initforms) - ,struct)))))) - -(defun define-typed-foreign-struct-creation-function (creation-function-name init-function-name foreign-type accessors) - (when creation-function-name - (let* ((struct (gensym)) - (arg-names (mapcar #'car accessors))) - `(defun ,creation-function-name ,arg-names - (let* ((,struct (make-gcable-record ,foreign-type))) - (,init-function-name ,struct ,@arg-names) - ,struct))))) - -(defun define-typed-foreign-struct-class-with-form (with-form-name foreign-type init-function-name) - (declare (ignorable init-function-name)) - (when with-form-name - `(defmacro ,with-form-name ((instance &rest inits) &body body) - (multiple-value-bind (body decls) (parse-body body nil) - `(rlet ((,instance ,,foreign-type)) - ,@decls - ,@(when inits - `((,',init-function-name ,instance ,@inits))) - ,@body))))) - - -(defmacro define-typed-foreign-struct-class (class-name (foreign-type predicate-name init-function-name creation-function-name with-form-name) &rest accessors) - (let* ((arg (gensym))) - `(progn - (%register-type-ordinal-class (parse-foreign-type ',foreign-type) ',class-name) - (def-foreign-type ,class-name ,foreign-type) - (declaim (inline ,predicate-name)) - (note-typed-foreign-struct-info ',foreign-type ',class-name ',init-function-name ',creation-function-name ',with-form-name ',predicate-name) - (defun ,predicate-name (,arg) - (and (typep ,arg 'macptr) - (<= (the fixnum (%macptr-domain ,arg)) 1) - (= (the fixnum (%macptr-type ,arg)) - (foreign-type-ordinal (load-time-value (parse-foreign-type ',foreign-type)))))) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (type-predicate ',class-name) ',predicate-name)) - ,(define-typed-foreign-struct-initializer init-function-name accessors) - ,(define-typed-foreign-struct-creation-function creation-function-name init-function-name foreign-type accessors) - ,(define-typed-foreign-struct-class-with-form with-form-name foreign-type init-function-name) - ,(define-typed-foreign-struct-accessors class-name accessors) - ',class-name))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun wrap-cg-float (x) - `(float ,x +cgfloat-zero+))) - - - -;;; AEDesc (Apple Event Descriptor) - -(define-typed-foreign-struct-class ns::aedesc (:esc ns::aedesc-p ns::init-aedesc ns::make-aedesc ns::with-aedesc) - (descriptor-type ns::aedesc-descriptor-type :esc.descriptorype) - (data-handle ns::aedesc-data-handle :esc.dataandle)) - - -(defmethod print-object ((a ns::aedesc) stream) - (print-unreadable-object (a stream :type t :identity (%gcable-ptr-p a)) - (format stream "~s ~s" - (ns::aedesc-descriptor-type a) - (ns::aedesc-data-handle a)) - (describe-macptr-allocation-and-address a stream))) - -;;; It's not clear how useful this would be; I think that it's -;;; part of the ObjC 2.0 extensible iteration stuff ("foreach"). -#+apple-objc-2.0 -(define-typed-foreign-struct-class ns::ns-fast-enumeration-state (:astnumerationtate ns::ns-fast-enumeration-state-p ns::init-ns-fast-enumeration-state ns::make-ns-fast-enumeration-state ns::with-ns-fast-enumeration-state)) - -;;; NSAffineTransformStruct CGAffineTransform -(define-typed-foreign-struct-class ns::ns-affine-transform-struct (:ffineransformtruct ns::ns-affine-transform-struct-p ns::init-ns-affine-transform-struct ns::make-ns-affine-transform-struct ns::wint-ns-affine-transform-struct) - (m11 ns::ns-affine-transform-struct-m11 :ffineransformtruct.m11 wrap-cg-float) - (m12 ns::ns-affine-transform-struct-m12 :ffineransformtruct.m12 wrap-cg-float) - (m21 ns::ns-affine-transform-struct-m21 :ffineransformtruct.m21 wrap-cg-float) - (m22 ns::ns-affine-transform-struct-m22 :ffineransformtruct.m22 wrap-cg-float) - (tx ns::ns-affine-transform-struct-tx :ffineransformtruct.t wrap-cg-float) - (ty ns::ns-affine-transform-struct-ty :ffineransformtruct.t wrap-cg-float)) - - -(defmethod print-object ((transform ns::ns-affine-transform-struct) stream) - (print-unreadable-object (transform stream :type t :identity t) - (format stream "~s ~s ~s ~s ~s ~s" - (ns::ns-affine-transform-struct-m11 transform) - (ns::ns-affine-transform-struct-m12 transform) - (ns::ns-affine-transform-struct-m21 transform) - (ns::ns-affine-transform-struct-m22 transform) - (ns::ns-affine-transform-struct-tx transform) - (ns::ns-affine-transform-struct-ty transform)) - (describe-macptr-allocation-and-address transform stream))) - - - - - -;;; An ffineransformtruct is identical to a -;;; (:struct :ffineransform), except for the names of its fields. - -(setf (foreign-type-ordinal (parse-foreign-type '(:struct :ffineransform))) - (foreign-type-ordinal (parse-foreign-type :ffineransformtruct))) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun unwrap-boolean (form) - `(not (eql 0 ,form))) - (defun wrap-boolean (form) - `(if ,form 1 0))) - - -;;; NSDecimal -(define-typed-foreign-struct-class ns::ns-decimal (:ecimal ns::ns-decimal-p nil nil nil) - (nil ns::ns-decimal-exponent :ecimal._exponent) - (nil ns::ns-decimal-length :ecimal._length) - (nil ns::ns-decimal-is-negative :ecimal._isegative wrap-boolean unwrap-boolean) - (nil ns::ns-decimal-is-compact :ecimal._isompact wrap-boolean unwrap-boolean)) - - -(defun ns::init-ns-decimal (data exponent length is-negative is-compact mantissa) - (setf (pref data :ecimal._exponent) exponent - (pref data :ecimal._length) length - (pref data :ecimal._isegative) (if is-negative 1 0) - (pref data :ecimal._isompact) (if is-compact 1 0)) - (let* ((v (coerce mantissa '(vector (unsigned-byte 16) 8)))) - (declare (type (simple-array (unsigned-byte 16) (8)) v)) - (with-macptrs ((m (pref data :ecimal._mantissa))) - (dotimes (i 8) - (setf (paref m (:* (:unsigned 16)) i) (aref v i)))))) - -(defun ns::make-ns-decimal (exponent length is-negative is-compact mantissa) - (let* ((data (make-gcable-record :ecimal))) - (ns::init-ns-decimal data exponent length is-negative is-compact mantissa) - data)) - - - - -(defun ns::ns-decimal-mantissa (decimal) - (if (typep decimal 'ns::ns-decimal) - (let* ((dest (make-array 8 :element-type '(unsigned-byte 16)))) - (with-macptrs ((m (pref decimal :ecimal._mantissa))) - (dotimes (i 8 dest) - (setf (aref dest i) (paref m (:* (:unsigned 16)) i))))) - (report-bad-arg decimal 'ns::ns-decimal))) - -(defun (setf ns::ns-decimal-mantissa) (new decimal) - (if (typep decimal 'ns::ns-decimal) - (let* ((src (coerce new '(simple-array (unsigned-byte 16) (8))))) - (declare (type (simple-array (unsigned-byte 16) 8) src)) - (with-macptrs ((m (pref decimal :ecimal._mantissa))) - (dotimes (i 8 new) - (setf (paref m (:* (:unsigned 16)) i) (aref src i))))) - (report-bad-arg decimal 'ns::ns-decimal))) - -(defmethod print-object ((d ns::ns-decimal) stream) - (print-unreadable-object (d stream :type t :identity t) - (format stream "exponent = ~d, length = ~s, is-negative = ~s, is-compact = ~s, mantissa = ~s" (ns::ns-decimal-exponent d) (ns::ns-decimal-length d) (ns::ns-decimal-is-negative d) (ns::ns-decimal-is-compact d) (ns::ns-decimal-mantissa d)) - (describe-macptr-allocation-and-address d stream))) - - - - -;;; NSRect - -(define-typed-foreign-struct-class ns::ns-rect (:ect ns::ns-rect-p ns::init-ns-rect ns::make-ns-rect ns::with-ns-rect) - (x ns::ns-rect-x :ect.origin.x wrap-cg-float) - (y ns::ns-rect-y :ect.origin.y wrap-cg-float) - (width ns::ns-rect-width :ect.size.width wrap-cg-float) - (height ns::ns-rect-height :ect.size.height wrap-cg-float)) - - -(defmethod print-object ((r ns::ns-rect) stream) - (print-unreadable-object (r stream :type t :identity t) - (flet ((maybe-round (x) - (multiple-value-bind (q r) (round x) - (if (zerop r) q x)))) - (format stream "~s X ~s @ ~s,~s" - (maybe-round (ns::ns-rect-width r)) - (maybe-round (ns::ns-rect-height r)) - (maybe-round (ns::ns-rect-x r)) - (maybe-round (ns::ns-rect-y r))) - (describe-macptr-allocation-and-address r stream)))) - - - -;;; NSSize -(define-typed-foreign-struct-class ns::ns-size (:ize ns::ns-size-p ns::init-ns-size ns::make-ns-size ns::with-ns-size) - (width ns::ns-size-width :ize.width wrap-cg-float) - (height ns::ns-size-height :ize.height wrap-cg-float)) - - -(defmethod print-object ((s ns::ns-size) stream) - (flet ((maybe-round (x) - (multiple-value-bind (q r) (round x) - (if (zerop r) q x)))) - (print-unreadable-object (s stream :type t :identity t) - (format stream "~s X ~s" - (maybe-round (ns::ns-size-width s)) - (maybe-round (ns::ns-size-height s))) - (describe-macptr-allocation-and-address s stream)))) - - -;;; NSPoint -(define-typed-foreign-struct-class ns::ns-point (:oint ns::ns-point-p ns::init-ns-point ns::make-ns-point ns::with-ns-point) - (x ns::ns-point-x :oint.x wrap-cg-float) - (y ns::ns-point-y :oint.y wrap-cg-float)) - -(defmethod print-object ((p ns::ns-point) stream) - (flet ((maybe-round (x) - (multiple-value-bind (q r) (round x) - (if (zerop r) q x)))) - (print-unreadable-object (p stream :type t :identity t) - (format stream "~s,~s" - (maybe-round (ns::ns-point-x p)) - (maybe-round (ns::ns-point-y p))) - (describe-macptr-allocation-and-address p stream)))) - - -;;; NSRange -(define-typed-foreign-struct-class ns::ns-range (:ange ns::ns-range-p ns::init-ns-range ns::make-ns-range ns::with-ns-range) - (location ns::ns-range-location :ange.location) - (length ns::ns-range-length :ange.length )) - -(defmethod print-object ((r ns::ns-range) stream) - (print-unreadable-object (r stream :type t :identity t) - (format stream "~s/~s" - (ns::ns-range-location r) - (ns::ns-range-length r)) - (describe-macptr-allocation-and-address r stream))) - - -;;; String might be stack allocated; make a copy before complaining -;;; about it. -(defun check-objc-message-name (string) - (dotimes (i (length string)) - (let* ((ch (char string i))) - (unless (or (alpha-char-p ch) - (digit-char-p ch 10) - (eql ch #\:) - (eql ch #\_)) - (error "Illegal character ~s in ObjC message name ~s" - ch (copy-seq string))))) - (when (and (position #\: string) - (not (eql (char string (1- (length string))) #\:))) - (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string)))) - - -(setf (pkg.intern-hook (find-package "NSFUN")) - 'get-objc-message-info) - -(set-dispatch-macro-character #\# #\/ - (lambda (stream subchar numarg) - (declare (ignorable subchar numarg)) - (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t)) - (attrtab (rdtab.ttab *readtable*))) - (when (peek-char t stream nil nil) - (loop - (multiple-value-bind (char attr) - (%next-char-and-attr stream attrtab) - (unless (eql attr $cht_cnst) - (when char (unread-char char stream)) - (return)) - (vector-push-extend char token)))) - (unless *read-suppress* - (unless (> (length token) 0) - (signal-reader-error stream "Invalid token after #/.")) - (check-objc-message-name token) - (intern token "NSFUN"))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Utilities ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Return separate lists of the keys and values in a keyword/value list - -(defun keys-and-vals (klist) - (when (oddp (length klist)) - (error "Invalid keyword/value list: ~S" klist)) - (loop for l = klist then (cddr l) - until (null l) - collect (first l) into keys - collect (second l) into vals - finally (return (values keys vals)))) - - -;;; Return the typestring for an ObjC METHOD - -(defun method-typestring (method) - (%get-cstring #+apple-objc-2.0 - (#_method_getTypeEncoding method) - #-apple-objc-2.0 - (pref method :objc_method.method_types))) - - -;;; Parse the ObjC message from a SENDxxx macro - -(defun parse-message (args) - (let ((f (first args)) - (nargs (length args))) - (cond ((or (= nargs 1) (= nargs 2)) - ;; (THING {VARGS}) - (if (constantp f) - (%parse-message (cons (eval f) (rest args))) - (values f (rest args) nil))) - ;; (THING1 ARG1 ... THINGN ARGN) - ((evenp nargs) - (multiple-value-bind (ks vs) (keys-and-vals args) - (if (every #'constantp ks) - (%parse-message (mapcan #'list (mapcar #'eval ks) vs)) - (values f (rest args) nil)))) - ;; (THING1 ARG1 ... THINGN ARGN VARGS) - (t (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) - (if (every #'constantp ks) - (%parse-message - (nconc (mapcan #'list (mapcar #'eval ks) vs) (last args))) - (values f (rest args) nil))))))) - - -;;; Parse the ObjC message from the evaluated args of a %SENDxxx function - -(defun %parse-message (args) - (let ((f (first args)) - (l (first (last args)))) - (cond ((stringp f) - ;; (STRING-with-N-colons ARG1 ... ARGN {LIST}) - (let* ((n (count #\: (the simple-string f))) - (message-info (need-objc-message-info f)) - (args (rest args)) - (nargs (length args))) - (cond ((and (= nargs 1) - (getf (objc-message-info-flags message-info) - :accepts-varargs)) - (values f nil l)) - ((= nargs n) (values f args nil)) - ((= nargs (1+ n)) (values f (butlast args) l)) - (t (error "Improperly formatted argument list: ~S" args))))) - ((keywordp f) - ;; (KEY1 ARG1 ... KEYN ARGN {LIST}) or (KEY LIST) - (let ((nargs (length args))) - (cond ((and (= nargs 2) (consp l) - (let* ((info (need-objc-message-info - (lisp-to-objc-message (list f))))) - (getf (objc-message-info-flags info) - :accepts-varargs))) - (values (lisp-to-objc-message (list f)) nil l)) - ((evenp nargs) - (multiple-value-bind (ks vs) (keys-and-vals args) - (values (lisp-to-objc-message ks) vs nil))) - ((and (> nargs 1) (listp l)) - (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) - (values (lisp-to-objc-message ks) vs l))) - (t (error "Improperly formatted argument list: ~S" args))))) - ((symbolp f) - ;; (SYMBOL {LIST}) - (let ((nargs (length (rest args)))) - (cond ((= nargs 0) (values (lisp-to-objc-message (list f)) nil nil)) - ((= nargs 1) (values (lisp-to-objc-message (list f)) nil l)) - (t (error "Improperly formatted argument list: ~S" args))))) - (t (error "Improperly formatted argument list: ~S" args))))) - - -;;; Return the declared type of FORM in ENV - -(defun declared-type (form env) - (cond ((symbolp form) - (multiple-value-bind (ignore ignore decls) - (variable-information form env) - (declare (ignore ignore)) - (or (cdr (assoc 'type decls)) t))) - ((and (consp form) (eq (first form) 'the)) - (second form)) - (t t))) - - -;;; Return the current optimization setting of KEY in ENV - -(defun optimization-setting (key &optional env) - (cadr (assoc key (declaration-information 'optimize env)))) - - -;;; Return the ObjC class named CNAME - -(defun find-objc-class (cname) - (%objc-class-classptr - (if (symbolp cname) - (find-class cname) - (load-objc-class-descriptor cname)))) - - -;;; Return the class object of an ObjC object O, signalling an error -;;; if O is not an ObjC object - -(defun objc-class-of (o) - (if (objc-object-p o) - (class-of o) - (progn - #+debug - (#_NSLog #@"class name = %s" :address (pref (pref o :objc_object.isa) - :objc_class.name)) - (error "~S is not an ObjC object" o)))) - - -;;; Returns the ObjC class corresponding to the declared type OTYPE if -;;; possible, NIL otherwise - -(defun get-objc-class-from-declaration (otype) - (cond ((symbolp otype) (lookup-objc-class (lisp-to-objc-classname otype))) - ((and (consp otype) (eq (first otype) '@metaclass)) - (let* ((name (second otype)) - (c - (typecase name - (string (lookup-objc-class name)) - (symbol (lookup-objc-class (lisp-to-objc-classname name))) - (t (error "Improper metaclass typespec: ~S" otype))))) - (unless (null c) (objc-class-of c)))))) - - -;;; Returns the selector of MSG - -(defun get-selector (msg) - (%get-selector (load-objc-selector msg))) - - -;;; Get the instance method structure corresponding to SEL for CLASS - -(defun get-method (class sel) - (let ((m (class-get-instance-method class sel))) - (if (%null-ptr-p m) - (error "Instances of ObjC class ~S cannot respond to the message ~S" - (objc-class-name class) - (lisp-string-from-sel sel)) - m))) - - -;;; Get the class method structure corresponding to SEL for CLASS - -(defun get-class-method (class sel) - (let ((m (class-get-class-method class sel))) - (if (%null-ptr-p m) - (error "ObjC class ~S cannot respond to the message ~S" - (objc-class-name class) - (lisp-string-from-sel sel)) - m))) - - -;;; For some reason, these types sometimes show up as :STRUCTs even though they -;;; are not structure tags, but type names - -(defun fudge-objc-type (ftype) - (if (equal ftype '(:STRUCT :ecimal)) - :ecimal - ftype)) - - -;;; Returns T if the result spec requires a STRET for its return, NIL otherwise -;;; RSPEC may be either a number (in which case it is interpreted as a number -;;; of words) or a foreign type spec acceptable to PARSE-FOREIGN-TYPE. STRETS -;;; must be used when a structure larger than 4 bytes is returned - -(defun requires-stret-p (rspec) - (when (member rspec '(:DOUBLE-FLOAT :UNSIGNED-DOUBLEWORD :SIGNED-DOUBLEWORD) - :test #'eq) - (return-from requires-stret-p nil)) - (setq rspec (fudge-objc-type rspec)) - (if (numberp rspec) - (> rspec 1) - (> (ensure-foreign-type-bits (parse-foreign-type rspec)) target::nbits-in-word))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Stret Convenience Stuff ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Allocate any temporary storage necessary to hold strets required -;;; AT TOPLEVEL in the value forms. Special recognition is given to -;;; SENDs involving strets and to stret pseudo-functions -;;; NS-MAKE-POINT, NS-MAKE-RANGE, NS-MAKE-RECT and NS-MAKE-SIZE - -(defmacro slet (varforms &body body &environment env) - (multiple-value-bind (clean-body decls) (parse-body body env nil) - (loop with r and s - for (var val) in varforms - do (multiple-value-setq (r s) (sletify val t var)) - collect r into rvarforms - unless (null s) collect s into stretforms - finally - (return - `(rlet ,rvarforms - ,@decls - ,@stretforms - ,@clean-body))))) - - -;;; Note that SLET* does not allow declarations - -(defmacro slet* (varforms &body body &environment env) - (if (= (length varforms) 1) - `(slet ,varforms ,@body) - `(slet ,(list (first varforms)) - (slet* ,(rest varforms) ,@body)))) - - -;;; Collect the info necessary to transform a SLET into an RLET - -(defun sletify (form &optional errorp (var (gensym))) - (if (listp form) - (case (first form) - (ns-make-point - (assert (= (length form) 3)) - `(,var :oint :x ,(second form) :y ,(third form))) - (ns-make-rect - (assert (= (length form) 5)) - `(,var :ect :origin.x ,(second form) :origin.y ,(third form) - :size.width ,(fourth form) :size.height ,(fifth form))) - (ns-make-range - (assert (= (length form) 3)) - `(,var :ange :location ,(second form) :length ,(third form))) - (ns-make-size - (assert (= (length form) 3)) - `(,var :ize :width ,(second form) :height ,(third form))) - (send - (let* ((info (get-objc-message-info (parse-message (cddr form))))) - (if (null info) - (error "Can't determine message being sent in ~s" form)) - (let* ((rtype (objc-method-info-result-type - (car (objc-message-info-methods info))))) - (if (getf (objc-message-info-flags info) :returns-structure) - (values `(,var ,(if (typep rtype 'foreign-type) - (unparse-foreign-type rtype) - rtype)) - `(send/stret ,var ,@(rest form))) - (if errorp - (error "NonSTRET SEND in ~S" form) - form))))) - (send-super - (let* ((info (get-objc-message-info (parse-message (cddr form))))) - (if (null info) - (error "Can't determine message being sent in ~s" form)) - (let* ((rtype (objc-method-info-result-type - (car (objc-message-info-methods info))))) - (if (getf (objc-message-info-flags info) :returns-structure) - (values `(,var ,(if (typep rtype 'foreign-type) - (unparse-foreign-type rtype) - rtype)) - `(send-super/stret ,var ,@(rest form))) - (if errorp - (error "NonSTRET SEND-SUPER in ~S" form) - form))))) - (t (if errorp - (error "Unrecognized STRET call in ~S" form) - form))) - (if errorp - (error "Unrecognized STRET call in ~S" form) - form))) - - -;;; Process the arguments to a message send as an implicit SLET, collecting -;;; the info necessary to build the corresponding RLET - -(defun sletify-message-args (args) - (loop with svf and sif - for a in args - do (multiple-value-setq (svf sif) (sletify a)) - unless (null sif) collect sif into sifs - unless (equal svf a) - do (setf a (first svf)) - and collect svf into svfs - collect a into nargs - finally (return (values nargs svfs sifs)))) - - -;;; Convenience macros for some common Cocoa structures. More -;;; could be added - -(defmacro ns-max-range (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (+ (pref ,rtemp :ange.location) (pref ,rtemp :ange.length))))) -(defmacro ns-min-x (r) `(pref ,r :ect.origin.x)) -(defmacro ns-min-y (r) `(pref ,r :ect.origin.y)) -(defmacro ns-max-x (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (+ (pref ,r :ect.origin.x) - (pref ,r :ect.size.width))))) -(defmacro ns-max-y (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (+ (pref ,r :ect.origin.y) - (pref ,r :ect.size.height))))) -(defmacro ns-mid-x (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (* 0.5 (+ (ns-min-x ,rtemp) (ns-max-x ,rtemp)))))) -(defmacro ns-mid-y (r) - (let ((rtemp (gensym))) - `(let ((,rtemp ,r)) - (* 0.5 (+ (ns-min-y ,rtemp) (ns-max-y ,rtemp)))))) -(defmacro ns-height (r) `(pref ,r :ect.size.height)) -(defmacro ns-width (r) `(pref ,r :ect.size.width)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Type Stuff ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - -(defvar *objc-message-info* (make-hash-table :test #'equal :size 500)) - -(defun result-type-requires-structure-return (result-type) - ;; Use objc-msg-send-stret for all methods that return - ;; record types. - (or (typep result-type 'foreign-record-type) - (and (not (typep result-type 'foreign-type)) - (typep (parse-foreign-type result-type) 'foreign-record-type)))) - -(defvar *objc-method-signatures* (make-hash-table :test #'equal)) - -(defstruct objc-method-signature-info - type-signature - function - super-function) - -(defun objc-method-signature-info (sig) - (or (gethash sig *objc-method-signatures*) - (setf (gethash sig *objc-method-signatures*) - (make-objc-method-signature-info :type-signature sig)))) - -(defun concise-foreign-type (ftype) - (if (typep ftype 'foreign-record-type) - (let* ((name (foreign-record-type-name ftype))) - (if name - `(,(foreign-record-type-kind ftype) ,name) - (unparse-foreign-type ftype))) - (if (objc-id-type-p ftype) - :id - (if (typep ftype 'foreign-pointer-type) - (let* ((to (foreign-pointer-type-to ftype))) - (if (null to) - '(:* :void) - `(:* ,(concise-foreign-type to)))) - (if (typep ftype 'foreign-type) - (unparse-foreign-type ftype) - ftype))))) - - -;;; Not a perfect mechanism. -(defclass objc-dispatch-function (funcallable-standard-object) - () - (:metaclass funcallable-standard-class)) - -(defmethod print-object ((o objc-dispatch-function) stream) - (print-unreadable-object (o stream :type t :identity t) - (let* ((name (function-name o))) - (when name - (format stream "~s" name))))) - - - - -(declaim (inline check-receiver)) - -;;; Return a NULL pointer if RECEIVER is a null pointer. -;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL. -(defun check-receiver (receiver) - (if (%null-ptr-p receiver) - (%null-ptr) - (let* ((domain (%macptr-domain receiver)) - (valid (eql domain *objc-object-domain*))) - (declare (fixnum domain)) - (when (zerop domain) - (if (recognize-objc-object receiver) - (progn (%set-macptr-domain receiver *objc-object-domain*) - (setq valid t)))) - (unless valid - (report-bad-arg receiver 'objc:objc-object))))) - -(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys) - (declare (ignore slot-names)) - (if message-info - (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous)) - (selector (objc-message-info-selector message-info)) - (first-method (car (objc-message-info-methods message-info)))) - (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info)) - $lfbits-numreq - (logior (ash - (if (getf (objc-message-info-flags message-info) - :accepts-varargs) - 1 - 0) - $lfbits-rest-bit) - (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit))))) - (flet ((signature-function-for-method (m) - (let* ((signature-info (objc-method-info-signature-info m))) - (or (objc-method-signature-info-function signature-info) - (setf (objc-method-signature-info-function signature-info) - (compile-send-function-for-signature - (objc-method-signature-info-type-signature signature-info))))))) - - (if (null ambiguous-methods) - ;; Pick an arbitrary method, since all methods have the same - ;; signature. - (let* ((function (signature-function-for-method first-method))) - (set-funcallable-instance-function - gf - (nfunction - send-unambiguous-message - (lambda (receiver &rest args) - (declare (dynamic-extent args)) - (or (check-receiver receiver) - (with-ns-exceptions-as-errors - (apply function receiver selector args))))))) - (let* ((protocol-pairs (mapcar #'(lambda (pm) - (cons (lookup-objc-protocol - (objc-method-info-class-name pm)) - (signature-function-for-method - pm))) - (objc-message-info-protocol-methods message-info))) - (method-pairs (mapcar #'(lambda (group) - (cons (mapcar #'(lambda (m) - (get-objc-method-info-class m)) - group) - (signature-function-for-method (car group)))) - (objc-message-info-ambiguous-methods message-info))) - (default-function (if method-pairs - (prog1 (cdar (last method-pairs)) - (setq method-pairs (nbutlast method-pairs))) - (prog1 (cdr (last protocol-pairs)) - (setq protocol-pairs (nbutlast protocol-pairs)))))) - (set-funcallable-instance-function - gf - (nfunction - send-unambiguous-message - (lambda (receiver &rest args) - (declare (dynamic-extent args)) - (or (check-receiver receiver) - (let* ((function - (or (dolist (pair protocol-pairs) - (when (conforms-to-protocol receiver (car pair)) - (return (cdr pair)))) - (block m - (dolist (pair method-pairs default-function) - (dolist (class (car pair)) - (when (typep receiver class) - (return-from m (cdr pair))))))))) - (with-ns-exceptions-as-errors - (apply function receiver selector args))))))))))) - (with-slots (name) gf - (set-funcallable-instance-function - gf - #'(lambda (&rest args) - (error "Unknown ObjC message ~a called with arguments ~s" - (symbol-name name) args)))))) - - -(defun %call-next-objc-method (self class selector sig &rest args) - (declare (dynamic-extent args)) - (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self - #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class - #+apple-objc-2.0 (#_class_getSuperclass class) - #-apple-objc-2.0 (pref class :objc_class.super_class))) - (let* ((siginfo (objc-method-signature-info sig)) - (function (or (objc-method-signature-info-super-function siginfo) - (setf (objc-method-signature-info-super-function siginfo) - (%compile-send-function-for-signature sig t))))) - (with-ns-exceptions-as-errors - (apply function s selector args))))) - - -(defun %call-next-objc-class-method (self class selector sig &rest args) - (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self - #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class - #+apple-objc-2.0 (#_class_getSuperclass (pref class :objc_class.isa)) - #-apple-objc-2.0 (pref (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) :objc_class.super_class))) - (let* ((siginfo (objc-method-signature-info sig)) - (function (or (objc-method-signature-info-super-function siginfo) - (setf (objc-method-signature-info-super-function siginfo) - (%compile-send-function-for-signature sig t))))) - (with-ns-exceptions-as-errors - (apply function s selector args))))) - -(defun postprocess-objc-message-info (message-info) - (let* ((objc-name (objc-message-info-message-name message-info)) - (lisp-name (or (objc-message-info-lisp-name message-info) - (setf (objc-message-info-lisp-name message-info) - (compute-objc-to-lisp-function-name objc-name)))) - (gf (or (fboundp lisp-name) - (setf (fdefinition lisp-name) - (make-instance 'objc-dispatch-function :name lisp-name))))) - - (unless (objc-message-info-selector message-info) - (setf (objc-message-info-selector message-info) - (ensure-objc-selector (objc-message-info-message-name message-info)))) - - (flet ((reduce-to-ffi-type (ftype) - (concise-foreign-type ftype))) - (flet ((ensure-method-signature (m) - (or (objc-method-info-signature m) - (setf (objc-method-info-signature m) - (let* ((sig - (cons (reduce-to-ffi-type - (objc-method-info-result-type m)) - (mapcar #'reduce-to-ffi-type - (objc-method-info-arglist m))))) - (setf (objc-method-info-signature-info m) - (objc-method-signature-info sig)) - sig))))) - (let* ((methods (objc-message-info-methods message-info)) - (signatures ()) - (protocol-methods) - (signature-alist ())) - (labels ((signatures-equal (xs ys) - (and xs - ys - (do* ((xs xs (cdr xs)) - (ys ys (cdr ys))) - ((null xs) (null ys)) - (unless (foreign-type-= (ensure-foreign-type (car xs)) - (ensure-foreign-type (car ys))) - (return nil)))))) - (dolist (m methods) - (let* ((signature (ensure-method-signature m))) - (pushnew signature signatures :test #'signatures-equal) - (if (getf (objc-method-info-flags m) :protocol) - (push m protocol-methods) - (let* ((pair (assoc signature signature-alist :test #'signatures-equal))) - (if pair - (push m (cdr pair)) - (push (cons signature (list m)) signature-alist))))))) - (setf (objc-message-info-ambiguous-methods message-info) - (mapcar #'cdr - (sort signature-alist - #'(lambda (x y) - (< (length (cdr x)) - (length (cdr y))))))) - (setf (objc-message-info-flags message-info) nil) - (setf (objc-message-info-protocol-methods message-info) - protocol-methods) - (when (cdr signatures) - (setf (getf (objc-message-info-flags message-info) :ambiguous) t)) - (let* ((first-method (car methods)) - (first-sig (objc-method-info-signature first-method)) - (first-sig-len (length first-sig))) - (setf (objc-message-info-req-args message-info) - (1- first-sig-len)) - ;; Whether some arg/result types vary or not, we want to insist - ;; on (a) either no methods take a variable number of arguments, - ;; or all do, and (b) either no method uses structure-return - ;; conventions, or all do. (It's not clear that these restrictions - ;; are entirely reasonable in the long run; in the short term, - ;; they'll help get things working.) - (flet ((method-returns-structure (m) - (result-type-requires-structure-return - (objc-method-info-result-type m))) - (method-accepts-varargs (m) - (eq (car (last (objc-method-info-arglist m))) - *void-foreign-type*)) - (method-has-structure-arg (m) - (dolist (arg (objc-method-info-arglist m)) - (when (typep (ensure-foreign-type arg) 'foreign-record-type) - (return t))))) - (when (dolist (method methods) - (when (method-has-structure-arg method) - (return t))) - (setf (compiler-macro-function lisp-name) - 'hoist-struct-constructors)) - (let* ((first-result-is-structure (method-returns-structure first-method)) - (first-accepts-varargs (method-accepts-varargs first-method))) - (if (dolist (m (cdr methods) t) - (unless (eq (method-returns-structure m) - first-result-is-structure) - (return nil))) - (if first-result-is-structure - (setf (getf (objc-message-info-flags message-info) - :returns-structure) t))) - (if (dolist (m (cdr methods) t) - (unless (eq (method-accepts-varargs m) - first-accepts-varargs) - (return nil))) - (if first-accepts-varargs - (progn - (setf (getf (objc-message-info-flags message-info) - :accepts-varargs) t) - (decf (objc-message-info-req-args message-info))))))))) - (reinitialize-instance gf :message-info message-info))))) - -;;; -may- need to invalidate cached info whenever new interface files -;;; are made accessible. Probably the right thing to do is to insist -;;; that (known) message signatures be updated in that case. -(defun get-objc-message-info (message-name &optional (use-database t)) - (setq message-name (string message-name)) - (or (gethash message-name *objc-message-info*) - (and use-database - (let* ((info (lookup-objc-message-info message-name))) - (when info - (setf (gethash message-name *objc-message-info*) info) - (postprocess-objc-message-info info) - info))))) - -(defun need-objc-message-info (message-name) - (or (get-objc-message-info message-name) - (error "Undeclared message: ~s" message-name))) - -;;; Should be called after using new interfaces that may define -;;; new methods on existing messages. -(defun update-objc-method-info () - (maphash #'(lambda (message-name info) - (lookup-objc-message-info message-name info) - (postprocess-objc-message-info info)) - *objc-message-info*)) - - -;;; Of the method declarations (OBJC-METHOD-INFO structures) associated -;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M, -;;; return the one that seems to be applicable for the object O. -;;; (If there's no ambiguity among the declared methods, any method -;;; will do; this just tells runtime %SEND functions how to compose -;;; an %FF-CALL). -(defun %lookup-objc-method-info (m o) - (let* ((methods (objc-message-info-methods m)) - (ambiguous (getf (objc-message-info-flags m) :ambiguous))) - (if (not ambiguous) - (car methods) - (or - (dolist (method methods) - (let* ((mclass (get-objc-method-info-class method))) - (if (typep o mclass) - (return method)))) - (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o))))) - -(defun resolve-existing-objc-method-info (message-info class-name class-p result-type args) - (let* ((method-info (dolist (m (objc-message-info-methods message-info)) - (when (and (eq (getf (objc-method-info-flags m) :class-p) - class-p) - (equal (objc-method-info-class-name m) - class-name)) - (return m))))) - (when method-info - (unless (and (foreign-type-= (ensure-foreign-type (objc-method-info-result-type method-info)) - (parse-foreign-type result-type)) - (do* ((existing (objc-method-info-arglist method-info) (cdr existing)) - (proposed args (cdr proposed))) - ((null existing) (null proposed)) - (unless (foreign-type-= (ensure-foreign-type (car existing)) - (parse-foreign-type (car proposed))) - (return nil)))) - (cerror "Redefine existing method to have new type signature." - "The method ~c[~a ~a] is already declared to have type signature ~s; the new declaration ~s is incompatible." (if class-p #\+ #\-) class-name (objc-message-info-message-name message-info) (objc-method-info-signature method-info) (cons result-type args)) - (setf (objc-method-info-arglist method-info) args - (objc-method-info-result-type method-info) result-type - (objc-method-info-signature method-info) nil - (objc-method-info-signature-info method-info) nil)) - method-info))) - -;;; Still not right; we have to worry about type conflicts with -;;; shadowed methods, as well. -(defun %declare-objc-method (message-name class-name class-p result-type args) - (let* ((info (get-objc-message-info message-name))) - (unless info - (format *error-output* "~&; Note: defining new ObjC message ~c[~a ~a]" (if class-p #\+ #\-) class-name message-name) - (setq info (make-objc-message-info :message-name message-name)) - (setf (gethash message-name *objc-message-info*) info)) - (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous)) - (method-info (or (resolve-existing-objc-method-info info class-name class-p result-type args) - (make-objc-method-info :message-info info - :class-name class-name - :result-type result-type - :arglist args - :flags (if class-p '(:class t)))))) - (pushnew method-info (objc-message-info-methods info)) - (postprocess-objc-message-info info) - (if (and (getf (objc-message-info-flags info) :ambiguous) - (not was-ambiguous)) - (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info)) - - (objc-method-info-signature method-info)))) - - - -;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID - -(defun translate-foreign-result-type (ftype) - (ensure-foreign-type-bits (parse-foreign-type ftype)) - (if (eq ftype :void) - :void - (translate-foreign-arg-type ftype))) - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Invoking ObjC Methods ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; The SEND and SEND/STRET macros - -(defmacro send (o msg &rest args &environment env) - (make-optimized-send o msg args env)) - -(defmacro send/stret (s o msg &rest args &environment env) - (make-optimized-send o msg args env s)) - - - - -;;; Optimize special cases of SEND and SEND/STRET - -(defun make-optimized-send (o msg args env &optional s super sclassname) - (multiple-value-bind (msg args vargs) (parse-message (cons msg args)) - (let* ((message-info (get-objc-message-info msg))) - (if (null message-info) - (error "Unknown message: ~S" msg)) - ;; If a vararg exists, make sure that the message can accept it - (when (and vargs (not (getf (objc-message-info-flags message-info) - :accepts-varargs))) - (error "Message ~S cannot accept a variable number of arguments" msg)) - (unless (= (length args) (objc-message-info-req-args message-info)) - (error "Message ~S requires ~a ~d args, but ~d were provided." - msg - (if vargs "at least" "exactly") - (objc-message-info-req-args message-info) - (length args))) - (multiple-value-bind (args svarforms sinitforms) (sletify-message-args args) - (let* ((ambiguous (getf (objc-message-info-flags message-info) :ambiguous)) - (methods (objc-message-info-methods message-info)) - (method (if (not ambiguous) (car methods)))) - (when ambiguous - (let* ((class (if sclassname - (find-objc-class sclassname) - (get-objc-class-from-declaration (declared-type o env))))) - (if class - (dolist (m methods) - (unless (getf (objc-method-info-flags m) :protocol) - (let* ((mclass (or (get-objc-method-info-class m) - (error "Can't find ObjC class named ~s" - (objc-method-info-class-name m))))) - (when (and class (subtypep class mclass)) - (return (setq method m))))))))) - (if method - (build-call-from-method-info method - args - vargs - o - msg - svarforms - sinitforms - s - super) - (build-ambiguous-send-form message-info - args - vargs - o - msg - svarforms - sinitforms - s - super))))))) - - -;;; WITH-NS-EXCEPTIONS-AS-ERRORS is only available in OpenMCL 0.14 and above - -#-openmcl-native-threads -(defmacro with-ns-exceptions-as-errors (&body body) - `(progn ,@body)) - - -;;; Return a call to the method specified by SEL on object O, with the args -;;; specified by ARGSPECS. This decides whether a normal or stret call is -;;; needed and, if the latter, uses the memory S to hold the result. If SUPER -;;; is nonNIL, then this builds a send to super. Finally, this also -;;; coerces return #$YES/#$NO values to T/NIL. The entire call takes place -;;; inside an implicit SLET. - -(defun build-call (o sel msg argspecs svarforms sinitforms &optional s super) - `(with-ns-exceptions-as-errors - (rlet ,svarforms - ,@sinitforms - ,(let ((rspec (first (last argspecs)))) - (if (requires-stret-p rspec) - (if (null s) - ;; STRET required but not provided - (error "The message ~S must be sent using SEND/STRET" msg) - ;; STRET required and provided, use stret send - (if (null super) - ;; Regular stret send - `(progn - (objc-message-send-stret ,s ,o ,(cadr sel) - ,@(append (butlast argspecs) (list :void))) - ,s) - ;; Super stret send - `(progn - (objc-message-send-super-stret ,s ,super ,(cadr sel) - ,@(append (butlast argspecs) (list :void))) - ,s))) - (if (null s) - ;; STRET not required and not provided, use send - (if (null super) - ;; Regular send - (if (eq rspec :) - `(coerce-from-bool - (objc-message-send ,o ,(cadr sel) ,@argspecs)) - `(objc-message-send ,o ,(cadr sel) ,@argspecs)) - ;; Super send - (if (eq rspec :) - `(coerce-from-bool - (objc-message-send-super ,super ,(cadr sel) ,@argspecs)) - `(objc-message-send-super ,super ,(cadr sel) ,@argspecs))) - ;; STRET not required but provided - (error "The message ~S must be sent using SEND" msg))))))) - -(defun objc-id-type-p (foreign-type) - (and (typep foreign-type 'foreign-pointer-type) - (let* ((to (foreign-pointer-type-to foreign-type))) - (and (typep to 'foreign-record-type) - (eq :struct (foreign-record-type-kind to)) - (not (null (progn (ensure-foreign-type-bits to) (foreign-record-type-fields to)))) - (let* ((target (foreign-record-field-type (car (foreign-record-type-fields to))))) - (and (typep target 'foreign-pointer-type) - (let* ((target-to (foreign-pointer-type-to target))) - (and (typep target-to 'foreign-record-type) - (eq :struct (foreign-record-type-kind target-to)) - (eq :objc_class (foreign-record-type-name target-to)))))))))) - -(defun unique-objc-classes-in-method-info-list (method-info-list) - (if (cdr method-info-list) ; if more than 1 class - (flet ((subclass-of-some-other-class (c) - (let* ((c-class (get-objc-method-info-class c))) - (dolist (other method-info-list) - (unless (eq other c) - (when (subtypep c-class (get-objc-method-info-class other)) - (return t))))))) - (remove-if #'subclass-of-some-other-class method-info-list)) - method-info-list)) - -(defun get-objc-method-info-class (method-info) - (or (objc-method-info-class-pointer method-info) - (setf (objc-method-info-class-pointer method-info) - (let* ((c (lookup-objc-class (objc-method-info-class-name method-info) nil))) - (when c - (let* ((meta-p (getf (objc-method-info-flags method-info) :class))) - (if meta-p - (with-macptrs ((m (pref c :objc_class.isa))) - (canonicalize-registered-metaclass m)) - (canonicalize-registered-class c)))))))) - -;;; Generate some sort of CASE or COND to handle an ambiguous message -;;; send (where the signature of the FF-CALL depends on the type of the -;;; receiver.) -;;; AMBIGUOUS-METHODS is a list of lists of OBJC-METHOD-INFO structures, -;;; where the methods in each sublist share the same type signature. It's -;;; sorted so that more unique method/signature combinations appear first -;;; (and are easier to special-case via TYPECASE.) -(defun build-send-case (ambiguous-methods - args - vargs - receiver - msg - s - super - protocol-methods) - (flet ((method-class-name (m) - (let* ((mclass (get-objc-method-info-class m))) - (unless mclass - (error "Can't find class with ObjC name ~s" - (objc-method-info-class-name m))) - (class-name mclass)))) - - (collect ((clauses)) - (let* ((protocol (gensym)) - (protocol-address (gensym))) - (dolist (method protocol-methods) - (let* ((protocol-name (objc-method-info-class-name method))) - (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name)) - (,protocol-address (and ,protocol (objc-protocol-address ,protocol)))) - (and ,protocol-address - (objc-message-send ,receiver - "conformsToProtocol:" - :address ,protocol-address - :))) - ,(build-internal-call-from-method-info - method args vargs receiver msg s super)))))) - (do* ((methods ambiguous-methods (cdr methods))) - ((null (cdr methods)) - (when ambiguous-methods - (clauses `(t - ,(build-internal-call-from-method-info - (caar methods) args vargs receiver msg s super))))) - (clauses `(,(if (cdar methods) - `(or ,@(mapcar #'(lambda (m) - `(typep ,receiver - ',(method-class-name m))) - (unique-objc-classes-in-method-info-list - (car methods)))) - `(typep ,receiver ',(method-class-name (caar methods)))) - ,(build-internal-call-from-method-info - (caar methods) args vargs receiver msg s super)))) - `(cond - ,@(clauses))))) - -(defun build-ambiguous-send-form (message-info args vargs o msg svarforms sinitforms s super) - (let* ((receiver (gensym)) - (caseform (build-send-case - (objc-message-info-ambiguous-methods message-info) - args - vargs - receiver - msg - s - super - (objc-message-info-protocol-methods message-info)))) - `(with-ns-exceptions-as-errors - (rlet ,svarforms - ,@sinitforms - (let* ((,receiver ,o)) - ,caseform))))) - - -;;; Generate the "internal" part of a method call; the "external" part -;;; has established ObjC exception handling and handled structure-return -;; details -(defun build-internal-call-from-method-info (method-info args vargs o msg s super) - (let* ((arglist ())) - (collect ((specs)) - (do* ((args args (cdr args)) - (argtypes (objc-method-info-arglist method-info) (cdr argtypes)) - (reptypes (cdr (objc-method-info-signature method-info)) (cdr reptypes))) - ((null args) (setq arglist (append (specs) vargs))) - (let* ((reptype (if (objc-id-type-p (car argtypes)) :id (car reptypes))) - (arg (car args))) - (specs reptype) - (specs arg))) - ;;(break "~& arglist = ~s" arglist) - (if (result-type-requires-structure-return - (objc-method-info-result-type method-info)) - (if (null s) - ;; STRET required but not provided - (error "The message ~S must be sent using SEND/STRET" msg) - (if (null super) - `(objc-message-send-stret ,s ,o ,msg ,@arglist ,(car (objc-method-info-signature method-info))) - `(objc-message-send-super-stret ,s ,super ,msg ,@arglist ,(car (objc-method-info-signature method-info))))) - (if s - ;; STRET provided but not required - (error "The message ~S must be sent using SEND" msg) - (let* ((result-spec (car (objc-method-info-signature method-info))) - (form (if super - `(objc-message-send-super ,super ,msg ,@arglist ,result-spec) - `(objc-message-send ,o ,msg ,@arglist ,result-spec)))) - form)))))) - -(defun build-call-from-method-info (method-info args vargs o msg svarforms sinitforms s super) - `(with-ns-exceptions-as-errors - (rlet ,svarforms - ,@sinitforms - ,(build-internal-call-from-method-info - method-info - args - vargs - o - msg - s - super)))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Instantiating ObjC Class ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; A MAKE-INSTANCE like interface to ObjC object creation - -(defun make-objc-instance (cname &rest initargs) - (declare (dynamic-extent initargs)) - (multiple-value-bind (ks vs) (keys-and-vals initargs) - (declare (dynamic-extent ks vs)) - (let* ((class (etypecase cname - (string (canonicalize-registered-class - (find-objc-class cname))) - (symbol (find-class cname)) - (class cname)))) - (send-objc-init-message (#/alloc class) ks vs)))) - -;;; Provide the BRIDGE module - -(provide "BRIDGE") Index: unk/ccl/examples/cocoa-application.lisp =================================================================== --- /trunk/ccl/examples/cocoa-application.lisp (revision 6894) +++ (revision ) @@ -1,105 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2002-2003 Clozure Associates -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html - - -(in-package "CCL") ; for now. - -(eval-when (:compile-toplevel :execute) - (use-interface-dir :cocoa)) - -(require "COCOA") -;;; Alternately, one could -;;; (require "COCOA-INSPECTOR"). I haven't tried this yet, but think -;;; that it -should- work. - -;;; This is a hack to try to set the CCL logical host's translations -;;; appropriately. If the environment variable CCL_DEFAULT_DIRECTORY -;;; is set, assume that it's correct and do nothing. Otherwise, if -;;; there's a key #@"CCLDefaultDirectory" in the main bundle's Info.plist, -;;; use it and the bundle's path to set CCL_DEFAULT_DIRECTORY and -;;; setup the CCL logical host translations again. -(defun reset-ccl-directory () - (or (getenv "CCL_DEFAULT_DIRECTORY") - (with-autorelease-pool - (let* ((bundle (#/mainBundle ns:ns-bundle)) - (ccl-dir (unless (%null-ptr-p bundle) - (#/objectForInfoDictionaryKey: bundle - #@"CCLDefaultDirectory"))) - (bundle-path (unless (%null-ptr-p bundle) - (#/bundlePath bundle)))) - (when (and ccl-dir (not (%null-ptr-p ccl-dir)) - bundle-path (not (%null-ptr-p bundle-path))) - (let* ((bundle-string (lisp-string-from-nsstring bundle-path)) - (ccl-string (lisp-string-from-nsstring ccl-dir)) - (bundle-len (length bundle-string))) - (if (and (> bundle-len 0) - (not (eql (schar bundle-string (1- bundle-len)) #\/))) - (setq bundle-string (concatenate 'string bundle-string "/"))) - (let* ((default-dir (native-translated-namestring - (merge-pathnames ccl-string bundle-string)))) - (setenv "CCL_DEFAULT_DIRECTORY" default-dir t) - (init-logical-directories)))))))) - - -(defclass cocoa-application (lisp-development-system) - ()) - -;;; If we're launched via the Finder, the only argument we'll -;;; get is of the form -psnXXXXXX. That's meaningless to us; -;;; it's easier to pretend that we didn't get any arguments. -;;; (If it seems like some of this needs to be thought out a -;;; bit better ... I'd tend to agree.) -(defmethod parse-application-arguments ((a cocoa-application)) - (values nil nil nil)) - -(defmethod toplevel-function ((a cocoa-application) init-file) - (declare (ignore init-file)) - (reset-ccl-directory) - (start-cocoa-application)) - - -;;; Wait until we're sure that the Cocoa event loop has started. -(wait-on-semaphore *cocoa-application-finished-launching*) - - -;;; The saved image will be an instance of COCOA-APPLICATION (mostly -;;; so that it'll ignore its argument list.) When it starts up, it'll -;;; run the Cocoa event loop in the cocoa event process. -;;; If you use an init file ("home:openmcl-init"), it'll be loaded -;;; in an environment in which *STANDARD-INPUT* always generates EOF -;;; and where output and error streams are directed to the OSX console -;;; (see below). If that causes problems, you may want to suppress -;;; the loading of your init file (via an :INIT-FILE nil arg to -;;; the call to SAVE-APPLICATION, below.) - -;;; As things are distributed, the file "dppccl" in the application -;;; bundle is just a placeholder. LaunchServices may have already -;;; decided that the application isn't really executable and may -;;; have cached that fact; touching the bundle directory -;;; here is an attempt to force LaunchServices to discard that -;;; cached information. - -(touch "ccl:openmcl.app;") - -(save-application "ccl:OpenMCL.app;Contents;MacOS;dppccl" - :prepend-kernel t - :application-class 'cocoa-application) - -;;; If things go wrong, you might see some debugging information via -;;; the OSX console (/Applications/Utilities/Console.app.) Standard -;;; and error output for the initial lisp process will be directed -;;; there. - Index: unk/ccl/examples/cocoa-backtrace.lisp =================================================================== --- /trunk/ccl/examples/cocoa-backtrace.lisp (revision 6894) +++ (revision ) @@ -1,191 +1,0 @@ -; -*- Mode: Lisp; Package: CCL; -*- - -(in-package "CCL") - -(defclass ns-lisp-string (ns:ns-string) - ((lisp-string :initarg :string :reader ns-lisp-string-string)) - (:metaclass ns:+ns-object)) - -(objc:defmethod (#/length :nteger) ((self ns-lisp-string)) - (length (ns-lisp-string-string self))) - -(objc:defmethod (#/characterAtIndex: :unichar) ((self ns-lisp-string) (index :nteger)) - (char-code (schar (ns-lisp-string-string self) index))) - -(defclass frame-label (ns-lisp-string) - ((frame-number :initarg :frame-number :foreign-type :int :accessor frame-label-number) - (controller :initarg :controller :foreign-type :id :reader frame-label-controller) - (frame-inspector :initform nil :accessor frame-label-frame-inspector)) - (:metaclass ns:+ns-object)) - -(defclass frame-item (ns-lisp-string) - ((frame-label :initarg :frame-label :foreign-type :id :accessor frame-item-label) - (index :initarg :index :foreign-type :int :accessor frame-item-index)) - (:metaclass ns:+ns-object)) - - -(defclass backtrace-window-controller (ns:ns-window-controller) - ((context :initarg :context :reader backtrace-controller-context) - (inspector :initform nil :reader backtrace-controller-inspector) - (outline-view :foreign-type :id :reader backtrace-controller-outline-view)) - (:metaclass ns:+ns-object)) - -(objc:defmethod #/windowNibName ((self backtrace-window-controller)) - #@"backtrace") - -(objc:defmethod (#/close :void) ((self backtrace-window-controller)) - (setf (slot-value self 'context) nil) - (call-next-method)) - -(defmethod our-frame-label-p ((self backtrace-window-controller) thing) - (and (typep thing 'frame-label) - (eql self (frame-label-controller thing)))) - -(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller)) - (let* ((outline (slot-value self 'outline-view)) - (font (default-font :name "Monaco" :size 12))) - (unless (%null-ptr-p outline) - (let* ((columns (#/tableColumns outline))) - (dotimes (i (#/count columns)) - (let* ((column (#/objectAtIndex: columns i)) - (data-cell (#/dataCell column))) - (#/setFont: data-cell font) - (when (eql i 0) - (let* ((header-cell (#/headerCell column)) - (inspector (backtrace-controller-inspector self)) - (break-condition - (inspector::break-condition - (inspector::inspector-object inspector))) - (break-condition-string - (let* ((*print-level* 5) - (*print-length* 5) - (*print-circle* t)) - (format nil "~a: ~a" - (class-name (class-of break-condition)) - break-condition)))) - - (#/setFont: header-cell (default-font :attributes '(:bold))) - (#/setStringValue: header-cell (%make-nsstring break-condition-string)))))))) - (let* ((window (#/window self))) - (unless (%null-ptr-p window) - (let* ((context (backtrace-controller-context self)) - (process (tcr->process (bt.tcr context)))) - (#/setTitle: window (%make-nsstring - (format nil "Backtrace for ~a(~d), break level ~d" - (process-name process) - (process-serial-number process) - (bt.break-level context))))))))) - -(objc:defmethod (#/outlineView:isItemExpandable: :) - ((self backtrace-window-controller) view item) - (declare (ignore view)) - (or (%null-ptr-p item) - (our-frame-label-p self item))) - -(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :nteger) - ((self backtrace-window-controller) view item) - (declare (ignore view)) - (let* ((inspector (backtrace-controller-inspector self))) - (cond ((%null-ptr-p item) - (inspector::inspector-line-count inspector)) - ((our-frame-label-p self item) - (let* ((frame-inspector - (or (frame-label-frame-inspector item) - (setf (frame-label-frame-inspector item) - (make-instance - 'inspector::stack-frame-inspector - :frame-number (frame-label-number item) - :object (inspector::inspector-object inspector) - :update-line-count t))))) - (inspector::inspector-line-count frame-inspector))) - (t -1)))) - -(objc:defmethod #/outlineView:child:ofItem: - ((self backtrace-window-controller) view (index :nteger) item) - (declare (ignore view)) - (let* ((inspector (backtrace-controller-inspector self))) - (cond ((%null-ptr-p item) - (let* ((label - (make-instance 'frame-label - :string - (let* ((value - (inspector::line-n inspector index))) - (if value - (%lfun-name-string value) - ":kernel"))))) - (setf (slot-value label 'controller) self - (slot-value label 'frame-number) index) - label)) - ((our-frame-label-p self item) - (let* ((frame-inspector - (or (frame-label-frame-inspector item) - (setf (frame-label-frame-inspector item) - (make-instance - 'inspector::stack-frame-inspector - :frame-number (frame-label-number item) - :object (inspector::inspector-object inspector) - :update-line-count t))))) - (make-instance 'frame-item - :frame-label item - :index index - :string - (let* ((ccl::*aux-vsp-ranges* (inspector::vsp-range inspector)) - (ccl::*aux-tsp-ranges* (inspector::tsp-range inspector))) - (with-output-to-string (s) - (multiple-value-bind (value label) - (inspector::line-n - frame-inspector - index) - (inspector::prin1-value - frame-inspector - s - value - label))))))) - (t (break) (%make-nsstring "Huh?"))))) - -(objc:defmethod #/outlineView:objectValueForTableColumn:byItem: - ((self backtrace-window-controller) view column item) - (declare (ignore view column)) - (if (%null-ptr-p item) - #@"Open this" - (%setf-macptr (%null-ptr) item))) - -(defmethod initialize-instance :after ((self backtrace-window-controller) - &key &allow-other-keys) - (setf (slot-value self 'inspector) - (make-instance 'inspector::stack-inspector :context (backtrace-controller-context self) :update-line-count t))) - -(defun backtrace-controller-for-context (context) - (or (bt.dialog context) - (setf (bt.dialog context) - (make-instance 'backtrace-window-controller - :with-window-nib-name #@"backtrace" - :context context)))) - -#+debug -(objc:defmethod (#/willLoad :void) ((self backtrace-window-controller)) - (#_NSLog #@"will load %@" :address (#/windowNibName self))) - -(defmethod ui-object-enter-backtrace-context ((app ns:ns-application) - context) - (let* ((proc *current-process*)) - (when (typep proc 'cocoa-listener-process) - (push context (cocoa-listener-process-backtrace-contexts proc))))) - -(defmethod ui-object-exit-backtrace-context ((app ns:ns-application) - context) - (let* ((proc *current-process*)) - (when (typep proc 'cocoa-listener-process) - (when (eq context (car (cocoa-listener-process-backtrace-contexts proc))) - (setf (cocoa-listener-process-backtrace-contexts proc) - (cdr (cocoa-listener-process-backtrace-contexts proc))) - (let* ((window (bt.dialog context))) - (when window - (#/performSelectorOnMainThread:withObject:waitUntilDone: window (@selector @/close) +null-ptr+ t))))))) - - - - - - - Index: unk/ccl/examples/cocoa-defaults.lisp =================================================================== --- /trunk/ccl/examples/cocoa-defaults.lisp (revision 6894) +++ (revision ) @@ -1,104 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2004 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 :execute) - (use-interface-dir :cocoa) - (use-interface-dir :carbon)) - -(require "OBJC-SUPPORT") - -(defstruct cocoa-default - symbol ; a lisp special variable - string ; an NSConstantString - type ; a keyword - value ; the "standard" initial value - doc ; a doc string - constraint ; an optional type constraint. - ) - -(let* ((cocoa-defaults ())) - (defun %get-cocoa-default (name) - (find name cocoa-defaults :key #'cocoa-default-symbol)) - (defun %put-cocoa-default (default) - (push default cocoa-defaults)) - (defun cocoa-defaults () cocoa-defaults) - (defun %remove-cocoa-default (name) - (setq cocoa-defaults - (delete name cocoa-defaults :key #'cocoa-default-symbol))) - (defun %clear-cocoa-defaults () (setq cocoa-defaults nil))) - -(defun set-cocoa-default (name string type value doc &optional constraint) - (check-type name symbol) - (check-type string objc-constant-string) - (check-type type keyword) - (check-type doc (or null string)) - (%remove-cocoa-default name) - (%put-cocoa-default (make-cocoa-default :symbol name - :string string - :type type - :value value - :doc doc - :constraint constraint)) - value) - -(defun %define-cocoa-default (name type value doc &optional constraint) - (proclaim `(special ,name)) - ;; Make the variable "GLOBAL": its value can be changed, but it can't - ;; have a per-thread binding. - (%symbol-bits name (logior (ash 1 $sym_vbit_global) - (the fixnum (%symbol-bits name)))) - (record-source-file name 'variable) - (setf (documentation name 'variable) doc) - (set name (set-cocoa-default name (ns-constant-string (string name)) type value doc constraint)) - name) - - - -(defmacro def-cocoa-default (name type value doc &optional constraint &environment env) - `(progn - (eval-when (:compile-toplevel) - (note-variable-info ',name :global ,env)) - (declaim (special ,name)) - (%define-cocoa-default ',name ',type ',value ',doc ,@(when constraint `((specifier-type ',constraint)))))) - - -(defun update-cocoa-defaults () - (update-cocoa-defaults-vector - (#/standardUserDefaults ns:ns-user-defaults) - (apply #'vector (reverse (cocoa-defaults))))) - -(defun update-cocoa-defaults-vector (domain defaults-vector) - (let* ((need-synch nil)) - (dotimes (i (length defaults-vector)) - (let* ((d (svref defaults-vector i)) - (name (cocoa-default-symbol d)) - (key (objc-constant-string-nsstringptr (cocoa-default-string d)))) - (if (%null-ptr-p (#/objectForKey: domain key)) - (progn - (#/setObject:forKey: domain (%make-nsstring (format nil "~a" (cocoa-default-value d))) key) - (setq need-synch t)) - (case (cocoa-default-type d) - (:int - (set name (#/integerForKey: domain key))) - (:float - (set name (#/floatForKey: domain key))) - (:string - (let* ((nsstring (#/stringForKey: domain key))) - (unless (%null-ptr-p nsstring) - (set name (lisp-string-from-nsstring nsstring))))))))) - (when need-synch (#/synchronize domain)))) Index: unk/ccl/examples/cocoa-editor.lisp =================================================================== --- /trunk/ccl/examples/cocoa-editor.lisp (revision 6894) +++ (revision ) @@ -1,2029 +1,0 @@ -;;-*- Mode: LISP; Package: CCL -*- - - -(in-package "CCL") - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "COCOA-WINDOW") - (require "HEMLOCK")) - -(eval-when (:compile-toplevel :execute) - ;; :ALL-IN-COCOA-THREAD selects code that does all rendering - ;; in the Cocoa event thread. - ;; Something else that could be conditionalized (and might - ;; be similarly named) would force all Hemlock commands - - ;; as well as rendering and event handling - to happen in - ;; the Cocoa thread. - (pushnew :all-in-cocoa-thread *features*) - (use-interface-dir :cocoa)) - -;;; In the double-float case, this is probably way too small. -;;; Traditionally, it's (approximately) the point at which -;;; a single-float stops being able to accurately represent -;;; integral values. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant large-number-for-text (float 1.0f7 +cgfloat-zero+))) - -(def-cocoa-default *editor-rows* :int 24 "Initial height of editor windows, in characters") -(def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters") - -;;; Background color components: red, blue, green, alpha. -;;; All should be single-floats between 0.0f0 and 1.0f0, inclusive. -(def-cocoa-default *editor-background-red-component* :float 1.0f0 "Red component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *editor-background-green-component* :float 1.0f0 "Green component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *editor-background-blue-component* :float 1.0f0 "Blue component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *editor-background-alpha-component* :float 1.0f0 "Alpha component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") - -;;; At runtime, this'll be a vector of character attribute dictionaries. -(defloadvar *styles* ()) - -(defun make-editor-style-map () - (let* ((font-name *default-font-name*) - (font-size *default-font-size*) - (font (default-font :name font-name :size font-size)) - (color-class (find-class 'ns:ns-color)) - (colors (vector (#/blackColor color-class) - (#/whiteColor color-class) - (#/darkGrayColor color-class) - (#/lightGrayColor color-class) - (#/redColor color-class) - (#/blueColor color-class) - (#/greenColor color-class) - (#/yellowColor color-class))) - (styles (make-array (the fixnum (* 4 (length colors))))) - (bold-stroke-width 9.0f0) - (s 0)) - (declare (dynamic-extent fonts colors)) - (dotimes (c (length colors)) - (dotimes (i 4) - (setf (svref styles s) (create-text-attributes :font font - :color (svref colors c) - :obliqueness - (if (logbitp 1 i) - 0.15f0) - :stroke-width - (if (logbitp 0 i) - bold-stroke-width))) - (incf s))) - (setq *styles* styles))) - -(defun make-hemlock-buffer (&rest args) - (let* ((buf (apply #'hi::make-buffer args))) - (if buf - (progn - (setf (hi::buffer-gap-context buf) (hi::make-buffer-gap-context)) - buf) - (progn - (format t "~& couldn't make hemlock buffer with args ~s" args) - ;;(dbg) - nil)))) - -;;; Define some key event modifiers. - -;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use -;;; it to map NSEvent modifier keys to key-event modifiers. - -(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift") -(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control") -(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta") -(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock") - - -;;; We want to display a Hemlock buffer in a "pane" (an on-screen -;;; view) which in turn is presented in a "frame" (a Cocoa window). A -;;; 1:1 mapping between frames and panes seems to fit best into -;;; Cocoa's document architecture, but we should try to keep the -;;; concepts separate (in case we come up with better UI paradigms.) -;;; Each pane has a modeline (which describes attributes of the -;;; underlying document); each frame has an echo area (which serves -;;; to display some commands' output and to provide multi-character -;;; input.) - - -;;; I'd pretty much concluded that it wouldn't be possible to get the -;;; Cocoa text system (whose storage model is based on NSString -;;; NSMutableAttributedString, NSTextStorage, etc.) to get along with -;;; Hemlock, and (since the whole point of using Hemlock was to be -;;; able to treat an editor buffer as a rich lisp data structure) it -;;; seemed like it'd be necessary to toss the higher-level Cocoa text -;;; system and implement our own scrolling, redisplay, selection -;;; ... code. -;;; -;;; Mikel Evins pointed out that NSString and friends were -;;; abstract classes and that there was therefore no reason (in -;;; theory) not to implement a thin wrapper around a Hemlock buffer -;;; that made it act like an NSString. As long as the text system can -;;; ask a few questions about the NSString (its length and the -;;; character and attributes at a given location), it's willing to -;;; display the string in a scrolling, mouse-selectable NSTextView; -;;; as long as Hemlock tells the text system when and how the contents -;;; of the abstract string changes, Cocoa will handle the redisplay -;;; details. -;;; - - - -;;; Hemlock-buffer-string objects: - -(defclass hemlock-buffer-string (ns:ns-string) - ((cache :initform nil :initarg :cache :accessor hemlock-buffer-string-cache)) - (:metaclass ns:+ns-object)) - -;;; Cocoa wants to treat the buffer as a linear array of characters; -;;; Hemlock wants to treat it as a doubly-linked list of lines, so -;;; we often have to map between an absolute position in the buffer -;;; and a relative position on a line. We can certainly do that -;;; by counting the characters in preceding lines every time that we're -;;; asked, but we're often asked to map a sequence of nearby positions -;;; and wind up repeating a lot of work. Caching the results of that -;;; work seems to speed things up a bit in many cases; this data structure -;;; is used in that process. (It's also the only way to get to the -;;; actual underlying Lisp buffer from inside the network of text-system -;;; objects.) - -(defstruct buffer-cache - buffer ; the hemlock buffer - buflen ; length of buffer, if known - workline ; cache for character-at-index - workline-offset ; cached offset of workline - workline-length ; length of cached workline - workline-start-font-index ; current font index at start of worklin - ) - -;;; Initialize (or reinitialize) a buffer cache, so that it points -;;; to the buffer's first line (which is the only line whose -;;; absolute position will never change). Code which modifies the -;;; buffer generally has to call this, since any cached information -;;; might be invalidated by the modification. - -(defun reset-buffer-cache (d &optional (buffer (buffer-cache-buffer d) - buffer-p)) - (when buffer-p (setf (buffer-cache-buffer d) buffer)) - (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (workline (hi::mark-line - (hi::buffer-start-mark buffer)))) - (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer) - (buffer-cache-workline-offset d) 0 - (buffer-cache-workline d) workline - (buffer-cache-workline-length d) (hi::line-length workline) - (buffer-cache-workline-start-font-index d) 0) - d)) - - -(defun adjust-buffer-cache-for-insertion (display pos n) - (if (buffer-cache-workline display) - (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context (buffer-cache-buffer display)))) - (if (> (buffer-cache-workline-offset display) pos) - (incf (buffer-cache-workline-offset display) n) - (when (>= (+ (buffer-cache-workline-offset display) - (buffer-cache-workline-length display)) - pos) - (setf (buffer-cache-workline-length display) - (hi::line-length (buffer-cache-workline display))))) - (incf (buffer-cache-buflen display) n)) - (reset-buffer-cache display))) - - - - -;;; Update the cache so that it's describing the current absolute -;;; position. - -(defun update-line-cache-for-index (cache index) - (let* ((buffer (buffer-cache-buffer cache)) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (line (or - (buffer-cache-workline cache) - (progn - (reset-buffer-cache cache) - (buffer-cache-workline cache)))) - (pos (buffer-cache-workline-offset cache)) - (len (buffer-cache-workline-length cache)) - (moved nil)) - (loop - (when (and (>= index pos) - (< index (1+ (+ pos len)))) - (let* ((idx (- index pos))) - (when moved - (setf (buffer-cache-workline cache) line - (buffer-cache-workline-offset cache) pos - (buffer-cache-workline-length cache) len)) - (return (values line idx)))) - (setq moved t) - (if (< index pos) - (setq line (hi::line-previous line) - len (hi::line-length line) - pos (1- (- pos len))) - (setq line (hi::line-next line) - pos (1+ (+ pos len)) - len (hi::line-length line)))))) - -;;; Ask Hemlock to count the characters in the buffer. -(defun hemlock-buffer-length (buffer) - (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer))) - (hemlock::count-characters (hemlock::buffer-region buffer)))) - -;;; Find the line containing (or immediately preceding) index, which is -;;; assumed to be less than the buffer's length. Return the character -;;; in that line or the trailing #\newline, as appropriate. -(defun hemlock-char-at-index (cache index) - (let* ((hi::*buffer-gap-context* - (hi::buffer-gap-context (buffer-cache-buffer cache)))) - (multiple-value-bind (line idx) (update-line-cache-for-index cache index) - (let* ((len (hemlock::line-length line))) - (if (< idx len) - (hemlock::line-character line idx) - #\newline))))) - -;;; Given an absolute position, move the specified mark to the appropriate -;;; offset on the appropriate line. -(defun move-hemlock-mark-to-absolute-position (mark cache abspos) - (let* ((hi::*buffer-gap-context* - (hi::buffer-gap-context (buffer-cache-buffer cache)))) - (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos) - #+debug - (#_NSLog #@"Moving point from current pos %d to absolute position %d" - :int (mark-absolute-position mark) - :int abspos) - (hemlock::move-to-position mark idx line) - #+debug - (#_NSLog #@"Moved mark to %d" :int (mark-absolute-position mark))))) - -;;; Return the absolute position of the mark in the containing buffer. -;;; This doesn't use the caching mechanism, so it's always linear in the -;;; number of preceding lines. -(defun mark-absolute-position (mark) - (let* ((pos (hi::mark-charpos mark)) - (hi::*buffer-gap-context* (hi::buffer-gap-context (hi::line-%buffer - (hi::mark-line mark))))) - (do* ((line (hi::line-previous (hi::mark-line mark)) - (hi::line-previous line))) - ((null line) pos) - (incf pos (1+ (hi::line-length line)))))) - -;;; Return the length of the abstract string, i.e., the number of -;;; characters in the buffer (including implicit newlines.) -(objc:defmethod (#/length :nteger) ((self hemlock-buffer-string)) - (let* ((cache (hemlock-buffer-string-cache self))) - (or (buffer-cache-buflen cache) - (setf (buffer-cache-buflen cache) - (let* ((buffer (buffer-cache-buffer cache))) - (hemlock-buffer-length buffer)))))) - - - -;;; Return the character at the specified index (as a :unichar.) - -(objc:defmethod (#/characterAtIndex: :unichar) - ((self hemlock-buffer-string) (index :nteger)) - #+debug - (#_NSLog #@"Character at index: %d" :nteger index) - (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index))) - -(objc:defmethod (#/getCharacters:range: :void) - ((self hemlock-buffer-string) - (buffer (:* :unichar)) - (r :ange)) - (let* ((cache (hemlock-buffer-string-cache self)) - (index (ns:ns-range-location r)) - (length (ns:ns-range-length r)) - (hi::*buffer-gap-context* - (hi::buffer-gap-context (buffer-cache-buffer cache)))) - #+debug - (#_NSLog #@"get characters: %d/%d" - :nteger index - :nteger length) - (multiple-value-bind (line idx) (update-line-cache-for-index cache index) - (let* ((len (hemlock::line-length line))) - (do* ((i 0 (1+ i))) - ((= i length)) - (cond ((< idx len) - (setf (paref buffer (:* :unichar) i) - (char-code (hemlock::line-character line idx))) - (incf idx)) - (t - (setf (paref buffer (:* :unichar) i) - (char-code #\Newline) - line (hi::line-next line) - len (hi::line-length line) - idx 0)))))))) - -(objc:defmethod (#/getLineStart:end:contentsEnd:forRange: :void) - ((self hemlock-buffer-string) - (startptr (:* :nteger)) - (endptr (:* :nteger)) - (contents-endptr (:* :nteger)) - (r :ange)) - (let* ((cache (hemlock-buffer-string-cache self)) - (index (pref r :ange.location)) - (length (pref r :ange.length)) - (hi::*buffer-gap-context* - (hi::buffer-gap-context (buffer-cache-buffer cache)))) - #+debug - (#_NSLog #@"get line start: %d/%d" - :unsigned index - :unsigned length) - (update-line-cache-for-index cache index) - (unless (%null-ptr-p startptr) - ;; Index of the first character in the line which contains - ;; the start of the range. - (setf (pref startptr :nteger) - (buffer-cache-workline-offset cache))) - (unless (%null-ptr-p endptr) - ;; Index of the newline which terminates the line which - ;; contains the start of the range. - (setf (pref endptr :nteger) - (+ (buffer-cache-workline-offset cache) - (buffer-cache-workline-length cache)))) - (unless (%null-ptr-p contents-endptr) - ;; Index of the newline which terminates the line which - ;; contains the start of the range. - (unless (zerop length) - (update-line-cache-for-index cache (+ index length))) - (setf (pref contents-endptr :nteger) - (1+ (+ (buffer-cache-workline-offset cache) - (buffer-cache-workline-length cache))))))) - - -;;; Return an NSData object representing the bytes in the string. If -;;; the underlying buffer uses #\linefeed as a line terminator, we can -;;; let the superclass method do the work; otherwise, we have to -;;; ensure that each line is terminated according to the buffer's -;;; conventions. -(objc:defmethod #/dataUsingEncoding:allowLossyConversion: - ((self hemlock-buffer-string) - (encoding :tringncoding) - (flag :)) - (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache self))) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (external-format (if buffer (hi::buffer-external-format buffer ))) - (raw-length (if buffer (hemlock-buffer-length buffer) 0))) - (hi::%set-buffer-modified buffer nil) - (if (eql 0 raw-length) - (make-instance 'ns:ns-mutable-data :with-length 0) - (case external-format - ((:unix nil) - (call-next-method encoding flag)) - ((:macos :cp/m) - (let* ((cp/m-p (eq external-format :cp/m))) - (when cp/m-p - ;; This may seem like lot of fuss about an ancient OS and its - ;; odd line-termination conventions. Of course, I'm actually - ;; referring to CP/M-86. - (do* ((line (hi::mark-line (hi::buffer-start-mark buffer)) - next) - (next (hi::line-next line) (hi::line-next line))) - ((null line)) - (when next (incf raw-length)))) - (let* ((pos 0) - (data (make-instance 'ns:ns-mutable-data - :with-length raw-length)) - (bytes (#/mutableBytes data))) - (do* ((line (hi::mark-line (hi::buffer-start-mark buffer)) - next) - (next (hi::line-next line) (hi::line-next line))) - ((null line) data) - (let* ((chars (hi::line-chars line)) - (len (length chars))) - (unless (zerop len) - (%cstr-pointer chars (%inc-ptr bytes pos) nil) - (incf pos len)) - (when next - (when cp/m-p - (setf (%get-byte bytes pos) (char-code #\return)) - (incf pos) - (setf (%get-byte bytes pos) (char-code #\linefeed)) - (incf pos)))))))))))) - - -;;; For debugging, mostly: make the printed representation of the string -;;; referenence the named Hemlock buffer. -(objc:defmethod #/description ((self hemlock-buffer-string)) - (let* ((cache (hemlock-buffer-string-cache self)) - (b (buffer-cache-buffer cache))) - (with-cstrs ((s (format nil "~a" b))) - (#/stringWithFormat: ns:ns-string #@"<%s for %s>" (#_object_getClassName self) s)))) - - - - -;;; hemlock-text-storage objects -(defclass hemlock-text-storage (ns:ns-text-storage) - ((string :foreign-type :id) - (edit-count :foreign-type :int) - (append-edits :foreign-type :int)) - (:metaclass ns:+ns-object)) - - -;;; This is only here so that calls to it can be logged for debugging. -#+debug -(objc:defmethod (#/lineBreakBeforeIndex:withinRange: :nteger) - ((self hemlock-text-storage) - (index :nteger) - (r :ange)) - (#_NSLog #@"Line break before index: %d within range: %@" - :unsigned index - :id (#_NSStringFromRange r)) - (call-next-method index r)) - - - -;;; Return true iff we're inside a "beginEditing/endEditing" pair -(objc:defmethod (#/editingInProgress :) ((self hemlock-text-storage)) - (not (eql (slot-value self 'edit-count) 0))) - -(defun textstorage-note-insertion-at-position (self pos n) - (ns:with-ns-range (r pos 0) - (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes r n) - (setf (ns:ns-range-length r) n) - (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r 0))) - -(objc:defmethod (#/noteInsertion: :void) ((self hemlock-text-storage) params) - (let* ((pos (#/longValue (#/objectAtIndex: params 0))) - (n (#/longValue (#/objectAtIndex: params 1)))) - (textstorage-note-insertion-at-position self pos n))) - -(objc:defmethod (#/noteDeletion: :void) ((self hemlock-text-storage) params) - (let* ((pos (#/longValue (#/objectAtIndex: params 0))) - (n (#/longValue (#/objectAtIndex: params 1)))) - (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n)) - (let* ((display (hemlock-buffer-string-cache (#/string self)))) - (reset-buffer-cache display) - (update-line-cache-for-index display pos)))) - -(objc:defmethod (#/noteModification: :void) ((self hemlock-text-storage) params) - (let* ((pos (#/longValue (#/objectAtIndex: params 0))) - (n (#/longValue (#/objectAtIndex: params 1)))) - #+debug - (#_NSLog #@"Note modification: pos = %d, n = %d" :int pos :int n) - (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters - #$NSTextStorageEditedAttributes) (ns:make-ns-range pos n) 0))) - -(objc:defmethod (#/noteAttrChange: :void) ((self hemlock-text-storage) params) - (let* ((pos (#/longValue (#/objectAtIndex: params 0))) - (n (#/longValue (#/objectAtIndex: params 1)))) - #+debug (#_NSLog #@"attribute-change at %d/%d" :int pos :int n) - (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes (ns:make-ns-range pos n) 0))) - -(objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage)) - #+debug - (#_NSLog #@"begin-editing") - (incf (slot-value self 'edit-count)) - #+debug - (#_NSLog #@"after beginEditing edit-count now = %d" :int (slot-value self 'edit-count)) - (call-next-method)) - -(objc:defmethod (#/endEditing :void) ((self hemlock-text-storage)) - #+debug - (#_NSLog #@"end-editing") - (call-next-method) - (decf (slot-value self 'edit-count)) - #+debug - (#_NSLog #@"after endEditing edit-count now = %d" :int (slot-value self 'edit-count))) - -;;; Return true iff we're inside a "beginEditing/endEditing" pair -(objc:defmethod (#/editingInProgress :) ((self hemlock-text-storage)) - (not (eql (slot-value self 'edit-count) 0))) - - - -;;; Access the string. It'd be nice if this was a generic function; -;;; we could have just made a reader method in the class definition. -(objc:defmethod #/string ((self hemlock-text-storage)) - (slot-value self 'string)) - -(objc:defmethod #/initWithString: ((self hemlock-text-storage) s) - (let* ((newself (#/init self))) - (setf (slot-value newself 'string) s) - newself)) - -;;; This is the only thing that's actually called to create a -;;; hemlock-text-storage object. (It also creates the underlying -;;; hemlock-buffer-string.) -(defun make-textstorage-for-hemlock-buffer (buffer) - (make-instance 'hemlock-text-storage - :with-string - (make-instance - 'hemlock-buffer-string - :cache - (reset-buffer-cache - (make-buffer-cache) - buffer)))) - -(objc:defmethod #/attributesAtIndex:effectiveRange: - ((self hemlock-text-storage) (index :nteger) (rangeptr (* :ange))) - #+debug - (#_NSLog #@"Attributes at index: %ld" :nteger index) - (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string))) - (buffer (buffer-cache-buffer buffer-cache)) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))) - (update-line-cache-for-index buffer-cache index) - (multiple-value-bind (start len style) - (ccl::do-dll-nodes (node - (hi::buffer-font-regions buffer) - (values 0 (buffer-cache-buflen buffer-cache) 0)) - (let* ((region (hi::font-region-node-region node)) - (start (hi::region-start region)) - (end (hi::region-end region)) - (startpos (mark-absolute-position start)) - (endpos (mark-absolute-position end))) - (when (and (>= index startpos) - (< index endpos)) - (return (values startpos - (- endpos startpos) - (hi::font-mark-font start)))))) - #+debug - (#_NSLog #@"Start = %d, len = %d, style = %d" - :int start :int len :int style) - (unless (%null-ptr-p rangeptr) - (setf (pref rangeptr :ange.location) start - (pref rangeptr :ange.length) len)) - (svref *styles* style)))) - -(objc:defmethod (#/replaceCharactersInRange:withString: :void) - ((self hemlock-text-storage) (r :ange) string) - (let* ((cache (hemlock-buffer-string-cache (#/string self))) - (buffer (if cache (buffer-cache-buffer cache))) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (location (pref r :ange.location)) - (length (pref r :ange.length)) - (mark (hi::buffer-%mark buffer)) - (point (hi::buffer-point buffer)) - input-mark) - ;; - ;; special behavior for listener windows. - ;; - (if (and (> (slot-value self 'append-edits) 0) - (progn - (setf input-mark (hi::variable-value 'hemlock::buffer-input-mark :buffer buffer)) - (not (hi::same-line-p point input-mark)))) - (progn - ;; - ;; move the point to the end of the buffer - ;; - (setf (hi::buffer-region-active buffer) nil) - (move-hemlock-mark-to-absolute-position point cache (hemlock-buffer-length buffer))) - (cond ((> length 0) - (move-hemlock-mark-to-absolute-position mark cache location) - (move-hemlock-mark-to-absolute-position point cache (+ location length)) - (hemlock::%buffer-activate-region buffer)) - (t - (move-hemlock-mark-to-absolute-position point cache location)))) - (hi::insert-string point (lisp-string-from-nsstring string)))) - - -;;; I'm not sure if we want the text system to be able to change -;;; attributes in the buffer. This method is only here so we can -;;; see if/when it tries to do so. -(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage) - attributes - (r :ange)) - (declare (ignorable attributes r)) - #+debug - (#_NSLog #@"set-attributes %@ range (%d %d)" - :id attributes - :unsigned (pref r :ange.location) - :unsigned (pref r :ange.length))) - -(defun for-each-textview-using-storage (textstorage f) - (let* ((layouts (#/layoutManagers textstorage))) - (unless (%null-ptr-p layouts) - (dotimes (i (#/count layouts)) - (let* ((layout (#/objectAtIndex: layouts i)) - (containers (#/textContainers layout))) - (unless (%null-ptr-p containers) - (dotimes (j (#/count containers)) - (let* ((container (#/objectAtIndex: containers j)) - (tv (#/textView container))) - (funcall f tv))))))))) - -;;; Again, it's helpful to see the buffer name when debugging. -(objc:defmethod #/description ((self hemlock-text-storage)) - (#/stringWithFormat: ns:ns-string #@"%s : string %@" (#_object_getClassName self) (slot-value self 'string))) - -;;; This needs to happen on the main thread. -(objc:defmethod (#/ensureSelectionVisible :void) ((self hemlock-text-storage)) - (for-each-textview-using-storage - self - #'(lambda (tv) - (#/scrollRangeToVisible: tv (#/selectedRange tv))))) - - -(defun close-hemlock-textstorage (ts) - (let* ((string (slot-value ts 'string))) - (setf (slot-value ts 'string) (%null-ptr)) - (unless (%null-ptr-p string) - (let* ((cache (hemlock-buffer-string-cache string)) - (buffer (if cache (buffer-cache-buffer cache)))) - (when buffer - (setf (buffer-cache-buffer cache) nil - (slot-value string 'cache) nil - (hi::buffer-document buffer) nil) - (let* ((p (hi::buffer-process buffer))) - (when p - (setf (hi::buffer-process buffer) nil) - (process-kill p))) - (when (eq buffer hi::*current-buffer*) - (setf (hi::current-buffer) - (car (last hi::*buffer-list*)))) - (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer) - (hi::invoke-hook hemlock::delete-buffer-hook buffer) - (setq hi::*buffer-list* (delq buffer hi::*buffer-list*)) - (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*)))))) - - - - - -;;; An abstract superclass of the main and echo-area text views. -(defclass hemlock-textstorage-text-view (ns::ns-text-view) - ((blink-location :foreign-type :unsigned :accessor text-view-blink-location) - (blink-color-attribute :foreign-type :id :accessor text-view-blink-color) - (blink-enabled :foreign-type : :accessor text-view-blink-enabled) ) - (:metaclass ns:+ns-object)) - - -(def-cocoa-default *layout-text-in-background* :int 1 "When non-zero, do text layout when idle.") - -(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void) - ((self hemlock-textstorage-text-view) layout cont (flag :)) - (declare (ignorable cont flag)) - (when (zerop *layout-text-in-background*) - (#/setDelegate: layout +null-ptr+) - (#/setBackgroundLayoutEnabled: layout nil))) - -;;; Note changes to the textview's background color; record them -;;; as the value of the "temporary" foreground color (for blinking). -(objc:defmethod (#/setBackgroundColor: :void) - ((self hemlock-textstorage-text-view) color) - (setf (text-view-blink-color self) color) - (call-next-method color)) - -;;; Maybe cause 1 character in the textview to blink (by drawing an empty -;;; character rectangle) in synch with the insertion point. - -(objc:defmethod (#/drawInsertionPointInRect:color:turnedOn: :void) - ((self hemlock-textstorage-text-view) - (r :ect) - color - (flag :)) - (unless (#/editingInProgress (#/textStorage self)) - (unless (eql #$NO (text-view-blink-enabled self)) - (let* ((layout (#/layoutManager self)) - (container (#/textContainer self)) - (blink-color (text-view-blink-color self))) - ;; We toggle the blinked character "off" by setting its - ;; foreground color to the textview's background color. - ;; The blinked character should be "on" whenever the insertion - ;; point is drawn as "off" - (ns:with-ns-range (char-range (text-view-blink-location self) 1) - (let* ((glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: - layout - char-range - +null-ptr+))) - #+debug (#_NSLog #@"Flag = %d, location = %d" : (if flag #$YES #$NO) :int (text-view-blink-location self)) - (let* ((rect (#/boundingRectForGlyphRange:inTextContainer: - layout - glyph-range - container))) - (#/set blink-color) - (#_NSRectFill rect)) - (if flag - (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self))))))) - (call-next-method r color flag))) - -(defmethod disable-blink ((self hemlock-textstorage-text-view)) - (when (eql (text-view-blink-enabled self) #$YES) - (setf (text-view-blink-enabled self) #$NO) - ;; Force the blinked character to be redrawn. Let the text - ;; system do the drawing. - (#/invalidateDisplayForCharacterRange: (#/layoutManager self) (ns:make-ns-range (text-view-blink-location self) 1)))) - -(defmethod update-blink ((self hemlock-textstorage-text-view)) - (disable-blink self) - (let* ((d (hemlock-buffer-string-cache (#/string self))) - (buffer (buffer-cache-buffer d))) - (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp")) - (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (point (hi::buffer-point buffer))) - #+debug (#_NSLog #@"Syntax check for blinking") - (cond ((eql (hi::next-character point) #\() - (hemlock::pre-command-parse-check point) - (when (hemlock::valid-spot point nil) - (hi::with-mark ((temp point)) - (when (hemlock::list-offset temp 1) - #+debug (#_NSLog #@"enable blink, forward") - (setf (text-view-blink-location self) - (1- (mark-absolute-position temp)) - (text-view-blink-enabled self) #$YES))))) - ((eql (hi::previous-character point) #\)) - (hemlock::pre-command-parse-check point) - (when (hemlock::valid-spot point nil) - (hi::with-mark ((temp point)) - (when (hemlock::list-offset temp -1) - #+debug (#_NSLog #@"enable blink, backward") - (setf (text-view-blink-location self) - (mark-absolute-position temp) - (text-view-blink-enabled self) #$YES)))))))))) - -;;; Set and display the selection at pos, whose length is len and whose -;;; affinity is affinity. This should never be called from any Cocoa -;;; event handler; it should not call anything that'll try to set the -;;; underlying buffer's point and/or mark - -(objc:defmethod (#/updateSelection:length:affinity: :void) - ((self hemlock-textstorage-text-view) - (pos :int) - (length :int) - (affinity :electionffinity)) - (when (eql length 0) - (update-blink self)) - (rlet ((range :ns-range :location pos :length length)) - (%call-next-objc-method self - hemlock-textstorage-text-view - (@selector #/setSelectedRange:affinity:stillSelecting:) - '(:void :ange :electionffinity :) - range - affinity - nil) - (#/scrollRangeToVisible: self range))) - -;;; A specialized NSTextView. The NSTextView is part of the "pane" -;;; object that displays buffers. -(defclass hemlock-text-view (hemlock-textstorage-text-view) - ((pane :foreign-type :id :accessor text-view-pane)) - (:metaclass ns:+ns-object)) - -;;; Access the underlying buffer in one swell foop. -(defmethod text-view-buffer ((self hemlock-text-view)) - (buffer-cache-buffer (hemlock-buffer-string-cache (#/string (#/textStorage self))))) - -(objc:defmethod (#/setString: :void) ((self hemlock-textstorage-text-view) s) - #+debug - (#_NSLog #@"hemlock-text-view %@ string set to %@" :id self :id s) - (call-next-method) s) - -(objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range) - ((self hemlock-textstorage-text-view) - (proposed :ns-range) - (g :electionranularity)) - #+debug - (#_NSLog #@"Granularity = %d" :int g) - (objc:returning-foreign-struct (r) - (block HANDLED - (let* ((index (ns:ns-range-location proposed)) - (length (ns:ns-range-length proposed))) - (when (and (eql 0 length) ; not extending existing selection - (not (eql g #$NSSelectByCharacter))) - (let* ((textstorage (#/textStorage self)) - (cache (hemlock-buffer-string-cache (#/string textstorage))) - (buffer (if cache (buffer-cache-buffer cache)))) - (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp")) - (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer))) - (hi::with-mark ((m1 (hi::buffer-point buffer))) - (move-hemlock-mark-to-absolute-position m1 cache index) - (hemlock::pre-command-parse-check m1) - (when (hemlock::valid-spot m1 nil) - (cond ((eql (hi::next-character m1) #\() - (hi::with-mark ((m2 m1)) - (when (hemlock::list-offset m2 1) - (ns:init-ns-range r index (- (mark-absolute-position m2) index)) - (return-from HANDLED r)))) - ((eql (hi::previous-character m1) #\)) - (hi::with-mark ((m2 m1)) - (when (hemlock::list-offset m2 -1) - (ns:init-ns-range r (mark-absolute-position m2) (- index (mark-absolute-position m2))) - (return-from HANDLED r)))))))))))) - (call-next-method proposed g) - #+debug - (#_NSLog #@"range = %@, proposed = %@, granularity = %d" - :address (#_NSStringFromRange r) - :address (#_NSStringFromRange proposed) - :electionranularity g)))) - - - - -;;; Translate a keyDown NSEvent to a Hemlock key-event. -(defun nsevent-to-key-event (nsevent) - (let* ((unmodchars (#/charactersIgnoringModifiers nsevent)) - (n (if (%null-ptr-p unmodchars) - 0 - (#/length unmodchars))) - (c (if (eql n 1) - (#/characterAtIndex: unmodchars 0)))) - (when c - (let* ((bits 0) - (modifiers (#/modifierFlags nsevent)) - (useful-modifiers (logandc2 modifiers - (logior #$NSShiftKeyMask - #$NSAlphaShiftKeyMask)))) - (dolist (map hemlock-ext::*modifier-translations*) - (when (logtest useful-modifiers (car map)) - (setq bits (logior bits (hemlock-ext::key-event-modifier-mask - (cdr map)))))) - (hemlock-ext::make-key-event c bits))))) - -(defun pass-key-down-event-to-hemlock (self event) - #+debug - (#_NSLog #@"Key down event = %@" :address event) - (let* ((buffer (text-view-buffer self))) - (when buffer - (let* ((q (hemlock-frame-event-queue (#/window self)))) - (hi::enqueue-key-event q (nsevent-to-key-event event)))))) - -(defun enqueue-buffer-operation (buffer thunk) - (dolist (w (hi::buffer-windows buffer)) - (let* ((q (hemlock-frame-event-queue (#/window w))) - (op (hi::make-buffer-operation :thunk thunk))) - (hi::event-queue-insert q op)))) - - -;;; Process a key-down NSEvent in a Hemlock text view by translating it -;;; into a Hemlock key event and passing it into the Hemlock command -;;; interpreter. - -(objc:defmethod (#/keyDown: :void) ((self hemlock-text-view) event) - (pass-key-down-event-to-hemlock self event)) - -;;; Update the underlying buffer's point (and "active region", if appropriate. -;;; This is called in response to a mouse click or other event; it shouldn't -;;; be called from the Hemlock side of things. - -(objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void) - ((self hemlock-text-view) - (r :ange) - (affinity :electionffinity) - (still-selecting :)) - #+debug - (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d" - :int (pref r :ange.location) - :int (pref r :ange.length) - :electionffinity affinity - : (if still-selecting #$YES #$NO)) - #+debug - (#_NSLog #@"text view string = %@, textstorage string = %@" - :id (#/string self) - :id (#/string (#/textStorage self))) - (unless (#/editingInProgress (#/textStorage self)) - (let* ((d (hemlock-buffer-string-cache (#/string self))) - (buffer (buffer-cache-buffer d)) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (point (hi::buffer-point buffer)) - (location (pref r :ange.location)) - (len (pref r :ange.length))) - (cond ((eql len 0) - #+debug - (#_NSLog #@"Moving point to absolute position %d" :int location) - (setf (hi::buffer-region-active buffer) nil) - (move-hemlock-mark-to-absolute-position point d location) - (update-blink self)) - (t - ;; We don't get much information about which end of the - ;; selection the mark's at and which end point is at, so - ;; we have to sort of guess. In every case I've ever seen, - ;; selection via the mouse generates a sequence of calls to - ;; this method whose parameters look like: - ;; a: range: {n0,0} still-selecting: false [ rarely repeats ] - ;; b: range: {n0,0) still-selecting: true [ rarely repeats ] - ;; c: range: {n1,m} still-selecting: true [ often repeats ] - ;; d: range: {n1,m} still-selecting: false [ rarely repeats ] - ;; - ;; (Sadly, "affinity" doesn't tell us anything interesting.) - ;; We've handled a and b in the clause above; after handling - ;; b, point references buffer position n0 and the - ;; region is inactive. - ;; Let's ignore c, and wait until the selection's stabilized. - ;; Make a new mark, a copy of point (position n0). - ;; At step d (here), we should have either - ;; d1) n1=n0. Mark stays at n0, point moves to n0+m. - ;; d2) n1+m=n0. Mark stays at n0, point moves to n0-m. - ;; If neither d1 nor d2 apply, arbitrarily assume forward - ;; selection: mark at n1, point at n1+m. - ;; In all cases, activate Hemlock selection. - (unless still-selecting - (let* ((pointpos (mark-absolute-position point)) - (selection-end (+ location len)) - (mark (hi::copy-mark point :right-inserting))) - (cond ((eql pointpos location) - (move-hemlock-mark-to-absolute-position point - d - selection-end)) - ((eql pointpos selection-end) - (move-hemlock-mark-to-absolute-position point - d - location)) - (t - (move-hemlock-mark-to-absolute-position mark - d - location) - (move-hemlock-mark-to-absolute-position point - d - selection-end))) - (hemlock::%buffer-push-buffer-mark buffer mark t))))))) - (call-next-method r affinity still-selecting)) - - - - -;;; Modeline-view - -;;; The modeline view is embedded in the horizontal scroll bar of the -;;; scrollview which surrounds the textview in a pane. (A view embedded -;;; in a scrollbar like this is sometimes called a "placard"). Whenever -;;; the view's invalidated, its drawRect: method draws a string containing -;;; the current values of the buffer's modeline fields. - -(defclass modeline-view (ns:ns-view) - ((pane :foreign-type :id :accessor modeline-view-pane)) - (:metaclass ns:+ns-object)) - - -;;; Attributes to use when drawing the modeline fields. There's no -;;; simple way to make the "placard" taller, so using fonts larger than -;;; about 12pt probably wouldn't look too good. 10pt Courier's a little -;;; small, but allows us to see more of the modeline fields (like the -;;; full pathname) in more cases. - -(defloadvar *modeline-text-attributes* nil) - -(def-cocoa-default *modeline-font-name* :string "Courier New Bold Italic" - "Name of font to use in modelines") -(def-cocoa-default *modeline-font-size* :float 10.0 "Size of font to use in modelines" (single-float 4.0 14.0)) - - -;;; Find the underlying buffer. -(defun buffer-for-modeline-view (mv) - (let* ((pane (modeline-view-pane mv))) - (unless (%null-ptr-p pane) - (let* ((tv (text-pane-text-view pane))) - (unless (%null-ptr-p tv) - (text-view-buffer tv)))))) - -;;; Draw a string in the modeline view. The font and other attributes -;;; are initialized lazily; apparently, calling the Font Manager too -;;; early in the loading sequence confuses some Carbon libraries that're -;;; used in the event dispatch mechanism, -(defun draw-modeline-string (the-modeline-view) - (let* ((pane (modeline-view-pane the-modeline-view)) - (buffer (buffer-for-modeline-view the-modeline-view))) - (when buffer - ;; You don't want to know why this is done this way. - (unless *modeline-text-attributes* - (setq *modeline-text-attributes* - (create-text-attributes :color (#/blackColor ns:ns-color) - :font (default-font - :name *modeline-font-name* - :size *modeline-font-size*)))) - (let* ((string - (apply #'concatenate 'string - (mapcar - #'(lambda (field) - (funcall (hi::modeline-field-function field) - buffer pane)) - (hi::buffer-modeline-fields buffer))))) - (#/drawAtPoint:withAttributes: (%make-nsstring string) - (ns:make-ns-point 0 0) - *modeline-text-attributes*))))) - -;;; Draw the underlying buffer's modeline string on a white background -;;; with a bezeled border around it. -(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :ect)) - (declare (ignorable rect)) - (let* ((frame (#/bounds self))) - (#_NSDrawWhiteBezel frame frame) - (draw-modeline-string self))) - -;;; Hook things up so that the modeline is updated whenever certain buffer -;;; attributes change. -(hi::%init-mode-redisplay) - - - -;;; Modeline-scroll-view - -;;; This is just an NSScrollView that draws a "placard" view (the modeline) -;;; in the horizontal scrollbar. The modeline's arbitrarily given the -;;; leftmost 75% of the available real estate. -(defclass modeline-scroll-view (ns:ns-scroll-view) - ((modeline :foreign-type :id :accessor scroll-view-modeline) - (pane :foreign-type :id :accessor scroll-view-pane)) - (:metaclass ns:+ns-object)) - -;;; Making an instance of a modeline scroll view instantiates the -;;; modeline view, as well. - -(objc:defmethod #/initWithFrame: ((self modeline-scroll-view) (frame :ect)) - (let* ((v (call-next-method frame))) - (when v - (let* ((modeline (make-instance 'modeline-view))) - (#/addSubview: v modeline) - (setf (scroll-view-modeline v) modeline))) - v)) - -;;; Scroll views use the "tile" method to lay out their subviews. -;;; After the next-method has done so, steal some room in the horizontal -;;; scroll bar and place the modeline view there. - -(objc:defmethod (#/tile :void) ((self modeline-scroll-view)) - (call-next-method) - (let* ((modeline (scroll-view-modeline self))) - (when (and (#/hasHorizontalScroller self) - (not (%null-ptr-p modeline))) - (let* ((hscroll (#/horizontalScroller self)) - (scrollbar-frame (#/frame hscroll)) - (modeline-frame (#/frame hscroll)) ; sic - (modeline-width (* (pref modeline-frame - :ect.size.width) - 0.75f0))) - (declare (type cgfloat modeline-width)) - (setf (pref modeline-frame :ect.size.width) - modeline-width - (the cgfloat - (pref scrollbar-frame :ect.size.width)) - (- (the cgfloat - (pref scrollbar-frame :ect.size.width)) - modeline-width) - (the cg-float - (pref scrollbar-frame :ect.origin.x)) - (+ (the cgfloat - (pref scrollbar-frame :ect.origin.x)) - modeline-width)) - (#/setFrame: hscroll scrollbar-frame) - (#/setFrame: modeline modeline-frame))))) - -;;; We want to constrain the scrolling that happens under program control, -;;; so that the clipview is always scrolled in character-sized increments. -#+doesnt-work-yet -(objc:defmethod (#/scrollClipView:toPoint: :void) - ((self modeline-scroll-view) - clip-view - (p :ns-point)) - #+debug - (#_NSLog #@"Scrolling to point %@" :id (#_NSStringFromPoint p)) - (let* ((char-height (#/verticalLineScroll self))) - (ns:with-ns-point (proposed (ns:ns-point-x p) (* char-height (round (ns:ns-point-y p) char-height))) - #+debug - (#_NSLog #@" Proposed point = %@" :id - (#_NSStringFromPoint proposed))) - (call-next-method clip-view proposed))) - - - - -;;; Text-pane - -;;; The text pane is just an NSBox that (a) provides a draggable border -;;; around (b) encapsulates the text view and the mode line. - -(defclass text-pane (ns:ns-box) - ((text-view :foreign-type :id :accessor text-pane-text-view) - (mode-line :foreign-type :id :accessor text-pane-mode-line) - (scroll-view :foreign-type :id :accessor text-pane-scroll-view)) - (:metaclass ns:+ns-object)) - -;;; Mark the pane's modeline as needing display. This is called whenever -;;; "interesting" attributes of a buffer are changed. - -(defun hi::invalidate-modeline (pane) - (#/setNeedsDisplay: (text-pane-mode-line pane) t)) - -(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane") -(def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane") - - -(objc:defmethod #/initWithFrame: ((self text-pane) (frame :ect)) - (let* ((pane (call-next-method frame))) - (unless (%null-ptr-p pane) - (#/setAutoresizingMask: pane (logior - #$NSViewWidthSizable - #$NSViewHeightSizable)) - (#/setBoxType: pane #$NSBoxPrimary) - (#/setBorderType: pane #$NSNoBorder) - (#/setContentViewMargins: pane (ns:make-ns-size *text-pane-margin-width* *text-pane-margin-height*)) - (#/setTitlePosition: pane #$NSNoTitle)) - pane)) - - -(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color) - (let* ((scrollview (#/autorelease - (make-instance - 'modeline-scroll-view - :with-frame (ns:make-ns-rect x y width height))))) - (#/setBorderType: scrollview #$NSBezelBorder) - (#/setHasVerticalScroller: scrollview t) - (#/setHasHorizontalScroller: scrollview t) - (#/setRulersVisible: scrollview nil) - (#/setAutoresizingMask: scrollview (logior - #$NSViewWidthSizable - #$NSViewHeightSizable)) - (#/setAutoresizesSubviews: (#/contentView scrollview) t) - (let* ((layout (make-instance 'ns:ns-layout-manager))) - (#/addLayoutManager: textstorage layout) - (#/release layout) - (let* ((contentsize (#/contentSize scrollview))) - (ns:with-ns-size (containersize large-number-for-text large-number-for-text) - (ns:with-ns-rect (tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) - (ns:init-ns-size containersize large-number-for-text large-number-for-text) - (ns:init-ns-rect tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) - (let* ((container (#/autorelease (make-instance - 'ns:ns-text-container - :with-container-size containersize)))) - (#/addTextContainer: layout container) - (let* ((tv (#/autorelease (make-instance 'hemlock-text-view - :with-frame tv-frame - :text-container container)))) - (#/setDelegate: layout tv) - (#/setMinSize: tv (ns:make-ns-size 0 (ns:ns-size-height contentsize))) - (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text)) - (#/setRichText: tv nil) - (#/setHorizontallyResizable: tv t) - (#/setVerticallyResizable: tv t) - (#/setAutoresizingMask: tv #$NSViewWidthSizable) - (#/setBackgroundColor: tv color) - (#/setSmartInsertDeleteEnabled: tv nil) - (#/setWidthTracksTextView: container tracks-width) - (#/setHeightTracksTextView: container nil) - (#/setDocumentView: scrollview tv) - (values tv scrollview))))))))) - -(defun make-scrolling-textview-for-pane (pane textstorage track-width color) - (let* ((contentrect (#/frame (#/contentView pane)))) - (multiple-value-bind (tv scrollview) - (make-scrolling-text-view-for-textstorage - textstorage - (ns:ns-rect-x contentrect) - (ns:ns-rect-y contentrect) - (ns:ns-rect-width contentrect) - (ns:ns-rect-height contentrect) - track-width - color) - (#/setContentView: pane scrollview) - (setf (slot-value pane 'scroll-view) scrollview - (slot-value pane 'text-view) tv - (slot-value tv 'pane) pane - (slot-value scrollview 'pane) pane) - (let* ((modeline (scroll-view-modeline scrollview))) - (setf (slot-value pane 'mode-line) modeline - (slot-value modeline 'pane) pane)) - tv))) - - -(defmethod hi::activate-hemlock-view ((view text-pane)) - (let* ((the-hemlock-frame (#/window view)) - (text-view (text-pane-text-view view))) - (#/makeFirstResponder: the-hemlock-frame text-view))) - - -(defclass echo-area-view (hemlock-textstorage-text-view) - () - (:metaclass ns:+ns-object)) - -(defmethod hi::activate-hemlock-view ((view echo-area-view)) - (let* ((the-hemlock-frame (#/window view))) - #+debug - (#_NSLog #@"Activating echo area") - (#/makeFirstResponder: the-hemlock-frame view))) - -(defmethod text-view-buffer ((self echo-area-view)) - (buffer-cache-buffer (hemlock-buffer-string-cache (#/string (#/textStorage self))))) - -;;; The "document" for an echo-area isn't a real NSDocument. -(defclass echo-area-document (ns:ns-object) - ((textstorage :foreign-type :id)) - (:metaclass ns:+ns-object)) - -(define-objc-method ((:void close) echo-area-document) - (let* ((ts (slot-value self 'textstorage))) - (unless (%null-ptr-p ts) - (setf (slot-value self 'textstorage) (%null-ptr)) - (close-hemlock-textstorage ts)))) - -(define-objc-method ((:void :update-change-count (:ocumenthangeype change)) echo-area-document) - (declare (ignore change))) - -(define-objc-method ((:void :key-down event) - echo-area-view) - (pass-key-down-event-to-hemlock self event)) - - -(defloadvar *hemlock-frame-count* 0) - -(defun make-echo-area (the-hemlock-frame x y width height gap-context color) - (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height)))) - (#/setAutoresizingMask: box #$NSViewWidthSizable) - (let* ((box-frame (#/bounds box)) - (containersize (ns:make-ns-size large-number-for-text (ns:ns-rect-height box-frame))) - (clipview (make-instance 'ns:ns-clip-view - :with-frame box-frame))) - (#/setAutoresizingMask: clipview (logior #$NSViewWidthSizable - #$NSViewHeightSizable)) - (#/setBackgroundColor: clipview color) - (#/addSubview: box clipview) - (#/setAutoresizesSubviews: box t) - (#/release clipview) - (let* ((buffer (hi:make-buffer (format nil "Echo Area ~d" - (prog1 - *hemlock-frame-count* - (incf *hemlock-frame-count*))) - :modes '("Echo Area"))) - (textstorage - (progn - (setf (hi::buffer-gap-context buffer) gap-context) - (make-textstorage-for-hemlock-buffer buffer))) - (doc (make-instance 'echo-area-document)) - (layout (make-instance 'ns:ns-layout-manager)) - (container (#/autorelease - (make-instance 'ns:ns-text-container - :with-container-size - containersize)))) - (#/addLayoutManager: textstorage layout) - (#/addTextContainer: layout container) - (#/release layout) - (let* ((echo (make-instance 'echo-area-view - :with-frame box-frame - :text-container container))) - (#/setMinSize: echo (pref box-frame :ect.size)) - (#/setMaxSize: echo (ns:make-ns-size large-number-for-text large-number-for-text)) - (#/setRichText: echo nil) - (#/setHorizontallyResizable: echo t) - (#/setVerticallyResizable: echo nil) - (#/setAutoresizingMask: echo #$NSViewNotSizable) - (#/setBackgroundColor: echo color) - (#/setWidthTracksTextView: container nil) - (#/setHeightTracksTextView: container nil) - (setf (hemlock-frame-echo-area-buffer the-hemlock-frame) buffer - (slot-value doc 'textstorage) textstorage - (hi::buffer-document buffer) doc) - (#/setDocumentView: clipview echo) - (#/setAutoresizesSubviews: clipview nil) - (#/sizeToFit echo) - (values echo box)))))) - -(defun make-echo-area-for-window (w gap-context-for-echo-area-buffer color) - (let* ((content-view (#/contentView w)) - (bounds (#/bounds content-view))) - (multiple-value-bind (echo-area box) - (make-echo-area w - 0.0f0 - 0.0f0 - (- (ns:ns-rect-width bounds) 24.0f0) - 20.0f0 - gap-context-for-echo-area-buffer - color) - (#/addSubview: content-view box) - echo-area))) - -(defclass hemlock-frame (ns:ns-window) - ((echo-area-view :foreign-type :id) - (event-queue :initform (ccl::init-dll-header (hi::make-frame-event-queue)) - :reader hemlock-frame-event-queue) - (command-thread :initform nil) - (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer) - (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream)) - (:metaclass ns:+ns-object)) - - -(defun double-%-in (string) - ;; Replace any % characters in string with %%, to keep them from - ;; being treated as printf directives. - (let* ((%pos (position #\% string))) - (if %pos - (concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos)))) - string))) - -(defun nsstring-for-lisp-condition (cond) - (%make-nsstring (double-%-in (princ-to-string cond)))) - -(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) info) - (let* ((message (#/objectAtIndex: info 0)) - (signal (#/objectAtIndex: info 1))) - (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title - (if (logbitp 0 (random 2)) - #@"Not OK, but what can you do?" - #@"The sky is falling. FRED never did this!") - +null-ptr+ - +null-ptr+ - self - self - (@selector #/sheetDidEnd:returnCode:contextInfo:) - (@selector #/sheetDidDismiss:returnCode:contextInfo:) - signal - message))) - -(objc:defmethod (#/sheetDidEnd:returnCode:contextInfo: :void) ((self hemlock-frame)) - (declare (ignore sheet code info))) - -(objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void) - ((self hemlock-frame) sheet code info) - (declare (ignore sheet code)) - (ccl::%signal-semaphore-ptr (%int-to-ptr (#/unsignedLongValue info)))) - -(defun report-condition-in-hemlock-frame (condition frame) - (let* ((semaphore (make-semaphore)) - (message (nsstring-for-lisp-condition condition)) - (sem-value (make-instance 'ns:ns-number - :with-unsigned-long (%ptr-to-int (semaphore.value semaphore))))) - (%stack-block ((paramptrs (ash 2 target::word-shift))) - (setf (%get-ptr paramptrs 0) message - (%get-ptr paramptrs (ash 1 target::word-shift)) sem-value) - (let* ((params (make-instance 'ns:ns-array - :with-objects paramptrs - :count 2)) - (*debug-io* *typeout-stream*)) - (stream-clear-output *debug-io*) - (print-call-history :detailed-p nil) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - frame (@selector #/runErrorSheet:) params t) - (wait-on-semaphore semaphore))))) - -(defun hi::report-hemlock-error (condition) - (report-condition-in-hemlock-frame condition (#/window (hi::current-window)))) - - -(defun hemlock-thread-function (q buffer pane echo-buffer echo-window) - (let* ((hi::*real-editor-input* q) - (hi::*editor-input* q) - (hi::*current-buffer* hi::*current-buffer*) - (hi::*current-window* pane) - (hi::*echo-area-window* echo-window) - (hi::*echo-area-buffer* echo-buffer) - (region (hi::buffer-region echo-buffer)) - (hi::*echo-area-region* region) - (hi::*echo-area-stream* (hi::make-hemlock-output-stream - (hi::region-end region) :full)) - (hi::*parse-starting-mark* - (hi::copy-mark (hi::buffer-point hi::*echo-area-buffer*) - :right-inserting)) - (hi::*parse-input-region* - (hi::region hi::*parse-starting-mark* - (hi::region-end region))) - (hi::*cache-modification-tick* -1) - (hi::*disembodied-buffer-counter* 0) - (hi::*in-a-recursive-edit* nil) - (hi::*last-key-event-typed* nil) - (hi::*input-transcript* nil) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (hemlock::*target-column* 0) - (hemlock::*last-comment-start* " ") - (hemlock::*last-search-string* ()) - (hemlock::*last-search-pattern* - (hemlock::new-search-pattern :string-insensitive :forward "Foo")) - ) - - (setf (hi::current-buffer) buffer) - (unwind-protect - (loop - (catch 'hi::editor-top-level-catcher - (handler-bind ((error #'(lambda (condition) - (hi::lisp-error-error-handler condition - :internal)))) - (hi::invoke-hook hemlock::abort-hook) - (hi::%command-loop)))) - (hi::invoke-hook hemlock::exit-hook)))) - - -(objc:defmethod (#/close :void) ((self hemlock-frame)) - (let* ((content-view (#/contentView self)) - (subviews (#/subviews content-view))) - (do* ((i (1- (#/count subviews)) (1- i))) - ((< i 0)) - (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i)))) - (let* ((proc (slot-value self 'command-thread))) - (when proc - (setf (slot-value self 'command-thread) nil) - (process-kill proc))) - (let* ((buf (hemlock-frame-echo-area-buffer self)) - (echo-doc (if buf (hi::buffer-document buf)))) - (when echo-doc - (setf (hemlock-frame-echo-area-buffer self) nil) - (#/close echo-doc))) - (release-canonical-nsobject self) - (call-next-method)) - -(defun new-hemlock-document-window () - (let* ((w (new-cocoa-window :class hemlock-frame - :activate nil))) - (values w (add-pane-to-window w :reserve-below 20.0)))) - - - -(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0)) - (let* ((window-content-view (#/contentView w)) - (window-frame (#/frame window-content-view))) - (ns:with-ns-rect (pane-rect 0 reserve-below (ns:ns-rect-width window-frame) (- (ns:ns-rect-height window-frame) (+ reserve-above reserve-below))) - (let* ((pane (make-instance 'text-pane :with-frame pane-rect))) - (#/addSubview: window-content-view pane) - pane)))) - -(defun textpane-for-textstorage (ts ncols nrows container-tracks-text-view-width color) - (let* ((pane (nth-value - 1 - (new-hemlock-document-window)))) - (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color) - (multiple-value-bind (height width) - (size-of-char-in-font (default-font)) - (size-text-pane pane height width nrows ncols)) - pane)) - - - - -(defun hemlock-buffer-from-nsstring (nsstring name &rest modes) - (let* ((buffer (make-hemlock-buffer name :modes modes))) - (nsstring-to-buffer nsstring buffer))) - -(defun %nsstring-to-mark (nsstring mark) - "returns external-format of string" - (let* ((string-len (#/length nsstring)) - (line-start 0) - (first-line-terminator ()) - (first-line (hi::mark-line mark)) - (previous first-line) - (buffer (hi::line-%buffer first-line)) - (hi::*buffer-gap-context* - (or - (hi::buffer-gap-context buffer) - (setf (hi::buffer-gap-context buffer) - (hi::make-buffer-gap-context))))) - (rlet ((remaining-range :ns-range :location 0 :length 1) - (line-end-index :nteger) - (contents-end-index :nteger)) - (do* ((number (+ (hi::line-number first-line) hi::line-increment) - (+ number hi::line-increment))) - ((= line-start string-len) - (let* ((line (hi::mark-line mark))) - (hi::insert-string mark (make-string 0)) - (setf (hi::line-next previous) line - (hi::line-previous line) previous)) - nil) - (setf (pref remaining-range :ange.location) line-start) - (#/getLineStart:end:contentsEnd:forRange: - nsstring - +null-ptr+ - line-end-index - contents-end-index - remaining-range) - (let* ((contents-end (pref contents-end-index :nteger)) - (line-end (pref line-end-index :nteger)) - (chars (make-string (- contents-end line-start)))) - (do* ((i line-start (1+ i)) - (j 0 (1+ j))) - ((= i contents-end)) - (setf (schar chars j) (code-char (#/characterAtIndex: nsstring i)))) - (unless first-line-terminator - (let* ((terminator (code-char - (#/characterAtIndex: nsstring contents-end)))) - (setq first-line-terminator - (case terminator - (#\return (if (= line-end (+ contents-end 2)) - :cp/m - :macos)) - (t :unix))))) - (if (eq previous first-line) - (progn - (hi::insert-string mark chars) - (hi::insert-character mark #\newline) - (setq first-line nil)) - (if (eq string-len contents-end) - (hi::insert-string mark chars) - (let* ((line (hi::make-line - :previous previous - :%buffer buffer - :chars chars - :number number))) - (setf (hi::line-next previous) line) - (setq previous line)))) - (setq line-start line-end)))) - first-line-terminator)) - -(defun nsstring-to-buffer (nsstring buffer) - (let* ((document (hi::buffer-document buffer)) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (region (hi::buffer-region buffer))) - (setf (hi::buffer-document buffer) nil) - (unwind-protect - (progn - (hi::delete-region region) - (hi::modifying-buffer buffer) - (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting)) - (setf (hi::buffer-external-format buffer) - (%nsstring-to-mark nsstring mark))) -) - (setf (hi::buffer-modified buffer) nil) - (hi::buffer-start (hi::buffer-point buffer)) - (hi::renumber-region region) - buffer) - (setf (hi::buffer-document buffer) document))) - -;;; This assumes that the buffer has no document and no textstorage (yet). -(defun hi::cocoa-read-file (lisp-pathname mark buffer) - (let* ((lisp-namestring (native-translated-namestring lisp-pathname)) - (cocoa-pathname (%make-nsstring lisp-namestring)) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (data (make-instance 'ns:ns-data - :with-contents-of-file cocoa-pathname)) - (string (make-instance 'ns:ns-string - :with-data data - :encoding #$NSASCIIStringEncoding)) - (external-format (%nsstring-to-mark string mark))) - (unless (hi::buffer-external-format buffer) - (setf (hi::buffer-external-format buffer) external-format)) - buffer)) - - - - -(setq hi::*beep-function* #'(lambda (stream) - (declare (ignore stream)) - (#_NSBeep))) - - -;;; This function must run in the main event thread. -(defun %hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width color) - (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width color)) - (frame (#/window pane)) - (buffer (text-view-buffer (text-pane-text-view pane)))) - (setf (slot-value frame 'echo-area-view) - (make-echo-area-for-window frame (hi::buffer-gap-context buffer) color)) - (setf (slot-value frame 'command-thread) - (process-run-function (format nil "Hemlock window thread") - #'(lambda () - (hemlock-thread-function - (hemlock-frame-event-queue frame) - buffer - pane - (hemlock-frame-echo-area-buffer frame) - (slot-value frame 'echo-area-view))))) - frame)) - - - - -(defun hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width color) - (process-interrupt *cocoa-event-process* - #'%hemlock-frame-for-textstorage - ts ncols nrows container-tracks-text-view-width color)) - - - -(defun hi::lock-buffer (b) - (grab-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b)))) - -(defun hi::unlock-buffer (b) - (release-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b)))) - -(defun hi::document-begin-editing (document) - #-all-in-cocoa-thread - (#/beginEditing (slot-value document 'textstorage)) - #+all-in-cocoa-thread - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (slot-value document 'textstorage) - (@selector #/beginEditing) - +null-ptr+ - t)) - -(defun document-edit-level (document) - (slot-value (slot-value document 'textstorage) 'edit-count)) - -(defun hi::document-end-editing (document) - #-all-in-cocoa-thread - (#/endEditing (slot-value document 'textstorage)) - #+all-in-cocoa-thread - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (slot-value document 'textstorage) - (@selector #/endEditing) - +null-ptr+ - t)) - -(defun hi::document-set-point-position (document) - (declare (ignorable document)) - #+debug - (#_NSLog #@"Document set point position called") - (let* ((textstorage (slot-value document 'textstorage))) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - textstorage (@selector #/updateHemlockSelection) +null-ptr+ t))) - - - -(defun perform-edit-change-notification (textstorage selector pos n) - (let* ((number-for-pos - (#/initWithLong: (#/alloc ns:ns-number) pos)) - (number-for-n - (#/initWithLong: (#/alloc ns:ns-number) n))) - (rlet ((paramptrs (:array :id 2))) - (setf (paref paramptrs (:* :id) 0) number-for-pos - (paref paramptrs (:* :id) 1) number-for-n) - (let* ((params (#/initWithObjects:count: (#/alloc ns:ns-array) paramptrs 2))) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - textstorage selector params t) - (#/release params) - (#/release number-for-n) - (#/release number-for-pos))))) - -(defun textstorage-note-insertion-at-position (textstorage pos n) - #+debug - (#_NSLog #@"insertion at position %d, len %d" :int pos :int n) - (#/edited:range:changeInLength: - textstorage #$NSTextStorageEditedAttributes (ns:make-ns-range pos 0) n) - (#/edited:range:changeInLength: - textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) 0)) - - -(defun hi::buffer-note-font-change (buffer region) - (when (hi::bufferp buffer) - (let* ((document (hi::buffer-document buffer)) - (textstorage (if document (slot-value document 'textstorage))) - (pos (mark-absolute-position (hi::region-start region))) - (n (- (mark-absolute-position (hi::region-end region)) pos))) - (perform-edit-change-notification textstorage - (@selector #/noteAttrChange:) - pos - n)))) - -(defun hi::buffer-note-insertion (buffer mark n) - (when (hi::bufferp buffer) - (let* ((document (hi::buffer-document buffer)) - (textstorage (if document (slot-value document 'textstorage)))) - (when textstorage - (let* ((pos (mark-absolute-position mark))) - (unless (eq (hi::mark-%kind mark) :right-inserting) - (decf pos n)) - #+debug - (format t "~&insert: pos = ~d, n = ~d" pos n) - (let* ((display (hemlock-buffer-string-cache (#/string textstorage)))) - ;(reset-buffer-cache display) - (adjust-buffer-cache-for-insertion display pos n) - (update-line-cache-for-index display pos)) - #-all-in-cocoa-thread - (textstorage-note-insertion-at-position textstorage pos n) - #+all-in-cocoa-thread - (perform-edit-change-notification textstorage - (@selector "noteInsertion:") - pos - n)))))) - -(defun hi::buffer-note-modification (buffer mark n) - (when (hi::bufferp buffer) - (let* ((document (hi::buffer-document buffer)) - (textstorage (if document (slot-value document 'textstorage)))) - (when textstorage - #+debug - (#_NSLog #@"enqueue modify: pos = %d, n = %d" - :int (mark-absolute-position mark) - :int n) - #-all-in-cocoa-thread - (#/edited:range:changeInLength: - textstorage - (logior #$NSTextStorageEditedCharacters - #$NSTextStorageEditedAttributes) - (ns:make-ns-range (mark-absolute-position mark) n) - 0) - #+all-in-cocoa-thread - (perform-edit-change-notification textstorage - (@selector #/noteModification:) - (mark-absolute-position mark) - n))))) - - -(defun hi::buffer-note-deletion (buffer mark n) - (when (hi::bufferp buffer) - (let* ((document (hi::buffer-document buffer)) - (textstorage (if document (slot-value document 'textstorage)))) - (when textstorage - #-all-in-cocoa-thread - (let* ((pos (mark-absolute-position mark))) - (#/edited:range:changeInLength: - textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n)) - (let* ((display (hemlock-buffer-string-cache (#/string textstorage)))) - (reset-buffer-cache display) - (update-line-cache-for-index display pos))) - #+all-in-cocoa-thread - (perform-edit-change-notification textstorage - (@selector #/noteDeletion:) - (mark-absolute-position mark) - (abs n)))))) - -(defun hi::set-document-modified (document flag) - (#/updateChangeCount: document (if flag #$NSChangeDone #$NSChangeCleared))) - - -(defmethod hi::document-panes ((document t)) - ) - - - - - -(defun size-of-char-in-font (f) - (let* ((sf (#/screenFont f)) - (screen-p t)) - (if (%null-ptr-p sf) (setq sf f screen-p nil)) - (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager))))) - (#/setUsesScreenFonts: layout screen-p) - (values (fround (#/defaultLineHeightForFont: layout sf)) - (fround (ns:ns-size-width (#/advancementForGlyph: sf (#/glyphWithName: sf #@" ")))))))) - - - -(defun size-text-pane (pane char-height char-width nrows ncols) - (let* ((tv (text-pane-text-view pane)) - (height (fceiling (* nrows char-height))) - (width (fceiling (* ncols char-width))) - (scrollview (text-pane-scroll-view pane)) - (window (#/window scrollview)) - (has-horizontal-scroller (#/hasHorizontalScroller scrollview)) - (has-vertical-scroller (#/hasVerticalScroller scrollview))) - (ns:with-ns-size (tv-size - (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv)))) - height) - (when has-vertical-scroller - (#/setVerticalLineScroll: scrollview char-height) - (#/setVerticalPageScroll: scrollview +cgfloat-zero+ #|char-height|#)) - (when has-horizontal-scroller - (#/setHorizontalLineScroll: scrollview char-width) - (#/setHorizontalPageScroll: scrollview +cgfloat-zero+ #|char-width|#)) - (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview))) - (pane-frame (#/frame pane)) - (margins (#/contentViewMargins pane))) - (incf (ns:ns-size-height sv-size) - (+ (ns:ns-rect-y pane-frame) - (* 2 (ns:ns-size-height margins)))) - (incf (ns:ns-size-width sv-size) - (ns:ns-size-width margins)) - (#/setContentSize: window sv-size) - (#/setResizeIncrements: window - (ns:make-ns-size char-width char-height)))))) - - -(defclass hemlock-editor-window-controller (ns:ns-window-controller) - () - (:metaclass ns:+ns-object)) - - - -;;; The HemlockEditorDocument class. - - -(defclass hemlock-editor-document (ns:ns-document) - ((textstorage :foreign-type :id)) - (:metaclass ns:+ns-object)) - -(defmethod textview-background-color ((doc hemlock-editor-document)) - (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color - (float *editor-background-red-component* - +cgfloat-zero+) - (float *editor-background-green-component* +cgfloat-zero+) - (float *editor-background-blue-component* +cgfloat-zero+) - (float *editor-background-alpha-component* +cgfloat-zero+))) - - -(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts) - (let* ((doc (%inc-ptr self 0)) ; workaround for stack-consed self - (string (#/string ts)) - (cache (hemlock-buffer-string-cache string)) - (buffer (buffer-cache-buffer cache))) - (unless (%null-ptr-p doc) - (setf (slot-value doc 'textstorage) ts - (hi::buffer-document buffer) doc)))) - -;; This runs on the main thread. -(objc:defmethod (#/revertToSavedFromFile:ofType: :) - ((self hemlock-editor-document) filename filetype) - (declare (ignore filetype)) - #+debug - (#_NSLog #@"revert to saved from file %@ of type %@" - :id filename :id filetype) - (let* ((data (make-instance ns:ns-data - :with-contents-of-file filename)) - (nsstring (make-instance ns:ns-string - :with-data data - :encoding #$NSASCIIStringEncoding)) - (buffer (hemlock-document-buffer self)) - (old-length (hemlock-buffer-length buffer)) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (textstorage (slot-value self 'textstorage)) - (point (hi::buffer-point buffer)) - (pointpos (mark-absolute-position point))) - (#/beginEditing textstorage) - (#/edited:range:changeInLength: - textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length)) - (nsstring-to-buffer nsstring buffer) - (let* ((newlen (hemlock-buffer-length buffer))) - (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen) - (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0) - (let* ((ts-string (#/string textstorage)) - (display (hemlock-buffer-string-cache ts-string))) - (reset-buffer-cache display) - (update-line-cache-for-index display 0) - (move-hemlock-mark-to-absolute-position point - display - (min newlen pointpos)))) - (#/endEditing textstorage) - (hi::document-set-point-position self) - (setf (hi::buffer-modified buffer) nil) - (hi::queue-buffer-change buffer) - t)) - - - -(objc:defmethod #/init ((self hemlock-editor-document)) - (let* ((doc (call-next-method))) - (unless (%null-ptr-p doc) - (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer - (make-hemlock-buffer - (lisp-string-from-nsstring - (#/displayName doc)) - :modes '("Lisp" "Editor"))))) - doc)) - -(objc:defmethod (#/readFromFile:ofType: :) - ((self hemlock-editor-document) filename type) - (declare (ignorable type)) - (let* ((pathname (lisp-string-from-nsstring filename)) - (buffer-name (hi::pathname-to-buffer-name pathname)) - (buffer (or - (hemlock-document-buffer self) - (let* ((b (make-hemlock-buffer buffer-name))) - (setf (hi::buffer-pathname b) pathname) - (setf (slot-value self 'textstorage) - (make-textstorage-for-hemlock-buffer b)) - b))) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (data (make-instance 'ns:ns-data :with-contents-of-file filename)) - (string (make-instance 'ns:ns-string - :with-data data - :encoding #$NSASCIIStringEncoding))) - (hi::document-begin-editing self) - (nsstring-to-buffer string buffer) - (let* ((textstorage (slot-value self 'textstorage)) - (display (hemlock-buffer-string-cache (#/string textstorage)))) - (reset-buffer-cache display) - (update-line-cache-for-index display 0) - (textstorage-note-insertion-at-position - textstorage - 0 - (hemlock-buffer-length buffer))) - (hi::document-end-editing self) - (setf (hi::buffer-modified buffer) nil) - (hi::process-file-options buffer pathname) - t)) - -#+experimental -(objc:defmethod (#/writeWithBackupToFile:ofType:saveOperation: :) - ((self hemlock-editor-document) path type (save-operation :aveperationype)) - #+debug - (#_NSLog #@"saving file to %@" :id path) - (call-next-method path type save-operation)) - -;;; This should be a preference. -(objc:defmethod (#/keepBackupFile :) ((self hemlock-editor-document)) - t) - - -(defmethod hemlock-document-buffer (document) - (let* ((string (#/string (slot-value document 'textstorage)))) - (unless (%null-ptr-p string) - (let* ((cache (hemlock-buffer-string-cache string))) - (when cache (buffer-cache-buffer cache)))))) - -(defmethod hi::document-panes ((document hemlock-editor-document)) - (let* ((ts (slot-value document 'textstorage)) - (panes ())) - (for-each-textview-using-storage - ts - #'(lambda (tv) - (let* ((pane (text-view-pane tv))) - (unless (%null-ptr-p pane) - (push pane panes))))) - panes)) - -(objc:defmethod #/dataRepresentationOfType: ((self hemlock-editor-document) - type) - (declare (ignorable type)) - (let* ((buffer (hemlock-document-buffer self))) - (when buffer - (setf (hi::buffer-modified buffer) nil))) - (#/dataUsingEncoding:allowLossyConversion: - (#/string (slot-value self 'textstorage)) #$NSASCIIStringEncoding t)) - - -;;; Shadow the setFileName: method, so that we can keep the buffer -;;; name and pathname in synch with the document. -(objc:defmethod (#/setFileName: :void) ((self hemlock-editor-document) - full-path) - (call-next-method full-path) - (let* ((buffer (hemlock-document-buffer self))) - (when buffer - (let* ((new-pathname (lisp-string-from-nsstring full-path))) - (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname)) - (setf (hi::buffer-pathname buffer) new-pathname))))) - - -(def-cocoa-default *initial-editor-x-pos* :float 200.0f0 "X position of upper-left corner of initial editor") - -(def-cocoa-default *initial-editor-y-pos* :float 400.0f0 "Y position of upper-left corner of initial editor") - -(defloadvar *next-editor-x-pos* nil) ; set after defaults initialized -(defloadvar *next-editor-y-pos* nil) - -(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document)) - #+debug - (#_NSLog #@"Make window controllers") - (let* ((window (%hemlock-frame-for-textstorage - (slot-value self 'textstorage) - *editor-columns* - *editor-rows* - nil - (textview-background-color self))) - (controller (make-instance - 'hemlock-editor-window-controller - :with-window window))) - (#/addWindowController: self controller) - (#/release controller) - (ns:with-ns-point (current-point - (or *next-editor-x-pos* - *initial-editor-x-pos*) - (or *next-editor-y-pos* - *initial-editor-y-pos*)) - (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point))) - (setq *next-editor-x-pos* (ns:ns-point-x new-point) - *next-editor-y-pos* (ns:ns-point-y new-point)))))) - - -(objc:defmethod (#/close :void) ((self hemlock-editor-document)) - #+debug - (#_NSLog #@"Document close: %@" :id self) - (let* ((textstorage (slot-value self 'textstorage))) - (unless (%null-ptr-p textstorage) - (setf (slot-value self 'textstorage) (%null-ptr)) - (for-each-textview-using-storage - textstorage - #'(lambda (tv) - (let* ((layout (#/layoutManager tv))) - (#/setBackgroundLayoutEnabled: layout nil)))) - (close-hemlock-textstorage textstorage))) - (call-next-method)) - - -(defun initialize-user-interface () - (#/sharedPanel preferences-panel) - (update-cocoa-defaults) - (make-editor-style-map)) - -(defun hi::scroll-window (textpane n) - (declare (ignore textpane)) - (let* ((point (hi::current-point))) - (or (hi::line-offset point (if (and n (< n 0)) -24 24) 0)))) - -(defmethod hemlock::center-text-pane ((pane text-pane)) - (#/centerSelectionInVisibleArea: (text-pane-text-view pane) +null-ptr+)) - - -(defun hi::open-document () - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (#/sharedDocumentController ns:ns-document-controller) - (@selector #/openDocument:) +null-ptr+ t)) - -(defmethod hi::save-hemlock-document ((self hemlock-editor-document)) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - self (@selector #/saveDocument:) +null-ptr+ t)) - - -(defmethod hi::save-hemlock-document-as ((self hemlock-editor-document)) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - self (@selector #/saveDocumentAs:) +null-ptr+ t)) - -;;; This needs to run on the main thread. -(objc:defmethod (#/updateHemlockSelection :void) ((self hemlock-text-storage)) - (let* ((string (#/string self)) - (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string))) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) - (point (hi::buffer-point buffer)) - (pointpos (mark-absolute-position point)) - (location pointpos) - (len 0)) - (when (hemlock::%buffer-region-active-p buffer) - (let* ((mark (hi::buffer-%mark buffer))) - (when mark - (let* ((markpos (mark-absolute-position mark))) - (if (< markpos pointpos) - (setq location markpos len (- pointpos markpos)) - (if (< pointpos markpos) - (setq location pointpos len (- markpos pointpos)))))))) - #+debug - (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d" - :int (hi::mark-charpos point) :int pos) - (for-each-textview-using-storage - self - #'(lambda (tv) - (#/updateSelection:length:affinity: tv location len (if (eql location 0) #$NSSelectionAffinityUpstream #$NSSelectionAffinityDownstream)))))) - - -(defun hi::allocate-temporary-object-pool () - (create-autorelease-pool)) - -(defun hi::free-temporary-objects (pool) - (release-autorelease-pool pool)) - -(provide "COCOA-EDITOR") Index: unk/ccl/examples/cocoa-inspector.lisp =================================================================== --- /trunk/ccl/examples/cocoa-inspector.lisp (revision 6894) +++ (revision ) @@ -1,458 +1,0 @@ -(in-package "CCL") - -#| -(cinspect ) - -A cocoa-based lisp inspector, LGPL'ed by Hamilton Link - -This code is freely distributable, etc. but I would appreciate people -submitting changes back to me and making suggestions about how it -could be altered or improved to me rather than starting a totally -separate inspector. - -Major plans: - Shift all the browser columns over to allow the first column to just have the object - Make double-clicking an object bring any existing inspector for that object to the front unless shift key is held - -Minor tweaks: - test on all sorts of things for sanity of leaf-ness of nodes and fields - test on all sorts of things for santity in what's safely editable in table view - fix the leaf-ness fields with a macptr value - change the font to something smaller (or even better, be settable) - clean up this file, maybe make a dedicated cinspector package for such things - document lessons learned about NSBrowser and NSTableView for next time - -Bugs: - - when selecting a non-item in a lower column that was just being - displayed (in the NSBrowser), the tableview isn't cleared and it - probably should be. - - Possibly a reasonable next thing after that would be to make control- -or alt-double-clicking open new windows with other browsing metaphors -appropriate to the object (like a class heirarchy browser, maybe a -table view for matrices, etc.), we'll see. - Eventually I'd like to expand the whole inspector functionality to -deal with ObjC things (methods and objects) and C foreign data in -general, but that's further off unless someone wants to take a crack -at it. Once we know we've got a macptr into ObjC we can deal, but some -very carefully written functions need to exist to safely interrogate -a random pointer to make that determination. - -Note the variable name convention in this file: "cinspector" refers to -a cocoa-inspector object containing a set of objects being displayed, -while "inspector" refers to an inspector object from the :inspector -package, which are used for command-line inspecting. - -|# - - -#| -I'd rather set up this file to be -- in-package cl-user -- require of some things -- a package definition for this code that brings in inspector::this-and-that and ccl::objc-stuff -- a couple of load-file forms that populate the new package and have the bulk of the following code -|# - -(require "COCOA") - -;;; This is useful when @ won't work, dynamically creating a NSString -;;; pointer from a string. - -(defun nsstringptr (string) - (objc-constant-string-nsstringptr - (ns-constant-string string))) - -#+old -(defmacro handler-case-for-cocoa (id form) - (declare (ignorable id)) - `(handler-case - ,form - (condition (c) - (declare (ignorable c)) - #+ignore - (format t "~s: Trapping condition: ~a" ,id c) - nil))) - -; for now this will map windows to objects -- the windows are pretty big, -; though, so it would be nice to extend them so the list of inspected objects -; is switchable in a single window (shouldn't be too hard once basic functionality -; is slapped down) -(defparameter *cocoa-inspector-nswindows-table* (make-hash-table :test 'eql)) - -; this is what a window should map to - an object that manages all the data a window might be displaying -(defclass cocoa-inspector () - ((object-vector :initform (make-array 0 :adjustable t :fill-pointer 0) :accessor object-vector) - (inspector-vector :initform (make-array 0 :adjustable t :fill-pointer 0) :accessor inspector-vector) - (focal-point :initform 0 :accessor focal-point))) - -;; note that ELT pays attention to the fill pointer, while AREF doesn't! -(defmethod object ((cinspector cocoa-inspector)) - (elt (object-vector cinspector) (focal-point cinspector))) -(defmethod nth-object ((cinspector cocoa-inspector) n) - (elt (object-vector cinspector) n)) -(defmethod inspector ((cinspector cocoa-inspector)) - (elt (inspector-vector cinspector) (focal-point cinspector))) -(defmethod nth-inspector ((cinspector cocoa-inspector) n) - (elt (inspector-vector cinspector) n)) -(defmethod push-object (object (cinspector cocoa-inspector)) - (let ((inspector (inspector::make-inspector object))) - (vector-push-extend object (object-vector cinspector)) - (vector-push-extend inspector (inspector-vector cinspector)) - (inspector::update-line-count inspector)) - #+ignore - (format t " after push-object, fill pointers = ~a ~a~%" - (fill-pointer (object-vector cinspector)) (fill-pointer (inspector-vector cinspector))) - object) -(defmethod (setf max-column) (value (cinspector cocoa-inspector)) - (when (and (numberp value) (<= 0 value (1- (fill-pointer (object-vector cinspector))))) - (setf ; new fill-pointers are just outside of the valid bounds - (fill-pointer (object-vector cinspector)) (1+ value) - (fill-pointer (inspector-vector cinspector)) (1+ value) - ; new focal point is either what it was before, or the new max column if that's smaller - (focal-point cinspector) (min value (focal-point cinspector))) - #+ignore - (format t " after (setf max-column), fill pointers = ~a ~a~%" - (fill-pointer (object-vector cinspector)) (fill-pointer (inspector-vector cinspector))) - value)) - -;; In the browser view, we'll find the element for some column -;; and consider whether any of its components merit further inspection -;; and, if so, which ones -(defmethod leaf-node-p ((thing t)) nil) -(defmethod leaf-node-p ((thing (eql t))) t) -(defmethod leaf-node-p ((thing null)) t) -(defmethod leaf-node-p ((thing number)) t) -(defmethod leaf-node-p ((thing string)) t) -(defmethod leaf-node-p ((thing inspector::unbound-marker)) t) -(defmethod leaf-field-p ((thing t) n) - (declare (ignore n)) - nil) ; for a non-leaf node, all fields are futher probable by default -(defmethod leaf-field-p ((thing symbol) n) - (when (and (keywordp thing) (= n 4)) t)) - -; whatever is currently the selected object in the inspector, get its -; properties and values for the tableView and print them to a string -(defun focus-nth-line (cinspector n) - (let* ((inspector (inspector cinspector)) - (*print-circle* t) - (output-stream (make-string-output-stream))) - (inspector::prin1-line-n inspector output-stream n) - (get-output-stream-string output-stream))) -(defun nth-object-nth-line (cinspector obj-n line-n) - (let* ((inspector (nth-inspector cinspector obj-n)) - (*print-circle* t) - (output-stream (make-string-output-stream))) - (inspector::prin1-line-n inspector output-stream line-n) - (get-output-stream-string output-stream))) -(defun focus-nth-property (cinspector n) - (let ((inspector (inspector cinspector))) - (multiple-value-bind (value label type) (inspector::line-n inspector n) - (declare (ignore value type)) - (if label - (format nil "~a" label) - "")))) -(defun focus-nth-value (cinspector n) - (let* ((inspector (inspector cinspector)) - (*print-circle* t) - (output-stream (make-string-output-stream)) - (*package* (find-package :cl-user))) - (multiple-value-bind (value label type) (inspector::line-n inspector n) - (declare (ignore label type)) - (format output-stream "~s" value)) - (get-output-stream-string output-stream))) -(defun nth-object-nth-value (cinspector obj-n line-n) - (let ((inspector (nth-inspector cinspector obj-n))) - (multiple-value-bind (value label type) (inspector::line-n inspector line-n) - (declare (ignore label type)) - value))) -(defun (setf focus-nth-value) (value cinspector n) - (let ((inspector (inspector cinspector))) - (setf (inspector::line-n inspector n) value))) -(defun focus-nth-value-editable (cinspector n) - (let ((inspector (inspector cinspector))) - (multiple-value-bind (value label type) (inspector::line-n inspector n) - (declare (ignore value)) - (and (or (null type) - (eq :normal type) - (eq :colon type)) - (editable-field-p (object cinspector) n label))))) -(defun nth-object-nth-value-editable (cinspector obj-n line-n) - (let ((inspector (nth-inspector cinspector obj-n))) - (multiple-value-bind (value label type) (inspector::line-n inspector line-n) - (declare (ignore value)) - (and (or (null type) - (eq :normal type) - (eq :colon type)) - (editable-field-p (nth-object cinspector obj-n) line-n label))))) -;; for now most of these will assume that field numbers are good enough, -;; certain things have inspector fields that move around (like symbols) -;; and can be dealt with on a case by case basis, but that's the reason -;; for passing in the label along with the field number -(defmethod editable-field-p ((thing t) n label) - (declare (ignore n label)) - t) -;; for lists field 4 is length, could cause a change but inspector doesn't just handle it -;; and at the moment I haven't started thinking of a framework for allowing such extensions -(defmethod editable-field-p ((thing list) n label) - (declare (ignore label)) - (/= n 4)) - -#| -I think most of the following should be pretty straightforward for -most utilities meant to run under openmcl: A NIB file, some delegates -and data sources, and some specialized callback functions for talking -with the ObjC world, and some standard code for keeping track of the -appropriate windows. -hel -|# - -; When loading a NIB file with an NSWindowController, DON'T omit the .nib extension -; if you're calling initWithWindowNibPath:owner: (even though the documentation says you should!) -#+ignore -(defparameter *default-inspector-nib-pathname* #p"CCL:OpenMCL.app;Contents;Resources;English.lproj;OpenmclInspector.nib") -; When loading it with a custom WindowController and initWithWindowNibName:, just the main file name -(defparameter *default-inspector-nib-pathname* #p"OpenmclInspector") - -;; Q: Is this subclass of NSBrowser enabling the doubleAction? I added it expecting to have to -;; specialize mouseDown (or whatever) to track double-clicking, but it just started working. -(defclass inspector-ns-browser (ns:ns-browser) ; just to specialize mousing, not add slots - () - (:metaclass ns:+ns-object)) - -(defclass inspector-window-controller (ns:ns-window-controller) - ((inspector-browser :foreign-type :id :reader inspector-browser)) - (:metaclass ns:+ns-object)) - -(defclass inspector-browser-delegate (ns:ns-object) - ((inspector-table-view :foreign-type :id :reader inspector-table-view) - (inspector-window :foreign-type :id :reader inspector-window)) - (:metaclass ns:+ns-object)) - -; why is the order of these two slots important? -; I get a segfault selecting the browser when they're in window/browser order after doing modifications in the table. -(defclass inspector-table-view-data-source (ns:ns-object) - ((inspector-browser :foreign-type :id :reader inspector-browser) - (inspector-window :foreign-type :id :reader inspector-window)) - (:metaclass ns:+ns-object)) - -(defclass inspector-table-view-delegate (ns:ns-object) - ((inspector-window :foreign-type :id :reader inspector-window)) - (:metaclass ns:+ns-object)) - - -;;; is there some reason this is called before the cell is actually -;;; selected? In any case, when a non-leaf cell is selected, this -;;; function is called first for the new column, so it has to push the -;;; new element into the cinspector -- what the browserAction will be -;;; left doing it remains to be seen. The only other time this is -;;; called AFAICT is when loadColumnZero or reloadColumn is called -(objc:defmethod (#/browser:numberOfRowsInColumn: :nteger) - ((self inspector-browser-delegate) - browser - (column :nteger)) - (or (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) - (selected-column (#/selectedColumn browser)) ; probably always (1- column), when a column is selected - (cinspector-column (1- selected-column)) ; 2nd column of nsbrowser <-> 1st column of cinspector - (row (#/selectedRowInColumn: browser selected-column))) - #+ignore - (format t "getting length of column ~d based on row ~d in column ~d~%" column row selected-column) - (cond ((not cinspector) 0) - ((= column 0) 1) ; just displaying the printed representaiton of the top inspected object - ((= selected-column 0) ; selected the printed rep of the inspected object (column should = 1) - (setf (max-column cinspector) 0) ; crop object-vector in cinspector - (let ((inspector (nth-inspector cinspector 0))) ; inspector for top object - (inspector::inspector-line-count inspector))) - ((>= selected-column 1) ; (-1 is the N/A column) - (setf (max-column cinspector) cinspector-column) ; crop object-vector in cinspector - (push-object (nth-object-nth-value cinspector cinspector-column row) cinspector) - (let ((inspector (nth-inspector cinspector (1+ cinspector-column)))) ; inspector for object just pushed - (inspector::inspector-line-count inspector))))) - 0)) - -#| -;; temporarily saved in case the above fails horribly - (if cinspector - (handler-case - (progn (when (<= 0 selected-column) ; -1 is sort of the N/A column - (setf (max-column cinspector) selected-column) - (push-object (nth-object-nth-value cinspector selected-column row) cinspector)) - (let ((inspector (nth-inspector cinspector column))) - (inspector::inspector-line-count inspector))) - (condition () 0)) - 0))) -|# - -;; In the following method defn this is unnecessary, the Browser can tell this for itself -;; [cell "setLoaded:" : #$YES] -(objc:defmethod (#/browser:willDisplayCell:atRow:column: :void) - ((self inspector-browser-delegate) - browser - cell - (row :nteger) - (column :nteger)) - (declare (ignorable browser column)) - (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) - (cinspector-column (1- column))) ; 2nd column of nsbrowser <-> 1st column of cinspector - #+ignore - (format t "asking for value for column ~a, row ~a~%" column row) - (cond ((not cinspector) nil) - ((= column 0) - (#/setStringValue: cell (nsstringptr (format nil "~s" (nth-object cinspector 0)))) - (#/setLeaf: cell nil)) - (t - ;; when switching between widgets to the browser, we can - ;; have reloaded a column and need to drill down a row - ;; from where we are at the moment - (#/setStringValue: cell (nsstringptr (nth-object-nth-line cinspector cinspector-column row))) - ;; leaf-p should really consider the type of the object in - ;; question (eventually taking into account whether we're - ;; browsing the class heirarchy or into objc or whatever) - (#/setLeaf: cell (or (leaf-node-p (nth-object cinspector cinspector-column)) ; i.e. no fields drill down - (leaf-field-p (nth-object cinspector cinspector-column) row) - ;; for now... - (= row 0) - (not (nth-object-nth-value-editable cinspector cinspector-column row)))))))) - -;;; when all is said and done and once the cinspector is properly -;;; populated, the selected object in the browser's nth column is -;;; actually the object in the cinspector's nth column (i.e. because -;;; the selected object is displayed in the next browser column over, -;;; and the cinspector and nsbrowser have a 1-off discrepancy, they -;;; cancel out) -- just a note to make the difference between these -;;; next two functions and the previous two functions - -;;; change the focus of the the table view to be the selected object -(objc:defmethod (#/browserAction: :void) - ((self inspector-browser-delegate) - sender); don't know why I'd want to, but could use a separate IBTarget class - #+ignore (format t "browserAction~%") - (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) - (column (#/selectedColumn sender))) - (when (<= 0 column) - (setf (focal-point cinspector) column) - (#/reloadData (inspector-table-view self)) - #+ignore - (format t " responding to selection in column ~d~%" column)))) - -;; open a new inspector on the selected object -(objc:defmethod (#/browserDoubleAction: :void) - ((self inspector-browser-delegate) - sender) - #+ignore (format t "browserDoubleAction~%") - (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) - (column (#/selectedColumn sender))) - (when (<= 0 column) - ;; this seems to work, but I'm not really paying attention to - ;; thread stuff... - (cinspect (nth-object cinspector column))))) - -(objc:defmethod (#/numberOfRowsInTableView: :nteger) - ((self inspector-table-view-data-source) - table-view) - (declare (ignore table-view)) - - (or (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) - (if cinspector - (let ((inspector (inspector cinspector))) - (inspector::inspector-line-count inspector)) - 0)) - 0)) - -(objc:defmethod #/tableView:objectValueForTableColumn:row: - ((self inspector-table-view-data-source) - table-view - table-column - (row :nteger)) - (declare (ignore table-view)) - (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) - (cond ((not cinspector) - #@"") - ((#/isEqual: (#/identifier table-column) #@"property") - (nsstringptr (focus-nth-property cinspector row))) - ((#/isEqual: (#/identifier table-column) #@"value") - (nsstringptr (focus-nth-value cinspector row)))))) - -;; I'm hoping that the delegate will prevent this from being called willy-nilly -(objc:defmethod (#/tableView:setObjectValue:forTableColumn:row: :void) - ((self inspector-table-view-data-source) - table-view object table-column (row :nteger)) - (declare (ignore table-column)) - (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) - ;; without any formatters, object appears to be an NSCFString - ;; also note we should probably save the original value (including unboundness etc) - ;; first so that we can return to it in the event of any error - ;; plus we should avoid doing anything if the original string and the new string are equal - (when cinspector - (setf (focus-nth-value cinspector row) - (let ((*package* (find-package :cl-user))) - ;; with-autorelease-pool could possibly be needed to - ;; autorelease the cString we're handling (I think) - (eval (read-from-string (lisp-string-from-nsstring object))))) - (#/reloadData table-view) ; really could just reload that one cell, but don't know how... - ;; changing the focused object may effect the browser's path, - ;; reload its column and keep the cinspector consistent Here we - ;; have to make sure that the column we're reloading and the - ;; column after both have values to display, for when - ;; reloadColumn: invokes browser:willDisplayCell:atRow:column: - (#/reloadColumn: (inspector-browser self) (focal-point cinspector)) - ;; [inspector-browser "scrollColumnToVisible:" :int (focal-point cinspector)] ; maybe need this, too - ))) - -;;; In the table view, the properties are not editable, but the -;;; values (if editable) allow lisp forms to be entered that are -;;; read and evaluated to determine the new property value. -(objc:defmethod (#/tableView:shouldEditTableColumn:row: :) - ((self inspector-table-view-delegate) - table-view table-column (row :nteger)) - (declare (ignore table-view)) - (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) - (and cinspector - (#/isEqual: (#/identifier table-column) #@"value") - (/= row 0) ; in practice the reference to - ; the object isn't editable, and - ; the GUI semantics aren't clear anyway, - ; possibly there will come a - ; time when I put row 0 in the - ; table title, but I need to - ; maintain the 0-indexed - ; focus-nth-whatever API here - ; and elsewhere if I do that - (focus-nth-value-editable cinspector row)))) - -;; the inspectorwindowcontroller is set up as the delegate of the window... -;; we now eliminate the dangling pointer to the window from the hash table -(objc:defmethod (#/windowWillClose: :void) - ((self inspector-window-controller) notification) - (let ((nswindow (#/object notification))) - (remhash nswindow *cocoa-inspector-nswindows-table*))) - -;;; hopefully a generally useful function -(defun load-windowcontroller-from-nib (wc-classname nib-pathname) - "Takes a NIB name and returns a new window controller" - (with-autorelease-pool - (make-instance - wc-classname - :with-window-nib-name (nsstringptr (namestring nib-pathname))))) - -;;; make a new inspector window from the nib file, and hash the window's -;;; browser and tableview to the object -(defun cinspect (object) - (with-autorelease-pool - (let* ((windowcontroller (load-windowcontroller-from-nib 'inspector-window-controller *default-inspector-nib-pathname*)) - (window (#/window windowcontroller)) - (cinspector (make-instance 'cocoa-inspector))) - ;; set up the window's initial "focused" object -- this may change as - ;; different parts of the inspector are clicked on, and actually we - ;; probably want to track more information than that associated with the - ;; window, so probably this will eventually be hashed to something like - ;; an inspector for the object or an even bigger wrapper - (setf (gethash window *cocoa-inspector-nswindows-table*) cinspector) - (push-object object cinspector) - ;; is this working? it isn't breaking, but double-clicking is - ;; being handled as two single actions - (let* ((browser (inspector-browser windowcontroller))) - (#/setDoubleAction: browser (@selector #/browserDoubleAction:)) - (#/setIgnoresMultiClick: browser t)) - (#/showWindow: windowcontroller window) - window))) - Index: unk/ccl/examples/cocoa-listener.lisp =================================================================== --- /trunk/ccl/examples/cocoa-listener.lisp (revision 6894) +++ (revision ) @@ -1,348 +1,0 @@ -;;-*- Mode: LISP; Package: CCL -*- - -(in-package "CCL") - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "COCOA-EDITOR") - (require "PTY")) - -(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters") -(def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters") - -(def-cocoa-default hi::*listener-output-style* :int 0 "Text style index for listener output") - -(def-cocoa-default hi::*listener-input-style* :int 1 "Text style index for listener output") - -(def-cocoa-default *listener-background-red-component* :float 0.90f0 "Red component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *listener-background-green-component* :float 0.90f0 "Green component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *listener-background-blue-component* :float 0.90f0 "Blue component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *listener-background-alpha-component* :float 1.0f0 "Red component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") - -;;; Setup the server end of a pty pair. -(defun setup-server-pty (pty) - pty) - -;;; Setup the client end of a pty pair. -(defun setup-client-pty (pty) - ;; Since the same (Unix) process will be reading from and writing - ;; to the pty, it's critical that we make the pty non-blocking. - ;; Has this been true for the last few years (native threads) ? - (fd-set-flag pty #$O_NONBLOCK) - (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG)) - pty) - - -(defloadvar *cocoa-listener-count* 0) - -(defclass cocoa-listener-process (process) - ((input-stream :reader cocoa-listener-process-input-stream) - (backtrace-contexts :initform nil - :accessor cocoa-listener-process-backtrace-contexts))) - - -(defun new-cocoa-listener-process (procname input-fd output-fd peer-fd) - (let* ((input-stream (make-selection-input-stream - input-fd - :peer-fd peer-fd - :elements-per-buffer (#_fpathconf - input-fd - #$_PC_MAX_INPUT))) - (proc - (make-mcl-listener-process - procname - input-stream - (make-fd-stream output-fd :direction :output - :sharing :lock - :elements-per-buffer - (#_fpathconf - output-fd - #$_PC_MAX_INPUT)) - #'(lambda ()` - (let* ((buf (find *current-process* hi:*buffer-list* - :key #'hi::buffer-process)) - (doc (if buf (hi::buffer-document buf)))) - (when doc - (setf (hi::buffer-process buf) nil) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - doc - (@selector #/close) - +null-ptr+ - nil)))) - :initial-function - #'(lambda () - (setq *listener-autorelease-pool* (create-autorelease-pool)) - (listener-function)) - :class 'cocoa-listener-process))) - (setf (slot-value proc 'input-stream) input-stream) - proc)) - - - - -(defclass hemlock-listener-window-controller (hemlock-editor-window-controller) - ((filehandle :foreign-type :id) ;Filehandle for I/O - (clientfd :foreign-type :int) ;Client (listener)'s side of pty - ) - (:metaclass ns:+ns-object) - ) - - -;;; Listener documents are never (or always) ediited. Don't cause their -;;; close boxes to be highlighted. -(objc:defmethod (#/setDocumentEdited: :void) - ((self hemlock-listener-window-controller) (edited :)) - (declare (ignorable edited))) - - -(objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w) - (let* ((new (call-next-method w))) - (unless (%null-ptr-p new) - (multiple-value-bind (server client) (ignore-errors (open-pty-pair)) - (when server - (let* ((fh (make-instance - 'ns:ns-file-handle - :with-file-descriptor (setup-server-pty server) - :close-on-dealloc t))) - (setf (slot-value new 'filehandle) fh) - (setf (slot-value new 'clientfd) (setup-client-pty client)) - (#/addObserver:selector:name:object: - (#/defaultCenter ns:ns-notification-center) - new - (@selector #/gotData:) - #&NSFileHandleReadCompletionNotification - fh) - (#/readInBackgroundAndNotify fh))))) - new)) - -(objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller) - notification) - #+debug (#_NSLog #@"gotData: !") - (with-slots (filehandle) self - (let* ((data (#/objectForKey: (#/userInfo notification) - #&NSFileHandleNotificationDataItem)) - (document (#/document self)) - (data-length (#/length data)) - (buffer (hemlock-document-buffer document)) - (string (%str-from-ptr (#/bytes data) data-length)) - (fh filehandle)) - (enqueue-buffer-operation - buffer - #'(lambda () - (hemlock::append-buffer-output buffer string))) - (#/readInBackgroundAndNotify fh)))) - - - -(objc:defmethod (#/dealloc :void) ((self hemlock-listener-window-controller)) - (#/removeObserver: (#/defaultCenter ns:ns-notification-center) self) - (call-next-method)) - - - -;;; The HemlockListenerDocument class. - - -(defclass hemlock-listener-document (hemlock-editor-document) - () - (:metaclass ns:+ns-object)) - -(defmethod textview-background-color ((doc hemlock-listener-document)) - (#/colorWithCalibratedRed:green:blue:alpha: - ns:ns-color - (float *listener-background-red-component* +cgfloat-zero+) - (float *listener-background-green-component* +cgfloat-zero+) - (float *listener-background-blue-component* +cgfloat-zero+) - (float *listener-background-alpha-component* +cgfloat-zero+))) - - -(defun hemlock::listener-document-send-string (document string) - (let* ((controller (#/objectAtIndex: (#/windowControllers document) 0)) - (filehandle (slot-value controller 'filehandle)) - (len (length string)) - (data (#/autorelease (make-instance 'ns:ns-mutable-data - :with-length len))) - (bytes (#/mutableBytes data))) - (%cstr-pointer string bytes nil) - (#/writeData: filehandle data) - (#/synchronizeFile filehandle))) - - -(objc:defmethod #/topListener ((self +hemlock-listener-document)) - (let* ((all-documents (#/orderedDocuments *NSApp*))) - (dotimes (i (#/count all-documents) (%null-ptr)) - (let* ((doc (#/objectAtIndex: all-documents i))) - (when (eql (#/class doc) self) - (return doc)))))) - -(defun symbol-value-in-top-listener-process (symbol) - (let* ((listenerdoc (#/topListener hemlock-listener-document)) - (buffer (unless (%null-ptr-p listenerdoc) - (hemlock-document-buffer listenerdoc))) - (process (if buffer (hi::buffer-process buffer)))) - (if process - (ignore-errors (symbol-value-in-process symbol process)) - (values nil t)))) - - - -(objc:defmethod (#/isDocumentEdited :) ((self hemlock-listener-document)) - nil) - -(objc:defmethod #/init ((self hemlock-listener-document)) - (let* ((doc (call-next-method))) - (unless (%null-ptr-p doc) - (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*)) - "Listener" - (format nil - "Listener-~d" *cocoa-listener-count*))) - (buffer (hemlock-document-buffer doc))) - (setf (slot-value (slot-value self 'textstorage) 'append-edits) 1) - (#/setFileName: doc (%make-nsstring listener-name)) - (setf (hi::buffer-pathname buffer) nil - (hi::buffer-minor-mode buffer "Listener") t - (hi::buffer-name buffer) listener-name) - (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*))) - doc)) - -(def-cocoa-default *initial-listener-x-pos* :float 400.0f0 "X position of upper-left corner of initial listener") - -(def-cocoa-default *initial-listener-y-pos* :float 400.0f0 "Y position of upper-left corner of initial listener") - -(defloadvar *next-listener-x-pos* nil) ; set after defaults initialized -(defloadvar *next-listener-y-pos* nil) ; likewise - -(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document)) - (let* ((textstorage (slot-value self 'textstorage)) - (window (%hemlock-frame-for-textstorage - textstorage - *listener-columns* - *listener-rows* - t - (textview-background-color self))) - (controller (make-instance - 'hemlock-listener-window-controller - :with-window window)) - (listener-name (hi::buffer-name (hemlock-document-buffer self)))) - ;; Disabling background layout on listeners is an attempt to work - ;; around a bug. The bug's probably gone ... - (let* ((layout-managers (#/layoutManagers textstorage))) - (dotimes (i (#/count layout-managers)) - (let* ((layout (#/objectAtIndex: layout-managers i))) - (#/setBackgroundLayoutEnabled: layout nil)))) - (#/addWindowController: self controller) - (#/release controller) - (ns:with-ns-point (current-point - (or *next-listener-x-pos* *initial-listener-x-pos*) - (or *next-listener-y-pos* *initial-listener-y-pos*)) - (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point))) - (setf *next-listener-x-pos* (ns:ns-point-x new-point) - *next-listener-y-pos* (ns:ns-point-y new-point)))) - (setf (hi::buffer-process (hemlock-document-buffer self)) - (let* ((tty (slot-value controller 'clientfd)) - (peer-tty (#/fileDescriptor (slot-value controller 'filehandle)))) - (new-cocoa-listener-process listener-name tty tty peer-tty))) - controller)) - -;;; Action methods -(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender) - (declare (ignore sender)) - (let* ((buffer (hemlock-document-buffer self)) - (process (if buffer (hi::buffer-process buffer)))) - (when (typep process 'cocoa-listener-process) - (ccl::force-break-in-listener process)))) - -(defmethod listener-backtrace-context ((proc cocoa-listener-process)) - (car (cocoa-listener-process-backtrace-contexts proc))) - -(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender) - (declare (ignore sender)) - (let* ((buffer (hemlock-document-buffer self)) - (process (if buffer (hi::buffer-process buffer)))) - (when (typep process 'cocoa-listener-process) - (let* ((context (listener-backtrace-context process))) - (when context - (#/showWindow: (backtrace-controller-for-context context) +null-ptr+)))))) - -;;; Menu item action validation. It'd be nice if we could distribute this a -;;; bit better, so that this method didn't have to change whenever a new -;;; action was implemented in this class. For now, we have to do so. - -(defmethod document-validate-menu-item ((doc hemlock-listener-document) item) - ;; Return two values: the first is true if the second is definitive. - ;; So far, all actions demand that there be an underlying process, so - ;; check for that first. - (let* ((buffer (hemlock-document-buffer doc)) - (process (if buffer (hi::buffer-process buffer)))) - (if (typep process 'cocoa-listener-process) - (let* ((action (#/action item))) - (cond - ((eql action (@selector #/interrupt:)) (values t t)) - ((eql action (@selector #/backtrace:)) - (values t - (not (null (listener-backtrace-context process))))))) - (values nil nil)))) - -(objc:defmethod (#/validateMenuItem: :) - ((self hemlock-listener-document) item) - (multiple-value-bind (have-opinion opinion) - (document-validate-menu-item self item) - (if have-opinion - opinion - (call-next-method item)))) - -(defun shortest-package-name (package) - (let* ((name (package-name package)) - (len (length name))) - (dolist (nick (package-nicknames package) name) - (let* ((nicklen (length nick))) - (if (< nicklen len) - (setq name nick len nicklen)))))) - -(defmethod ui-object-note-package ((app ns:ns-application) package) - (with-autorelease-pool - (process-interrupt *cocoa-event-process* - #'(lambda (proc name) - (dolist (buf hi::*buffer-list*) - (when (eq proc (hi::buffer-process buf)) - (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))) - *current-process* - (shortest-package-name package)))) - -(defmethod hi::send-string-to-listener-process ((process cocoa-listener-process) - string &key path package) - (let* ((selection (make-input-selection :package package - :source-file path - :string-stream - (make-string-input-stream string)))) - (enqueue-input-selection (cocoa-listener-process-input-stream process) selection))) - - -(defun hemlock::evaluate-input-selection (selection) - (application-ui-operation *application* :eval-selection selection)) - -(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application) - selection) - (declare (ignore selection)) - (let* ((top-listener-document (#/topListener hemlock-listener-document))) - (if top-listener-document - (let* ((buffer (hemlock-document-buffer top-listener-document))) - (if buffer - (let* ((proc (hi::buffer-process buffer))) - (if (typep proc 'cocoa-listener-process) - proc))))))) - -(defmethod ui-object-eval-selection ((app ns:ns-application) - selection) - (let* ((target-listener (ui-object-choose-listener-for-selection - app selection))) - (if (typep target-listener 'cocoa-listener-process) - (enqueue-input-selection (cocoa-listener-process-input-stream - target-listener) - selection)))) - - - - - - - Index: unk/ccl/examples/cocoa-prefs.lisp =================================================================== --- /trunk/ccl/examples/cocoa-prefs.lisp (revision 6894) +++ (revision ) @@ -1,214 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2004 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 :execute) - (use-interface-dir :cocoa)) - - - -(defclass prefs-view (ns:ns-view) - ((form :foreign-type :id :accessor prefs-view-form) - (nvalues :foreign-type :int :accessor prefs-view-nvalues) - (nchanges :foreign-type :int :accessor prefs-view-nchanges) - (revert-button :foreign-type :id :accessor prefs-view-revert-button) - (commit-button :foreign-type :id :accessor prefs-view-commit-button) - (scroll-view :foreign-type :id :reader prefs-view-scroll-view) - (domain :foreign-type :id - :accessor prefs-view-domain) - (defaults-vector :initform nil :accessor prefs-view-defaults-vector)) - (:metaclass ns:+ns-object)) - - -(defmethod set-prefs-cell-from-default ((self prefs-view) cell default form val index) - (let* ((doc (cocoa-default-doc default)) - (type (cocoa-default-type default))) - (#/setTag: cell index) - (#/setStringValue: cell val) - (when doc - (#/setToolTip:forCell: form (%make-nsstring doc) cell)) - (case type - (:int - (#/setEntryType: cell #$NSIntType) - '(#/setAlignment: cell #$NSRightTextAlignment)) - (:float - (#/setEntryType: cell #$NSFloatType) - '(#/setAlignment: cell #$NSRightTextAlignment)) - (t - (#/setScrollable: cell t))) - (#/setAction: cell (@selector #/notePrefsChange:)) - (#/setTarget: cell self))) - -(defmethod create-prefs-view-form ((self prefs-view)) - (let* ((scrollview (prefs-view-scroll-view self)) - (contentsize (#/contentSize scrollview))) - (ns:with-ns-rect (form-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) - (ns:with-ns-size (intercell-spacing-size 1 4) - (ns:with-ns-size (cell-size 500 22) - (let* ((form (make-instance 'ns:ns-form :with-frame form-frame))) - (#/setScrollable: form t) - (#/setIntercellSpacing: form intercell-spacing-size) - (#/setCellSize: form cell-size) - (setf (prefs-view-form self) form) - (#/setDocumentView: scrollview form) - form)))))) - -(defmethod init-prefs-form-from-defaults ((self prefs-view)) - (let* ((defaults (setf (prefs-view-defaults-vector self) - (apply #'vector (reverse (cocoa-defaults))))) - (form (create-prefs-view-form self)) - (domain (setf (prefs-view-domain self) (#/standardUserDefaults ns:ns-user-defaults))) - (n (length defaults))) - (setf (prefs-view-nvalues self) n) - (dotimes (i n) - (let* ((d (svref defaults i)) - (key (objc-constant-string-nsstringptr (cocoa-default-string d))) - (val (#/objectForKey: domain key))) - (when (%null-ptr-p val) - (#/setObject:forKey: - domain (setq val (%make-nsstring (format nil "~a" (cocoa-default-value d)))) key)) - (set-prefs-cell-from-default self - (#/addEntry: form key) - d - form - val - i))) - (setf (prefs-view-nchanges self) 0) - (#/setEnabled: (prefs-view-revert-button self) nil) - (#/setEnabled: (prefs-view-commit-button self) nil) - (#/sizeToCells form))) - -(objc:defmethod (#/notePrefsChange: :void) ((self prefs-view) form) - (let* ((cell (#/cellAtIndex: form (#/indexOfSelectedItem form))) - (n (prefs-view-nvalues self)) - (form (prefs-view-form self)) - (current (#/tag cell)) - (d (svref (prefs-view-defaults-vector self) current)) - (next (mod (1+ current) n)) - (value (#/stringValue cell))) - (unless (#/isEqualTo: value - (#/objectForKey: (prefs-view-domain self) - (objc-constant-string-nsstringptr (cocoa-default-string d)))) - ;; If there's a constraint, sanity-check the value. - (when (zerop (prefs-view-nchanges self)) - (#/setEnabled: (prefs-view-commit-button self) t) - (#/setEnabled: (prefs-view-revert-button self) t)) - (incf (prefs-view-nchanges self))) - (#/selectCell: form (#/cellAtIndex: form next)))) - -(objc:defmethod (#/commitPrefs: :void) ((self prefs-view) sender) - (declare (ignore sender)) - (let* ((form (prefs-view-form self)) - (domain (prefs-view-domain self))) - (dotimes (i (prefs-view-nvalues self)) - (let* ((cell (#/cellAtIndex: form i)) - (key (#/title cell)) - (val (#/stringValue cell))) - (#/setObject:forKey: domain val key))) - (#/synchronize domain) - (setf (prefs-view-nchanges self) 0) - (#/setEnabled: (prefs-view-revert-button self) nil) - (#/setEnabled: (prefs-view-commit-button self) nil) - (update-cocoa-defaults-vector domain (prefs-view-defaults-vector self)))) - -(objc:defmethod (#/revertPrefs: :void) ((self prefs-view) sender) - (declare (ignore sender)) - (let* ((form (prefs-view-form self)) - (domain (prefs-view-domain self))) - (dotimes (i (prefs-view-nvalues self)) - (let* ((cell (#/cellAtIndex: form i)) - (key (#/title cell))) - (#/setStringValue: cell (#/objectForKey: domain key)))) - (setf (prefs-view-nchanges self) 0) - (#/setEnabled: (prefs-view-revert-button self) nil) - (#/setEnabled: (prefs-view-commit-button self) nil))) - - -(objc:defmethod #/initWithFrame: ((self prefs-view) (frame :ect)) - (call-next-method frame) - (ns:with-ns-rect (scroll-frame 20 40 (- (ns:ns-rect-width frame) 40) (- (ns:ns-rect-height frame) 60)) - (let* ((scrollview (make-instance 'ns:ns-scroll-view - :with-frame scroll-frame)) - (scroll-content (#/contentView scrollview))) - (#/setBorderType: scrollview #$NSBezelBorder) - (#/setHasVerticalScroller: scrollview t) - (#/setHasHorizontalScroller: scrollview t) - (#/setRulersVisible: scrollview nil) - (#/setAutoresizingMask: scrollview (logior - #$NSViewWidthSizable - #$NSViewHeightSizable)) - (#/setAutoresizesSubviews: scroll-content t) - (setf (slot-value self 'scroll-view) scrollview) - (ns:with-ns-rect (revert-frame 20 10 80 20) - (ns:with-ns-rect (commit-frame (- (+ (ns:ns-rect-x frame) - (ns:ns-rect-width frame) - (+ 80.0f0 20.0f0))) - 10 80 20) - (let* ((commit-button (make-instance - 'ns:ns-button - :with-frame commit-frame)) - (revert-button (make-instance - 'ns:ns-button - :with-frame revert-frame))) - (#/setTitle: commit-button #@"Commit") - (#/setTitle: revert-button #@"Revert") - (#/setEnabled: commit-button nil) - (#/setEnabled: revert-button nil) - (#/setAction: commit-button (@selector "commitPrefs:")) - (#/setTarget: commit-button self) - (#/setAction: revert-button (@selector "revertPrefs:")) - (#/setTarget: revert-button self) - (#/setAutoresizingMask: commit-button #$NSViewMinXMargin) - (#/setAutoresizingMask: revert-button #$NSViewMaxXMargin) - (#/setBezelStyle: revert-button #$NSRoundedBezelStyle) - (#/setBezelStyle: commit-button #$NSRoundedBezelStyle) - (setf (prefs-view-revert-button self) revert-button - (prefs-view-commit-button self) commit-button) - (#/addSubview: self revert-button) - (#/addSubview: self commit-button) - (#/addSubview: self scrollview) - self)))))) - -(defloadvar *preferences-panel* nil) - -(defclass preferences-panel (ns:ns-panel) - ((prefs-view :foreign-type :id :accessor preferences-panel-prefs-view)) - (:metaclass ns:+ns-object)) - -(objc:defmethod #/sharedPanel ((self +preferences-panel)) - (cond (*preferences-panel*) - (t - (let* ((panel (new-cocoa-window :class self - :title "Preferences" - :activate nil)) - (view (#/contentView panel)) - (bounds (#/bounds view)) - (v (make-instance 'prefs-view :with-frame bounds))) - (#/setContentView: panel v) - (#/setNeedsDisplay: v t) - (setf (slot-value panel 'prefs-view) v) - (setq *preferences-panel* panel))))) - -(objc:defmethod #/init ((self preferences-panel)) - (let* ((class (class-of self))) - (#/dealloc self) - (#/sharedPanel class))) - -(objc:defmethod (#/show :void) ((self preferences-panel)) - (init-prefs-form-from-defaults (preferences-panel-prefs-view self)) - (#/makeKeyAndOrderFront: self +null-ptr+)) - Index: unk/ccl/examples/cocoa-textfind.lisp =================================================================== --- /trunk/ccl/examples/cocoa-textfind.lisp (revision 6894) +++ (revision ) @@ -1,19 +1,0 @@ -(in-package "CCL) - -;;; This is stolen (rather shamelessly) from the TextFinder class in -;;; Apple's TextEdit example. - -(require "COCOA-WINDOW") -(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *readtable* *objc-readtable*)) - -(def-objc-class "TextFinder" "NSObject" - ((findstring "findString") (* (:struct :tring))) - ((findtextfield "findTextField") :id) - ((replacetextfield "replaceTextField") :id) - ((ignorecasebutton "ignoreCaseButton") :id) - ((findnextbutton "findNextButton") :id) - ((statusfield "statusField") :id) - ((lastfindwassuccessful "lastFindWasSuccessful") :)) - - Index: unk/ccl/examples/cocoa-typeout.lisp =================================================================== --- /trunk/ccl/examples/cocoa-typeout.lisp (revision 6894) +++ (revision ) @@ -1,183 +1,0 @@ -(in-package "CCL") - -(eval-when (:compile-toplevel :execute) - (use-interface-dir :cocoa)) - -;; -;; the typeout panel is just an ns-panel containing a scroll-view -;; which contains a text-view. The text is read only. -;; -;; There is only one panel which is created with the first invocation -;; of the 'shared-panel class method. The panel is bound to the -;; variable ccl::*typeout-panel* -;; -;; the panel is implicitly bound to a stream, and text written to -;; the stream is written into the text-view object. The stream is -;; available via the function (ccl::typeout-stream) -;; -;; the panel width is set to 600 pixels, which is fine since hemlock -;; looks like it wants to wrap the documentation at 80 characters -;; anyway. In the long run this window should use a variable size font -;; and maybe compute the width as 80 times the width of the letter W. -;; -;; I'll revisit this after the preferences are more defined. -;; -;; @class typeout-view -;; -(defclass typeout-view (ns:ns-view) - ((scroll-view :foreign-type :id :reader typeout-view-scroll-view) - (text-view :foreign-type :id :reader typeout-view-text-view) - (text-storage :foreign-type :id :reader typeout-view-text-storage)) - (:metaclass ns:+ns-object)) - -(objc:defmethod #/initWithFrame: ((self typeout-view) (frame :ect)) - (call-next-method frame) - (let* ((scrollview (make-instance 'ns:ns-scroll-view - :with-frame frame)) - (scroll-content (#/contentView scrollview))) - (#/setBorderType: scrollview #$NSBezelBorder) - (#/setHasVerticalScroller: scrollview t) - (#/setHasHorizontalScroller: scrollview nil) - (#/setRulersVisible: scrollview nil) - (#/setAutoresizingMask: scrollview #$NSViewHeightSizable) - (#/setAutoresizesSubviews: scroll-content t) - (#/addSubview: self scrollview) - (setf (slot-value self 'scroll-view) scrollview) - (let* ((contentsize (#/contentSize scrollview))) - (ns:with-ns-rect (text-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) - (let* ((text-view (make-instance 'ns:ns-text-view - :with-frame text-frame)) - (text-storage (#/textStorage text-view))) - (#/setEditable: text-view nil) - (setf (slot-value self 'text-storage) text-storage) - (#/setDocumentView: scrollview text-view) - (setf (slot-value self 'text-view) text-view))))) - self) - -;; -;; @class typeout-panel -;; -(defloadvar *typeout-panel* nil) - -(defclass typeout-panel (ns:ns-panel) - ((typeout-view :foreign-type :id :accessor typeout-panel-typeout-view)) - (:metaclass ns:+ns-object)) - -(objc:defmethod #/sharedPanel ((self +typeout-panel)) - (cond (*typeout-panel*) - (t - (let* ((panel (new-cocoa-window :class self - :title "Typeout" - :width 600 - :activate nil))) - (ns:with-ns-size (size 600 10000) - (#/setMaxSize: panel size) - (setf (ns:ns-size-height size) 1) - (#/setMinSize: panel size)) - (let* ((view (make-instance 'typeout-view :with-frame (#/bounds (#/contentView panel))))) - (#/setContentView: panel view) - (#/setNeedsDisplay: view t) - (setf (slot-value panel 'typeout-view) view) - (setq *typeout-panel* panel)))))) - -(objc:defmethod #/init ((self typeout-panel)) - (let* ((class (class-of self))) - (#/dealloc self) - (#/sharedPanel class))) - - -(objc:defmethod (#/show :void) ((self typeout-panel)) - (#/orderFront: self +null-ptr+)) - -(defloadvar *typeout-attributes* nil) - -(defclass typeout-stream (fundamental-stream) - ((text-storage :initform nil :accessor typeout-stream-text-storage) - (line-number :initform 0 :accessor typeout-stream-line-number) - (line-position :initform 0 :accessor typeout-stream-line-position))) - -(defun prepare-typeout-stream (stream) - (let ((panel (#/sharedPanel typeout-panel))) - (unless (typeout-stream-text-storage stream) - (setf (typeout-stream-text-storage stream) (typeout-view-text-storage (typeout-panel-typeout-view panel)))) - (unless *typeout-attributes* - (setf *typeout-attributes* (create-text-attributes - :font (default-font :name *default-font-name* :size *default-font-size*) - :line-break-mode :word))) - (#/show panel))) - - -;;; -;;; TYPEOUT-STREAM methods -;;; - -(defmethod stream-write-char ((stream typeout-stream) char) - (prepare-typeout-stream stream) - ;; - ;; convert tabs to spaces. - ;; - (if (eq char #\tab) - (return-from stream-write-char - (progn - (format stream "(make-string (- 8 (mod ~A 8)) :initial-element #\space)~%" (typeout-stream-line-position stream)) - (stream-write-string stream (make-string (- 8 (mod (typeout-stream-line-position stream) 8)) - :initial-element #\space))))) - - ;; - ;; Maybe convert non-printable characters to something else? - ;; This is a problem for the editor, but probably not here. - - ;; - ;; adjust the line and column #s accordingly - ;; - (if (eq char #\newline) - (progn - (incf (typeout-stream-line-number stream)) - (setf (typeout-stream-line-position stream) 0)) - (incf (typeout-stream-line-position stream))) - - ;; - ;; print the character by converting it to a string and appending - ;; it to the text-storage buffer. - ;; - (let* ((the-typeout-view (typeout-panel-typeout-view *typeout-panel*)) - (text-storage (slot-value the-typeout-view 'text-storage)) - (str (make-string 1 :initial-element char)) - (attr-str (make-instance 'ns:ns-attributed-string - :with-string str - :attributes *typeout-attributes*))) - (#/appendAttributedString: text-storage attr-str))) - -(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) - (prepare-typeout-stream stream) - (let* ((str (if start - (subseq string start end) - string)) - (attr-str (make-instance 'ns:ns-attributed-string - :with-string str - :attributes *typeout-attributes*)) - (the-typeout-view (typeout-panel-typeout-view *typeout-panel*)) - (text-storage (slot-value the-typeout-view 'text-storage))) - (setf (typeout-stream-line-position stream) (length string)) - (#/appendAttributedString: text-storage attr-str))) - -(defmethod stream-fresh-line ((stream typeout-stream)) - (prepare-typeout-stream stream) - (stream-write-char stream #\newline)) - -(defmethod stream-line-column ((stream typeout-stream)) - (typeout-stream-line-position stream)) - -(defmethod stream-clear-output ((stream typeout-stream)) - (prepare-typeout-stream stream) - (let* ((the-typeout-view (typeout-panel-typeout-view *typeout-panel*)) - (text-storage (slot-value the-typeout-view 'text-storage)) - (len (#/length text-storage))) - (declare (type ns:ns-text-storage text-storage)) - (#/deleteCharactersInRange: text-storage (ns:make-ns-range 0 len)))) - -(defloadvar *typeout-stream* (make-instance 'typeout-stream)) - -(defun typeout-stream () - *typeout-stream*) - Index: unk/ccl/examples/cocoa-window.lisp =================================================================== --- /trunk/ccl/examples/cocoa-window.lisp (revision 6894) +++ (revision ) @@ -1,355 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2002-2003 Clozure Associates -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html - - -(in-package "CCL") ; for now. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "OBJC-SUPPORT") - ;; - ;; this stuff should all be integrated with a preferences file in ~/Library/OpenMCL/ - ;; (Um, it -is- integrated with the preferences file.) - ;; - (require "COCOA-DEFAULTS") - (def-cocoa-default *default-font-name* :string "Courier" "Name of font to use in editor windows") - (def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to use in editor windows, as a positive SINGLE-FLOAT") - (def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in characters" (integer 1 32)) - (require "COCOA-PREFS") - (require "COCOA-TYPEOUT")) - -(eval-when (:compile-toplevel :execute) - (use-interface-dir #+apple-objc :cocoa #+gnu-objc :gnustep)) - - -(defun init-cocoa-application () - (with-autorelease-pool - (let* ((bundle (open-main-bundle)) - (dict (#/infoDictionary bundle)) - (classname (#/objectForKey: dict #@"NSPrincipalClass")) - (mainnibname (#/objectForKey: dict #@"NSMainNibFile")) - (progname (#/objectForKey: dict #@"CFBundleName"))) - (if (%null-ptr-p classname) - (error "problems loading bundle: can't determine class name")) - (if (%null-ptr-p mainnibname) - (error "problems loading bundle: can't determine main nib name")) - (unless (%null-ptr-p progname) - (#/setProcessName: (#/processInfo ns:ns-process-info) progname)) - (let* ((appclass (#_NSClassFromString classname)) - (app (#/sharedApplication appclass))) - (#/loadNibNamed:owner: ns:ns-bundle mainnibname app) - app)))) - - - -#+apple-objc -(defun trace-dps-events (flag) - (external-call "__DPSSetEventsTraced" - :unsigned-byte (if flag #$YES #$NO) - :void)) - -(defvar *appkit-process-interrupt-ids* (make-id-map)) -(defun register-appkit-process-interrupt (thunk) - (assign-id-map-id *appkit-process-interrupt-ids* thunk)) -(defun appkit-interrupt-function (id) - (id-map-free-object *appkit-process-interrupt-ids* id)) - -(defclass appkit-process (process) ()) - -(defconstant process-interrupt-event-subtype 17) - - - - -(defclass lisp-application (ns:ns-application) - ((termp :foreign-type :)) - (:metaclass ns:+ns-object)) - - -(objc:defmethod (#/postEventAtStart: :void) ((self ns:ns-application) e) - (#/postEvent:atStart: self e t)) - -;;; Interrupt the AppKit event process, by enqueing an event (if the -;;; application event loop seems to be running.) It's possible that -;;; the event loop will stop after the calling thread checks; in that -;;; case, the application's probably already in the process of -;;; exiting, and isn't that different from the case where asynchronous -;;; interrupts are used. An attribute of the event is used to identify -;;; the thunk which the event handler needs to funcall. -(defmethod process-interrupt ((process appkit-process) function &rest args) - (if (eq process *current-process*) - (apply function args) - (if (or (not *NSApp*) (not (#/isRunning *NSApp*))) - (call-next-method) - (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2: - ns:ns-event - #$NSApplicationDefined - (ns:make-ns-point 0 0) - 0 - 0.0d0 - 0 - +null-ptr+ - process-interrupt-event-subtype - (register-appkit-process-interrupt - #'(lambda () (apply function args))) 0))) - (#/retain e) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - *NSApp* (@selector "postEventAtStart:") e t))))) - - -(defloadvar *default-ns-application-proxy-class-name* - "LispApplicationDelegate") - -#+apple-objc -(defun enable-foreground () - (%stack-block ((psn 8)) - (external-call "_GetCurrentProcess" :address psn) - (external-call "_CPSEnableForegroundOperation" :address psn) - (eql 0 (external-call "_SetFrontProcess" :address psn :signed-halfword)))) - -;;; I'm not sure if there's another way to recognize events whose -;;; type is #$NSApplicationDefined. -(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e) - (if (and (eql (#/type e) #$NSApplicationDefined) - (eql (#/subtype e) process-interrupt-event-subtype)) - ;;; The thunk to funcall is identified by the value - ;;; of the event's data1 attribute. - (funcall (appkit-interrupt-function (#/data1 e))) - (call-next-method e))) - - -(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender) - (declare (ignore sender)) - (#/show (#/sharedPanel preferences-panel))) - -(objc:defmethod (#/toggleTypeout: :void) ((self lisp-application) sender) - (declare (ignore sender)) - (#/show (#/sharedPanel typeout-panel))) - -(defun nslog-condition (c) - (let* ((rep (format nil "~a" c))) - (with-cstrs ((str rep)) - (with-nsstr (nsstr str (length rep)) - (#_NSLog #@"Error in event loop: %@" :address nsstr))))) - - -(defmethod process-exit-application ((process appkit-process) thunk) - (when (eq process *initial-process*) - (%set-toplevel thunk) - (#/terminate: *NSApp* +null-ptr+))) - -(defun run-event-loop () - (%set-toplevel nil) - (change-class *cocoa-event-process* 'appkit-process) - (let* ((app *NSApp*)) - (loop - (handler-case (#/run app) - (error (c) (nslog-condition c))) - (unless (#/isRunning app) - (return))))) - - - -(defun start-cocoa-application (&key - (application-proxy-class-name - *default-ns-application-proxy-class-name*)) - - (flet ((cocoa-startup () - ;; Start up a thread to run periodic tasks. - (process-run-function "housekeeping" - #'(lambda () - (loop - (%nanosleep *periodic-task-seconds* - *periodic-task-nanoseconds*) - (housekeeping)))) - - (with-autorelease-pool - (enable-foreground) - (or *NSApp* (setq *NSApp* (init-cocoa-application))) - (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon"))) - (unless (%null-ptr-p icon) - (#/setApplicationIconImage: *NSApp* icon))) - (setf (application-ui-object *application*) *NSApp*) - (when application-proxy-class-name - (let* ((classptr (%objc-class-classptr - (load-objc-class-descriptor application-proxy-class-name))) - (instance (#/init (#/alloc classptr)))) - - (#/setDelegate: *NSApp* instance)))) - (run-event-loop))) - (process-interrupt *cocoa-event-process* #'(lambda () - (%set-toplevel - #'cocoa-startup) - (toplevel))))) - -(defparameter *font-attribute-names* - '((:bold . #.#$NSBoldFontMask) - (:italic . #.#$NSItalicFontMask) - (:small-caps . #.#$NSSmallCapsFontMask))) - - -;;; The NSFont method #/isFixedPitch has returned random answers -;;; in many cases for the last few OSX releases. Try to return -;;; a reasonable answer, by checking to see if the width of the -;;; advancement for the #\i glyph matches that of the advancement -;;; of the #\m glyph. - -(defun is-fixed-pitch-font (font) - (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i"))) - (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m"))))) - -;;; Try to find the specified font. If it doesn't exist (or isn't -;;; fixed-pitch), try to find a fixed-pitch font of the indicated size. -(defun default-font (&key (name *default-font-name*) - (size *default-font-size*) - (attributes ())) - - (setq size (float size +cgfloat-zero+)) - (with-cstrs ((name name)) - (with-autorelease-pool - (rletz ((matrix (:array :loat 6))) - (setf (paref matrix (:* :loat) 0) size - (paref matrix (:* :loat) 3) size) - (let* ((fontname (#/stringWithCString: ns:ns-string name)) - (font (#/fontWithName:matrix: ns:ns-font fontname matrix)) - - (implemented-attributes ())) - (if (or (%null-ptr-p font) - (and - (not (is-fixed-pitch-font font)))) - (setq font (#/userFixedPitchFontOfSize: ns:ns-font size))) - (when attributes - (dolist (attr-name attributes) - (let* ((pair (assoc attr-name *font-attribute-names*)) - (newfont)) - (when pair - (setq newfont - (#/convertFont:toHaveTrait: - (#/sharedFontManager ns:ns-font-manager) font (cdr pair))) - (unless (eql font newfont) - (setq font newfont) - (push attr-name implemented-attributes)))))) - (values (#/retain font) implemented-attributes)))))) - -;;; Create a paragraph style, mostly so that we can set tabs reasonably. -(defun create-paragraph-style (font line-break-mode) - (let* ((p (make-instance 'ns:ns-mutable-paragraph-style)) - (charwidth (fround (ns:ns-size-width (#/maximumAdvancement font))))) - (#/setLineBreakMode: p - (ecase line-break-mode - (:char #$NSLineBreakByCharWrapping) - (:word #$NSLineBreakByWordWrapping) - ;; This doesn't seem to work too well. - ((nil) #$NSLineBreakByClipping))) - ;; Clear existing tab stops. - (#/setTabStops: p (#/array ns:ns-array)) - (do* ((i 1 (1+ i))) - ((= i 100) p) - (let* ((tabstop (make-instance - 'ns:ns-text-tab - :with-type #$NSLeftTabStopType - :location (* (* i *tab-width*) - charwidth)))) - (#/addTabStop: p tabstop) - (#/release tabstop))))) - -(defun create-text-attributes (&key (font (default-font)) - (line-break-mode :char) - (color nil) - (obliqueness nil) - (stroke-width nil)) - (let* ((dict (#/retain (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))) - (#/setObject:forKey: dict (create-paragraph-style font line-break-mode) #&NSParagraphStyleAttributeName) - (#/setObject:forKey: dict font #&NSFontAttributeName) - (when color - (#/setObject:forKey: dict color #&NSForegroundColorAttributeName)) - (when stroke-width - (#/setObject:forKey: dict (make-instance 'ns:ns-number - :with-float (float stroke-width)) #&NSStrokeWidthAttributeName)) - (when obliqueness - (#/setObject:forKey: dict (make-instance 'ns:ns-number - :with-float (float obliqueness)) #&NSObliquenessAttributeName)) - dict)) - - -(defun get-cocoa-window-flag (w flagname) - (case flagname - (:accepts-mouse-moved-events - (#/acceptsMouseMovedEvents w)) - (:cursor-rects-enabled - (#/areCursorRectsEnabled w)) - (:auto-display - (#/isAutodisplay w)))) - - - -(defun (setf get-cocoa-window-flag) (value w flagname) - (case flagname - (:accepts-mouse-moved-events - (#/setAcceptsMouseMovedEvents: w value)) - (:auto-display - (#/setAutodisplay: w value)))) - - - -(defun activate-window (w) - ;; Make w the "key" and frontmost window. Make it visible, if need be. - (#/makeKeyAndOrderFront: w nil)) - -(defun new-cocoa-window (&key - (class (find-class 'ns:ns-window)) - (title nil) - (x 200.0) - (y 200.0) - (height 200.0) - (width 500.0) - (closable t) - (iconifyable t) - (metal t) - (expandable t) - (backing :buffered) - (defer t) - (accepts-mouse-moved-events nil) - (auto-display t) - (activate t)) - (ns:with-ns-rect (frame x y width height) - (let* ((stylemask - (logior #$NSTitledWindowMask - (if closable #$NSClosableWindowMask 0) - (if iconifyable #$NSMiniaturizableWindowMask 0) - (if expandable #$NSResizableWindowMask 0) - (if metal #$NSTexturedBackgroundWindowMask 0))) - (backing-type - (ecase backing - ((t :retained) #$NSBackingStoreRetained) - ((nil :nonretained) #$NSBackingStoreNonretained) - (:buffered #$NSBackingStoreBuffered))) - (w (make-instance - class - :with-content-rect frame - :style-mask stylemask - :backing backing-type - :defer defer))) - (setf (get-cocoa-window-flag w :accepts-mouse-moved-events) - accepts-mouse-moved-events - (get-cocoa-window-flag w :auto-display) - auto-display) - (when activate (activate-window w)) - (when title (#/setTitle: w (%make-nsstring title))) - w))) - - - - Index: unk/ccl/examples/cocoa.lisp =================================================================== --- /trunk/ccl/examples/cocoa.lisp (revision 6894) +++ (revision ) @@ -1,91 +1,0 @@ -(in-package "CCL") - -;;; We need to be able to point the CoreFoundation and Cocoa libraries -;;; at some bundle very early in the process. If you want to use some -;;; other bundle path, you may need to change the call to FAKE-CFBUNDLE-PATH -;;; below. - -#+darwin-target -(progn - (require "FAKE-CFBUNDLE-PATH") - (fake-cfbundle-path "ccl:OpenMCL.app;Contents;MacOS;dppccl")) - - -(require "OBJC-SUPPORT") -(require "COCOA-WINDOW") -(require "COCOA-LISTENER") -(require "COCOA-BACKTRACE") - - - -;;; The application delegate gets notified of state changes in the -;;; application object. -(defclass lisp-application-delegate (ns:ns-object) - () - (:metaclass ns:+ns-object)) - - -(objc:defmethod (#/applicationWillFinishLaunching: :void) - ((self lisp-application-delegate) notification) - (declare (ignore notification)) - (initialize-user-interface)) - -(objc:defmethod (#/applicationWillTerminate: :void) - ((self lisp-application-delegate) notification) - (declare (ignore notification)) - ;; UI has decided to quit; terminate other lisp threads. - (prepare-to-quit)) - -(objc:defmethod (#/newListener: :void) ((self lisp-application-delegate) - sender) - (declare (ignore sender)) - (#/openUntitledDocumentOfType:display: - (#/sharedDocumentController ns:ns-document-controller) - #@"Listener" - t)) - -(defvar *cocoa-application-finished-launching* (make-semaphore) - "Semaphore that's signaled when the application's finished launching ...") - -(objc:defmethod (#/applicationDidFinishLaunching: :void) - ((self lisp-application-delegate) notification) - (declare (ignore notification)) - (signal-semaphore *cocoa-application-finished-launching*)) - -(objc:defmethod (#/applicationOpenUntitledFile: :) - ((self lisp-application-delegate) app) - (when (zerop *cocoa-listener-count*) - (#/newListener: self app) - t)) - - -(defmethod ui-object-do-operation ((o ns:ns-application) - operation - &rest args) - (declare (ignore operation args)) - ;; Do nothing. Would it be better to warn and/or log this ? - ) - -(defmethod ui-object-do-operation ((o ns:ns-application) - (operation (eql :note-current-package)) - &rest args) - (ui-object-note-package o (car args))) - -(defmethod ui-object-do-operation ((o ns:ns-application) - (operation (eql :eval-selection)) - &rest args) - (ui-object-eval-selection o (car args))) - -(defmethod ui-object-do-operation ((o ns:ns-application) - (operation (eql :enter-backtrace-context)) - &rest args) - (ui-object-enter-backtrace-context o (car args))) - -(defmethod ui-object-do-operation ((o ns:ns-application) - (operation (eql :exit-backtrace-context)) - &rest args) - (ui-object-exit-backtrace-context o (car args))) - -(start-cocoa-application) - - Index: unk/ccl/examples/compile-hemlock.lisp =================================================================== --- /trunk/ccl/examples/compile-hemlock.lisp (revision 6894) +++ (revision ) @@ -1,160 +1,0 @@ -(in-package "CCL") - -(defparameter *hemlock-src-dir-pathname* "ccl:hemlock;src;") - -(defparameter *hemlock-binary-dir-pathname* "ccl:hemlock;bin;openmcl;") - -(defparameter *hemlock-binary-file-extension* - (pathname-type (compile-file-pathname "foo.lisp"))) - -(defun hemlock-source-pathname (name) - (make-pathname :name name - :type "lisp" - :defaults *hemlock-src-dir-pathname*)) - -(defun hemlock-binary-pathname (name) - (make-pathname :name name - :type *hemlock-binary-file-extension* - :defaults *hemlock-binary-dir-pathname*)) - -(defun compile-and-load-hemlock-file (name &optional force) - (let* ((source-pathname (hemlock-source-pathname name)) - (binary-pathname (hemlock-binary-pathname name))) - (when (or force - (not (probe-file binary-pathname)) - (> (file-write-date source-pathname) - (file-write-date binary-pathname))) - (compile-file source-pathname :output-file binary-pathname :verbose t)) - (load binary-pathname :verbose t))) - - -(defparameter *hemlock-files* - '("package" - - ;; Lisp implementation specific stuff goes into one of - ;; the next two files. - "lispdep" - "hemlock-ext" - - "decls" ;early declarations of functions and stuff - - "struct" - ;; "struct-ed" - "charmacs" - "key-event" - "keysym-defs" - "cocoa-hemlock" - "rompsite" - - #+clx - "input" - "macros" - "line" - "ring" - "vars" - "interp" - "syntax" - "htext1" - "buffer" - "htext2" - "htext3" - "htext4" - "files" - "search1" - "search2" - "table" - #+clx - "hunk-draw" - #+clx - "window" - #-clx - "modeline" - #+clx - "screen" - #+clx - "winimage" - "linimage" - #+clx - "display" - #+clx - "bit-display" - - #+nil "tty/termcap" - #+nil "tty-disp-rt" - #+nil "tty-display" - "pop-up-stream" - #+clx "bit-screen" - #+nil "tty/tty-screen" - "cursor" - "font" - "streams" - #+nil "hacks" - "main" - "echo" - "echocoms" - "command" - "indent" - ;; moved "comments" - "morecoms" - "undo" - "killcoms" - "searchcoms" - "filecoms" - "doccoms" - "srccom" - "group" - "fill" - "text" - "lispmode" - ;; "ts-buf" - ;; "ts-stream" - ;; "eval-server" - ;; "lispbuf" - "listener" - ;; "lispeval" - ;; "spell-rt" - ;; "spell-corr" - ;; "spell-aug" - ;; "spellcoms" - - "comments" - "overwrite" - "abbrev" - "icom" - "kbdmac" - "defsyn" - #+why - "scribe" - #+what - "pascal" - #+who - "dylan" - "edit-defs" - "auto-save" - "register" - "xcoms" - ;; "unixcoms" - ;; "mh" - "highlight" - ;; "dired" - ;; "diredcoms" - "bufed" - "lisp-lib" - "completion" - ;; "shell" - ;; "debug" - ;; "netnews" - ;; "rcs" - "bindings" - "bindings-gb" ;Gilbert's bindings - )) - -(defun compile-hemlock (&optional force) - (with-compilation-unit () - (dolist (name *hemlock-files*) - (compile-and-load-hemlock-file name force))) - (fasl-concatenate "ccl:library;hemlock" - (mapcar #'hemlock-binary-pathname *hemlock-files*) - :if-exists :supersede) - (provide "HEMLOCK") - ) Index: unk/ccl/examples/fake-cfbundle-path.lisp =================================================================== --- /trunk/ccl/examples/fake-cfbundle-path.lisp (revision 6894) +++ (revision ) @@ -1,22 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- - -(in-package "CCL") - -;;; Before loading any Cocoa code which depends on CFBundle/NSBundle -;;; being able to find an application bundle, it -may- be neccessary -;;; to point the environment variable "CFProcessPath" to some file -;;; that's where the bundle's executable would be. -;;; This should only be necessary if the current application isn't -;;; already "inside a bundle". If it is necessary, it has to happen -;;; before the CoreFoundation library's initialized. - -(defun fake-cfbundle-path (executable-path) - (when executable-path - (unless (probe-file executable-path) - (cerror "Create an empty file." - "The specified executable path (~s) doesn't exist" - executable-path) - (create-file executable-path)) - (let* ((fakepath - (native-translated-namestring executable-path))) - (setenv "CFProcessPath" fakepath)))) Index: unk/ccl/examples/name-translation.lisp =================================================================== --- /trunk/ccl/examples/name-translation.lisp (revision 6894) +++ (revision ) @@ -1,444 +1,0 @@ -;;;; -*- 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: unk/ccl/examples/objc-clos.lisp =================================================================== --- /trunk/ccl/examples/objc-clos.lisp (revision 6894) +++ (revision ) @@ -1,1254 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2003-2004 Clozure Associates and contributors. -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html -;;; -;;; TO DO -;;; - Both method creation and invocation should be faster and cons less -;;; - Resolve messages with repeated keywords -;;; (rename them to :range1:range2 or don't use &key in GFs and methods) -;;; - How to integrate SEND-SUPER with CALL-NEXT-METHOD? -;;; - Variable arity ObjC methods -;;; - Pass-by-ref structures need to keep track of IN, OUT, IN/OUT info -;;; - Need to canonicalize and retain every returned :ID -;;; - Support :BEFORE, :AFTER and :AROUND for ObjC methods -;;; - User-defined ObjC methods via DEFMETHOD (or DEFINE-OBJ-METHOD) -;;; - Need to fully handle init keywords and ObjC init messages - -;;; Package and module stuff - -(in-package "CCL") - -(eval-when (:compile-toplevel :execute) - #+apple-objc - (use-interface-dir :cocoa) - #+gnu-objc - (use-interface-dir :gnustep)) - -;;; We need OBJC-FOREIGN-ARG-TYPE from the bridge to process ivar types - -(require "BRIDGE") - - -(defparameter *objc-import-private-ivars* t "When true, the CLASS-DIRECT-SLOTS of imported ObjC classes will contain slot definitions for instance variables whose name starts with an underscore. Note that this may exacerbate compatibility problems.") - - -;;; ObjC messages that cannot currently be translated into CLOS methods - -(defparameter *troublesome-messages* - '( - ;; Multicolon messages that don't respect the name translation rules - "performv::" "translateTo::" "indexOf:::" "scaleTo::" "forward::" - "exchange::" - ;; Messages involving the nonexistent NSButtonState - "focusRingImageForState:" "useDisabledEffectForState:" - "isBorderedForState:" "imageForState:" "useHighlightEffectForState:" - "isOpaqueForState:" "bezelStyleForState:" - ;; Messages containing repeated keywords - "orderString:range:string:range:flags:" - "parseSuiteOfPairsKey:separator:value:separator:allowOmitLastSeparator:" - "perform:with:with:" - "perform:withObject:withObject:" - "performSelector:withObject:withObject:" - ;; Variable arity messages - "appendFormat:" "arrayWithObjects:" "encodeValuesOfObjCTypes:" - "decodeValuesOfObjCTypes:" "dictinaryWithObjectsAndKeys:" - "handleFailureInFunction:object:file:lineNumber:description:" - "handleFailureInMethod:object:file:lineNumber:description:" - "initWithFormat:" "initWithObjects:" "initWithObjectsAndKeys:" - "initWithFormat:locale:" "localizedStringWithFormat:" "raise:format:" - "setWithObjects:" "stringByAppendingFormat:" "stringWithFormat:" - ;; Seems to involve a (:STRUCT :?) argument - "percentEscapeDecodeBuffer:range:stripWhitespace:")) - -(defun troublesome-message-p (msg) - (if (member msg *troublesome-messages* :test #'string=) t nil)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; 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)))))))))) - - - -(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))) - (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 we're pointing to a structure whose first field is - ;; a pointer to a structure named :OBJC_CLASS, we're of - ;; type :ID and can (fairly) safely use %GET-PTR. - ;; Otherwise, reference the field as a raw macptr. - (let* ((to (foreign-pointer-type-to ftype))) - (if - (and (typep to 'foreign-record-type) - (eq :struct (foreign-record-type-kind to)) - (progn - (ensure-foreign-type-bits to) - (let* ((first-field (car (foreign-record-type-fields to))) - (first-field-type - (if first-field - (foreign-record-field-type first-field)))) - (and (typep first-field-type 'foreign-pointer-type) - (let* ((first-to (foreign-pointer-type-to - first-field-type))) - (and (typep first-to 'foreign-record-type) - (eq :struct - (foreign-record-type-kind first-to)) - (eq :objc_class - (foreign-record-type-name first-to)))))))) - (values #'%get-ptr #'%set-ptr) - (values #'(lambda (ptr offset) - (let* ((p (%null-ptr))) - (%set-macptr-domain p 1) - (%setf-macptr p (%get-ptr ptr offset)))) - #'%set-ptr)))) - (foreign-mem-block-type - (let* ((nbytes (%foreign-type-or-record-size ftype :bytes))) - (values #'%inc-ptr #'(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 - (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) - append (list (first l) (second l)) into new-initargs))) - -(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) - (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)) - - -;;; This (interesting) code has never been enabled, and is (slightly) -;;; broken by the new (lazy, declaration-based) implementation of SEND -;;; and friends. -;;; We probably want to un-break this (and figure out how to define -;;; ObjC gf's in the new world), and some of the code for compiling -;;; arbitrary message sends may be useful in other contexts. - -#+objc-generic-functions -(progn -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Generic Function and Method Protocols ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The classes of ObjC generic functions and methods - -(defclass objc-generic-function (standard-generic-function) - () - (:metaclass funcallable-standard-class)) - -(defclass objc-method (standard-method) ()) - - -;;; Return the generic function name, lambda list and keywords corresponding -;;; to a given ObjC MSG - -(defun gfify (msg) - (let* ((mcomps (split-if-char #\: msg :elide)) - (ncolons (count #\: msg)) - (prefix (if (zerop ncolons) "@" ""))) - (values (compute-lisp-name - (if (zerop ncolons) - (string-cat prefix (first mcomps)) - (first mcomps)) - (find-package "NS")) - (if (zerop ncolons) '(%self) '(%self %arg &key)) - (mapcar #'compute-lisp-name (rest mcomps))))) - - -;;; Special dcode for ObjC generic functions -;;; Currently, the list of keywords is used as the qualifier for an ObjC method -;;; This dcode just scans the list of methods looking for one whose qualifer -;;; matches the keywords in this call - -(defun %%objc-dcode (dt args) - (flet ((invoke-method (largs) - (multiple-value-bind (keys vals) (keys-and-vals (cddr largs)) - (declare (ignore vals)) - (dolist (m (%gf-dispatch-table-methods dt)) - (when (equal (method-qualifiers m) keys) - (return-from %%objc-dcode (apply (method-function m) largs)))) - (apply #'no-applicable-method (%gf-dispatch-table-gf dt) largs)))) - ;; If only one arg is present, ARGS is apparently not encoded - (if (numberp args) - (with-list-from-lexpr (l args) (invoke-method l)) - (invoke-method (list args))))) - - -;;; Ensure that the generic function corresponding to MSG exists - -(defun ensure-objc-generic-function (msg) - (cond - ((null (message-descriptors msg)) - (error "Unknown ObjC message: ~S" msg)) - ((troublesome-message-p msg) nil) - (t - (multiple-value-bind (gf-name lambda-list) (gfify msg) - (let ((gf (ensure-generic-function - gf-name - :lambda-list lambda-list - :generic-function-class (find-class 'objc-generic-function) - :method-class (find-class 'objc-method)))) - (setf (%gf-dcode gf) #'%%objc-dcode) - gf))))) - - -;;; Create the method function corresponding to the given ObjC MSG - -(defun make-objc-method-function (msg lambda-list keys) - (let ((msgdescs (message-descriptors msg))) - (compile - nil - (if (= (length msgdescs) 1) - ;; The type signature is unique - `(lambda ,lambda-list - ,(build-message-send - msg (msg-desc-type-signature (first msgdescs)) keys)) - ;; The type signature is ambiguous - `(lambda ,lambda-list - (cond - ,@(loop for md in msgdescs - collect - `((or - ,@(loop for c in (msg-desc-classes md) - collect - `(typep %self ',(class-name c)))) - (locally - (declare (,(class-name (first (msg-desc-classes md))) - %self)) - ,(build-message-send - msg (msg-desc-type-signature md) keys)))))))))) - - -;;; Build the message-sending code for the given message with the given -;;; type signature and keys - -(defun build-message-send (msg tsig keys) - (let* ((rvars nil) - (args (if (zerop (count #\: msg)) - nil - (loop - for a in (cons '%arg keys) - for ftype in (rest tsig) - for r/s-assoc = (coerceable-foreign-record-p ftype) - for sname = (gensym) - if r/s-assoc - do (push (list sname (fudge-objc-type ftype)) rvars) - and collect - (generate-structure-to-foreign-record-copier-form - (record-structure-association-structure-name r/s-assoc) - (record-structure-association-record-name r/s-assoc) - :struct-name a :record-name sname) - else collect a)))) - (if (requires-stret-p (first tsig)) - ;; STRET message send - (let ((r (gensym))) - `(rlet ((,r ,(fudge-objc-type (first tsig))) ,@rvars) - (send/stret ,r %self ,msg ,@args) - ,(create-structure-from-record-form r (cadar tsig)))) - ;; Normal message send - `(rlet ,rvars - (send %self ,msg ,@args))))) - - -;;; Ensure that the method corresponding to CLASS's method for MSG exists - -(defun ensure-objc-method (msg) - (cond - ((null (message-descriptors msg)) - (error "Unknown ObjC message: ~S" msg)) - ((troublesome-message-p msg) nil) - (t - (flet ((keywordify (sym) - (intern (string sym) (find-package 'keyword)))) - (multiple-value-bind (gf-name lambda-list keys) (gfify msg) - (let* ((gf (ensure-objc-generic-function msg)) - (lambda-list (append lambda-list keys)) - (m - (ensure-method - gf-name - nil - :function (make-objc-method-function msg lambda-list keys) - :qualifiers (mapcar #'keywordify keys) - :lambda-list lambda-list))) - (setf (%gf-dcode gf) #'%%objc-dcode) - m)))))) - - -;;; Generate ObjC methods for all messages in *TYPE-SIGNATURE-TABLE* - -(defun define-all-objc-methods () - (declare (special *type-signature-table*)) - (maphash #'(lambda (msg ignore) - (declare (ignore ignore)) - (ensure-objc-method msg)) - *type-signature-table*)) - - -;;; Lisp structures analogous to common Cocoa records - -(defstruct (ns-range (:constructor make-ns-range (location length))) - location - length) - -(defun ns-make-range (loc len) - (make-ns-range loc len)) - -(defstruct (ns-point (:constructor make-ns-point (x y))) - x - y) - -(defun ns-make-point (x y) - (make-ns-point (coerce x 'single-float) (coerce y 'single-float))) - -(defstruct (ns-size (:constructor make-ns-size (width height))) - width - height) - -(defun ns-make-size (w h) - (make-ns-size - (coerce w 'single-float) - (coerce h 'single-float))) - -;;; Note that this is linear: four fields, rather than an ns-point -;;; and an ns-size. -(defstruct (ns-rect - (:constructor make-ns-rect - (origin.x origin.y size.width size.height))) - origin.x - origin.y - size.width - size.height) - -(defun ns-make-rect (ox oy sw sh) - (make-ns-rect - (coerce ox 'single-float) - (coerce oy 'single-float) - (coerce sw 'single-float) - (coerce sh 'single-float))) - -(defstruct (ns-decimal - (:constructor make-ns-decimal - (_exponent _length _is-negative _is-compact _reserved _mantissa))) - _exponent - _length - _is-negative - _is-compact - _reserved - _mantissa) - -;;; Also linear -(defstruct (cg-rect - (:constructor make-cg-rect - (origin.x origin.y size.width size.height))) - origin.x - origin.y - size.width - size.height) - -(defstruct (ns-affine-transform-struct - (:constructor make-ns-affine-transform-struct - (m11 m12 m21 m22 tx ty))) - m11 m12 m21 m22 tx ty) - - -(defun generate-foreign-record-to-structure-copier-form (record-type-name structure-class-name &key (struct-name (gensym)) (record-name (gensym))) - (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name)))) - (record-type (%foreign-type-or-record record-type-name)) - (accessor-names (foreign-record-accessor-names record-type))) - (unless (eq (length slot-names) (length accessor-names)) - (error "Slot names ~s don't match record accessors ~s" - slot-names accessor-names)) - (let* ((body (mapcar #'(lambda (slot-name accessor) - `(setf (slot-value ,struct-name ',slot-name) - ,(%foreign-access-form record-name - record-type - 0 - accessor))) - slot-names accessor-names))) - `(progn ,@body ,struct-name)))) - -(defun generate-structure-to-foreign-record-copier-form - (structure-class-name record-type-name - &key - (struct-name (gensym)) - (record-name (gensym))) - (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name)))) - (record-type (%foreign-type-or-record record-type-name)) - (accessor-names (foreign-record-accessor-names record-type))) - (unless (eq (length slot-names) (length accessor-names)) - (error "Slot names ~s don't match record accessors ~s" - slot-names accessor-names)) - (let* ((body (mapcar #'(lambda (slot-name accessor) - `(setf ,(%foreign-access-form record-name - record-type - 0 - accessor) - (slot-value ,struct-name ',slot-name))) - slot-names accessor-names))) - `(progn ,@body ,record-name)))) - -(defun generate-foreign-record-to-structure-creator-form - (record-type-name constructor-name &key (record-name (gensym))) - (let* ((record-type (%foreign-type-or-record record-type-name)) - (accessor-names (foreign-record-accessor-names record-type)) - (args (mapcar #'(lambda (accessor) - (%foreign-access-form record-name - record-type - 0 - accessor)) - accessor-names))) - `(,constructor-name ,@args))) - - -(defstruct record-structure-association - record-name - structure-name - structure-constructor-name) - -(defparameter *record-structure-associations* ()) - -(defun record-structure-association-from-record-name (r) - (find r *record-structure-associations* :key #'record-structure-association-record-name)) - -(defun need-record-structure-association-from-record-name (r) - (or (record-structure-association-from-record-name r) - (error "No lisp structure associated with foreign record named ~s" r))) - -(defun record-structure-association-from-structure-name (r) - (find r *record-structure-associations* :key #'record-structure-association-structure-name)) - -(defun associate-record-with-structure (record-name structure-name constructor-name) - (let* ((already-r (record-structure-association-from-record-name record-name)) - (already-s (record-structure-association-from-structure-name structure-name)) - (already (or already-r already-s)) - (different (not (eq already-r already-s)))) - (if already - (if different - (if already-r - (error "~&Record named ~s is already associated with structure named ~s" - (record-structure-association-record-name already-r) - (record-structure-association-structure-name already-r)) - (if already-s - (error "~&Structure named ~s is already associated with record named ~s" - (record-structure-association-structure-name already-s) - (record-structure-association-record-name already-s)))) - (setf (record-structure-association-structure-constructor-name already) - constructor-name)) - (push (make-record-structure-association - :record-name record-name - :structure-name structure-name - :structure-constructor-name constructor-name) - *record-structure-associations*)) - t)) - -(defun create-structure-from-record-form (var record-type) - (let* ((a (need-record-structure-association-from-record-name - record-type)) - (constructor - (record-structure-association-structure-constructor-name a))) - (generate-foreign-record-to-structure-creator-form - record-type constructor :record-name var))) - -(defun coerceable-foreign-record-p (ftype) - (and (consp ftype) - (eq (first ftype) :struct) - (find (second ftype) *record-structure-associations* - :key #'record-structure-association-record-name))) - -(associate-record-with-structure :_ect 'ns-rect 'make-ns-rect) -(associate-record-with-structure :_oint 'ns-point 'make-ns-point) -(associate-record-with-structure :_ize 'ns-size 'make-ns-size) -(associate-record-with-structure :_ange 'ns-range 'make-ns-range) -(associate-record-with-structure :ecimal 'ns-decimal 'make-ns-decimal) -(associate-record-with-structure :ect 'cg-rect 'make-cg-rect) -(associate-record-with-structure :_ffineransformtruct - 'ns-affine-transform-struct - 'make-ns-affine-transform-struct) -) ; #+objc-generic-functions Index: unk/ccl/examples/objc-package.lisp =================================================================== --- /trunk/ccl/examples/objc-package.lisp (revision 6894) +++ (revision ) @@ -1,59 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2007 Clozure Associates and contributors. -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html -;;; - -(in-package "CCL") - -;;; All class names and instance variable names are interned in the NS package -;;; Force all symbols interned in the NS package to be external - -(defpackage "NS" - (:use) - (:export "+CGFLOAT-ZERO+" "CGFLOAT")) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (package-force-export "NS")) - -;;; ObjC function names (as produced by #/) are interned in NSF. -(defpackage "NEXTSTEP-FUNCTIONS" - (:use) - (:nicknames "NSFUN")) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (package-force-export "NSFUN")) - -(defpackage "OBJC" - (:use) - (:export "OBJC-OBJECT" "OBJC-CLASS-OBJECT" "OBJC-CLASS" "OBJC-METACLASS" - "@CLASS" "@SELECTOR" "MAKE-OBJC-INSTANCE" "RETURNING-FOREIGN-STRUCT" - "DEFMETHOD" "SLET" "SEND" "SEND/STRET" "SEND-SUPER" "SEND-SUPER/STRET" - "DEFINE-OBJC-METHOD" "DEFINE-OBJC-CLASS-METHOD" - "OBJC-MESSAGE-SEND" "OBJC-MESSAGE-SEND-STRET" - "OBJC-MESSAGE-SEND-SUPER" "OBJC-MESSAGE-SEND-SUPER-STRET" - "LOAD-FRAMEWORK")) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (import '(objc:@class objc:@selector objc:make-objc-instance - objc:send objc:send/stret objc:send-super objc:send-super/stret - ns:+cgfloat-zero+ ns:cgfloat - objc:define-objc-method objc:define-objc-class-method - objc:objc-message-send objc:objc-message-send-stret - objc:objc-message-send-super objc:objc-message-send-super-stret - ) - "CCL")) - -(provide "OBJC-PACKAGE") Index: unk/ccl/examples/objc-readtable.lisp =================================================================== --- /trunk/ccl/examples/objc-readtable.lisp (revision 6894) +++ (revision ) @@ -1,65 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2002-2003 Clozure Associates -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html - -(in-package "CCL") - -(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: unk/ccl/examples/objc-runtime.lisp =================================================================== --- /trunk/ccl/examples/objc-runtime.lisp (revision 6894) +++ (revision ) @@ -1,2876 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- -;;; -;;; Copyright (C) 2002-2003 Clozure Associates -;;; This file is part of OpenMCL. -;;; -;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public -;;; License , known as the LLGPL and distributed with OpenMCL as the -;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, -;;; which is distributed with OpenMCL as the file "LGPL". Where these -;;; conflict, the preamble takes precedence. -;;; -;;; OpenMCL is referenced in the preamble as the "LIBRARY." -;;; -;;; The LLGPL is also available online at -;;; http://opensource.franz.com/preamble.html - - -(in-package "CCL") - - -;;; Utilities for interacting with the Apple/GNU Objective-C runtime -;;; systems. - -(eval-when (:compile-toplevel :load-toplevel :execute) - #+darwin-target (pushnew :apple-objc *features*) - #+(and darwin-target 64-bit-target) (pushnew :apple-objc-2.0 *features*) - #-darwin-target (pushnew :gnu-objc *features*)) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (set-dispatch-macro-character - #\# - #\@ - (nfunction - |objc-#@-reader| - (lambda (stream subchar numarg) - (declare (ignore subchar numarg)) - (let* ((string (read stream))) - (unless *read-suppress* - (check-type string string) - `(@ ,string))))))) - -(eval-when (:compile-toplevel :execute) - #+apple-objc - (progn - (use-interface-dir :cocoa) - (use-interface-dir :carbon)) ; need :carbon for things in this file - #+gnu-objc - (use-interface-dir :gnustep)) - - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "OBJC-PACKAGE") - (require "SPLAY-TREE") - (require "NAME-TRANSLATION") - (require "OBJC-CLOS")) - -(defloadvar *NSApp* nil ) - -;;; Apple ObjC 2.0 provides (#_objc_getProtocol name). In other -;;; runtimes, there doesn't seem to be any way to find a Protocol -;;; object given its name. We need to be able to ask at runtime -;;; whether a given object conforms to a protocol in order to -;;; know when a protocol method is ambiguous, at least when the -;;; message contains ambiguous methods and some methods are protocol -;;; methods -(defloadvar *objc-protocols* (make-hash-table :test #'equal)) - -(defstruct objc-protocol - name - address) - -(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) - ;; 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 a - ;; 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)))))) - ;; 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 - (%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 get-objc-class-decl (class-name &optional (use-db t)) - (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) - #+x8664-target - (%def-foreign-type : (foreign-pointer-type-to (parse-foreign-type :x86_64_marg_list))) - #+ppc-target - (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 x8664-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)) - (stackparams (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) marg-ptr stackparams)) - (gpr-offset (if (< n-static-gprs 6) n-static-gprs n-static-stack-args)) - (fpr-offset (if (< n-static-fprs 8) - (* 16 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 - (if (eq fpr-base stackparams) - (setq fpr-offset (* 2 fpr-offset))) - (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 ((,marg-ptr (+ ,(%foreign-type-or-record-size - : :bytes) - (* 8 ,stack-total)))) - - (setf (pref ,marg-ptr :.rax) ,fpr-total) - (with-macptrs ((,regparams (pref ,marg-ptr :.reg

arams)) - (,stackparams (pref ,marg-ptr :.stack

arams))) - (progn ,@(static-arg-forms)) - (%process-varargs-list ,regparams ,marg-ptr ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg) - (external-call "_objc_msgSendv" - :address ,receiver - :address ,selptr - :size_t (+ 48 (* 8 ,stack-total)) - :address ,marg-ptr - ,return-type-spec))))))))) - -#+(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)) - ,@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-cstrs ((s string)) - (%make-nsstring-from-c-string s))) - -#+apple-objc-2.0 -;;; This isn't defined in headers; it's sort of considered a built-in -;;; type by the ObjC frontend. (See also the ObjC runtime source.) -(eval-when (:compile_toplevel :execute) - (def-foreign-type nil - (:struct :_objc_exception_data - (:buf :jmp_buf) - (:pointers (:array :address 4))))) - - -#+apple-objc-2.0 -(defmacro with-ns-exceptions-as-errors (&body body) - (let* ((data (gensym)) - (cframe (gensym))) - `(rletZ ((,data :_objc_exception_data)) - (unwind-protect - (progn - (#_objc_exception_try_enter ,data) - (catch ,data - (with-c-frame ,cframe - (%associate-jmp-buf-with-catch-frame - ,data - (%fixnum-ref (%current-tcr) target::tcr.catch-top) - ,cframe) - (progn - ,@body)))) - (check-ns-exception ,data))))) - - - -#-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) - ) - -#+apple-objc-2.0 -(defun check-ns-exception (data) - (with-macptrs ((exception (#_objc_exception_extract data))) - (if (%null-ptr-p exception) - (#_objc_exception_try_exit data) - (error (ns-exception->lisp-condition (%inc-ptr exception 0)))))) - -#+(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: unk/ccl/examples/objc-support.lisp =================================================================== --- /trunk/ccl/examples/objc-support.lisp (revision 6894) +++ (revision ) @@ -1,447 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- - -(in-package "CCL") - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "BRIDGE")) - -(defun allocate-objc-object (class) - (#/alloc class)) - -(defun conforms-to-protocol (thing protocol) - (#/conformsToProtocol: thing (objc-protocol-address protocol))) - - - - -#+apple-objc -(defun iterate-over-objc-classes (fn) - (let* ((n (#_objc_getClassList (%null-ptr) 0))) - (declare (fixnum n)) - (%stack-block ((buffer (the fixnum (ash n target::word-shift)))) - (#_objc_getClassList buffer n) - (do* ((i 0 (1+ i))) - ((= i n) (values)) - (declare (fixnum i)) - (funcall fn (paref buffer (:* :id) i)))))) - -#+apple-objc -(defun count-objc-classes () - (#_objc_getClassList (%null-ptr) 0)) - -#+gnu-objc -(defun iterate-over-objc-classes (fn) - (rletZ ((enum-state :address)) - (loop - (let* ((class (#_objc_next_class enum-state))) - (if (%null-ptr-p class) - (return) - (funcall fn class)))))) - -#+gnu-objc -(defun count-objc-classes () - (let* ((n 0)) - (declare (fixnum n)) - (rletZ ((enum-state :address)) - (if (%null-ptr-p (#_objc_next_class enum-state)) - (return n) - (incf n))))) - -(defun %note-protocol (p) - (with-macptrs ((cname (objc-message-send p "name" :address))) - (let* ((namelen (%cstrlen cname)) - (name (make-string namelen))) - (declare (dynamic-extent name)) - (%str-from-ptr cname namelen name) - (let* ((proto (or (gethash name *objc-protocols*) - (progn - (setq name (subseq name 0)) - (setf (gethash name *objc-protocols*) - (make-objc-protocol :name name)))))) - (unless (objc-protocol-address proto) - (setf (objc-protocol-address proto) (%inc-ptr p 0))) - proto)))) - -(defun note-class-protocols (class) - #-apple-objc-2.0 - (do* ((protocols (pref class :objc_class.protocols) - (pref protocols :objc_protocol_list.next))) - ((%null-ptr-p protocols)) - (let* ((count (pref protocols :objc_protocol_list.count))) - (with-macptrs ((list (pref protocols :objc_protocol_list.list))) - (dotimes (i count) - (with-macptrs ((p (paref list (:* (:* (:struct :

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

rotocol))) i))) - (%note-protocol p)))) - (unless (%null-ptr-p protocols) (#_free protocols))))) - - -(defun map-objc-classes (&optional (lookup-in-database-p t)) - (iterate-over-objc-classes - #'(lambda (class) - (note-class-protocols class) - (install-foreign-objc-class class lookup-in-database-p)))) - -(let* ((nclasses 0)) - (declare (fixnum nclasses)) - (defun maybe-map-objc-classes () - (let* ((new (count-objc-classes))) - (declare (fixnum new)) - (unless (= nclasses new) - (setq nclasses new) - (map-objc-classes) - t)))) - -(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.a - (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")) - - - -(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 %make-nsstring-from-c-string (s) - (#/initWithCString: (#/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)) - -;;; This can fail if the nsstring contains non-8-bit characters. -(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 -;;; (#__NSRaiseError nsexception) is entirely equivalent to -;;; -[NSException raise]. If we get nervous about passing the former -;;; around, we can always look up the method imp of the latter. -(defmacro raising-ns-exception-on-error (&body body) - `(handler-case (progn ,@body) - (error (c) (external-call "__NSRaiseError" :address (ns-exception c) :void)))) - -#+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.) - (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 (#_malloc nbytes))) - (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 #__NSRaiseError in the %rdx slot, the - ;; original return address in the %xmm0 slot, and force a return to - ;; the trampoline code above. - (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 "__NSRaiseError"))))) - (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) - (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: unk/ccl/examples/process-objc-modules.lisp =================================================================== --- /trunk/ccl/examples/process-objc-modules.lisp (revision 6894) +++ (revision ) @@ -1,217 +1,0 @@ -;;;-*-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") -