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