Index: anches/1.2/devel/source/cocoa-ide/hemlock/src/lispmode.lisp
===================================================================
--- /branches/1.2/devel/source/cocoa-ide/hemlock/src/lispmode.lisp	(revision 8153)
+++ 	(revision )
@@ -1,2005 +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$")
-;;;
-;;; **********************************************************************
-;;;
-;;; Hemlock LISP Mode commands
-;;;
-;;; Written by Ivan Vazquez and Bill Maddox.
-;;;
-
-(in-package :hemlock)
-
-;; (declaim (optimize (speed 2))); turn off byte compilation.
-
-
-
-;;;; Variables and lisp-info structure.
-
-;;; These routines are used to define, for standard LISP mode, the start and end
-;;; of a block to parse.  If these need to be changed for a minor mode that sits
-;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the
-;;; name of the function to use instead of START-OF-PARSE-BLOCK and 
-;;; END-OF-PARSE-BLOCK.
-;;; 
-
-(defhvar "Parse Start Function"
-  "Take a mark and move it to the top of a block for paren parsing."
-  :value 'start-of-parse-block)
-
-(defhvar "Parse End Function"
-  "Take a mark and move it to the bottom of a block for paren parsing."
-  :value 'end-of-parse-block)
-
-	    
-;;; LISP-INFO is the structure used to store the data about the line in its
-;;; Plist.
-;;;
-;;;     -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether
-;;;        or not a line's begining and/or ending are quoted.
-;;; 
-;;;     -> RANGES-TO-IGNORE is a list of cons cells, each having the form
-;;;        ( [begining-charpos] [end-charpos] ) each of these cells indicating
-;;;        a range to ignore.  End is exclusive.
-;;; 
-;;;     -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of 
-;;;        unmatched opening and closing parens that there are on a line.
-;;; 
-;;;     -> SIGNATURE-SLOT ...
-;;; 
-
-(defstruct (lisp-info (:constructor make-lisp-info ()))
-  (begins-quoted nil)		; (or t nil)
-  (ending-quoted nil)		; (or t nil)
-  (ranges-to-ignore nil)	; (or t nil)
-  (net-open-parens 0 :type fixnum)
-  (net-close-parens 0 :type fixnum)
-  (signature-slot))
-
-
-
-
-;;;; Macros.
-
-;;; The following Macros exist to make it easy to acces the Syntax primitives
-;;; without uglifying the code.  They were originally written by Maddox.
-;;; 
-
-(defmacro scan-char (mark attribute values)
-  `(find-attribute ,mark ',attribute ,(attr-predicate values)))
-
-(defmacro rev-scan-char (mark attribute values)
-  `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values)))
-
-(defmacro test-char (char attribute values)
-  `(let ((x (character-attribute ',attribute ,char)))
-     ,(attr-predicate-aux values)))
-
-(eval-when (:compile-toplevel :execute :load-toplevel)
-(defun attr-predicate (values)
-  (cond ((eq values 't)
-	 '#'plusp)
-	((eq values 'nil)
-	 '#'zerop)
-	(t `#'(lambda (x) ,(attr-predicate-aux values)))))
-
-(defun attr-predicate-aux (values)
-  (cond ((eq values t)
-	 '(plusp x))
-	((eq values nil)
-	 '(zerop x))
-	((symbolp values)
-	 `(eq x ',values))
-	((and (listp values) (member (car values) '(and or not)))
-	 (cons (car values) (mapcar #'attr-predicate-aux (cdr values))))
-	(t (error "Illegal form in attribute pattern - ~S" values))))
-
-); Eval-When
-
-;;; 
-;;; FIND-LISP-CHAR
-
-(defmacro find-lisp-char (mark)
-  "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL."
-  `(find-attribute ,mark :lisp-syntax
-		   #'(lambda (x)
-		       (member x '(:open-paren :close-paren :newline :comment
-					       :char-quote :string-quote))))) 
-;;; 
-;;; PUSH-RANGE
-
-(defmacro push-range (new-range info-struct)
-  "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT."
-  `(when ,new-range
-     (setf (lisp-info-ranges-to-ignore ,info-struct) 
-	   (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct)))))
-;;; 
-;;; SCAN-DIRECTION
-
-(defmacro scan-direction (mark forwardp &rest forms)
-  "Expand to a form that scans either backward or forward according to Forwardp."
-  (if forwardp
-      `(scan-char ,mark ,@forms)
-      `(rev-scan-char ,mark ,@forms)))
-;;; 
-;;; DIRECTION-CHAR
-
-(defmacro direction-char (mark forwardp)
-  "Expand to a form that returns either the previous or next character according
-  to Forwardp."
-  (if forwardp
-      `(next-character ,mark)
-      `(previous-character ,mark)))
-
-;;; 
-;;; NEIGHBOR-MARK
-
-(defmacro neighbor-mark (mark forwardp)
-  "Expand to a form that moves MARK either backward or forward one character, 
-  depending on FORWARDP."
-  (if forwardp
-      `(mark-after ,mark)
-      `(mark-before ,mark)))
-
-;;; 
-;;; NEIGHBOR-LINE
-
-(defmacro neighbor-line (line forwardp)
-  "Expand to return the next or previous line, according to Forwardp."
-  (if forwardp
-      `(line-next ,line)
-      `(line-previous ,line)))
-
-
-
-;;;; Parsing functions.
-
-;;; PRE-COMMAND-PARSE-CHECK -- Public.
-;;;
-(defun pre-command-parse-check (mark &optional (fer-sure-parse nil))
-  "Parse the area before the command is actually executed."
-  (with-mark ((top mark)
-	      (bottom mark))
-    (funcall (value parse-start-function) top)
-    (funcall (value parse-end-function) bottom)
-    (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))
-
-;;; PARSE-OVER-BLOCK
-;;;
-(defun parse-over-block (start-line end-line &optional (fer-sure-parse nil))
-  "Parse over an area indicated from END-LINE to START-LINE."
-  (let ((test-line start-line)
-	prev-line-info)
-    
-    (with-mark ((mark (mark test-line 0)))
-      
-      ; Set the pre-begining and post-ending lines to delimit the range
-      ; of action any command will take.  This means set the lisp-info of the 
-      ; lines immediately before and after the block to Nil.
-      
-      (when (line-previous start-line)
-	(setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil))
-      (when (line-next end-line)
-	(setf (getf (line-plist (line-next end-line)) 'lisp-info) nil))
-      
-      (loop
-       (let ((line-info (getf (line-plist test-line) 'lisp-info)))
-	 
-	 ;;    Reparse the line when any of the following are true:
-	 ;;
-	 ;;      FER-SURE-PARSE is T
-	 ;;
-	 ;;      LINE-INFO or PREV-LINE-INFO are Nil.
-	 ;;
-	 ;;      If the line begins quoted and the previous one wasn't 
-	 ;;      ended quoted.
-	 ;;
-	 ;;      The Line's signature slot is invalid (the line has changed).
-	 ;;
-	 
-	 (when (or fer-sure-parse      
-		   (not line-info)     
-		   (not prev-line-info)
-		   
-		   (not (eq (lisp-info-begins-quoted line-info) 
-			    (lisp-info-ending-quoted prev-line-info)))
-		   
-		   (not (eql (line-signature test-line)     
-			     (lisp-info-signature-slot line-info))))
-	   
-	   (move-to-position mark 0 test-line)
-	   
-	   (unless line-info
-	     (setf line-info (make-lisp-info))
-	     (setf (getf (line-plist test-line) 'lisp-info) line-info))
-	   
-	   (parse-lisp-line-info mark line-info prev-line-info))
-	 
-	 (when (eq end-line test-line)
-	   (return nil))
-	 
-	 (setq prev-line-info line-info)
-	 
-	 (setq test-line (line-next test-line)))))))
-
-
-
-;;;; Parse block finders.
-
-(defhvar "Minimum Lines Parsed"
-  "The minimum number of lines before and after the point parsed by Lisp mode."
-  :value 50)
-(defhvar "Maximum Lines Parsed"
-  "The maximum number of lines before and after the point parsed by Lisp mode."
-  :value 500)
-(defhvar "Defun Parse Goal"
-  "Lisp mode parses the region obtained by skipping this many defuns forward
-   and backward from the point unless this falls outside of the range specified
-   by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"."
-  :value 2)
-
-
-(macrolet ((frob (step end)
-	     `(let ((min (value minimum-lines-parsed))
-		    (max (value maximum-lines-parsed))
-		    (goal (value defun-parse-goal))
-		    (last-defun nil))
-		(declare (fixnum min max goal))
-		(do ((line (mark-line mark) (,step line))
-		     (count 0 (1+ count)))
-		    ((null line)
-		     (,end mark))
-		  (declare (fixnum count))
-		  (when (char= (line-character line 0) #\()
-		    (setq last-defun line)
-		    (decf goal)
-		    (when (and (<= goal 0) (>= count min))
-		      (line-start mark line)
-		      (return)))
-		  (when (> count max)
-		    (line-start mark (or last-defun line))
-		    (return))))))
-
-  (defun start-of-parse-block (mark)
-    (frob line-previous buffer-start))
-
-  (defun end-of-parse-block (mark)
-    (frob line-next buffer-end)))
-
-;;; 
-;;; START-OF-SEARCH-LINE
-
-(defun start-of-search-line (line)
-  "Set LINE to the begining line of the block of text to parse."
-  (with-mark ((mark (mark line 0)))
-    (funcall (value 'Parse-Start-Function) mark)
-    (setq line (mark-line mark))))
-
-;;; 
-;;; END-OF-SEACH-LINE
-
-(defun end-of-search-line (line)
-  "Set LINE to the ending line of the block of text to parse."
-  (with-mark ((mark (mark line 0)))
-    (funcall (value 'Parse-End-Function) mark)
-    (setq line (mark-line mark))))
-
-
-
-;;;; PARSE-LISP-LINE-INFO.
-
-;;; PARSE-LISP-LINE-INFO -- Internal.
-;;;
-;;; This parses through the line doing the following things:
-;;;
-;;;      Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
-;;;
-;;;      Making all areas of the line that should be invalid (comments,
-;;;      char-quotes, and the inside of strings) and such be in
-;;;      RANGES-TO-IGNORE.
-;;;
-;;;      Set BEGINS-QUOTED and ENDING-QUOTED 
-;;;
-(defun parse-lisp-line-info (mark line-info prev-line-info)
-  "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
-   RANGES-TO-INGORE, and ENDING-QUOTED."
-  (let ((net-open-parens 0)
-	(net-close-parens 0))
-    (declare (fixnum net-open-parens net-close-parens))
-    
-    ;; Re-set the slots necessary
-    
-    (setf (lisp-info-ranges-to-ignore line-info) nil)
-    
-    ;; The only way the current line begins quoted is when there
-    ;; is a previous line and it's ending was quoted.
-    
-    (setf (lisp-info-begins-quoted line-info)
-	  (and prev-line-info 
-	       (lisp-info-ending-quoted prev-line-info)))
-    
-    (if (lisp-info-begins-quoted line-info)
-	(deal-with-string-quote mark line-info)
-	(setf (lisp-info-ending-quoted line-info) nil))
-    
-    (unless (lisp-info-ending-quoted line-info)
-      (loop 
-	(find-lisp-char mark)
-	(ecase (character-attribute :lisp-syntax (next-character mark))
-	  
-	  (:open-paren
-	   (setq net-open-parens (1+ net-open-parens))
-	   (mark-after mark))
-	  
-	  (:close-paren
-	   (if (zerop net-open-parens)
-	       (setq net-close-parens (1+ net-close-parens))
-	       (setq net-open-parens (1- net-open-parens)))
-	   (mark-after mark))
-	  
-	  (:newline
-	   (setf (lisp-info-ending-quoted line-info) nil)
-	   (return t))
-	  
-	  (:comment
-	   (push-range (cons (mark-charpos mark) (line-length (mark-line mark)))
-		       line-info)
-	   (setf (lisp-info-ending-quoted line-info) nil)
-	   (return t))
-	  
-	  (:char-quote
-	   (mark-after mark)
-	   (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark)))
-		       line-info)
-	   (mark-after mark))
-	  
-	  (:string-quote
-	   (mark-after mark)
-	   (unless (deal-with-string-quote mark line-info)
-	     (setf (lisp-info-ending-quoted line-info) t)
-	     (return t))))))
-    
-    (setf (lisp-info-net-open-parens line-info) net-open-parens)
-    (setf (lisp-info-net-close-parens line-info) net-close-parens)
-    (setf (lisp-info-signature-slot line-info) 
-	  (line-signature (mark-line mark)))))
-
-
-
-
-;;;; String quote utilities.
-
-;;; VALID-STRING-QUOTE-P
-;;;
-(defmacro valid-string-quote-p (mark forwardp)
-  "Return T if the string-quote indicated by MARK is valid."
-  (let ((test-mark (gensym)))
-    `(with-mark ((,test-mark ,mark))
-       ,(unless forwardp
-	  ;; TEST-MARK should always be right before the String-quote to be
-	  ;; checked.
-	  `(mark-before ,test-mark))
-       (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
-	 (let ((slash-count 0))
-	   (loop
-	     (mark-before ,test-mark)
-	     (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
-		 (incf slash-count)
-		 (return t)))
-	   (not (oddp slash-count)))))))
-
-;;; 
-;;; FIND-VALID-STRING-QUOTE
-
-(defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil))
-  "Expand to a form that will leave MARK before a valid string-quote character,
-  in either a forward or backward direction, according to FORWARDP.  If 
-  CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
-  valid string-quote."
-  (let ((e-mark (gensym)))
-    `(with-mark ((,e-mark ,mark))
-       
-       (loop
-	(unless (scan-direction ,e-mark ,forwardp :lisp-syntax 
-				,(if cease-at-eol 
-				     `(or :newline :string-quote)
-				     `:string-quote))
-	  (return nil))
-	
-	,@(if cease-at-eol
-	      `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
-				 :newline)
-		  (return nil))))
-	
-	(when (valid-string-quote-p ,e-mark ,forwardp)
-	  (move-mark ,mark ,e-mark)
-	  (return t))
-	
-	(neighbor-mark ,e-mark ,forwardp)))))
-
-
-;;;; DEAL-WITH-STRING-QUOTE.
-
-;;; DEAL-WITH-STRING-QUOTE
-;;;
-;;; Called when a string is begun (i.e. parse hits a #\").  It checks for a
-;;; matching quote on the line that MARK points to, and puts the appropriate
-;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area.
-;;; The "appropriate area" is from MARK to the end of the line or the matching
-;;; string-quote, whichever comes first.
-;;;
-(defun deal-with-string-quote (mark info-struct)
-  "Alter the current line's info struct as necessary as due to encountering a
-   string quote character."
-  (with-mark ((e-mark mark))
-    (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
-	   ;; If matching quote is on this line then mark the area between the
-	   ;; first quote (MARK) and the matching quote as invalid by pushing
-	   ;; its begining and ending into the IGNORE-RANGE.
-	   (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
-		       info-struct)
-	   (setf (lisp-info-ending-quoted info-struct) nil)
-	   (mark-after e-mark)
-	   (move-mark mark e-mark))
-	  ;; If the EOL has been hit before the matching quote then mark the
-	  ;; area from MARK to the EOL as invalid.
-	  (t
-	   (push-range (cons (mark-charpos mark)
-			     (1+ (line-length (mark-line mark))))
-		       info-struct)
-	   ;; The Ending is marked as still being quoted. 
-	   (setf (lisp-info-ending-quoted info-struct) t)
-	   (line-end mark)
-	   nil))))
-
-
-
-
-;;;; Character validity checking:
-
-;;; Find-Ignore-Region  --  Internal
-;;;
-;;;    If the character in the specified direction from Mark is in an ignore
-;;; region, then return the region and the line that the region is in as
-;;; values.  If there is no ignore region, then return NIL and the Mark-Line.
-;;; If the line is not parsed, or there is no character (because of being at
-;;; the buffer beginning or end), then return both values NIL.
-;;;
-(defun find-ignore-region (mark forwardp)
-  (flet ((scan (line pos)
-	   (declare (fixnum pos))
-	   (let ((info (getf (line-plist line) 'lisp-info)))
-	     (if info
-		 (dolist (range (lisp-info-ranges-to-ignore info)
-				(values nil line))
-		   (let ((start (car range))
-			 (end (cdr range)))
-		     (declare (fixnum start end))
-		     (when (and (>= pos start) (< pos end))
-		       (return (values range line)))))
-		 (values nil nil)))))
-    (let ((pos (mark-charpos mark))
-	  (line (mark-line mark)))
-      (declare (fixnum pos))
-      (cond (forwardp (scan line pos))
-	    ((> pos 0) (scan line (1- pos)))
-	    (t
-	     (let ((prev (line-previous line)))
-	       (if prev
-		   (scan prev (line-length prev))
-		   (values nil nil))))))))
-
-
-;;; Valid-Spot  --  Public
-;;;
-(defun valid-spot (mark forwardp)
-  "Return true if the character pointed to by Mark is not in a quoted context,
-  false otherwise.  If Forwardp is true, we use the next character, otherwise
-  we use the previous."
-  (multiple-value-bind (region line)
-		       (find-ignore-region mark forwardp)
-    (and line (not region))))
-
-
-;;; Scan-Direction-Valid  --  Internal
-;;;
-;;;    Like scan-direction, but only stop on valid characters.
-;;;
-(defmacro scan-direction-valid (mark forwardp &rest forms)
-  (let ((n-mark (gensym))
-	(n-line (gensym))
-	(n-region (gensym))
-	(n-won (gensym)))
-    `(let ((,n-mark ,mark) (,n-won nil))
-       (loop
-	 (multiple-value-bind (,n-region ,n-line)
-			      (find-ignore-region ,n-mark ,forwardp)
-	   (unless ,n-line (return nil))
-	   (if ,n-region
-	       (move-to-position ,n-mark
-				 ,(if forwardp
-				      `(cdr ,n-region) 
-				      `(car ,n-region))
-				 ,n-line)
-	       (when ,n-won (return t)))
-	   ;;
-	   ;; Peculiar condition when a quoting character terminates a line.
-	   ;; The ignore region is off the end of the line causing %FORM-OFFSET
-	   ;; to infinitely loop.
-	   (when (> (mark-charpos ,n-mark) (line-length ,n-line))
-	     (line-offset ,n-mark 1 0))
-	   (unless (scan-direction ,n-mark ,forwardp ,@forms)
-	     (return nil))
-	   (setq ,n-won t))))))
-
-
-
-;;;; List offseting.
-
-;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
-;;; with the same existing structure, with the altering of one variable.
-;;; This one variable being FORWARDP.
-;;; 
-(defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
-  "Expand to code that will go forward one list either backward or forward, 
-   according to the FORWARDP flag."
-  (let ((mark (gensym)))
-    `(let ((paren-count ,extra-parens))
-       (declare (fixnum paren-count))
-       (with-mark ((,mark ,actual-mark))
-	 (loop
-	   (scan-direction ,mark ,forwardp :lisp-syntax
-			   (or :close-paren :open-paren :newline))
-	   (let ((ch (direction-char ,mark ,forwardp)))
-	     (unless ch (return nil))
-	     (when (valid-spot ,mark ,forwardp)
-	       (case (character-attribute :lisp-syntax ch)
-		 (:close-paren
-		  (decf paren-count)
-		  ,(when forwardp
-		     ;; When going forward, an unmatching close-paren means the
-		     ;; end of list.
-		     `(when (<= paren-count 0)
-			(neighbor-mark ,mark ,forwardp)
-			(move-mark ,actual-mark ,mark)
-			(return t))))
-		 (:open-paren
-		  (incf paren-count)
-		  ,(unless forwardp             ; Same as above only end of list
-		     `(when (>= paren-count 0)  ; is opening parens.
-			(neighbor-mark ,mark ,forwardp)
-			(move-mark ,actual-mark ,mark)
-			(return t))))
-		 
-		 (:newline 
-		  ;; When a #\Newline is hit, then the matching paren must lie
-		  ;; on some other line so drop down into the multiple line
-		  ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren
-		  ;; seen yet, keep going.
-		  (cond ((zerop paren-count))
-			((quest-for-balancing-paren ,mark paren-count ,forwardp)
-			 (move-mark ,actual-mark ,mark)
-			 (return t))
-			(t
-			 (return nil)))))))
-	   
-	   (neighbor-mark ,mark ,forwardp))))))
-
-;;; 
-;;; QUEST-FOR-BALANCING-PAREN
-
-(defmacro quest-for-balancing-paren (mark paren-count forwardp)
-  "Expand to a form that finds the the balancing paren for however many opens or
-  closes are registered by Paren-Count."
-  `(let* ((line (mark-line ,mark)))
-     (loop
-       (setq line (neighbor-line line ,forwardp))
-       (unless line (return nil))
-       (let ((line-info (getf (line-plist line) 'lisp-info))
-	     (unbal-paren ,paren-count))
-	 (unless line-info (return nil))
-	 
-	 ,(if forwardp
-	      `(decf ,paren-count (lisp-info-net-close-parens line-info))
-	      `(incf ,paren-count (lisp-info-net-open-parens line-info)))
-	 
-	 (when ,(if forwardp
-		    `(<= ,paren-count 0)
-		    `(>= ,paren-count 0))
-	   ,(if forwardp
-		`(line-start ,mark line)
-		`(line-end ,mark line))
-	   (return (goto-correct-paren-char ,mark unbal-paren ,forwardp)))
-
-	 ,(if forwardp
-	      `(incf ,paren-count (lisp-info-net-open-parens line-info))
-	      `(decf ,paren-count (lisp-info-net-close-parens line-info)))))))
-		   
-
-;;; 
-;;; GOTO-CORRECT-PAREN-CHAR
-
-(defmacro goto-correct-paren-char (mark paren-count forwardp)
-  "Expand to a form that will leave MARK on the correct balancing paren matching 
-   however many are indicated by COUNT." 
-  `(with-mark ((m ,mark))
-     (let ((count ,paren-count))
-       (loop
-	 (scan-direction m ,forwardp :lisp-syntax 
-			 (or :close-paren :open-paren :newline))
-	 (when (valid-spot m ,forwardp)
-	   (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
-	     (:close-paren 
-	      (decf count)
-	      ,(when forwardp
-		 `(when (zerop count)
-		    (neighbor-mark m ,forwardp)
-		    (move-mark ,mark m)
-		    (return t))))
-	     
-	     (:open-paren 
-	      (incf count)
-	      ,(unless forwardp
-		 `(when (zerop count)
-		    (neighbor-mark m ,forwardp)
-		    (move-mark ,mark m)
-		    (return t))))))
-	 (neighbor-mark m ,forwardp)))))
-
-
-(defun list-offset (mark offset)
-  (if (plusp offset)
-      (dotimes (i offset t)
-	(unless (%list-offset mark t) (return nil)))
-      (dotimes (i (- offset) t)
-	(unless (%list-offset mark nil) (return nil)))))
-
-(defun forward-up-list (mark)
-  "Moves mark just past the closing paren of the immediately containing list."
-  (%list-offset mark t :extra-parens 1))
-
-(defun backward-up-list (mark)
-  "Moves mark just before the opening paren of the immediately containing list."
-  (%list-offset mark nil :extra-parens -1))
-
-
-
-
-;;;; Top level form location hacks (open parens beginning lines).
-
-;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET.
-;;; 
-(eval-when (:compile-toplevel :execute)
-(defmacro neighbor-top-level (line forwardp)
-  `(loop
-     (when (test-char (line-character ,line 0) :lisp-syntax :open-paren)
-       (return t))
-     (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line)))
-     (unless ,line (return nil))))
-) ;eval-when
-
-(defun top-level-offset (mark offset)
-  "Go forward or backward offset number of top level forms.  Mark is
-   returned if offset forms exists, otherwise nil."
-  (declare (fixnum offset))
-  (let* ((line (mark-line mark))
-	 (at-start (test-char (line-character line 0) :lisp-syntax :open-paren)))
-    (cond ((zerop offset) mark)
-	  ((plusp offset)
-	   (do ((offset (if at-start offset (1- offset))
-			(1- offset)))
-	       (nil)
-	     (declare (fixnum offset))
-	     (unless (neighbor-top-level line t) (return nil))
-	     (when (zerop offset) (return (line-start mark line)))
-	     (unless (setf line (line-next line)) (return nil))))
-	  (t
-	   (do ((offset (if (and at-start (start-line-p mark))
-			    offset
-			    (1+ offset))
-			(1+ offset)))
-		(nil)
-	     (declare (fixnum offset))
-	     (unless (neighbor-top-level line nil) (return nil))
-	     (when (zerop offset) (return (line-start mark line)))
-	     (unless (setf line (line-previous line)) (return nil)))))))
-
-
-(defun mark-top-level-form (mark1 mark2)
-  "Moves mark1 and mark2 to the beginning and end of the current or next defun.
-   Mark1 one is used as a reference.  The marks may be altered even if
-   unsuccessful.  if successful, return mark2, else nil."
-  (let ((winp (cond ((inside-defun-p mark1)
-		     (cond ((not (top-level-offset mark1 -1)) nil)
-			   ((not (form-offset (move-mark mark2 mark1) 1)) nil)
-			   (t mark2)))
-		    ((start-defun-p mark1)
-		     (form-offset (move-mark mark2 mark1) 1))
-		    ((and (top-level-offset (move-mark mark2 mark1) -1)
-			  (start-defun-p mark2)
-			  (form-offset mark2 1)
-			  (same-line-p mark1 mark2))
-		     (form-offset (move-mark mark1 mark2) -1)
-		     mark2)
-		    ((top-level-offset mark1 1)
-		     (form-offset (move-mark mark2 mark1) 1)))))
-    (when winp
-      (when (blank-after-p mark2) (line-offset mark2 1 0))
-      mark2)))
-
-(defun inside-defun-p (mark)
-  "T if the current point is (supposedly) in a top level form."
-  (with-mark ((m mark))
-    (when (top-level-offset m -1)
-      (form-offset m 1)
-      (mark> m mark))))
-
-(defun start-defun-p (mark)
-  "Returns t if mark is sitting before an :open-paren at the beginning of a
-   line."
-  (and (start-line-p mark)
-       (test-char (next-character mark) :lisp-syntax :open-paren)))
-
-
-
-
-;;;; Form offseting.
-
-(defmacro %form-offset (mark forwardp)
-  `(with-mark ((m ,mark))
-     (when (scan-direction-valid m ,forwardp :lisp-syntax
-				 (or :open-paren :close-paren
-				     :char-quote :string-quote
-				     :constituent))
-       (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
-	 (:open-paren
-	  (when ,(if forwardp `(list-offset m 1) `(mark-before m))
-	    ,(unless forwardp
-	       '(scan-direction m nil :lisp-syntax (not :prefix)))
-	    (move-mark ,mark m)
-	    t))
-	 (:close-paren
-	  (when ,(if forwardp `(mark-after m) `(list-offset m -1))
-	    ,(unless forwardp
-	       '(scan-direction m nil :lisp-syntax (not :prefix)))
-	    (move-mark ,mark m)
-	    t))
-	 ((:constituent :char-quote)
-	  (scan-direction-valid m ,forwardp :lisp-syntax
-				(not (or :constituent :char-quote)))
-	  ,(if forwardp
-	       `(scan-direction-valid m t :lisp-syntax
-				      (not (or :constituent :char-quote)))
-	       `(scan-direction-valid m nil :lisp-syntax
-				      (not (or :constituent :char-quote
-					       :prefix))))
-	  (move-mark ,mark m)
-	  t)
-	 (:string-quote
-	  (cond ((valid-spot m ,(not forwardp))
-		 (neighbor-mark m ,forwardp)
-		 (when (scan-direction-valid m ,forwardp :lisp-syntax
-					     :string-quote)
-		   (neighbor-mark m ,forwardp)
-		   (move-mark ,mark m)
-		   t))
-		(t (neighbor-mark m ,forwardp)
-		   (move-mark ,mark m)
-		   t)))))))
-
-
-(defun form-offset (mark offset)
-  "Move mark offset number of forms, after if positive, before if negative.
-   Mark is always moved.  If there weren't enough forms, returns nil instead of
-   mark."
-  (if (plusp offset)
-      (dotimes (i offset t)
-	(unless (%form-offset mark t) (return nil)))
-      (dotimes (i (- offset) t)
-	(unless (%form-offset mark nil) (return nil)))))
-
-
-
-
-;;;; Table of special forms with special indenting requirements.
-
-(defhvar "Indent Defanything"
-  "This is the number of special arguments implicitly assumed to be supplied
-   in calls to functions whose names begin with \"DEF\".  If set to NIL, this
-   feature is disabled."
-  :value 2)
-
-(defvar *special-forms* (make-hash-table :test #'equal))
-
-(defun defindent (fname args)
-  "Define Fname to have Args special arguments.  If args is null then remove
-   any special arguments information."
-  (check-type fname string)
-  (let ((fname (string-upcase fname)))
-    (cond ((null args) (remhash fname *special-forms*))
-	  (t
-	   (check-type args integer)
-	   (setf (gethash fname *special-forms*) args)))))
-
-
-;;; Hemlock forms.
-;;; 
-(defindent "with-mark" 1)
-(defindent "with-random-typeout" 1)
-(defindent "with-pop-up-display" 1)
-(defindent "defhvar" 1)
-(defindent "hlet" 1)
-(defindent "defcommand" 2)
-(defindent "defattribute" 1)
-(defindent "command-case" 1)
-(defindent "with-input-from-region" 1)
-(defindent "with-output-to-mark" 1)
-(defindent "with-output-to-window" 1)
-(defindent "do-strings" 1)
-(defindent "save-for-undo" 1)
-(defindent "do-alpha-chars" 1)
-(defindent "do-headers-buffers" 1)
-(defindent "do-headers-lines" 1)
-(defindent "with-headers-mark" 1)
-(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
-(defindent "with-writable-buffer" 1)
-
-;;; Common Lisp forms.
-;;; 
-(defindent "block" 1)
-(defindent "case" 1)
-(defindent "catch" 1)
-(defindent "ccase" 1)			   
-(defindent "compiler-let" 1)
-(defindent "ctypecase" 1)
-(defindent "defconstant" 1)
-(defindent "define-compiler-macro" 2)
-(defindent "define-setf-method" 2)
-(defindent "destructuring-bind" 2)
-(defindent "defmacro" 2)
-(defindent "defpackage" 1)
-(defindent "defparameter" 1)
-(defindent "defstruct" 1)
-(defindent "deftype" 2)
-(defindent "defun" 2)
-(defindent "defvar" 1)
-(defindent "do" 2)
-(defindent "do*" 2)
-(defindent "do-all-symbols" 1)
-(defindent "do-external-symbols" 1)
-(defindent "do-symbols" 1)
-(defindent "dolist" 1)
-(defindent "dotimes" 1)
-(defindent "ecase" 1)
-(defindent "etypecase" 1)
-(defindent "eval-when" 1)
-(defindent "flet" 1)
-(defindent "if" 1)
-(defindent "labels" 1)
-(defindent "lambda" 1)
-(defindent "let" 1)
-(defindent "let*" 1)
-(defindent "locally" 0)
-(defindent "loop" 0)
-(defindent "macrolet" 1)
-(defindent "multiple-value-bind" 2)
-(defindent "multiple-value-call" 1)
-(defindent "multiple-value-prog1" 1)
-(defindent "multiple-value-setq" 1)
-(defindent "prog1" 1)
-(defindent "progv" 2)
-(defindent "progn" 0)
-(defindent "typecase" 1)
-(defindent "unless" 1)
-(defindent "unwind-protect" 1)
-(defindent "when" 1)
-(defindent "with-input-from-string" 1)
-(defindent "with-open-file" 1)
-(defindent "with-open-stream" 1)
-(defindent "with-output-to-string" 1)
-(defindent "with-package-iterator" 1)
-
-;;; Error/condition system forms.
-;;; 
-(defindent "define-condition" 2)
-(defindent "handler-bind" 1)
-(defindent "handler-case" 1)
-(defindent "restart-bind" 1)
-(defindent "restart-case" 1)
-(defindent "with-simple-restart" 1)
-;;; These are for RESTART-CASE branch formatting.
-(defindent "store-value" 1)
-(defindent "use-value" 1)
-(defindent "muffle-warning" 1)
-(defindent "abort" 1)
-(defindent "continue" 1)
-
-;;; Debug-internals forms.
-;;;
-(defindent "do-debug-function-blocks" 1)
-(defindent "di:do-debug-function-blocks" 1)
-(defindent "do-debug-function-variables" 1)
-(defindent "di:do-debug-function-variables" 1)
-(defindent "do-debug-block-locations" 1)
-(defindent "di:do-debug-block-locations" 1)
-;;;
-;;; Debug-internals conditions
-;;; (define these to make uses of HANDLER-CASE indent branches correctly.)
-;;;
-(defindent "debug-condition" 1)
-(defindent "di:debug-condition" 1)
-(defindent "no-debug-info" 1)
-(defindent "di:no-debug-info" 1)
-(defindent "no-debug-function-returns" 1)
-(defindent "di:no-debug-function-returns" 1)
-(defindent "no-debug-blocks" 1)
-(defindent "di:no-debug-blocks" 1)
-(defindent "lambda-list-unavailable" 1)
-(defindent "di:lambda-list-unavailable" 1)
-(defindent "no-debug-variables" 1)
-(defindent "di:no-debug-variables" 1)
-(defindent "invalid-value" 1)
-(defindent "di:invalid-value" 1)
-(defindent "ambiguous-variable-name" 1)
-(defindent "di:ambiguous-variable-name" 1)
-(defindent "debug-error" 1)
-(defindent "di:debug-error" 1)
-(defindent "unhandled-condition" 1)
-(defindent "di:unhandled-condition" 1)
-(defindent "unknown-code-location" 1)
-(defindent "di:unknown-code-location" 1)
-(defindent "unknown-debug-variable" 1)
-(defindent "di:unknown-debug-variable" 1)
-(defindent "invalid-control-stack-pointer" 1)
-(defindent "di:invalid-control-stack-pointer" 1)
-(defindent "frame-function-mismatch" 1)
-(defindent "di:frame-function-mismatch" 1)
-
-
-;;; CLOS forms.
-;;; 
-(defindent "with-slots" 1)
-(defindent "with-accessors" 2)
-(defindent "defclass" 2)
-(defindent "print-unreadable-object" 1)
-(defindent "defmethod" 2)
-(defindent "make-instance" 1)
-
-;;; System forms.
-;;;
-(defindent "rlet" 1)
-
-;;; Multiprocessing forms.
-(defindent "with-lock-grabbed" 1)
-(defindent "process-wait" 1)
-
-
-
-
-;;;; Indentation.
-
-;;; LISP-INDENTATION -- Internal Interface.
-
-(defun strip-package-prefix (string)
-  (let* ((p (position #\: string :from-end t)))
-    (if p
-      (subseq string (1+ p))
-      string)))
-;;;
-(defun lisp-indentation (mark)
-  "Compute number of spaces which mark should be indented according to
-   local context and lisp grinding conventions.  This assumes mark is at the
-   beginning of the line to be indented."
-  (with-mark ((m mark)
-	      (temp mark))
-    ;; See if we are in a quoted context.
-    (unless (valid-spot m nil)
-      (return-from lisp-indentation (lisp-generic-indentation m)))
-    ;; Look for the paren that opens the containing form.
-    (unless (backward-up-list m)
-      (return-from lisp-indentation 0))
-    ;; Move after the paren, save the start, and find the form name.
-    (mark-after m)
-    (with-mark ((start m))
-      (unless (and (scan-char m :lisp-syntax
-			      (not (or :space :prefix :char-quote)))
-		   (test-char (next-character m) :lisp-syntax :constituent))
-	(return-from lisp-indentation (mark-column start)))
-      (with-mark ((fstart m))
-	(scan-char m :lisp-syntax (not :constituent))
-	(let* ((fname (nstring-upcase
-                       (strip-package-prefix (region-to-string (region fstart m)))))
-	       (special-args (or (gethash fname *special-forms*)
-				 (and (> (length fname) 2)
-				      (string= fname "DEF" :end1 3)
-				      (value indent-defanything)))))
-	  (declare (simple-string fname))
-	  ;; Now that we have the form name, did it have special syntax?
-	  (cond (special-args
-		 (with-mark ((spec m))
-		   (cond ((and (form-offset spec special-args)
-			       (mark<= spec mark))
-			  (1+ (mark-column start)))
-			 ((skip-valid-space m)
-			  (mark-column m))
-			 (t
-			  (+ (mark-column start) 3)))))
-		;; See if the user seems to have altered the editor's
-		;; indentation, and if so, try to adhere to it.  This usually
-		;; happens when you type in a quoted list constant that line
-		;; wraps.  You want all the items on successive lines to fall
-		;; under the first character after the opening paren, not as if
-		;; you are calling a function.
-		((and (form-offset temp -1)
-		      (or (blank-before-p temp) (not (same-line-p temp fstart)))
-		      (not (same-line-p temp mark)))
-		 (unless (blank-before-p temp)
-		   (line-start temp)
-		   (find-attribute temp :space #'zerop))
-		 (mark-column temp))
-		;; Appears to be a normal form.  Is the first arg on the same
-		;; line as the form name?
-		((skip-valid-space m)
-		 (or (lisp-indentation-check-for-local-def
-		      mark temp fstart start t)
-		     (mark-column m)))
-		;; Okay, fall under the first character after the opening paren.
-		(t
-		 (or (lisp-indentation-check-for-local-def
-		      mark temp fstart start nil)
-		     (mark-column start)))))))))
-
-(defhvar "Lisp Indentation Local Definers"
-  "Forms with syntax like LABELS, MACROLET, etc."
-  :value '("LABELS" "MACROLET" "FLET"))
-
-;;; LISP-INDENTATION-CHECK-FOR-LOCAL-DEF -- Internal.
-;;;
-;;; This is a temporary hack to see how it performs.  When we are indenting
-;;; what appears to be a function call, let's look for FLET or MACROLET to see
-;;; if we really are indenting a local definition.  If we are, return the
-;;; indentation for a DEFUN; otherwise, nil
-;;;
-;;; Mark is the argument to LISP-INDENTATION.  Start is just inside the paren
-;;; of what looks like a function call.  If we are in an FLET, arg-list
-;;; indicates whether the local function's arg-list has been entered, that is,
-;;; whether we need to normally indent for a DEFUN body or indent specially for
-;;; the arg-list.
-;;;
-(defun lisp-indentation-check-for-local-def (mark temp1 temp2 start arg-list)
-  ;; We know this succeeds from LISP-INDENTATION.
-  (backward-up-list (move-mark temp1 mark)) ;Paren for local definition.
-  (cond ((and (backward-up-list temp1)	    ;Paren opening the list of defs
-	      (form-offset (move-mark temp2 temp1) -1)
-	      (mark-before temp2)
-	      (backward-up-list temp1)	    ;Paren for FLET or MACROLET.
-	      (mark= temp1 temp2))	    ;Must be in first arg form.
-	 ;; See if the containing form is named FLET or MACROLET.
-	 (mark-after temp1)
-	 (unless (and (scan-char temp1 :lisp-syntax
-				 (not (or :space :prefix :char-quote)))
-		      (test-char (next-character temp1) :lisp-syntax
-				 :constituent))
-	   (return-from lisp-indentation-check-for-local-def nil))
-	 (move-mark temp2 temp1)
-	 (scan-char temp2 :lisp-syntax (not :constituent))
-	 (let ((fname (nstring-upcase (region-to-string (region temp1 temp2)))))
-	   (cond ((not (member fname (value lisp-indentation-local-definers)
-			       :test #'string=))
-		  nil)
-		 (arg-list
-		  (1+ (mark-column start)))
-		 (t
-		  (+ (mark-column start) 3)))))))
-
-;;; LISP-GENERIC-INDENTATION -- Internal.
-;;;
-;;; LISP-INDENTATION calls this when mark is in a invalid spot, or quoted
-;;; context.  If we are inside a string, we return the column one greater
-;;; than the opening double quote.  Otherwise, we just use the indentation
-;;; of the first preceding non-blank line.
-;;;
-(defun lisp-generic-indentation (mark)
-  (with-mark ((m mark))
-    (form-offset m -1)
-    (cond ((eq (character-attribute :lisp-syntax (next-character m))
-	       :string-quote)
-	   (1+ (mark-column m)))
-	  (t
-	   (let* ((line (mark-line mark))
-		  (prev (do ((line (line-previous line) (line-previous line)))
-			    ((not (and line (blank-line-p line))) line))))
-	     (cond (prev
-		    (line-start mark prev)
-		    (find-attribute mark :space #'zerop)
-		    (mark-column mark))
-		   (t 0)))))))
-
-;;; Skip-Valid-Space  --  Internal
-;;;
-;;;    Skip over any space on the line Mark is on, stopping at the first valid
-;;; non-space character.  If there is none on the line, return nil.
-;;;
-(defun skip-valid-space (mark)
-  (loop
-    (scan-char mark :lisp-syntax (not :space))
-    (let ((val (character-attribute :lisp-syntax
-				    (next-character mark))))
-      (cond ((eq val :newline) (return nil))
-	    ((valid-spot mark t) (return mark))))
-    (mark-after mark)))
-
-;; (declaim (optimize (speed 0))); byte compile again
-
-
-
-;;;; Indentation commands and hook functions.
-
-(defcommand "Defindent" (p)
-  "Define the Lisp indentation for the current function.
-  The indentation is a non-negative integer which is the number
-  of special arguments for the form.  Examples: 2 for Do, 1 for Dolist.
-  If a prefix argument is supplied, then delete the indentation information."
-  "Do a defindent, man!"
-  (with-mark ((m (current-point)))
-    (pre-command-parse-check m)
-    (unless (backward-up-list m) (editor-error))
-    (mark-after m)
-    (with-mark ((n m))
-      (scan-char n :lisp-syntax (not :constituent))
-      (let ((s (region-to-string (region m n))))
-	(declare (simple-string s))
-	(when (zerop (length s)) (editor-error))
-	(if p
-	    (defindent s nil)
-	    (let ((i (prompt-for-integer
-		      :prompt (format nil "Indentation for ~A: " s)
-		      :help "Number of special arguments.")))
-	      (when (minusp i)
-		(editor-error "Indentation must be non-negative."))
-	      (defindent s i))))))
-  (indent-command nil))
-
-(defcommand "Indent Form" (p)
-  "Indent Lisp code in the next form."
-  "Indent Lisp code in the next form."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((m point))
-      (unless (form-offset m 1) (editor-error))
-      (lisp-indent-region (region point m) "Indent Form"))))
-
-;;; LISP-INDENT-REGION -- Internal.
-;;;
-;;; This indents a region of Lisp code without doing excessive redundant
-;;; computation.  We parse the entire region once, then scan through doing
-;;; indentation on each line.  We forcibly reparse each line that we indent so
-;;; that the list operations done to determine indentation of subsequent lines
-;;; will work.  This is done undoably with save1, save2, buf-region, and
-;;; undo-region.
-;;;
-(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))  (let* ((start (region-start region))
-         (end (region-end region))
-         (buffer (hi::line-%buffer (mark-line start))))
-    (with-mark ((m1 start)
-		(m2 end))
-      (funcall (value parse-start-function) m1)
-      (funcall (value parse-end-function) m2)
-      (parse-over-block (mark-line m1) (mark-line m2)))
-    (hi::check-buffer-modification buffer start)
-    (hi::check-buffer-modification buffer end)
-    (let* ((first-line (mark-line start))
-              (last-line (mark-line end))
-              (prev (line-previous first-line))
-              (prev-line-info
-               (and prev (getf (line-plist prev) 'lisp-info)))
-              (save1 (line-start (copy-mark start :right-inserting)))
-              (save2 (line-end (copy-mark end :left-inserting)))
-              (buf-region (region save1 save2))
-              (undo-region (copy-region buf-region)))
-         (with-mark ((bol start :left-inserting))
-           (do ((line first-line (line-next line)))
-               (nil)
-             (line-start bol line)
-             (ensure-lisp-indentation bol)
-             (let ((line-info (getf (line-plist line) 'lisp-info)))
-               (parse-lisp-line-info bol line-info prev-line-info)
-               (setq prev-line-info line-info))
-             (when (eq line last-line) (return nil))))
-         (make-region-undo :twiddle undo-text buf-region undo-region))))
-
-;;; INDENT-FOR-LISP -- Internal.
-;;;
-;;; This is the value of "Indent Function" for "Lisp" mode.
-;;;
-(defun indent-for-lisp (mark)
-  (line-start mark)
-  (pre-command-parse-check mark)
-  (ensure-lisp-indentation mark))
-
-(defun count-leading-whitespace (mark)
-  (with-mark ((m mark))
-    (line-start m)
-    (do* ((p 0)
-	  (q 0 (1+ q))
-          (tab-width (value spaces-per-tab)))
-         ()
-      (case (next-character m)
-        (#\space (incf p))
-        (#\tab (setq p (* tab-width (ceiling (1+ p) tab-width))))
-        (t (return (values p q))))
-      (character-offset m 1))))
-
-;;; Don't do anything if M's line is already correctly indented.
-(defun ensure-lisp-indentation (m)
-  (let* ((col (lisp-indentation m)))
-    (multiple-value-bind (curcol curpos) (count-leading-whitespace m)
-      (cond ((= curcol col) (setf (mark-charpos m) curpos))
-	    (t
-	     (delete-horizontal-space m)
-	     (funcall (value indent-with-tabs) m col))))))
-
-
-
-
-
-;;;; Most "Lisp" mode commands.
-
-(defcommand "Beginning of Defun" (p)
-  "Move the point to the beginning of a top-level form, collapsing the selection.
-  with an argument, skips the previous p top-level forms."
-  "Move the point to the beginning of a top-level form, collapsing the selection."
-  (let ((point (current-point-collapsing-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(end-of-defun-command (- count))
-	(unless (top-level-offset point (- count))
-	  (editor-error)))))
-
-(defcommand "Select to Beginning of Defun" (p)
-  "Move the point to the beginning of a top-level form, extending the selection.
-  with an argument, skips the previous p top-level forms."
-  "Move the point to the beginning of a top-level form, extending the selection."
-  (let ((point (current-point-extending-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(end-of-defun-command (- count))
-	(unless (top-level-offset point (- count))
-	  (editor-error)))))
-
-;;; "End of Defun", with a positive p (the normal case), does something weird.
-;;; Get a mark at the beginning of the defun, and then offset it forward one
-;;; less top level form than we want.  This sets us up to use FORM-OFFSET which
-;;; allows us to leave the point immediately after the defun.  If we used
-;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current
-;;; defun, point would be left at the beginning of the p+1'st form instead of
-;;; at the end of the p'th form.
-;;;
-(defcommand "End of Defun" (p)
-  "Move the point to the end of a top-level form, collapsing the selection.
-   With an argument, skips the next p top-level forms."
-  "Move the point to the end of a top-level form, collapsing the selection."
-  (let ((point (current-point-collapsing-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(beginning-of-defun-command (- count))
-	(with-mark ((m point)
-		    (dummy point))
-	  (cond ((not (mark-top-level-form m dummy))
-		 (editor-error "No current or next top level form."))
-		(t 
-		 (unless (top-level-offset m (1- count))
-		   (editor-error "Not enough top level forms."))
-		 ;; We might be one unparsed for away.
-		 (pre-command-parse-check m)
-		 (unless (form-offset m 1)
-		   (editor-error "Not enough top level forms."))
-		 (when (blank-after-p m) (line-offset m 1 0))
-		 (move-mark point m)))))))
-
-(defcommand "Select to End of Defun" (p)
-  "Move the point to the end of a top-level form, extending the selection.
-   With an argument, skips the next p top-level forms."
-  "Move the point to the end of a top-level form, extending the selection."
-  (let ((point (current-point-extending-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(beginning-of-defun-command (- count))
-	(with-mark ((m point)
-		    (dummy point))
-	  (cond ((not (mark-top-level-form m dummy))
-		 (editor-error "No current or next top level form."))
-		(t 
-		 (unless (top-level-offset m (1- count))
-		   (editor-error "Not enough top level forms."))
-		 ;; We might be one unparsed for away.
-		 (pre-command-parse-check m)
-		 (unless (form-offset m 1)
-		   (editor-error "Not enough top level forms."))
-		 (when (blank-after-p m) (line-offset m 1 0))
-		 (move-mark point m)))))))
-
-(defcommand "Forward List" (p)
-  "Skip over the next Lisp list, collapsing the selection.
-  With argument, skips the next p lists."
-  "Skip over the next Lisp list, collapsing the selection."
-  (let ((point (current-point-collapsing-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (unless (list-offset point count) (editor-error))))
-
-(defcommand "Select Forward List" (p)
-  "Skip over the next Lisp list, extending the selection.
-  With argument, skips the next p lists."
-  "Skip over the next Lisp list, extending the selection."
-  (let ((point (current-point-extending-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (unless (list-offset point count) (editor-error))))
-
-(defcommand "Backward List" (p)
-  "Skip over the previous Lisp list, collapsing the selection.
-  With argument, skips the previous p lists."
-  "Skip over the previous Lisp list, collapsing the selection."
-  (let ((point (current-point-collapsing-selection))
-	(count (- (or p 1))))
-    (pre-command-parse-check point)
-    (unless (list-offset point count) (editor-error))))
-
-(defcommand "Select Backward List" (p)
-  "Skip over the previous Lisp list, extending the selection.
-  With argument, skips the previous p lists."
-  "Skip over the previous Lisp list, extending the selection."
-  (let ((point (current-point-extending-selection))
-	(count (- (or p 1))))
-    (pre-command-parse-check point)
-    (unless (list-offset point count) (editor-error))))
-
-(defcommand "Forward Form" (p)
-  "Skip over the next Form, collapsing the selection.
-  With argument, skips the next p Forms."
-  "Skip over the next Form, collapsing the selection."
-  (let ((point (current-point-collapsing-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (unless (form-offset point count) (editor-error))))
-
-(defcommand "Select Forward Form" (p)
-  "Skip over the next Form, extending the selection.
-  With argument, skips the next p Forms."
-  "Skip over the next Form, extending the selection."
-  (let ((point (current-point-extending-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (unless (form-offset point count) (editor-error))))
-
-(defcommand "Backward Form" (p)
-  "Skip over the previous Form, collapsing the selection.
-  With argument, skips the previous p Forms."
-  "Skip over the previous Form, collaspsing the selection."
-  (let ((point (current-point-collapsing-selection))
-	(count (- (or p 1))))
-    (pre-command-parse-check point)
-    (unless (form-offset point count) (editor-error))))
-
-(defcommand "Select Backward Form" (p)
-  "Skip over the previous Form, extending the selection.
-  With argument, skips the previous p Forms."
-  "Skip over the previous Form, extending the selection."
-  (let ((point (current-point-extending-selection))
-	(count (- (or p 1))))
-    (pre-command-parse-check point)
-    (unless (form-offset point count) (editor-error))))
-
-(defcommand "Mark Form" (p)
-  "Set the mark at the end of the next Form.
-   With a positive argument, set the mark after the following p
-   Forms. With a negative argument, set the mark before
-   the preceding -p Forms."
-  "Set the mark at the end of the next Form."
-  (with-mark ((m (current-point)))
-    (pre-command-parse-check m)
-    (let ((count (or p 1))
-	  (mark (push-buffer-mark (copy-mark m) t)))
-      (if (form-offset m count)
-	  (move-mark mark m)
-	  (editor-error)))))
-
-(defcommand "Mark Defun" (p)
-  "Puts the region around the next or containing top-level form.
-   The point is left before the form and the mark is placed immediately
-   after it."
-  "Puts the region around the next or containing top-level form."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((start point)
-		(end point))
-      (cond ((not (mark-top-level-form start end))
-	     (editor-error "No current or next top level form."))
-	    (t
-	     (move-mark point start)
-	     (move-mark (push-buffer-mark (copy-mark point) t) end))))))
-
-(defcommand "Forward Kill Form" (p)
-  "Kill the next Form.
-   With a positive argument, kills the next p Forms.
-   Kills backward with a negative argument."
-  "Kill the next Form."
-  (with-mark ((m1 (current-point))
-	      (m2 (current-point)))
-    (pre-command-parse-check m1)
-    (let ((count (or p 1)))
-      (unless (form-offset m1 count) (editor-error))
-      (if (minusp count)
-	  (kill-region (region m1 m2) :kill-backward)
-	  (kill-region (region m2 m1) :kill-forward)))))
-
-(defcommand "Backward Kill Form" (p)
-  "Kill the previous Form.
-  With a positive argument, kills the previous p Forms.
-  Kills forward with a negative argument."
-  "Kill the previous Form."
-  (forward-kill-form-command (- (or p 1))))
-
-(defcommand "Extract Form" (p)
-  "Replace the current containing list with the next form.  The entire affected
-   area is pushed onto the kill ring.  If an argument is supplied, that many
-   upward levels of list nesting is replaced by the next form."
-  "Replace the current containing list with the next form.  The entire affected
-   area is pushed onto the kill ring.  If an argument is supplied, that many
-   upward levels of list nesting is replaced by the next form."
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((form-start point :right-inserting)
-		(form-end point))
-      (unless (form-offset form-end 1) (editor-error))
-      (form-offset (move-mark form-start form-end) -1)
-      (with-mark ((containing-start form-start :left-inserting)
-		  (containing-end form-end :left-inserting))
-	(dotimes (i (or p 1))
-	  (unless (and (forward-up-list containing-end)
-		       (backward-up-list containing-start))
-	    (editor-error)))
-	(let ((r (copy-region (region form-start form-end))))
-	  (ring-push (delete-and-save-region
-		      (region containing-start containing-end))
-		     *kill-ring*)
-	  (ninsert-region point r)
-	  (move-mark point form-start))))))
-
-(defcommand "Extract List" (p)
-  "Extract the current list.
-  The current list replaces the surrounding list.  The entire affected
-  area is pushed on the kill-ring.  With prefix argument, remove that
-  many surrounding lists."
-  "Replace the P containing lists with the current one."
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((lstart point :right-inserting)
-		(lend point))
-      (if (eq (character-attribute :lisp-syntax (next-character lstart))
-	      :open-paren)
-	  (mark-after lend)
-	  (unless (backward-up-list lstart) (editor-error)))
-      (unless (forward-up-list lend) (editor-error))
-      (with-mark ((rstart lstart)
-		  (rend lend))
-	(dotimes (i (or p 1))
-	  (unless (and (forward-up-list rend) (backward-up-list rstart))
-	    (editor-error)))
-	(let ((r (copy-region (region lstart lend))))
-	  (ring-push (delete-and-save-region (region rstart rend))
-		     *kill-ring*)
-	  (ninsert-region point r)
-	  (move-mark point lstart))))))
-
-(defcommand "Transpose Forms" (p)
-  "Transpose Forms immediately preceding and following the point.
-  With a zero argument, tranposes the Forms at the point and the mark.
-  With a positive argument, transposes the Form preceding the point
-  with the p-th one following it.  With a negative argument, transposes the
-  Form following the point with the p-th one preceding it."
-  "Transpose Forms immediately preceding and following the point."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (zerop count)
-	(let ((mark (current-mark)))
-	  (with-mark ((s1 mark :left-inserting)
-		      (s2 point :left-inserting))
-	    (scan-char s1 :whitespace nil)
-	    (scan-char s2 :whitespace nil)
-	    (with-mark ((e1 s1 :right-inserting)
-			(e2 s2 :right-inserting))
-	      (unless (form-offset e1 1) (editor-error))
-	      (unless (form-offset e2 1) (editor-error))
-	      (ninsert-region s1 (delete-and-save-region (region s2 e2)))
-	      (ninsert-region s2 (delete-and-save-region (region s1 e1))))))
-	(let ((fcount (if (plusp count) count 1))
-	      (bcount (if (plusp count) 1 count)))
-	  (with-mark ((s1 point :left-inserting)
-		      (e2 point :right-inserting))
-	    (dotimes (i bcount)
-	      (unless (form-offset s1 -1) (editor-error)))
-	    (dotimes (i fcount)
-	      (unless (form-offset e2 1) (editor-error)))
-	    (with-mark ((e1 s1 :right-inserting)
-			(s2 e2 :left-inserting))
-	      (unless (form-offset e1 1) (editor-error))
-	      (unless (form-offset s2 -1) (editor-error))
-	      (ninsert-region s1 (delete-and-save-region (region s2 e2)))
-	      (ninsert-region s2 (delete-and-save-region (region s1 e1)))
-	      (move-mark point s2)))))))
-
-
-(defcommand "Insert ()" (count)
-  "Insert a pair of parentheses ().  With positive argument, puts
-   parentheses around the next COUNT Forms, or previous COUNT forms, if
-   COUNT is negative.  The point is positioned after the open parenthesis."
-  "Insert a pair of parentheses ()."
-  ;; TODO Form navigation is broken, so this is broken too -- it is
-  ;; possible to put parens around more forms than there are in current
-  ;; expression.  It works by moving past as many forms as there is, and
-  ;; then each delimiting paren also counts as a form.
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (cond (count
-	   (when (minusp count)
-	     (form-offset point count)
-	     (setq count (- count)))
-	   (insert-character point #\()
-	   (with-mark ((m point))
-	     (unless (form-offset m count)
-	       (editor-error "Could not find that many forms."))
-	     (insert-character m #\))))
-	  ;; The simple case with no prefix argument
-	  (t
-	   (insert-character point #\()
-	   (insert-character point #\))
-	   (mark-before point)))))
-
-
-(defcommand "Move Over )" (p)
-  "Move past the next close parenthesis, and start a new line.  Any
-   indentation preceding the preceding the parenthesis is deleted, and the
-   new line is indented.  If there is only whitespace preceding the close
-   paren, the paren is moved to the end of the previous line. With prefix
-   argument, this command moves past next closing paren and inserts space."
-  "Move past the next close parenthesis, and start a new line."
-  ;; TODO This is still not complete, because SCAN-CHAR finds the next
-  ;; close-paren, but we need to find the next paren that closes current
-  ;; expression.  This will have to be updated when form navigation is
-  ;; fixed.
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((m point :right-inserting))
-      (cond ((scan-char m :lisp-syntax :close-paren)
-	     (cond ((same-line-p point m)
-		    (delete-horizontal-space m))
-		   (t
-		    (move-mark point m)
-		    (reverse-find-attribute point :whitespace #'zerop)
-		    (delete-region (region point m))))
-	     (cond ((not p)
-		    ;; Move to the previous line if current is empty
-		    (when (zerop (mark-charpos m))
-		      (delete-characters m -1))
-		    (mark-after m)
-		    (move-mark point m)
-		    (indent-new-line-command 1))
-		   (t
-		    (mark-after m)
-		    (move-mark point m)
-		    (insert-character m #\space))))
-	    (t 
-	     (editor-error "Could not find closing paren."))))))
-
-
-(defcommand "Forward Up List" (p)
-  "Move forward past a one containing )."
-  "Move forward past a one containing )."
-  (let ((point (current-point-collapsing-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(backward-up-list-command (- count))
-	(with-mark ((m point))
-	  (dotimes (i count (move-mark point m))
-	    (unless (forward-up-list m) (editor-error)))))))
-
-
-(defcommand "Backward Up List" (p)
-  "Move backward past a one containing (."
-  "Move backward past a one containing (."
-  (let ((point (current-point-collapsing-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(forward-up-list-command (- count))
-	(with-mark ((m point))
-	  (dotimes (i count (move-mark point m))
-	    (unless (backward-up-list m) (editor-error)))))))
-
-
-(defcommand "Down List" (p)
-  "Move down a level in list structure.  With positive argument, moves down
-   p levels.  With negative argument, moves down backward, but only one
-   level."
-  "Move down a level in list structure."
-  (let ((point (current-point-collapsing-selection))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (with-mark ((m point))
-      (cond ((plusp count)
-	     (loop repeat count
-                   do (unless (and (scan-char m :lisp-syntax :open-paren)
-                                   (mark-after m))
-                        (editor-error))))
-	    (t
-	     (unless (and (rev-scan-char m :lisp-syntax :close-paren)
-			  (mark-before m))
-	       (editor-error))))
-      (move-mark point m))))
-
-
-
-
-;;;; Filling Lisp comments, strings, and indented text.
-
-(defhvar "Fill Lisp Comment Paragraph Confirm"
-  "This determines whether \"Fill Lisp Comment Paragraph\" will prompt for
-   confirmation to fill contiguous lines with the same initial whitespace when
-   it is invoked outside of a comment or string."
-  :value t)
-
-(defcommand "Fill Lisp Comment Paragraph" (p)
-  "This fills a flushleft or indented Lisp comment.
-   This also fills Lisp string literals using the proper indentation as a
-   filling prefix.  When invoked outside of a comment or string, this tries
-   to fill all contiguous lines beginning with the same initial, non-empty
-   blankspace.  When filling a comment, the current line is used to determine a
-   fill prefix by taking all the initial whitespace on the line, the semicolons,
-   and any whitespace following the semicolons."
-  "Fills a flushleft or indented Lisp comment."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((start point)
-		(end point)
-		(m point))
-      (let ((commentp (fill-lisp-comment-paragraph-prefix start end)))
-	(cond (commentp
-	       (fill-lisp-comment-or-indented-text start end))
-	      ((and (not (valid-spot m nil))
-		    (form-offset m -1)
-		    (eq (character-attribute :lisp-syntax (next-character m))
-			:string-quote))
-	       (fill-lisp-string m))
-	      ((or (not (value fill-lisp-comment-paragraph-confirm))
-		   (prompt-for-y-or-n
-		    :prompt '("Not in a comment or string.  Fill contiguous ~
-			       lines with the same initial whitespace? ")))
-	       (fill-lisp-comment-or-indented-text start end)))))))
-
-;;; FILL-LISP-STRING -- Internal.
-;;;
-;;; This fills the Lisp string containing mark as if it had been entered using
-;;; Hemlock's Lisp string indentation, "Indent Function" for "Lisp" mode.  This
-;;; assumes the area around mark has already been PRE-COMMAND-PARSE-CHECK'ed,
-;;; and it ensures the string ends before doing any filling.  This function
-;;; is undo'able.
-;;;
-(defun fill-lisp-string (mark)
-  (with-mark ((end mark))
-    (unless (form-offset end 1)
-      (editor-error "Attempted to fill Lisp string, but it doesn't end?"))
-    (let* ((mark (copy-mark mark :left-inserting))
-	   (end (copy-mark end :left-inserting))
-	   (string-region (region mark end))
-	   (undo-region (copy-region string-region))
-	   (hack (make-empty-region)))
-      ;; Generate prefix.
-      (funcall (value indent-with-tabs)
-	       (region-end hack) (1+ (mark-column mark)))
-      ;; Skip opening double quote and fill string starting on its own line.
-      (mark-after mark)
-      (insert-character mark #\newline)
-      (line-start mark)
-      (setf (mark-kind mark) :right-inserting)
-      (fill-region string-region (region-to-string hack))
-      ;; Clean up inserted prefix on first line, delete inserted newline, and
-      ;; move before the double quote for undo.
-      (with-mark ((text mark :left-inserting))
-	(find-attribute text :whitespace #'zerop)
-	(delete-region (region mark text)))
-      (delete-characters mark -1)
-      (mark-before mark)
-      ;; Save undo.
-      (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
-			string-region undo-region))))
-
-;;; FILL-LISP-COMMENT-OR-INDENTED-TEXT -- Internal.
-;;;
-;;; This fills all contiguous lines around start and end containing fill prefix
-;;; designated by the region between start and end.  These marks can only be
-;;; equal when there is no comment and no initial whitespace.  This is a bad
-;;; situation since this function in that situation would fill the entire
-;;; buffer into one paragraph.  This function is undo'able.
-;;;
-(defun fill-lisp-comment-or-indented-text (start end)
-  (when (mark= start end)
-    (editor-error "This command only fills Lisp comments, strings, or ~
-		   indented text, but this line is flushleft."))
-  ;;
-  ;; Find comment block.
-  (let* ((prefix (region-to-string (region start end)))
-	 (length (length prefix)))
-    (declare (simple-string prefix))
-    (flet ((frob (mark direction)
-	     (loop
-	       (let* ((line (line-string (mark-line mark)))
-		      (line-len (length line)))
-		 (declare (simple-string line))
-		 (unless (string= line prefix :end1 (min line-len length))
-		   (when (= direction -1)
-		     (unless (same-line-p mark end) (line-offset mark 1 0)))
-		   (return)))
-	       (unless (line-offset mark direction 0)
-		 (when (= direction 1) (line-end mark))
-		 (return)))))
-      (frob start -1)
-      (frob end 1))
-    ;;
-    ;; Do it undoable.
-    (let* ((start1 (copy-mark start :right-inserting))
-	   (end2 (copy-mark end :left-inserting))
-	   (region (region start1 end2))
-	   (undo-region (copy-region region)))
-      (fill-region region prefix)
-      (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
-			region undo-region))))
-
-;;; FILL-LISP-COMMENT-PARAGRAPH-PREFIX -- Internal.
-;;;
-;;; This sets start and end around the prefix to be used for filling.  We
-;;; assume we are dealing with a comment.  If there is no ";", then we try to
-;;; find some initial whitespace.  If there is a ";", we make sure the line is
-;;; blank before it to eliminate ";"'s in the middle of a line of text.
-;;; Finally, if we really have a comment instead of some indented text, we skip
-;;; the ";"'s and any immediately following whitespace.  We allow initial
-;;; whitespace, so we can fill strings with the same command.
-;;;
-(defun fill-lisp-comment-paragraph-prefix (start end)
-  (line-start start)
-  (let ((commentp t)) ; Assumes there's a comment.
-    (unless (to-line-comment (line-start end) ";")
-      (find-attribute end :whitespace #'zerop)
-      #|(when (start-line-p end)
-	(editor-error "No comment on line, and no initial whitespace."))|#
-      (setf commentp nil))
-    (when commentp
-      (unless (blank-before-p end)
-	(find-attribute (line-start end) :whitespace #'zerop)
-	#|(when (start-line-p end)
-	  (editor-error "Semicolon preceded by unindented text."))|#
-	(setf commentp nil)))
-    (when commentp
-      (find-attribute end :lisp-syntax #'(lambda (x) (not (eq x :comment))))
-      (find-attribute end :whitespace #'zerop))
-    commentp))
-
-
-
-
-;;;; "Lisp" mode.
-
-(defcommand "LISP Mode" (p)
-  "Put current buffer in LISP mode." 
-  "Put current buffer in LISP mode."  
-  (declare (ignore p))
-  (setf (buffer-major-mode (current-buffer)) "LISP"))
-
-
-(defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
-
-
-(defun buffer-first-in-package-form (buffer)
-  "Returns the package name referenced in the first apparent IN-PACKAGE
-   form in buffer, or NIL if it can't find an IN-PACKAGE."
-  (let* ((pattern (new-search-pattern :string-insensitive :forward "in-package" nil))
-         (mark (copy-mark (buffer-start-mark buffer))))
-    (with-mark ((start mark)
-                (end mark))
-      (loop
-        (unless (find-pattern mark pattern)
-          (return))
-        (pre-command-parse-check mark)
-        (when (valid-spot mark t)
-          (move-mark end mark)
-          (when (form-offset end 1)
-            (move-mark start end)
-            (when (backward-up-list start)
-              (when (scan-char start :lisp-syntax :constituent)
-                (let* ((s (nstring-upcase (region-to-string (region start end))))
-                       (*package* (find-package "CL-USER")))
-                  (unless (eq (ignore-errors (values (read-from-string s)))
-                              'in-package)
-                    (return)))
-                (unless (form-offset end 1) (return))
-                (move-mark start end)
-                (form-offset start -1)
-                (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
-                  (return
-                    (if pkgname
-                      (values (ignore-errors (string pkgname))))))))))))))
-
-(defparameter *previous-in-package-search-pattern*
-    (new-search-pattern :string-insensitive :backward "in-package" nil))
-
-(defun package-at-mark (start-mark)
-  (let* ((pattern *previous-in-package-search-pattern*)
-         (mark (copy-mark start-mark :temporary)))
-    (with-mark ((start mark)
-                (end mark)
-                (list-end mark))
-      (loop
-        (unless (find-pattern mark pattern)
-          (return))
-        (pre-command-parse-check mark)
-        (when (valid-spot mark t)
-          (move-mark end mark)
-          (when (form-offset end 1)
-            (move-mark start end)
-            (when (backward-up-list start)
-              (move-mark list-end start)
-              (unless (and (list-offset list-end 1)
-                           (mark<= list-end start-mark))
-                (return))
-              (when (scan-char start :lisp-syntax :constituent)
-                (unless (or (mark= mark start)
-                            (let* ((s (nstring-upcase (region-to-string (region start end))))
-                                   (*package* (find-package "CL-USER")))
-                              (eq (ignore-errors (values (read-from-string s)))
-                                  'in-package)))
-                  (return))
-                (unless (form-offset end 1) (format t "~& worse") (return 4))
-                (move-mark start end)
-                (form-offset start -1)
-                (return
-                  (if (eql (next-character start) #\")
-                    (progn
-                      (character-offset start 1)
-                      (character-offset end -1)
-                      (region-to-string (region start end)))
-                    (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
-                      (if pkgname
-                        (values (ignore-errors (string pkgname)))))))))))))))
-
-(defun ensure-buffer-package (buffer)
-  (or (variable-value 'current-package :buffer buffer)
-      (setf (variable-value 'current-package :buffer buffer)
-            (buffer-first-in-package-form buffer))))
-
-(defun buffer-package (buffer)
-  (when (hemlock-bound-p 'current-package :buffer buffer)
-    (let ((package-name (variable-value 'current-package :buffer buffer)))
-      (find-package package-name))))
-
-(defun setup-lisp-mode (buffer)
-  (unless (hemlock-bound-p 'current-package :buffer buffer)
-    (defhvar "Current Package"
-      "The package used for evaluation of Lisp in this buffer."
-      :buffer buffer
-      :value "CL-USER"
-      :hooks (list 'package-name-change-hook))))
-
-
-
-
-
-
-;;;; Some mode variables to coordinate with other stuff.
-
-(defhvar "Auto Fill Space Indent"
-  "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
-   \"New Line\"."
-  :mode "Lisp" :value t)
-
-(defhvar "Comment Start"
-  "String that indicates the start of a comment."
-  :mode "Lisp" :value ";")
-
-(defhvar "Comment Begin"
-  "String that is inserted to begin a comment."
-  :mode "Lisp" :value "; ")
-
-(defhvar "Indent Function"
-  "Indentation function which is invoked by \"Indent\" command.
-   It must take one argument that is the prefix argument."
-  :value 'indent-for-lisp
-  :mode "Lisp")
-
-(defun string-to-arglist (string buffer &optional quiet-if-unknown)
-  (multiple-value-bind (name error)
-      (let* ((*package* (or
-                         (find-package
-                          (variable-value 'current-package :buffer buffer))
-                         *package*)))
-        (ignore-errors (values (read-from-string string))))
-    (unless error
-      (when (typep name 'symbol)
-        (multiple-value-bind (arglist win)
-            (ccl::arglist-string name)
-          (if (or win (not quiet-if-unknown))
-            (format nil "~S : ~A" name (if win (or arglist "()") "(unknown)"))))))))
-
-(defcommand "Current Function Arglist" (p)
-  "Show arglist of function whose name precedes point."
-  "Show arglist of function whose name precedes point."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((mark1 point)
-		(mark2 point))
-      (when (backward-up-list mark1)
-        (when (form-offset (move-mark mark2 (mark-after mark1)) 1)
-          (let* ((fun-name (region-to-string (region mark1 mark2)))
-                 (arglist-string (string-to-arglist fun-name (current-buffer))))
-            (when arglist-string
-              (message arglist-string))))))))
-
-(defcommand "Arglist On Space" (p)
-  "Insert a space, then show the current function's arglist."
-  "Insert a space, then show the current function's arglist."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (insert-character point #\Space)
-    (pre-command-parse-check point)
-    (with-mark ((mark1 point)
-		(mark2 point))
-      (when (backward-up-list mark1)
-        (when (form-offset (move-mark mark2 (mark-after mark1)) 1)
-          (with-mark ((mark3 mark2))
-            (do* ()
-                 ((mark= mark3 point)
-                  (let* ((fun-name (region-to-string (region mark1 mark2)))
-                         (arglist-string
-                          (string-to-arglist fun-name (current-buffer) t)))
-                    (when arglist-string
-                      (message arglist-string))))
-              (if (ccl::whitespacep (next-character mark3))
-                (mark-after mark3)
-                (return nil)))))))))
-
-(hi:defcommand "Show Callers" (p)
-  "Display a scrolling list of the callers of the symbol at point.
-   Double-click a row to go to the caller's definition."
-  (declare (ignore p))
-  (with-mark ((mark1 (current-point))
-              (mark2 (current-point)))
-    (mark-symbol mark1 mark2)
-    (with-input-from-region (s (region mark1 mark2))
-      (let* ((symbol (read s)))
-	(make-instance 'ccl::sequence-window-controller
-	  :sequence (ccl::callers symbol)
-	  :title (format nil "Callers of ~a" symbol)
-	  :result-callback #'(lambda (item)
-			       (get-def-info-and-go-to-it (symbol-name item)
-							  (symbol-package item))))))))
-
-#||
-(defcommand "Set Package Name" (p)
-  (variable-value 'current-package :buffer buffer)
-||#