- ada-mode V2.28.text (3/3) Re: EMACS Ada Mode Update?

[matthew_heaney@acm.org (Matthew Heaney)]

---
       ;;
       (t
        (setq found t)))) ; end of loop

    (if found
        (cons begin end)
      nil)))


(defun ada-search-but-not (search-re not-search-re &optional backward limit)
  ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings,
  ;; comments and parameter-lists.
  (let ((begin nil)
        (end nil)
        (begin-not nil)
        (begin-end nil)
        (end-not nil)
        (ret-cons nil)
        (found nil))

    ;;
    ;; search until found or end-of-buffer
    ;;
    (while (and
            (not found)
            (save-excursion
              (setq ret-cons
                    (ada-search-ignore-string-comment search-re
                                                      backward limit))
              (if (consp ret-cons)
                  (progn
                    (setq begin (car ret-cons))
                    (setq end (cdr ret-cons))
                    t)
                nil)))

      (if (or
           ;;
           ;; if no NO-SEARCH-RE was found
           ;;
           (not
            (save-excursion
              (setq ret-cons
                    (ada-search-ignore-string-comment not-search-re
                                                      backward nil))
              (if (consp ret-cons)
                  (progn
                    (setq begin-not (car ret-cons))
                    (setq end-not (cdr ret-cons))
                    t)
                nil)))
           ;;
           ;;  or this NO-SEARCH-RE is not a part of the SEARCH-RE
           ;;  found before.
           ;;
           (or
            (<= end-not begin)
            (>= begin-not end)))

          (setq found t)

        ;;
        ;; not found the correct match => skip this match
        ;;
        (goto-char (if backward
                       begin
                     end)))) ; end of loop

    (if found
        (progn
          (goto-char begin)
          (cons begin end))
      nil)))


(defun ada-goto-prev-nonblank-line ( &optional ignore-comment)
  ;; Moves point to the beginning of previous non-blank line,
  ;; ignoring comments if IGNORE-COMMENT is non-nil.
  ;; It returns t if a matching line was found.
  (let ((notfound t)
        (newpoint nil))

    (save-excursion
      ;;
      ;; backward one line, if there is one
      ;;
      (if (zerop (forward-line -1))
          ;;
          ;; there is some kind of previous line
          ;;
          (progn
            (beginning-of-line)
            (setq newpoint (point))

            ;;
            ;; search until found or beginning-of-buffer
            ;;
            (while (and (setq notfound
                              (or (looking-at "[ \t]*$")
                                  (and (looking-at "[ \t]*--")
                                       ignore-comment)))
                        (not (ada-in-limit-line-p)))
              (forward-line -1)
              ;;(beginning-of-line)
              (setq newpoint (point))) ; end of loop

            )) ; end of if

      ) ; end of save-excursion

    (if notfound nil
      (progn
        (goto-char newpoint)
        t))))


(defun ada-goto-next-nonblank-line ( &optional ignore-comment)
  ;; Moves point to next non-blank line,
  ;; ignoring comments if IGNORE-COMMENT is non-nil.
  ;; It returns t if a matching line was found.
  (let ((notfound t)
        (newpoint nil))

    (save-excursion
    ;;
    ;; forward one line
    ;;
      (if (zerop (forward-line 1))
          ;;
          ;; there is some kind of previous line
          ;;
          (progn
            (beginning-of-line)
            (setq newpoint (point))

            ;;
            ;; search until found or end-of-buffer
            ;;
            (while (and (setq notfound
                              (or (looking-at "[ \t]*$")
                                  (and (looking-at "[ \t]*--")
                                       ignore-comment)))
                        (not (ada-in-limit-line-p)))
              (forward-line 1)
              (beginning-of-line)
              (setq newpoint (point))) ; end of loop

            )) ; end of if

      ) ; end of save-excursion

    (if notfound nil
      (progn
        (goto-char newpoint)
        t))))


;; ---- boolean functions for indentation

