comment region

[hall@allegra.att.com (Bob Hall)]

Here's some old stuff I had lying around.  It works both for a selected
region and a region you specify by cntrl-<space> + move cursor (the
mouse-selected region takes precedence).
Actuated by "c-x c-;".   With a prefix numeric arg,
e.g. "c-u c-x c-;"  it removes (instead of adds) one level of semicolons.
(COMMENT-REGION and UNCOMMENT-REGION should probably be abstracted into
one routine, but I haven't taken the time.)
[Usual disclaimer about bugs, but it seems to work for me.]

-- Bob

;;; ****************************************************************
;;; Commenting in and out a region

(DEFMACRO WHILE (TESTFORM &BODY BODY)
  "Standard WHILE construct: TESTFORM is executed on entry,
   if it is nonNIL, body is executed and TESTFORM is then reexecuted.
   Iteration continues until TESTFORM returns NIL, whereupon the form
   returns NIL."
  `(LOOP (UNLESS ,TESTFORM (RETURN)) ,@BODY))

(DEFUN MYFIND-SELECTION-RANGE (WINDOW)
  "Returns two values: first is start position of region within WINDOW,
   second is end position.  If selection-range is empty then returns
   the region defined by point and mark."
  (MULTIPLE-VALUE-BIND (REG-START REG-END)
      (SELECTION-RANGE WINDOW)
    (IF (> REG-END REG-START)
        (VALUES REG-START REG-END)
        (LET* ((PT (BUFFER-POSITION (FRED-BUFFER WINDOW)))
               MK)
          (ED-EXCHANGE-POINT-AND-MARK WINDOW)
          (SETQ MK (BUFFER-POSITION (FRED-BUFFER WINDOW)))
          (ED-EXCHANGE-POINT-AND-MARK WINDOW)
          (VALUES (MIN PT MK) (MAX PT MK))))))

(DEFUN COMMENT-REGION (&OPTIONAL (WINDOW (FRONT-WINDOW)))
  "Puts a semicolon after each newline contained in the region of WINDOW.
   Puts one at the start of the region if the character before the start of
   the region is a newline.  Does not put one in after a newline that is the
   final character in the region.  Updates the cursor mark to the end of the
   region and extends the start of the region to include the new semicolon
   if necessary.   Does not turn off region."
  (MULTIPLE-VALUE-BIND (REG-START REG-END)
      (MYFIND-SELECTION-RANGE WINDOW)
    (SETQ REG-START (MAX REG-START 0))
    (WHEN (NOT (EQL REG-START REG-END))
      (LET* ((PREV-CHAR NIL)
             (POINT (FRED-BUFFER WINDOW)))
        (SET-MARK POINT (- REG-END 1))
        (WHILE (>= (BUFFER-POSITION POINT) REG-START)
          (SETQ PREV-CHAR
                (IF (ZEROP (BUFFER-POSITION POINT))
                    #\NEWLINE
                    (BUFFER-CHAR POINT
                                 (- (BUFFER-POSITION POINT) 1))))
          (WHEN (EQL PREV-CHAR #\NEWLINE)
            (BUFFER-INSERT POINT "\;")
            (INCF REG-END)
            (MOVE-MARK POINT -1))
          (MOVE-MARK POINT -1))
        (SET-MARK POINT REG-START)
        (SET-SELECTION-RANGE WINDOW REG-END)
        (FRED-UPDATE WINDOW))))
  (VALUES))

(DEFUN UNCOMMENT-REGION (&OPTIONAL (WINDOW (FRONT-WINDOW)))
  "Removes a semicolon after each newline contained in the region of WINDOW
   (if it exists).  Removes one at the start of the region if the character
   before the start of the region is a newline.  Does not remove any outside of
   the region.  Updates the cursor mark to the end of the region and fixes the start
   of the region to include the new semicolon if necessary.   Does not turn off
   region."
  (MULTIPLE-VALUE-BIND (REG-START REG-END)
      (MYFIND-SELECTION-RANGE WINDOW)
    (SETQ REG-START (MAX REG-START 0))
    (WHEN (NOT (EQL REG-START REG-END))
      (LET* ((PREV-CHAR NIL)
             (POINT (FRED-BUFFER WINDOW)))
        (SET-MARK POINT (- REG-END 1))
        (WHILE (>= (BUFFER-POSITION POINT) REG-START)
          (SETQ PREV-CHAR
                (IF (ZEROP (BUFFER-POSITION POINT))
                    #\NEWLINE
                    (BUFFER-CHAR POINT
                                 (- (BUFFER-POSITION POINT) 1))))
          (WHEN (AND (EQL PREV-CHAR #\NEWLINE)
                     (EQL (BUFFER-CHAR POINT) #\;))
            (BUFFER-DELETE POINT
                           (BUFFER-POSITION POINT)
                           (1+ (BUFFER-POSITION POINT)))
            (DECF REG-END))
          (MOVE-MARK POINT -1))
        (SET-MARK POINT REG-START)
        (SET-SELECTION-RANGE WINDOW REG-END)
        (FRED-UPDATE WINDOW))))
  (VALUES))

(DEFUN COMMENT-OR-UNCOMMENT-REGION (&OPTIONAL (WINDOW (FRONT-WINDOW)))
  (LET* ((PREFARG (FRED-PREFIX-ARGUMENT WINDOW)))
    (IF PREFARG
        (UNCOMMENT-REGION WINDOW)
        (COMMENT-REGION WINDOW))))

(COMTAB-SET-KEY (COMTAB-GET-KEY *COMTAB* '(:CONTROL #\X))
                '(:CONTROL #\;)
                'COMMENT-OR-UNCOMMENT-REGION
                "If there is no prefix numeric argument then
                 comments out all lines in the region.  If there is a
                 numeric argument, then UNcomments all lines in the region.")