Changeset 6699

Timestamp:

Jun 12, 2007, 12:40:05 PM (17 years ago)

Author:

Gary Byers

Message:

Greater care with echo-area modification.

File:

• branches/ide-1.0/ccl/hemlock/src/echo.lisp (modified) (10 diffs)

branches/ide-1.0/ccl/hemlock/src/echo.lisp

@@ -45 +45 @@
     (progn
       (buffer-document-begin-editing *echo-area-buffer*)
-      ,@body)
+      (modifying-buffer *echo-area-buffer* ,@body))
     (buffer-document-end-editing *echo-area-buffer*)))
 ;;; %Not-Inside-A-Parse  --  Internal
@@ -115 +115 @@
   "You guessed it."
   (maybe-wait)
-  (let* ((b (current-buffer)))
+  (let* ((b (current-buffer))
+         (doc (buffer-document *echo-area-buffer*)))
     (unwind-protect
          (progn
@@ -122 +123 @@
             (delete-region *echo-area-region*))
            (setf (buffer-modified *echo-area-buffer*) nil))
+      (when doc
+        (document-set-point-position doc))
       (setf (current-buffer) b))))
 
@@ -151 +154 @@
                    (clear-echo-area)))
             (apply #'format *echo-area-stream* string args)
-            (setf (buffer-modified *echo-area-buffer*) nil))))
+            (setf (buffer-modified *echo-area-buffer*) t))))
    (force-output *echo-area-stream*)
    (setq *last-message-time* (get-internal-real-time)))
@@ -169 +172 @@
 
 
-(defhvar "Raise Echo Area When Modified"
-  "When set, Hemlock raises the echo area window when output appears there."
-  :value nil)
-
-;;; RAISE-ECHO-AREA-WHEN-MODIFIED -- Internal.
-;;;
-;;; INIT-BITMAP-SCREEN-MANAGER in bit-screen.lisp adds this hook when
-;;; initializing the bitmap screen manager.
-;;;
-#+clx
-(defun raise-echo-area-when-modified (buffer modified)
-  (when (and (value hemlock::raise-echo-area-when-modified)
-             (eq buffer *echo-area-buffer*)
-             modified)
-    (let* ((hunk (window-hunk *echo-area-window*))
-           (win (window-group-xparent (bitmap-hunk-window-group hunk))))
-      (xlib:map-window win)
-      (setf (xlib:window-priority win) :above)
-      (xlib:display-force-output
-       (bitmap-device-display (device-hunk-device hunk))))))
+
+
 
 
@@ -199 +184 @@
                                                      *parse-default*)))
   (clear-echo-area)
-  (let ((point (buffer-point *echo-area-buffer*)))
-    (if (listp prompt)
-        (apply #'format *echo-area-stream* prompt)
-        (insert-string point prompt))
-    (when default
-      (insert-character point #\[)
-      (insert-string point default)
-      (insert-string point "] "))))
+  (modifying-echo-buffer 
+   (let ((point (buffer-point *echo-area-buffer*)))
+     (if (listp prompt)
+       (apply #'format *echo-area-stream* prompt)
+       (insert-string point prompt))
+     (when default
+       (insert-character point #\[)
+       (insert-string point default)
+       (insert-string point "] ")))))
 
 (defun parse-for-something ()
@@ -216 +202 @@
      (use-buffer *echo-area-buffer*
        (recursive-edit nil))
+      
      (setf (current-window) start-window))))
 
@@ -252 +239 @@
 (defun buffer-verification-function (string)
   (declare (simple-string string))
-  (cond ((string= string "") nil)
-        (*parse-value-must-exist*
-         (multiple-value-bind
-             (prefix key value field ambig)
-             (complete-string string *parse-string-tables*)
-           (declare (ignore field))
-           (ecase key
-             (:none nil)
-             ((:unique :complete)
-              (list value))
-             (:ambiguous
-              (delete-region *parse-input-region*)
-              (insert-string (region-start *parse-input-region*) prefix)
-              (let ((point (current-point)))
-                (move-mark point (region-start *parse-input-region*))
-                (unless (character-offset point ambig)
-                  (buffer-end point)))
-              nil))))
-        (t
-         (list (or (getstring string *buffer-names*) string)))))
+  (modifying-echo-buffer
+   (cond ((string= string "") nil)
+         (*parse-value-must-exist*
+          (multiple-value-bind
+              (prefix key value field ambig)
+              (complete-string string *parse-string-tables*)
+            (declare (ignore field))
+            (ecase key
+              (:none nil)
+              ((:unique :complete)
+               (list value))
+              (:ambiguous
+               (delete-region *parse-input-region*)
+               (insert-string (region-start *parse-input-region*) prefix)
+               (let ((point (current-point)))
+                 (move-mark point (region-start *parse-input-region*))
+                 (unless (character-offset point ambig)
+                   (buffer-end point)))
+               nil))))
+         (t
+          (list (or (getstring string *buffer-names*) string))))))
 
 
@@ -317 +305 @@
                                          :junk-allowed t)
     (cond (pn)
-          (t (delete-characters (region-end *echo-area-region*)
-                                (- idx (length string)))
+          (t (modifying-echo-buffer
+              (delete-characters (region-end *echo-area-region*)
+                                (- idx (length string))))
              nil))))
 
@@ -365 +354 @@
       (complete-string string *parse-string-tables*)
     (declare (ignore field))
-    (cond (*parse-value-must-exist*
-           (ecase key
-             (:none nil)
-             ((:unique :complete)
-              (list prefix value))
-             (:ambiguous
-              (delete-region *parse-input-region*)
-              (insert-string (region-start *parse-input-region*) prefix)
-              (let ((point (current-point)))
-                (move-mark point (region-start *parse-input-region*))
-                (unless (character-offset point ambig)
-                  (buffer-end point)))
-              nil)))
-          (t
-           ;; HACK: If it doesn't have to exist, and the completion does not
-           ;; add anything, then return the completion's capitalization,
-           ;; instead of the user's input.
-           (list (if (= (length string) (length prefix)) prefix string))))))
+    (modifying-echo-buffer
+     (cond (*parse-value-must-exist*
+            (ecase key
+              (:none nil)
+              ((:unique :complete)
+               (list prefix value))
+              (:ambiguous
+               (delete-region *parse-input-region*)
+               (insert-string (region-start *parse-input-region*) prefix)
+               (let ((point (current-point)))
+                 (move-mark point (region-start *parse-input-region*))
+                 (unless (character-offset point ambig)
+                   (buffer-end point)))
+               nil)))
+           (t
+            ;; HACK: If it doesn't have to exist, and the completion does not
+            ;; add anything, then return the completion's capitalization,
+            ;; instead of the user's input.
+            (list (if (= (length string) (length prefix)) prefix string)))))))