home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gnum4.zip / c-boxes.el < prev    next >
Lisp/Scheme  |  1994-09-16  |  13KB  |  407 lines
  1. ;;; Boxed comments for C mode.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
  3. ;;; Francois Pinard <pinard@iro.umontreal.ca>, April 1991.
  4. ;;;
  5. ;;; I often refill paragraphs inside C comments, while stretching or
  6. ;;; shrinking the surrounding box as needed.  This is a real pain to
  7. ;;; do by hand.  Here is the code I made to ease my life on this,
  8. ;;; usable from within GNU Emacs.  It would not be fair giving all
  9. ;;; sources for a product without also giving the means for nicely
  10. ;;; modifying them.
  11. ;;;
  12. ;;; The function rebox-c-comment adjust comment boxes without
  13. ;;; refilling comment paragraphs, while reindent-c-comment adjust
  14. ;;; comment boxes after refilling.  Numeric prefixes are used to add,
  15. ;;; remove, or change the style of the box surrounding the comment.
  16. ;;; Since refilling paragraphs in C mode does make sense only for
  17. ;;; comments, this code redefines the M-q command in C mode.  I use
  18. ;;; this hack by putting, in my .emacs file:
  19. ;;;
  20. ;;;    (setq c-mode-hook
  21. ;;;          '(lambda ()
  22. ;;;         (define-key c-mode-map "\M-q" 'reindent-c-comment)))
  23. ;;;    (autoload 'rebox-c-comment "c-boxes" nil t)
  24. ;;;    (autoload 'reindent-c-comment "c-boxes" nil t)
  25. ;;;
  26. ;;; The cursor should be within a comment before any of these
  27. ;;; commands, or else it should be between two comments, in which case
  28. ;;; the command applies to the next comment.  When the command is
  29. ;;; given without prefix, the current comment box type is recognized
  30. ;;; and preserved.  Given 0 as a prefix, the comment box disappears
  31. ;;; and the comment stays between a single opening `/*' and a single
  32. ;;; closing `*/'.  Given 1 or 2 as a prefix, a single or doubled lined
  33. ;;; comment box is forced.  Given 3 as a prefix, a Taarna style box is
  34. ;;; forced, but you do not even want to hear about those.  When a
  35. ;;; negative prefix is given, the absolute value is used, but the
  36. ;;; default style is changed.  Any other value (like C-u alone) forces
  37. ;;; the default box style.
  38. ;;;
  39. ;;; I observed rounded corners first in some code from Warren Tucker
  40. ;;; <wht@n4hgf.mt-park.ga.us>.
  41.  
  42. (defvar c-box-default-style 'single "*Preferred style for box comments.")
  43. (defvar c-mode-taarna-style nil "*Non-nil for Taarna team C-style.")
  44.  
  45. ;;; Set or reset the Taarna team's own way for a C style.
  46.  
  47. (defun taarna-mode ()
  48.   (interactive)
  49.   (if c-mode-taarna-style
  50.       (progn
  51.  
  52.     (setq c-mode-taarna-style nil)
  53.     (setq c-indent-level 2)
  54.     (setq c-continued-statement-offset 2)
  55.     (setq c-brace-offset 0)
  56.     (setq c-argdecl-indent 5)
  57.     (setq c-label-offset -2)
  58.     (setq c-tab-always-indent t)
  59.     (setq c-box-default-style 'single)
  60.     (message "C mode: GNU style"))
  61.  
  62.     (setq c-mode-taarna-style t)
  63.     (setq c-indent-level 4)
  64.     (setq c-continued-statement-offset 4)
  65.     (setq c-brace-offset -4)
  66.     (setq c-argdecl-indent 4)
  67.     (setq c-label-offset -4)
  68.     (setq c-tab-always-indent t)
  69.     (setq c-box-default-style 'taarna)
  70.     (message "C mode: Taarna style")))
  71.  
  72. ;;; Return the minimum value of the left margin of all lines, or -1 if
  73. ;;; all lines are empty.
  74.  
  75. (defun buffer-left-margin ()
  76.   (let ((margin -1))
  77.     (goto-char (point-min))
  78.     (while (not (eobp))
  79.       (skip-chars-forward " \t")
  80.       (if (not (looking-at "\n"))
  81.       (setq margin
  82.         (if (< margin 0)
  83.             (current-column)
  84.           (min margin (current-column)))))
  85.       (forward-line 1))
  86.     margin))
  87.  
  88. ;;; Return the maximum value of the right margin of all lines.  Any
  89. ;;; sentence ending a line has a space guaranteed before the margin.
  90.  
  91. (defun buffer-right-margin ()
  92.   (let ((margin 0) period)
  93.     (goto-char (point-min))
  94.     (while (not (eobp))
  95.       (end-of-line)
  96.       (if (bobp)
  97.       (setq period 0)
  98.     (backward-char 1)
  99.     (setq period (if (looking-at "[.?!]") 1 0))
  100.     (forward-char 1))
  101.       (setq margin (max margin (+ (current-column) period)))
  102.       (forward-char 1))
  103.     margin))
  104.  
  105. ;;; Add, delete or adjust a C comment box.  If FLAG is nil, the
  106. ;;; current boxing style is recognized and preserved.  When 0, the box
  107. ;;; is removed; when 1, a single lined box is forced; when 2, a double
  108. ;;; lined box is forced; when 3, a Taarna style box is forced.  If
  109. ;;; negative, the absolute value is used, but the default style is
  110. ;;; changed.  For any other value (like C-u), the default style is
  111. ;;; forced.  If REFILL is not nil, refill the comment paragraphs prior
  112. ;;; to reboxing.
  113.  
  114. (defun rebox-c-comment-engine (flag refill)
  115.   (save-restriction
  116.     (let ((undo-list buffer-undo-list)
  117.       (marked-point (point-marker))
  118.       (saved-point (point))
  119.       box-style left-margin right-margin)
  120.  
  121.       ;; First, find the limits of the block of comments following or
  122.       ;; enclosing the cursor, or return an error if the cursor is not
  123.       ;; within such a block of comments, narrow the buffer, and
  124.       ;; untabify it.
  125.  
  126.       ;; - insure the point is into the following comment, if any
  127.  
  128.       (skip-chars-forward " \t\n")
  129.       (if (looking-at "/\\*")
  130.       (forward-char 2))
  131.  
  132.       (let ((here (point)) start end temp)
  133.  
  134.     ;; - identify a minimal comment block
  135.  
  136.     (search-backward "/*")
  137.     (setq temp (point))
  138.     (beginning-of-line)
  139.     (setq start (point))
  140.     (skip-chars-forward " \t")
  141.     (if (< (point) temp)
  142.         (progn
  143.           (goto-char saved-point)
  144.           (error "text before comment's start")))
  145.     (search-forward "*/")
  146.     (setq temp (point))
  147.     (end-of-line)
  148.     (if (looking-at "\n")
  149.         (forward-char 1))
  150.     (setq end (point))
  151.     (skip-chars-backward " \t\n")
  152.     (if (> (point) temp)
  153.         (progn
  154.           (goto-char saved-point)
  155.           (error "text after comment's end")))
  156.     (if (< end here)
  157.         (progn
  158.           (goto-char saved-point)
  159.           (error "outside any comment block")))
  160.  
  161.     ;; - try to extend the comment block backwards
  162.  
  163.     (goto-char start)
  164.     (while (and (not (bobp))
  165.             (progn (previous-line 1)
  166.                (beginning-of-line)
  167.                (looking-at "[ \t]*/\\*.*\\*/[ \t]*$")))
  168.       (setq start (point)))
  169.  
  170.     ;; - try to extend the comment block forward
  171.  
  172.     (goto-char end)
  173.     (while (looking-at "[ \t]*/\\*.*\\*/[ \t]*$")
  174.       (forward-line 1)
  175.       (beginning-of-line)
  176.       (setq end (point)))
  177.  
  178.     ;; - narrow to the whole block of comments
  179.  
  180.     (narrow-to-region start end))
  181.  
  182.       ;; Second, remove all the comment marks, and move all the text
  183.       ;; rigidly to the left to insure the left margin stays at the
  184.       ;; same place.  At the same time, recognize and save the box
  185.       ;; style in BOX-STYLE.
  186.  
  187.       (let ((previous-margin (buffer-left-margin))
  188.         actual-margin)
  189.  
  190.     ;; - remove all comment marks
  191.  
  192.     (goto-char (point-min))
  193.     (replace-regexp "^\\([ \t]*\\)/\\*" "\\1  ")
  194.     (goto-char (point-min))
  195.     (replace-regexp "^\\([ \t]*\\)|" "\\1 ")
  196.     (goto-char (point-min))
  197.     (replace-regexp "\\(\\*/\\||\\)[ \t]*" "")
  198.     (goto-char (point-min))
  199.     (replace-regexp "\\*/[ \t]*/\\*" " ")
  200.  
  201.     ;; - remove the first and last dashed lines
  202.  
  203.     (setq box-style 'plain)
  204.     (goto-char (point-min))
  205.     (if (looking-at "^[ \t]*-*[.\+\\]?[ \t]*\n")
  206.         (progn
  207.           (setq box-style 'single)
  208.           (replace-match ""))
  209.       (if (looking-at "^[ \t]*=*[.\+\\]?[ \t]*\n")
  210.           (progn
  211.         (setq box-style 'double)
  212.         (replace-match ""))))
  213.     (goto-char (point-max))
  214.     (previous-line 1)
  215.     (beginning-of-line)
  216.     (if (looking-at "^[ \t]*[`\+\\]?*[-=]+[ \t]*\n")
  217.         (progn
  218.           (if (eq box-style 'plain)
  219.           (setq box-style 'taarna))
  220.           (replace-match "")))
  221.  
  222.     ;; - remove all spurious whitespace
  223.  
  224.     (goto-char (point-min))
  225.     (replace-regexp "[ \t]+$" "")
  226.     (goto-char (point-min))
  227.     (if (looking-at "\n+")
  228.         (replace-match ""))
  229.     (goto-char (point-max))
  230.     (skip-chars-backward "\n")
  231.     (if (looking-at "\n\n+")
  232.         (replace-match "\n"))
  233.     (goto-char (point-min))
  234.     (replace-regexp "\n\n\n+" "\n\n")
  235.  
  236.     ;; - move the text left is adequate
  237.  
  238.     (setq actual-margin (buffer-left-margin))
  239.     (if (not (= previous-margin actual-margin))
  240.         (indent-rigidly (point-min) (point-max)
  241.                 (- previous-margin actual-margin))))
  242.  
  243.       ;; Third, select the new box style from the old box style and
  244.       ;; the argument, choose the margins for this style and refill
  245.       ;; each paragraph.
  246.  
  247.       ;; - modify box-style only if flag is defined
  248.  
  249.       (if flag
  250.       (setq box-style
  251.         (cond ((eq flag 0) 'plain)
  252.               ((eq flag 1) 'single)
  253.               ((eq flag 2) 'double)
  254.               ((eq flag 3) 'taarna)
  255.               ((eq flag '-) (setq c-box-default-style 'plain) 'plain)
  256.               ((eq flag -1) (setq c-box-default-style 'single) 'single)
  257.               ((eq flag -2) (setq c-box-default-style 'double) 'double)
  258.               ((eq flag -3) (setq c-box-default-style 'taarna) 'taarna)
  259.               (t c-box-default-style))))
  260.  
  261.       ;; - compute the left margin
  262.  
  263.       (setq left-margin (buffer-left-margin))
  264.  
  265.       ;; - temporarily set the fill prefix and column, then refill
  266.  
  267.       (untabify (point-min) (point-max))
  268.  
  269.       (if refill
  270.       (let ((fill-prefix (make-string left-margin ? ))
  271.         (fill-column (- fill-column
  272.                 (if (memq box-style '(single double)) 4 6))))
  273.         (fill-region (point-min) (point-max))))
  274.  
  275.       ;; - compute the right margin after refill
  276.  
  277.       (setq right-margin (buffer-right-margin))
  278.  
  279.       ;; Fourth, put the narrowed buffer back into a comment box,
  280.       ;; according to the value of box-style.  Values may be:
  281.       ;;    plain: insert between a single pair of comment delimiters
  282.       ;;    single: complete box, overline and underline with dashes
  283.       ;;    double: complete box, overline and underline with equal signs
  284.       ;;    taarna: comment delimiters on each line, underline with dashes
  285.  
  286.       ;; - move the right margin to account for left inserts
  287.  
  288.       (setq right-margin (+ right-margin
  289.                 (if (memq box-style '(single double))
  290.                 2
  291.                   3)))
  292.  
  293.       ;; - construct the box comment, from top to bottom
  294.  
  295.       (goto-char (point-min))
  296.       (cond ((eq box-style 'plain)
  297.  
  298.          ;; - construct a plain style comment
  299.  
  300.          (skip-chars-forward " " (+ (point) left-margin))
  301.          (insert (make-string (- left-margin (current-column)) ? )
  302.              "/* ")
  303.          (end-of-line)
  304.          (forward-char 1)
  305.          (while (not (eobp))
  306.            (skip-chars-forward " " (+ (point) left-margin))
  307.            (insert (make-string (- left-margin (current-column)) ? )
  308.                "   ")
  309.            (end-of-line)
  310.            (forward-char 1))
  311.          (backward-char 1)
  312.          (insert "  */"))
  313.         ((eq box-style 'single)
  314.  
  315.          ;; - construct a single line style comment
  316.  
  317.          (indent-to left-margin)
  318.          (insert "/*")
  319.          (insert (make-string (- right-margin (current-column)) ?-)
  320.              "-.\n")
  321.          (while (not (eobp))
  322.            (skip-chars-forward " " (+ (point) left-margin))
  323.            (insert (make-string (- left-margin (current-column)) ? )
  324.                "| ")
  325.            (end-of-line)
  326.            (indent-to right-margin)
  327.            (insert " |")
  328.            (forward-char 1))
  329.          (indent-to left-margin)
  330.          (insert "`")
  331.          (insert (make-string (- right-margin (current-column)) ?-)
  332.              "*/\n"))
  333.         ((eq box-style 'double)
  334.  
  335.          ;; - construct a double line style comment
  336.  
  337.          (indent-to left-margin)
  338.          (insert "/*")
  339.          (insert (make-string (- right-margin (current-column)) ?=)
  340.              "=\\\n")
  341.          (while (not (eobp))
  342.            (skip-chars-forward " " (+ (point) left-margin))
  343.            (insert (make-string (- left-margin (current-column)) ? )
  344.                "| ")
  345.            (end-of-line)
  346.            (indent-to right-margin)
  347.            (insert " |")
  348.            (forward-char 1))
  349.          (indent-to left-margin)
  350.          (insert "\\")
  351.          (insert (make-string (- right-margin (current-column)) ?=)
  352.              "*/\n"))
  353.         ((eq box-style 'taarna)
  354.  
  355.          ;; - construct a Taarna style comment
  356.  
  357.          (while (not (eobp))
  358.            (skip-chars-forward " " (+ (point) left-margin))
  359.            (insert (make-string (- left-margin (current-column)) ? )
  360.                "/* ")
  361.            (end-of-line)
  362.            (indent-to right-margin)
  363.            (insert " */")
  364.            (forward-char 1))
  365.          (indent-to left-margin)
  366.          (insert "/* ")
  367.          (insert (make-string (- right-margin (current-column)) ?-)
  368.              " */\n"))
  369.         (t (error "unknown box style")))
  370.  
  371.       ;; Fifth, retabify, restore the point position, then cleanup the
  372.       ;; undo list of any boundary since we started.
  373.  
  374.       ;; - retabify before left margin only (adapted from tabify.el)
  375.  
  376.       (goto-char (point-min))
  377.       (while (re-search-forward "^[ \t][ \t][ \t]*" nil t)
  378.     (let ((column (current-column))
  379.           (indent-tabs-mode t))
  380.       (delete-region (match-beginning 0) (point))
  381.       (indent-to column)))
  382.  
  383.       ;; - restore the point position
  384.  
  385.       (goto-char (marker-position marked-point))
  386.  
  387.       ;; - remove all intermediate boundaries from the undo list
  388.  
  389.       (if (not (eq buffer-undo-list undo-list))
  390.       (let ((cursor buffer-undo-list))
  391.         (while (not (eq (cdr cursor) undo-list))
  392.           (if (car (cdr cursor))
  393.           (setq cursor (cdr cursor))
  394.         (rplacd cursor (cdr (cdr cursor))))))))))
  395.  
  396. ;;; Rebox a C comment without refilling it.
  397.  
  398. (defun rebox-c-comment (flag)
  399.   (interactive "P")
  400.   (rebox-c-comment-engine flag nil))
  401.  
  402. ;;; Rebox a C comment after refilling.
  403.  
  404. (defun reindent-c-comment (flag)
  405.   (interactive "P")
  406.   (rebox-c-comment-engine flag t))
  407.