home *** CD-ROM | disk | FTP | other *** search
/ Unix System Administration Handbook 1997 October / usah_oct97.iso / gnu / tar.txt / tar-1.12 / rebox.el < prev    next >
Lisp/Scheme  |  1997-04-25  |  30KB  |  853 lines
  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))))
  853.