Skip to content
Snippets Groups Projects
lispmode.lisp 59 KiB
Newer Older
chiles's avatar
 
chiles committed
    ;; Move after the paren, save the start, and find the form name.
ram's avatar
ram committed
    (mark-after m)
    (with-mark ((start m))
chiles's avatar
 
chiles committed
      (unless (and (scan-char m :lisp-syntax
			      (not (or :space :prefix :char-quote)))
ram's avatar
ram committed
		   (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 (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))
chiles's avatar
 
chiles committed
	  ;; Now that we have the form name, did it have special syntax?
ram's avatar
ram committed
	  (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)))))
chiles's avatar
 
chiles committed
		;; 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.
ram's avatar
ram committed
		((and (form-offset temp -1)
chiles's avatar
 
chiles committed
		      (or (blank-before-p temp) (not (same-line-p temp fstart)))
ram's avatar
ram committed
		      (not (same-line-p temp mark)))
		 (unless (blank-before-p temp)
		   (line-start temp)
		   (find-attribute temp :space #'zerop))
		 (mark-column temp))
chiles's avatar
 
chiles committed
		;; Appears to be a normal form.  Is the first arg on the same
		;; line as the form name?
ram's avatar
ram committed
		((skip-valid-space m)
chiles's avatar
 
chiles committed
		 (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.
ram's avatar
ram committed
		(t
chiles's avatar
 
chiles committed
		 (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"))

chiles's avatar
 
chiles committed
;;; 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.
chiles's avatar
 
chiles committed
  (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.
chiles's avatar
 
chiles committed
	 ;; See if the containing form is named FLET or MACROLET.
chiles's avatar
 
chiles committed
	 (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=))
chiles's avatar
 
chiles committed
		  nil)
		 (arg-list
		  (1+ (mark-column start)))
		 (t
		  (+ (mark-column start) 3)))))))
ram's avatar
ram committed

chiles's avatar
 
chiles committed
;;; 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.
;;;
ram's avatar
ram committed
(defun lisp-generic-indentation (mark)
chiles's avatar
 
chiles committed
  (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)))))))
ram's avatar
ram committed

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

chiles's avatar
 
chiles committed

ram's avatar
ram committed

chiles's avatar
 
chiles committed
;;;; Indentation commands and hook functions.
ram's avatar
ram committed

(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))))))
chiles's avatar
 
chiles committed
  (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"))
  (check-region-query-size region)
  (let ((start (region-start region))
	(end (region-end region)))
    (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)))
    (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)
	  (insert-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)
  (insert-lisp-indentation mark))

(defun insert-lisp-indentation (m)
  (delete-horizontal-space m)
  (funcall (value indent-with-tabs) m (lisp-indentation m)))



;;;; Most "Lisp" mode commands.
ram's avatar
ram committed

(defcommand "Beginning of Defun" (p)
  "Move the point to the beginning of a top-level form.
  with an argument, skips the previous p top-level forms."
  "Move the point to the beginning of a top-level form."
  (let ((point (current-point))
	(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.
   With an argument, skips the next p top-level forms."
  "Move the point to the end of a top-level form."
  (let ((point (current-point))
	(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.
  With argument, skips the next p lists."
  "Skip over the next Lisp list."
  (let ((point (current-point))
	(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.
  With argument, skips the previous p lists."
  "Skip over the previous Lisp list."
  (let ((point (current-point))
	(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.
  With argument, skips the next p Forms."
  "Skip over the next Form."
  (let ((point (current-point))
	(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.
  With argument, skips the previous p Forms."
  "Skip over the previous Form."
  (let ((point (current-point))
	(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))))))

ram's avatar
ram committed
(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 ()" (p)
  "Insert a pair of parentheses ().
   With positive argument, puts parentheses around the next p
   Forms.  The point is positioned after the open parenthesis."
  "Insert a pair of parentheses ()."
  (let ((point (current-point))
	(count (or p 0)))
    (pre-command-parse-check point)
    (cond ((not (minusp count))
	   (insert-character point #\()
	   (with-mark ((tmark point))
	     (unless (form-offset tmark count) (editor-error))
	     (cond ((mark= tmark point)
		    (insert-character point #\))
		    (mark-before point))
		   (t (insert-character tmark #\))))))
	  (t (editor-error)))))


(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."
  "Move past the next close parenthesis, and start a new line."
  (declare (ignore p))
  (let ((point (current-point)))
    (pre-command-parse-check point)
    (with-mark ((m point :left-inserting))
ram's avatar
ram committed
      (cond ((scan-char m :lisp-syntax :close-paren)
	     (delete-horizontal-space m)
	     (mark-after m)
	     (move-mark point m)
ram's avatar
ram committed
	     (indent-new-line-command 1))
ram's avatar
ram committed


(defcommand "Forward Up List" (p)
  "Move forward past a one containing )."
  "Move forward past a one containing )."
  (let ((point (current-point))
	(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))
	(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 argument, moves down p levels."
  "Move down a level in list structure."
  (let ((point (current-point))
	(count (or p 1)))
    (pre-command-parse-check point)
    (with-mark ((m point))
      (dotimes (i count (move-mark point m))
	(unless (and (scan-char m :lisp-syntax :open-paren)
		     (mark-after m))
	  (editor-error))))))


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

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



;;;; Matching parenthesis display.

(defhvar "Paren Pause Period"
  "This is how long commands that deal with \"brackets\" shows the cursor at
   the matching \"bracket\" for this number of seconds."
  :value 0.5)

(defcommand "Lisp Insert )" (p)
  "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
  "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
  (declare (ignore p))
  (let ((point (current-point)))
    (insert-character point #\))
    (pre-command-parse-check point)
    (when (valid-spot point nil) 
      (with-mark ((m point))
	(if (list-offset m -1)
	    (let ((pause (value paren-pause-period))
		  (win (current-window)))
	      (if pause
		  (unless (show-mark m win pause)
		    (clear-echo-area)
		    (message "~A" (line-string (mark-line m))))
		  (unless (displayed-p m (current-window))
		    (clear-echo-area)
		    (message "~A" (line-string (mark-line m))))))
	    (editor-error))))))

;;; Since we use paren highlighting in Lisp mode, we do not want paren
;;; flashing too.
;;; 
(defhvar "Paren Pause Period"
  "This is how long commands that deal with \"brackets\" shows the cursor at
   the matching \"bracket\" for this number of seconds."
  :value nil
  :mode "Lisp")
;;;
(defhvar "Highlight Open Parens"
  "When non-nil, causes open parens to be displayed in a different font when
   the cursor is directly to the right of the corresponding close paren."
  :value t
  :mode "Lisp")


(defhvar "Open Paren Finder Function"
  "Should be a function that takes a mark for input and returns either NIL
   if the mark is not after a close paren, or two (temporary) marks
   surrounding the corresponding open paren."
  :mode "Lisp"
  :value 'lisp-open-paren-finder-function)

(defun lisp-open-paren-finder-function (mark)
  (when (eq (character-attribute :lisp-syntax (previous-character mark))
	    :close-paren)
    (with-mark ((mark mark))
      (pre-command-parse-check mark)
      (if (not (and (valid-spot mark nil) (list-offset mark -1)))
	  (values nil nil)
	  (values mark (mark-after (copy-mark mark)))))))


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