(defun ada-in-decl-p ()
  ;; Returns t if point is inside a declarative part.
  ;; Assumes point to be at the end of a statement.
  (or
   (ada-in-paramlist-p)
   (save-excursion
     (ada-goto-matching-decl-start t))))


(defun ada-looking-at-semi-or ()
  ;; Returns t if looking-at an 'or' following a semicolon.
  (save-excursion
    (and (looking-at "\\<or\\>")
         (progn
           (forward-word 1)
           (ada-goto-stmt-start)
           (looking-at "\\<or\\>")))))


(defun ada-looking-at-semi-private ()
  ;; Returns t if looking-at an 'private' following a semicolon.
  (save-excursion
    (and (looking-at "\\<private\\>")
         (progn
           (forward-word 1)
           (ada-goto-stmt-start)
           (looking-at "\\<private\\>")))))


;;; make a faster??? ada-in-limit-line-p not using count-lines
(defun ada-in-limit-line-p ()
  ;; return t if point is in first or last accessible line.
  (or (save-excursion (beginning-of-line) (= (point-min) (point)))
      (save-excursion (end-of-line) (= (point-max) (point)))))


(defun ada-in-comment-p ()
  ;; Returns t if inside a comment.
  (nth 4 (parse-partial-sexp
          (save-excursion (beginning-of-line) (point))
          (point))))


