From a79b681332686c0ea1d8ca0e6145a88af8d1cbaf Mon Sep 17 00:00:00 2001
From: chiles <chiles>
Date: Thu, 13 Jun 1991 21:59:46 +0000
Subject: [PATCH] Added "Fill Lisp Comment Paragraph" to core.  This also works
 for strings, except for the first line of the string.

---
 hemlock/lispmode.lisp | 246 +++++++++++++++++++++++++-----------------
 1 file changed, 145 insertions(+), 101 deletions(-)

diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp
index bfca358d6..59dc78e5e 100644
--- a/hemlock/lispmode.lisp
+++ b/hemlock/lispmode.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispmode.lisp,v 1.1.1.4 1991/02/08 16:36:18 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispmode.lisp,v 1.1.1.5 1991/06/13 21:59:46 chiles Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -20,8 +20,8 @@
 
 
 
-;;;;  ####  VARIABLES  ####
-;;;
+;;;; 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
@@ -38,10 +38,9 @@
   :value 'end-of-parse-block)
 
 	    
-;;;; #### STRUCTURES ####
-;;; 
-;;; LISP-INFO is the structure used to store the data about the line in its Plist.
-;;; 
+;;; 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.
 ;;; 
@@ -65,8 +64,8 @@
 
 
 
-;;;;  ####  MACROS  ####
-;;; 
+;;;; Macros.
+
 ;;; The following Macros exist to make it easy to acces the Syntax primitives
 ;;; without uglifying the code.  They were originally written by Maddox.
 ;;; 
@@ -157,10 +156,10 @@
       `(line-previous ,line)))
 
 
-;;;; #### PARSING FUNCTIONS ###
-;;;
-;;; PRE-COMMAND-PARSE-CHECK
+;;;; 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)
@@ -169,9 +168,8 @@
     (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)
@@ -229,8 +227,7 @@
 	 (setq test-line (line-next test-line)))))))
 
 
-;;;;  ####  PARSE BLOCK FINDERS  ####
-;;; 
+;;;; Parse block finders.
 
 (defhvar "Minimum Lines Parsed"
   "The minimum number of lines before and after the point parsed by Lisp mode."
@@ -291,20 +288,23 @@
     (setq line (mark-line mark))))
 
 
-;;; PARSE-LISP-LINE-INFO parses through the line doing the following things:
-;;; 
+;;;; 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."
+   RANGES-TO-INGORE, and ENDING-QUOTED."
   (let ((net-open-parens 0)
 	(net-close-parens 0))
     (declare (fixnum net-open-parens net-close-parens))
@@ -365,26 +365,23 @@ RANGES-TO-INGORE, and ENDING-QUOTED."
     (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
+;;;; 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
-	  `(mark-before ,test-mark))   ; String-quote to be checked.
-       
+       ,(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)
@@ -421,45 +418,41 @@ RANGES-TO-INGORE, and ENDING-QUOTED."
 	
 	(neighbor-mark ,e-mark ,forwardp)))))
 
-;;; 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.
+;;;; 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."
+   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.
-	   
+	   ;; 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.
-	  
+	  ;; 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))))
+	   (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:
 
@@ -540,15 +533,15 @@ string quote character."
 	   (setq ,n-won t))))))
 
 
-;;;; #### LIST-OFFSETING ####
-;;; 
+;;;; 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."
+   according to the FORWARDP flag."
   (let ((mark (gensym)))
     `(let ((paren-count ,extra-parens))
        (declare (fixnum paren-count))
@@ -562,8 +555,10 @@ according to the FORWARDP flag."
 	       (case (character-attribute :lisp-syntax ch)
 		 (:close-paren
 		  (decf paren-count)
-		  ,(when forwardp               ; When going forward, an unmatching
-		     `(when (<= paren-count 0)  ; close-paren means the end of list.
+		  ,(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))))
@@ -576,10 +571,10 @@ according to the FORWARDP flag."
 			(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.
+		  ;; 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)
@@ -745,7 +740,7 @@ according to the FORWARDP flag."
 
 
 
-;;;; #### FORM OFFSETING ####
+;;;; Form offseting.
 
 (defmacro %form-offset (mark forwardp)
   `(with-mark ((m ,mark))
@@ -802,8 +797,7 @@ according to the FORWARDP flag."
 
 
 
-;;; Table of special forms with special indenting requirements.
-
+;;;; Table of special forms with special indenting requirements.
 
 (defhvar "Indent Defanything"
   "This is the number of special arguments implicitly assumed to be supplied
@@ -940,20 +934,24 @@ according to the FORWARDP flag."
 
 
 
+;;;; Indentation.
+
+;;; LISP-INDENTATION -- Internal Interface.
+;;;
 ;;; Compute number of spaces which mark should be indented according to
 ;;; local context and lisp grinding conventions.
-
+;;;
 (defun lisp-indentation (mark)
   (with-mark ((m mark)
 	      (temp mark))
     (unless (valid-spot m nil)
-      (return-from lisp-indentation
-		   (lisp-generic-indentation m)))
+      (return-from lisp-indentation (lisp-generic-indentation m)))
     (unless (backward-up-list m)
       (return-from lisp-indentation 0))
     (mark-after m)
     (with-mark ((start m))
-      (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote)))
+      (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))
@@ -974,8 +972,7 @@ according to the FORWARDP flag."
 			 (t
 			  (+ (mark-column start) 3)))))
 		((and (form-offset temp -1)
-		      (or (blank-before-p temp)
-			  (not (same-line-p temp fstart)))
+		      (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)
@@ -1194,32 +1191,6 @@ according to the FORWARDP flag."
 	  (ninsert-region point r)
 	  (move-mark point form-start))))))
 
-(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
@@ -1343,6 +1314,79 @@ according to the FORWARDP flag."
   (funcall (value indent-with-tabs) m (lisp-indentation m)))
 
 
+(defcommand "Fill Lisp Comment Paragraph" (p)
+  "This fills a flushleft or indented Lisp comment.
+   This also fills lines all 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 the first initial whitespace character following the semicolons.
+   If there is no comment, we simply take all the initial whitespace.  Then
+   every adjacent line with the prefix is filled as one paragraph."
+  "Fills a flushleft or indented Lisp comment."
+  (declare (ignore p))
+  ;;
+  ;; Find comment prefix.
+  (with-mark ((start (current-point))
+	      (end (current-point)))
+    (fill-lisp-comment-paragraph-prefix start end)
+    ;;
+    ;; 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))))
+
+
 (defcommand "Insert ()" (p)
   "Insert a pair of parentheses ().
    With positive argument, puts parentheses around the next p
-- 
GitLab