Index: /branches/ide-1.0/ccl/hemlock/src/archive/auto-save.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/auto-save.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/auto-save.lisp	(revision 6569)
@@ -0,0 +1,401 @@
+;;; -*- Package: Hemlock; Log: hemlock.log -*-
+;;; 
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;; 
+;;; Auto-Save Mode
+;;; Written by Christopher Hoover
+;;;
+
+(in-package :hemlock)
+
+
+
+;;;; Per Buffer State Information
+
+;;; 
+;;; The auto-save-state structure is used to store the state information for
+;;; a particular buffer in "Save" mode, namely the buffer-signature at the last
+;;; key stroke, the buffer-signature at the time of the last checkpoint, a count
+;;; of the number of destructive keystrokes which have occured since the time of
+;;; the last checkpoint, and the pathname used to write the last checkpoint.  It
+;;; is generally kept in a buffer-local hvar called "Auto Save State".
+;;; 
+(defstruct (auto-save-state
+	    (:conc-name save-state-)
+	    (:print-function print-auto-save-state))
+  "Per buffer state for auto-save"
+  (buffer nil)				   ; buffer this state is for; for printing
+  (key-signature 0 :type fixnum)	   ; buffer-signature at last keystroke
+  (last-ckp-signature 0 :type fixnum)	   ; buffer-signature at last checkpoint
+  (key-count 0 :type fixnum)		   ; # destructive keystrokes since ckp
+  (pathname nil))			   ; pathname used to write last ckp file
+
+(defun print-auto-save-state (auto-save-state stream depth)
+  (declare (ignore depth))
+  (format stream "#<Auto Save Buffer State for buffer ~A>"
+	  (buffer-name (save-state-buffer auto-save-state))))
+
+
+;;; GET-AUTO-SAVE-STATE tries to get the auto-save-state for the buffer.  If
+;;; the buffer is not in "Save" mode then this function returns NIL.
+;;;
+(defun get-auto-save-state (buffer)
+  (if (hemlock-bound-p 'auto-save-state :buffer buffer)
+       (variable-value 'auto-save-state :buffer buffer)))
+
+;;; RESET-AUTO-SAVE-STATE resets the auto-save-state of the buffer making it
+;;; look as if the buffer was just checkpointed.  This is in fact how
+;;; checkpoint-buffer updates the state.  If the buffer is not in "Save" mode
+;;; this function punts the attempt and does nothing.
+;;;
+(defun reset-auto-save-state (buffer)
+  (let ((state (get-auto-save-state buffer)))
+    (when state
+      (let ((signature (buffer-signature buffer)))
+	(setf (save-state-key-signature state)
+	      signature)
+	(setf (save-state-last-ckp-signature state)
+	      signature)
+	(setf (save-state-key-count state)
+	      0)))))
+
+
+
+
+;;;; Checkpoint Pathname Interface/Internal Routines
+
+;;; GET-CHECKPOINT-PATHNAME -- Interface
+;;;
+;;; Returns the pathname of the checkpoint file for the specified
+;;; buffer;  Returns NIL if no checkpoints have been written thus
+;;; far or if the buffer isn't in "Save" mode.
+;;; 
+(defun get-checkpoint-pathname (buffer)
+  "Returns the pathname of the checkpoint file for the specified buffer.
+   If no checkpoints have been written thus far, or if the buffer is not in
+   \"Save\" mode, return nil."
+  (let ((state (get-auto-save-state buffer)))
+    (if state
+	(save-state-pathname state))))
+
+;;; MAKE-UNIQUE-SAVE-PATHNAME is used as the default value for "Auto Save
+;;; Pathname Hook" and is mentioned in the User's manual, so it gets a doc
+;;; doc string.
+;;;
+(defun make-unique-save-pathname (buffer)
+  "Returns a pathname for a non-existing file in DEFAULT-DIRECTORY.  Uses
+   GENSYM to for a file name: save-GENSYM.CKP."
+  (declare (ignore buffer))
+  (let ((def-dir (hemlock-ext:default-directory)))
+    (loop
+      (let* ((sym (gensym))
+	     (f (merge-pathnames (format nil "save-~A.CKP" sym) def-dir)))
+	(unless (probe-file f)
+	  (return f))))))
+    
+(defhvar "Auto Save Pathname Hook"
+  "This hook is called by Auto Save to get a checkpoint pathname when there
+   is no pathname associated with a buffer.  If this value is NIL, then
+   \"Save\" mode is turned off in the buffer.  Otherwise, the function
+   will be called. It should take a buffer as its argument and return either
+   NIL or a pathname.  If NIL is returned, then \"Save\" mode is turned off
+   in the buffer;  else the pathname returned is used as the checkpoint
+   pathname for the buffer."
+  :value #'make-unique-save-pathname)
+
+
+;;; MAKE-BUFFER-CKP-PATHNAME attempts to form a pathname by using the buffer's
+;;; associated pathname (from buffer-pathname).  If there isn't a pathname
+;;; associated with the buffer, the function returns nil.  Otherwise, it uses
+;;; the "Auto Save Filename Pattern" and FORMAT to make the checkpoint
+;;; pathname.
+;;;
+(defun make-buffer-ckp-pathname (buffer)
+  (let ((buffer-pn (buffer-pathname buffer)))
+    (if buffer-pn
+	(pathname (format nil
+			  (value auto-save-filename-pattern)
+			  (directory-namestring buffer-pn)
+			  (file-namestring buffer-pn))))))
+
+
+
+
+;;;; Buffer-level Checkpoint Routines
+
+;;;
+;;; write-checkpoint-file -- Internal
+;;;
+;;; Does the low-level write of the checkpoint.  Returns T if it succeeds
+;;; and NIL if it fails.  Echoes winnage or lossage to the luser.
+;;;
+(defun write-checkpoint-file (pathname buffer)
+  (let ((ns (namestring pathname)))
+    (cond ((hemlock-ext:file-writable pathname)
+	   (message "Saving ~A" ns)
+	   (handler-case (progn
+			   (write-file (buffer-region buffer) pathname
+				       :keep-backup nil
+				       :access #o600) ;read/write by owner.
+			   t)
+	     (error (condition)
+	       (loud-message "Auto Save failure: ~A" condition)
+	       nil)))
+	  (t
+	   (message "Can't write ~A" ns)
+	   nil))))
+
+
+;;;
+;;; To save, or not to save... and to save as what?
+;;;
+;;; First, make-buffer-ckp-pathname is called. It will return either NIL or
+;;; a pathname formed by using buffer-pathname in conjunction with the hvar
+;;; "Auto Save Filename Pattern".  If there isn't an associated pathname or
+;;; make-buffer-ckp-pathname returns NIL, then we use the pathname we used
+;;; the last time we checkpointed the buffer.  If we've never checkpointed
+;;; the buffer, then we check "Auto Save Pathname Hook".  If it is NIL then
+;;; we turn Save mode off for the buffer, else we funcall the function on
+;;; the hook with the buffer as an argument.  The function on the hook should
+;;; return either NIL or a pathname. If it returns NIL, we toggle Save mode
+;;; off for the buffer;  otherwise, we use the pathname it returned.
+;;;
+
+;;; 
+;;; checkpoint-buffer -- Internal
+;;;
+;;; This functions takes a buffer as its argument and attempts to write a
+;;; checkpoint for that buffer.  See the notes at the beginning of this page
+;;; for how it determines what pathname to use as the checkpoint pathname.
+;;; Note that a checkpoint is not necessarily written -- instead "Save"
+;;; mode may be turned off for the buffer.
+;;;
+(defun checkpoint-buffer (buffer)
+  (let* ((state (get-auto-save-state buffer))
+	 (buffer-ckp-pn (make-buffer-ckp-pathname buffer))
+	 (last-pathname (save-state-pathname state)))
+    (cond (buffer-ckp-pn
+	   (when (write-checkpoint-file buffer-ckp-pn buffer)
+	     (reset-auto-save-state buffer)
+	     (setf (save-state-pathname state) buffer-ckp-pn)
+	     (when (and last-pathname
+			(not (equal last-pathname buffer-ckp-pn))
+			(probe-file last-pathname))
+	       (delete-file last-pathname))))
+	  (last-pathname
+	   (when (write-checkpoint-file last-pathname buffer)
+	     (reset-auto-save-state buffer)))
+	  (t
+	   (let* ((save-pn-hook (value auto-save-pathname-hook))
+		  (new-pn (if save-pn-hook
+			      (funcall save-pn-hook buffer))))
+	     (cond ((or (not new-pn)
+			(zerop (length
+				(the simple-string (namestring new-pn)))))
+		    (setf (buffer-minor-mode buffer "Save") nil))
+		   (t
+		    (when (write-checkpoint-file new-pn buffer)
+		      (reset-auto-save-state buffer)
+		      (setf (save-state-pathname state) new-pn)))))))))
+
+;;;
+;;; checkpoint-all-buffers -- Internal
+;;; 
+;;; This function looks through the buffer list and checkpoints
+;;; each buffer that is in "Save" mode that has been modified since
+;;; its last checkpoint. 
+;;; 
+(defun checkpoint-all-buffers (elapsed-time)
+  (declare (ignore elapsed-time))
+  (dolist (buffer *buffer-list*)
+    (let ((state (get-auto-save-state buffer)))
+      (when (and state
+		 (buffer-modified buffer)
+		 (not (eql
+		       (save-state-last-ckp-signature state)
+		       (buffer-signature buffer))))
+	(checkpoint-buffer buffer)))))
+
+
+
+;;;; Random Hooks: cleanup, buffer-modified, change-save-freq.
+
+;;;
+;;; cleanup-checkpoint -- Internal
+;;; 
+;;; Cleans up checkpoint file for a given buffer if Auto Save Cleanup
+;;; Checkpoints is non-NIL.  This is called via "Write File Hook"
+;;; 
+(defun cleanup-checkpoint (buffer)
+  (let ((ckp-pathname (get-checkpoint-pathname buffer)))
+    (when (and (value auto-save-cleanup-checkpoints)
+	       ckp-pathname
+	       (probe-file ckp-pathname))
+      (delete-file ckp-pathname))))
+
+(add-hook write-file-hook 'cleanup-checkpoint)
+
+;;;
+;;; notice-buffer-modified -- Internal
+;;;
+;;; This function is called on "Buffer Modified Hook" to reset
+;;; the Auto Save state.  It makes the buffer look like it has just
+;;; been checkpointed.
+;;;
+(defun notice-buffer-modified (buffer flag)
+  ;; we care only when the flag has gone to false
+  (when (not flag)
+    (reset-auto-save-state buffer)))
+
+(add-hook buffer-modified-hook 'notice-buffer-modified)
+
+;;;
+;;; change-save-frequency -- Internal
+;;; 
+;;; This keeps us scheduled at the proper interval.  It is stuck on
+;;; the hook list for the hvar "Auto Save Checkpoint Frequency" and
+;;; is therefore called whenever this value is set.
+;;; 
+(defun change-save-frequency (name kind where new-value)
+  (declare (ignore name kind where))
+  (setq new-value (truncate new-value))
+  (remove-scheduled-event 'checkpoint-all-buffers)
+  (when (and new-value
+	     (plusp new-value))
+    (schedule-event new-value 'checkpoint-all-buffers t)))
+
+
+;;; "Save" mode is in "Default Modes", so turn it off in these modes.
+;;;
+
+(defun interactive-modes (buffer on)
+  (when on (setf (buffer-minor-mode buffer "Save") nil)))
+
+#+GBNIL (add-hook typescript-mode-hook 'interactive-modes)
+#+GBNIL (add-hook eval-mode-hook 'interactive-modes)
+
+
+
+
+;;;; Key Count Routine for Input Hook
+
+;;; 
+;;; auto-save-count-keys -- Internal
+;;;
+;;; This function sits on the Input Hook to eat cycles.  If the current
+;;; buffer is not in Save mode or if the current buffer is the echo area
+;;; buffer, it does nothing.  Otherwise, we check to see if we have exceeded
+;;; the key count threshold (and write a checkpoint if we have) and we
+;;; increment the key count for the buffer.
+;;;
+(defun auto-save-count-keys ()
+  #.*fast*
+  (let ((buffer (current-buffer)))
+    (unless (eq buffer *echo-area-buffer*)
+      (let ((state (value auto-save-state))
+	    (threshold (value auto-save-key-count-threshold)))
+	(when (and state threshold)
+	  (let ((signature (buffer-signature buffer)))
+	    (declare (fixnum signature))
+	    (when (not (eql signature
+			    (save-state-key-signature state)))
+	      ;; see if we exceeded threshold last time...
+	      (when (>= (save-state-key-count state)
+			(the fixnum threshold))
+		(checkpoint-buffer buffer))
+	      ;; update state
+	      (setf (save-state-key-signature state) signature)
+	      (incf (save-state-key-count state)))))))))
+
+(add-hook input-hook 'auto-save-count-keys)
+
+
+
+;;;; Save Mode Hemlock Variables
+
+;;; 
+;;; Hemlock variables/parameters for Auto-Save Mode
+;;;
+
+(defhvar "Auto Save Filename Pattern"
+  "This control-string is used with format to make the filename of the
+  checkpoint file.  Format is called with two arguments, the first
+  being the directory namestring and the second being the file
+  namestring of the default buffer pathname."
+  :value "~A~A.CKP")
+
+(defhvar "Auto Save Key Count Threshold"
+  "This value is the number of destructive/modifying keystrokes that will
+  automatically trigger an checkpoint.  This value may be NIL to turn this
+  feature off."
+  :value 256)
+
+(defhvar "Auto Save Cleanup Checkpoints"
+  "This variable controls whether or not \"Save\" mode will delete the
+  checkpoint file for a buffer after it is saved.  If this value is
+  non-NIL then cleanup will occur."
+  :value t)
+
+(defhvar "Auto Save Checkpoint Frequency"
+  "All modified buffers (in \"Save\" mode) will be checkpointed after this
+  amount of time (in seconds).  This value may be NIL (or non-positive)
+  to turn this feature off."
+  :value (* 2 60)
+  :hooks '(change-save-frequency))
+
+(defhvar "Auto Save State"
+  "Shadow magic.  This variable is seen when in buffers that are not
+  in \"Save\" mode.  Do not change this value or you will lose."
+  :value nil)
+
+
+
+;;;; "Save" mode
+
+(defcommand "Auto Save Mode" (p)
+  "If the argument is zero or negative, turn \"Save\" mode off.  If it
+  is positive turn \"Save\" mode on.  If there is no argument, toggle
+  \"Save\" mode in the current buffer.  When in \"Save\" mode, files
+  are automatically checkpointed every \"Auto Save Checkpoint Frequency\"
+  seconds or every \"Auto Save Key Count Threshold\" destructive
+  keystrokes.  If there is a pathname associated with the buffer, the
+  filename used for the checkpoint file is controlled by the hvar \"Auto
+  Save Filename Pattern\".  Otherwise, the hook \"Auto Save Pathname Hook\"
+  is used to generate a checkpoint pathname.  If the buffer's pathname
+  changes between checkpoints, the checkpoint file will be written under
+  the new name and the old checkpoint file will be deleted if it exists.
+  When a buffer is written out, the checkpoint will be deleted if the
+  hvar \"Auto Save Cleanup Checkpoints\" is non-NIL."
+  "Turn on, turn off, or toggle \"Save\" mode in the current buffer."
+  (setf (buffer-minor-mode (current-buffer) "Save")
+	(if p
+	    (plusp p)
+	    (not (buffer-minor-mode (current-buffer) "Save")))))
+
+(defun setup-auto-save-mode (buffer)
+  (let* ((signature (buffer-signature buffer))
+	 (state (make-auto-save-state
+		 :buffer buffer
+		 :key-signature (the fixnum signature)
+		 :last-ckp-signature (the fixnum signature))))
+    ;; shadow the global value with a variable which will
+    ;; contain our per buffer state information
+    (defhvar "Auto Save State"
+      "This is the \"Save\" mode state information for this buffer."
+      :buffer buffer
+      :value state)))
+
+(defun cleanup-auto-save-mode (buffer)
+  (delete-variable 'auto-save-state
+		   :buffer buffer))
+
+(defmode "Save"
+  :setup-function 'setup-auto-save-mode
+  :cleanup-function 'cleanup-auto-save-mode)
Index: /branches/ide-1.0/ccl/hemlock/src/archive/bufed.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/bufed.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/bufed.lisp	(revision 6569)
@@ -0,0 +1,301 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains Bufed (Buffer Editing) code.
+;;;
+
+(in-package :hemlock)
+
+
+
+
+;;;; Representation of existing buffers.
+
+;;; This is the array of buffers in the bufed buffer.  Each element is a cons,
+;;; where the CAR is the buffer, and the CDR indicates whether the buffer
+;;; should be deleted (t deleted, nil don't).
+;;;
+(defvar *bufed-buffers* nil)
+(defvar *bufed-buffers-end* nil)
+;;;
+(defmacro bufed-buffer (x) `(car ,x))
+(defmacro bufed-buffer-deleted (x) `(cdr ,x))
+(defmacro make-bufed-buffer (buffer) `(list ,buffer))
+
+
+;;; This is the bufed buffer if it exists.
+;;;
+(defvar *bufed-buffer* nil)
+
+;;; This is the cleanup method for deleting *bufed-buffer*.
+;;;
+(defun delete-bufed-buffers (buffer)
+  (when (eq buffer *bufed-buffer*)
+    (setf *bufed-buffer* nil)
+    (setf *bufed-buffers* nil)))
+
+
+
+
+;;;; Commands.
+
+(defmode "Bufed" :major-p t
+  :documentation
+  "Bufed allows the user to quickly save, goto, delete, etc., his buffers.")
+
+(defhvar "Virtual Buffer Deletion"
+  "When set, \"Bufed Delete\" marks a buffer for deletion instead of immediately
+   deleting it."
+  :value t)
+
+(defhvar "Bufed Delete Confirm"
+  "When set, \"Bufed\" commands that actually delete buffers ask for
+   confirmation before taking action."
+  :value t)
+
+(defcommand "Bufed Delete" (p)
+  "Delete the buffer.
+   Any windows displaying this buffer will display some other buffer."
+  "Delete the buffer indicated by the current line.  Any windows displaying this
+   buffer will display some other buffer."
+  (declare (ignore p))
+  (let* ((point (current-point))
+	 (buf-info (array-element-from-mark point *bufed-buffers*)))
+    (if (and (not (value virtual-buffer-deletion))
+	     (or (not (value bufed-delete-confirm))
+		 (prompt-for-y-or-n :prompt "Delete buffer? " :default t
+				    :must-exist t :default-string "Y")))
+	(delete-bufed-buffer (bufed-buffer buf-info))
+	(with-writable-buffer (*bufed-buffer*)
+	  (setf (bufed-buffer-deleted buf-info) t)
+	  (with-mark ((point point))
+	    (setf (next-character (line-start point)) #\D))))))
+
+(defcommand "Bufed Undelete" (p)
+  "Undelete the buffer.
+   Any windows displaying this buffer will display some other buffer."
+  "Undelete the buffer.  Any windows displaying this buffer will display some
+   other buffer."
+  (declare (ignore p))
+  (with-writable-buffer (*bufed-buffer*)
+    (setf (bufed-buffer-deleted (array-element-from-mark
+				 (current-point) *bufed-buffers*))
+	  nil)
+    (with-mark ((point (current-point)))
+      (setf (next-character (line-start point)) #\space))))
+
+(defcommand "Bufed Expunge" (p)
+  "Expunge buffers marked for deletion."
+  "Expunge buffers marked for deletion."
+  (declare (ignore p))
+  (expunge-bufed-buffers))
+
+(defcommand "Bufed Quit" (p)
+  "Kill the bufed buffer, expunging any buffer marked for deletion."
+  "Kill the bufed buffer, expunging any buffer marked for deletion."
+  (declare (ignore p))
+  (expunge-bufed-buffers)
+  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
+
+;;; EXPUNGE-BUFED-BUFFERS deletes the marked buffers in the bufed buffer,
+;;; signalling an error if the current buffer is not the bufed buffer.  This
+;;; returns t if it deletes some buffer, otherwise nil.  We build a list of
+;;; buffers before deleting any because the BUFED-DELETE-HOOK moves elements
+;;; around in *bufed-buffers*.
+;;;
+(defun expunge-bufed-buffers ()
+  (unless (eq *bufed-buffer* (current-buffer))
+    (editor-error "Not in the Bufed buffer."))
+  (let (buffers)
+    (dotimes (i *bufed-buffers-end*)
+      (let ((buf-info (svref *bufed-buffers* i)))
+	(when (bufed-buffer-deleted buf-info)
+	  (push (bufed-buffer buf-info) buffers))))
+    (if (and buffers
+	     (or (not (value bufed-delete-confirm))
+		 (prompt-for-y-or-n :prompt "Delete buffers? " :default t
+				    :must-exist t :default-string "Y")))
+	(dolist (b buffers t) (delete-bufed-buffer b)))))
+
+(defun delete-bufed-buffer (buf)
+  (when (and (buffer-modified buf)
+	     (prompt-for-y-or-n :prompt (list "~A is modified.  Save it first? "
+					      (buffer-name buf))))
+    (save-file-command nil buf))
+  (delete-buffer-if-possible buf))
+
+
+(defcommand "Bufed Goto" (p)
+  "Change to the buffer."
+  "Change to the buffer."
+  (declare (ignore p))
+  (change-to-buffer
+   (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
+
+(defcommand "Bufed Goto and Quit" (p)
+  "Change to the buffer quitting Bufed.
+   This supplies a function for \"Generic Pointer Up\" which is a no-op."
+  "Change to the buffer quitting Bufed."
+  (declare (ignore p))
+  (expunge-bufed-buffers)
+  (point-to-here-command nil)
+  (change-to-buffer
+   (bufed-buffer (array-element-from-pointer-pos *bufed-buffers*
+		 "No buffer on that line.")))
+  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))
+  (supply-generic-pointer-up-function #'(lambda () nil)))
+
+(defcommand "Bufed Save File" (p)
+  "Save the buffer."
+  "Save the buffer."
+  (declare (ignore p))
+  (save-file-command
+   nil
+   (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
+
+(defcommand "Bufed" (p)
+  "Creates a list of buffers in a buffer supporting operations such as deletion
+   and selection.  If there already is a bufed buffer, just go to it."
+  "Creates a list of buffers in a buffer supporting operations such as deletion
+   and selection.  If there already is a bufed buffer, just go to it."
+  (declare (ignore p))
+  (let ((buf (or *bufed-buffer*
+		 (make-buffer "Bufed" :modes '("Bufed")
+			      :delete-hook (list #'delete-bufed-buffers)))))
+
+    (unless *bufed-buffer*
+      (setf *bufed-buffer* buf)
+      (setf *bufed-buffers-end*
+	    ;; -1 echo, -1 bufed.
+	    (- (length (the list *buffer-list*)) 2))
+      (setf *bufed-buffers* (make-array *bufed-buffers-end*))
+      (setf (buffer-writable buf) t)
+      (with-output-to-mark (s (buffer-point buf))
+	(let ((i 0))
+	  (do-strings (n b *buffer-names*)
+	    (declare (simple-string n))
+	    (unless (or (eq b *echo-area-buffer*)
+			(eq b buf))
+	      (bufed-write-line b n s)
+	      (setf (svref *bufed-buffers* i) (make-bufed-buffer b))
+	      (incf i)))))
+      (setf (buffer-writable buf) nil)
+      (setf (buffer-modified buf) nil)
+      (let ((fields (buffer-modeline-fields *bufed-buffer*)))
+	(setf (cdr (last fields))
+	      (list (or (modeline-field :bufed-cmds)
+			(make-modeline-field
+			 :name :bufed-cmds :width 18
+			 :function
+			 #'(lambda (buffer window)
+			     (declare (ignore buffer window))
+			     "  Type ? for help.")))))
+	(setf (buffer-modeline-fields *bufed-buffer*) fields))
+      (buffer-start (buffer-point buf)))
+    (change-to-buffer buf)))
+
+(defun bufed-write-line (buffer name s
+		         &optional (buffer-pathname (buffer-pathname buffer)))
+  (let ((modified (buffer-modified buffer)))
+    (write-string (if modified " *" "  ") s)
+    (if buffer-pathname
+	(format s "~A  ~A~:[~50T~A~;~]~%"
+		(file-namestring buffer-pathname)
+		(directory-namestring buffer-pathname)
+		(string= (pathname-to-buffer-name buffer-pathname) name)
+		name)
+	(write-line name s))))
+
+
+(defcommand "Bufed Help" (p)
+  "Show this help."
+  "Show this help."
+  (declare (ignore p))
+  (describe-mode-command nil "Bufed"))
+
+
+
+
+;;;; Maintenance hooks.
+
+(eval-when (:compile-toplevel :execute)
+(defmacro with-bufed-point ((point buffer &optional pos) &rest body)
+  (let ((pos (or pos (gensym))))
+    `(when (and *bufed-buffers*
+		(not (eq *bufed-buffer* ,buffer))
+		(not (eq *echo-area-buffer* ,buffer)))
+       (let ((,pos (position ,buffer *bufed-buffers* :key #'car
+			     :test #'eq :end *bufed-buffers-end*)))
+	 (unless ,pos (error "Unknown Bufed buffer."))
+	 (let ((,point (buffer-point *bufed-buffer*)))
+	   (unless (line-offset (buffer-start ,point) ,pos 0)
+	     (error "Bufed buffer not displayed?"))
+	   (with-writable-buffer (*bufed-buffer*) ,@body))))))
+) ;eval-when
+
+
+(defun bufed-modified-hook (buffer modified)
+  (with-bufed-point (point buffer)
+    (setf (next-character (mark-after point)) (if modified #\* #\space))))
+;;;
+(add-hook buffer-modified-hook 'bufed-modified-hook)
+
+(defun bufed-make-hook (buffer)
+  (declare (ignore buffer))
+  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
+;;;
+(add-hook make-buffer-hook 'bufed-make-hook)
+
+(defun bufed-delete-hook (buffer)
+  (with-bufed-point (point buffer pos)
+    (with-mark ((temp point :left-inserting))
+      (line-offset temp 1)
+      (delete-region (region point temp)))
+    (let ((len-1 (1- *bufed-buffers-end*)))
+      (replace *bufed-buffers* *bufed-buffers*
+	       :start1 pos :end1 len-1
+	       :start2 (1+ pos) :end1 *bufed-buffers-end*)
+      (setf (svref *bufed-buffers* len-1) nil)
+      (setf *bufed-buffers-end* len-1))))
+;;;
+(add-hook delete-buffer-hook 'bufed-delete-hook)
+
+(defun bufed-name-hook (buffer name)
+  (with-bufed-point (point buffer)
+    (with-mark ((temp point :left-inserting))
+      (line-offset temp 1)
+      (delete-region (region point temp)))
+    (with-output-to-mark (s point)
+      (bufed-write-line buffer name s))))
+;;;
+(add-hook buffer-name-hook 'bufed-name-hook)
+
+(defun bufed-pathname-hook (buffer pathname)
+  (with-bufed-point (point buffer)
+    (with-mark ((temp point :left-inserting))
+      (line-offset temp 1)
+      (delete-region (region point temp)))
+    (with-output-to-mark (s point)
+      (bufed-write-line buffer (buffer-name buffer) s pathname))))
+;;;
+(add-hook buffer-pathname-hook 'bufed-pathname-hook)
+
+
+
+;;;; Utilities
+
+(defun array-element-from-pointer-pos (vector &optional
+					      (error-msg "Invalid line."))
+  (multiple-value-bind (x y window) (last-key-event-cursorpos)
+    (declare (ignore x window))
+    (when (>= y (length vector))
+      (editor-error error-msg))
+    (svref vector y)))
Index: /branches/ide-1.0/ccl/hemlock/src/archive/group.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/group.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/group.lisp	(revision 6569)
@@ -0,0 +1,238 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;; File group stuff for Hemlock.
+;;; Written by Skef Wholey and Rob MacLachlan.
+;;;
+;;;    The "Compile Group" and "List Compile Group" commands in lispeval
+;;;    also know about groups.
+;;;
+;;; This file provides Hemlock commands for manipulating groups of files
+;;; that make up a larger system.  A file group is a set of files whose
+;;; names are listed in some other file.  At any given time one group of
+;;; files is the Active group.  The Select Group command makes a group the
+;;; Active group, prompting for the name of a definition file if the group
+;;; has not been selected before.  Once a group has been selected once, the
+;;; name of the definition file associated with that group is retained.  If
+;;; one wishes to change the name of the definition file after a group has
+;;; been selected, one should call Select Group with a prefix argument.
+
+(in-package :hemlock)
+
+(defvar *file-groups* (make-string-table)
+  "A string table of file groups.")
+
+(defvar *active-file-group* ()
+  "The list of files in the currently active group.")
+
+(defvar *active-file-group-name* ()
+  "The name of the currently active group.")
+
+
+
+
+;;;; Selecting the active group.
+
+(defcommand "Select Group" (p)
+  "Makes a group the active group.  With a prefix argument, changes the
+  definition file associated with the group."
+  "Makes a group the active group."
+  (let* ((group-name
+	  (prompt-for-keyword
+	   (list *file-groups*)
+	   :must-exist nil
+	   :prompt "Select Group: "
+	   :help
+	   "Type the name of the file group you wish to become the active group."))
+	 (old (getstring group-name *file-groups*))
+	 (pathname
+	  (if (and old (not p))
+	      old
+	      (prompt-for-file :must-exist t
+			       :prompt "From File: "
+			       :default (merge-pathnames
+					 (make-pathname
+					  :name group-name
+					  :type "upd")
+					 (value pathname-defaults))))))
+    (setq *active-file-group-name* group-name)
+    (setq *active-file-group* (nreverse (read-file-group pathname nil)))
+    (setf (getstring group-name *file-groups*) pathname)))
+
+
+;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames
+;;; of the files named in that file.  This guy knows about @@ indirection and
+;;; ignores empty lines and lines that begin with @ but not @@.  A simpler
+;;; scheme could be used for non-Spice implementations, but all this hair is
+;;; probably useful, so Update format may as well be a standard for this sort
+;;; of thing.
+;;;
+(defun read-file-group (pathname tail)
+  (with-open-file (file pathname)
+    (do* ((name (read-line file nil nil) (read-line file nil nil))
+	  (length (if name (length name)) (if name (length name))))
+	 ((null name) tail)
+      (declare (type (or simple-string null) name))
+      (cond ((zerop length))
+	    ((char= (char name 0) #\@)
+	     (when (and (> length 1) (char= (char name 1) #\@))
+	       (setq tail (read-file-group
+			   (merge-pathnames (subseq name 2)
+					    pathname)
+			   tail))))
+	    (t
+	     (push (merge-pathnames (pathname name) pathname) tail))))))
+
+
+
+
+;;;; DO-ACTIVE-GROUP.
+
+(defhvar "Group Find File"
+  "If true, group commands use \"Find File\" to read files, otherwise
+  non-resident files are read into the \"Group Search\" buffer."
+  :value nil)
+
+(defhvar "Group Save File Confirm"
+  "If true, then the group commands will ask for confirmation before saving
+  a modified file." :value t)
+
+(defmacro do-active-group (&rest forms)
+  "This iterates over the active file group executing forms once for each
+   file.  When forms are executed, the file will be in the current buffer,
+   and the point will be at the start of the file."
+  (let ((n-buf (gensym))
+	(n-start-buf (gensym))
+	(n-save (gensym)))
+    `(progn
+       (unless *active-file-group*
+	 (editor-error "There is no active file group."))
+
+       (let ((,n-start-buf (current-buffer))
+	     (,n-buf nil))
+	 (unwind-protect
+	     (dolist (file *active-file-group*)
+	       (catch 'file-not-found
+		 (setq ,n-buf (group-read-file file ,n-buf))
+		 (with-mark ((,n-save (current-point) :right-inserting))
+		   (unwind-protect
+		       (progn
+			 (buffer-start (current-point))
+			 ,@forms)
+		     (move-mark (current-point) ,n-save)))
+		 (group-save-file)))
+	   (if (member ,n-start-buf *buffer-list*)
+	       (setf (current-buffer) ,n-start-buf
+		     (window-buffer (current-window)) ,n-start-buf)
+	       (editor-error "Original buffer deleted!")))))))
+
+;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP.
+;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't
+;;; already been read, to get files in, and then we delete the buffer if it is
+;;; newly created and "Group Find File" is false.  This lets FIND-FILE-BUFFER
+;;; do all the work.  We don't actually use the "Find File" command, so the
+;;; buffer history isn't affected.
+;;;
+;;; Search-Buffer is any temporary search buffer left over from the last file
+;;; that we want deleted.  We don't do the deletion if the buffer is modified.
+;;;
+(defun group-read-file (name search-buffer)
+  (unless (probe-file name)
+    (message "File ~A not found." name)
+    (throw 'file-not-found nil))
+  (multiple-value-bind (buffer created-p)
+		       (find-file-buffer name)
+    (setf (current-buffer) buffer)
+    (setf (window-buffer (current-window)) buffer)
+
+    (when (and search-buffer (not (buffer-modified search-buffer)))
+      (dolist (w (buffer-windows search-buffer))
+	(setf (window-buffer w) (current-buffer)))
+      (delete-buffer search-buffer))
+
+    (if (and created-p (not (value group-find-file)))
+	(current-buffer) nil)))
+
+;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP.
+;;;
+(defun group-save-file ()
+  (let* ((buffer (current-buffer))
+	 (pn (buffer-pathname buffer))
+	 (name (namestring pn)))
+    (when (and (buffer-modified buffer)
+	       (or (not (value group-save-file-confirm))
+		   (prompt-for-y-or-n
+		    :prompt (list "Save changes in ~A? " name)
+		    :default t)))
+      (save-file-command ()))))
+
+
+
+
+;;;; Searching and Replacing commands.
+
+(defcommand "Group Search" (p)
+  "Searches the active group for a specified string, which is prompted for."
+  "Searches the active group for a specified string."
+  (declare (ignore p))
+  (let ((string (prompt-for-string :prompt "Group Search: "
+				   :help "String to search for in active file group"
+				   :default *last-search-string*)))
+    (get-search-pattern string :forward)
+    (do-active-group
+     (do ((won (find-pattern (current-point) *last-search-pattern*)
+	       (find-pattern (current-point) *last-search-pattern*)))
+	 ((not won))
+       (character-offset (current-point) won)
+       (command-case
+	   (:prompt "Group Search: "
+		    :help "Type a character indicating the action to perform."
+		    :change-window nil)
+	 (:no "Search for the next occurrence.")
+	 (:do-all "Go on to the next file in the group."
+	  (return nil))
+	 ((:exit :yes) "Exit the search."
+	  (return-from group-search-command))
+	 (:recursive-edit "Enter a recursive edit."
+	  (do-recursive-edit)
+	  (get-search-pattern string :forward)))))
+    (message "All files in group ~S searched." *active-file-group-name*)))
+
+(defcommand "Group Replace" (p)
+  "Replaces one string with another in the active file group."
+  "Replaces one string with another in the active file group."
+  (declare (ignore p))
+  (let* ((target (prompt-for-string :prompt "Group Replace: "
+				    :help "Target string"
+				    :default *last-search-string*))
+	 (replacement (prompt-for-string :prompt "With: "
+					 :help "Replacement string")))
+    (do-active-group
+     (query-replace-function nil target replacement
+			     "Group Replace on previous file" t))
+    (message "Replacement done in all files in group ~S."
+	     *active-file-group-name*)))
+
+(defcommand "Group Query Replace" (p)
+  "Query Replace for the active file group."
+  "Query Replace for the active file group."
+  (declare (ignore p))
+  (let ((target (prompt-for-string :prompt "Group Query Replace: "
+				   :help "Target string"
+				   :default *last-search-string*)))
+    (let ((replacement (prompt-for-string :prompt "With: "
+					  :help "Replacement string")))
+      (do-active-group
+       (unless (query-replace-function
+		nil target replacement "Group Query Replace on previous file")
+	 (return nil)))
+      (message "Replacement done in all files in group ~S."
+	       *active-file-group-name*))))
Index: /branches/ide-1.0/ccl/hemlock/src/archive/highlight.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/highlight.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/highlight.lisp	(revision 6569)
@@ -0,0 +1,211 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;; Highlighting paren and some other good stuff.
+;;;
+;;; Written by Bill Chiles and Jim Healy.
+;;;
+
+(in-package :hemlock)
+
+
+
+
+;;;; Open parens.
+
+(defhvar "Highlight Open Parens"
+  "When non-nil, causes open parens to be displayed in a different font when
+   the cursor is directly to the right of the corresponding close paren."
+  :value nil)
+
+(defhvar "Open Paren Finder Function"
+  "Should be a function that takes a mark for input and returns either NIL
+   if the mark is not after a close paren, or two (temporary) marks
+   surrounding the corresponding open paren."
+  :value 'lisp-open-paren-finder-function)
+
+
+(defvar *open-paren-font-marks* nil
+  "The pair of font-marks surrounding the currently highlighted open-
+   paren or nil if there isn't one.")
+
+(defvar *open-paren-highlight-font* 2
+  "The index into the font-map for the open paren highlighting font.")
+
+
+;;; MAYBE-HIGHLIGHT-OPEN-PARENS is a redisplay hook that matches parens by
+;;; highlighting the corresponding open-paren after a close-paren is
+;;; typed.
+;;; 
+(defun maybe-highlight-open-parens (window)
+  (declare (ignore window))
+  (when (value highlight-open-parens)
+    (if (and (value highlight-active-region) (region-active-p))
+	(kill-open-paren-font-marks)
+	(multiple-value-bind
+	    (start end)
+	    (funcall (value open-paren-finder-function)
+		     (current-point))
+	  (if (and start end)
+	      (set-open-paren-font-marks start end)
+	      (kill-open-paren-font-marks))))))
+;;;
+(add-hook redisplay-hook 'maybe-highlight-open-parens)
+
+(defun set-open-paren-font-marks (start end)
+  (if *open-paren-font-marks*
+      (flet ((maybe-move (dst src)
+	       (unless (mark= dst src)
+		 (move-font-mark dst src))))
+	(declare (inline maybe-move))
+	(maybe-move (region-start *open-paren-font-marks*) start)
+	(maybe-move (region-end *open-paren-font-marks*) end))
+      (let ((line (mark-line start)))
+	(setf *open-paren-font-marks*
+	      (region
+	       (font-mark line (mark-charpos start)
+			  *open-paren-highlight-font*)
+	       (font-mark line (mark-charpos end) 0))))))
+
+(defun kill-open-paren-font-marks ()
+  (when *open-paren-font-marks*
+    (delete-font-mark (region-start *open-paren-font-marks*))
+    (delete-font-mark (region-end *open-paren-font-marks*))
+    (setf *open-paren-font-marks* nil)))
+
+
+
+
+
+;;;; Active regions.
+
+(defvar *active-region-font-marks* nil)
+(defvar *active-region-highlight-font* 3
+  "The index into the font-map for the active region highlighting font.")
+
+
+;;; HIGHLIGHT-ACTIVE-REGION is a redisplay hook for active regions.
+;;; Since it is too hard to know how the region may have changed when it is
+;;; active and already highlighted, if it does not check out to being exactly
+;;; the same, we just delete all the font marks and make new ones.  When
+;;; the current window is the echo area window, just pretend everything is
+;;; okay; this keeps the region highlighted while we're in there.
+;;;
+(defun highlight-active-region (window)
+  (unless (eq window *echo-area-window*)
+    (when (value highlight-active-region)
+      (cond ((region-active-p)
+	     (cond ((not *active-region-font-marks*)
+		    (set-active-region-font-marks))
+		   ((check-active-region-font-marks))
+		   (t (kill-active-region-font-marks)
+		      (set-active-region-font-marks))))
+	    (*active-region-font-marks*
+	     (kill-active-region-font-marks))))))
+;;;
+(add-hook redisplay-hook 'highlight-active-region)
+
+(defun set-active-region-font-marks ()
+  (flet ((stash-a-mark (m &optional (font *active-region-highlight-font*))
+	   (push (font-mark (mark-line m) (mark-charpos m) font)
+		 *active-region-font-marks*)))
+    (let* ((region (current-region nil nil))
+	   (start (region-start region))
+	   (end (region-end region)))
+      (with-mark ((mark start))
+	(unless (mark= mark end)
+	  (loop
+	    (stash-a-mark mark)
+	    (unless (line-offset mark 1 0) (return))
+	    (when (mark>= mark end) (return)))
+	  (unless (start-line-p end) (stash-a-mark end 0))))))
+  (setf *active-region-font-marks* (nreverse *active-region-font-marks*)))
+
+(defun kill-active-region-font-marks ()
+  (dolist (m *active-region-font-marks*)
+    (delete-font-mark m))
+  (setf *active-region-font-marks* nil))
+
+;;; CHECK-ACTIVE-REGION-FONT-MARKS returns t if the current region is the same
+;;; as that what is highlighted on the screen.  This assumes
+;;; *active-region-font-marks* is non-nil.  At the very beginning, our start
+;;; mark must not be at the end; it must be at the first font mark; and the
+;;; font marks must be in the current buffer.  We don't make font marks if the
+;;; start is at the end, so if this is the case, then they just moved together.
+;;; We return nil in this case to kill all the font marks and make new ones, but
+;;; no new ones will be made.
+;;;
+;;; Sometimes we hack the font marks list and return t because we can easily
+;;; adjust the highlighting to be correct.  This keeps all the font marks from
+;;; being killed and re-established.  In the loop, if there are no more font
+;;; marks, we either ended a region already highlighted on the next line down,
+;;; or we have to revamp the font marks.  Before returning here, we see if the
+;;; region ends one more line down at the beginning of the line.  If this is
+;;; true, then the user is simply doing "Next Line" at the beginning of the
+;;; line.
+;;;
+;;; Each time through the loop we look at the top font mark, move our roving
+;;; mark down one line, and see if they compare.  If they are not equal, the
+;;; region may still be the same as that highlighted on the screen.  If this
+;;; is the last font mark, not at the beginning of the line, and it is at the
+;;; region's end, then this last font mark is in the middle of a line somewhere
+;;; changing the font from the highlighting font to the default font.  Return
+;;; t.
+;;;
+;;; If our roving mark is not at the current font mark, but it is at or after
+;;; the end of the active region, then the end of the active region has moved
+;;; before its previous location.
+;;;
+;;; Otherwise, move on to the next font mark.
+;;;
+;;; If our roving mark never moved onto a next line, then the buffer ends on the
+;;; previous line, and the last font mark changes from the highlighting font to
+;;; the default font.
+;;;
+(defun check-active-region-font-marks ()
+  (let* ((region (current-region nil nil))
+	 (end (region-end region)))
+    (with-mark ((mark (region-start region)))
+      (let ((first-active-mark (car *active-region-font-marks*))
+	    (last-active-mark (last *active-region-font-marks*)))
+	(if (and (mark/= mark end)
+		 (eq (current-buffer)
+		     (line-buffer (mark-line first-active-mark)))
+		 (mark= first-active-mark mark))
+	    (let ((marks (cdr *active-region-font-marks*)))
+	      (loop
+		(unless marks
+		  (let ((res (and (line-offset mark 1 0)
+				  (mark= mark end))))
+		    (when (and (not res)
+			       (line-offset mark 1 0)
+			       (mark= mark end)
+			       (start-line-p (car last-active-mark)))
+		      (setf (cdr last-active-mark)
+			    (list (font-mark (line-previous (mark-line mark))
+					     0
+					     *active-region-highlight-font*)))
+		      (return t))
+		    (return res)))
+		(let ((fmark (car marks)))
+		  (if (line-offset mark 1 0)
+		      (cond ((mark/= mark fmark)
+			     (return (and (not (cdr marks))
+					  (not (start-line-p fmark))
+					  (mark= fmark end))))
+			    ((mark>= mark end)
+			     (return nil))
+			    (t (setf marks (cdr marks))))
+
+		      (return (and (not (cdr marks))
+				   (not (start-line-p fmark))
+				   (mark= fmark end))))))))))))
+
Index: /branches/ide-1.0/ccl/hemlock/src/archive/lisp-lib.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/lisp-lib.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/lisp-lib.lisp	(revision 6569)
@@ -0,0 +1,175 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains code to peruse the CMU Common Lisp library of hacks.
+;;;
+;;; Written by Blaine Burks.
+;;;
+
+(in-package :hemlock)
+
+
+(defmode "Lisp-Lib" :major-p t)
+
+;;; The library should be in *lisp-library-directory*
+
+(defvar *lisp-library-directory*  "/afs/cs.cmu.edu/project/clisp/library/")
+
+(defvar *selected-library-buffer* nil)
+
+
+
+;;;; Commands.
+
+(defcommand "Lisp Library" (p)
+  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
+  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
+  (declare (ignore p))
+  (when (not (and *selected-library-buffer*
+		  (member *selected-library-buffer* *buffer-list*)))
+    (when (getstring "Lisp Library" *buffer-names*)
+      (editor-error "There is already a buffer named \"Lisp Library\"."))
+    (setf *selected-library-buffer*
+	  (make-buffer "Lisp Library" :modes '("Lisp-Lib")))
+    (message "Groveling library ...")
+    (let ((lib-directory (directory *lisp-library-directory*))
+	  (lib-entries ()))
+      (with-output-to-mark (s (buffer-point *selected-library-buffer*))
+	(dolist (lib-spec lib-directory)
+	  (let* ((path-parts (pathname-directory lib-spec))
+		 (last (elt path-parts (1- (length path-parts))))
+		 (raw-pathname (merge-pathnames last lib-spec)))
+	    (when (and (directoryp lib-spec)
+		       (probe-file (merge-pathnames
+				    (make-pathname :type "catalog")
+				    raw-pathname)))
+	      (push raw-pathname lib-entries)
+	      (format s "~d~%" last)))))
+      (defhvar "Library Entries"
+	"Holds a list of library entries for the 'Lisp Library' buffer"
+	:buffer *selected-library-buffer*
+	:value (coerce (nreverse lib-entries) 'simple-vector))))
+  (setf (buffer-writable *selected-library-buffer*) nil)
+  (setf (buffer-modified *selected-library-buffer*) nil)
+  (change-to-buffer *selected-library-buffer*)
+  (buffer-start (current-point)))
+
+(defcommand "Describe Pointer Library Entry" (p)
+  "Finds the file that describes the lisp library entry indicated by the
+   pointer."
+  "Finds the file that describes the lisp library entry indicated by the
+   pointer."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
+    (editor-error "Not in a Lisp Library buffer."))
+  (describe-library-entry (array-element-from-pointer-pos
+			   (value library-entries) "No entry on current line")))
+
+(defcommand "Describe Library Entry" (p)
+  "Find the file that describes the lisp library entry on the current line."
+  "Find the file that describes the lisp library entry on the current line."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
+    (editor-error "Not in a Lisp Library buffer."))
+  (describe-library-entry (array-element-from-mark (current-point)
+			   (value library-entries) "No entry on current line")))
+
+(defun describe-library-entry (pathname)
+  (let ((lisp-buf (current-buffer))
+	(buffer (view-file-command
+		 nil
+		 (merge-pathnames (make-pathname :type "catalog") pathname))))
+    (push #'(lambda (buffer)
+	      (declare (ignore buffer))
+	      (setf lisp-buf nil))
+	  (buffer-delete-hook lisp-buf))
+    (setf (variable-value 'view-return-function :buffer buffer)
+	  #'(lambda () (if lisp-buf
+			   (change-to-buffer lisp-buf)
+			   (lisp-library-command nil))))))
+
+(defcommand "Load Library Entry" (p)
+  "Loads the current library entry into the current slave."
+  "Loads the current library entry into the current slave."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
+    (editor-error "Not in a Lisp Library buffer."))
+  (string-eval (format nil "(load ~S)"
+		       (namestring (library-entry-load-file nil)))))
+
+(defcommand "Load Pointer Library Entry" (p)
+  "Loads the library entry indicated by the mouse into the current slave."
+  "Loads the library entry indicated by the mouse into the current slave."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
+    (editor-error "Not in a Lisp Library buffer."))
+  (string-eval (format nil "(load ~S)"
+		       (namestring (library-entry-load-file t)))))
+
+(defcommand "Editor Load Library Entry" (p)
+  "Loads the current library entry into the editor Lisp."
+  "Loads the current library entry into the editor Lisp."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
+    (editor-error "Not in a Lisp Library buffer."))
+  (in-lisp (load (library-entry-load-file nil))))
+
+(defcommand "Editor Load Pointer Library Entry" (p)
+  "Loads the library entry indicated by the mouse into the editor Lisp."
+  "Loads the library entry indicated by the mouse into the editor Lisp."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
+    (editor-error "Not in a Lisp Library buffer."))
+  (in-lisp (load (library-entry-load-file t))))
+
+;;; LIBRARY-ENTRY-LOAD-FILE uses the mouse's position or the current point,
+;;; depending on pointerp, to return a file that will load that library entry.
+;;;
+(defun library-entry-load-file (pointerp)
+  (let* ((lib-entries (value library-entries))
+	 (error-msg "No entry on current-line")
+	 (base-name (if pointerp
+			(array-element-from-pointer-pos lib-entries error-msg)
+			(array-element-from-mark (current-point) lib-entries
+						 error-msg)))
+	 (parts (pathname-directory base-name))
+	 (load-name (concatenate 'simple-string
+				 "load-" (elt parts (1- (length parts)))))
+	 (load-pathname (merge-pathnames load-name base-name))
+	 (file-to-load
+	  (or
+	   (probe-file (compile-file-pathname load-pathname))
+	   (probe-file (merge-pathnames (make-pathname :type "fasl")
+					load-pathname))
+	   (probe-file (merge-pathnames (make-pathname :type "lisp")
+					load-pathname))
+	   (probe-file (compile-file-pathname base-name))
+	   (probe-file (merge-pathnames (make-pathname :type "fasl")
+					base-name))
+	   (probe-file (merge-pathnames (make-pathname :type "lisp")
+					base-name)))))
+    (unless file-to-load (editor-error "You'll have to load it yourself."))
+    file-to-load))
+
+(defcommand "Exit Lisp Library" (p)
+  "Exit Lisp-Lib Mode, deleting the buffer when possible."
+  "Exit Lisp-Lib Mode, deleting the buffer when possible."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
+    (editor-error "Not in a Lisp Library buffer."))
+  (delete-buffer-if-possible (getstring "Lisp Library" *buffer-names*)))
+
+(defcommand "Lisp Library Help" (p)
+  "Show this help."
+  "Show this help."
+  (declare (ignore p))
+  (describe-mode-command nil "Lisp-Lib"))
+
Index: /branches/ide-1.0/ccl/hemlock/src/archive/overwrite.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/overwrite.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/overwrite.lisp	(revision 6569)
@@ -0,0 +1,65 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles.
+;;;
+
+(in-package :hemlock)
+
+
+(defmode "Overwrite")
+
+
+(defcommand "Overwrite Mode" (p)
+  "Printing characters overwrite characters instead of pushing them to the right.
+   A positive argument turns Overwrite mode on, while zero or a negative
+   argument turns it off.  With no arguments, it is toggled.  Use C-Q to
+   insert characters normally."
+  "Determine if in Overwrite mode or not and set the mode accordingly."
+  (setf (buffer-minor-mode (current-buffer) "Overwrite")
+	(if p
+	    (plusp p)
+	    (not (buffer-minor-mode (current-buffer) "Overwrite")))))
+
+
+(defcommand "Self Overwrite" (p)
+  "Replace the next character with the last character typed,
+   but insert at end of line.  With prefix argument, do it that many times."
+  "Implements ``Self Overwrite'', calling this function is not meaningful."
+  (let ((char (hemlock-ext:key-event-char *last-key-event-typed*))
+	(point (current-point)))
+    (unless char (editor-error "Can't insert that character."))
+    (do ((n (or p 1) (1- n)))
+	((zerop n))
+      (case (next-character point)
+	(#\tab
+	 (let ((col1 (mark-column point))
+	       (col2 (mark-column (mark-after point))))
+	   (if (= (- col2 col1) 1)
+	       (setf (previous-character point) char)
+	       (insert-character (mark-before point) char))))
+	((#\newline nil) (insert-character point char))
+	(t (setf (next-character point) char)
+	   (mark-after point))))))
+
+
+(defcommand "Overwrite Delete Previous Character" (p)
+  "Replaces previous character with space, but tabs and newlines are deleted.
+   With prefix argument, do it that many times."
+  "Replaces previous character with space, but tabs and newlines are deleted."
+  (do ((point (current-point))
+       (n (or p 1) (1- n)))
+      ((zerop n))
+    (case (previous-character point)
+      ((#\newline #\tab) (delete-characters point -1))
+      ((nil) (editor-error))
+      (t (setf (previous-character point) #\space)
+	 (mark-before point)))))
Index: /branches/ide-1.0/ccl/hemlock/src/archive/srccom.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/srccom.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/srccom.lisp	(revision 6569)
@@ -0,0 +1,484 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;; Source comparison stuff for Hemlock.
+;;;
+;;; Written by Skef Wholey and Bill Chiles.
+;;;
+
+(in-package :hemlock)
+
+(defhvar "Source Compare Ignore Extra Newlines"
+  "If T, Source Compare and Source Merge will treat all groups of newlines
+  as if they were a single newline.  The default is T."
+  :value t)
+
+(defhvar "Source Compare Ignore Case"
+  "If T, Source Compare and Source Merge will treat all letters as if they
+  were of the same case.  The default is Nil."
+  :value nil)
+
+(defhvar "Source Compare Ignore Indentation"
+  "This determines whether comparisons ignore initial whitespace on a line or
+   use the whole line."
+  :value nil)
+
+(defhvar "Source Compare Number of Lines"
+  "This variable controls the number of lines Source Compare and Source Merge
+  will compare when resyncronizing after a difference has been encountered.
+  The default is 3."
+  :value 3)
+
+(defhvar "Source Compare Default Destination"
+  "This is a sticky-default buffer name to offer when comparison commands prompt
+   for a results buffer."
+  :value "Differences")
+
+
+(defcommand "Buffer Changes" (p)
+  "Generate a comparison of the current buffer with its file on disk."
+  "Generate a comparison of the current buffer with its file on disk."
+  (declare (ignore p))
+  (let ((buffer (current-buffer)))
+    (unless (buffer-pathname buffer)
+      (editor-error "No pathname associated with buffer."))
+    (let ((other-buffer (or (getstring "Buffer Changes File" *buffer-names*)
+			    (make-buffer "Buffer Changes File")))
+	  (result-buffer (or (getstring "Buffer Changes Result" *buffer-names*)
+			     (make-buffer "Buffer Changes Result"))))
+      (visit-file-command nil (buffer-pathname buffer) other-buffer)
+      (delete-region (buffer-region result-buffer))
+      (compare-buffers-command nil buffer other-buffer result-buffer)
+      (delete-buffer other-buffer))))
+
+;;; "Compare Buffers" creates two temporary buffers when there is a prefix.
+;;; These get deleted when we're done.  Buffer-a and Buffer-b are used for
+;;; names is banners in either case.
+;;; 
+(defcommand "Compare Buffers" (p &optional buffer-a buffer-b dest-buffer)
+  "Performs a source comparison on two specified buffers.  If the prefix
+   argument is supplied, only compare the regions in the buffer."
+  "Performs a source comparison on two specified buffers, Buffer-A and
+   Buffer-B, putting the result of the comparison into the Dest-Buffer.
+   If the prefix argument is supplied, only compare the regions in the
+   buffer."
+  (srccom-choose-comparison-functions)
+  (multiple-value-bind (buffer-a buffer-b dest-point
+		        delete-buffer-a delete-buffer-b)
+		       (get-srccom-buffers "Compare buffer: " buffer-a buffer-b
+					   dest-buffer p)
+    (with-output-to-mark (log dest-point)
+      (format log "Comparison of ~A and ~A.~%~%"
+	      (buffer-name buffer-a) (buffer-name buffer-b))
+      (with-mark ((mark-a (buffer-start-mark (or delete-buffer-a buffer-a)))
+		  (mark-b (buffer-start-mark (or delete-buffer-b buffer-b))))
+	(loop
+	  (multiple-value-bind (diff-a diff-b)
+			       (srccom-find-difference mark-a mark-b)
+	    (when (null diff-a) (return nil))
+	    (format log "**** Buffer ~A:~%" (buffer-name buffer-a))
+	    (insert-region dest-point diff-a)
+	    (format log "**** Buffer ~A:~%" (buffer-name buffer-b))
+	    (insert-region dest-point diff-b)
+	    (format log "***************~%~%")
+	    (move-mark mark-a (region-end diff-a))
+	    (move-mark mark-b (region-end diff-b))
+	    (unless (line-offset mark-a 1) (return))
+	    (unless (line-offset mark-b 1) (return)))))
+	(format log "Done.~%"))
+    (when delete-buffer-a
+      (delete-buffer delete-buffer-a)
+      (delete-buffer delete-buffer-b))))
+
+
+;;; "Merge Buffers" creates two temporary buffers when there is a prefix.
+;;; These get deleted when we're done.  Buffer-a and Buffer-b are used for
+;;; names is banners in either case.
+;;; 
+(defcommand "Merge Buffers" (p &optional buffer-a buffer-b dest-buffer)
+  "Performs a source merge on two specified buffers.  If the prefix
+   argument is supplied, only compare the regions in the buffer."
+  "Performs a source merge on two specified buffers, Buffer-A and Buffer-B,
+   putting the resulting text into the Dest-Buffer.  If the prefix argument
+   is supplied, only compare the regions in the buffer."
+  (srccom-choose-comparison-functions)
+  (multiple-value-bind (buffer-a buffer-b dest-point
+		        delete-buffer-a delete-buffer-b)
+		       (get-srccom-buffers "Merge buffer: " buffer-a buffer-b
+					   dest-buffer p)
+    (with-output-to-mark (stream dest-point)
+      (let ((region-a (buffer-region (or delete-buffer-a buffer-a))))
+	(with-mark ((temp-a (region-start region-a) :right-inserting)
+		    (temp-b dest-point :right-inserting)
+		    (mark-a (region-start region-a))
+		    (mark-b (region-start
+			     (buffer-region (or delete-buffer-b buffer-b)))))
+	  (clear-echo-area)
+	  (loop
+	    (multiple-value-bind (diff-a diff-b)
+				 (srccom-find-difference mark-a mark-b)
+	      (when (null diff-a)
+		(insert-region dest-point (region temp-a (region-end region-a)))
+		(return nil))
+	      ;; Copy the part that's the same.
+	      (insert-region dest-point (region temp-a (region-start diff-a)))
+	      ;; Put both versions in the buffer, and prompt for which one to use.
+	      (move-mark temp-a dest-point)
+	      (format stream "~%**** Buffer ~A (1):~%" (buffer-name buffer-a))
+	      (insert-region dest-point diff-a)
+	      (move-mark temp-b dest-point)
+	      (format stream "~%**** Buffer ~A (2):~%" (buffer-name buffer-b))
+	      (insert-region dest-point diff-b)
+	      (command-case
+		  (:prompt "Merge Buffers: "
+		   :help "Type one of these characters to say how to merge:") 
+		(#\1 "Use the text from buffer 1."
+		     (delete-region (region temp-b dest-point))
+		     (delete-characters temp-a)
+		     (delete-region
+		      (region temp-a
+			      (line-start temp-b
+					  (line-next (mark-line temp-a))))))
+		(#\2 "Use the text from buffer 2."
+		     (delete-region (region temp-a temp-b))
+		     (delete-characters temp-b)
+		     (delete-region
+		      (region temp-b
+			      (line-start temp-a
+					  (line-next (mark-line temp-b))))))
+		(#\b "Insert both versions with **** MERGE LOSSAGE **** around them."
+		     (insert-string temp-a "
+		     **** MERGE LOSSAGE ****")
+		     (insert-string dest-point "
+		     **** END OF MERGE LOSSAGE ****"))
+		(#\a "Align window at start of difference display."
+		     (line-start
+		      (move-mark
+		       (window-display-start
+			(car (buffer-windows (line-buffer (mark-line temp-a)))))
+		       temp-a))
+		     (reprompt))
+		(:recursive-edit "Enter a recursive edit."
+				 (with-mark ((save dest-point))
+				   (do-recursive-edit)
+				   (move-mark dest-point save))
+				 (reprompt)))
+	      (redisplay)
+	      (move-mark mark-a (region-end diff-a))
+	      (move-mark mark-b (region-end diff-b))
+	      (move-mark temp-a mark-a)
+	      (unless (line-offset mark-a 1) (return))
+	      (unless (line-offset mark-b 1) (return))))))
+      (message "Done."))
+    (when delete-buffer-a
+      (delete-buffer delete-buffer-a)
+      (delete-buffer delete-buffer-b))))
+
+(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p)
+  (unless buffer-a
+    (setf buffer-a (prompt-for-buffer :prompt first-prompt
+				      :must-exist t
+				      :default (current-buffer))))
+  (unless buffer-b
+    (setf buffer-b (prompt-for-buffer :prompt "With buffer: "
+				      :must-exist t
+				      :default (previous-buffer))))
+  (unless dest-buffer
+    (setf dest-buffer
+	  (prompt-for-buffer :prompt "Putting results in buffer: "
+			     :must-exist nil
+			     :default-string
+			     (value source-compare-default-destination))))
+  (if (stringp dest-buffer)
+      (setf dest-buffer (make-buffer dest-buffer))
+      (buffer-end (buffer-point dest-buffer)))
+  (setf (value source-compare-default-destination) (buffer-name dest-buffer))
+  (change-to-buffer dest-buffer)
+  (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym)))))
+	 (alt-buffer-b (if alt-buffer-a
+			   (make-buffer (prin1-to-string (gensym))))))
+    (when alt-buffer-a
+      (ninsert-region (buffer-point alt-buffer-a)
+		      (copy-region (if (mark< (buffer-point buffer-a)
+					      (buffer-mark buffer-a))
+				       (region (buffer-point buffer-a)
+					       (buffer-mark buffer-a))
+				       (region (buffer-mark buffer-a)
+					       (buffer-point buffer-a)))))
+      (ninsert-region (buffer-point alt-buffer-b)
+		      (copy-region (if (mark< (buffer-point buffer-b)
+					      (buffer-mark buffer-b))
+				       (region (buffer-point buffer-b)
+					       (buffer-mark buffer-b))
+				       (region (buffer-mark buffer-b)
+					       (buffer-point buffer-b))))))
+    (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b)))
+#|
+(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p)
+  (unless buffer-a
+    (setf buffer-a (prompt-for-buffer :prompt first-prompt
+				      :must-exist t
+				      :default (current-buffer))))
+  (unless buffer-b
+    (setf buffer-b (prompt-for-buffer :prompt "With buffer: "
+				      :must-exist t
+				      :default (previous-buffer))))
+  (unless dest-buffer
+    (let* ((name (value source-compare-default-destination))
+	   (temp-default (getstring name *buffer-names*))
+	   (default (or temp-default (make-buffer name))))
+      (setf dest-buffer (prompt-for-buffer :prompt "Putting results in buffer: "
+					   :must-exist nil
+					   :default default))
+      ;; Delete the default buffer if it did already exist and was not chosen.
+      (unless (or (eq dest-buffer default) temp-default)
+	(delete-buffer default))))
+  (if (stringp dest-buffer)
+      (setf dest-buffer (make-buffer dest-buffer))
+      (buffer-end (buffer-point dest-buffer)))
+  (setf (value source-compare-default-destination) (buffer-name dest-buffer))
+  (change-to-buffer dest-buffer)
+  (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym)))))
+	 (alt-buffer-b (if alt-buffer-a
+			   (make-buffer (prin1-to-string (gensym))))))
+    (when alt-buffer-a
+      (ninsert-region (buffer-point alt-buffer-a)
+		      (copy-region (if (mark< (buffer-point buffer-a)
+					      (buffer-mark buffer-a))
+				       (region (buffer-point buffer-a)
+					       (buffer-mark buffer-a))
+				       (region (buffer-mark buffer-a)
+					       (buffer-point buffer-a)))))
+      (ninsert-region (buffer-point alt-buffer-b)
+		      (copy-region (if (mark< (buffer-point buffer-b)
+					      (buffer-mark buffer-b))
+				       (region (buffer-point buffer-b)
+					       (buffer-mark buffer-b))
+				       (region (buffer-mark buffer-b)
+					       (buffer-point buffer-b))))))
+    (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b)))
+|#
+
+
+
+;;;; Functions that find the differences between two buffers.
+
+(defun srccom-find-difference (mark-a mark-b)
+  "Returns as multiple values two regions of text that are different in the
+  lines following Mark-A and Mark-B.  If no difference is encountered, Nil
+  is returned."
+  (multiple-value-bind (diff-a diff-b)
+		       (srccom-different-lines mark-a mark-b)
+    (when diff-a
+      (multiple-value-bind (same-a same-b)
+			   (srccom-similar-lines diff-a diff-b)
+	(values (region diff-a same-a)
+		(region diff-b same-b))))))
+
+;;; These are set by SRCCOM-CHOOSE-COMPARISON-FUNCTIONS depending on something.
+;;;
+(defvar *srccom-line=* nil)
+(defvar *srccom-line-next* nil)
+
+(defun srccom-different-lines (mark-a mark-b)
+  "Returns as multiple values two marks pointing to the first different lines
+  found after Mark-A and Mark-B.  Nil is returned if no different lines are
+  found."
+  (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
+       (mark-a (copy-mark mark-a))
+       (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
+       (mark-b (copy-mark mark-b)))
+      (())
+    (cond ((null line-a)
+	   (return (if line-b
+		       (values mark-a mark-b))))
+	  ((null line-b)
+	   (return (values mark-a mark-b))))
+    (line-start mark-a line-a)
+    (line-start mark-b line-b)
+    (unless (funcall *srccom-line=* line-a line-b)
+      (return (values mark-a mark-b)))))
+
+(defun srccom-similar-lines (mark-a mark-b)
+  "Returns as multiple values two marks pointing to the first similar lines
+  found after Mark-A and Mark-B."
+  (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
+       (cmark-a (copy-mark mark-a))
+       (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
+       (cmark-b (copy-mark mark-b))
+       (temp)
+       (window-size (value source-compare-number-of-lines)))
+      (())
+    ;; If we hit the end of one buffer, then the difference extends to the end
+    ;; of both buffers.
+    (if (or (null line-a) (null line-b))
+	(return
+	 (values
+	  (buffer-end-mark (line-buffer (mark-line mark-a)))
+	  (buffer-end-mark (line-buffer (mark-line mark-b))))))
+    (line-start cmark-a line-a)
+    (line-start cmark-b line-b)
+    ;; Three cases:
+    ;;  1] Difference will be same length in A and B.  If so, Line-A = Line-B.
+    ;;  2] Difference will be longer in A.  If so, Line-A = something in B.
+    ;;  3] Difference will be longer in B.  If so, Line-B = something in A.
+    (cond ((and (funcall *srccom-line=* line-a line-b)
+		(srccom-check-window line-a line-b window-size))
+	   (return (values cmark-a cmark-b)))
+	  ((and (setq temp (srccom-line-in line-a mark-b cmark-b))
+		(srccom-check-window line-a temp window-size))
+	   (return (values cmark-a (line-start cmark-b temp))))
+	  ((and (setq temp (srccom-line-in line-b mark-a cmark-a))
+		(srccom-check-window temp line-b window-size))
+	   (return (values (line-start cmark-a temp) cmark-b))))))
+
+(defun srccom-line-in (line start end)
+  "Checks to see if there is a Line Srccom-Line= to the given Line in the
+  region delimited by the Start and End marks.  Returns that line if so, or
+  Nil if there is none."
+  (do ((current (mark-line start) (funcall *srccom-line-next* current))
+       (terminus (funcall *srccom-line-next* (mark-line end))))
+      ((eq current terminus) nil)
+    (if (funcall *srccom-line=* line current)
+	(return current))))
+
+(defun srccom-check-window (line-a line-b count)
+  "Verifies that the Count lines following Line-A and Line-B are Srccom-Line=.
+  If so, returns T.  Otherwise returns Nil."
+  (do ((line-a line-a (funcall *srccom-line-next* line-a))
+       (line-b line-b (funcall *srccom-line-next* line-b))
+       (index 0 (1+ index)))
+      ((= index count) t)
+    (if (not (funcall *srccom-line=* line-a line-b))
+	(return nil))))
+
+
+
+
+;;;; Functions that control the comparison of text.
+
+;;; SRCCOM-CHOOSE-COMPARISON-FUNCTIONS -- Internal.
+;;;
+;;; This initializes utility functions for comparison commands based on Hemlock
+;;; variables.
+;;;
+(defun srccom-choose-comparison-functions ()
+  (setf *srccom-line=*
+	(if (value source-compare-ignore-case)
+	    (if (value source-compare-ignore-indentation)
+		#'srccom-ignore-case-and-indentation-line=
+		#'srccom-case-insensitive-line=)
+	    (if (value source-compare-ignore-indentation)
+		#'srccom-ignore-indentation-case-sensitive-line=
+		#'srccom-case-sensitive-line=)))
+  (setf *srccom-line-next*
+	(if (value source-compare-ignore-extra-newlines)
+	    #'srccom-line-next-ignoring-extra-newlines
+	    #'line-next)))
+#|
+(defun srccom-choose-comparison-functions ()
+  "This function should be called by a ``top level'' source compare utility
+  to initialize the lower-level functions that compare text."
+  (setf *srccom-line=*
+	(if (value source-compare-ignore-case)
+	    #'srccom-case-insensitive-line=
+	    #'srccom-case-sensitive-line=))
+  (setf *srccom-line-next*
+	(if (value source-compare-ignore-extra-newlines)
+	    #'srccom-line-next-ignoring-extra-newlines
+	    #'line-next)))
+|#
+
+;;; SRCCOM-LINE-NEXT-IGNORING-EXTRA-NEWLINES -- Internal.
+;;;
+;;; This is the value of *srccom-line-next* when "Source Compare Ignore Extra
+;;; Newlines" is non-nil.
+;;;
+(defun srccom-line-next-ignoring-extra-newlines (line)
+  (if (null line) nil
+      (do ((line (line-next line) (line-next line)))
+	  ((or (null line) (not (blank-line-p line))) line))))
+
+;;; SRCCOM-IGNORE-CASE-AND-INDENTATION-LINE=	   -- Internal.
+;;; SRCCOM-CASE-INSENSITIVE-LINE=		   -- Internal.
+;;; SRCCOM-IGNORE-INDENTATION-CASE-SENSITIVE-LINE= -- Internal.
+;;; SRCCOM-CASE-SENSITIVE-LINE=			   -- Internal.
+;;;
+;;; These are the value of *srccom-line-=* depending on the orthogonal values
+;;; of "Source Compare Ignore Case" and "Source Compare Ignore Indentation".
+;;;
+(macrolet ((def-line= (name test &optional ignore-indentation)
+	     `(defun ,name (line-a line-b)
+		(or (eq line-a line-b)		; if they're both NIL
+		    (and line-a
+			 line-b
+			 (let* ((chars-a (line-string line-a))
+				(len-a (length chars-a))
+				(chars-b (line-string line-b))
+				(len-b (length chars-b)))
+			   (declare (simple-string chars-a chars-b))
+			   (cond
+			    ((and (= len-a len-b)
+				  (,test chars-a chars-b)))
+			    ,@(if ignore-indentation
+				  `((t
+				     (flet ((frob (chars len)
+					      (dotimes (i len nil)
+						(let ((char (schar chars i)))
+						  (unless
+						      (or (char= char #\space)
+							  (char= char #\tab))
+						    (return i))))))
+				       (let ((i (frob chars-a len-a))
+					     (j (frob chars-b len-b)))
+					 (if (and i j)
+					     (,test chars-a chars-b
+						    :start1 i :end1 len-a
+						    :start2 j :end2 len-b)
+					     )))))))))))))
+
+  (def-line= srccom-ignore-case-and-indentation-line= string-equal t)
+
+  (def-line= srccom-case-insensitive-line= string-equal)
+
+  (def-line= srccom-ignore-indentation-case-sensitive-line= string= t)
+
+  (def-line= srccom-case-sensitive-line= string=))
+
+#|
+;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal.
+;;;
+;;; Returns t if line-a and line-b contain STRING-EQUAL text.
+;;;
+(defun srccom-case-insensitive-line= (line-a line-b)
+  (or (eq line-a line-b)		; if they're both NIL
+      (and line-a
+	   line-b
+	   (let ((chars-a (line-string line-a))
+		 (chars-b (line-string line-b)))
+	     (declare (simple-string chars-a chars-b))
+	     (and (= (length chars-a) (length chars-b))
+		  (string-equal chars-a chars-b))))))
+
+;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal.
+;;;
+;;; Returns t if line-a and line-b contain STRING= text.
+;;;
+(defun srccom-case-sensitive-line= (line-a line-b)
+  (or (eq line-a line-b)		; if they're both NIL
+      (and line-a
+	   line-b
+	   (let ((chars-a (line-string line-a))
+		 (chars-b (line-string line-b)))
+	     (declare (simple-string chars-a chars-b))
+	     (and (= (length chars-a) (length chars-b))
+		  (string= chars-a chars-b))))))
+|#
Index: /branches/ide-1.0/ccl/hemlock/src/archive/xcoms.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/archive/xcoms.lisp	(revision 6569)
+++ /branches/ide-1.0/ccl/hemlock/src/archive/xcoms.lisp	(revision 6569)
@@ -0,0 +1,40 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains commands and support specifically for X related features.
+;;;
+;;; Written by Bill Chiles.
+;;;
+
+(in-package :hemlock)
+
+
+(defcommand "Region to Cut Buffer" (p)
+  "Place the current region into the X cut buffer."
+  "Place the current region into the X cut buffer."
+  (declare (ignore p))
+  (store-cut-string (hi::bitmap-device-display
+		     (hi::device-hunk-device (hi::window-hunk (current-window))))
+		    (region-to-string (current-region))))
+
+(defcommand "Insert Cut Buffer" (p)
+  "Insert the X cut buffer at current point."
+  "Insert the X cut buffer at current point.  Returns nil when it is empty."
+  (declare (ignore p))
+  (let ((str (fetch-cut-string (hi::bitmap-device-display
+				(hi::device-hunk-device
+				 (hi::window-hunk (current-window)))))))
+    (if str
+	(let ((point (current-point)))
+	  (push-buffer-mark (copy-mark point))
+	  (insert-string (current-point) str))
+	(editor-error "X cut buffer empty.")))
+  (setf (last-command-type) :ephemerally-active))
Index: anches/ide-1.0/ccl/hemlock/src/auto-save.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/auto-save.lisp	(revision 6568)
+++ 	(revision )
@@ -1,401 +1,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.log -*-
-;;; 
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;; 
-;;; Auto-Save Mode
-;;; Written by Christopher Hoover
-;;;
-
-(in-package :hemlock)
-
-
-
-;;;; Per Buffer State Information
-
-;;; 
-;;; The auto-save-state structure is used to store the state information for
-;;; a particular buffer in "Save" mode, namely the buffer-signature at the last
-;;; key stroke, the buffer-signature at the time of the last checkpoint, a count
-;;; of the number of destructive keystrokes which have occured since the time of
-;;; the last checkpoint, and the pathname used to write the last checkpoint.  It
-;;; is generally kept in a buffer-local hvar called "Auto Save State".
-;;; 
-(defstruct (auto-save-state
-	    (:conc-name save-state-)
-	    (:print-function print-auto-save-state))
-  "Per buffer state for auto-save"
-  (buffer nil)				   ; buffer this state is for; for printing
-  (key-signature 0 :type fixnum)	   ; buffer-signature at last keystroke
-  (last-ckp-signature 0 :type fixnum)	   ; buffer-signature at last checkpoint
-  (key-count 0 :type fixnum)		   ; # destructive keystrokes since ckp
-  (pathname nil))			   ; pathname used to write last ckp file
-
-(defun print-auto-save-state (auto-save-state stream depth)
-  (declare (ignore depth))
-  (format stream "#<Auto Save Buffer State for buffer ~A>"
-	  (buffer-name (save-state-buffer auto-save-state))))
-
-
-;;; GET-AUTO-SAVE-STATE tries to get the auto-save-state for the buffer.  If
-;;; the buffer is not in "Save" mode then this function returns NIL.
-;;;
-(defun get-auto-save-state (buffer)
-  (if (hemlock-bound-p 'auto-save-state :buffer buffer)
-       (variable-value 'auto-save-state :buffer buffer)))
-
-;;; RESET-AUTO-SAVE-STATE resets the auto-save-state of the buffer making it
-;;; look as if the buffer was just checkpointed.  This is in fact how
-;;; checkpoint-buffer updates the state.  If the buffer is not in "Save" mode
-;;; this function punts the attempt and does nothing.
-;;;
-(defun reset-auto-save-state (buffer)
-  (let ((state (get-auto-save-state buffer)))
-    (when state
-      (let ((signature (buffer-signature buffer)))
-	(setf (save-state-key-signature state)
-	      signature)
-	(setf (save-state-last-ckp-signature state)
-	      signature)
-	(setf (save-state-key-count state)
-	      0)))))
-
-
-
-
-;;;; Checkpoint Pathname Interface/Internal Routines
-
-;;; GET-CHECKPOINT-PATHNAME -- Interface
-;;;
-;;; Returns the pathname of the checkpoint file for the specified
-;;; buffer;  Returns NIL if no checkpoints have been written thus
-;;; far or if the buffer isn't in "Save" mode.
-;;; 
-(defun get-checkpoint-pathname (buffer)
-  "Returns the pathname of the checkpoint file for the specified buffer.
-   If no checkpoints have been written thus far, or if the buffer is not in
-   \"Save\" mode, return nil."
-  (let ((state (get-auto-save-state buffer)))
-    (if state
-	(save-state-pathname state))))
-
-;;; MAKE-UNIQUE-SAVE-PATHNAME is used as the default value for "Auto Save
-;;; Pathname Hook" and is mentioned in the User's manual, so it gets a doc
-;;; doc string.
-;;;
-(defun make-unique-save-pathname (buffer)
-  "Returns a pathname for a non-existing file in DEFAULT-DIRECTORY.  Uses
-   GENSYM to for a file name: save-GENSYM.CKP."
-  (declare (ignore buffer))
-  (let ((def-dir (hemlock-ext:default-directory)))
-    (loop
-      (let* ((sym (gensym))
-	     (f (merge-pathnames (format nil "save-~A.CKP" sym) def-dir)))
-	(unless (probe-file f)
-	  (return f))))))
-    
-(defhvar "Auto Save Pathname Hook"
-  "This hook is called by Auto Save to get a checkpoint pathname when there
-   is no pathname associated with a buffer.  If this value is NIL, then
-   \"Save\" mode is turned off in the buffer.  Otherwise, the function
-   will be called. It should take a buffer as its argument and return either
-   NIL or a pathname.  If NIL is returned, then \"Save\" mode is turned off
-   in the buffer;  else the pathname returned is used as the checkpoint
-   pathname for the buffer."
-  :value #'make-unique-save-pathname)
-
-
-;;; MAKE-BUFFER-CKP-PATHNAME attempts to form a pathname by using the buffer's
-;;; associated pathname (from buffer-pathname).  If there isn't a pathname
-;;; associated with the buffer, the function returns nil.  Otherwise, it uses
-;;; the "Auto Save Filename Pattern" and FORMAT to make the checkpoint
-;;; pathname.
-;;;
-(defun make-buffer-ckp-pathname (buffer)
-  (let ((buffer-pn (buffer-pathname buffer)))
-    (if buffer-pn
-	(pathname (format nil
-			  (value auto-save-filename-pattern)
-			  (directory-namestring buffer-pn)
-			  (file-namestring buffer-pn))))))
-
-
-
-
-;;;; Buffer-level Checkpoint Routines
-
-;;;
-;;; write-checkpoint-file -- Internal
-;;;
-;;; Does the low-level write of the checkpoint.  Returns T if it succeeds
-;;; and NIL if it fails.  Echoes winnage or lossage to the luser.
-;;;
-(defun write-checkpoint-file (pathname buffer)
-  (let ((ns (namestring pathname)))
-    (cond ((hemlock-ext:file-writable pathname)
-	   (message "Saving ~A" ns)
-	   (handler-case (progn
-			   (write-file (buffer-region buffer) pathname
-				       :keep-backup nil
-				       :access #o600) ;read/write by owner.
-			   t)
-	     (error (condition)
-	       (loud-message "Auto Save failure: ~A" condition)
-	       nil)))
-	  (t
-	   (message "Can't write ~A" ns)
-	   nil))))
-
-
-;;;
-;;; To save, or not to save... and to save as what?
-;;;
-;;; First, make-buffer-ckp-pathname is called. It will return either NIL or
-;;; a pathname formed by using buffer-pathname in conjunction with the hvar
-;;; "Auto Save Filename Pattern".  If there isn't an associated pathname or
-;;; make-buffer-ckp-pathname returns NIL, then we use the pathname we used
-;;; the last time we checkpointed the buffer.  If we've never checkpointed
-;;; the buffer, then we check "Auto Save Pathname Hook".  If it is NIL then
-;;; we turn Save mode off for the buffer, else we funcall the function on
-;;; the hook with the buffer as an argument.  The function on the hook should
-;;; return either NIL or a pathname. If it returns NIL, we toggle Save mode
-;;; off for the buffer;  otherwise, we use the pathname it returned.
-;;;
-
-;;; 
-;;; checkpoint-buffer -- Internal
-;;;
-;;; This functions takes a buffer as its argument and attempts to write a
-;;; checkpoint for that buffer.  See the notes at the beginning of this page
-;;; for how it determines what pathname to use as the checkpoint pathname.
-;;; Note that a checkpoint is not necessarily written -- instead "Save"
-;;; mode may be turned off for the buffer.
-;;;
-(defun checkpoint-buffer (buffer)
-  (let* ((state (get-auto-save-state buffer))
-	 (buffer-ckp-pn (make-buffer-ckp-pathname buffer))
-	 (last-pathname (save-state-pathname state)))
-    (cond (buffer-ckp-pn
-	   (when (write-checkpoint-file buffer-ckp-pn buffer)
-	     (reset-auto-save-state buffer)
-	     (setf (save-state-pathname state) buffer-ckp-pn)
-	     (when (and last-pathname
-			(not (equal last-pathname buffer-ckp-pn))
-			(probe-file last-pathname))
-	       (delete-file last-pathname))))
-	  (last-pathname
-	   (when (write-checkpoint-file last-pathname buffer)
-	     (reset-auto-save-state buffer)))
-	  (t
-	   (let* ((save-pn-hook (value auto-save-pathname-hook))
-		  (new-pn (if save-pn-hook
-			      (funcall save-pn-hook buffer))))
-	     (cond ((or (not new-pn)
-			(zerop (length
-				(the simple-string (namestring new-pn)))))
-		    (setf (buffer-minor-mode buffer "Save") nil))
-		   (t
-		    (when (write-checkpoint-file new-pn buffer)
-		      (reset-auto-save-state buffer)
-		      (setf (save-state-pathname state) new-pn)))))))))
-
-;;;
-;;; checkpoint-all-buffers -- Internal
-;;; 
-;;; This function looks through the buffer list and checkpoints
-;;; each buffer that is in "Save" mode that has been modified since
-;;; its last checkpoint. 
-;;; 
-(defun checkpoint-all-buffers (elapsed-time)
-  (declare (ignore elapsed-time))
-  (dolist (buffer *buffer-list*)
-    (let ((state (get-auto-save-state buffer)))
-      (when (and state
-		 (buffer-modified buffer)
-		 (not (eql
-		       (save-state-last-ckp-signature state)
-		       (buffer-signature buffer))))
-	(checkpoint-buffer buffer)))))
-
-
-
-;;;; Random Hooks: cleanup, buffer-modified, change-save-freq.
-
-;;;
-;;; cleanup-checkpoint -- Internal
-;;; 
-;;; Cleans up checkpoint file for a given buffer if Auto Save Cleanup
-;;; Checkpoints is non-NIL.  This is called via "Write File Hook"
-;;; 
-(defun cleanup-checkpoint (buffer)
-  (let ((ckp-pathname (get-checkpoint-pathname buffer)))
-    (when (and (value auto-save-cleanup-checkpoints)
-	       ckp-pathname
-	       (probe-file ckp-pathname))
-      (delete-file ckp-pathname))))
-
-(add-hook write-file-hook 'cleanup-checkpoint)
-
-;;;
-;;; notice-buffer-modified -- Internal
-;;;
-;;; This function is called on "Buffer Modified Hook" to reset
-;;; the Auto Save state.  It makes the buffer look like it has just
-;;; been checkpointed.
-;;;
-(defun notice-buffer-modified (buffer flag)
-  ;; we care only when the flag has gone to false
-  (when (not flag)
-    (reset-auto-save-state buffer)))
-
-(add-hook buffer-modified-hook 'notice-buffer-modified)
-
-;;;
-;;; change-save-frequency -- Internal
-;;; 
-;;; This keeps us scheduled at the proper interval.  It is stuck on
-;;; the hook list for the hvar "Auto Save Checkpoint Frequency" and
-;;; is therefore called whenever this value is set.
-;;; 
-(defun change-save-frequency (name kind where new-value)
-  (declare (ignore name kind where))
-  (setq new-value (truncate new-value))
-  (remove-scheduled-event 'checkpoint-all-buffers)
-  (when (and new-value
-	     (plusp new-value))
-    (schedule-event new-value 'checkpoint-all-buffers t)))
-
-
-;;; "Save" mode is in "Default Modes", so turn it off in these modes.
-;;;
-
-(defun interactive-modes (buffer on)
-  (when on (setf (buffer-minor-mode buffer "Save") nil)))
-
-#+GBNIL (add-hook typescript-mode-hook 'interactive-modes)
-#+GBNIL (add-hook eval-mode-hook 'interactive-modes)
-
-
-
-
-;;;; Key Count Routine for Input Hook
-
-;;; 
-;;; auto-save-count-keys -- Internal
-;;;
-;;; This function sits on the Input Hook to eat cycles.  If the current
-;;; buffer is not in Save mode or if the current buffer is the echo area
-;;; buffer, it does nothing.  Otherwise, we check to see if we have exceeded
-;;; the key count threshold (and write a checkpoint if we have) and we
-;;; increment the key count for the buffer.
-;;;
-(defun auto-save-count-keys ()
-  #.*fast*
-  (let ((buffer (current-buffer)))
-    (unless (eq buffer *echo-area-buffer*)
-      (let ((state (value auto-save-state))
-	    (threshold (value auto-save-key-count-threshold)))
-	(when (and state threshold)
-	  (let ((signature (buffer-signature buffer)))
-	    (declare (fixnum signature))
-	    (when (not (eql signature
-			    (save-state-key-signature state)))
-	      ;; see if we exceeded threshold last time...
-	      (when (>= (save-state-key-count state)
-			(the fixnum threshold))
-		(checkpoint-buffer buffer))
-	      ;; update state
-	      (setf (save-state-key-signature state) signature)
-	      (incf (save-state-key-count state)))))))))
-
-(add-hook input-hook 'auto-save-count-keys)
-
-
-
-;;;; Save Mode Hemlock Variables
-
-;;; 
-;;; Hemlock variables/parameters for Auto-Save Mode
-;;;
-
-(defhvar "Auto Save Filename Pattern"
-  "This control-string is used with format to make the filename of the
-  checkpoint file.  Format is called with two arguments, the first
-  being the directory namestring and the second being the file
-  namestring of the default buffer pathname."
-  :value "~A~A.CKP")
-
-(defhvar "Auto Save Key Count Threshold"
-  "This value is the number of destructive/modifying keystrokes that will
-  automatically trigger an checkpoint.  This value may be NIL to turn this
-  feature off."
-  :value 256)
-
-(defhvar "Auto Save Cleanup Checkpoints"
-  "This variable controls whether or not \"Save\" mode will delete the
-  checkpoint file for a buffer after it is saved.  If this value is
-  non-NIL then cleanup will occur."
-  :value t)
-
-(defhvar "Auto Save Checkpoint Frequency"
-  "All modified buffers (in \"Save\" mode) will be checkpointed after this
-  amount of time (in seconds).  This value may be NIL (or non-positive)
-  to turn this feature off."
-  :value (* 2 60)
-  :hooks '(change-save-frequency))
-
-(defhvar "Auto Save State"
-  "Shadow magic.  This variable is seen when in buffers that are not
-  in \"Save\" mode.  Do not change this value or you will lose."
-  :value nil)
-
-
-
-;;;; "Save" mode
-
-(defcommand "Auto Save Mode" (p)
-  "If the argument is zero or negative, turn \"Save\" mode off.  If it
-  is positive turn \"Save\" mode on.  If there is no argument, toggle
-  \"Save\" mode in the current buffer.  When in \"Save\" mode, files
-  are automatically checkpointed every \"Auto Save Checkpoint Frequency\"
-  seconds or every \"Auto Save Key Count Threshold\" destructive
-  keystrokes.  If there is a pathname associated with the buffer, the
-  filename used for the checkpoint file is controlled by the hvar \"Auto
-  Save Filename Pattern\".  Otherwise, the hook \"Auto Save Pathname Hook\"
-  is used to generate a checkpoint pathname.  If the buffer's pathname
-  changes between checkpoints, the checkpoint file will be written under
-  the new name and the old checkpoint file will be deleted if it exists.
-  When a buffer is written out, the checkpoint will be deleted if the
-  hvar \"Auto Save Cleanup Checkpoints\" is non-NIL."
-  "Turn on, turn off, or toggle \"Save\" mode in the current buffer."
-  (setf (buffer-minor-mode (current-buffer) "Save")
-	(if p
-	    (plusp p)
-	    (not (buffer-minor-mode (current-buffer) "Save")))))
-
-(defun setup-auto-save-mode (buffer)
-  (let* ((signature (buffer-signature buffer))
-	 (state (make-auto-save-state
-		 :buffer buffer
-		 :key-signature (the fixnum signature)
-		 :last-ckp-signature (the fixnum signature))))
-    ;; shadow the global value with a variable which will
-    ;; contain our per buffer state information
-    (defhvar "Auto Save State"
-      "This is the \"Save\" mode state information for this buffer."
-      :buffer buffer
-      :value state)))
-
-(defun cleanup-auto-save-mode (buffer)
-  (delete-variable 'auto-save-state
-		   :buffer buffer))
-
-(defmode "Save"
-  :setup-function 'setup-auto-save-mode
-  :cleanup-function 'cleanup-auto-save-mode)
Index: anches/ide-1.0/ccl/hemlock/src/bufed.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/bufed.lisp	(revision 6568)
+++ 	(revision )
@@ -1,301 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains Bufed (Buffer Editing) code.
-;;;
-
-(in-package :hemlock)
-
-
-
-
-;;;; Representation of existing buffers.
-
-;;; This is the array of buffers in the bufed buffer.  Each element is a cons,
-;;; where the CAR is the buffer, and the CDR indicates whether the buffer
-;;; should be deleted (t deleted, nil don't).
-;;;
-(defvar *bufed-buffers* nil)
-(defvar *bufed-buffers-end* nil)
-;;;
-(defmacro bufed-buffer (x) `(car ,x))
-(defmacro bufed-buffer-deleted (x) `(cdr ,x))
-(defmacro make-bufed-buffer (buffer) `(list ,buffer))
-
-
-;;; This is the bufed buffer if it exists.
-;;;
-(defvar *bufed-buffer* nil)
-
-;;; This is the cleanup method for deleting *bufed-buffer*.
-;;;
-(defun delete-bufed-buffers (buffer)
-  (when (eq buffer *bufed-buffer*)
-    (setf *bufed-buffer* nil)
-    (setf *bufed-buffers* nil)))
-
-
-
-
-;;;; Commands.
-
-(defmode "Bufed" :major-p t
-  :documentation
-  "Bufed allows the user to quickly save, goto, delete, etc., his buffers.")
-
-(defhvar "Virtual Buffer Deletion"
-  "When set, \"Bufed Delete\" marks a buffer for deletion instead of immediately
-   deleting it."
-  :value t)
-
-(defhvar "Bufed Delete Confirm"
-  "When set, \"Bufed\" commands that actually delete buffers ask for
-   confirmation before taking action."
-  :value t)
-
-(defcommand "Bufed Delete" (p)
-  "Delete the buffer.
-   Any windows displaying this buffer will display some other buffer."
-  "Delete the buffer indicated by the current line.  Any windows displaying this
-   buffer will display some other buffer."
-  (declare (ignore p))
-  (let* ((point (current-point))
-	 (buf-info (array-element-from-mark point *bufed-buffers*)))
-    (if (and (not (value virtual-buffer-deletion))
-	     (or (not (value bufed-delete-confirm))
-		 (prompt-for-y-or-n :prompt "Delete buffer? " :default t
-				    :must-exist t :default-string "Y")))
-	(delete-bufed-buffer (bufed-buffer buf-info))
-	(with-writable-buffer (*bufed-buffer*)
-	  (setf (bufed-buffer-deleted buf-info) t)
-	  (with-mark ((point point))
-	    (setf (next-character (line-start point)) #\D))))))
-
-(defcommand "Bufed Undelete" (p)
-  "Undelete the buffer.
-   Any windows displaying this buffer will display some other buffer."
-  "Undelete the buffer.  Any windows displaying this buffer will display some
-   other buffer."
-  (declare (ignore p))
-  (with-writable-buffer (*bufed-buffer*)
-    (setf (bufed-buffer-deleted (array-element-from-mark
-				 (current-point) *bufed-buffers*))
-	  nil)
-    (with-mark ((point (current-point)))
-      (setf (next-character (line-start point)) #\space))))
-
-(defcommand "Bufed Expunge" (p)
-  "Expunge buffers marked for deletion."
-  "Expunge buffers marked for deletion."
-  (declare (ignore p))
-  (expunge-bufed-buffers))
-
-(defcommand "Bufed Quit" (p)
-  "Kill the bufed buffer, expunging any buffer marked for deletion."
-  "Kill the bufed buffer, expunging any buffer marked for deletion."
-  (declare (ignore p))
-  (expunge-bufed-buffers)
-  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
-
-;;; EXPUNGE-BUFED-BUFFERS deletes the marked buffers in the bufed buffer,
-;;; signalling an error if the current buffer is not the bufed buffer.  This
-;;; returns t if it deletes some buffer, otherwise nil.  We build a list of
-;;; buffers before deleting any because the BUFED-DELETE-HOOK moves elements
-;;; around in *bufed-buffers*.
-;;;
-(defun expunge-bufed-buffers ()
-  (unless (eq *bufed-buffer* (current-buffer))
-    (editor-error "Not in the Bufed buffer."))
-  (let (buffers)
-    (dotimes (i *bufed-buffers-end*)
-      (let ((buf-info (svref *bufed-buffers* i)))
-	(when (bufed-buffer-deleted buf-info)
-	  (push (bufed-buffer buf-info) buffers))))
-    (if (and buffers
-	     (or (not (value bufed-delete-confirm))
-		 (prompt-for-y-or-n :prompt "Delete buffers? " :default t
-				    :must-exist t :default-string "Y")))
-	(dolist (b buffers t) (delete-bufed-buffer b)))))
-
-(defun delete-bufed-buffer (buf)
-  (when (and (buffer-modified buf)
-	     (prompt-for-y-or-n :prompt (list "~A is modified.  Save it first? "
-					      (buffer-name buf))))
-    (save-file-command nil buf))
-  (delete-buffer-if-possible buf))
-
-
-(defcommand "Bufed Goto" (p)
-  "Change to the buffer."
-  "Change to the buffer."
-  (declare (ignore p))
-  (change-to-buffer
-   (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
-
-(defcommand "Bufed Goto and Quit" (p)
-  "Change to the buffer quitting Bufed.
-   This supplies a function for \"Generic Pointer Up\" which is a no-op."
-  "Change to the buffer quitting Bufed."
-  (declare (ignore p))
-  (expunge-bufed-buffers)
-  (point-to-here-command nil)
-  (change-to-buffer
-   (bufed-buffer (array-element-from-pointer-pos *bufed-buffers*
-		 "No buffer on that line.")))
-  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))
-  (supply-generic-pointer-up-function #'(lambda () nil)))
-
-(defcommand "Bufed Save File" (p)
-  "Save the buffer."
-  "Save the buffer."
-  (declare (ignore p))
-  (save-file-command
-   nil
-   (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
-
-(defcommand "Bufed" (p)
-  "Creates a list of buffers in a buffer supporting operations such as deletion
-   and selection.  If there already is a bufed buffer, just go to it."
-  "Creates a list of buffers in a buffer supporting operations such as deletion
-   and selection.  If there already is a bufed buffer, just go to it."
-  (declare (ignore p))
-  (let ((buf (or *bufed-buffer*
-		 (make-buffer "Bufed" :modes '("Bufed")
-			      :delete-hook (list #'delete-bufed-buffers)))))
-
-    (unless *bufed-buffer*
-      (setf *bufed-buffer* buf)
-      (setf *bufed-buffers-end*
-	    ;; -1 echo, -1 bufed.
-	    (- (length (the list *buffer-list*)) 2))
-      (setf *bufed-buffers* (make-array *bufed-buffers-end*))
-      (setf (buffer-writable buf) t)
-      (with-output-to-mark (s (buffer-point buf))
-	(let ((i 0))
-	  (do-strings (n b *buffer-names*)
-	    (declare (simple-string n))
-	    (unless (or (eq b *echo-area-buffer*)
-			(eq b buf))
-	      (bufed-write-line b n s)
-	      (setf (svref *bufed-buffers* i) (make-bufed-buffer b))
-	      (incf i)))))
-      (setf (buffer-writable buf) nil)
-      (setf (buffer-modified buf) nil)
-      (let ((fields (buffer-modeline-fields *bufed-buffer*)))
-	(setf (cdr (last fields))
-	      (list (or (modeline-field :bufed-cmds)
-			(make-modeline-field
-			 :name :bufed-cmds :width 18
-			 :function
-			 #'(lambda (buffer window)
-			     (declare (ignore buffer window))
-			     "  Type ? for help.")))))
-	(setf (buffer-modeline-fields *bufed-buffer*) fields))
-      (buffer-start (buffer-point buf)))
-    (change-to-buffer buf)))
-
-(defun bufed-write-line (buffer name s
-		         &optional (buffer-pathname (buffer-pathname buffer)))
-  (let ((modified (buffer-modified buffer)))
-    (write-string (if modified " *" "  ") s)
-    (if buffer-pathname
-	(format s "~A  ~A~:[~50T~A~;~]~%"
-		(file-namestring buffer-pathname)
-		(directory-namestring buffer-pathname)
-		(string= (pathname-to-buffer-name buffer-pathname) name)
-		name)
-	(write-line name s))))
-
-
-(defcommand "Bufed Help" (p)
-  "Show this help."
-  "Show this help."
-  (declare (ignore p))
-  (describe-mode-command nil "Bufed"))
-
-
-
-
-;;;; Maintenance hooks.
-
-(eval-when (:compile-toplevel :execute)
-(defmacro with-bufed-point ((point buffer &optional pos) &rest body)
-  (let ((pos (or pos (gensym))))
-    `(when (and *bufed-buffers*
-		(not (eq *bufed-buffer* ,buffer))
-		(not (eq *echo-area-buffer* ,buffer)))
-       (let ((,pos (position ,buffer *bufed-buffers* :key #'car
-			     :test #'eq :end *bufed-buffers-end*)))
-	 (unless ,pos (error "Unknown Bufed buffer."))
-	 (let ((,point (buffer-point *bufed-buffer*)))
-	   (unless (line-offset (buffer-start ,point) ,pos 0)
-	     (error "Bufed buffer not displayed?"))
-	   (with-writable-buffer (*bufed-buffer*) ,@body))))))
-) ;eval-when
-
-
-(defun bufed-modified-hook (buffer modified)
-  (with-bufed-point (point buffer)
-    (setf (next-character (mark-after point)) (if modified #\* #\space))))
-;;;
-(add-hook buffer-modified-hook 'bufed-modified-hook)
-
-(defun bufed-make-hook (buffer)
-  (declare (ignore buffer))
-  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
-;;;
-(add-hook make-buffer-hook 'bufed-make-hook)
-
-(defun bufed-delete-hook (buffer)
-  (with-bufed-point (point buffer pos)
-    (with-mark ((temp point :left-inserting))
-      (line-offset temp 1)
-      (delete-region (region point temp)))
-    (let ((len-1 (1- *bufed-buffers-end*)))
-      (replace *bufed-buffers* *bufed-buffers*
-	       :start1 pos :end1 len-1
-	       :start2 (1+ pos) :end1 *bufed-buffers-end*)
-      (setf (svref *bufed-buffers* len-1) nil)
-      (setf *bufed-buffers-end* len-1))))
-;;;
-(add-hook delete-buffer-hook 'bufed-delete-hook)
-
-(defun bufed-name-hook (buffer name)
-  (with-bufed-point (point buffer)
-    (with-mark ((temp point :left-inserting))
-      (line-offset temp 1)
-      (delete-region (region point temp)))
-    (with-output-to-mark (s point)
-      (bufed-write-line buffer name s))))
-;;;
-(add-hook buffer-name-hook 'bufed-name-hook)
-
-(defun bufed-pathname-hook (buffer pathname)
-  (with-bufed-point (point buffer)
-    (with-mark ((temp point :left-inserting))
-      (line-offset temp 1)
-      (delete-region (region point temp)))
-    (with-output-to-mark (s point)
-      (bufed-write-line buffer (buffer-name buffer) s pathname))))
-;;;
-(add-hook buffer-pathname-hook 'bufed-pathname-hook)
-
-
-
-;;;; Utilities
-
-(defun array-element-from-pointer-pos (vector &optional
-					      (error-msg "Invalid line."))
-  (multiple-value-bind (x y window) (last-key-event-cursorpos)
-    (declare (ignore x window))
-    (when (>= y (length vector))
-      (editor-error error-msg))
-    (svref vector y)))
Index: anches/ide-1.0/ccl/hemlock/src/group.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/group.lisp	(revision 6568)
+++ 	(revision )
@@ -1,238 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;; File group stuff for Hemlock.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-;;;    The "Compile Group" and "List Compile Group" commands in lispeval
-;;;    also know about groups.
-;;;
-;;; This file provides Hemlock commands for manipulating groups of files
-;;; that make up a larger system.  A file group is a set of files whose
-;;; names are listed in some other file.  At any given time one group of
-;;; files is the Active group.  The Select Group command makes a group the
-;;; Active group, prompting for the name of a definition file if the group
-;;; has not been selected before.  Once a group has been selected once, the
-;;; name of the definition file associated with that group is retained.  If
-;;; one wishes to change the name of the definition file after a group has
-;;; been selected, one should call Select Group with a prefix argument.
-
-(in-package :hemlock)
-
-(defvar *file-groups* (make-string-table)
-  "A string table of file groups.")
-
-(defvar *active-file-group* ()
-  "The list of files in the currently active group.")
-
-(defvar *active-file-group-name* ()
-  "The name of the currently active group.")
-
-
-
-
-;;;; Selecting the active group.
-
-(defcommand "Select Group" (p)
-  "Makes a group the active group.  With a prefix argument, changes the
-  definition file associated with the group."
-  "Makes a group the active group."
-  (let* ((group-name
-	  (prompt-for-keyword
-	   (list *file-groups*)
-	   :must-exist nil
-	   :prompt "Select Group: "
-	   :help
-	   "Type the name of the file group you wish to become the active group."))
-	 (old (getstring group-name *file-groups*))
-	 (pathname
-	  (if (and old (not p))
-	      old
-	      (prompt-for-file :must-exist t
-			       :prompt "From File: "
-			       :default (merge-pathnames
-					 (make-pathname
-					  :name group-name
-					  :type "upd")
-					 (value pathname-defaults))))))
-    (setq *active-file-group-name* group-name)
-    (setq *active-file-group* (nreverse (read-file-group pathname nil)))
-    (setf (getstring group-name *file-groups*) pathname)))
-
-
-;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames
-;;; of the files named in that file.  This guy knows about @@ indirection and
-;;; ignores empty lines and lines that begin with @ but not @@.  A simpler
-;;; scheme could be used for non-Spice implementations, but all this hair is
-;;; probably useful, so Update format may as well be a standard for this sort
-;;; of thing.
-;;;
-(defun read-file-group (pathname tail)
-  (with-open-file (file pathname)
-    (do* ((name (read-line file nil nil) (read-line file nil nil))
-	  (length (if name (length name)) (if name (length name))))
-	 ((null name) tail)
-      (declare (type (or simple-string null) name))
-      (cond ((zerop length))
-	    ((char= (char name 0) #\@)
-	     (when (and (> length 1) (char= (char name 1) #\@))
-	       (setq tail (read-file-group
-			   (merge-pathnames (subseq name 2)
-					    pathname)
-			   tail))))
-	    (t
-	     (push (merge-pathnames (pathname name) pathname) tail))))))
-
-
-
-
-;;;; DO-ACTIVE-GROUP.
-
-(defhvar "Group Find File"
-  "If true, group commands use \"Find File\" to read files, otherwise
-  non-resident files are read into the \"Group Search\" buffer."
-  :value nil)
-
-(defhvar "Group Save File Confirm"
-  "If true, then the group commands will ask for confirmation before saving
-  a modified file." :value t)
-
-(defmacro do-active-group (&rest forms)
-  "This iterates over the active file group executing forms once for each
-   file.  When forms are executed, the file will be in the current buffer,
-   and the point will be at the start of the file."
-  (let ((n-buf (gensym))
-	(n-start-buf (gensym))
-	(n-save (gensym)))
-    `(progn
-       (unless *active-file-group*
-	 (editor-error "There is no active file group."))
-
-       (let ((,n-start-buf (current-buffer))
-	     (,n-buf nil))
-	 (unwind-protect
-	     (dolist (file *active-file-group*)
-	       (catch 'file-not-found
-		 (setq ,n-buf (group-read-file file ,n-buf))
-		 (with-mark ((,n-save (current-point) :right-inserting))
-		   (unwind-protect
-		       (progn
-			 (buffer-start (current-point))
-			 ,@forms)
-		     (move-mark (current-point) ,n-save)))
-		 (group-save-file)))
-	   (if (member ,n-start-buf *buffer-list*)
-	       (setf (current-buffer) ,n-start-buf
-		     (window-buffer (current-window)) ,n-start-buf)
-	       (editor-error "Original buffer deleted!")))))))
-
-;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP.
-;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't
-;;; already been read, to get files in, and then we delete the buffer if it is
-;;; newly created and "Group Find File" is false.  This lets FIND-FILE-BUFFER
-;;; do all the work.  We don't actually use the "Find File" command, so the
-;;; buffer history isn't affected.
-;;;
-;;; Search-Buffer is any temporary search buffer left over from the last file
-;;; that we want deleted.  We don't do the deletion if the buffer is modified.
-;;;
-(defun group-read-file (name search-buffer)
-  (unless (probe-file name)
-    (message "File ~A not found." name)
-    (throw 'file-not-found nil))
-  (multiple-value-bind (buffer created-p)
-		       (find-file-buffer name)
-    (setf (current-buffer) buffer)
-    (setf (window-buffer (current-window)) buffer)
-
-    (when (and search-buffer (not (buffer-modified search-buffer)))
-      (dolist (w (buffer-windows search-buffer))
-	(setf (window-buffer w) (current-buffer)))
-      (delete-buffer search-buffer))
-
-    (if (and created-p (not (value group-find-file)))
-	(current-buffer) nil)))
-
-;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP.
-;;;
-(defun group-save-file ()
-  (let* ((buffer (current-buffer))
-	 (pn (buffer-pathname buffer))
-	 (name (namestring pn)))
-    (when (and (buffer-modified buffer)
-	       (or (not (value group-save-file-confirm))
-		   (prompt-for-y-or-n
-		    :prompt (list "Save changes in ~A? " name)
-		    :default t)))
-      (save-file-command ()))))
-
-
-
-
-;;;; Searching and Replacing commands.
-
-(defcommand "Group Search" (p)
-  "Searches the active group for a specified string, which is prompted for."
-  "Searches the active group for a specified string."
-  (declare (ignore p))
-  (let ((string (prompt-for-string :prompt "Group Search: "
-				   :help "String to search for in active file group"
-				   :default *last-search-string*)))
-    (get-search-pattern string :forward)
-    (do-active-group
-     (do ((won (find-pattern (current-point) *last-search-pattern*)
-	       (find-pattern (current-point) *last-search-pattern*)))
-	 ((not won))
-       (character-offset (current-point) won)
-       (command-case
-	   (:prompt "Group Search: "
-		    :help "Type a character indicating the action to perform."
-		    :change-window nil)
-	 (:no "Search for the next occurrence.")
-	 (:do-all "Go on to the next file in the group."
-	  (return nil))
-	 ((:exit :yes) "Exit the search."
-	  (return-from group-search-command))
-	 (:recursive-edit "Enter a recursive edit."
-	  (do-recursive-edit)
-	  (get-search-pattern string :forward)))))
-    (message "All files in group ~S searched." *active-file-group-name*)))
-
-(defcommand "Group Replace" (p)
-  "Replaces one string with another in the active file group."
-  "Replaces one string with another in the active file group."
-  (declare (ignore p))
-  (let* ((target (prompt-for-string :prompt "Group Replace: "
-				    :help "Target string"
-				    :default *last-search-string*))
-	 (replacement (prompt-for-string :prompt "With: "
-					 :help "Replacement string")))
-    (do-active-group
-     (query-replace-function nil target replacement
-			     "Group Replace on previous file" t))
-    (message "Replacement done in all files in group ~S."
-	     *active-file-group-name*)))
-
-(defcommand "Group Query Replace" (p)
-  "Query Replace for the active file group."
-  "Query Replace for the active file group."
-  (declare (ignore p))
-  (let ((target (prompt-for-string :prompt "Group Query Replace: "
-				   :help "Target string"
-				   :default *last-search-string*)))
-    (let ((replacement (prompt-for-string :prompt "With: "
-					  :help "Replacement string")))
-      (do-active-group
-       (unless (query-replace-function
-		nil target replacement "Group Query Replace on previous file")
-	 (return nil)))
-      (message "Replacement done in all files in group ~S."
-	       *active-file-group-name*))))
Index: anches/ide-1.0/ccl/hemlock/src/highlight.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/highlight.lisp	(revision 6568)
+++ 	(revision )
@@ -1,211 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;; Highlighting paren and some other good stuff.
-;;;
-;;; Written by Bill Chiles and Jim Healy.
-;;;
-
-(in-package :hemlock)
-
-
-
-
-;;;; Open parens.
-
-(defhvar "Highlight Open Parens"
-  "When non-nil, causes open parens to be displayed in a different font when
-   the cursor is directly to the right of the corresponding close paren."
-  :value nil)
-
-(defhvar "Open Paren Finder Function"
-  "Should be a function that takes a mark for input and returns either NIL
-   if the mark is not after a close paren, or two (temporary) marks
-   surrounding the corresponding open paren."
-  :value 'lisp-open-paren-finder-function)
-
-
-(defvar *open-paren-font-marks* nil
-  "The pair of font-marks surrounding the currently highlighted open-
-   paren or nil if there isn't one.")
-
-(defvar *open-paren-highlight-font* 2
-  "The index into the font-map for the open paren highlighting font.")
-
-
-;;; MAYBE-HIGHLIGHT-OPEN-PARENS is a redisplay hook that matches parens by
-;;; highlighting the corresponding open-paren after a close-paren is
-;;; typed.
-;;; 
-(defun maybe-highlight-open-parens (window)
-  (declare (ignore window))
-  (when (value highlight-open-parens)
-    (if (and (value highlight-active-region) (region-active-p))
-	(kill-open-paren-font-marks)
-	(multiple-value-bind
-	    (start end)
-	    (funcall (value open-paren-finder-function)
-		     (current-point))
-	  (if (and start end)
-	      (set-open-paren-font-marks start end)
-	      (kill-open-paren-font-marks))))))
-;;;
-(add-hook redisplay-hook 'maybe-highlight-open-parens)
-
-(defun set-open-paren-font-marks (start end)
-  (if *open-paren-font-marks*
-      (flet ((maybe-move (dst src)
-	       (unless (mark= dst src)
-		 (move-font-mark dst src))))
-	(declare (inline maybe-move))
-	(maybe-move (region-start *open-paren-font-marks*) start)
-	(maybe-move (region-end *open-paren-font-marks*) end))
-      (let ((line (mark-line start)))
-	(setf *open-paren-font-marks*
-	      (region
-	       (font-mark line (mark-charpos start)
-			  *open-paren-highlight-font*)
-	       (font-mark line (mark-charpos end) 0))))))
-
-(defun kill-open-paren-font-marks ()
-  (when *open-paren-font-marks*
-    (delete-font-mark (region-start *open-paren-font-marks*))
-    (delete-font-mark (region-end *open-paren-font-marks*))
-    (setf *open-paren-font-marks* nil)))
-
-
-
-
-
-;;;; Active regions.
-
-(defvar *active-region-font-marks* nil)
-(defvar *active-region-highlight-font* 3
-  "The index into the font-map for the active region highlighting font.")
-
-
-;;; HIGHLIGHT-ACTIVE-REGION is a redisplay hook for active regions.
-;;; Since it is too hard to know how the region may have changed when it is
-;;; active and already highlighted, if it does not check out to being exactly
-;;; the same, we just delete all the font marks and make new ones.  When
-;;; the current window is the echo area window, just pretend everything is
-;;; okay; this keeps the region highlighted while we're in there.
-;;;
-(defun highlight-active-region (window)
-  (unless (eq window *echo-area-window*)
-    (when (value highlight-active-region)
-      (cond ((region-active-p)
-	     (cond ((not *active-region-font-marks*)
-		    (set-active-region-font-marks))
-		   ((check-active-region-font-marks))
-		   (t (kill-active-region-font-marks)
-		      (set-active-region-font-marks))))
-	    (*active-region-font-marks*
-	     (kill-active-region-font-marks))))))
-;;;
-(add-hook redisplay-hook 'highlight-active-region)
-
-(defun set-active-region-font-marks ()
-  (flet ((stash-a-mark (m &optional (font *active-region-highlight-font*))
-	   (push (font-mark (mark-line m) (mark-charpos m) font)
-		 *active-region-font-marks*)))
-    (let* ((region (current-region nil nil))
-	   (start (region-start region))
-	   (end (region-end region)))
-      (with-mark ((mark start))
-	(unless (mark= mark end)
-	  (loop
-	    (stash-a-mark mark)
-	    (unless (line-offset mark 1 0) (return))
-	    (when (mark>= mark end) (return)))
-	  (unless (start-line-p end) (stash-a-mark end 0))))))
-  (setf *active-region-font-marks* (nreverse *active-region-font-marks*)))
-
-(defun kill-active-region-font-marks ()
-  (dolist (m *active-region-font-marks*)
-    (delete-font-mark m))
-  (setf *active-region-font-marks* nil))
-
-;;; CHECK-ACTIVE-REGION-FONT-MARKS returns t if the current region is the same
-;;; as that what is highlighted on the screen.  This assumes
-;;; *active-region-font-marks* is non-nil.  At the very beginning, our start
-;;; mark must not be at the end; it must be at the first font mark; and the
-;;; font marks must be in the current buffer.  We don't make font marks if the
-;;; start is at the end, so if this is the case, then they just moved together.
-;;; We return nil in this case to kill all the font marks and make new ones, but
-;;; no new ones will be made.
-;;;
-;;; Sometimes we hack the font marks list and return t because we can easily
-;;; adjust the highlighting to be correct.  This keeps all the font marks from
-;;; being killed and re-established.  In the loop, if there are no more font
-;;; marks, we either ended a region already highlighted on the next line down,
-;;; or we have to revamp the font marks.  Before returning here, we see if the
-;;; region ends one more line down at the beginning of the line.  If this is
-;;; true, then the user is simply doing "Next Line" at the beginning of the
-;;; line.
-;;;
-;;; Each time through the loop we look at the top font mark, move our roving
-;;; mark down one line, and see if they compare.  If they are not equal, the
-;;; region may still be the same as that highlighted on the screen.  If this
-;;; is the last font mark, not at the beginning of the line, and it is at the
-;;; region's end, then this last font mark is in the middle of a line somewhere
-;;; changing the font from the highlighting font to the default font.  Return
-;;; t.
-;;;
-;;; If our roving mark is not at the current font mark, but it is at or after
-;;; the end of the active region, then the end of the active region has moved
-;;; before its previous location.
-;;;
-;;; Otherwise, move on to the next font mark.
-;;;
-;;; If our roving mark never moved onto a next line, then the buffer ends on the
-;;; previous line, and the last font mark changes from the highlighting font to
-;;; the default font.
-;;;
-(defun check-active-region-font-marks ()
-  (let* ((region (current-region nil nil))
-	 (end (region-end region)))
-    (with-mark ((mark (region-start region)))
-      (let ((first-active-mark (car *active-region-font-marks*))
-	    (last-active-mark (last *active-region-font-marks*)))
-	(if (and (mark/= mark end)
-		 (eq (current-buffer)
-		     (line-buffer (mark-line first-active-mark)))
-		 (mark= first-active-mark mark))
-	    (let ((marks (cdr *active-region-font-marks*)))
-	      (loop
-		(unless marks
-		  (let ((res (and (line-offset mark 1 0)
-				  (mark= mark end))))
-		    (when (and (not res)
-			       (line-offset mark 1 0)
-			       (mark= mark end)
-			       (start-line-p (car last-active-mark)))
-		      (setf (cdr last-active-mark)
-			    (list (font-mark (line-previous (mark-line mark))
-					     0
-					     *active-region-highlight-font*)))
-		      (return t))
-		    (return res)))
-		(let ((fmark (car marks)))
-		  (if (line-offset mark 1 0)
-		      (cond ((mark/= mark fmark)
-			     (return (and (not (cdr marks))
-					  (not (start-line-p fmark))
-					  (mark= fmark end))))
-			    ((mark>= mark end)
-			     (return nil))
-			    (t (setf marks (cdr marks))))
-
-		      (return (and (not (cdr marks))
-				   (not (start-line-p fmark))
-				   (mark= fmark end))))))))))))
-
Index: anches/ide-1.0/ccl/hemlock/src/lisp-lib.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/lisp-lib.lisp	(revision 6568)
+++ 	(revision )
@@ -1,175 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains code to peruse the CMU Common Lisp library of hacks.
-;;;
-;;; Written by Blaine Burks.
-;;;
-
-(in-package :hemlock)
-
-
-(defmode "Lisp-Lib" :major-p t)
-
-;;; The library should be in *lisp-library-directory*
-
-(defvar *lisp-library-directory*  "/afs/cs.cmu.edu/project/clisp/library/")
-
-(defvar *selected-library-buffer* nil)
-
-
-
-;;;; Commands.
-
-(defcommand "Lisp Library" (p)
-  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
-  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
-  (declare (ignore p))
-  (when (not (and *selected-library-buffer*
-		  (member *selected-library-buffer* *buffer-list*)))
-    (when (getstring "Lisp Library" *buffer-names*)
-      (editor-error "There is already a buffer named \"Lisp Library\"."))
-    (setf *selected-library-buffer*
-	  (make-buffer "Lisp Library" :modes '("Lisp-Lib")))
-    (message "Groveling library ...")
-    (let ((lib-directory (directory *lisp-library-directory*))
-	  (lib-entries ()))
-      (with-output-to-mark (s (buffer-point *selected-library-buffer*))
-	(dolist (lib-spec lib-directory)
-	  (let* ((path-parts (pathname-directory lib-spec))
-		 (last (elt path-parts (1- (length path-parts))))
-		 (raw-pathname (merge-pathnames last lib-spec)))
-	    (when (and (directoryp lib-spec)
-		       (probe-file (merge-pathnames
-				    (make-pathname :type "catalog")
-				    raw-pathname)))
-	      (push raw-pathname lib-entries)
-	      (format s "~d~%" last)))))
-      (defhvar "Library Entries"
-	"Holds a list of library entries for the 'Lisp Library' buffer"
-	:buffer *selected-library-buffer*
-	:value (coerce (nreverse lib-entries) 'simple-vector))))
-  (setf (buffer-writable *selected-library-buffer*) nil)
-  (setf (buffer-modified *selected-library-buffer*) nil)
-  (change-to-buffer *selected-library-buffer*)
-  (buffer-start (current-point)))
-
-(defcommand "Describe Pointer Library Entry" (p)
-  "Finds the file that describes the lisp library entry indicated by the
-   pointer."
-  "Finds the file that describes the lisp library entry indicated by the
-   pointer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (describe-library-entry (array-element-from-pointer-pos
-			   (value library-entries) "No entry on current line")))
-
-(defcommand "Describe Library Entry" (p)
-  "Find the file that describes the lisp library entry on the current line."
-  "Find the file that describes the lisp library entry on the current line."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (describe-library-entry (array-element-from-mark (current-point)
-			   (value library-entries) "No entry on current line")))
-
-(defun describe-library-entry (pathname)
-  (let ((lisp-buf (current-buffer))
-	(buffer (view-file-command
-		 nil
-		 (merge-pathnames (make-pathname :type "catalog") pathname))))
-    (push #'(lambda (buffer)
-	      (declare (ignore buffer))
-	      (setf lisp-buf nil))
-	  (buffer-delete-hook lisp-buf))
-    (setf (variable-value 'view-return-function :buffer buffer)
-	  #'(lambda () (if lisp-buf
-			   (change-to-buffer lisp-buf)
-			   (lisp-library-command nil))))))
-
-(defcommand "Load Library Entry" (p)
-  "Loads the current library entry into the current slave."
-  "Loads the current library entry into the current slave."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (string-eval (format nil "(load ~S)"
-		       (namestring (library-entry-load-file nil)))))
-
-(defcommand "Load Pointer Library Entry" (p)
-  "Loads the library entry indicated by the mouse into the current slave."
-  "Loads the library entry indicated by the mouse into the current slave."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (string-eval (format nil "(load ~S)"
-		       (namestring (library-entry-load-file t)))))
-
-(defcommand "Editor Load Library Entry" (p)
-  "Loads the current library entry into the editor Lisp."
-  "Loads the current library entry into the editor Lisp."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (in-lisp (load (library-entry-load-file nil))))
-
-(defcommand "Editor Load Pointer Library Entry" (p)
-  "Loads the library entry indicated by the mouse into the editor Lisp."
-  "Loads the library entry indicated by the mouse into the editor Lisp."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (in-lisp (load (library-entry-load-file t))))
-
-;;; LIBRARY-ENTRY-LOAD-FILE uses the mouse's position or the current point,
-;;; depending on pointerp, to return a file that will load that library entry.
-;;;
-(defun library-entry-load-file (pointerp)
-  (let* ((lib-entries (value library-entries))
-	 (error-msg "No entry on current-line")
-	 (base-name (if pointerp
-			(array-element-from-pointer-pos lib-entries error-msg)
-			(array-element-from-mark (current-point) lib-entries
-						 error-msg)))
-	 (parts (pathname-directory base-name))
-	 (load-name (concatenate 'simple-string
-				 "load-" (elt parts (1- (length parts)))))
-	 (load-pathname (merge-pathnames load-name base-name))
-	 (file-to-load
-	  (or
-	   (probe-file (compile-file-pathname load-pathname))
-	   (probe-file (merge-pathnames (make-pathname :type "fasl")
-					load-pathname))
-	   (probe-file (merge-pathnames (make-pathname :type "lisp")
-					load-pathname))
-	   (probe-file (compile-file-pathname base-name))
-	   (probe-file (merge-pathnames (make-pathname :type "fasl")
-					base-name))
-	   (probe-file (merge-pathnames (make-pathname :type "lisp")
-					base-name)))))
-    (unless file-to-load (editor-error "You'll have to load it yourself."))
-    file-to-load))
-
-(defcommand "Exit Lisp Library" (p)
-  "Exit Lisp-Lib Mode, deleting the buffer when possible."
-  "Exit Lisp-Lib Mode, deleting the buffer when possible."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (delete-buffer-if-possible (getstring "Lisp Library" *buffer-names*)))
-
-(defcommand "Lisp Library Help" (p)
-  "Show this help."
-  "Show this help."
-  (declare (ignore p))
-  (describe-mode-command nil "Lisp-Lib"))
-
Index: anches/ide-1.0/ccl/hemlock/src/overwrite.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/overwrite.lisp	(revision 6568)
+++ 	(revision )
@@ -1,65 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles.
-;;;
-
-(in-package :hemlock)
-
-
-(defmode "Overwrite")
-
-
-(defcommand "Overwrite Mode" (p)
-  "Printing characters overwrite characters instead of pushing them to the right.
-   A positive argument turns Overwrite mode on, while zero or a negative
-   argument turns it off.  With no arguments, it is toggled.  Use C-Q to
-   insert characters normally."
-  "Determine if in Overwrite mode or not and set the mode accordingly."
-  (setf (buffer-minor-mode (current-buffer) "Overwrite")
-	(if p
-	    (plusp p)
-	    (not (buffer-minor-mode (current-buffer) "Overwrite")))))
-
-
-(defcommand "Self Overwrite" (p)
-  "Replace the next character with the last character typed,
-   but insert at end of line.  With prefix argument, do it that many times."
-  "Implements ``Self Overwrite'', calling this function is not meaningful."
-  (let ((char (hemlock-ext:key-event-char *last-key-event-typed*))
-	(point (current-point)))
-    (unless char (editor-error "Can't insert that character."))
-    (do ((n (or p 1) (1- n)))
-	((zerop n))
-      (case (next-character point)
-	(#\tab
-	 (let ((col1 (mark-column point))
-	       (col2 (mark-column (mark-after point))))
-	   (if (= (- col2 col1) 1)
-	       (setf (previous-character point) char)
-	       (insert-character (mark-before point) char))))
-	((#\newline nil) (insert-character point char))
-	(t (setf (next-character point) char)
-	   (mark-after point))))))
-
-
-(defcommand "Overwrite Delete Previous Character" (p)
-  "Replaces previous character with space, but tabs and newlines are deleted.
-   With prefix argument, do it that many times."
-  "Replaces previous character with space, but tabs and newlines are deleted."
-  (do ((point (current-point))
-       (n (or p 1) (1- n)))
-      ((zerop n))
-    (case (previous-character point)
-      ((#\newline #\tab) (delete-characters point -1))
-      ((nil) (editor-error))
-      (t (setf (previous-character point) #\space)
-	 (mark-before point)))))
Index: anches/ide-1.0/ccl/hemlock/src/xcoms.lisp
===================================================================
--- /branches/ide-1.0/ccl/hemlock/src/xcoms.lisp	(revision 6568)
+++ 	(revision )
@@ -1,40 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains commands and support specifically for X related features.
-;;;
-;;; Written by Bill Chiles.
-;;;
-
-(in-package :hemlock)
-
-
-(defcommand "Region to Cut Buffer" (p)
-  "Place the current region into the X cut buffer."
-  "Place the current region into the X cut buffer."
-  (declare (ignore p))
-  (store-cut-string (hi::bitmap-device-display
-		     (hi::device-hunk-device (hi::window-hunk (current-window))))
-		    (region-to-string (current-region))))
-
-(defcommand "Insert Cut Buffer" (p)
-  "Insert the X cut buffer at current point."
-  "Insert the X cut buffer at current point.  Returns nil when it is empty."
-  (declare (ignore p))
-  (let ((str (fetch-cut-string (hi::bitmap-device-display
-				(hi::device-hunk-device
-				 (hi::window-hunk (current-window)))))))
-    (if str
-	(let ((point (current-point)))
-	  (push-buffer-mark (copy-mark point))
-	  (insert-string (current-point) str))
-	(editor-error "X cut buffer empty.")))
-  (setf (last-command-type) :ephemerally-active))