Changeset 8207

Timestamp:

Jan 17, 2008, 1:49:54 PM (17 years ago)

Author:

gz

Message:

Make sure all the symbols in the editor documentation in the wiki are exported
from the hemlock-interface package, and vice versa. Get rid of a bunch of stuff
we no longer support, add a few things that got lost (move-to-column, update-
modeline-fields).

Make a subtype of buffer, echo-buffer, for buffers used as echo area backing.
Add public fn all-buffers which only returns the non-echo-area ones.

Get rid of the assorted "Page" commands -- since Cocoa doesn't display ^{L's,
there is no point encouraging people to use them.}

Now that I actually understand mode variables, don't use them for query/replace
and i-search state, use buffer variables.

Add hemlock-ext:raise-buffer-view, use it in "Jump to Saved Position"

make delete-buffer error if buffer-document is non-nil (used to do something
like that before).

Location:

branches/event-ide/ccl/cocoa-ide

Files:

• cocoa-editor.lisp (modified) (5 diffs)
• hemlock/src/bindings.lisp (modified) (1 diff)
• hemlock/src/buffer.lisp (modified) (4 diffs)
• hemlock/src/decls.lisp (modified) (2 diffs)
• hemlock/src/echo.lisp (modified) (1 diff)
• hemlock/src/echocoms.lisp (modified) (1 diff)
• hemlock/src/edit-defs.lisp (modified) (2 diffs)
• hemlock/src/filecoms.lisp (modified) (2 diffs)
• hemlock/src/htext1.lisp (modified) (1 diff)
• hemlock/src/interp.lisp (modified) (1 diff)
• hemlock/src/isearchcoms.lisp (modified) (2 diffs)
• hemlock/src/key-event.lisp (modified) (1 diff)
• hemlock/src/macros.lisp (modified) (1 diff)
• hemlock/src/main.lisp (modified) (3 diffs)
• hemlock/src/modeline.lisp (modified) (2 diffs)
• hemlock/src/morecoms.lisp (modified) (1 diff)
• hemlock/src/package.lisp (modified) (27 diffs)
• hemlock/src/register.lisp (modified) (3 diffs)
• hemlock/src/rompsite.lisp (modified) (5 diffs)
• hemlock/src/searchcoms.lisp (modified) (3 diffs)
• hemlock/src/struct.lisp (modified) (1 diff)
• hemlock/src/views.lisp (modified) (5 diffs)

branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

@@ -1732 +1732 @@
   (declare (ignore change)))
 
-(defloadvar *hemlock-frame-count* 0)
-
 (defun make-echo-area (the-hemlock-frame x y width height main-buffer color)
   (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height))))
