Dogcows Code - chaz/tar/blob - rebox.el

   1 ;;; Handling of comment boxes.
   2 ;;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97 Free Software Foundation, Inc.
   3 ;;; François Pinard <pinard@iro.umontreal.ca>, April 1991.
   4
   5 ;;; I first observed rounded corners, as in style 223 boxes, in code from
   6 ;;; Warren Tucker <wht@n4hgf.mt-park.ga.us>, a previous shar maintainer.
   7
   8 ;;; Refilling paragraphs inside comments, stretching or shrinking the
   9 ;;; surrounding box as needed, is a pain to do "by hand".  This GNU Emacs
  10 ;;; LISP code eases my life on this and I find it fair, giving all sources
  11 ;;; for a package, to also give the means for nicely modifying comments.
  12
  13 ;;; The function rebox-comment discovers the extent of the boxed comments
  14 ;;; near the cursor, possibly refills the text, then adjusts the comment
  15 ;;; box style.  The function rebox-region does the same, except that it
  16 ;;; takes the current region as a boxed comment.  Numeric prefixes are
  17 ;;; used to add or remove a box, change its style (language, quality or
  18 ;;; type), or to prevent refilling of its text.  A minus sign alone as
  19 ;;; prefix asks for interactive style selection.
  20
  21 ;;; For most Emacs language editing modes, refilling does not make sense
  22 ;;; outside comments, so you may redefine the M-q command and link it to
  23 ;;; this file.  For example, I use this in my .emacs file:
  24
  25 ;;;     (setq c-mode-hook
  26 ;;;           '(lambda ()
  27 ;;;              (define-key c-mode-map "\M-q" 'rebox-comment)))
  28 ;;;     (autoload 'rebox-comment "rebox" nil t)
  29 ;;;     (autoload 'rebox-region "rebox" nil t)
  30
  31 ;;; The cursor should be within a comment before any of these commands,
  32 ;;; or else it should be between two comments, in which case the command
  33 ;;; applies to the next comment.  When the command is given without prefix,
  34 ;;; the current comment box style is recognized from the comment itself
  35 ;;; as far as possible, and preserved.  A prefix may be used to force
  36 ;;; a particular box style.  A style is made up of three attributes: a
  37 ;;; language (the hundreds digit), a quality (the tens digit) and a type
  38 ;;; (the units digit).  A zero or negative flag value changes the default
  39 ;;; box style to its absolute value.  Zero digits in default style,
  40 ;;; when not overriden in flag, asks for recognition of corresponding
  41 ;;; attributes from the current box.  `C-u' avoids refilling the text,
  42 ;;; using the default box style.  `C-u -' defines the style interactively.
  43
  44 ;;; Box language is associated with comment delimiters.  Values are 100
  45 ;;; for none or unknown, 200 for `/*' and `*/' as in plain C, 300 for
  46 ;;; '//' as in C++, 400 for `#' as in most scripting languages, 500 for
  47 ;;; `;' as in LISP or assembler and 600 for `%' as in TeX or PostScript.
  48
  49 ;;; Box quality differs according to language.  For unknown languages (100)
  50 ;;; or for the C language (200), values are 10 for simple, 20 or 30 for
  51 ;;; rounded, and 40 for starred.  For all others, box quality indicates
  52 ;;; the thickness in characters of the left and right sides of the box:
  53 ;;; values are 10, 20, 30 or 40 for 1, 2, 3 or 4 characters wide.  C++
  54 ;;; quality 10 is always promoted to 20.  Roughly said, simple quality
  55 ;;; boxes (10) use comment delimiters to left and right of each comment
  56 ;;; line, and also for the top or bottom line when applicable.  Rounded
  57 ;;; quality boxes (20 or 30) try to suggest rounded corners in boxes.
  58 ;;; Starred quality boxes (40) mostly use a left margin of asterisks or
  59 ;;; X'es, and use them also in box surroundings.  Experiment a little to
  60 ;;; see what happens.
  61
  62 ;;; Box type values are 1 for fully opened boxes for which boxing is done
  63 ;;; only for the left and right but not for top or bottom, 2 for half
  64 ;;; single lined boxes for which boxing is done on all sides except top,
  65 ;;; 3 for fully single lined boxes for which boxing is done on all sides,
  66 ;;; 4 for half double lined boxes which is like type 2 but more bold,
  67 ;;; or 5 for fully double lined boxes which is like type 3 but more bold.
  68
  69 ;;; The special style 221 or 231 is worth a note, because it is fairly
  70 ;;; common: the whole C comment stays between a single opening `/*'
  71 ;;; and a single closing `*/'.  The special style 111 deletes a box.
  72 ;;; The initial default style is 023 so, unless overriden, comments are
  73 ;;; put in single lined boxes, C comments are of rounded quality.
  74
  75 (defvar rebox-default-style 0 "*Preferred style for box comments.")
  76
  77 ;;; Help strings for prompting or error messages.
  78
  79 (defconst REBOX_HELP_FOR_LANGUAGE
  80   "Box language is 100-none, 200-/*, 300-//, 400-#, 500-;, 600-%%")
  81 (defconst REBOX_LANGUAGE_NONE 100)
  82 (defconst REBOX_LANGUAGE_C 200)
  83 (defconst REBOX_LANGUAGE_C++ 300)
  84 (defconst REBOX_LANGUAGE_AWK 400)
  85 (defconst REBOX_LANGUAGE_LISP 500)
  86 (defconst REBOX_LANGUAGE_TEX 600)
  87
  88 (defun rebox-help-string-for-language (language)
  89   (cond ((= language 0) "default language")
  90         ((= language REBOX_LANGUAGE_NONE) "no language")
  91         ((= language REBOX_LANGUAGE_C) "plain C")
  92         ((= language REBOX_LANGUAGE_C++) "C++")
  93         ((= language REBOX_LANGUAGE_AWK) "sh/Perl/make")
  94         ((= language REBOX_LANGUAGE_LISP) "LISP/assembler")
  95         ((= language REBOX_LANGUAGE_TEX) "TeX/PostScript")
  96         (t "<Unknown Language>")))
  97
  98 (defconst REBOX_HELP_FOR_QUALITY
  99   "Box quality/width is 10-simple, 20-rounded, 30-rounded or 40-starred")
 100 (defconst REBOX_QUALITY_SIMPLE_ONE 10)
 101 (defconst REBOX_QUALITY_ROUNDED_TWO 20)
 102 (defconst REBOX_QUALITY_ROUNDED_THREE 30)
 103 (defconst REBOX_QUALITY_STARRED_FOUR 40)
 104
 105 (defun rebox-help-string-for-quality (quality)
 106   (cond ((= quality 0) "default quality")
 107         ((= quality REBOX_QUALITY_SIMPLE_ONE) "square or 1-wide")
 108         ((= quality REBOX_QUALITY_ROUNDED_TWO) "rounded or 2-wide")
 109         ((= quality REBOX_QUALITY_ROUNDED_THREE) "rounded or 3-wide")
 110         ((= quality REBOX_QUALITY_STARRED_FOUR) "starred or 4-wide")
 111         (t "<Unknown Quality>")))
 112
 113 (defconst REBOX_HELP_FOR_TYPE
 114   "Box type is 1-open, 2-half-single, 3-single, 4-half-double or 5-double")
 115 (defconst REBOX_TYPE_OPEN 1)
 116 (defconst REBOX_TYPE_HALF_SINGLE 2)
 117 (defconst REBOX_TYPE_SINGLE 3)
 118 (defconst REBOX_TYPE_HALF_DOUBLE 4)
 119 (defconst REBOX_TYPE_DOUBLE 5)
 120
 121 (defun rebox-help-string-for-type (type)
 122   (cond ((= type 0) "default type")
 123         ((= type REBOX_TYPE_OPEN) "opened box")
 124         ((= type REBOX_TYPE_HALF_SINGLE) "half normal")
 125         ((= type REBOX_TYPE_SINGLE) "full normal")
 126         ((= type REBOX_TYPE_HALF_DOUBLE) "half bold")
 127         ((= type REBOX_TYPE_DOUBLE) "full bold")
 128         (t "<Unknown Type>")))
 129
 130 (defconst REBOX_MAX_LANGUAGE 6)
 131 (defconst REBOX_MAX_QUALITY 4)
 132 (defconst REBOX_MAX_TYPE 5)
 133
 134 ;;; Request the style interactively, using the minibuffer.
 135
 136 (defun rebox-ask-for-style ()
 137   (let (key language quality type)
 138     (while (not language)
 139       (message REBOX_HELP_FOR_LANGUAGE)
 140       (setq key (read-char))
 141       (if (and (>= key ?0) (<= key (+ ?0 REBOX_MAX_LANGUAGE)))
 142           (setq language (- key ?0))))
 143     (while (not quality)
 144       (message REBOX_HELP_FOR_QUALITY)
 145       (setq key (read-char))
 146       (if (and (>= key ?0) (<= key (+ ?0 REBOX_MAX_QUALITY)))
 147           (setq quality (- key ?0))))
 148     (while (not type)
 149       (message REBOX_HELP_FOR_TYPE)
 150       (setq key (read-char))
 151       (if (and (>= key ?0) (<= key (+ ?0 REBOX_MAX_TYPE)))
 152           (setq type (- key ?0))))
 153     (+ (* 100 language) (* 10 quality) type)))
 154
 155 ;;; Write some TEXT followed by an edited STYLE value into the minibuffer.
 156
 157 (defun rebox-show-style (text style)
 158   (message
 159    (concat text (format " (%03d)" style)
 160            ": " (rebox-help-string-for-language (* (/ style 100) 100))
 161            ", " (rebox-help-string-for-quality (* (% (/ style 10) 10) 10))
 162            ", " (rebox-help-string-for-type (% style 10)))))
 163
 164 ;;; Validate FLAG and usually return t if not interrupted by errors.
 165 ;;; But if FLAG is zero or negative, then change default box style and
 166 ;;; return nil.
 167
 168 (defun rebox-validate-flag (flag)
 169
 170   ;; Validate flag.
 171
 172   (if (numberp flag)
 173       (let ((value (if (< flag 0) (- flag) flag)))
 174         (if (> (/ value 100) REBOX_MAX_LANGUAGE)
 175             (error REBOX_HELP_FOR_LANGUAGE))
 176         (if (> (% (/ value 10) 10) REBOX_MAX_QUALITY)
 177             (error REBOX_HELP_FOR_QUALITY))
 178         (if (> (% value 10) REBOX_MAX_TYPE)
 179             (error REBOX_HELP_FOR_TYPE))))
 180
 181   ;; Change default box style if requested.
 182
 183   (if (and (numberp flag) (<= flag 0))
 184       (progn
 185         (setq flag (- flag))
 186         (if (not (zerop (/ flag 100)))
 187             (setq rebox-default-style
 188                   (+ (* (/ flag 100) 100)
 189                      (% rebox-default-style 100))))
 190         (if (not (zerop (% (/ flag 10) 10)))
 191             (setq rebox-default-style
 192                   (+ (* (/ rebox-default-style 100) 100)
 193                      (* (% (/ flag 10) 10) 10)
 194                      (% rebox-default-style 10))))
 195         (if (not (zerop (% flag 10)))
 196             (setq rebox-default-style
 197                   (+ (* (/ rebox-default-style 10) 10)
 198                      (% flag 10))))
 199         (rebox-show-style "Default style" rebox-default-style)
 200         nil)
 201     t))
 202
 203 ;;; Return the minimum value of the left margin of all lines, or -1 if
 204 ;;; all lines are empty.
 205
 206 (defun rebox-left-margin ()
 207   (let ((margin -1))
 208     (goto-char (point-min))
 209     (while (not (eobp))
 210       (skip-chars-forward " \t")
 211       (if (not (looking-at "\n"))
 212           (setq margin
 213                 (if (< margin 0)
 214                     (current-column)
 215                   (min margin (current-column)))))
 216       (forward-line 1))
 217     margin))
 218
 219 ;;; Return the maximum value of the right margin of all lines.  Any
 220 ;;; sentence ending a line has a space guaranteed before the margin.
 221
 222 (defun rebox-right-margin ()
 223   (let ((margin 0) period)
 224     (goto-char (point-min))
 225     (while (not (eobp))
 226       (end-of-line)
 227       (if (bobp)
 228           (setq period 0)
 229         (backward-char 1)
 230         (setq period (if (looking-at "[.?!]") 1 0))
 231         (forward-char 1))
 232       (setq margin (max margin (+ (current-column) period)))
 233       (forward-char 1))
 234     margin))
 235
 236 ;;; Return a regexp to match the start or end of a comment for some
 237 ;;; LANGUAGE, leaving the comment marks themselves available in \1.
 238
 239 ;; FIXME: Recognize style 1** boxes.
 240
 241 (defun rebox-regexp-start (language)
 242   (cond ((= language 0) "^[ \t]*\\(/\\*\\|//+\\|#+\\|;+\\|%+\\)")
 243         ((= language REBOX_LANGUAGE_NONE) "^\\(\\)")
 244         ((= language REBOX_LANGUAGE_C) "^[ \t]*\\(/\\*\\)")
 245         ((= language REBOX_LANGUAGE_C++) "^[ \t]*\\(//+\\)")
 246         ((= language REBOX_LANGUAGE_AWK) "^[ \t]*\\(#+\\)")
 247         ((= language REBOX_LANGUAGE_LISP) "^[ \t]*\\(;+\\)")
 248         ((= language REBOX_LANGUAGE_TEX) "^[ \t]*\\(%+\\)")))
 249
 250 (defun rebox-regexp-end (language)
 251   (cond ((= language 0) "\\(\\*/\\|//+\\|#+\\|;+\\|%+\\)[ \t]*$")
 252         ((= language REBOX_LANGUAGE_NONE) "\\(\\)$")
 253         ((= language REBOX_LANGUAGE_C) "\\(\\*/\\)[ \t]*$")
 254         ((= language REBOX_LANGUAGE_C++) "\\(//+\\)[ \t]*$")
 255         ((= language REBOX_LANGUAGE_AWK) "\\(#+\\)[ \t]*$")
 256         ((= language REBOX_LANGUAGE_LISP) "\\(;+\\)[ \t]*$")
 257         ((= language REBOX_LANGUAGE_TEX) "\\(%+\\)[ \t]*$")))
 258
 259 ;;; By looking at the text starting at the cursor position, guess the
 260 ;;; language in use, and return it.
 261
 262 (defun rebox-guess-language ()
 263   (let ((language REBOX_LANGUAGE_NONE)
 264         (value (* 100 REBOX_MAX_LANGUAGE)))
 265     (while (not (zerop value))
 266       (if (looking-at (rebox-regexp-start value))
 267           (progn
 268             (setq language value)
 269             (setq value 0))
 270         (setq value (- value 100))))
 271     language))
 272
 273 ;;; Find the limits of the block of comments following or enclosing
 274 ;;; the cursor, or return an error if the cursor is not within such a
 275 ;;; block of comments.  Extend it as far as possible in both
 276 ;;; directions, then narrow the buffer around it.
 277
 278 (defun rebox-find-and-narrow ()
 279   (save-excursion
 280     (let (start end temp language)
 281
 282       ;; Find the start of the current or immediately following comment.
 283
 284       (beginning-of-line)
 285       (skip-chars-forward " \t\n")
 286       (beginning-of-line)
 287       (if (not (looking-at (rebox-regexp-start 0)))
 288           (progn
 289             (setq temp (point))
 290             (if (re-search-forward "\\*/" nil t)
 291                 (progn
 292                   (re-search-backward "/\\*")
 293                   (if (> (point) temp)
 294                       (error "outside any comment block"))
 295                   (setq temp (point))
 296                   (beginning-of-line)
 297                   (skip-chars-forward " \t")
 298                   (if (not (= (point) temp))
 299                       (error "text before start of comment"))
 300                   (beginning-of-line))
 301               (error "outside any comment block"))))
 302
 303       (setq start (point))
 304       (setq language (rebox-guess-language))
 305
 306       ;; - find the end of this comment
 307
 308       (if (= language REBOX_LANGUAGE_C)
 309           (progn
 310             (search-forward "*/")
 311             (if (not (looking-at "[ \t]*$"))
 312                 (error "text after end of comment"))))
 313       (end-of-line)
 314       (if (eobp)
 315           (insert "\n")
 316         (forward-char 1))
 317       (setq end (point))
 318
 319       ;; - try to extend the comment block backwards
 320
 321       (goto-char start)
 322       (while (and (not (bobp))
 323                   (if (= language REBOX_LANGUAGE_C)
 324                       (progn
 325                         (skip-chars-backward " \t\n")
 326                         (if (and (looking-at "[ \t]*\n[ \t]*/\\*")
 327                                  (> (point) 2))
 328                             (progn
 329                               (backward-char 2)
 330                               (if (looking-at "\\*/")
 331                                   (progn
 332                                     (re-search-backward "/\\*")
 333                                     (setq temp (point))
 334                                     (beginning-of-line)
 335                                     (skip-chars-forward " \t")
 336                                     (if (= (point) temp)
 337                                         (progn (beginning-of-line) t)))))))
 338                     (previous-line 1)
 339                     (looking-at (rebox-regexp-start language))))
 340         (setq start (point)))
 341
 342       ;; - try to extend the comment block forward
 343
 344       (goto-char end)
 345       (while (looking-at (rebox-regexp-start language))
 346         (if (= language REBOX_LANGUAGE_C)
 347             (progn
 348               (re-search-forward "[ \t]*/\\*")
 349               (re-search-forward "\\*/")
 350               (if (looking-at "[ \t]*$")
 351                   (progn
 352                     (beginning-of-line)
 353                     (forward-line 1)
 354                     (setq end (point)))))
 355           (forward-line 1)
 356           (setq end (point))))
 357
 358       ;; - narrow to the whole block of comments
 359
 360       (narrow-to-region start end))))
 361
 362 ;;; After refilling it if REFILL is not nil, while respecting a left
 363 ;;; MARGIN, put the narrowed buffer back into a boxed LANGUAGE comment
 364 ;;; box of a given QUALITY and TYPE.
 365
 366 (defun rebox-reconstruct (refill margin language quality type)
 367   (rebox-show-style "Style" (+ language quality type))
 368
 369   (let (right-margin nw nn ne ww ee sw ss se x xx)
 370
 371     ;; - decide the elements of the box being produced
 372
 373     (cond ((= language REBOX_LANGUAGE_NONE)
 374            ;; - planify a comment for no language in particular
 375
 376            (cond ((= quality REBOX_QUALITY_SIMPLE_ONE)
 377                   ;; - planify a simple box
 378
 379                   (cond ((= type REBOX_TYPE_OPEN)
 380                          (setq nw "") (setq sw "")
 381                          (setq ww "") (setq ee ""))
 382                         ((= type REBOX_TYPE_HALF_SINGLE)
 383                          (setq nw "")
 384                          (setq ww "| ")              (setq ee " |")
 385                          (setq sw "+-") (setq ss ?-) (setq se "-+"))
 386                         ((= type REBOX_TYPE_SINGLE)
 387                          (setq nw "+-") (setq nn ?-) (setq ne "-+")
 388                          (setq ww "| ")              (setq ee " |")
 389                          (setq sw "+-") (setq ss ?-) (setq se "-+"))
 390                         ((= type REBOX_TYPE_HALF_DOUBLE)
 391                          (setq nw "")
 392                          (setq ww "| ")              (setq ee " |")
 393                          (setq sw "*=") (setq ss ?=) (setq se "=*"))
 394                         ((= type REBOX_TYPE_DOUBLE)
 395                          (setq nw "*=") (setq nn ?=) (setq ne "=*")
 396                          (setq ww "| ")              (setq ee " |")
 397                          (setq sw "*=") (setq ss ?=) (setq se "=*"))))
 398
 399                  ((or (= quality REBOX_QUALITY_ROUNDED_TWO)
 400                       (= quality REBOX_QUALITY_ROUNDED_THREE))
 401                   ;; - planify a rounded box
 402
 403                   (cond ((= type REBOX_TYPE_OPEN)
 404                          (setq nw "") (setq sw "")
 405                          (setq ww "| ") (setq ee " |"))
 406                         ((= type REBOX_TYPE_HALF_SINGLE)
 407                          (setq nw "")
 408                          (setq ww "| ")              (setq ee " |")
 409                          (setq sw "`-") (setq ss ?-) (setq se "-'"))
 410                         ((= type REBOX_TYPE_SINGLE)
 411                          (setq nw ".-") (setq nn ?-) (setq ne "-.")
 412                          (setq ww "| ")              (setq ee " |")
 413                          (setq sw "`-") (setq ss ?-) (setq se "-'"))
 414                         ((= type REBOX_TYPE_HALF_DOUBLE)
 415                          (setq nw "")
 416                          (setq ww "| " )              (setq ee " |" )
 417                          (setq sw "\\=") (setq ss ?=) (setq se "=/" ))
 418                         ((= type REBOX_TYPE_DOUBLE)
 419                          (setq nw "/=" ) (setq nn ?=) (setq ne "=\\")
 420                          (setq ww "| " )              (setq ee " |" )
 421                          (setq sw "\\=") (setq ss ?=) (setq se "=/" ))))
 422
 423                  ((= quality REBOX_QUALITY_STARRED_FOUR)
 424                   ;; - planify a starred box
 425
 426                   (cond ((= type REBOX_TYPE_OPEN)
 427                          (setq nw "") (setq sw "")
 428                          (setq ww "| ") (setq ee ""))
 429                         ((= type REBOX_TYPE_HALF_SINGLE)
 430                          (setq nw "")
 431                          (setq ww "* ")              (setq ee " *")
 432                          (setq sw "**") (setq ss ?*) (setq se "**"))
 433                         ((= type REBOX_TYPE_SINGLE)
 434                          (setq nw "**") (setq nn ?*) (setq ne "**")
 435                          (setq ww "* ")              (setq ee " *")
 436                          (setq sw "**") (setq ss ?*) (setq se "**"))
 437                         ((= type REBOX_TYPE_HALF_DOUBLE)
 438                          (setq nw "")
 439                          (setq ww "X ")              (setq ee " X")
 440                          (setq sw "XX") (setq ss ?X) (setq se "XX"))
 441                         ((= type REBOX_TYPE_DOUBLE)
 442                          (setq nw "XX") (setq nn ?X) (setq ne "XX")
 443                          (setq ww "X ")              (setq ee " X")
 444                          (setq sw "XX") (setq ss ?X) (setq se "XX"))))))
 445
 446           ((= language REBOX_LANGUAGE_C)
 447            ;; - planify a comment for C
 448
 449            (cond ((= quality REBOX_QUALITY_SIMPLE_ONE)
 450                   ;; - planify a simple C comment
 451
 452                   (cond ((= type REBOX_TYPE_OPEN)
 453                          (setq nw "") (setq sw "")
 454                          (setq ww "/* ") (setq ee " */"))
 455                         ((= type REBOX_TYPE_HALF_SINGLE)
 456                          (setq nw "")
 457                          (setq ww "/* ")              (setq ee " */")
 458                          (setq sw "/* ") (setq ss ?-) (setq se " */"))
 459                         ((= type REBOX_TYPE_SINGLE)
 460                          (setq nw "/* ") (setq nn ?-) (setq ne " */")
 461                          (setq ww "/* ")              (setq ee " */")
 462                          (setq sw "/* ") (setq ss ?-) (setq se " */"))
 463                         ((= type REBOX_TYPE_HALF_DOUBLE)
 464                          (setq nw "")
 465                          (setq ww "/* ")              (setq ee " */")
 466                          (setq sw "/* ") (setq ss ?=) (setq se " */"))
 467                         ((= type REBOX_TYPE_DOUBLE)
 468                          (setq nw "/* ") (setq nn ?=) (setq ne " */")
 469                          (setq ww "/* ")              (setq ee " */")
 470                          (setq sw "/* ") (setq ss ?=) (setq se " */"))))
 471
 472                  ((or (= quality REBOX_QUALITY_ROUNDED_TWO)
 473                       (= quality REBOX_QUALITY_ROUNDED_THREE))
 474                   ;; - planify a rounded C comment
 475
 476                   (cond ((= type REBOX_TYPE_OPEN)
 477                          ;; ``open rounded'' is a special case
 478                          (setq nw "") (setq sw "")
 479                          (setq ww "   ") (setq ee ""))
 480                         ((= type REBOX_TYPE_HALF_SINGLE)
 481                          (setq nw "/*") (setq nn ? ) (setq ne " .")
 482                          (setq ww "| ")              (setq ee " |")
 483                          (setq sw "`-") (setq ss ?-) (setq se "*/"))
 484                         ((= type REBOX_TYPE_SINGLE)
 485                          (setq nw "/*") (setq nn ?-) (setq ne "-.")
 486                          (setq ww "| ")              (setq ee " |")
 487                          (setq sw "`-") (setq ss ?-) (setq se "*/"))
 488                         ((= type REBOX_TYPE_HALF_DOUBLE)
 489                          (setq nw "/*" ) (setq nn ? ) (setq ne " \\")
 490                          (setq ww "| " )              (setq ee " |" )
 491                          (setq sw "\\=") (setq ss ?=) (setq se "*/" ))
 492                         ((= type REBOX_TYPE_DOUBLE)
 493                          (setq nw "/*" ) (setq nn ?=) (setq ne "=\\")
 494                          (setq ww "| " )              (setq ee " |" )
 495                          (setq sw "\\=") (setq ss ?=) (setq se "*/" ))))
 496
 497                  ((= quality REBOX_QUALITY_STARRED_FOUR)
 498                   ;; - planify a starred C comment
 499
 500                   (cond ((= type REBOX_TYPE_OPEN)
 501                          (setq nw "/* ") (setq nn ? ) (setq ne "")
 502                          (setq ww " * ")              (setq ee "")
 503                          (setq sw " */") (setq ss ? ) (setq se ""))
 504                         ((= type REBOX_TYPE_HALF_SINGLE)
 505                          (setq nw "/* ") (setq nn ? ) (setq ne " *")
 506                          (setq ww " * ")              (setq ee " *")
 507                          (setq sw " **") (setq ss ?*) (setq se "**/"))
 508                         ((= type REBOX_TYPE_SINGLE)
 509                          (setq nw "/**") (setq nn ?*) (setq ne "**")
 510                          (setq ww " * ")              (setq ee " *")
 511                          (setq sw " **") (setq ss ?*) (setq se "**/"))
 512                         ((= type REBOX_TYPE_HALF_DOUBLE)
 513                          (setq nw "/* " ) (setq nn ? ) (setq ne " *\\")
 514                          (setq ww "|* " )              (setq ee " *|" )
 515                          (setq sw "\\**") (setq ss ?*) (setq se "**/" ))
 516                         ((= type REBOX_TYPE_DOUBLE)
 517                          (setq nw "/**" ) (setq nn ?*) (setq ne "**\\")
 518                          (setq ww "|* " )              (setq ee " *|" )
 519                          (setq sw "\\**") (setq ss ?*) (setq se "**/" ))))))
 520
 521           (t
 522            ;; - planify a comment for all other things
 523
 524            (if (and (= language REBOX_LANGUAGE_C++)
 525                     (= quality REBOX_QUALITY_SIMPLE_ONE))
 526                (setq quality REBOX_QUALITY_ROUNDED_TWO))
 527            (setq x (cond ((= language REBOX_LANGUAGE_C++) ?/)
 528                          ((= language REBOX_LANGUAGE_AWK) ?#)
 529                          ((= language REBOX_LANGUAGE_LISP) ?\;)
 530                          ((= language REBOX_LANGUAGE_TEX) ?%)))
 531            (setq xx (make-string (/ quality 10) x))
 532            (setq ww (concat xx " "))
 533            (cond ((= type REBOX_TYPE_OPEN)
 534                   (setq nw "") (setq sw "") (setq ee ""))
 535                  ((= type REBOX_TYPE_HALF_SINGLE)
 536                   (setq ee (concat " " xx))
 537                   (setq nw "")
 538                   (setq sw ww) (setq ss ?-) (setq se ee))
 539                  ((= type REBOX_TYPE_SINGLE)
 540                   (setq ee (concat " " xx))
 541                   (setq nw ww) (setq nn ?-) (setq ne ee)
 542                   (setq sw ww) (setq ss ?-) (setq se ee))
 543                  ((= type REBOX_TYPE_HALF_DOUBLE)
 544                   (setq ee (concat " " xx))
 545                   (setq xx (make-string (1+ (/ quality 10)) x))
 546                   (setq nw "")
 547                   (setq sw xx) (setq ss x) (setq se xx))
 548                  ((= type REBOX_TYPE_DOUBLE)
 549                   (setq ee (concat " " xx))
 550                   (setq xx (make-string (1+ (/ quality 10)) x))
 551                   (setq nw xx) (setq nn x) (setq ne xx)
 552                   (setq sw xx) (setq ss x) (setq se xx)))))
 553
 554     ;; - possibly refill, and adjust margins to account for left inserts
 555
 556     (if (not (and flag (listp flag)))
 557         (let ((fill-prefix (make-string margin ? ))
 558               (fill-column (- fill-column (+ (length ww) (length ee)))))
 559           (fill-region (point-min) (point-max))))
 560
 561     (setq right-margin (+ (rebox-right-margin) (length ww)))
 562
 563     ;; - construct the box comment, from top to bottom
 564
 565     (goto-char (point-min))
 566     (if (and (= language REBOX_LANGUAGE_C)
 567              (or (= quality REBOX_QUALITY_ROUNDED_TWO)
 568                  (= quality REBOX_QUALITY_ROUNDED_THREE))
 569              (= type REBOX_TYPE_OPEN))
 570         (progn
 571           ;; - construct an 33 style comment
 572
 573           (skip-chars-forward " " (+ (point) margin))
 574           (insert (make-string (- margin (current-column)) ? )
 575                   "/* ")
 576           (end-of-line)
 577           (forward-char 1)
 578           (while (not (eobp))
 579             (skip-chars-forward " " (+ (point) margin))
 580             (insert (make-string (- margin (current-column)) ? )
 581                     ww)
 582             (beginning-of-line)
 583             (forward-line 1))
 584           (backward-char 1)
 585           (insert "  */"))
 586
 587       ;; - construct all other comment styles
 588
 589       ;; construct one top line
 590       (if (not (zerop (length nw)))
 591           (progn
 592             (indent-to margin)
 593             (insert nw)
 594             (if (or (not (eq nn ? )) (not (zerop (length ne))))
 595                 (insert (make-string (- right-margin (current-column)) nn)
 596                         ne))
 597             (insert "\n")))
 598
 599       ;; construct one middle line
 600       (while (not (eobp))
 601         (skip-chars-forward " " (+ (point) margin))
 602         (insert (make-string (- margin (current-column)) ? )
 603                 ww)
 604         (end-of-line)
 605         (if (not (zerop (length ee)))
 606             (progn
 607               (indent-to right-margin)
 608               (insert ee)))
 609         (beginning-of-line)
 610         (forward-line 1))
 611
 612       ;; construct one bottom line
 613       (if (not (zerop (length sw)))
 614           (progn
 615             (indent-to margin)
 616             (insert sw)
 617             (if (or (not (eq ss ? )) (not (zerop (length se))))
 618                 (insert (make-string (- right-margin (current-column)) ss)
 619                         se "\n")))))))
 620
 621 ;;; Add, delete or adjust a comment box in the narrowed buffer.
 622 ;;; Various FLAG values are explained at beginning of this file.
 623
 624 (defun rebox-engine (flag)
 625   (let ((undo-list buffer-undo-list)
 626         (marked-point (point-marker))
 627         (language (progn (goto-char (point-min)) (rebox-guess-language)))
 628         (quality 0)
 629         (type 0))
 630
 631     (untabify (point-min) (point-max))
 632
 633     ;; Remove all the comment marks, and move all the text rigidly to the
 634     ;; left for insuring that the left margin stays at the same place.
 635     ;; At the same time, try recognizing the box style, saving its quality
 636     ;; in QUALITY and its type in TYPE.  (LANGUAGE is already guessed.)
 637
 638     (let ((indent-tabs-mode nil)
 639           (previous-margin (rebox-left-margin))
 640           actual-margin)
 641
 642       ;; FIXME: Cleanup style 1** boxes.
 643       ;; FIXME: Recognize really all cases of type and quality.
 644
 645       ;; - remove all comment marks
 646
 647       (if (= language REBOX_LANGUAGE_NONE)
 648           nil
 649         (goto-char (point-min))
 650         (while (re-search-forward (rebox-regexp-start language) nil t)
 651           (goto-char (match-beginning 1))
 652           (delete-region (point) (match-end 1))
 653           (insert (make-string (- (match-end 1) (point)) ? )))
 654         (goto-char (point-min))
 655         (while (re-search-forward (rebox-regexp-end language) nil t)
 656           (replace-match "" t t)))
 657
 658       (if (= language REBOX_LANGUAGE_C)
 659           (progn
 660             (goto-char (point-min))
 661             (while (re-search-forward "\\*/ */\\*" nil t)
 662               (replace-match "  " t t))
 663
 664             (goto-char (point-min))
 665             (while (re-search-forward "^\\( *\\)|\\*\\(.*\\)\\*| *$" nil t)
 666               (setq quality REBOX_QUALITY_STARRED_FOUR)
 667               (setq type REBOX_TYPE_DOUBLE)
 668               (replace-match "\\1  \\2" t))
 669
 670             (goto-char (point-min))
 671             (while (re-search-forward "^\\( *\\)\\*\\(.*\\)\\* *$" nil t)
 672               (setq quality REBOX_QUALITY_STARRED_FOUR)
 673               (setq type REBOX_TYPE_SINGLE)
 674               (replace-match "\\1 \\2" t))
 675
 676             (goto-char (point-min))
 677             (while (re-search-forward "^\\( *\\)|\\(.*\\)| *$" nil t)
 678               (setq quality REBOX_QUALITY_ROUNDED_TWO)
 679               (replace-match "\\1 \\2" t))
 680
 681             (goto-char (point-min))
 682             (if (zerop quality)
 683                 (while (re-search-forward "^\\( +\\)\\* " nil t)
 684                   (setq quality REBOX_QUALITY_STARRED_FOUR)
 685                   (setq type REBOX_TYPE_OPEN)
 686                   (replace-match "\\1  " t)))))
 687
 688       ;; - remove the first dashed or starred line
 689
 690       (goto-char (point-min))
 691       (if (looking-at "^ *\\(--+\\|\\*\\*+\\)[.\+\\]? *\n")
 692           (progn
 693             (setq type REBOX_TYPE_SINGLE)
 694             (replace-match "" t t))
 695         (if (looking-at "^ *\\(==\\|XX+\\|##+\\|;;+\\)[.\+\\]? *\n")
 696             (progn
 697               (setq type REBOX_TYPE_DOUBLE)
 698               (replace-match "" t t))))
 699
 700       ;; - remove the last dashed or starred line
 701
 702       (goto-char (point-max))
 703       (previous-line 1)
 704       (if (looking-at "^ *[`\+\\]?*--+ *\n")
 705           (progn
 706             (if (= type REBOX_TYPE_OPEN)
 707                 (setq type REBOX_TYPE_HALF_SINGLE))
 708             (replace-match "" t t))
 709         (if (looking-at "^ *[`\+\\]?*\\(==+\\|##+\\|;;+\\) *\n")
 710             (progn
 711               (if (= type REBOX_TYPE_OPEN)
 712                   (setq type REBOX_TYPE_HALF_DOUBLE))
 713               (replace-match "" t t))
 714           (if (looking-at "^ *\\*\\*+[.\+\\]? *\n")
 715               (progn
 716                 (setq quality REBOX_QUALITY_STARRED_FOUR)
 717                 (setq type REBOX_TYPE_HALF_SINGLE)
 718                 (replace-match "" t t))
 719             (if (looking-at "^ *XX+[.\+\\]? *\n")
 720                 (progn
 721                   (setq quality REBOX_QUALITY_STARRED_FOUR)
 722                   (setq type REBOX_TYPE_HALF_DOUBLE)
 723                   (replace-match "" t t))))))
 724
 725       ;; - remove all spurious whitespace
 726
 727       (goto-char (point-min))
 728       (while (re-search-forward " +$" nil t)
 729         (replace-match "" t t))
 730
 731       (goto-char (point-min))
 732       (if (looking-at "\n+")
 733           (replace-match "" t t))
 734
 735       (goto-char (point-max))
 736       (skip-chars-backward "\n")
 737       (if (looking-at "\n\n+")
 738           (replace-match "\n" t t))
 739
 740       (goto-char (point-min))
 741       (while (re-search-forward "\n\n\n+" nil t)
 742         (replace-match "\n\n" t t))
 743
 744       ;; - move the text left is adequate
 745
 746       (setq actual-margin (rebox-left-margin))
 747       (if (not (= previous-margin actual-margin))
 748           (indent-rigidly (point-min) (point-max)
 749                           (- previous-margin actual-margin))))
 750
 751     ;; Override box style according to FLAG or chosen default style.
 752     ;; Else, use either recognized style elements or built-in defaults.
 753
 754     (cond ((and (numberp flag) (not (zerop (/ flag 100))))
 755            (setq language (* (/ flag 100) 100)))
 756           ((not (zerop (/ rebox-default-style 100)))
 757            (setq language (* (/ rebox-default-style 100) 100))))
 758
 759     (cond ((and (numberp flag) (not (zerop (% (/ flag 10) 10))))
 760            (setq quality (* (% (/ flag 10) 10) 10)))
 761           ((not (zerop (% (/ rebox-default-style 10) 10)))
 762            (setq quality (* (% (/ rebox-default-style 10) 10) 10)))
 763           ((zerop quality)
 764            (setq quality REBOX_QUALITY_ROUNDED_TWO)))
 765
 766     (cond ((and (numberp flag) (not (zerop (% flag 10))))
 767            (setq type (% flag 10)))
 768           ((not (zerop (% rebox-default-style 10)))
 769            (setq type (% rebox-default-style 10)))
 770           ((zerop type)
 771            (setq type 1)))
 772
 773     ;; Possibly refill, then reconstruct the comment box.
 774
 775     (let ((indent-tabs-mode nil))
 776       (rebox-reconstruct (not (and flag (listp flag)))
 777                          (rebox-left-margin)
 778                          language quality type))
 779
 780     ;; Retabify to the left only (adapted from tabify.el).
 781
 782     (if indent-tabs-mode
 783         (progn
 784           (goto-char (point-min))
 785           (while (re-search-forward "^[ \t][ \t]+" nil t)
 786             (let ((column (current-column)))
 787               (delete-region (match-beginning 0) (point))
 788               (indent-to column)))))
 789
 790     ;; Restore the point position.
 791
 792     (goto-char (marker-position marked-point))
 793
 794     ;; Remove all intermediate boundaries from the undo list.
 795
 796     (if (not (eq buffer-undo-list undo-list))
 797         (let ((cursor buffer-undo-list))
 798           (while (not (eq (cdr cursor) undo-list))
 799             (if (car (cdr cursor))
 800                 (setq cursor (cdr cursor))
 801               (rplacd cursor (cdr (cdr cursor)))))))))
 802
 803 ;;; Set or reset the Taarna team's own way for a C style.  You do not
 804 ;;; really want to know about this.
 805
 806 (defvar c-mode-taarna-style nil "*Non-nil for Taarna team C-style.")
 807
 808 (defun taarna-mode ()
 809   (interactive)
 810   (if c-mode-taarna-style
 811       (progn
 812
 813         (setq c-mode-taarna-style nil)
 814         (setq c-indent-level 2)
 815         (setq c-continued-statement-offset 2)
 816         (setq c-brace-offset 0)
 817         (setq c-argdecl-indent 5)
 818         (setq c-label-offset -2)
 819         (setq c-tab-always-indent t)
 820         (setq rebox-default-style REBOX_QUALITY_ROUNDED_TWO)
 821         (message "C mode: GNU style"))
 822
 823     (setq c-mode-taarna-style t)
 824     (setq c-indent-level 4)
 825     (setq c-continued-statement-offset 4)
 826     (setq c-brace-offset -4)
 827     (setq c-argdecl-indent 4)
 828     (setq c-label-offset -4)
 829     (setq c-tab-always-indent t)
 830     (setq rebox-default-style
 831           (+ REBOX_QUALITY_SIMPLE_ONE REBOX_TYPE_HALF_SINGLE))
 832     (message "C mode: Taarna style")))
 833
 834 ;;; Rebox the current region.
 835
 836 (defun rebox-region (flag)
 837   (interactive "P")
 838   (if (eq flag '-) (setq flag (rebox-ask-for-style)))
 839   (if (rebox-validate-flag flag)
 840       (save-restriction
 841         (narrow-to-region (region-beginning) (region-end))
 842         (rebox-engine flag))))
 843
 844 ;;; Rebox the surrounding comment.
 845
 846 (defun rebox-comment (flag)
 847   (interactive "P")
 848   (if (eq flag '-) (setq flag (rebox-ask-for-style)))
 849   (if (rebox-validate-flag flag)
 850       (save-restriction
 851         (rebox-find-and-narrow)
 852         (rebox-engine flag))))