Index: anches/ide-1.0/ccl/examples/CocoaBridgeDoc.txt =================================================================== --- /branches/ide-1.0/ccl/examples/CocoaBridgeDoc.txt (revision 6866) +++ (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: anches/ide-1.0/ccl/examples/cocoa-application.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-application.lisp (revision 6866) +++ (revision ) @@ -1,89 +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. - - - - -(defclass cocoa-application (application) - ()) - -(defmethod application-error ((a application) condition error-pointer) - (break-loop-handle-error condition error-pointer)) - - -;;; 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 nil)) - -(defmethod toplevel-function ((a cocoa-application) init-file) - (declare (ignore init-file)) - (when (< #&NSAppKitVersionNumber 824) - (#_NSLog #@"This application requires features introduced in OSX 10.4.") - (#_ _exit -1)) - (setq *standalone-cocoa-ide* t) - (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 - (make-pathname - :directory (pathname-directory (translate-logical-pathname "ccl:OpenMCL.app;Contents;MacOS;")) - :name (standard-kernel-name)) - :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: anches/ide-1.0/ccl/examples/cocoa-backtrace.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-backtrace.lisp (revision 6866) +++ (revision ) @@ -1,250 +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 :foreign-type :int :accessor frame-label-number) - (controller :foreign-type :id :reader frame-label-controller) - (frame-inspector :initform nil :accessor frame-label-frame-inspector)) - (:metaclass ns:+ns-object)) - -(objc:defmethod #/initWithFrameNumber:controller: ((self frame-label) (frame-number :int) controller) - (let* ((obj (#/init self))) - (unless (%null-ptr-p obj) - (setf (slot-value obj 'frame-number) frame-number - (slot-value obj 'controller) controller)) - obj)) - - -(defclass item-label (ns-lisp-string) - ((frame-label :foreign-type :id :accessor item-label-label) - (index :foreign-type :int :accessor item-label-index)) - (:metaclass ns:+ns-object)) - -(objc:defmethod #/initWithFrameLabel:index: ((self item-label) the-frame-label (index :int)) - (let* ((obj (#/init self))) - (unless (%null-ptr-p obj) - (setf (slot-value obj 'frame-label) the-frame-label - (slot-value obj 'index) index)) - obj)) - -(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) - (#/setTarget: outline self) - (#/setDoubleAction: outline (@selector #/backtraceDoubleClick:)) - (#/setShouldCascadeWindows: self nil) - (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))) - (listener-window (if (typep process 'cocoa-listener-process) - (cocoa-listener-process-window process)))) - (when listener-window - (let* ((listener-frame (#/frame listener-window)) - (backtrace-width (ns:ns-rect-width (#/frame window))) - (new-x (- (+ (ns:ns-rect-x listener-frame) - (/ (ns:ns-rect-width listener-frame) 2)) - (/ backtrace-width 2)))) - (ns:with-ns-point (p new-x (+ (ns:ns-rect-y listener-frame) (ns:ns-rect-height listener-frame))) - (#/setFrameOrigin: window p)))) - (#/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 (#/backtraceDoubleClick: :void) - ((self backtrace-window-controller) sender) - (let* ((row (#/clickedRow sender))) - (if (>= row 0) - (let* ((item (#/itemAtRow: sender row)) - (val-p nil) - (value nil)) - (cond ((typep item 'frame-label) - (let* ((controller (frame-label-controller item)) - (inspector (backtrace-controller-inspector controller)) - (frame-number (frame-label-number item))) - (setq val-p t value (inspector::line-n inspector frame-number)))) - ((typep item 'item-label) - (let* ((the-frame-label (item-label-label item)) - (frame-inspector (frame-label-frame-inspector the-frame-label)) - (index (item-label-index item)) - (rawval (inspector::line-n frame-inspector index))) - (if (and (consp rawval) - (typep (car rawval) 'keyword)) - (setq val-p t value (cddr rawval)))))) - (if val-p - (cinspect value)))))) - - - - -(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 - :with-frame-number index - :controller self - :string - (let* ((value - (inspector::line-n inspector index))) - (if value - (%lfun-name-string value) - ":kernel"))))) - 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 'item-label - :with-frame-label item - :index index - :string - (let* ((ccl::*aux-vsp-ranges* (inspector::vsp-range inspector)) - (ccl::*aux-tsp-ranges* (inspector::tsp-range inspector)) - (ccl::*aux-csp-ranges* (inspector::csp-range inspector))) - (with-output-to-string (s) - (let* ((value - (inspector::line-n - frame-inspector - index))) - (inspector::prin1-value - frame-inspector - s - value))))))) - (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* ((btwindow (prog1 (bt.dialog context) - (setf (bt.dialog context) nil))) - (restartswindow - (prog1 (car (bt.restarts context)) - (setf (bt.restarts context) nil)))) - (when btwindow - (#/performSelectorOnMainThread:withObject:waitUntilDone: btwindow (@selector #/close) +null-ptr+ t)) - (when restartswindow - (#/performSelectorOnMainThread:withObject:waitUntilDone: restartswindow (@selector #/close) +null-ptr+ t))))))) - - - - - - - Index: anches/ide-1.0/ccl/examples/cocoa-defaults.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-defaults.lisp (revision 6866) +++ (revision ) @@ -1,134 +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 - change-hook ; an optional hook function - ) - -(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 change-hook) - (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 - :change-hook change-hook)) - (if (eq type :color) - (apply #'color-values-to-nscolor value) - value)) - -;;; Names which contain #\* confuse Cocoa Bindings. -(defun objc-default-key (name) - (ns-constant-string (lisp-to-objc-message (list (make-symbol (remove #\* (string name))))))) - - -(defun %define-cocoa-default (name type value doc &optional change-hook) - (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 (objc-default-key name) type value doc change-hook)) - name) - - - -(defmacro def-cocoa-default (name type value doc &optional change-hook &environment env) - `(progn - (eval-when (:compile-toplevel) - (note-variable-info ',name :global ,env)) - (declaim (special ,name)) - (defloadvar ,name nil) - (%define-cocoa-default ',name ',type ,value ',doc ,change-hook))) - - -(defun update-cocoa-defaults () - (update-cocoa-defaults-list - (#/standardUserDefaults ns:ns-user-defaults) - (cocoa-defaults))) - -(defun update-cocoa-defaults-list (domain defaults) - (dolist (d defaults) - (let* ((name (cocoa-default-symbol d)) - (type (cocoa-default-type d)) - (key (objc-constant-string-nsstringptr (cocoa-default-string d)))) - (let* ((hook (cocoa-default-change-hook d)) - (old-value (symbol-value name))) - (case type - (:int - (set name (#/integerForKey: domain key))) - (:float - (set name (#/floatForKey: domain key))) - (:bool - (set name (#/boolForKey: domain key))) - (:string - (let* ((nsstring (#/stringForKey: domain key))) - (unless (%null-ptr-p nsstring) - (set name (lisp-string-from-nsstring nsstring))))) - (:color - (let* ((data (#/dataForKey: domain key))) - (unless (%null-ptr-p data) - (set name (#/retain (#/unarchiveObjectWithData: ns:ns-unarchiver data))))))) - (when hook (funcall hook old-value (symbol-value name))))))) - - - -;;; Return an NSDictionary describing the "default" values of the defaults. -(defun cocoa-defaults-initial-values () - (let* ((defaults (cocoa-defaults)) - (dict (make-instance 'ns:ns-mutable-dictionary - :with-capacity (length defaults)))) - (dolist (d defaults dict) - (let* ((value (cocoa-default-value d))) - (#/setObject:forKey: dict - (case (cocoa-default-type d) - (:color (#/archivedDataWithRootObject: - ns:ns-archiver - (apply #'color-values-to-nscolor value))) - (:bool (if value #@"YES" #@"NO")) - (t - (%make-nsstring (format nil "~a" (cocoa-default-value d))))) - (objc-constant-string-nsstringptr (cocoa-default-string d))))))) Index: anches/ide-1.0/ccl/examples/cocoa-doc.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-doc.lisp (revision 6866) +++ (revision ) @@ -1,177 +1,0 @@ -(in-package "CCL") - -(def-cocoa-default *hyperspec-http-url-string* :string "http://www.lisp.org/HyperSpec/" "HTTP URL for HyperSpec lookup") - -(def-cocoa-default *hyperspec-file-url-string* :string "/" "filesystem path for HyperSpec lookup") - -(defloadvar *hyperspec-root-url* nil) -(defloadvar *hyperspec-map-sym-hash* nil) - - -(defloadvar *hyperspec-map-sym-url* nil) - -(def-cocoa-default *hyperspec-use-file-url* :bool nil "selects hyperspec url scheme") - - -(def-cocoa-default *hyperspec-lookup-enabled* :bool nil "enables hyperspec lookup" - (lambda (old new) - (unless (eq new old) - (if new - (setup-hyperspec-root-url) - (progn - (when *hyperspec-root-url* - (#/release *hyperspec-root-url*)) - (setq *hyperspec-root-url* nil) - (when *hyperspec-map-sym-url* - (#/release *hyperspec-map-sym-url*)) - (setq *hyperspec-root-url* nil) - (setq *hyperspec-map-sym-hash* nil)))))) - - -(defclass display-document (ns:ns-document) - ((text-view :foreign-type :id)) - (:metaclass ns:+ns-object)) - -(defclass url-delegate (ns:ns-object) - () - (:metaclass ns:+ns-object)) - -(objc:defmethod (#/textView:clickedOnLink:atIndex: :) - ((self url-delegate) - textview - link - (index :nteger)) - (declare (ignorable link)) - (let* ((attribute (#/attribute:atIndex:effectiveRange: - (#/textStorage textview) - #&NSLinkAttributeName - index - +null-ptr+))) - (if (typep attribute 'ns:ns-url) - (rlet ((dictp :id +null-ptr+)) - (let* ((data (make-instance 'ns:ns-data :with-contents-of-url attribute)) - (string (unless (%null-ptr-p data) - (make-instance 'ns:ns-attributed-string - :with-html data - :base-url attribute - :document-attributes dictp))) - (textstorage (#/textStorage textview)) - (dict (pref dictp :id)) - (title (unless (%null-ptr-p dict) - (#/valueForKey: dict #&NSTitleDocumentAttribute)))) - (when title - (#/setTitle: (#/window textview) title)) - (when string - (#/beginEditing textstorage) - (#/replaceCharactersInRange:withAttributedString: - textstorage - (ns:make-ns-range 0 (#/length textstorage)) - string) - (#/setSelectedRange: textview (ns:make-ns-range 0 0)) - (#/endEditing textstorage) - (#/scrollRangeToVisible: textview (ns:make-ns-range 0 0))))))) - #$YES) - -(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :) - ((self url-delegate) - textview - (range :ange) - string) - (declare (ignorable textview range string)) - nil) - - - - - -(objc:defmethod #/windowNibName ((self display-document)) - #@"displaydoc") - -(objc:defmethod (#/windowControllerDidLoadNib: :void) - ((self display-document) controller) - (with-slots (text-view) self - (unless (%null-ptr-p text-view) - (#/setEditable: text-view t) - (#/setDelegate: text-view (make-instance 'url-delegate)))) - (call-next-method controller)) - - -(defun hyperspec-root-url () - (or *hyperspec-root-url* - (set *hyperspec-root-url* (setup-hyperspec-root-url)))) - -(defun setup-hyperspec-root-url () - (make-instance 'ns:ns-url - :with-string - (%make-nsstring - (if *hyperspec-use-file-url* - *hyperspec-file-url-string* - *hyperspec-http-url-string*)))) - - - - -(defun hyperspec-map-hash (document) - (or *hyperspec-map-sym-hash* - (rlet ((perror :id +null-ptr+)) - (let* ((map-url (make-instance 'ns:ns-url :with-string "Data/Map_Sym.txt" :relative-to-url (hyperspec-root-url))) - (data (make-instance 'ns:ns-data - :with-contents-of-url map-url - :options 0 - :error perror))) - (let* ((err (pref perror :id))) - (unless (%null-ptr-p err) - (#/presentError: document err) - (return-from hyperspec-map-hash nil))) - (with-input-from-string (s (%str-from-ptr (#/bytes data) (#/length data))) - (let* ((hash (make-hash-table :test #'eq)) - (*package* (find-package "CL")) - (eof (cons nil nil))) - (declare (dynamic-extent eof)) - (loop - (let* ((sym (read s nil eof)) - (url (read-line s nil eof))) - (when (eq sym eof) - (return - (setq *hyperspec-map-sym-url* map-url - *hyperspec-map-sym-hash* hash))) - (setf (gethash sym hash) url))))))))) - -(defun lookup-hyperspec-symbol (symbol doc) - (let* ((relative-url (gethash symbol (hyperspec-map-hash doc)))) - (when relative-url - (let* ((url (#/absoluteURL - (make-instance 'ns:ns-url - :with-string (%make-nsstring relative-url) - :relative-to-url *hyperspec-map-sym-url*)))) - (rlet ((pdocattrs :id +null-ptr+) - (perror :id +null-ptr+)) - (let* ((data (make-instance 'ns:ns-data - :with-contents-of-url url - :options 0 - :error perror))) - (if (not (%null-ptr-p (pref perror :id))) - (progn - (#/presentError: doc (pref perror :id))) - (let* ((string (make-instance 'ns:ns-attributed-string - :with-html data - :base-url url - :document-attributes pdocattrs)) - (docattrs (pref pdocattrs :id)) - (title (if (%null-ptr-p docattrs) - +null-ptr+ - (#/objectForKey: docattrs #&NSTitleDocumentAttribute)))) - (if (%null-ptr-p title) - (setq title (%make-nsstring (string symbol)))) - (#/newDisplayDocumentWithTitle:content: - (#/sharedDocumentController ns:ns-document-controller) - title - string))))))))) - - - - - - - - Index: anches/ide-1.0/ccl/examples/cocoa-editor.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-editor.lisp (revision 6866) +++ (revision ) @@ -1,2558 +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") - -(def-cocoa-default *editor-background-color* :color '(1.0 1.0 1.0 1.0) "Editor background color") - - -(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)) - (bold-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold)))) - (unless (eql f font) f))) - (oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:italic)))) - (unless (eql f font) f))) - (bold-oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold :italic)))) - (unless (eql f font) f))) - (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-instance 'ns:ns-mutable-array - :with-capacity (the fixnum (* 4 (length colors))))) - (bold-stroke-width -10.0f0) - (fonts (vector font (or bold-font font) (or oblique-font font) (or bold-oblique-font font))) - (real-fonts (vector font bold-font oblique-font bold-oblique-font)) - (s 0)) - (declare (dynamic-extent fonts real-fonts colors)) - (dotimes (c (length colors)) - (dotimes (i 4) - (let* ((mask (logand i 3))) - (#/addObject: styles - (create-text-attributes :font (svref fonts mask) - :color (svref colors c) - :obliqueness - (if (logbitp 1 i) - (unless (svref real-fonts mask) - 0.15f0)) - :stroke-width - (if (logbitp 0 i) - (unless (svref real-fonts mask) - bold-stroke-width))))) - (incf s))) - (#/retain 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 workline - ) - -;;; 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))))) - (+ (hi::get-line-origin (hi::mark-line mark)) pos))) - -;;; 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 (if line (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))))))) - - - - - -;;; 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) - (hemlock-string :foreign-type :id) - (edit-count :foreign-type :int) - (append-edits :foreign-type :int) - (cache :foreign-type :id) - (styles :foreign-type :id)) - (: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 (#/hemlockString 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 0 - (#_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)) - (with-slots (edit-count) self - #+debug - (#_NSLog #@"begin-editing") - (incf edit-count) - #+debug - (#_NSLog #@"after beginEditing on %@ edit-count now = %d" :id self :int edit-count) - (call-next-method))) - -(objc:defmethod (#/endEditing :void) ((self hemlock-text-storage)) - (with-slots (edit-count) self - #+debug - (#_NSLog #@"end-editing") - (call-next-method) - (decf edit-count) - (when (< edit-count 0) - (#_NSLog #@"after endEditing on %@, edit-count now = %d" :id self :int 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 #/cache ((self hemlock-text-storage)) - (slot-value self 'cache)) - -(objc:defmethod #/hemlockString ((self hemlock-text-storage)) - (slot-value self 'hemlock-string)) - -(objc:defmethod #/styles ((self hemlock-text-storage)) - (slot-value self 'styles)) - -(objc:defmethod #/initWithString: ((self hemlock-text-storage) s) - (setq s (%inc-ptr s 0)) - (let* ((newself (#/init self)) - (styles (make-editor-style-map)) - (cache (#/retain (make-instance ns:ns-mutable-attributed-string - :with-string s - :attributes (#/objectAtIndex: styles 0))))) - (declare (type hemlock-text-storage newself)) - (setf (slot-value newself 'styles) styles) - (setf (slot-value newself 'hemlock-string) s) - (setf (slot-value newself 'cache) cache) - (setf (slot-value newself 'string) (#/retain (#/string cache))) - newself)) - -;;; Should generally only be called after open/revert. -(objc:defmethod (#/updateCache :void) ((self hemlock-text-storage)) - (with-slots (hemlock-string cache styles) self - (#/replaceCharactersInRange:withString: cache (ns:make-ns-range 0 (#/length cache)) hemlock-string) - (#/setAttributes:range: cache (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length cache))))) - -;;; 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: %d storage %@" :unsigned index :id self) - (with-slots (cache styles) self - (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr))) - (when (eql 0 (#/count attrs)) - (#_NSLog #@"No attributes ?") - (ns:with-ns-range (r) - (#/attributesAtIndex:longestEffectiveRange:inRange: - cache index r (ns:make-ns-range 0 (#/length cache))) - (setq attrs (#/objectAtIndex: styles 0)) - (#/setAttributes:range: cache attrs r))) - attrs))) - -(objc:defmethod (#/replaceCharactersInRange:withString: :void) - ((self hemlock-text-storage) (r :ange) string) - #+debug (#_NSLog #@"Replace in range %ld/%ld with %@" - :nteger (pref r :ange.location) - :nteger (pref r :ange.length) - :id string) - (let* ((cache (hemlock-buffer-string-cache (#/hemlockString 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)) - (point (hi::buffer-point buffer))) - (let* ((lisp-string (lisp-string-from-nsstring string)) - (document (if buffer (hi::buffer-document buffer))) - (textstorage (if document (slot-value document 'textstorage)))) - (when textstorage (#/beginEditing textstorage)) - (setf (hi::buffer-region-active buffer) nil) - (unless (zerop length) - (hi::with-mark ((start point) - (end point)) - (move-hemlock-mark-to-absolute-position start cache location) - (move-hemlock-mark-to-absolute-position end cache (+ location length)) - (hi::delete-region (hi::region start end)))) - (hi::insert-string point lisp-string) - (when textstorage - (#/endEditing textstorage) - (for-each-textview-using-storage - textstorage - (lambda (tv) - (hi::disable-self-insert - (hemlock-frame-event-queue (#/window tv))))) - (#/ensureSelectionVisible textstorage))))) - - -(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage) - attributes - (r :ange)) - #+debug - (#_NSLog #@"Set attributes: %@ at %d/%d" :id attributes :int (pref r :ange.location) :int (pref r :ange.length)) - (with-slots (cache) self - (#/setAttributes:range: cache attributes r) - #+debug - (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: cache (pref r :ange.location) +null-ptr+)))) - -(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 'hemlock-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) - (declare (type hemlock-text-storage ts)) - (with-slots (styles) ts - (#/release styles) - (setq styles +null-ptr+)) - (let* ((hemlock-string (slot-value ts 'hemlock-string))) - (setf (slot-value ts 'hemlock-string) +null-ptr+) - - (unless (%null-ptr-p hemlock-string) - (let* ((cache (hemlock-buffer-string-cache hemlock-string)) - (buffer (if cache (buffer-cache-buffer cache)))) - (when buffer - (setf (buffer-cache-buffer cache) nil - (slot-value hemlock-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*)))))) - - - -;;; Mostly experimental, so that we can see what happens when a -;;; real typesetter is used. -(defclass hemlock-ats-typesetter (ns:ns-ats-typesetter) - () - (:metaclass ns:+ns-object)) - -(objc:defmethod (#/layoutGlyphsInLayoutManager:startingAtGlyphIndex:maxNumberOfLineFragments:nextGlyphIndex: :void) - ((self hemlock-ats-typesetter) - layout-manager - (start-index :nteger) - (max-lines :nteger) - (next-index (:* :nteger))) - (#_NSLog #@"layoutGlyphs: start = %d, maxlines = %d" :int start-index :int max-lines) - (call-next-method layout-manager start-index max-lines next-index)) - - - -;;; 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)) - -(objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view) - sender) - (declare (ignorable sender)) - #+debug (#_NSLog #@"Change color to = %@" :id (#/color sender))) - -(def-cocoa-default *layout-text-in-background* :bool t "When true, do text layout when idle.") - -(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void) - ((self hemlock-textstorage-text-view) layout cont (flag :)) - (declare (ignorable cont flag)) - #+debug (#_NSLog #@"layout complete: container = %@, atend = %d" :id cont :int (if flag 1 0)) - (unless *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) - #+debug (#_NSLog #@"Set background color: %@" :id color) - (let* ((old (text-view-blink-color self))) - (unless (%null-ptr-p old) - (#/release old))) - (setf (text-view-blink-color self) (#/retain 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 "off" 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) - (ns:with-ns-range (char-range (text-view-blink-location self) 1) - (let* ((layout (#/layoutManager self)) - (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: - layout - char-range - +null-ptr+))) - (#/lockFocus self) - (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self)) - (#/unlockFocus self))))) - - -(defmethod update-blink ((self hemlock-textstorage-text-view)) - (disable-blink self) - (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage 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") - (update-buffer-package (hi::buffer-document buffer) buffer) - - (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) - (char-width :foreign-type :loat :accessor text-view-char-width) - (char-height :foreign-type :loat :accessor text-view-char-height)) - (:metaclass ns:+ns-object)) - - -(defloadvar *text-view-context-menu* ()) - -(defun text-view-context-menu () - (or *text-view-context-menu* - (setq *text-view-context-menu* - (#/retain - (let* ((menu (make-instance 'ns:ns-menu :with-title #@"Menu"))) - (#/addItemWithTitle:action:keyEquivalent: - menu #@"Cut" (@selector #/cut:) #@"") - (#/addItemWithTitle:action:keyEquivalent: - menu #@"Copy" (@selector #/copy:) #@"") - (#/addItemWithTitle:action:keyEquivalent: - menu #@"Paste" (@selector #/paste:) #@"") - ;; Separator - (#/addItem: menu (#/separatorItem ns:ns-menu-item)) - (#/addItemWithTitle:action:keyEquivalent: - menu #@"Background Color ..." (@selector #/changeBackgroundColor:) #@"") - (#/addItemWithTitle:action:keyEquivalent: - menu #@"Text Color ..." (@selector #/changeTextColor:) #@"") - - menu))))) - -(objc:defmethod (#/changeFont: :void) - ((self hemlock-text-view) sender) - (declare (ignorable sender)) - (#_NSLog #@"changefont!")) - - -(objc:defmethod (#/changeBackgroundColor: :void) - ((self hemlock-text-view) sender) - (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel)) - (color (#/backgroundColor self))) - (#/close colorpanel) - (#/setAction: colorpanel (@selector #/updateBackgroundColor:)) - (#/setColor: colorpanel color) - (#/setTarget: colorpanel self) - (#/setContinuous: colorpanel nil) - (#/orderFrontColorPanel: *NSApp* sender))) - - - -(objc:defmethod (#/updateBackgroundColor: :void) - ((self hemlock-text-view) sender) - (when (#/isVisible sender) - (let* ((color (#/color sender))) - (unless (typep self 'echo-area-view) - (let* ((window (#/window self)) - (echo-view (unless (%null-ptr-p window) - (slot-value window 'echo-area-view)))) - (when echo-view (#/setBackgroundColor: echo-view color)))) - (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender) - (#/setBackgroundColor: self color)))) - -(objc:defmethod (#/changeTextColor: :void) - ((self hemlock-text-view) sender) - (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel)) - (textstorage (#/textStorage self)) - (color (#/objectForKey: - (#/objectAtIndex: (slot-value textstorage 'styles) 0) - #&NSForegroundColorAttributeName))) - (#/close colorpanel) - (#/setAction: colorpanel (@selector #/updateTextColor:)) - (#/setColor: colorpanel color) - (#/setTarget: colorpanel self) - (#/setContinuous: colorpanel nil) - (#/orderFrontColorPanel: *NSApp* sender))) - - - - - - - -(objc:defmethod (#/updateTextColor: :void) - ((self hemlock-textstorage-text-view) sender) - (%call-next-objc-method - self - hemlock-textstorage-text-view - (@selector #/changeColor:) - '(:void :id) - sender) - (#/setNeedsDisplay: self t)) - -(objc:defmethod (#/updateTextColor: :void) - ((self hemlock-text-view) sender) - (let* ((textstorage (#/textStorage self)) - (styles (slot-value textstorage 'styles)) - (newcolor (#/color sender))) - (dotimes (i 4) - (let* ((dict (#/objectAtIndex: styles i))) - (#/setValue:forKey: dict newcolor #&NSForegroundColorAttributeName))) - (call-next-method sender))) - - - - -;;; Access the underlying buffer in one swell foop. -(defmethod text-view-buffer ((self hemlock-text-view)) - (buffer-cache-buffer (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))) - - - - -(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 (#/hemlockString 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 &optional quoted) - (let* ((modifiers (#/modifierFlags nsevent))) - (unless (logtest #$NSCommandKeyMask modifiers) - (let* ((chars (if quoted - (#/characters nsevent) - (#/charactersIgnoringModifiers nsevent))) - (n (if (%null-ptr-p chars) - 0 - (#/length chars))) - (c (if (eql n 1) - (#/characterAtIndex: chars 0)))) - (when c - (let* ((bits 0) - (useful-modifiers (logandc2 modifiers - (logior #$NSShiftKeyMask - #$NSAlphaShiftKeyMask)))) - (unless quoted - (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 q) - #+debug - (#_NSLog #@"Key down event = %@" :address event) - (let* ((buffer (text-view-buffer self))) - (when buffer - (let* ((hemlock-event (nsevent-to-key-event event (hi::frame-event-queue-quoted-insert q )))) - (when hemlock-event - (hi::enqueue-key-event q hemlock-event)))))) - -(defun hi::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. - -(defun handle-key-down (self event) - (let* ((q (hemlock-frame-event-queue (#/window self)))) - (if (or (and (zerop (#/length (#/characters event))) - (hi::frame-event-queue-quoted-insert q)) - (#/hasMarkedText self)) - nil - (progn - (pass-key-down-event-to-hemlock self event q) - t)))) - - -(objc:defmethod (#/keyDown: :void) ((self hemlock-text-view) event) - (or (handle-key-down self event) - (call-next-method 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 (#/hemlockString (#/textStorage 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") - - -;;; 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)) - -(objc:defmethod #/defaultMenu ((class +hemlock-text-view)) - (text-view-context-menu)) - -;;; If we don't override this, NSTextView will start adding Google/ -;;; Spotlight search options and dictionary lookup when a selection -;;; is active. -(objc:defmethod #/menuForEvent: ((self hemlock-text-view) event) - (declare (ignore event)) - (#/menu self)) - -(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color style) - (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))) - #+suffer - (#/setTypesetter: layout (make-instance 'hemlock-ats-typesetter)) - (#/addLayoutManager: textstorage layout) - (#/setUsesScreenFonts: layout t) - (#/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) - (#/setTypingAttributes: tv (#/objectAtIndex: (#/styles textstorage) style)) - (#/setSmartInsertDeleteEnabled: tv nil) - (#/setAllowsUndo: tv nil) ; don't want NSTextView undo - (#/setUsesFindPanel: tv t) - (#/setUsesFontPanel: tv t) - (#/setMenu: tv (text-view-context-menu)) - (#/setWidthTracksTextView: container tracks-width) - (#/setHeightTracksTextView: container nil) - (#/setDocumentView: scrollview tv) - (values tv scrollview))))))))) - -(defun make-scrolling-textview-for-pane (pane textstorage track-width color style) - (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 - style) - (#/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))) - #+debug (#_NSLog #@"Activating text pane") - (#/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 (#/hemlockString (#/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)) - -(defmethod update-buffer-package ((doc echo-area-document) buffer) - (declare (ignore buffer))) - -(objc:defmethod (#/close :void) ((self 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)))) - -(objc:defmethod (#/updateChangeCount: :void) - ((self echo-area-document) - (change :ocumenthangeype)) - (declare (ignore change))) - -(objc:defmethod (#/keyDown: :void) ((self echo-area-view) event) - (or (handle-key-down self event) - (call-next-method 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) - (#/setUsesFontPanel: echo nil) - (#/setHorizontallyResizable: echo t) - (#/setVerticallyResizable: echo nil) - (#/setAutoresizingMask: echo #$NSViewNotSizable) - (#/setBackgroundColor: echo color) - (#/setWidthTracksTextView: container nil) - (#/setHeightTracksTextView: container nil) - (#/setMenu: echo +null-ptr+) - (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))) - #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal) - (#_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)) - #+debug - (#_NSLog #@"Sheet did end")) - -(objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void) - ((self hemlock-frame) sheet code info) - (declare (ignore sheet code)) - #+debug (#_NSLog #@"dismiss sheet: semaphore = %lx" :unsigned-doubleword (#/unsignedLongValue info)) - (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))))) - #+debug - (#_NSLog #@"created semaphore with value %lx" :address (semaphore.value semaphore)) - (rlet ((paramptrs (:array :id 2))) - (setf (paref paramptrs (:array :id) 0) message - (paref paramptrs (:array :id) 1) sem-value) - (let* ((params (make-instance 'ns:ns-array - :with-objects paramptrs - :count 2)) - #|(*debug-io* *typeout-stream*)|#) - (stream-clear-output *debug-io*) - (ignore-errors (print-call-history :detailed-p t)) - (#/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 (class) - (let* ((w (new-cocoa-window :class class - :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 (class ts ncols nrows container-tracks-text-view-width color style) - (let* ((pane (nth-value - 1 - (new-hemlock-document-window class)))) - (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color style) - (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 line-termination of string" - (let* ((string (lisp-string-from-nsstring nsstring)) - (lfpos (position #\linefeed string)) - (crpos (position #\return string)) - (line-termination (if crpos - (if (eql lfpos (1+ crpos)) - :cp/m - :macos) - :unix))) - (hi::insert-string mark - (case line-termination - (:cp/m (remove #\return string)) - (:macos (nsubstitute #\linefeed #\return string)) - (t string))) - line-termination)) - -(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-line-termination 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)))) - - - -(setq hi::*beep-function* #'(lambda (stream) - (declare (ignore stream)) - (#_NSBeep))) - - -;;; This function must run in the main event thread. -(defun %hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style) - (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style)) - (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 (class ts ncols nrows container-tracks-text-view-width color style) - (process-interrupt *cocoa-event-process* - #'%hemlock-frame-for-textstorage - class ts ncols nrows container-tracks-text-view-width color style)) - - - -(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 font) - (when (hi::bufferp buffer) - (let* ((document (hi::buffer-document buffer)) - (textstorage (if document (slot-value document 'textstorage))) - (styles (#/styles textstorage)) - (cache (#/cache textstorage)) - (pos (mark-absolute-position (hi::region-start region))) - (n (- (mark-absolute-position (hi::region-end region)) pos))) - #+debug - (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id (#/objectAtIndex: styles font)) - (#/setAttributes:range: cache (#/objectAtIndex: styles font) (ns:make-ns-range pos n)) - (perform-edit-change-notification textstorage - (@selector #/noteAttrChange:) - pos - n)))) - -(defun buffer-active-font (buffer) - (let* ((style 0) - (region (hi::buffer-active-font-region buffer)) - (textstorage (slot-value (hi::buffer-document buffer) 'textstorage)) - (styles (#/styles textstorage))) - (when region - (let* ((start (hi::region-end region))) - (setq style (hi::font-mark-font start)))) - (#/objectAtIndex: styles style))) - -(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)) - (cache (#/cache textstorage)) - (hemlock-string (#/hemlockString textstorage)) - (display (hemlock-buffer-string-cache hemlock-string)) - (buffer (buffer-cache-buffer display)) - (font (buffer-active-font buffer))) - (unless (eq (hi::mark-%kind mark) :right-inserting) - (decf pos n)) - #+debug - (#_NSLog #@"insert: pos = %d, n = %d" :int pos :int n) - ;;(reset-buffer-cache display) - (adjust-buffer-cache-for-insertion display pos n) - (update-line-cache-for-index display pos) - (let* ((replacestring (#/substringWithRange: hemlock-string (ns:make-ns-range pos n)))) - (ns:with-ns-range (replacerange pos 0) - (#/replaceCharactersInRange:withString: - cache replacerange replacestring))) - (#/setAttributes:range: cache font (ns:make-ns-range pos n)) - #-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 - (let* ((hemlock-string (#/hemlockString textstorage)) - (cache (#/cache textstorage)) - (pos (mark-absolute-position mark))) - (ns:with-ns-range (range pos n) - (#/replaceCharactersInRange:withString: - cache range (#/substringWithRange: hemlock-string range)) - #+debug - (#_NSLog #@"enqueue modify: pos = %d, n = %d" - :int pos - :int n) - #-all-in-cocoa-thread - (#/edited:range:changeInLength: - textstorage - (logior #$NSTextStorageEditedCharacters - #$NSTextStorageEditedAttributes) - range - 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 - (let* ((pos (mark-absolute-position mark)) - (cache (#/cache textstorage))) - #-all-in-cocoa-thread - (progn - (#/edited:range:changeInLength: - textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n)) - (let* ((display (hemlock-buffer-string-cache (#/hemlockString textstorage)))) - (reset-buffer-cache display) - (update-line-cache-for-index display pos))) - (#/deleteCharactersInRange: cache (ns:make-ns-range pos (abs n))) - #+all-in-cocoa-thread - (perform-edit-change-notification textstorage - (@selector #/noteDeletion:) - pos - (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) - (setf (slot-value tv 'char-width) char-width - (slot-value tv 'char-height) char-height) - (#/setResizeIncrements: window - (ns:make-ns-size char-width char-height)))))) - - -(defclass hemlock-editor-window-controller (ns:ns-window-controller) - () - (:metaclass ns:+ns-object)) - - -;;; Map *default-file-character-encoding* to an :tringncoding -(defun get-default-encoding () - (let* ((string (string (or *default-file-character-encoding* - "ISO-8859-1"))) - (len (length string))) - (with-cstrs ((cstr string)) - (with-nsstr (nsstr cstr len) - (let* ((cf (#_CFStringConvertIANACharSetNameToEncoding nsstr))) - (if (= cf #$kCFStringEncodingInvalidId) - (setq cf (#_CFStringGetSystemEncoding))) - (let* ((ns (#_CFStringConvertEncodingToNSStringEncoding cf))) - (if (= ns #$kCFStringEncodingInvalidId) - (#/defaultCStringEncoding ns:ns-string) - ns))))))) - -;;; The HemlockEditorDocument class. - - -(defclass hemlock-editor-document (ns:ns-document) - ((textstorage :foreign-type :id) - (encoding :foreign-type :tringncoding)) - (:metaclass ns:+ns-object)) - -(defmethod update-buffer-package ((doc hemlock-editor-document) buffer) - (let* ((name (hemlock::package-at-mark (hi::buffer-point buffer)))) - (when name - (let* ((pkg (find-package name))) - (if pkg - (setq name (shortest-package-name pkg)))) - (let* ((curname (hi::variable-value 'hemlock::current-package :buffer buffer))) - (if (or (null curname) - (not (string= curname name))) - (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name)))))) - -(objc:defmethod (#/validateMenuItem: :) - ((self hemlock-text-view) item) - (let* ((action (#/action item))) - #+debug (#_NSLog #@"action = %s" :address action) - (if (eql action (@selector #/hyperSpecLookUp:)) - ;;; For now, demand a selection. - (and *hyperspec-root-url* - (not (eql 0 (ns:ns-range-length (#/selectedRange self))))) - (call-next-method item)))) - -(defmethod user-input-style ((doc hemlock-editor-document)) - 0) - -(defvar *encoding-name-hash* (make-hash-table)) - -(defmethod hi::document-encoding-name ((doc hemlock-editor-document)) - (with-slots (encoding) doc - (if (eql encoding 0) - "Automatic" - (or (gethash encoding *encoding-name-hash*) - (setf (gethash encoding *encoding-name-hash*) - (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding))))))) - - -(defmethod textview-background-color ((doc hemlock-editor-document)) - *editor-background-color*) - - -(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts) - (let* ((doc (%inc-ptr self 0)) ; workaround for stack-consed self - (string (#/hemlockString 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* ((encoding (slot-value self 'encoding)) - (nsstring (make-instance ns:ns-string - :with-contents-of-file filename - :encoding encoding - :error +null-ptr+)) - (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 (#/hemlockString 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)))) - (#/updateCache textstorage) - (#/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 (#/readFromURL:ofType:error: :) - ((self hemlock-editor-document) url type (perror (:* :id))) - (declare (ignorable type)) - (rlet ((pused-encoding :tringncoding 0)) - (let* ((pathname - (lisp-string-from-nsstring - (if (#/isFileURL url) - (#/path url) - (#/absoluteString url)))) - (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)) - (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding)) - (string - (if (zerop selected-encoding) - (#/stringWithContentsOfURL:usedEncoding:error: - ns:ns-string - url - pused-encoding - perror) - +null-ptr+))) - (when (%null-ptr-p string) - (if (zerop selected-encoding) - (setq selected-encoding (get-default-encoding))) - (setq string (#/stringWithContentsOfURL:encoding:error: - ns:ns-string - url - selected-encoding - perror))) - (unless (%null-ptr-p string) - (with-slots (encoding) self (setq encoding selected-encoding)) - (hi::queue-buffer-change buffer) - (hi::document-begin-editing self) - (nsstring-to-buffer string buffer) - (let* ((textstorage (slot-value self 'textstorage)) - (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))) - (reset-buffer-cache display) - (#/updateCache textstorage) - (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)) - -(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files") - -(objc:defmethod (#/keepBackupFile :) ((self hemlock-editor-document)) - *editor-keep-backup-files*) - - -(defmethod hemlock-document-buffer (document) - (let* ((string (#/hemlockString (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 (#/noteEncodingChange: :void) ((self hemlock-editor-document) - popup) - (with-slots (encoding) self - (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup))) - ;; Force modeline update. - (hi::queue-buffer-change (hemlock-document-buffer self)))) - -(objc:defmethod (#/prepareSavePanel: :) ((self hemlock-editor-document) - panel) - (with-slots (encoding) self - (let* ((popup (build-encodings-popup (#/sharedDocumentController ns:ns-document-controller) encoding))) - (#/setAction: popup (@selector #/noteEncodingChange:)) - (#/setTarget: popup self) - (#/setAccessoryView: panel popup))) - (#/setExtensionHidden: panel nil) - (#/setCanSelectHiddenExtension: panel nil) - (call-next-method panel)) - - -(defloadvar *ns-cr-string* (%make-nsstring (string #\return))) -(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed))) -(defloadvar *ns-crlf-string* (with-autorelease-pool (#/retain (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*)))) - -(objc:defmethod (#/writeToURL:ofType:error: :) - ((self hemlock-editor-document) url type (error (:* :id))) - (declare (ignore type)) - (with-slots (encoding textstorage) self - (let* ((string (#/string textstorage)) - (buffer (hemlock-document-buffer self))) - (case (when buffer (hi::buffer-line-termination buffer)) - (:cp/m (unless (typep string 'ns:ns-mutable-string) - (setq string (make-instance 'ns:ns-mutable-string :with string string)) - (#/replaceOccurrencesOfString:withString:options:range: - string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) - (:macos (setq string (if (typep string 'ns:ns-mutable-string) - string - (make-instance 'ns:ns-mutable-string :with string string))) - (#/replaceOccurrencesOfString:withString:options:range: - string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) - (when (#/writeToURL:atomically:encoding:error: - string url t encoding error) - (when buffer - (setf (hi::buffer-modified buffer) nil)) - t)))) - - - - -;;; Shadow the setFileName: method, so that we can keep the buffer -;;; name and pathname in synch with the document. -(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document) - url) - (call-next-method url) - (let* ((buffer (hemlock-document-buffer self))) - (when buffer - (let* ((new-pathname (lisp-string-from-nsstring (#/path url)))) - (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 20.0f0 "X position of upper-left corner of initial editor") - -(def-cocoa-default *initial-editor-y-pos* :float -20.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) - -(defun x-pos-for-window (window x) - (let* ((frame (#/frame window)) - (screen (#/screen window))) - (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen))) - (let* ((screen-rect (#/visibleFrame screen))) - (if (>= x 0) - (+ x (ns:ns-rect-x screen-rect)) - (- (+ (ns:ns-rect-width screen-rect) x) (ns:ns-rect-width frame)))))) - -(defun y-pos-for-window (window y) - (let* ((frame (#/frame window)) - (screen (#/screen window))) - (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen))) - (let* ((screen-rect (#/visibleFrame screen))) - (if (>= y 0) - (+ y (ns:ns-rect-y screen-rect) (ns:ns-rect-height frame)) - (+ (ns:ns-rect-height screen-rect) y))))) - -(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document)) - #+debug - (#_NSLog #@"Make window controllers") - (let* ((textstorage (slot-value self 'textstorage)) - (window (%hemlock-frame-for-textstorage - hemlock-frame - textstorage - *editor-columns* - *editor-rows* - nil - (textview-background-color self) - (user-input-style 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* - (x-pos-for-window window *initial-editor-x-pos*)) - (or *next-editor-y-pos* - (y-pos-for-window window *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 hi::scroll-window (textpane n) - (let* ((n (or n 0)) - (sv (text-pane-scroll-view textpane)) - (tv (text-pane-text-view textpane)) - (char-height (text-view-char-height tv)) - (sv-height (ns:ns-size-height (#/contentSize sv))) - (nlines (floor sv-height char-height)) - (point (hi::current-point))) - (or (hi::line-offset point (* n nlines)) - (if (< n 0) - (hi::buffer-start point) - (hi::buffer-end point))))) - -(defmethod hemlock::center-text-pane ((pane text-pane)) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (text-pane-text-view pane) - (@selector #/centerSelectionInVisibleArea:) - +null-ptr+ - t)) - - -(defclass hemlock-document-controller (ns:ns-document-controller) - ((last-encoding :foreign-type :tringncoding)) - (:metaclass ns:+ns-object)) - -(defloadvar *hemlock-document-controller* nil "Shared document controller") - -(objc:defmethod #/sharedDocumentController ((self +hemlock-document-controller)) - (or *hemlock-document-controller* - (setq *hemlock-document-controller* (#/init (#/alloc self))))) - -(objc:defmethod #/init ((self hemlock-document-controller)) - (if *hemlock-document-controller* - (progn - (#/release self) - *hemlock-document-controller*) - (prog1 - (setq *hemlock-document-controller* (call-next-method)) - (setf (slot-value *hemlock-document-controller* 'last-encoding) 0)))) - -(defun iana-charset-name-of-nsstringencoding (ns) - (#_CFStringConvertEncodingToIANACharSetName - (#_CFStringConvertNSStringEncodingToEncoding ns))) - - -(defun nsstring-for-nsstring-encoding (ns) - (let* ((iana (iana-charset-name-of-nsstringencoding ns))) - (if (%null-ptr-p iana) - (#/stringWithFormat: ns:ns-string #@"{%@}" - (#/localizedNameOfStringEncoding: ns:ns-string ns)) - iana))) - -;;; Return a list of :tringncodings, sorted by the -;;; (localized) name of each encoding. -(defun supported-nsstring-encodings () - (collect ((ids)) - (let* ((ns-ids (#/availableStringEncodings ns:ns-string))) - (unless (%null-ptr-p ns-ids) - (do* ((i 0 (1+ i))) - () - (let* ((id (paref ns-ids (:* :tringncoding) i))) - (if (zerop id) - (return (sort (ids) - #'(lambda (x y) - (= #$NSOrderedAscending - (#/localizedCompare: - (nsstring-for-nsstring-encoding x) - (nsstring-for-nsstring-encoding y)))))) - (ids id)))))))) - - -(defmacro nsstring-encoding-to-nsinteger (n) - (target-word-size-case - (32 `(u32->s32 ,n)) - (64 n))) - -(defmacro nsinteger-to-nsstring-encoding (n) - (target-word-size-case - (32 `(s32->u32 ,n)) - (64 n))) - - -;;; TexEdit.app has support for allowing the encoding list in this -;;; popup to be customized (e.g., to suppress encodings that the -;;; user isn't interested in.) -(defmethod build-encodings-popup ((self hemlock-document-controller) - &optional (preferred-encoding 0)) - (let* ((id-list (supported-nsstring-encodings)) - (popup (make-instance 'ns:ns-pop-up-button))) - ;;; Add a fake "Automatic" item with tag 0. - (#/addItemWithTitle: popup #@"Automatic") - (#/setTag: (#/itemAtIndex: popup 0) 0) - (dolist (id id-list) - (#/addItemWithTitle: popup (nsstring-for-nsstring-encoding id)) - (#/setTag: (#/lastItem popup) (nsstring-encoding-to-nsinteger id))) - (when preferred-encoding - (#/selectItemWithTag: popup (nsstring-encoding-to-nsinteger preferred-encoding))) - (#/sizeToFit popup) - popup)) - - -(objc:defmethod (#/runModalOpenPanel:forTypes: :nteger) - ((self hemlock-document-controller) panel types) - (let* ((popup (build-encodings-popup self #|preferred|#))) - (#/setAccessoryView: panel popup) - (let* ((result (call-next-method panel types))) - (when (= result #$NSOKButton) - (with-slots (last-encoding) self - (setq last-encoding (nsinteger-to-nsstring-encoding (#/tag (#/selectedItem popup)))))) - result))) - -(defun hi::open-document () - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (#/sharedDocumentController hemlock-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)) - -(defun initialize-user-interface () - (#/sharedDocumentController hemlock-document-controller) - (#/sharedPanel lisp-preferences-panel) - (make-editor-style-map)) - -;;; This needs to run on the main thread. -(objc:defmethod (#/updateHemlockSelection :void) ((self hemlock-text-storage)) - (let* ((string (#/hemlockString 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 pointpos) - (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)) - - -(defloadvar *general-pasteboard* nil) - -(defun general-pasteboard () - (or *general-pasteboard* - (setq *general-pasteboard* - (#/retain (#/generalPasteboard ns:ns-pasteboard))))) - -(defloadvar *string-pasteboard-types* ()) - -(defun string-pasteboard-types () - (or *string-pasteboard-types* - (setq *string-pasteboard-types* - (#/retain (#/arrayWithObject: ns:ns-array #&NSStringPboardType))))) - - -(objc:defmethod (#/stringToPasteBoard: :void) - ((self lisp-application) string) - (let* ((pb (general-pasteboard))) - (#/declareTypes:owner: pb (string-pasteboard-types) nil) - (#/setString:forType: pb string #&NSStringPboardType))) - -(defun hi::string-to-clipboard (string) - (when (> (length string) 0) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - *nsapp* (@selector #/stringToPasteBoard:) (%make-nsstring string) t))) - -;;; The default #/paste method seems to want to set the font to -;;; something ... inappropriate. If we can figure out why it -;;; does that and persuade it not to, we wouldn't have to do -;;; this here. -;;; (It's likely to also be the case that Carbon applications -;;; terminate lines with #\Return when writing to the clipboard; -;;; we may need to continue to override this method in order to -;;; fix that.) -(objc:defmethod (#/paste: :void) ((self hemlock-text-view) sender) - (declare (ignorable sender)) - #+debug (#_NSLog #@"Paste: sender = %@" :id sender) - (let* ((pb (general-pasteboard)) - (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType)))) - (unless (%null-ptr-p string) - (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*))) - (unless (typep string 'ns:ns-mutable-string) - (setq string (make-instance 'ns:ns-mutable-string :with-string string))) - (#/replaceOccurrencesOfString:withString:options:range: - string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))) - (let* ((textstorage (#/textStorage self))) - (unless (eql 0 (slot-value textstorage 'append-edits)) - (#/setSelectedRange: self (ns:make-ns-range (#/length textstorage) 0))) - (let* ((selectedrange (#/selectedRange self))) - (#/replaceCharactersInRange:withString: textstorage selectedrange string)))))) - -(objc:defmethod (#/hyperSpecLookUp: :void) - ((self hemlock-text-view) sender) - (declare (ignore sender)) - (let* ((range (#/selectedRange self))) - (unless (eql 0 (ns:ns-range-length range)) - (let* ((string (nstring-upcase (lisp-string-from-nsstring (#/substringWithRange: (#/string (#/textStorage self)) range))))) - (multiple-value-bind (symbol win) (find-symbol string "CL") - (when win - (lookup-hyperspec-symbol symbol self))))))) - - -(defun hi::edit-definition (name) - (let* ((info (get-source-files-with-types&classes name))) - (if info - (if (cdr info) - (edit-definition-list name info) - (edit-single-definition name (car info)))))) - - -(defun find-definition-in-document (name indicator document) - (let* ((buffer (hemlock-document-buffer document)) - (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))) - (hemlock::find-definition-in-buffer buffer name indicator))) - - -(defstatic *edit-definition-id-map* (make-id-map)) - -;;; Need to force things to happen on the main thread. -(defclass cocoa-edit-definition-request (ns:ns-object) - ((name-id :foreign-type :int) - (info-id :foreign-type :int)) - (:metaclass ns:+ns-object)) - -(objc:defmethod #/initWithName:info: - ((self cocoa-edit-definition-request) - (name :int) (info :int)) - (#/init self) - (setf (slot-value self 'name-id) name - (slot-value self 'info-id) info) - self) - -(objc:defmethod (#/editDefinition: :void) - ((self hemlock-document-controller) request) - (let* ((name (id-map-free-object *edit-definition-id-map* (slot-value request 'name-id))) - (info (id-map-free-object *edit-definition-id-map* (slot-value request 'info-id)))) - (destructuring-bind (indicator . pathname) info - (let* ((namestring (native-translated-namestring pathname)) - (url (#/initFileURLWithPath: - (#/alloc ns:ns-url) - (%make-nsstring namestring))) - (document (#/openDocumentWithContentsOfURL:display:error: - self - url - nil - +null-ptr+))) - (unless (%null-ptr-p document) - (if (= (#/count (#/windowControllers document)) 0) - (#/makeWindowControllers document)) - (find-definition-in-document name indicator document) - (#/updateHemlockSelection (slot-value document 'textstorage)) - (#/showWindows document)))))) - -(defun edit-single-definition (name info) - (let* ((request (make-instance 'cocoa-edit-definition-request - :with-name (assign-id-map-id *edit-definition-id-map* name) - :info (assign-id-map-id *edit-definition-id-map* info)))) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (#/sharedDocumentController ns:ns-document-controller) - (@selector #/editDefinition:) - request - t))) - - -(defun edit-definition-list (name infolist) - (make-instance 'sequence-window-controller - :sequence infolist - :result-callback #'(lambda (info) - (edit-single-definition name info)) - :display #'(lambda (item stream) - (prin1 (car item) stream)) - :title (format nil "Definitions of ~s" name))) - - -(objc:defmethod (#/documentClassForType: :lass) ((self hemlock-document-controller) - type) - (if (#/isEqualToString: type #@"html") - display-document - (call-next-method type))) - - -(objc:defmethod #/newDisplayDocumentWithTitle:content: - ((self hemlock-document-controller) - title - string) - (let* ((doc (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+))) - (unless (%null-ptr-p doc) - (#/addDocument: self doc) - (#/makeWindowControllers doc) - (let* ((window (#/window (#/objectAtIndex: (#/windowControllers doc) 0)))) - (#/setTitle: window title) - (let* ((tv (slot-value doc 'text-view)) - (lm (#/layoutManager tv)) - (ts (#/textStorage lm))) - (#/beginEditing ts) - (#/replaceCharactersInRange:withAttributedString: - ts - (ns:make-ns-range 0 (#/length ts)) - string) - (#/endEditing ts)) - (#/makeKeyAndOrderFront: - window - self))))) - - - -(provide "COCOA-EDITOR") Index: anches/ide-1.0/ccl/examples/cocoa-inspector.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-inspector.lisp (revision 6866) +++ (revision ) @@ -1,469 +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)) - ;; This can return nil. - (let* ((i (focal-point cinspector)) - (v (inspector-vector cinspector)) - (n (length v))) - (if (< i n) - (aref v i)))) -(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 (< -1 column (length (object-vector cinspector))) - ;; 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))) - (if inspector - (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))) - (#/setColumnResizingType: browser #$NSBrowserUserColumnResizing) - (#/setPrefersAllColumnUserResizing: browser nil) - (#/setDoubleAction: browser (@selector #/browserDoubleAction:)) - (#/setIgnoresMultiClick: browser t)) - (#/showWindow: windowcontroller window) - window))) - -;;; Make INSPECT call CINSPECT. -(setq *default-inspector-ui-creation-function* 'cinspect) Index: anches/ide-1.0/ccl/examples/cocoa-listener.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-listener.lisp (revision 6866) +++ (revision ) @@ -1,548 +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 1 "Text style index for listener output") - -(def-cocoa-default hi::*listener-input-style* :int 0 "Text style index for listener output") - -(def-cocoa-default *listener-background-color* :color '(1.0 1.0 1.0 1.0) "Listener default background color") - -;;; Setup the server end of a pty pair. -(defun setup-server-pty (pty) - (set-tty-raw 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) - (set-tty-raw pty) - #+no - (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG)) - #+no - (disable-tty-output-modes pty #$ONLCR) - pty) - - -(defloadvar *cocoa-listener-count* 0) - -(defclass cocoa-listener-process (process) - ((input-stream :reader cocoa-listener-process-input-stream) - (output-stream :reader cocoa-listener-process-output-stream) - (input-peer-stream :reader cocoa-listener-process-input-peer-stream) - (backtrace-contexts :initform nil - :accessor cocoa-listener-process-backtrace-contexts) - (window :reader cocoa-listener-process-window) - (buffer :initform nil :reader cocoa-listener-process-buffer))) - - -(defun new-cocoa-listener-process (procname input-fd output-fd peer-fd window buffer) - (let* ((input-stream (make-selection-input-stream - input-fd - :peer-fd peer-fd - :elements-per-buffer (#_fpathconf - input-fd - #$_PC_MAX_INPUT) - :encoding :utf-8)) - (output-stream (make-fd-stream output-fd :direction :output - :sharing :lock - :elements-per-buffer - (#_fpathconf - output-fd - #$_PC_MAX_INPUT) - :encoding :utf-8)) - (peer-stream (make-fd-stream peer-fd :direction :output - :sharing :lock - :elements-per-buffer - (#_fpathconf - peer-fd - #$_PC_MAX_INPUT) - :encoding :utf-8)) - (proc - (make-mcl-listener-process - procname - input-stream - output-stream - #'(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) - (setf (slot-value proc 'output-stream) output-stream) - (setf (slot-value proc 'input-peer-stream) peer-stream) - (setf (slot-value proc 'window) window) - (setf (slot-value proc 'buffer) buffer) - proc)) - - -(defclass hemlock-listener-frame (hemlock-frame) - () - (:metaclass ns:+ns-object)) - - -(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 - (nextra :foreign-type :int) ;count of untranslated bytes remaining - (translatebuf :foreign-type :address) ;buffer for utf8 translation - (bufsize :foreign-type :int) ;size of translatebuf - ) - (: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)) - (let* ((bufsize #$BUFSIZ) - (buffer (#_malloc bufsize))) - (setf (slot-value new 'translatebuf) buffer - (slot-value new 'bufsize) bufsize - (slot-value new 'nextra) 0)) - (#/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) - (with-slots (filehandle nextra translatebuf bufsize) self - (let* ((data (#/objectForKey: (#/userInfo notification) - #&NSFileHandleNotificationDataItem)) - (document (#/document self)) - (encoding (load-time-value (get-character-encoding :utf-8))) - (data-length (#/length data)) - (buffer (hemlock-document-buffer document)) - (n nextra) - (cursize bufsize) - (need (+ n data-length)) - (xlate translatebuf) - (fh filehandle)) - (when (> need cursize) - (let* ((new (#_malloc need))) - (dotimes (i n) (setf (%get-unsigned-byte new i) - (%get-unsigned-byte xlate i))) - (#_free xlate) - (setq xlate new translatebuf new bufsize need))) - #+debug (#_NSLog #@"got %d bytes of data" :int data-length) - (with-macptrs ((target (%inc-ptr xlate n))) - (#/getBytes:range: data target (ns:make-ns-range 0 data-length))) - (let* ((total (+ n data-length))) - (multiple-value-bind (nchars noctets-used) - (funcall (character-encoding-length-of-memory-encoding-function encoding) - xlate - total - 0) - (let* ((string (make-string nchars))) - (funcall (character-encoding-memory-decode-function encoding) - xlate - noctets-used - 0 - string) - (unless (zerop (setq n (- total noctets-used))) - ;; By definition, the number of untranslated octets - ;; can't be more than 3. - (dotimes (i n) - (setf (%get-unsigned-byte xlate i) - (%get-unsigned-byte xlate (+ noctets-used i))))) - (setq nextra n) - (hi::enqueue-buffer-operation - buffer - #'(lambda () - (unwind-protect - (progn - (hi::buffer-document-begin-editing buffer) - (hemlock::append-buffer-output buffer string)) - (hi::buffer-document-end-editing buffer)))) - (#/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 update-buffer-package ((doc hemlock-listener-document) buffer) - (declare (ignore buffer))) - -(defmethod hi::document-encoding-name ((doc hemlock-listener-document)) - "UTF-8") - -(defmethod user-input-style ((doc hemlock-listener-document)) - hi::*listener-input-style*) - -(defmethod textview-background-color ((doc hemlock-listener-document)) - *listener-background-color*) - - -(defun hemlock::listener-document-send-string (document string) - (let* ((buffer (hemlock-document-buffer document)) - (process (if buffer (hi::buffer-process buffer)))) - (if process - (hi::send-string-to-listener-process process string)))) - - -(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)))) - -(defun hi::top-listener-output-stream () - (let* ((doc (#/topListener hemlock-listener-document))) - (unless (%null-ptr-p doc) - (let* ((buffer (hemlock-document-buffer doc)) - (process (if buffer (hi::buffer-process buffer)))) - (when (typep process 'cocoa-listener-process) - (cocoa-listener-process-output-stream process)))))) - - - -(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 -100.0f0 "X position of upper-left corner of initial listener") - -(def-cocoa-default *initial-listener-y-pos* :float 100.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 (#/close :void) ((self hemlock-listener-document)) - (if (zerop (decf *cocoa-listener-count*)) - (setq *next-listener-x-pos* nil - *next-listener-y-pos* nil)) - (call-next-method)) - -(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document)) - (let* ((textstorage (slot-value self 'textstorage)) - (window (%hemlock-frame-for-textstorage - hemlock-listener-frame - textstorage - *listener-columns* - *listener-rows* - t - (textview-background-color self) - (user-input-style 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* - (x-pos-for-window window *initial-listener-x-pos*)) - (or *next-listener-y-pos* - (y-pos-for-window window *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 window (hemlock-document-buffer self)))) - 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)))) - -(objc:defmethod (#/continue: :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) - (process-interrupt process #'continue)))) - -(objc:defmethod (#/exitBreak: :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) - (process-interrupt process #'abort-break)))) - -(defmethod listener-backtrace-context ((proc cocoa-listener-process)) - (car (cocoa-listener-process-backtrace-contexts proc))) - -(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) 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) sender)))))) - -(defun restarts-controller-for-context (context) - (or (car (bt.restarts context)) - (setf (car (bt.restarts context)) - (let* ((tcr (bt.tcr context)) - (tsp-range (inspector::make-tsp-stack-range tcr context)) - (vsp-range (inspector::make-vsp-stack-range tcr context)) - (csp-range (inspector::make-csp-stack-range tcr context)) - (process (tcr->process (bt.tcr context)))) - (make-instance 'sequence-window-controller - :sequence (cdr (bt.restarts context)) - :result-callback #'(lambda (r) - (process-interrupt - process - #'invoke-restart-interactively - r)) - :display #'(lambda (item stream) - (let* ((ccl::*aux-vsp-ranges* vsp-range) - (ccl::*aux-tsp-ranges* tsp-range) - (ccl::*aux-csp-ranges* csp-range)) - (princ item stream))) - :title (format nil "Restarts for ~a(~d), break level ~d" - (process-name process) - (process-serial-number process) - (bt.break-level context))))))) - -(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) 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: (restarts-controller-for-context context) sender)))))) - -(objc:defmethod (#/continue: :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 - (process-interrupt process #'invoke-restart-interactively 'continue)))))) - - - - - - -;;; 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 #/revertDocumentToSaved:)) - (values t nil)) - ((eql action (@selector #/makeKeyAndOrderFront:)) - (let* ((target (#/target item)) - (window (cocoa-listener-process-window process))) - (if (eql target window) - (progn - (#/setKeyEquivalent: item #@"L") - (#/setKeyEquivalentModifierMask: item #$NSCommandKeyMask)) - (#/setKeyEquivalent: item #@"")) - (values t t))) - ((eql action (@selector #/interrupt:)) (values t t)) - ((eql action (@selector #/continue:)) - (let* ((context (listener-backtrace-context process))) - (values - t - (and context - (find 'continue (cdr (bt.restarts context)) - :key #'restart-name))))) - ((or (eql action (@selector #/backtrace:)) - (eql action (@selector #/exitBreak:)) - (eql action (@selector #/restarts:))) - (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)))) - -;;; This is basically used to provide INPUT to the listener process, by -;;; writing to an fd which is conntected to that process's standard -;;; input. -(defmethod hi::send-string-to-listener-process ((process cocoa-listener-process) - string &key path package) - (let* ((stream (cocoa-listener-process-input-peer-stream process))) - (labels ((out-raw-char (ch) - (write-char ch stream)) - (out-ch (ch) - (when (or (eql ch #\^v) - (eql ch #\^p) - (eql ch #\newline) - (eql ch #\^q)) - (out-raw-char #\^q)) - (out-raw-char ch)) - (out-string (s) - (dotimes (i (length s)) - (out-ch (char s i))))) - (out-raw-char #\^p) - (when package (out-string package)) - (out-raw-char #\newline) - (out-raw-char #\^v) - (when path (out-string path)) - (out-raw-char #\newline) - (out-string string) - (force-output stream)))) - - -(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) - (destructuring-bind (package path string) selection - (hi::send-string-to-listener-process target-listener string :package package :path path))))) - -;;; Give the windows menu item for the top listener a command-key -;;; equivalent of cmd-L. Remove command-key equivalents from other windows. -;;; (There are probably other ways of doing this.) -(objc:defmethod (#/validateMenuItem: :) ((self hemlock-listener-frame) - item) - (let* ((action (#/action item))) - (when (eql action (@selector #/makeKeyAndOrderFront:)) - (let* ((target (#/target item))) - (when (eql target self) - (let* ((top-doc (#/topListener hemlock-listener-document)) - (our-doc (#/document (#/windowController self)))) - (if (eql our-doc top-doc) - (progn - (#/setKeyEquivalent: item #@"l") - (#/setKeyEquivalentModifierMask: item #$NSCommandKeyMask)) - (#/setKeyEquivalent: item #@""))))))) - (call-next-method item)) - - - - - - Index: anches/ide-1.0/ccl/examples/cocoa-prefs.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-prefs.lisp (revision 6866) +++ (revision ) @@ -1,180 +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)) - - -(defloadvar *lisp-preferences-panel* nil) - -(defclass lisp-preferences-panel (ns:ns-panel) - () - (:metaclass ns:+ns-object)) - -(defclass font-name-transformer (ns:ns-value-transformer) - () - (:metaclass ns:+ns-object)) - -(objc:defmethod #/transformedNameClass ((self +font-name-transformer)) - ns:ns-string) - - -(objc:defmethod (#/allowsReverseTransformation :) - ((self +font-name-transformer)) - nil) - -(objc:defmethod #/transformValue ((self font-name-transformer) value) - ;; Is there any better way of doing this that doesn't involve - ;; making a font ? - (#/displayName (make-instance ns:ns-font - :with-name value - :size (float 12.0 +cgfloat-zero+)))) - - - -(defclass lisp-preferences-window-controller (ns:ns-window-controller) - ((selected-font-index :foreign-type :int)) - (:metaclass ns:+ns-object)) - -(objc:defmethod (#/fontPanelForDefaultFont: :void) - ((self lisp-preferences-window-controller) sender) - (with-slots (selected-font-index) self - (setq selected-font-index 1)) - (#/orderFrontFontPanel: *NSApp* sender)) - - -(objc:defmethod (#/fontPanelForModelineFont: :void) - ((self lisp-preferences-window-controller) sender) - (with-slots (selected-font-index) self - (setq selected-font-index 2)) - (#/orderFrontFontPanel: *NSApp* sender)) - -(objc:defmethod (#/changeFont: :void) ((self lisp-preferences-window-controller) sender) - #+debug (#_NSLog #@"ChangeFont.") - (with-slots ((idx selected-font-index)) self - (when (> idx 0) - (let* ((f (#/convertFont: sender (default-font)))) - (when (is-fixed-pitch-font f) - (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))) - (#/setValue:forKey: values (#/fontName f) (if (eql 1 idx) #@"defaultFontName" #@"modelineFontName:")) - (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) (if (eql 1 idx) #@"defaultFontSize" #@"modelineFontSize")))))))) - - -(objc:defmethod (#/changeColor: :void) ((self lisp-preferences-panel) - sender) - (declare (ignore sender))) - - -(objc:defmethod (#/selectHyperspecFileURL: :void) - ((self lisp-preferences-window-controller) - sender) - (declare (ignore sender)) - (let* ((panel (make-instance 'ns:ns-open-panel)) - (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))) - (#/setAllowsMultipleSelection: panel nil) - (#/setCanChooseDirectories: panel t) - (#/setCanChooseFiles: panel nil) - (when (eql - (#/runModalForDirectory:file:types: - panel - (#/valueForKey: values #@"hyperspecFileURLString") - +null-ptr+ - +null-ptr+) - #$NSOKButton) - (let* ((filename (#/objectAtIndex: (#/filenames panel) 0))) - (#/setValue:forKey: values filename #@"hyperspecFileURLString"))))) - -(objc:defmethod (#/selectCCLdirectory: :void) - ((self lisp-preferences-window-controller) - sender) - (declare (ignore sender)) - (let* ((panel (make-instance 'ns:ns-open-panel)) - (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))) - (#/setAllowsMultipleSelection: panel nil) - (#/setCanChooseDirectories: panel t) - (#/setCanChooseFiles: panel nil) - (when (eql - (#/runModalForDirectory:file:types: - panel - (#/valueForKey: values #@"cclDirectory") - +null-ptr+ - +null-ptr+) - #$NSOKButton) - (let* ((filename (#/pathWithComponents: ns:ns-string - (#/arrayWithObjects: - ns:ns-array - (#/objectAtIndex: (#/filenames panel) 0) - #@"" - +null-ptr+)))) - (#/setValue:forKey: values filename #@"cclDirectory"))))) - - - -(objc:defmethod #/sharedPanel ((self +lisp-preferences-panel)) - (cond (*lisp-preferences-panel*) - (t - (let* ((domain (#/standardUserDefaults ns:ns-user-defaults)) - (initial-values (cocoa-defaults-initial-values))) - (#/registerDefaults: domain initial-values) - (update-cocoa-defaults) - (#/setValueTransformer:forName: - ns:ns-value-transformer - (make-instance 'font-name-transformer) - #@"FontNameTransformer") - (let* ((sdc (#/sharedUserDefaultsController ns:ns-user-defaults-controller))) - (#/setAppliesImmediately: sdc nil) - (#/setInitialValues: sdc initial-values) - (let* ((controller (make-instance lisp-preferences-window-controller - :with-window-nib-name #@"preferences")) - (window (#/window controller))) - (unless (%null-ptr-p window) - (#/setFloatingPanel: window t) - (#/addObserver:selector:name:object: - (#/defaultCenter ns:ns-notification-center) - controller - (@selector #/defaultsChanged:) - #&NSUserDefaultsDidChangeNotification - (#/standardUserDefaults ns:ns-user-defaults)) - (setq *lisp-preferences-panel* window)))))))) - - -(objc:defmethod #/init ((self lisp-preferences-panel)) - (let* ((class (class-of self))) - (#/dealloc self) - (#/sharedPanel class))) - - -(objc:defmethod (#/makeKeyAndOrderFront: :void) - ((self lisp-preferences-panel) sender) - (let* ((color-panel (#/sharedColorPanel ns:ns-color-panel))) - (#/close color-panel) - (#/setAction: color-panel +null-ptr+) - (#/setShowsAlpha: color-panel t)) - (call-next-method sender)) - -(objc:defmethod (#/show :void) ((self lisp-preferences-panel)) - (#/makeKeyAndOrderFront: self +null-ptr+)) - -(objc:defmethod (#/defaultsChanged: :void) - ((self lisp-preferences-window-controller) - notification) - (declare (ignore notification)) - (update-cocoa-defaults)) - - - Index: anches/ide-1.0/ccl/examples/cocoa-typeout.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-typeout.lisp (revision 6866) +++ (revision ) @@ -1,189 +1,0 @@ -(in-package "CCL") - -(eval-when (:compile-toplevel :execute) - (use-interface-dir :cocoa)) - -;; -;; a typeout window is just an ns-window containing a scroll-view -;; which contains a text-view. The text is read only. -;; -;; the window 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) -;; - -;; @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)) - (:metaclass ns:+ns-object)) - -(defclass typeout-text-view (ns:ns-text-view) - () - (:metaclass ns:+ns-object)) - -(objc:defmethod (#/clearAll: :void) ((self typeout-text-view)) - (#/selectAll: self +null-ptr+) - (#/delete: self +null-ptr+)) - -(objc:defmethod (#/insertText: :void) ((self typeout-text-view) text) - (#/setEditable: self t) - (call-next-method text) - (#/setEditable: self nil)) - - -(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 t) - (#/setRulersVisible: scrollview nil) - (#/setAutoresizingMask: scrollview (logior #$NSViewWidthSizable #$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 'typeout-text-view - :with-frame text-frame))) - (#/setEditable: text-view nil) - (#/setHorizontallyResizable: text-view t) - (#/setAutoresizingMask: text-view #$NSViewWidthSizable) - (#/setTypingAttributes: text-view (create-text-attributes - :font (default-font :name *default-font-name* :size *default-font-size*) - :line-break-mode :char)) - (#/setDocumentView: scrollview text-view) - (ns:with-ns-size (container-size 1.0f7 1.0f7) - (let* ((layout (#/layoutManager text-view)) - (container (make-instance 'ns:ns-text-container - :with-container-size container-size))) - (#/setWidthTracksTextView: container t) - (#/setHeightTracksTextView: container nil) - (#/addTextContainer: layout container))) - - (setf (slot-value self 'text-view) text-view))))) - self) - -;; -;; @class typeout-panel -;; -(defloadvar *typeout-window* nil) - -(defclass typeout-window (ns:ns-window) - ((typeout-view :foreign-type :id :accessor typeout-window-typeout-view)) - (:metaclass ns:+ns-object)) - -(defloadvar *typeout-windows* ()) -(defstatic *typeout-windows-lock* (make-lock)) - -(defun get-typeout-window (title) - (with-lock-grabbed (*typeout-windows-lock*) - (when *typeout-windows* - (let* ((w (pop *typeout-windows*))) - (set-window-title w title) - w)))) - -(objc:defmethod #/typeoutWindowWithTitle: ((self +typeout-window) title) - (let* ((panel (new-cocoa-window :class self - :title title - :width 600 - :activate nil))) - (#/setReleasedWhenClosed: panel nil) - (let* ((view (make-instance 'typeout-view :with-frame (#/bounds (#/contentView panel))))) - (#/setAutoresizingMask: view (logior - #$NSViewWidthSizable - #$NSViewHeightSizable)) - (#/setContentView: panel view) - (#/setNeedsDisplay: view t) - (setf (slot-value panel 'typeout-view) view) - panel))) - -(objc:defmethod #/sharedPanel ((self +typeout-window)) - (cond (*typeout-window*) - (t - (setq *typeout-window* (#/typeoutWindowWithTitle: self "Typeout"))))) - - - -(objc:defmethod (#/close :void) ((self typeout-window)) - (call-next-method) - (unless (eql self *typeout-window*) - (with-lock-grabbed (*typeout-windows-lock*) - (push (%inc-ptr self 0) *typeout-windows*)))) - - - -(objc:defmethod (#/show :void) ((self typeout-window)) - (#/makeKeyAndOrderFront: self +null-ptr+)) - - -(defclass typeout-stream (fundamental-character-output-stream) - ((string-stream :initform (make-string-output-stream)) - (window :initform (#/sharedPanel typeout-window) :initarg :window))) - -(defun prepare-typeout-stream (stream) - (declare (ignorable stream)) - (with-slots (window) stream - (#/show window))) - - - -;;; -;;; TYPEOUT-STREAM methods -;;; - -(defmethod stream-write-char ((stream typeout-stream) char) - (prepare-typeout-stream stream) - (write-char char (slot-value stream 'string-stream))) - -(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) - (prepare-typeout-stream stream) - (write-string (if (and (eql start 0) (or (null end) (eql end (length string)))) - string - (subseq string start end)) - (slot-value stream 'string-stream))) - - -(defmethod stream-fresh-line ((stream typeout-stream)) - (prepare-typeout-stream stream) - (fresh-line (slot-value stream 'string-stream))) - -(defmethod stream-line-column ((stream typeout-stream)) - (stream-line-column (slot-value stream 'string-stream))) - -(defmethod stream-clear-output ((stream typeout-stream)) - (prepare-typeout-stream stream) - (let* ((window (slot-value stream 'window)) - (the-typeout-view (typeout-window-typeout-view window)) - (text-view (slot-value the-typeout-view 'text-view)) - (string-stream (slot-value stream 'string-stream))) - (get-output-stream-string string-stream) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - text-view - (@selector #/clearAll:) - +null-ptr+ - t))) - -(defmethod stream-force-output ((stream typeout-stream)) - (let* ((window (slot-value stream 'window)) - (the-typeout-view (typeout-window-typeout-view window)) - (text-view (slot-value the-typeout-view 'text-view))) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - text-view - (@selector #/insertText:) - (%make-nsstring (get-output-stream-string (slot-value stream 'string-stream))) - t))) - - -(defloadvar *typeout-stream* nil) - -(defun typeout-stream (&optional title) - (if (null title) - (or *typeout-stream* - (setq *typeout-stream* (make-instance 'typeout-stream))) - (make-instance 'typeout-stream :window (#/typeoutWindowWithTitle: typeout-window (%make-nsstring (format nil "~a" title)))))) - Index: anches/ide-1.0/ccl/examples/cocoa-utils.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-utils.lisp (revision 6866) +++ (revision ) @@ -1,90 +1,0 @@ -; -*- Mode: Lisp; Package: CCL; -*- - -(in-package "CCL") - -(eval-when (:compile-toplevel :execute) - (use-interface-dir :cocoa)) - -(defclass sequence-window-controller (ns:ns-window-controller) - ((table-view :foreign-type :id :reader sequence-window-controller-table-view) - (sequence :initform nil :initarg :sequence :type sequence :reader sequence-window-controller-sequence) - (result-callback :initarg :result-callback) - (display :initform #'(lambda (item stream) (prin1 item stream)) :initarg :display) - (title :initform "Sequence dialog" :initarg :title)) - (:metaclass ns:+ns-object)) - - -(objc:defmethod #/init ((self sequence-window-controller)) - (let* ((w (new-cocoa-window :activate nil)) - (contentview (#/contentView w)) - (contentframe (#/frame contentview)) - (scrollview (make-instance 'ns:ns-scroll-view :with-frame contentframe))) - (#/setWindow: self w) - (#/setHasVerticalScroller: scrollview t) - (#/setHasHorizontalScroller: scrollview t) - (#/setRulersVisible: scrollview nil) - (#/setAutoresizingMask: scrollview (logior - #$NSViewWidthSizable - #$NSViewHeightSizable)) - (#/setAutoresizesSubviews: (#/contentView scrollview) t) - (let* ((table-view (make-instance 'ns:ns-table-view))) - (#/setDocumentView: scrollview table-view) - (setf (slot-value self 'table-view) table-view) - (let* ((column (make-instance 'ns:ns-table-column :with-identifier #@""))) - (#/setEditable: column nil) - (#/addTableColumn: table-view column)) - (#/setAutoresizingMask: table-view (logior - #$NSViewWidthSizable - #$NSViewHeightSizable)) - (#/sizeToFit table-view) - (#/setDataSource: table-view self) - (#/setTarget: table-view self) - (#/setHeaderView: table-view +null-ptr+) - (#/setUsesAlternatingRowBackgroundColors: table-view t) - (#/setDoubleAction: table-view (@selector #/sequenceDoubleClick:)) - (#/addSubview: contentview scrollview) - self))) - -(objc:defmethod (#/sequenceDoubleClick: :void) - ((self sequence-window-controller) sender) - (let* ((n (#/clickedRow sender))) - (when (>= n 0) - (with-slots (sequence result-callback) self - (funcall result-callback (elt sequence n)))))) - -(objc:defmethod (#/numberOfRowsInTableView: :nteger) - ((self sequence-window-controller) view) - (declare (ignore view)) - (length (slot-value self 'sequence))) - - -(objc:defmethod #/tableView:objectValueForTableColumn:row: - ((self sequence-window-controller) view column (row :nteger)) - (declare (ignore column view)) - (with-slots (display sequence) self - (%make-nsstring (with-output-to-string (s) - (funcall display (elt sequence row) s))))) - -(defmethod initialize-instance :after ((self sequence-window-controller) &key &allow-other-keys) - (let* ((window (#/window self))) - (with-slots (title) self - (when title (#/setTitle: window (%make-nsstring title)))) - (#/reloadData (sequence-window-controller-table-view self)) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - self - (@selector #/showWindow:) - +null-ptr+ - nil))) - -;;; Looks like a "util" to me ... -(defun pathname-to-url (pathname) - (make-instance 'ns:ns-url - :file-url-with-path - (%make-nsstring (native-translated-namestring pathname)))) - -(defun color-values-to-nscolor (red green blue alpha) - (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color - (float red +cgfloat-zero+) - (float green +cgfloat-zero+) - (float blue +cgfloat-zero+) - (float alpha +cgfloat-zero+))) Index: anches/ide-1.0/ccl/examples/cocoa-window.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-window.lisp (revision 6866) +++ (revision ) @@ -1,396 +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") - (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 - (#/standardUserDefaults ns:ns-user-defaults) - (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)) - -(defstatic *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))))) - - -(defparameter *debug-in-event-process* t) - -(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.") - -(defmethod process-debug-condition ((process appkit-process) condition frame-pointer) - "Better than nothing. Not much better." - (when *debug-in-event-process* - (let* ((c (if (typep condition 'ns-lisp-exception) - (ns-lisp-exception-condition condition) - condition))) - (unless (member c *event-process-reported-conditions*) - (push c *event-process-reported-conditions*) - (catch 'need-a-catch-frame-for-backtrace - (let* ((*debug-in-event-process* nil) - (context (new-backtrace-info nil - frame-pointer - (if *backtrace-contexts* - (or (child-frame - (bt.youngest (car *backtrace-contexts*)) - nil) - (last-frame-ptr)) - (last-frame-ptr)) - (%current-tcr) - condition - (%current-frame-ptr) - #+ppc-target *fake-stack-frames* - #+x86-target (%current-frame-ptr) - (db-link) - (1+ *break-level*))) - (*backtrace-contexts* (cons context *backtrace-contexts*))) - (format t "~%~%*** Error in event process: ~a~%~%" condition) - (print-call-history :context context :detailed-p t :count 20 :origin frame-pointer) - (format t "~%~%~%") - (force-output 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 lisp-preferences-panel))) - -(objc:defmethod (#/toggleTypeout: :void) ((self lisp-application) sender) - (declare (ignore sender)) - (#/show (#/sharedPanel typeout-window))) - -(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 (let* ((*event-process-reported-conditions* nil)) - (#/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 (nth-value 1 (size-of-char-in-font 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)) - ;; And set the "default tab interval". - (#/setDefaultTabInterval: p (float (* *tab-width* charwidth) +cgfloat-zero+)) - p)) - -(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 set-window-title (window title) - (#/setTitle: window (if title - (if (typep title 'ns:ns-string) - title - (%make-nsstring title)) - #@"") )) - -(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 (set-window-title w title)) - w))) - - - - Index: anches/ide-1.0/ccl/examples/cocoa.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa.lisp (revision 6866) +++ (revision ) @@ -1,104 +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;")) - - -(require "OBJC-SUPPORT") - -(if (< #&NSAppKitVersionNumber 824) - (error "This application requires features introduced in OSX 10.4.")) - -(defparameter *standalone-cocoa-ide* nil) - - -(require "COCOA-UTILS") -(require "COCOA-WINDOW") -(require "COCOA-DOC") -(require "COCOA-LISTENER") -(require "COCOA-BACKTRACE") -(require "COCOA-INSPECTOR") - -(def-cocoa-default *ccl-directory* :string (ensure-directory-namestring (namestring (ccl-directory))) nil #'(lambda (old new) (unless (equal old new) (replace-base-translation "ccl:" new)))) - - -;;; 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: anches/ide-1.0/ccl/examples/fake-cfbundle-path.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/fake-cfbundle-path.lisp (revision 6866) +++ (revision ) @@ -1,46 +1,0 @@ -;;;-*-Mode: LISP; Package: CCL -*- - -(in-package "CCL") - -;;; Before loading any Cocoa code which depends on CFBundle/NSBundle -;;; being able to find an application bundle, it -may- be neccessary -;;; to point the environment variable "CFProcessPath" to some file -;;; that's where the bundle's executable would be. -;;; This should only be necessary if the current application isn't -;;; already "inside a bundle". If it is necessary, it has to happen -;;; before the CoreFoundation library's initialized. - -(defun fake-cfbundle-path (bundle-root) - (let* ((kernel-name (standard-kernel-name)) - (needle "OPENMCL-KERNEL") - (translated-root (translate-logical-pathname bundle-root)) - (executable-path (merge-pathnames - (make-pathname :directory "Contents/MacOS/" - :name kernel-name) - translated-root)) - (info-plist-proto-path (merge-pathnames "Contents/Info.plist-proto" - translated-root))) - (unless (probe-file info-plist-proto-path) - (error "Can't find Info.plist prototype in ~s" info-plist-proto-path)) - (with-open-file (in info-plist-proto-path - :direction :input - :external-format :utf-8) - (with-open-file (out (make-pathname :directory (pathname-directory info-plist-proto-path) - :name "Info" - :type "plist") - :direction :output - :if-does-not-exist :create - :if-exists :supersede - :external-format :utf-8) - (do* ((line (read-line in nil nil) (read-line in nil nil))) - ((null line)) - (let* ((pos (search needle line))) - (when pos - (setq line - (concatenate 'string - (subseq line 0 pos) - kernel-name - (subseq line (+ pos (length needle))))))) - (write-line line out)))) - (touch executable-path) - (setenv "CFProcessPath" (native-translated-namestring executable-path)))) Index: anches/ide-1.0/ccl/examples/process-objc-modules.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/process-objc-modules.lisp (revision 6866) +++ (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") -