Re: Emacs Ada-Mode

[Stephen.leake@gsfc.nasa.gov]

Simon Wright <simon@pogner.demon.co.uk> writes:

> brianorpin@bigfoot.com (Brian Orpin) writes:
> 
> > Does anyone know if there is a more recent version of the Ada-Mode than
> > 2.23?
> > 
> > What I would like is an extension to the mode to align the colons in
> > record declarations.
> 
> Just to report experience so far, the 2.28 posted here seems to do
> this just fine under 19.34 (GNU Emacs 19.34.1 (i486-pc-linux-gnu, X
> toolkit))
<snip>

He asked about "record declarations", not "parameter lists". As it happens,
I've been working on a record declaration formatter, and given the three-day
weekend, it now seems to be working. Here's the elisp. I'll also post to
the ada mode mailing list.

(define-key ada-mode-map "\C-c\C-r" 'ada-format-record)


;;; format record

(defvar ada-record-start-re
  "\\<\\(is\\|abstract\\|tagged\\|limited\\|with\\)[ \t\n]+record\\>"
  "Regexp for the start of a record declaration.")

(defvar ada-record-end-re
  "\\<end[ \t\n]+record[ \t\n]*;"
  "Regexp for the end of a record declaration.")

(defvar ada-identifier-re
  "\\([a-zA-Z][a-zA-Z0-9_]*[a-zA-Z0-9]\\)"
  "Regexp for extracting an identifier")

(defvar ada-name-re
  "\\([a-zA-Z][a-zA-Z0-9_\\.\\']*[a-zA-Z0-9]\\)"
  "Regexp for extracting a fully qualified name (including attribute)")

(defvar ada-comment-re
  "[ \t\n]*\\(--.*$\\)"
  "Regexp for extracting a trailing comment")

(defvar ada-comment-line-re
  "^[ \t\n]*\\(--.*\\)$"
  "Regexp for matching a comment line (with no code)")

(defvar ada-whitespace-re
  "[ \t\n]*"
  "Regexp matching Ada whitespace (sans new-page)")

(defun ada-forward-comment-end ()
  "Move forward to end of current multi-line comment"
  (while
      (progn
	(goto-end-line)
	(save-excursion
	  (forward-char 1)
	  (looking-at ada-comment-line-re)))))

(defun ada-format-record ()
  "Reformats a record type declaration.
Warning:    1) only single line trailing comments are preserved
            2) If the syntax is incorrect (especially, if there are
               semicolons missing), it can get totally confused !
