Changeset 12887

Timestamp:

Sep 28, 2009, 2:01:36 PM (10 years ago)

Author:

rme

Message:

trunk changes r12874 through r12886

Location:

branches/watchpoints

Files:

• cocoa-ide/cocoa-editor.lisp (modified) (2 diffs)
• cocoa-ide/hemlock/src/edit-defs.lisp (modified) (2 diffs)
• cocoa-ide/hemlock/src/listener.lisp (modified) (3 diffs)
• level-1/l1-streams.lisp (modified) (1 diff)
• tools/advice-profiler/profiler.lisp (modified) (1 diff)

branches/watchpoints/cocoa-ide/cocoa-editor.lisp

@@ -1491 +1491 @@
                                     (> (#/clickCount event) 1))))))
            (let* ((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::*current-buffer* buffer))
-                 (hi::with-mark ((m1 (hi::buffer-point buffer)))
-                   (setq index (hi:mark-absolute-position m1))
-                   (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 (- (hi: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 (hi:mark-absolute-position m2) (- index (hi: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)
-                :<NSS>election<G>ranularity g))))
-
-
+                  (buffer (buffer-cache-buffer cache))
+                  (hi::*current-buffer* buffer)
+                  (point (hi::buffer-point buffer)))
+             (hi::with-mark ((mark point))
+               (move-hemlock-mark-to-absolute-position mark cache index)
+               (when (selection-offset-for-double-click buffer mark)
+                 ;; Act as if we started the selection at the other end, so the heuristic
+                 ;; in #/selectionRangeForProposedRange does the right thing.  ref bug #565.
+                 (hi::move-mark point mark)
+                 (let ((start index)
+                       (end (hi::mark-absolute-position mark)))
+                   (when (< end start) (rotatef start end))
+                   (ns:init-ns-range r start (- end start)))
+                 #+debug
+                 (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
+                          :address (#_NSStringFromRange r)
+                          :address (#_NSStringFromRange proposed)
+                          :<NSS>election<G>ranularity g)
+                 (return-from HANDLED r))))))
+       (prog1
+           (call-next-method proposed g)
+         #+debug
+         (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
+                  :address (#_NSStringFromRange r)
+                  :address (#_NSStringFromRange proposed)
+                  :<NSS>election<G>ranularity g)))))
+
+;; Return nil to use the default Cocoa selection, which will be word for double-click, line for triple.
+;; TODO: make this consistent with "current sexp".
+(defun selection-offset-for-double-click (buffer mark)
+  (when (string= (hi::buffer-major-mode buffer) "Lisp") ;; gag
+    (hemlock::pre-command-parse-check mark)
+    (when (hemlock::valid-spot mark nil)
+      (cond ((eql (hi::next-character mark) #\()
+             (hemlock::list-offset mark 1))
+            ((eql (hi::previous-character mark) #\))
+             (hemlock::list-offset mark -1))))))
 
 (defun append-output (view string)
@@ -1534 +1546 @@
      (affinity :<NSS>election<A>ffinity)
      (still-selecting :<BOOL>))
-  #+debug 
-  (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d"
-           :int (pref r :<NSR>ange.location)
-           :int (pref r :<NSR>ange.length)
+  #+debug
+  (#_NSLog #@"Set selected range called: range = %@, affinity = %d, still-selecting = %d"
+           :address (#_NSStringFromRange r)
            :<NSS>election<A>ffinity affinity
            :<BOOL> (if still-selecting #$YES #$NO))

branches/watchpoints/cocoa-ide/hemlock/src/edit-defs.lisp

@@ -93 +93 @@
         (error (c) (editor-error (format nil "~a" c)))))))
       
-
-#|
-;;; "Edit Command Definition" is a hack due to creeping evolution in
-;;; GO-TO-DEFINITION.  We specify :function type and a name with "-COMMAND"
-;;; instead of :command type and the real command name because this causes
-;;; the right pattern to be created for searching.  We could either specify
-;;; that you always edit command definitions with this command (breaking
-;;; "Go to Definition" for commands called as functions), fixing the code,
-;;; or we can hack this command so everything works.
-;;;
 (defcommand "Edit Command Definition" (p)
-  "Prompts for command definition name and goes to it for editing."
   "Prompts for command definition name and goes to it for editing."
   (multiple-value-bind
@@ -116 +105 @@
         (prompt-for-keyword :tables (list *command-names*)
                             :prompt "Command to edit: "))
-    (go-to-definition (fun-defined-from-pathname (command-function command))
-                      :function
-                      (concatenate 'simple-string name "-COMMAND"))))
-
+    (declare (ignore name))
+    (handler-case (edit-definition (command-function command))
+      (error (c) (editor-error (format nil "~a" c))))))
+
+#|
 ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
 ;;; returns a pathname for the file the function was defined in.  If it was

branches/watchpoints/cocoa-ide/hemlock/src/listener.lisp

@@ -601 +601 @@
 
 (defcommand "Editor Evaluate Defun" (p)
-  "Evaluates the current or next top-level form in the editor Lisp.
+  "Evaluates the current or next top-level form.
    If the current region is active, this evaluates the region."
-  "Evaluates the current or next top-level form in the editor Lisp."
   (declare (ignore p))
   (if (region-active-p)
@@ -610 +609 @@
 
 (defcommand "Editor Evaluate Region" (p)
-  "Evaluates lisp forms between the point and the mark in the editor Lisp."
-  "Evaluates lisp forms between the point and the mark in the editor Lisp."
+  "Evaluates lisp forms between the point and the mark"
   (declare (ignore p))
   (if (region-active-p)
@@ -634 +632 @@
 (defcommand "Editor Re-evaluate Defvar" (p)
   "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
-   form as if the variable is not bound.  This occurs in the editor Lisp."
-  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
-   form as if the variable is not bound.  This occurs in the editor Lisp."
+   form as if the variable is not bound."
   (declare (ignore p))
   (with-input-from-region (stream (defun-region (current-point)))

branches/watchpoints/level-1/l1-streams.lisp

@@ -3426 +3426 @@
 
 (defmethod stream-external-format ((s character-stream))
-  (make-external-format :character-encoding #+big-endian-target :utf32-be #+little-endian-target :utf32-le :line-termination :unix))
+  (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix))
 
 

branches/watchpoints/tools/advice-profiler/profiler.lisp

@@ -121 +121 @@
     (ccl:rlet ((ts :mach_timespec))
       (unless (zerop (#_clock_get_time (%get-ptr clock-port) ts))
-        (error "error reading clock ~A: ~A~%" id (ccl::%strerror (ccl::%get-errno))))
+        (error "error reading Mach clock: ~A~%" (ccl::%strerror (ccl::%get-errno))))
       (mach-timespec->nanoseconds ts))))