(defun ada-in-string-p ()
  ;; Returns t if point is inside a string
  ;; (Taken from pascal-mode.el, modified by MH).
  (save-excursion
    (and
     (nth 3 (parse-partial-sexp
             (save-excursion
               (beginning-of-line)
               (point)) (point)))
     ;; check if 'string quote' is only a character constant
     (progn
       (re-search-backward "\"" nil t) ; `#' is not taken as a string delimiter
       (not (= (char-after (1- (point))) ?'))))))


(defun ada-in-string-or-comment-p ()
  ;; Returns t if point is inside a string, a comment, or a character constant.
  (let ((parse-result (parse-partial-sexp
                       (save-excursion (beginning-of-line) (point)) (point))))
    (or ;; in-comment-p
     (nth 4 parse-result)
     ;; in-string-p
     (and
      (nth 3 parse-result)
      ;; check if 'string quote' is only a character constant
      (progn
        (re-search-backward "\"" nil t) ; `#' not regarded a string delimiter
        (not (= (char-after (1- (point))) ?'))))
     ;; in-char-const-p
     (ada-in-char-const-p))))


(defun ada-in-paramlist-p ()
  ;; Returns t if point is inside a parameter-list
  ;; following 'function'/'procedure'/'package'.
  (save-excursion
    (and
     (re-search-backward "(\\|)" nil t)
     ;; inside parentheses ?
     (looking-at "(")
     (backward-word 2)
     ;; right keyword before parenthesis ?
     (looking-at (concat "\\<\\("
                         "procedure\\|function\\|body\\|package\\|"
                         "task\\|entry\\|accept\\)\\>"))
     (re-search-forward ")\\|:" nil t)
     ;; at least one ':' inside the parentheses ?
     (not (backward-char 1))
     (looking-at ":"))))


;; not really a boolean function ...
(defun ada-in-open-paren-p ()
  ;; If point is somewhere behind an open parenthesis not yet closed,
  ;; it returns the column # of the first non-ws behind this open
  ;; parenthesis, otherwise nil."
  (let ((start (if (<= (point) ada-search-paren-char-count-limit)
                   (point-min)
                 (save-excursion
                   (goto-char (- (point) ada-search-paren-char-count-limit))
                   (beginning-of-line)
                   (point))))
        parse-result
        (col nil))
    (setq parse-result (parse-partial-sexp start (point)))
    (if (nth 1 parse-result)
        (save-excursion
          (goto-char (1+ (nth 1 parse-result)))
          (if (save-excursion
                (re-search-forward "[^ \t]" nil 1)
                (backward-char 1)
                (and
                 (not (looking-at "\n"))
                 (setq col (current-column))))
              col
            (current-column)))
      nil)))


\f
;;;----------------------;;;
;;; Behaviour Of TAB Key ;;;
;;;----------------------;;;

(defun ada-tab ()
  "Do indenting or tabbing according to `ada-tab-policy'."
  (interactive)
  (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented"))
        ;; ada-indent-and-tab
        ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard))
        ((eq ada-tab-policy 'indent-auto) (ada-indent-current))
        ((eq ada-tab-policy 'gei) (ada-tab-gei))
        ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB
        ((eq ada-tab-policy 'always-tab) (error "not implemented"))
        ))


(defun ada-untab (arg)
  "Delete leading indenting according to `ada-tab-policy'."
  (interactive "P")
  (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard))
        ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB
                                         (prefix-numeric-value arg) ; GEB
                                         arg)) ; GEB
        ((eq ada-tab-policy 'indent-auto) (error "not implemented"))
        ((eq ada-tab-policy 'always-tab) (error "not implemented"))
        ))


(defun ada-indent-current-function ()
  "Ada mode version of the indent-line-function."
  (interactive "*")
  (let ((starting-point (point-marker)))
    (ada-beginning-of-line)
    (ada-tab)
    (if (< (point) starting-point)
        (goto-char starting-point))
    (set-marker starting-point nil)
    ))


(defun ada-tab-hard ()
  "Indent current line to next tab stop."
  (interactive)
  (save-excursion
    (beginning-of-line)
    (insert-char ?  ada-indent))
  (if (save-excursion (= (point) (progn (beginning-of-line) (point))))
      (forward-char ada-indent)))


(defun ada-untab-hard ()
  "indent current line to previous tab stop."
  (interactive)
  (let  ((bol (save-excursion (progn (beginning-of-line) (point))))
        (eol (save-excursion (progn (end-of-line) (point)))))
    (indent-rigidly bol eol  (- 0 ada-indent))))


\f
;;;---------------;;;
;;; Miscellaneous ;;;
;;;---------------;;;

(defun ada-remove-trailing-spaces  ()
 "remove trailing spaces in the whole buffer."
  (interactive)
  (save-match-data
    (save-excursion
      (save-restriction
        (widen)
        (goto-char (point-min))
        (while (re-search-forward "[ \t]+$" (point-max) t)
          (replace-match "" nil nil))))))


(defun ada-untabify-buffer ()
;; change all tabs to spaces
  (save-excursion
    (untabify (point-min) (point-max))
    nil))


(defun ada-uncomment-region (beg end)
  "delete `comment-start' at the beginning of a line in the region."
  (interactive "r")
  (comment-region beg end -1))


;; define a function to support find-file.el if loaded
(defun ada-ff-other-window ()
  "Find other file in other window using `ff-find-other-file'."
  (interactive)
  (and (fboundp 'ff-find-other-file)
       (ff-find-other-file t)))

;; inspired by guerby@gnat.com
(defun ada-gnat-style ()
  "Clean up comments, `(' and `,' for GNAT style checking switch."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward "-- ?\\([^ -]\\)" nil t)
      (replace-match "--  \\1"))
    (goto-char (point-min))
    (while (re-search-forward "\\>(" nil t)
      (replace-match " ("))
    (goto-char (point-min))
    (while (re-search-forward ",\\<" nil t)
      (replace-match ", "))
    ))


\f
;;;--------------------------------;;;
;;; Moving To Subprograms/Packages ;;;
;;;--------------------------------;;;

(defun ada-next-procedure ()
  "Moves point to next procedure."
  (interactive)
  (end-of-line)
  (if (re-search-forward ada-procedure-start-regexp nil t)
      (goto-char (match-beginning 1))
    (error "No more functions/procedures/tasks")))

(defun ada-previous-procedure ()
  "Moves point to previous procedure."
  (interactive)
  (beginning-of-line)
  (if (re-search-backward ada-procedure-start-regexp nil t)
      (goto-char (match-beginning 1))
    (error "No more functions/procedures/tasks")))

(defun ada-next-package ()
  "Moves point to next package."
  (interactive)
  (end-of-line)
  (if (re-search-forward ada-package-start-regexp nil t)
      (goto-char (match-beginning 1))
    (error "No more packages")))

(defun ada-previous-package ()
  "Moves point to previous package."
  (interactive)
  (beginning-of-line)
  (if (re-search-backward ada-package-start-regexp nil t)
      (goto-char (match-beginning 1))
    (error "No more packages")))

\f
;;;-----------------------
;;; define keymap for Ada
;;;-----------------------

(if (not ada-mode-map)
    (progn
      (setq ada-mode-map (make-sparse-keymap))

      ;; Compiling
      (define-key ada-mode-map "\C-c\C-c" 'ada-compile)
      (define-key ada-mode-map "\C-c\C-v" 'ada-check-syntax)
      (define-key ada-mode-map "\C-c\C-m" 'ada-make-local)
      (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer)

      ;; Indentation and Formatting
      (define-key ada-mode-map "\177"     'backward-delete-char-untabify)
      (define-key ada-mode-map "\C-j"     'ada-indent-newline-indent)
      (define-key ada-mode-map "\t"       'ada-tab)
      (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
      (if (ada-xemacs)
	  (define-key ada-mode-map '(shift tab)    'ada-untab)
	(define-key ada-mode-map [S-tab]    'ada-untab))
      (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)

      ;; Casing
      (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region)
      (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)

      ;; Moving around
;;; It isn't good to redefine these.  What should be done instead?  -- rms.
;;;   (define-key ada-mode-map "\M-e"     'ada-next-package)
;;;   (define-key ada-mode-map "\M-a"     'ada-previous-package)
      (define-key ada-mode-map "\M-\C-e"  'ada-next-procedure)
      (define-key ada-mode-map "\M-\C-a"  'ada-previous-procedure)
      (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
      (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)

      ;; Comments
      ;; Use predefined function of emacs19 for comments (RE)
      (define-key ada-mode-map "\C-c;"    'comment-region)
      (define-key ada-mode-map "\C-c:"    'ada-uncomment-region)
      (if (ada-xemacs)
          (define-key ada-mode-map '(meta return) 'ada-indent-new-comment-line)
        (define-key ada-mode-map [M-return] 'ada-indent-new-comment-line))
;;; We don't want to make meta-characters case-specific.
;;;   (define-key ada-mode-map "\M-Q"     'ada-fill-comment-paragraph-justify)
      (define-key ada-mode-map "\M-\C-q"  'ada-fill-comment-paragraph-postfix)

      ;; Toggling between Spec & Body
      (define-key ada-mode-map "\C-C\C-o" 'ff-find-other-file)
      (define-key ada-mode-map "\C-C\C-w" 'ada-ff-other-window)

      ;; Change basic functionality

      ;; `substitute-key-definition' is not defined equally in Emacs
      ;; and XEmacs, you cannot put in an optional 4th parameter in
      ;; XEmacs.  I don't think it's necessary, so I leave it out for
      ;; Emacs as well.  If you encounter any problems with the
      ;; following three functions, please tell me. RE
      (mapcar (function (lambda (pair)
			  (substitute-key-definition (car pair) (cdr pair)
						     ada-mode-map)))
	      '((beginning-of-line      . ada-beginning-of-line)
		(end-of-line            . ada-end-of-line)
		(forward-to-indentation . ada-forward-to-indentation)
		))
      ;; else Emacs
      ;;(mapcar (lambda (pair)
      ;;             (substitute-key-definition (car pair) (cdr pair)
      ;;				   ada-mode-map global-map))

      ))

\f
;;;-------------------
;;; define menu 'Ada'
;;;-------------------

(defun ada-add-ada-menu ()
  "Adds the menu 'Ada' to the menu bar in Ada mode."
  (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode."
                    '("Ada"
                      ["Local Compile..."     ada-compile     t]
                      ["Ada Local Make..."    ada-make-local  t]
                      ["Global Make..."       compile (fboundp 'compile)]
                      ["Check Syntax..."      ada-check-syntax t]
                      ["Next Error"           next-error (fboundp 'next-error)]
                      ["----" nil nil]

                      ["Toggle Spec/Body"               ff-find-other-file
		       (fboundp 'ff-find-other-file)]
                      ["Find Spec/Body in Other Window" ada-ff-other-window
		       (fboundp 'ff-find-other-file)]
                      ["----" nil nil]

                      ["Next subprogram/task"     ada-next-procedure t]
                      ["Previous subprogram/task" ada-previous-procedure t]
                      ["Next package"             ada-next-package t]
                      ["Previous package"         ada-previous-package t]
                      ["Goto matching start"      ada-move-to-start t]
                      ["Goto matching end"        ada-move-to-end t]
                      ["----" nil nil]

                      ["Indent Current Line (TAB)"
                       ada-indent-current-function t]
                      ["Indent Lines in Region" ada-indent-region t]
                      ["Format Parameter List"  ada-format-paramlist t]
                      ["Adjust Case Region"     ada-adjust-case-region t]
                      ["----" nil nil]

                      ["Comment   Region" comment-region t]
                      ["Uncomment Region" ada-uncomment-region t]
                      ["Fill Comment Paragraph"
                       ada-fill-comment-paragraph t]
                      ["Fill and Justify Comment"
                       ada-fill-comment-paragraph-justify t]
                      ["Fill, Justify, and Postfix Comment..."
                       ada-fill-comment-paragraph-postfix t]
                      ))
  (if (ada-xemacs) (progn
                     (easy-menu-add ada-mode-menu)
                     (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))
\f
;;;-------------------------------
;;; Define Some Support Functions
;;;-------------------------------

(defun ada-beginning-of-line (&optional arg)
  (interactive "P")
  (cond
   ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg))
   (t (beginning-of-line arg))
   ))

(defun ada-end-of-line (&optional arg)
  (interactive "P")
  (cond
   ((eq ada-tab-policy 'indent-af) (af-end-of-line arg))
   (t (end-of-line arg))
   ))

(defun ada-current-column ()
  (cond
   ((eq ada-tab-policy 'indent-af) (af-current-column))
   (t (current-column))
   ))

(defun ada-forward-to-indentation (&optional arg)
  (interactive "P")
  (cond
   ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg))
   (t (forward-to-indentation arg))
   ))

;;;---------------------------------------------------
;;; support for find-file
;;;---------------------------------------------------


;;;###autoload
(defun ada-make-filename-from-adaname (adaname)
  "Determine the filename of a package/procedure from its own Ada name."
  ;; this is done simply by calling `gnatkr', when we work with GNAT. It
  ;; must be a more complex function in other compiler environments.
  (interactive "s")
  (let (krunch-buf)
    (setq krunch-buf (generate-new-buffer "*gkrunch*"))
    (save-excursion
      (set-buffer krunch-buf)
      ;; send adaname to external process `gnatkr'.
      (call-process "gnatkr" nil krunch-buf nil
                    adaname ada-krunch-args)
      ;; fetch output of that process
      (setq adaname (buffer-substring
                     (point-min)
                     (progn
                       (goto-char (point-min))
                       (end-of-line)
                       (point))))
      (kill-buffer krunch-buf)))
  (setq adaname adaname) ;; can I avoid this statement?
  )


;;; functions for placing the cursor on the corresponding subprogram
(defun ada-which-function-are-we-in ()
  "Determine whether we are on a function definition/declaration.
If that is the case remember the name of that function."

  (setq ff-function-name nil)

  (save-excursion
    (if (re-search-backward ada-procedure-start-regexp nil t)
	(setq ff-function-name (buffer-substring (match-beginning 0)
						 (match-end 0)))
      ; we didn't find a procedure start, perhaps there is a package
      (if (re-search-backward ada-package-start-regexp nil t)
	  (setq ff-function-name (buffer-substring (match-beginning 0)
						   (match-end 0)))
	))))


;;;---------------------------------------------------
;;; support for font-lock
;;;---------------------------------------------------

;; Strings are a real pain in Ada because a single quote character is
;; overloaded as a string quote and type/instance delimiter.  By default, a
;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
;; So, for Font Lock mode purposes, we mark single quotes as having string
;; syntax when the gods that created Ada determine them to be.  sm.

(defconst ada-font-lock-syntactic-keywords
  ;; Mark single quotes as having string quote syntax in 'c' instances.
  '(("\\(\'\\).\\(\'\\)" (1 (7 . ?\')) (2 (7 . ?\')))))

(defconst ada-font-lock-keywords-1
  (list
   ;;
   ;; handle "type T is access function return S;"
   ;; 
   (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
   ;;
   ;; accept, entry, function, package (body), protected (body|type),
   ;; pragma, procedure, task (body) plus name.
   (list (concat
	  "\\<\\("
	  "accept\\|"
	  "entry\\|"
          "function\\|"
          "package[ \t]+body\\|"
          "package\\|"
          "pragma\\|"
          "procedure\\|"
          "protected[ \t]+body\\|"
          "protected[ \t]+type\\|"
          "protected\\|"
;;	  "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\
;;\\|r\\(agma\\|ocedure\\)\\)\\|"
	  "task[ \t]+body\\|"
	  "task[ \t]+type\\|"
	  "task"
;;	  "task\\(\\|[ \t]+body\\)"
	  "\\)\\>[ \t]*"
	  "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
    '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)))
  "Subdued level highlighting for Ada mode.")

(defconst ada-font-lock-keywords-2
  (append ada-font-lock-keywords-1
   (list
    ;;
    ;; Main keywords, except those treated specially below.
    (concat "\\<\\("
;    ("abort" "abs" "abstract" "accept" "access" "aliased" "all"
;     "and" "array" "at" "begin" "case" "declare" "delay" "delta"
;     "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
;     "generic" "if" "in" "is" "limited" "loop" "mod" "not"
;     "null" "or" "others" "private" "protected"
;     "range" "record" "rem" "renames" "requeue" "return" "reverse"
;     "select" "separate" "tagged" "task" "terminate" "then" "until"
;     "while" "xor")
            "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|"
            "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
            "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
            "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
            "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
            "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|"
           
"r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|
"
            "se\\(lect\\|parate\\)\\|"
            "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed
	    "wh\\(ile\\|en\\)\\|xor" ; "when" added
            "\\)\\>")
    ;;
    ;; Anything following end and not already fontified is a body name.
    '("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?"
      (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
    ;;
    ;; Variable name plus optional keywords followed by a type name.  Slow.
;    (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*"
;                 "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
;                 "\\(\\sw+\\)?")
;         '(1 font-lock-variable-name-face)
;         '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
    ;;
    ;; Optional keywords followed by a type name.
    (list (concat ; ":[ \t]*"
                  "\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
                  "[ \t]*"
                  "\\(\\sw+\\)?")
          '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
    ;;
    ;; Keywords followed by a type or function name.
    (list (concat "\\<\\("
                  "new\\|of\\|subtype\\|type"
                  "\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*\\((\\)?")
          '(1 font-lock-keyword-face)
          '(2 (if (match-beginning 4)
                  font-lock-function-name-face
                font-lock-type-face) nil t))
    ;;
    ;; Keywords followed by a (comma separated list of) reference.
    (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
                  ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE
                  "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W")
          '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
    ;;
    ;; Goto tags.
    '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
    ))
  "Gaudy level highlighting for Ada mode.")

(defvar ada-font-lock-keywords ada-font-lock-keywords-1
  "Default expressions to highlight in Ada mode.")


;; set font-lock properties for XEmacs
(if (ada-xemacs)
    (put 'ada-mode 'font-lock-defaults
         '(ada-font-lock-keywords
           nil t ((?\_ . "w")(?\. . "w")) beginning-of-line)))
\f
;;;---------------------------
;;; support for imenu
;;;---------------------------
(setq imenu-sort-function 'imenu--sort-by-name)
\f
;;;---------------------------
;;; Support for outline
;;;---------------------------

;; used by outline-minor-mode
(defun ada-outline-level ()
  (save-excursion
    (skip-chars-forward "\t ")
    (current-column)))

;;;
;;; generate body
;;;
(defun ada-gen-comment-until-proc ()
  ;; comment until spec of a procedure or a function.
  (forward-line 1)
  (set-mark-command (point))
  (if (re-search-forward ada-procedure-start-regexp nil t)
      (progn (goto-char (match-beginning 1))
             (comment-region (mark) (point)))
    (error "No more functions/procedures")))


(defun ada-gen-treat-proc (match)
  ;; make dummy body of a procedure/function specification.
  ;; MATCH is a cons cell containing the start and end location of the
  ;; last search for ada-procedure-start-regexp. 
  (goto-char (car match))
  (let (proc-found func-found procname functype)
    (cond
     ((or (setq proc-found (looking-at "^[ \t]*procedure"))
	  (setq func-found (looking-at "^[ \t]*function")))
      ;; treat it as a proc/func
      (forward-word 2) 
      (forward-word -1)
      (setq procname (buffer-substring (point) (cdr match))) ; store  proc name

    ;; goto end of procname
    (goto-char (cdr match))

    ;; skip over parameterlist
    (forward-sexp)
    ;; if function, skip over 'return' and result type.
    (if func-found
	(progn
	  (forward-word 1)
	  (skip-chars-forward " \t\n")
	  (setq functype (buffer-substring (point)
					   (progn 
					     (skip-chars-forward
					      "a-zA-Z0-9_\.")
					     (point))))))
    ;; look for next non WS
    (cond
     ((looking-at "[ \t]*;")
      (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';'
      (ada-indent-newline-indent)
      (insert " is")
      (ada-indent-newline-indent)
      (if func-found
	  (progn
	    (insert "Result : ")
	    (insert functype)
	    (insert ";")
	    (ada-indent-newline-indent)))
      (insert "begin -- ")
      (insert procname)
      (ada-indent-newline-indent)
      (insert "null;")
      (ada-indent-newline-indent)
      (if func-found
	  (progn
	    (insert "return Result;")
	    (ada-indent-newline-indent)))
      (insert "end ")
      (insert procname)
      (insert ";")
      (ada-indent-newline-indent)	
      )
      ;; else
     ((looking-at "[ \t\n]*is")
      ;; do nothing
      )
     ((looking-at "[ \t\n]*rename")
      ;; do nothing
      )
     (t
      (message "unknown syntax")))
    ))))


(defun ada-make-body ()
  "Create an Ada package body in the current buffer.
The potential old buffer contents is deleted first, then we copy the
spec buffer in here and modify it to make it a body.

This function typically is to be hooked into `ff-file-created-hooks'."
  (interactive)
  (delete-region (point-min) (point-max))
  (insert-buffer (car (cdr (buffer-list))))
  (ada-mode)

  (let (found)
    (if (setq found 
	      (ada-search-ignore-string-comment ada-package-start-regexp))
	(progn (goto-char (cdr found))
	       (insert " body")
	       ;; (forward-line -1)
	       ;;(comment-region (point-min) (point))
	       )
      (error "No package"))
    
    ;; (comment-until-proc)
    ;;   does not work correctly
    ;;   must be done by hand
    
    (while (setq found
		 (ada-search-ignore-string-comment ada-procedure-start-regexp))
      (ada-gen-treat-proc found))))


;;; provide ourself

(provide 'ada-mode)

;;; ada-mode.el ends here


--- end of part 3 ---