In such a case, use `undo', correct the syntax and try again."

  (interactive)
  (let ((begin nil)
	(begin-mark nil)
        (end nil)
	(end-mark nil)
        (delend nil)
        (record nil)
	(match-cons nil))
    (unwind-protect
        (progn 
          (set-syntax-table ada-mode-symbol-syntax-table)

          ;; check if really inside record
          (or (ada-in-record-p)
              (error "not in record"))
          ;;
          ;; find start of current record
          ;;
          (setq match-cons (ada-search-ignore-string-comment ada-record-start-re t nil nil))
          (setq begin (cdr match-cons))
	  (setq begin-mark (copy-marker begin))

          ;;
          ;; find end of record
          ;;
          (setq match-cons (ada-search-ignore-string-comment ada-record-end-re nil nil nil))
          (setq delend (1+ (point)))
	  (setq end-mark (copy-marker (1+ delend)))

          ;; find end of last component declaration
	  (ada-search-ignore-string-comment ada-record-end-re t nil nil)
          (ada-search-ignore-string-comment "[^ \t\n]" t nil nil)
          (forward-char 1)
          (setq end (point))

          ;; build a list of all elements of the record
          (setq record (ada-scan-record (1+ begin) end))

          ;; delete the original record
          (delete-region begin (1- delend))

          ;; insert the new record
          (goto-char begin)
          (ada-insert-record record))

      ;; indent multi-line default expressions and comments
      ;; we use markers, because begin, end positions may be invalid at this point.
      (ada-indent-region begin-mark end-mark)

      (goto-char begin-mark)
      
      ;; restore syntax-table
      (set-syntax-table ada-mode-syntax-table)
      )))

(defun ada-scan-record (begin end)
  ;; Scans a record  between BEGIN and END and returns a list
  ;; of its contents.
  ;; The list has the following format:
  ;;
  ;; nth contents
  ;; 0	 Name of Component
  ;; 1	 Type and constraint
  ;; 2   type-length
  ;; 3   Default-Exp      
  ;; 4   exp-length 
  ;; 5   comment-on-newline-p
  ;; 6   Comment
  ;;
  ;; type-length, exp-length give correct indentation even for multi-line types and expressions.


  (let ((record (list))
        (comp (list))
        component-start
        semipos
        match-cons
	start-column)

    (goto-char begin)
    
    ;; loop for all components
    (while (progn
	     (ada-goto-next-non-ws)
	     (setq component-start (point))
	     (< component-start end))
      
      ;; find last character of component-declaration
      (setq match-cons (ada-search-ignore-string-comment "[ \t\n]*;" nil end t))
      (goto-char component-start)
      (setq semipos (car match-cons))

      ;; read name(s) of component(s)
      (looking-at (concat ada-identifier-re "[ \t\n]*\\(:[ \t\n]*\\)"))

      (setq comp (list (buffer-substring (match-beginning 1) (match-end 1))))
      (goto-char (match-end 2)) ; start of type name

      ;; read subtype of component (with constraint)
      (setq start-column (current-column))
      (looking-at ada-name-re)
      (goto-char (match-end 0))
      (if (save-match-data (looking-at (concat ada-whitespace-re "(")))
	  (forward-sexp))
      (setq comp
	    (append comp
		    (list
		     (buffer-substring (match-beginning 0)
				       (point))
		     (max 0 (- (current-column) start-column)))))

      ;; read default-expression, if there is one
      (setq start-column (current-column))
      (setq comp
            (append comp
		    (if (looking-at "[ \t\n]*\\(:=\\)")
			(progn
			  (goto-char semipos)
			  (list
			   (buffer-substring (match-beginning 1) (point)) ; doesn't include semicolon!
			   (max 0 (- (current-column) start-column))))
		      (list nil 0))))

      ;; read comment, if there is one
      (goto-char (1+ semipos))
      (setq comp
            (append comp
                     (if (looking-at ada-comment-re)
			 (let ((comment-start (match-beginning 1))
			       (new-line (looking-at "[ \t]*$")))
			   (ada-forward-comment-end)
			   (list new-line
				 (buffer-substring comment-start (point))))
		       (list nil nil))))
      
      ;; add this component-declaration to the list
      (setq record (append record (list comp)))

      ) ; end of loop

    (reverse record)))


(defun ada-insert-record (record)
  ;; Inserts a formatted RECORD in the buffer.
  ;; See doc of `ada-scan-record' for the format.
  (let ((i (length record))
	(name-max-length 0)
	(type-max-length 0)
	(exp-max-length 0)
        type-start-col
        exp-start-col
	comment-start-col
        (column nil)
        (orgpoint 0)
        (firstcol nil)
	component)

    ;; newline after 'is record', indent first component
    (ada-indent-newline-indent)

    ;; determine starting columns for each field.
    (setq firstcol (current-column))
    (while (not (zerop i))
      (setq i (1- i))
      (setq component (nth i record))

      (setq name-max-length (max name-max-length (length (nth 0 component))))

      ;; include ' : ' in type length
      (setq type-max-length (max type-max-length (+ 3 (nth 2 component))))

      ;; include '; ' in expression length
      (setq exp-max-length (max exp-max-length (+ 2 (nth 4 component))))
      
      ) ; end while

    (setq type-start-col (+ firstcol 1 name-max-length))
    (setq exp-start-col (+ type-start-col type-max-length))
    (setq comment-start-col (+ exp-start-col exp-max-length))
      
    (setq i (length record))

    ;; Insert all components. Components in 'record' are in reverse order
    (while (not (zerop i))
      (setq i (1- i))
      (setq column firstcol)

      (setq component (nth i record))
      
      ;; insert component name and type
      (insert (nth 0 component))
      (indent-to type-start-col)
      (insert ": ")
      (insert (nth 1 component))

      ;; insert default-expression (if any)
      (if (nth 3 component)
          (progn
            (indent-to exp-start-col)
            (insert (nth 3 component))
	    ))
      
      (insert ";")
      
      ;; insert comment (if any)
      (if (nth 6 component)
          (progn
	    (if (nth 5 component)
		(ada-indent-newline-indent)
	      (indent-to comment-start-col))
            (insert (nth 6 component))))

      (newline-and-indent)
      ) ; end of loop

    (insert "end record;")
    (ada-indent-current)
    ))

(defun ada-in-record-p ()
  ;; Returns t if point is inside a record type declaration
  (interactive)
  (save-excursion
    (and
     (re-search-backward (concat "\\<end\\(;\\|\\>\\)\\|\\(" ada-record-start-re "\\)") nil t)
     (not (looking-at "end")))))

;;; end format record