Skip to content
Snippets Groups Projects
lispmode.lisp 59 KiB
Newer Older
ram's avatar
ram committed
;;; -*- Log: hemlock.log; Package: Hemlock -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispmode.lisp,v 1.5 1997/06/05 13:19:38 pw Exp $")
ram's avatar
ram committed
;;;
ram's avatar
ram committed
;;; **********************************************************************
;;;
;;; Hemlock LISP Mode commands
;;;
;;; Written by Ivan Vazquez and Bill Maddox.
;;;

(in-package "HEMLOCK")

ram's avatar
ram committed
(declaim (optimize (speed 2))); turn off byte compilation.
ram's avatar
ram committed


ram's avatar
ram committed
;;;; Variables and lisp-info structure.

ram's avatar
ram committed
;;; 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)

	    
ram's avatar
ram committed
;;; LISP-INFO is the structure used to store the data about the line in its
;;; Plist.
;;;
ram's avatar
ram committed
;;;     -> 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))



ram's avatar
ram committed
;;;; Macros.

ram's avatar
ram committed
;;; 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 load eval)
(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 (Compile Load Eval)

;;; 
;;; 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)))


ram's avatar
ram committed
;;;; Parsing functions.
ram's avatar
ram committed

ram's avatar
ram committed
;;; PRE-COMMAND-PARSE-CHECK -- Public.
;;;
ram's avatar
ram committed
(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
ram's avatar
ram committed
;;;
ram's avatar
ram committed
(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)))))))


ram's avatar
ram committed
;;;; Parse block finders.
ram's avatar
ram committed

(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))))


ram's avatar
ram committed
;;;; PARSE-LISP-LINE-INFO.

;;; PARSE-LISP-LINE-INFO -- Internal.
;;;
;;; This parses through the line doing the following things:
;;;
ram's avatar
ram committed
;;;      Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
ram's avatar
ram committed
;;;
ram's avatar
ram committed
;;;      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 
ram's avatar
ram committed
;;;
ram's avatar
ram committed
(defun parse-lisp-line-info (mark line-info prev-line-info)
  "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
ram's avatar
ram committed
   RANGES-TO-INGORE, and ENDING-QUOTED."
ram's avatar
ram committed
  (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)))))
ram's avatar
ram committed

ram's avatar
ram committed
;;;; String quote utilities.
ram's avatar
ram committed

ram's avatar
ram committed
;;; VALID-STRING-QUOTE-P
;;;
ram's avatar
ram committed
(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))
ram's avatar
ram committed
       ,(unless forwardp
	  ;; TEST-MARK should always be right before the String-quote to be
	  ;; checked.
	  `(mark-before ,test-mark))
ram's avatar
ram committed
       (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)))))

ram's avatar
ram committed
;;;; DEAL-WITH-STRING-QUOTE.
ram's avatar
ram committed

ram's avatar
ram committed
;;; 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.
;;;
ram's avatar
ram committed
(defun deal-with-string-quote (mark info-struct)
  "Alter the current line's info struct as necessary as due to encountering a
ram's avatar
ram committed
   string quote character."
ram's avatar
ram committed
  (with-mark ((e-mark mark))
    (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
ram's avatar
ram committed
	   ;; 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.
ram's avatar
ram committed
	   (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))
ram's avatar
ram committed
	  ;; If the EOL has been hit before the matching quote then mark the
	  ;; area from MARK to the EOL as invalid.
ram's avatar
ram committed
	  (t
ram's avatar
ram committed
	   (push-range (cons (mark-charpos mark)
			     (1+ (line-length (mark-line mark))))
ram's avatar
ram committed
		       info-struct)
	   ;; The Ending is marked as still being quoted. 
	   (setf (lisp-info-ending-quoted info-struct) t)
	   (line-end mark)
	   nil))))
ram's avatar
ram committed

;;;; 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))))))


ram's avatar
ram committed
;;;; List offseting.

ram's avatar
ram committed
;;; %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, 
ram's avatar
ram committed
   according to the FORWARDP flag."
ram's avatar
ram committed
  (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)
ram's avatar
ram committed
		  ,(when forwardp
		     ;; When going forward, an unmatching close-paren means the
		     ;; end of list.
		     `(when (<= paren-count 0)
ram's avatar
ram committed
			(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 
ram's avatar
ram committed
		  ;; 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.
ram's avatar
ram committed
		  (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 eval)
(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)))



ram's avatar
ram committed
;;;; Form offseting.
ram's avatar
ram committed

(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)))))



ram's avatar
ram committed
;;;; Table of special forms with special indenting requirements.
ram's avatar
ram committed

(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-setf-method" 2)
(defindent "defmacro" 2)
(defindent "defpackage" 1)
ram's avatar
ram committed
(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 "labels" 1)
(defindent "lambda" 1)
(defindent "let" 1)
(defindent "let*" 1)
(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)

;;; 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)

ram's avatar
ram committed
;;; 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)

ram's avatar
ram committed
;;; Xlib forms.
;;;
(defindent "with-gcontext" 1)
(defindent "xlib:with-gcontext" 1)
(defindent "with-state" 1)
(defindent "xlib:with-state" 1)
(defindent "with-display" 1)
(defindent "xlib:with-display" 1)
(defindent "with-event-queue" 1)
(defindent "xlib:with-event-queue" 1)
(defindent "with-server-grabbed" 1)
(defindent "xlib:with-server-grabbed" 1)
(defindent "event-case" 1)
(defindent "xlib:event-case" 1)

;;; CLOS forms.
;;; 
(defindent "with-slots" 1)
(defindent "with-slots*" 2) ; obsolete
(defindent "with-accessors 2)
(defindent "with-accessors*" 2) ; obsolete
ram's avatar
ram committed
(defindent "defclass" 2)
(defindent "print-unreadable-object" 1)
ram's avatar
ram committed

;;; System forms.
;;;
(defindent "alien-bind" 1)
(defindent "def-c-record" 1)
(defindent "defrecord" 1)

ram's avatar
ram committed
;;; Wire forms.
(defindent "remote" 1)
(defindent "wire:remote" 1)
(defindent "remote-value" 1)
(defindent "wire:remote-value" 1)
(defindent "remote-value-bind" 3)
(defindent "wire:remote-value-bind" 3)

ram's avatar
ram committed


ram's avatar
ram committed
;;;; Indentation.
ram's avatar
ram committed

ram's avatar
ram committed
;;; LISP-INDENTATION -- Internal Interface.
;;;
ram's avatar
ram committed
(defun lisp-indentation (mark)
ram's avatar
ram committed
  "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."
ram's avatar
ram committed
  (with-mark ((m mark)
	      (temp mark))
ram's avatar
ram committed
    ;; See if we are in a quoted context.
ram's avatar
ram committed
    (unless (valid-spot m nil)
ram's avatar
ram committed
      (return-from lisp-indentation (lisp-generic-indentation m)))
    ;; Look for the paren that opens the containing form.