@@ -1747 +1745 @@
       (#/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")))
+      (let* ((buffer (hi::make-echo-buffer))
              (textstorage
               (progn
@@ -1852 +1846 @@
      t)))
 
-(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition)
-  (maybe-log-callback-error condition)
+(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition debug-p)
+  (when debug-p (maybe-log-callback-error condition))
   (let ((pane (hi::hemlock-view-pane view)))
     (when (and pane (not (%null-ptr-p pane)))
@@ -2954 +2948 @@
    t))
 
+(defun hemlock-ext:raise-buffer-view (buffer &optional action)
+  "Bring a window containing buffer to front and then execute action in
+   the window.  Returns before operation completes."
+  ;; Queue for after this event, so don't screw up current context.
+  (queue-for-gui #'(lambda ()
+                     (let ((doc (hi::buffer-document buffer)))
+                       (unless (and doc (not (%null-ptr-p doc)))
+                         (hi:editor-error "Deleted buffer: ~s" buffer))
+                       (#/showWindows doc)
+                       (when action
+                         (hi::handle-hemlock-event (front-view-for-buffer buffer) action))))))
+
 ;;; Enable CL:ED
 (defun cocoa-edit (&optional arg)
@@ -2962 +2968 @@
         ((ccl::valid-function-name-p arg)
          (hemlock::edit-definition arg)
-         arg)
+         nil)
         (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

@@ -362 +362 @@
 
 
-;;;; Typescript.
-#+typescript
-(progn
-(bind-key "Confirm Typescript Input" #k"return" :mode "Typescript")
-(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript")
-(bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript")
-(bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript")
-(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript")
-(bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript")
-(bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript")
-(bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript")
-(bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript")
-(bind-key "Typescript Slave Status" #k"hyper-s" :mode "Typescript")
-(bind-key "Select Slave" #k"control-meta-\c")
-(bind-key "Select Background" #k"control-meta-C")
-
-(bind-key "Abort Operations" #k"hyper-a")
-(bind-key "List Operations" #k"hyper-l")
-
-(bind-key "Next Compiler Error" #k"hyper-n")
-(bind-key "Previous Compiler Error" #k"hyper-p")
-)
-
-
 ;;;; Lisp (some).
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp

@@ -397 +397 @@
   "Internal variable which might contain the current buffer." )
 
+(defun all-buffers ()
+  "List of all buffers"
+  (remove-if #'echo-buffer-p *buffer-list*))
+
+(ccl:defloadvar *echo-area-counter* 0)
+
+(defun make-echo-buffer ()
+  (let* ((name (loop as name = (format nil "Echo Area ~d" (incf *echo-area-counter*))
+                  until (null (getstring name *buffer-names*))
+                  finally (return name)))
+         (buffer (internal-make-echo-buffer
+                  :%name name
+                  :major-mode-object (getstring "Echo Area" *mode-names*))))
+    (initialize-buffer buffer)))
+
 (defun make-buffer (name &key (modes (value hemlock::default-modes))
-                              (modeline-fields
-                               (value hemlock::default-modeline-fields))
-                              delete-hook)
+                              (modeline-fields (value hemlock::default-modeline-fields))
+                              delete-hook)
   "Creates and returns a buffer with the given Name if a buffer with Name does
    not already exist, otherwise returns nil.  Modes is a list of mode names,
    and Modeline-fields is a list of modeline field objects.  Delete-hook is a
    list of functions that take a buffer as the argument."
-  #+GZ
   (when (getstring name *buffer-names*)
     (cerror "Try to delete" "~s already exists" name)
@@ -415 +428 @@
          (unless (listp delete-hook)
            (error ":delete-hook is a list of functions -- ~S." delete-hook))
-         (let* ((region (make-empty-region))
-                (object (getstring "Fundamental" *mode-names*))
-                (buffer (internal-make-buffer
-                         :%name name
-                         :%region region
-                         :major-mode-object object
-                         :bindings (make-hash-table)
-                         :point (copy-mark (region-end region))
-                         :delete-hook delete-hook
-                         :variables (make-string-table))))
-           (set-buffer-modeline-fields buffer modeline-fields)
-           (setf (line-%buffer (mark-line (region-start region))) buffer)
-           (push buffer *buffer-list*)
-           (setf (getstring name *buffer-names*) buffer)
-           (unless (equalp modes '("Fundamental"))
-             (setf (buffer-major-mode buffer) (car modes))
-             (dolist (m (cdr modes))
-               (setf (buffer-minor-mode buffer m) t)))
-           (invoke-hook hemlock::make-buffer-hook buffer)
-           buffer))))
+         (let* ((buffer (internal-make-buffer
+                         :%name name
+                         :major-mode-object (getstring "Fundamental" *mode-names*)
+                         :delete-hook delete-hook)))
+           (initialize-buffer buffer :modeline-fields modeline-fields :modes modes)))))
+
+(defun initialize-buffer (buffer &key modeline-fields modes)
+  (setf (buffer-bindings buffer) (make-hash-table))
+  (setf (buffer-variables buffer) (make-string-table))
+  (let ((region (make-empty-region)))
+    (setf (line-%buffer (mark-line (region-start region))) buffer)
+    (setf (buffer-%region buffer) region)
+    (setf (buffer-point buffer) (copy-mark (region-end region))))
+  (setf (getstring (buffer-%name buffer) *buffer-names*) buffer)
+  (push buffer *buffer-list*)
+  (set-buffer-modeline-fields buffer modeline-fields)
+  (when modes
+    (unless (equalp modes '("Fundamental"))
+      (setf (buffer-major-mode buffer) (car modes))
+      (dolist (m (cdr modes))
+        (setf (buffer-minor-mode buffer m) t))))
+  (invoke-hook hemlock::make-buffer-hook buffer)
+  buffer)
 
 (defun delete-buffer (buffer)
@@ -440 +456 @@
   (when (eq buffer *current-buffer*)
     (error "Cannot delete current buffer ~S." buffer))
+  (when (buffer-document buffer)
+    (error "Cannot delete displayed buffer ~S." buffer))
   (invoke-hook (buffer-delete-hook buffer) buffer)
   (invoke-hook hemlock::delete-buffer-hook buffer)
@@ -470 +488 @@
 ;;; "make-buffer" wants fundamental to be defined when it is called, and we
 ;;; can't make the real fundamental mode until there is a current buffer
-;;; because "defmode" wants to invoke it's mode definition hook.  Also,
+;;; because "defmode" wants to invoke its mode definition hook.  Also,
 ;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet
 ;;; defined, so we supply this argument to MAKE-BUFFER as nil.  This is

branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp

@@ -55 +55 @@
              ,name)))
 
-(declfun change-to-buffer (buffer))     ;filecoms.lisp
-
-(declfun hemlock::to-line-comment (mark start)) ;defined in comments.lisp used in lispbuf.lisp
-
 ;;; Some special variables are forward-referenced, and we don't even
 ;;; need to invent a new language to advise the compiler of that ...
@@ -64 +60 @@
                   *the-sentinel*
                   *in-the-editor* *buffer-list* *things-to-do-once*
-                  *gc-notify-before* *gc-notify-after*))
+                  *gc-notify-before* *gc-notify-after*
+                  *key-event-history*))

branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

@@ -271 +271 @@
         (let ((merge
                (cond ((not (eps-parse-default eps)) nil)
-                     ((directoryp pn)
+                     ((ccl:directory-pathname-p pn)
                       (merge-pathnames pn (eps-parse-default eps)))
                      (t

branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp

@@ -221 +221 @@
                   (string/= string (ring-ref *echo-area-history* 0)))
           (ring-push string *echo-area-history*)))
-    (multiple-value-bind (res flag)
+    (multiple-value-bind (vals flag)
                          (funcall (eps-parse-verification-function eps) eps string)
-      (unless (or res flag) (editor-error))
-      (exit-echo-parse eps res))))
+      ;; flag is to distinguish vals=() to return 0 values vs vals=nil because invalid.
+      (unless (or vals flag) (editor-error))
+      (exit-echo-parse eps vals))))
 
 (defcommand "Previous Parse" (p)

branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp

@@ -121 +121 @@
                       (concatenate 'simple-string name "-COMMAND"))))
 
+;;; 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
+;;; not defined in some file, then nil is returned.
+;;; 
+(defun fun-defined-from-pathname (function)
+  "Takes a symbol or function and returns the pathname for the file the
+   function was defined in.  If it was not defined in some file, nil is
+   returned."
+  (flet ((true-namestring (path) (namestring (truename path))))
+    (typecase function
+      (function (fun-defined-from-pathname (ccl:function-name function)))
+      (symbol (let* ((info (ccl::%source-files function)))
+                (if (atom info)
+                  (true-namestring info)
+                  (let* ((finfo (assq 'function info)))
+                    (when finfo
+                      (true-namestring
+                       (if (atom finfo)
+                         finfo
+                         (car finfo)))))))))))
+
 ;;; GO-TO-DEFINITION tries to find name in file with a search pattern based
 ;;; on type (defun or defmacro).  File may be translated to another source
@@ -131 +152 @@
      (file
       (setf file (go-to-definition-file file))
-      (let* ((buffer (find-file-command nil file))
+      (let* ((buffer (old-find-file-command nil file))
              (point (buffer-point buffer))
              (name-len (length name)))

branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp

@@ -355 +355 @@
   (clear-echo-area))
 
-;;; REVERT-PATHNAME -- Internal
-;;;
-;;; If in Save Mode, return either the checkpoint pathname or the buffer
-;;; pathname whichever is more recent. Otherwise return the buffer-pathname
-;;; if it exists. If neither file exists, return NIL.
-;;; 
-(defun revert-pathname (buffer)
-  (let* ((buffer-pn (buffer-pathname buffer))
-         (buffer-pn-date (file-write-date buffer-pn))
-         (checkpoint-pn (get-checkpoint-pathname buffer))
-         (checkpoint-pn-date (and checkpoint-pn
-                                  (file-write-date checkpoint-pn))))
-    (cond (checkpoint-pn-date
-           (if (> checkpoint-pn-date (or buffer-pn-date 0))
-               (values checkpoint-pn t)
-               (values buffer-pn nil)))
-          (buffer-pn-date (values buffer-pn nil))
-          (t (values nil nil)))))
-
-
-
 
 ;;;; Find file.
 
 
-(defcommand "Find File" (p &optional pathname)
+(defcommand "Find File" (p)
   "Visit a file in its own buffer.
    If the file is already in some buffer, select that buffer,
    otherwise make a new buffer with the same name as the file and
    read the file into it."
-  "Make a buffer containing the file Pathname current, creating a buffer
-   if necessary.  The buffer is returned."
-  (if pathname
-    (old-find-file-command p pathname)
-    (hi::open-document)))
+  (hi::open-document))
   
 
-
+#|
 (defun find-file-buffer (pathname)
-  "Return a buffer assoicated with the file Pathname, reading the file into a
+  "Return a buffer associated with the file Pathname, reading the file into a
    new buffer if necessary.  The second value is T if we created a buffer, NIL
    otherwise.  If the file has already been read, we check to see if the file
@@ -433 +408 @@
            (read-buffer-file pathname found)
            (values found nil)))))
-
+|#
 
 ;;; Check-Disk-Version-Consistent  --  Internal

branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp

@@ -478 +478 @@
       column)))
 
+(defun move-to-column (mark column &optional (line (mark-line mark)))
+  (let ((tab-spaces (value hemlock::spaces-per-tab)))
+    (multiple-value-bind (chars gap-start gap-end end-pos)
+                         (if (current-open-line-p line)
+                           (values (current-open-chars)
+                                   (current-left-open-pos)
+                                   (current-right-open-pos)
+                                   (current-line-cache-length))
+                           (values (line-%chars line)
+                                   0
+                                   0
+                                   (length (line-%chars line))))
+      (loop with col = 0 with pos = 0
+        do (when (eql pos gap-start) (setq pos gap-end))
+        while (and (< pos end-pos) (< col column))
+        do (incf col (if (eql (schar chars pos) #\tab)
+                           (- tab-spaces (mod col tab-spaces))
+                           1))
+        do (incf pos)
+        finally (return (unless (< col column)
+                          (move-to-position mark pos line)))))))
+
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp

@@ -381 +381 @@
     result))
 
+(defvar *key-event-history* (make-ring 60)) 
 
 ;;; LAST-COMMAND-TYPE  --  Public

branches/event-ide/ccl/cocoa-ide/hemlock/src/isearchcoms.lisp

@@ -15 +15 @@
   :value "I-Search Self Insert"
   :mode "I-Search")
-
-(defhvar "I-Search State"
-  "Internal variable containing current state of I-Search"
-  :mode "I-Search")
-
-(defun current-isearch-state ()
-  (or (value i-search-state)
-      (error "I-Search command invoked outside I-Search")))
 
 (defcommand "Incremental Search" (p)
@@ -129 +121 @@
 ;;
 
+(defun current-isearch-state ()
+  (or (value i-search-state)
+      (error "I-Search command invoked outside I-Search")))
+
 (defun start-isearch-mode (direction)
-  (setf (buffer-minor-mode (current-buffer) "I-Search") t)
-  (let* ((iss (make-isearch-state :direction direction
+  (let* ((buffer (current-buffer))
+         (iss (make-isearch-state :direction direction
                                   :start-region (current-region-info))))
+    (setf (buffer-minor-mode buffer "I-Search") t)
+    (unless (hemlock-bound-p 'i-search-state :buffer buffer)
+      (defhvar "I-Search State"
+        "Internal variable containing current state of I-Search"
+        :buffer buffer))
     (push-new-buffer-mark (current-point))
     (setf (value i-search-state) iss)

branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp

@@ -463 +463 @@
 (defvar *key-events*)
 
-;;; GET-KEY-EVENT -- Internal.
+;;; GET-KEY-EVENT* -- Internal.
 ;;;
 ;;; This finds the key-event specified by keysym and bits.  If the key-event

branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

@@ -557 +557 @@
 (declaim (special *random-typeout-ml-fields* *buffer-names*))
 
-(defvar *random-typeout-buffers* () "A list of random-typeout buffers.")
-
-
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp

@@ -82 +82 @@
 ;;;; DEFINE-SOME-VARIABLES.
 
-;;; This is necessary to define "Default Status Line Fields" which belongs
-;;; beside the other modeline variables.  This DEFVAR would live in
-;;; Morecoms.Lisp, but it is compiled and loaded after this file.
-;;;
-(declaim (special hemlock::*recursive-edit-count*))
-;;;
-(make-modeline-field
- :name :edit-level :width 15
- :function #'(lambda (buffer)
-               (declare (ignore buffer))
-               (if (zerop hemlock::*recursive-edit-count*)
-                   ""
-                   (format nil "Edit Level: ~2,'0D "
-                           hemlock::*recursive-edit-count*))))
-
-;;; This is necessary to define "Default Status Line Fields" which belongs
-;;; beside the other modeline variables.  This DEFVAR would live in
-;;; Completion.Lisp, but it is compiled and loaded after this file.
-;;;
-(make-modeline-field
- :name :completion :width 40
- :function #'(lambda (buffer)
-               (declare (special hemlock::*completion-mode-possibility*))
-               (declare (ignore buffer))
-               hemlock::*completion-mode-possibility*))
-
-
 (defun define-some-variables ()
   (defhvar "Default Modes"
     "This variable contains the default list of modes for new buffers."
     :value '("Fundamental"))
-  (defhvar "Echo Area Height"
-    "Number of lines in the echo area window."
-    :value 3)
   (defhvar "Make Buffer Hook"
     "This hook is called with the new buffer whenever a buffer is created.")
@@ -142 +112 @@
   (defhvar "Buffer Package Hook"
       "This hook is called with the new package name whenever a (Lisp) buffer's package changes")
-  (defhvar "Set Window Hook"
-    "This hook is called with the new window when the current window
-     is set.")
-  (defhvar "Make Window Hook"
-    "This hook is called with a new window when one is created.")
-  (defhvar "Delete Window Hook"
-    "This hook is called with a window before it is deleted.")
-  (defhvar "Window Buffer Hook"
-    "This hook is invoked with the window and new buffer when a window's
-     buffer is changed.")
   (defhvar "Delete Variable Hook"
     "This hook is called when a variable is deleted with the args to
      delete-variable.")
-  (defhvar "Entry Hook"
-    "this hook is called when the editor is entered.")
-  (defhvar "Exit Hook"
-    "This hook is called when the editor is exited.")
-  (defhvar "Redisplay Hook"
-    "This is called on the current window from REDISPLAY after checking the
-     window display start, window image, and recentering.  After calling the
-     functions in this hook, we do the above stuff and call the smart
-     redisplay method for the device."
-    :value nil)
   (defhvar "Key Echo Delay"
     "Wait this many seconds before echoing keys in the command loop.  This
@@ -188 +138 @@
     "This hook is called when a mode character attribute is deleted.")
   (defhvar "Default Modeline Fields"
-    "The default list of modeline-fields for MAKE-WINDOW."
+    "The default list of modeline-fields for MAKE-BUFFER."
     :value *default-modeline-fields*)
-  (defhvar "Default Status Line Fields"
-    "This is the default list of modeline-fields for the echo area window's
-     modeline which is used for general information."
-    :value (list (make-modeline-field
-                  :name :hemlock-banner :width 27
-                  :function #'(lambda (buffer)
-                                (declare (ignore buffer))
-                                (format nil "Hemlock ~A  "
-                                        *hemlock-version*)))
-                 (modeline-field :edit-level)
-                 (modeline-field :completion)))
   (defhvar "Maximum Modeline Pathname Length"
     "When set, this variable is the maximum length of the display of a pathname

branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp

@@ -140 +140 @@
                         (format nil "~A: " name))
                        (t "")))))
+
+(make-modeline-field
+ :name :completion :width 40
+ :function #'(lambda (buffer)
+               (declare (special hemlock::*completion-mode-possibility*))
+               (declare (ignore buffer))
+               hemlock::*completion-mode-possibility*))
+
+
 
 
@@ -216 +225 @@
 
 (defun note-modeline-change (buffer &rest more)
-  (declare (ignore more))
+  (declare (ignore more)) ;; used as hooks some of which pass more info
   (hemlock-ext:invalidate-modeline buffer))
+
+;; Public version
+(defun update-modeline-fields (buffer)
+  (note-modeline-change buffer))

branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp

@@ -376 +376 @@
              char abspos size (round (/ (* 100 abspos) size)) line-number charpos)))
 
-;;;; Page commands & stuff.
-
-(defvar *goto-page-last-num* 0)
-(defvar *goto-page-last-string* "")
-
-(defcommand "Goto Page" (p)
-  "Go to an absolute page number (argument).  If no argument, then go to
-  next page.  A negative argument moves back that many pages if possible.
-  If argument is zero, prompt for string and goto page with substring
-  in title."
-  "Go to an absolute page number (argument).  If no argument, then go to
-  next page.  A negative argument moves back that many pages if possible.
-  If argument is zero, prompt for string and goto page with substring
-  in title."
-  (let ((point (current-point)))
-    (cond ((not p)
-           (page-offset point 1))
-          ((zerop p)
-           (let* ((againp (eq (last-command-type) :goto-page-zero))
-                  (name (prompt-for-string :prompt "Substring of page title: "
-                                           :default (if againp
-                                                        *goto-page-last-string*)))
-                  (dir (page-directory (current-buffer)))
-                  (i 1))
-             (declare (simple-string name))
-             (cond ((not againp)
-                    (push-new-buffer-mark point))
-                   ((string-equal name *goto-page-last-string*)
-                    (setf dir (nthcdr *goto-page-last-num* dir))
-                    (setf i (1+ *goto-page-last-num*))))
-             (loop 
-               (when (null dir)
-                 (editor-error "No page title contains ~S." name))
-               (when (search name (the simple-string (car dir))
-                             :test #'char-equal)
-                 (goto-page point i)
-                 (setf (last-command-type) :goto-page-zero)
-                 (setf *goto-page-last-num* i)
-                 (setf *goto-page-last-string* name)
-                 (return t))
-               (incf i)
-               (setf dir (cdr dir)))))
-            ((minusp p)
-             (page-offset point p))
-            (t (goto-page point p)))
-    (set-scroll-position :line point)))
-
-(defun goto-page (mark i)
-  (with-mark ((m mark))
-    (buffer-start m)
-    (unless (page-offset m (1- i))
-      (editor-error "No page numbered ~D." i))
-    (move-mark mark m)))
-
-                           
-
-
 (defcommand "Count Lines" (p)
   "Display number of lines in the region."

branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

@@ -4 +4 @@
   (:use)
   (:export
-   ;; Functions from the CIM:
+   ;; Symbols from the CIM, by chapter:
+
+   ;; Representation of Text
    #:linep
    #:line-string
@@ -25 +27 @@
    #:copy-mark
    #:delete-mark
+   #:with-mark
    #:move-to-position
    #:move-to-absolute-position
@@ -49 +52 @@
    #:count-lines
    #:count-characters
+
+   ;; Buffers
    #:current-buffer
    #:current-point-for-insertion
@@ -60 +65 @@
    #:push-buffer-mark
    #:push-new-buffer-mark
-   #:change-to-buffer
+   #:all-buffers
    #:make-buffer
    #:bufferp
@@ -79 +84 @@
    #:buffer-package
    #:delete-buffer
+   #:with-writable-buffer
    #:make-modeline-field
    #:modeline-field-p
@@ -87 +93 @@
    #:buffer-modeline-fields
    #:buffer-modeline-field-p
-   #:update-modeline-field
+   #:update-modeline-fields
+
+   ;; Altering and Searching Text
    #:insert-character
    #:insert-string
@@ -118 +126 @@
    #:kill-region
    #:kill-characters
+   #:*ephemerally-active-command-types*
    #:activate-region
    #:deactivate-region
@@ -128 +137 @@
    #:find-pattern
    #:replace-pattern
+   #:*last-search-string*
+
+   ;; Hemlock Variables
+   #:*global-variable-names*
    #:current-variable-tables
    #:defhvar
@@ -135 +148 @@
    #:variable-name
    #:string-to-variable
+   #:value
+   #:setv
+   #:hlet
    #:hemlock-bound-p
    #:delete-variable
+   #:add-hook
+   #:remove-hook
+   #:invoke-hook
+
+   ;; Commands
+   #:*command-names*
+   #:defcommand
    #:make-command
    #:commandp
@@ -148 +171 @@
    #:map-bindings
    #:key-translation
-   #:interactive
    #:last-command-type
    #:prefix-argument
-   #:recursive-edit
-   #:in-recursive-edit
-   #:exit-recursive-edit
-   #:abort-recursive-edit
+
+   ;; Modes
+   #:*mode-names*
    #:defmode
    #:mode-documentation
@@ -161 +182 @@
    #:mode-variables
    #:mode-major-p
+
+   ;; Character attributes
+   #:*character-attribute-names*
    #:defattribute
    #:character-attribute-name
@@ -173 +197 @@
    #:reverse-find-not-attribute
    #:character-attribute-hooks
-   #:make-window
-   #:delete-window
-   #:next-window
-   #:previous-window
-   #:show-mark
-   #:redisplay
-   #:redisplay-all
-   #:editor-finish-output
+
+   ;; Controlling the Display
+   #:current-view
+   #:hemlock-view-p
+   #:hemlock-view-buffer
+   #:mark-column
+   #:move-to-column
+   #:set-scroll-position
+
+   ;; Logical Key Events
+   #:*logical-key-event-names*
    #:define-logical-key-event
    #:logical-key-event-key-events
@@ -186 +213 @@
    #:logical-key-event-documentation
    #:logical-key-event-p
+
+   ;; The Echo Area
    #:clear-echo-area
    #:message
    #:loud-message
+   #:beep
+   #:command-case
    #:prompt-for-buffer
    #:prompt-for-key-event
@@ -200 +231 @@
    #:prompt-for-y-or-n
    #:prompt-for-yes-or-no
+   #:parse-for-something
+
+   ;; Files
+   #:define-file-option
+   #:define-file-type-hook
    #:process-file-options
    #:pathname-to-buffer-name
@@ -207 +243 @@
    #:write-buffer-file
    #:read-buffer-file
-   #:find-file-buffer
+  ;; #:find-file-buffer
+
+   ;;# Hemlock's Lisp Environment
    ;;   #:ed
-   #:pause-hemlock
-   #:clear-editor-input
+   #:*key-event-history*
+   #:last-key-event-typed
+   #:last-char-typed
    #:make-hemlock-output-stream
    #:hemlock-output-stream-p
    #:make-hemlock-region-stream
    #:hemlock-region-stream-p
-   #:editor-error-format-string
-   #:editor-error-format-arguments
+   #:with-input-from-region
+   #:with-output-to-mark
+   #:with-pop-up-display
    #:editor-error
-   #:add-definition-dir-translation
-   #:delete-definition-dir-translation
-   #:schedule-event
-   #:remove-scheduled-event
+   #:handle-lisp-errors
    #:in-lisp
+   #:do-alpha-chars
+
+   ;; Higher-Level Text Primitives
    #:indent-region
    #:indent-region-for-commands
@@ -241 +281 @@
    #:paragraph-offset
    #:mark-paragraph
-   #:goto-page
-   #:page-offset
-   #:page-directory
-   #:display-page-directory
    #:fill-region
    #:fill-region-by-paragraphs
+
+   ;; Utilities
    #:make-string-table
    #:string-table-p
@@ -256 +294 @@
    #:find-ambiguous
    #:find-containing
+   #:do-strings
    #:make-ring
    #:ringp
@@ -265 +304 @@
    #:save-for-undo
    #:make-region-undo
-   #:supply-generic-pointer-up-function
-
-   ;; Macros from the CIM:
-   #:with-writable-buffer
-   #:value
-   #:setv
-   #:add-hook
-   #:remove-hook
-   #:invoke-hook
-   #:defcommand
-   #:use-buffer
-   #:command-case
-   #:define-file-option
-   #:define-file-type-hook
-   #:do-active-group
-   #:with-input-from-region
-   #:with-output-to-mark
-   #:with-pop-up-display
-   #:handle-lisp-errors
-   #:do-alpha-chars
-   #:do-strings
-   
+
+   ;; Miscellaneous
+
+   #:define-keysym
+   #:define-keysym-code
+   #:define-mouse-keysym
+   #:name-keysym
+   #:keysym-names
+   #:keysym-preferred-name
+   #:define-key-event-modifier
+   #:*all-modifier-names*
+   #:make-key-event-bits
+   #:key-event-modifier-mask
+   #:key-event-bits-modifiers
+   #:make-key-event
+   #:key-event-p
+   #:key-event-bits
+   #:key-event-keysym
+   #:char-key-event
+   #:key-event-char
+   #:key-event-bit-p
+   #:do-alpha-key-events
+   #:pretty-key-string
    ))
 
@@ -312 +352 @@
    #:send-string-to-listener
    #:buffer-process-description
+   #:raise-buffer-view
    ))
 
@@ -365 +406 @@
 
    ;; rompsite.lisp
-   #:show-mark #:fun-defined-from-pathname
-   #:editor-describe-function #:pause-hemlock #:store-cut-string
-   #:fetch-cut-string #:schedule-event #:remove-scheduled-event
-   #:enter-window-autoraise #:directoryp #:merge-relative-pathnames
+   #:editor-describe-function
+   #:merge-relative-pathnames
    ;;
    ;; Export default-font to prevent a name conflict that occurs due to
@@ -377 +416 @@
 
    ;; 
-   #:mark #:mark-line #:mark-charpos #:mark-column #:markp #:region #:region-start #:region-end
+   #:mark #:mark-line #:mark-charpos #:mark-column #:move-to-column
+   #:markp #:region #:region-start #:region-end
    #:regionp #:buffer #:bufferp #:buffer-modes #:buffer-point #:buffer-writable
    #:buffer-delete-hook #:buffer-variables #:buffer-write-date
@@ -384 +424 @@
    #:command-documentation #:modeline-field #:modeline-field-p
 
-   ;; from input.lisp
-   #:clear-editor-input
-   #:*key-event-history* #:input-waiting
-
    ;; from macros.lisp
    #:invoke-hook #:value #:setv #:hlet #:string-to-variable #:add-hook #:remove-hook
@@ -393 +429 @@
    #:editor-error-format-string #:editor-error-format-arguments #:do-strings
    #:command-case #:reprompt #:with-output-to-mark #:with-input-from-region
-   #:handle-lisp-errors #:with-pop-up-display #:*random-typeout-buffers*
+   #:handle-lisp-errors #:with-pop-up-display
 
    ;; from views.lisp
@@ -415 +451 @@
    #:delete-string #:clrstring #:do-strings
 
-   ;; bit-display.lisp
-   #:redisplay #:redisplay-all
-
-   ;; bit-screen.lisp
-   #:make-xwindow-like-hwindow #:*create-window-hook* #:*delete-window-hook*
-   #:*random-typeout-hook* #:*create-initial-windows-hook*
-
    ;; buffer.lisp
    #:buffer-modified #:buffer-region #:buffer-name #:buffer-pathname
    #:buffer-major-mode #:buffer-minor-mode #:buffer-modeline-fields
    #:buffer-modeline-field-p #:current-buffer #:current-point
-   #:in-recursive-edit #:exit-recursive-edit #:abort-recursive-edit
-   #:recursive-edit #:defmode #:mode-major-p #:mode-variables #:mode-documentation
+   #:defmode #:mode-major-p #:mode-variables #:mode-documentation
    #:make-buffer #:delete-buffer #:with-writable-buffer #:buffer-start-mark
    #:buffer-end-mark #:*buffer-list*
@@ -440 +468 @@
    #:key-event-modifier-mask #:key-event-char #:key-event-bit-p
    #:pretty-key-string
-
-   ;; display.lisp
-   #:redisplay #:redisplay-all
 
    ;; echo.lisp
@@ -512 +537 @@
    #:after-editor-initializations
 
-   ;; screen.lisp
-   #:make-window #:delete-window #:next-window #:previous-window
-
-
    ;; search1.lisp
    #:search-pattern #:search-pattern-p #:find-pattern #:replace-pattern
    #:new-search-pattern
 
+   ;; modeline.lisp
+   #:modeline-field-width
+   #:modeline-field-function #:make-modeline-field
+   #:update-modeline-field #:modeline-field-name #:modeline-field
 
    ;; streams.lisp
@@ -538 +563 @@
    #:hemlock-bound-p #:defhvar #:delete-variable
 
-   ;; window.lisp
-   #:modeline-field-width
-   #:modeline-field-function #:make-modeline-field
-   #:update-modeline-field #:modeline-field-name #:modeline-field
-   #:editor-finish-output
-
    ))
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp

@@ -107 +107 @@
 (defcommand "Save Position" (p)
   "Saves the current location in a register.  Prompts for register name."
-  "Saves the current location in a register.  Prompts for register name."
   (declare (ignore p))
   (let ((reg-name (prompt-for-register)))
@@ -115 +114 @@
 (defcommand "Jump to Saved Position" (p)
   "Moves the point to a location previously saved in a register."
-  "Moves the point to a location previously saved in a register."
   (declare (ignore p))
   (let* ((reg-name (prompt-for-register "Jump to Register: " t))
@@ -121 +119 @@
     (unless (markp val)
       (editor-error "Register ~A does not hold a location." reg-name))
-    (change-to-buffer (mark-buffer val))
-    (move-mark (current-point) val)))
+    (unless (eq (mark-buffer val) (current-buffer))
+      (hemlock-ext:raise-buffer-view (mark-buffer val)
+                                     #'(lambda ()
+                                         (move-mark (current-point) val))))))
 
 (defcommand "Kill Register" (p)
-  "Kill a regist er.  Prompts for the name."
   "Kill a register.  Prompts for the name."
   (declare (ignore p))

branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp

@@ -15 +15 @@
 
 (in-package :hi)
-
-;;;; SITE-INIT.
-
-;;; *key-event-history* is defined in input.lisp, but it needs to be set in
-;;; SITE-INIT, since MAKE-RING doesn't exist at load time for this file.
-;;;
-(declaim (special *key-event-history*))
 
 ;;; SITE-INIT  --  Internal
@@ -63 +56 @@
     "Paints white on black in window bodies, black on white in modelines."
     :value nil)
-  (defhvar "Enter Window Hook"
-    "When the mouse enters an editor window, this hook is invoked.  These
-     functions take the Hemlock Window as an argument."
-    :value nil)
-  (defhvar "Exit Window Hook"
-    "When the mouse exits an editor window, this hook is invoked.  These
-     functions take the Hemlock Window as an argument."
-    :value nil)
-  (defhvar "Set Window Autoraise"
-    "When non-nil, setting the current window will automatically raise that
-     window via a function on \"Set Window Hook\".  If the value is :echo-only
-     (the default), then only the echo area window will be raised
-     automatically upon becoming current."
-    :value :echo-only)
   (defhvar "Default Font"
     "The string name of the font to be used for Hemlock -- buffer text,
@@ -94 +73 @@
      a ruler in the bottom border of the window."
     :value t)
-
-  (setf *key-event-history* (make-ring 60))
   nil)
 
@@ -115 +92 @@
    directory."
   (let ((pathname (merge-pathnames pathname default-directory)))
-    (if (directoryp pathname)
+    (if (ccl:directory-pathname-p pathname)
         pathname
         (pathname (concatenate 'simple-string
                                (namestring pathname)
                                "/")))))
-
-(defun directoryp (pathname)
-  "Returns whether pathname names a directory, that is whether it has no
-   name and no type components."
-  (not (or (pathname-name pathname) (pathname-type pathname))))
-
-
 
 
@@ -161 +131 @@
 
 
-
-;;;; Event scheduling.
-
-;;; The time queue provides a ROUGH mechanism for scheduling events to
-;;; occur after a given amount of time has passed, optionally repeating
-;;; using the given time as an interval for rescheduling.  When the input
-;;; loop goes around, it will check the current time and process all events
-;;; that should have happened before or at this time.  The function gets
-;;; called on the number of seconds that have elapsed since it was last
-;;; called.
-;;;
-;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the
-;;; editor stream in methods.
-;;;
-;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces.
-
-(defstruct (tq-event (:print-function print-tq-event)
-                     (:constructor make-tq-event
-                                   (time last-time interval function)))
-  time          ; When the event should happen.
-  last-time     ; When the event was scheduled.
-  interval      ; When non-nil, how often the event should happen.
-  function)     ; What to do.
-
-(defun print-tq-event (obj stream n)
-  (declare (ignore n))
-  (format stream "#<Tq-Event ~S>" (tq-event-function obj)))
-
-(defvar *time-queue* nil
-  "This is the time priority queue used in Hemlock input streams for event
-   scheduling.")
-
-;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*.
-;;; Event is inserted before the first element that it is less than (which
-;;; means that it gets inserted after elements that are the same).
-;;; *time-queue* is returned.
-;;; 
-(defun queue-time-event (event)
-  (let ((time (tq-event-time event)))
-    (if *time-queue*
-        (if (< time (tq-event-time (car *time-queue*)))
-            (push event *time-queue*)
-            (do ((prev *time-queue* rest)
-                 (rest (cdr *time-queue*) (cdr rest)))
-                ((or (null rest)
-                     (< time (tq-event-time (car rest))))
-                 (push event (cdr prev))
-                 *time-queue*)))
-        (push event *time-queue*))))
-
-;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for
-;;; the next event to happen.
-;;; 
-(defun next-scheduled-event-wait ()
-  (if *time-queue*
-      (let ((wait (round (- (tq-event-time (car *time-queue*))
-                            (get-internal-real-time))
-                         internal-time-units-per-second)))
-        (if (plusp wait) wait 0))))
-
-;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose
-;;; time has come.  If we run out of events, or there are none, then we get
-;;; out.  If we popped an event whose time hasn't come, we push it back on the
-;;; queue.  Each function is called on how many seconds, roughly, went by since
-;;; the last time it was called (or scheduled).  If it has an interval, we
-;;; re-queue it.  While invoking the function, bind *time-queue* to nothing in
-;;; case the event function tries to read off *editor-input*.
-;;;
-(defun invoke-scheduled-events ()
-  (let ((time (get-internal-real-time)))
-    (loop
-      (unless *time-queue* (return))
-      (let* ((event (car *time-queue*))
-             (event-time (tq-event-time event)))
-        (cond ((>= time event-time)
-               (let ((*time-queue* nil))
-                 (funcall (tq-event-function event)
-                          (round (- time (tq-event-last-time event))
-                                 internal-time-units-per-second)))
-               (without-interrupts
-                (let ((interval (tq-event-interval event)))
-                  (when interval
-                    (setf (tq-event-time event) (+ time interval))
-                    (setf (tq-event-last-time event) time)
-                    (pop *time-queue*)
-                    (queue-time-event event)))))
-              (t (return)))))))
-
-(defun schedule-event (time function &optional (repeat t))
-  "This causes function to be called after time seconds have passed,
-   optionally repeating every time seconds.  This is a rough mechanism
-   since commands can take an arbitrary amount of time to run; the function
-   will be called at the first possible moment after time has elapsed.
-   Function takes the time that has elapsed since the last time it was
-   called (or since it was scheduled for the first invocation)."
-  (let ((now (get-internal-real-time))
-        (itime (* internal-time-units-per-second time)))
-    (queue-time-event (make-tq-event (+ itime now) now (if repeat itime)
-                                     function))))
-
-(defun remove-scheduled-event (function)
-  "Removes function queued with SCHEDULE-EVENT."
-  (setf *time-queue* (delete function *time-queue* :key #'tq-event-function)))
-
-
-;;;; Function description and defined-from.
-
-;;; 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
-;;; not defined in some file, then nil is returned.
-;;; 
-(defun fun-defined-from-pathname (function)
-  "Takes a symbol or function and returns the pathname for the file the
-   function was defined in.  If it was not defined in some file, nil is
-   returned."
-  (flet ((true-namestring (path) (namestring (truename path))))
-    (typecase function
-      (function (fun-defined-from-pathname (ccl:function-name function)))
-      (symbol (let* ((info (ccl::%source-files function)))
-                (if (atom info)
-                  (true-namestring info)
-                  (let* ((finfo (assq 'function info)))
-                    (when finfo
-                      (true-namestring
-                       (if (atom finfo)
-                         finfo
-                         (car finfo)))))))))))
-
-
 (defvar *editor-describe-stream*
   #+CMU (system:make-indenting-stream *standard-output*)

branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

@@ -102 +102 @@
 (add-hook abort-hook 'abort-query/replace-mode)
 
-(defhvar "Query/Replace State"
-  "Internal variable containing current state of Query/Replace"
-  :mode "Query/Replace")
-
-(defun current-query-replace-state ()
-  (or (value query/replace-state)
-      (error "Query/Replace command invoked outside Query Replace")))
-
 (defhvar "Case Replace"
   "If this is true then \"Query Replace\" will try to preserve case when
@@ -131 +123 @@
     (query/replace-finish qrs)))
 
+(defun current-query-replace-state ()
+  (or (value query/replace-state)
+      (error "Query/Replace command invoked outside Query Replace")))
+
 (defcommand "Query Replace" (p &optional
                                (target (prompt-for-string
@@ -142 +138 @@
    from the keyboard is given.  If the region is active, limit queries to
    occurrences that occur within it, otherwise use point to end of buffer."
-  (let ((qrs (query/replace-init :count p :target target :replacement replacement
-                                 :undo-name "Query Replace")))
+  (let* ((buffer (current-buffer))
+         (qrs (query/replace-init :count p :target target :replacement replacement
+                                  :undo-name "Query Replace")))
     (setf (buffer-minor-mode (current-buffer) "Query/Replace") t)
+    (unless (hemlock-bound-p 'query/replace-state :buffer buffer)
+      (defhvar "Query/Replace State"
+        "Internal variable containing current state of Query/Replace"
+        :buffer buffer))
     (setf (value query/replace-state) qrs)
     (query/replace-find-next qrs)))

branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp

@@ -120 +120 @@
   )
 
+(defstruct (echo-buffer (:include buffer)
+                        (:constructor internal-make-echo-buffer))
+  )
 
 (defstruct (font-region-node (:include ccl::dll-node)

branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

@@ -55 +55 @@
    ))
 
+(defun hemlock-view-p (object)
+  (typep object 'hemlock-view))
+
 (defmethod initialize-instance ((view hemlock-view) &key)
   (call-next-method)
@@ -79 +82 @@
 ;; This handles errors in event handling.  It assumes it's called in a normal
 ;; event handling context for some view.
-(defun lisp-error-error-handler (condition)
+(defun lisp-error-error-handler (condition &key debug-p)
   (with-standard-standard-output
     (handler-case
         (progn
-          (hemlock-ext:report-hemlock-error (current-view) condition)
+          (hemlock-ext:report-hemlock-error (current-view) condition debug-p)
           (let ((emsg (ignore-errors (princ-to-string condition))))
             (abort-to-toplevel (or emsg "Error"))))
@@ -186 +189 @@
                           (get-command-binding-for-key view key)
        #+gz (log-debug "~&  binding ~s ~s" main-binding transparent-bindings)
+       (ring-push key *key-event-history*)
        (when main-binding
          (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
@@ -222 +226 @@
   "Set the desired scroll position of the current view"
   (when (markp where)
+    (unless (eq (mark-buffer where)
+                (hemlock-view-buffer (current-view)))
+      (error "~s is not a mark in the current view." where))
     (setq where (mark-absolute-position where)))
   (setf *next-view-start* (cons how where)))
@@ -248 +255 @@
         (modifying-buffer-storage (*current-buffer*)
           (restart-case
-              (handler-bind ((error #'lisp-error-error-handler))
+              (handler-bind ((error #'(lambda (c)
+                                        (lisp-error-error-handler c :debug-p t))))
                 (execute-hemlock-key view key))
             (exit-event-handler () :report "Exit from hemlock event handler")))