Mercurial > hg > xemacs-beta
diff lisp/modes/ada-mode.el @ 189:489f57a838ef r20-3b21
Import from CVS: tag r20-3b21
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:57:07 +0200 |
| parents | 28f395d8dc7a |
| children |
line wrap: on
line diff
--- a/lisp/modes/ada-mode.el Mon Aug 13 09:56:30 2007 +0200 +++ b/lisp/modes/ada-mode.el Mon Aug 13 09:57:07 2007 +0200 @@ -1,35 +1,38 @@ ;;; ada-mode.el --- An Emacs major-mode for editing Ada source. -;;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. - -;;; Authors: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> -;;; Rolf Ebert <ebert@inf.enst.fr> - -;;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by + +;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc. + +;; Authors: Rolf Ebert <ebert@inf.enst.fr> +;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> +;; Keywords: languages oop ada +;; Rolf Ebert's version: 2.27 + +;; This file is part of XEmacs + +;; XEmacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; XEmacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; This mode is a complete rewrite of a major mode for editing Ada 83 ;;; and Ada 95 source code under Emacs-19. It contains completely new ;;; indenting code and support for code browsing (see ada-xref). -;;; Synched up with: FSF 19.34. +;;; Synched up with: FSF 20.1 ;;; USAGE ;;; ===== -;;; Emacs should enter ada-mode when you load an ada source (*.ad[abs]). +;;; Emacs should enter Ada mode when you load an Ada source (*.ad[abs]). ;;; ;;; When you have entered ada-mode, you may get more info by pressing ;;; C-h m. You may also get online help describing various functions by: @@ -53,7 +56,7 @@ ;;; electric-ada.el. ;;; ;;; The current Ada mode is a complete rewrite by M. Heritsch and -;;; R. Ebert. Some ideas from the ada-mode mailing list have been +;;; R. Ebert. Some ideas from the Ada mode mailing list have been ;;; added. Some of the functionality of L. Slater's mode has not ;;; (yet) been recoded in this new mode. Perhaps you prefer sticking ;;; to his version. @@ -65,15 +68,18 @@ ;;; In the presence of comments and/or incorrect syntax ;;; ada-format-paramlist produces weird results. ;;; ------------------- -;;; Indenting of some tasking constructs is still buggy. +;;; Character constants with otherwise syntactic relevant characters +;;; like `(' or `"' throw indentation off the track. Fontification +;;; should work now in Emacs-19.35 +;;; C : constant Character := Character'('"'); ;;; ------------------- -;;; package Test is -;;; -- If I hit return on the "type" line it will indent the next line -;;; -- in another 3 space instead of heading out to the "(". If I hit -;;; -- tab or return it reindents the line correctly but does not initially. -;;; type Wait_Return is (Read_Success, Read_Timeout, Wait_Timeout, -;;; Nothing_To_Wait_For_In_Wait_List); -;;; ------------------- + + +;;; TODO +;;; ==== +;;; +;;; o bodify-single-subprogram +;;; o make a function "separate" and put it in the corresponding file. @@ -92,43 +98,70 @@ ;;; USER OPTIONS ;;;-------------------- + +;; ---- customize support + +(defgroup ada nil + "Major mode for editing Ada source in Emacs" + :group 'languages) + ;; ---- configure indentation -(defvar ada-indent 3 - "*Defines the size of Ada indentation.") - -(defvar ada-broken-indent 2 - "*# of columns to indent the continuation of a broken line.") - -(defvar ada-label-indent -4 - "*# of columns to indent a label.") - -(defvar ada-stmt-end-indent 0 +(defcustom ada-indent 3 + "*Defines the size of Ada indentation." + :type 'integer + :group 'ada) + +(defcustom ada-broken-indent 2 + "*# of columns to indent the continuation of a broken line." + :type 'integer + :group 'ada) + +(defcustom ada-label-indent -4 + "*# of columns to indent a label." + :type 'integer + :group 'ada) + +(defcustom ada-stmt-end-indent 0 "*# of columns to indent a statement end keyword in a separate line. -Examples are 'is', 'loop', 'record', ...") - -(defvar ada-when-indent 3 - "*Defines the indentation for 'when' relative to 'exception' or 'case'.") - -(defvar ada-indent-record-rel-type 3 - "*Defines the indentation for 'record' relative to 'type' or 'use'.") - -(defvar ada-indent-comment-as-code t - "*If non-nil, comment-lines get indented as Ada code.") - -(defvar ada-indent-is-separate t - "*If non-nil, 'is separate' or 'is abstract' on a single line are indented.") - -(defvar ada-indent-to-open-paren t - "*If non-nil, indent according to the innermost open parenthesis.") - -(defvar ada-search-paren-char-count-limit 3000 - "*Search that many characters for an open parenthesis.") +Examples are 'is', 'loop', 'record', ..." + :type 'integer + :group 'ada) + +(defcustom ada-when-indent 3 + "*Defines the indentation for 'when' relative to 'exception' or 'case'." + :type 'integer + :group 'ada) + +(defcustom ada-indent-record-rel-type 3 + "*Defines the indentation for 'record' relative to 'type' or 'use'." + :type 'integer + :group 'ada) + +(defcustom ada-indent-comment-as-code t + "*If non-nil, comment-lines get indented as Ada code." + :type 'boolean + :group 'ada) + +(defcustom ada-indent-is-separate t + "*If non-nil, 'is separate' or 'is abstract' on a single line are indented." + :type 'boolean + :group 'ada) + +(defcustom ada-indent-to-open-paren t + "*If non-nil, indent according to the innermost open parenthesis." + :type 'boolean + :group 'ada) + +(defcustom ada-search-paren-char-count-limit 3000 + "*Search that many characters for an open parenthesis." + :type 'integer + :group 'ada) ;; ---- other user options -(defvar ada-tab-policy 'indent-auto +(defcustom ada-tab-policy 'indent-auto "*Control behaviour of the TAB key. Must be one of `indent-rigidly', `indent-auto', `gei', `indent-af' or `always-tab'. @@ -137,74 +170,173 @@ `indent-auto' : use indentation functions in this file. `gei' : use David Kågedal's Generic Indentation Engine. `indent-af' : use Gary E. Barnes' ada-format.el -`always-tab' : do indent-relative.") - -(defvar ada-move-to-declaration nil +`always-tab' : do indent-relative." + :type '(choice (const indent-auto) + (const indent-rigidly) + (const gei) + (const indent-af) + (const always-tab)) + :group 'ada) + +(defcustom ada-move-to-declaration nil "*If non-nil, `ada-move-to-start' moves point to the subprog declaration, -not to 'begin'.") - -(defvar ada-spec-suffix ".ads" - "*Suffix of Ada specification files.") - -(defvar ada-body-suffix ".adb" - "*Suffix of Ada body files.") - -(defvar ada-language-version 'ada95 - "*Do we program in `ada83' or `ada95'?") - -(defvar ada-case-keyword 'downcase-word +not to 'begin'." + :type 'boolean + :group 'ada) + +(defcustom ada-spec-suffix ".ads" + "*Suffix of Ada specification files." + :type 'string + :group 'ada) + +(defcustom ada-body-suffix ".adb" + "*Suffix of Ada body files." + :type 'string + :group 'ada) + +(defcustom ada-spec-suffix-as-regexp "\\.ads$" + "*Regexp to find Ada specification files." + :type 'string + :group 'ada) + +(defcustom ada-body-suffix-as-regexp "\\.adb$" + "*Regexp to find Ada body files." + :type 'string + :group 'ada) + +(defvar ada-other-file-alist + (list + (list ada-spec-suffix-as-regexp (list ada-body-suffix)) + (list ada-body-suffix-as-regexp (list ada-spec-suffix)) + ) + "*Alist of extensions to find given the current file's extension. + +This list should contain the most used extensions before the others, +since the search algorithm searches sequentially through each directory +specified in `ada-search-directories'. If a file is not found, a new one +is created with the first matching extension (`.adb' yields `.ads').") + +(defcustom ada-search-directories + '("." "/usr/adainclude" "/usr/local/adainclude" "/opt/gnu/adainclude") + "*List of directories to search for Ada files. +See the description for the `ff-search-directories' variable." + :type '(repeat (choice :tag "Directory" + (const :tag "default" nil) + (directory :format "%v"))) + :group 'ada) + +(defcustom ada-language-version 'ada95 + "*Do we program in `ada83' or `ada95'?" + :type '(choice (const ada83) + (const ada95)) + :group 'ada) + +(defcustom ada-case-keyword 'downcase-word "*Function to call to adjust the case of Ada keywords. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'.") - -(defvar ada-case-identifier 'ada-loose-case-word +It may be `downcase-word', `upcase-word', `ada-loose-case-word' or +`capitalize-word'." + :type '(choice (const downcase-word) + (const upcase-word) + (const capitalize-word) + (const ada-loose-case-word)) + :group 'ada) + +(defcustom ada-case-identifier 'ada-loose-case-word "*Function to call to adjust the case of an Ada identifier. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'.") - -(defvar ada-case-attribute 'capitalize-word +It may be `downcase-word', `upcase-word', `ada-loose-case-word' or +`capitalize-word'." + :type '(choice (const downcase-word) + (const upcase-word) + (const capitalize-word) + (const ada-loose-case-word)) + :group 'ada) + +(defcustom ada-case-attribute 'capitalize-word "*Function to call to adjust the case of Ada attributes. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'.") - -(defvar ada-auto-case t +It may be `downcase-word', `upcase-word', `ada-loose-case-word' or +`capitalize-word'." + :type '(choice (const downcase-word) + (const upcase-word) + (const capitalize-word) + (const ada-loose-case-word)) + :group 'ada) + +(defcustom ada-auto-case t "*Non-nil automatically changes case of preceding word while typing. Casing is done according to `ada-case-keyword', `ada-case-identifier' -and `ada-cacse-attribute'.") - -(defvar ada-clean-buffer-before-saving nil - "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving.") +and `ada-case-attribute'." + :type 'boolean + :group 'ada) + +(defcustom ada-clean-buffer-before-saving t + "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving." + :type 'boolean + :group 'ada) (defvar ada-mode-hook nil - "*List of functions to call when Ada Mode is invoked. + "*List of functions to call when Ada mode is invoked. This is a good place to add Ada environment specific bindings.") -(defvar ada-external-pretty-print-program "aimap" - "*External pretty printer to call from within Ada Mode.") - -(defvar ada-tmp-directory "/tmp/" - "*Directory to store the temporary file for the Ada pretty printer.") - -(defvar ada-fill-comment-prefix "-- " - "*This is inserted in the first columns when filling a comment paragraph.") - -(defvar ada-fill-comment-postfix " --" - "*This is inserted at the end of each line when filling a comment paragraph -with `ada-fill-comment-paragraph-postfix'.") - -(defvar ada-krunch-args "0" - "*Argument of gnatk8, a string containing the max number of characters. -Set to 0, if you don't use crunched filenames.") +(defcustom ada-external-pretty-print-program "aimap" + "*External pretty printer to call from within Ada mode." + :type 'string + :group 'ada) + +(defcustom ada-tmp-directory "/tmp/" + "*Directory to store the temporary file for the Ada pretty printer." + :type 'string + :group 'ada) + +(defcustom ada-compile-options "-c" + "*Buffer local options passed to the Ada compiler. +These options are used when the compiler is invoked on the current buffer." + :type 'string + :group 'ada) +(make-variable-buffer-local 'ada-compile-options) + +(defcustom ada-make-options "-c" + "*Buffer local options passed to `ada-compiler-make' (usually `gnatmake'). +These options are used when `gnatmake' is invoked on the current buffer." + :type 'string + :group 'ada) +(make-variable-buffer-local 'ada-make-options) + +(defcustom ada-compiler-syntax-check "gcc -c -gnats" + "*Compiler command with options for syntax checking." + :type 'string + :group 'ada) + +(defcustom ada-compiler-make "gnatmake" + "*The `make' command for the given compiler." + :type 'string + :group 'ada) + +(defcustom ada-fill-comment-prefix "-- " + "*This is inserted in the first columns when filling a comment paragraph." + :type 'string + :group 'ada) + +(defcustom ada-fill-comment-postfix " --" + "*This is inserted at the end of each line when filling a comment paragraph. +with `ada-fill-comment-paragraph-postfix'." + :type 'string + :group 'ada) + +(defcustom ada-krunch-args "0" + "*Argument of gnatkr, a string containing the max number of characters. +Set to 0, if you don't use crunched filenames." + :type 'string + :group 'ada) ;;; ---- end of user configurable variables (defvar ada-mode-abbrev-table nil - "Abbrev table used in Ada Mode.") + "Abbrev table used in Ada mode.") (define-abbrev-table 'ada-mode-abbrev-table ()) (defvar ada-mode-map () - "Local keymap used for Ada Mode.") + "Local keymap used for Ada mode.") (defvar ada-mode-syntax-table nil "Syntax table to be used for editing Ada source code.") @@ -279,9 +411,9 @@ (defvar ada-end-stmt-re "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\ -\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|\ +\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\ declare\\|generic\\|private\\)\\>\\|\ -^[ \t]*\\(package\\|procedure\\|function\\)[ \ta-zA-Z0-9_\\.]+is\\|\ +^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\ ^[ \t]*exception\\>\\)" "Regexp of possible ends for a non-broken statement. A new statement starts after these.") @@ -295,12 +427,16 @@ task\\|accept\\|entry\\)\\>" "Regexp for the start of a subprogram.") +(defvar ada-named-block-re + "[ \t]*[a-zA-Z_0-9]+ *:[^=]" + "Regexp of the name of a block or loop.") + ;; Written by Christian Egli <Christian.Egli@hcsd.hac.com> ;; (defvar ada-imenu-generic-expression - '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2) - ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2)) + '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2) + ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2)) "Imenu generic expression for Ada mode. See `imenu-generic-expression'.") @@ -313,7 +449,7 @@ (string-match "XEmacs" emacs-version))) (defun ada-create-syntax-table () - "Create the syntax table for Ada Mode." + "Create the syntax table for Ada mode." ;; There are two different syntax-tables. The standard one declares ;; `_' as a symbol constituent, in the second one, it is a word ;; constituent. For some search and replacing routines we @@ -321,8 +457,10 @@ (setq ada-mode-syntax-table (make-syntax-table)) (set-syntax-table ada-mode-syntax-table) - ;; define string brackets (% is alternative string bracket) - (modify-syntax-entry ?% "\"" ada-mode-syntax-table) + ;; define string brackets (`%' is alternative string bracket, but + ;; almost never used as such and throws font-lock and indentation + ;; off the track.) + (modify-syntax-entry ?% "$" ada-mode-syntax-table) (modify-syntax-entry ?\" "\"" ada-mode-syntax-table) (modify-syntax-entry ?\# "$" ada-mode-syntax-table) @@ -353,7 +491,7 @@ (modify-syntax-entry ?\f "> " ada-mode-syntax-table) (modify-syntax-entry ?\n "> " ada-mode-syntax-table) - ;; define what belongs in ada symbols + ;; define what belongs in Ada symbols (modify-syntax-entry ?_ "_" ada-mode-syntax-table) ;; define parentheses to match @@ -367,7 +505,7 @@ ;;;###autoload (defun ada-mode () - "Ada Mode is the major mode for editing Ada code. + "Ada mode is the major mode for editing Ada code. Bindings are as follows: (Note: 'LFD' is control-j.) @@ -387,7 +525,7 @@ Fill comment paragraph and justify each line '\\[ada-fill-comment-paragraph-justify]' Fill comment paragraph, justify and append postfix '\\[ada-fill-comment-paragraph-postfix]' - Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]' + Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]' Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]' Goto matching start of current 'end ...;' '\\[ada-move-to-start]' @@ -448,25 +586,40 @@ (make-local-variable 'case-fold-search) (setq case-fold-search t) + (make-local-variable 'outline-regexp) + (setq outline-regexp "[^\n\^M]") + (make-local-variable 'outline-level) + (setq outline-level 'ada-outline-level) + (make-local-variable 'fill-paragraph-function) (setq fill-paragraph-function 'ada-fill-comment-paragraph) + ;;(make-local-variable 'adaptive-fill-regexp) (make-local-variable 'imenu-generic-expression) (setq imenu-generic-expression ada-imenu-generic-expression) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((ada-font-lock-keywords - ada-font-lock-keywords-1 - ada-font-lock-keywords-2) - nil t - ((?\_ . "w")) - beginning-of-line)) + (if (ada-xemacs) nil ; XEmacs uses properties + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '((ada-font-lock-keywords + ada-font-lock-keywords-1 ada-font-lock-keywords-2) + nil t + ((?\_ . "w")(?\. . "w")) + beginning-of-line + (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) + + ;; Set up support for find-file.el. + (make-variable-buffer-local 'ff-other-file-alist) + (make-variable-buffer-local 'ff-search-directories) + (setq ff-other-file-alist 'ada-other-file-alist + ff-search-directories 'ada-search-directories + ff-pre-load-hooks 'ff-which-function-are-we-in + ff-post-load-hooks 'ff-set-point-accordingly + ff-file-created-hooks 'ada-make-body)) (setq major-mode 'ada-mode) (setq mode-name "Ada") - (setq blink-matching-paren t) - (use-local-map ada-mode-map) (if ada-mode-syntax-table @@ -500,6 +653,45 @@ ;;;-------------------------- +;;; Compile support +;;;-------------------------- + +(defun ada-check-syntax () + "Check syntax of the current buffer. +Uses the function `compile' to execute `ada-compiler-syntax-check'." + (interactive) + (let ((old-compile-command compile-command)) + (setq compile-command (concat ada-compiler-syntax-check + (if (eq ada-language-version 'ada83) + "-gnat83 ") + " " ada-compile-options " " + (buffer-name))) + (setq compile-command (read-from-minibuffer + "enter command for syntax check: " + compile-command)) + (compile compile-command) + ;; restore old compile-command + (setq compile-command old-compile-command))) + +(defun ada-make-local () + "Bring current Ada unit up-to-date. +Uses the function `compile' to execute `ada-compile-make'." + (interactive) + (let ((old-compile-command compile-command)) + (setq compile-command (concat ada-compiler-make + " " ada-make-options " " + (buffer-name))) + (setq compile-command (read-from-minibuffer + "enter command for local make: " + compile-command)) + (compile compile-command) + ;; restore old compile-command + (setq compile-command old-compile-command))) + + + + +;;;-------------------------- ;;; Fill Comment Paragraph ;;;-------------------------- @@ -661,7 +853,7 @@ "Calls the external Pretty Printer. The name is specified in `ada-external-pretty-print-program'. Saves the current buffer in a directory specified by `ada-tmp-directory', -starts the pretty printer as an external process on that file and then +starts the pretty printer as external process on that file and then reloads the beautified program in the buffer and cleans up `ada-tmp-directory'." (interactive) @@ -724,7 +916,7 @@ ;;;--------------- ;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be> -;; modifiedby RE and MH +;; modified by RE and MH (defun ada-after-keyword-p () ;; returns t if cursor is after a keyword. @@ -737,14 +929,19 @@ (not (looking-at "_"))) ; (MH) (looking-at (concat ada-keywords "[^_]"))))) -(defun ada-after-char-p () - ;; returns t if after ada character "'". This is interpreted as being - ;; in a character constant. +(defun ada-in-char-const-p () + ;; Returns t if point is inside a character constant. + ;; We assume to be in a constant if the previous and the next character + ;; are "'". (save-excursion - (if (> (point) 2) - (progn - (forward-char -2) - (looking-at "'")) + (if (> (point) 1) + (and + (progn + (forward-char 1) + (looking-at "'")) + (progn + (forward-char -2) + (looking-at "'"))) nil))) @@ -756,7 +953,7 @@ (forward-char -1) (if (and (> (point) 1) (not (or (ada-in-string-p) (ada-in-comment-p) - (ada-after-char-p)))) + (ada-in-char-const-p)))) (if (eq (char-syntax (char-after (1- (point)))) ?w) (if (save-excursion (forward-word -1) @@ -801,7 +998,7 @@ ;; save original keybindings to allow swapping ret/lfd ;; when casing is activated ;; the 'or ...' is there to be sure that the value will not - ;; be changed again when Ada Mode is called more than once (MH) + ;; be changed again when Ada mode is called more than once (MH) (or ada-ret-binding (setq ada-ret-binding (key-binding "\C-M"))) (or ada-lfd-binding @@ -819,7 +1016,7 @@ ;; added by MH ;; (defun ada-loose-case-word (&optional arg) - "Capitalizes the first letter and the letters following `_'. + "Capitalizes the first letter and the letters following `_'. ARG is ignored, it's there to fit the standard casing functions' style." (let ((pos (point)) (first t)) @@ -835,6 +1032,7 @@ ;; ;; added by MH +;; modified by JSH to handle attributes ;; (defun ada-adjust-case-region (from to) "Adjusts the case of all words in the region. @@ -843,13 +1041,13 @@ (let ((begin nil) (end nil) (keywordp nil) - (reldiff nil)) + (attribp nil)) (unwind-protect (save-excursion (set-syntax-table ada-mode-symbol-syntax-table) (goto-char to) ;; - ;; loop: look for all identifiers and keywords + ;; loop: look for all identifiers, keywords, and attributes ;; (while (re-search-backward "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]" @@ -858,16 +1056,15 @@ ;; ;; print status message ;; - (setq reldiff (- (point) from)) - (message "adjusting case ... %5d characters left" - (- (point) from)) + (message "adjusting case ... %5d characters left" (- (point) from)) + (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']")) (forward-char 1) (or ;; do nothing if it is a string or comment (ada-in-string-or-comment-p) (progn ;; - ;; get the identifier or keyword + ;; get the identifier or keyword or attribute ;; (setq begin (point)) (setq keywordp (looking-at (concat ada-keywords "[^_]"))) @@ -877,7 +1074,9 @@ ;; (if keywordp (funcall ada-case-keyword -1) - (funcall ada-case-identifier -1)) + (if attribp + (funcall ada-case-attribute -1) + (funcall ada-case-identifier -1))) (goto-char begin)))) (message "adjusting case ... done")) (set-syntax-table ada-mode-syntax-table)))) @@ -888,7 +1087,7 @@ ;; (defun ada-adjust-case-buffer () "Adjusts the case of all words in the whole buffer. -Attention: This function might take very long for big buffers !" +ATTENTION: This function might take very long for big buffers !" (interactive "*") (ada-adjust-case-region (point-min) (point-max))) @@ -898,8 +1097,8 @@ ;;;------------------------;;; (defun ada-format-paramlist () - "Reformats a parameter-list. -Attention: 1) Comments inside the list are killed ! + "Reformats a parameter list. +ATTENTION: 1) Comments inside the list are killed ! 2) If the syntax is not correct (especially, if there are semicolons missing), it can get totally confused ! In such a case, use `undo', correct the syntax and try again." @@ -920,7 +1119,7 @@ ;; find start of current parameter-list ;; (ada-search-ignore-string-comment - (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) + (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) (ada-search-ignore-string-comment "(" nil nil t) (backward-char 1) (setq begin (point)) @@ -1061,9 +1260,9 @@ (ada-goto-next-non-ws)) ;; - ;; read type of parameter + ;; read type of parameter ;; - (looking-at "\\<[a-zA-Z0-9_\\.]+\\>") + (looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>") (setq param (append param (list @@ -1409,51 +1608,16 @@ (setq lines-remaining (1- lines-remaining))) ;; show line number where the error occurred (error - (error "line %d: %s" (1+ (count-lines (point-min) (point))) err))) + (error "line %d: %s" (1+ (count-lines (point-min) (point))) err) nil)) (message "indenting ... done"))) (defun ada-indent-newline-indent () "Indents the current line, inserts a newline and then indents the new line." (interactive "*") - (let ((column) - (orgpoint)) - - (ada-indent-current) - (newline) - (delete-horizontal-space) - (setq orgpoint (point)) - - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (setq column (save-excursion - (funcall (ada-indent-function) orgpoint)))) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table)) - - (indent-to column) - - ;; The following is needed to ensure that indentation will still be - ;; correct if something follows behind point when typing LFD - ;; For example: Imagine point to be there (*) when LFD is typed: - ;; while cond loop - ;; null; *end loop; - ;; Result without the following statement would be: - ;; while cond loop - ;; null; - ;; *end loop; - ;; You would then have to type TAB to correct it. - ;; If that doesn't bother you, you can comment out the following - ;; statement to speed up indentation a LITTLE bit. - - (if (not (looking-at "[ \t]*$")) - (ada-indent-current)) - )) + (ada-indent-current) + (newline) + (ada-indent-current)) (defun ada-indent-current () @@ -1496,10 +1660,10 @@ (setq prev-indent (save-excursion (funcall (ada-indent-function) line-end)))) - (progn ; first line of buffer -> set indent - (beginning-of-line) ; to 0 - (delete-horizontal-space) - (setq prevline nil)))) + (progn ; first line of buffer -> set indent + (beginning-of-line) ; to 0 + (delete-horizontal-space) + (setq prevline nil)))) (if prevline ;; @@ -1511,18 +1675,17 @@ ;; (back-to-indentation) (setq cur-indent (ada-get-current-indent prev-indent)) - ;; only reindent if indentation is different then the current - (if (= (current-column) cur-indent) - nil + ;; only reindent if indentation is different then the current + (if (= (current-column) cur-indent) + nil (delete-horizontal-space) - (indent-to cur-indent)) - + (indent-to cur-indent)) ;; ;; restore position of point ;; (goto-char orgpoint) (if (< (current-column) (current-indentation)) - (back-to-indentation)))))) + (back-to-indentation)))))) ;; ;; restore syntax-table @@ -1559,27 +1722,33 @@ ;; end ;; ((looking-at "\\<end\\>") - (save-excursion - (ada-goto-matching-start 1) - - ;; - ;; found 'loop' => skip back to 'while' or 'for' - ;; if 'loop' is not on a separate line - ;; - (if (and - (looking-at "\\<loop\\>") - (save-excursion - (back-to-indentation) - (not (looking-at "\\<loop\\>")))) - (if (save-excursion - (and - (setq match-cons - (ada-search-ignore-string-comment - ada-loop-start-re t nil)) - (not (looking-at "\\<loop\\>")))) - (goto-char (car match-cons)))) - - (current-indentation))) + (let ((label 0)) + (save-excursion + (ada-goto-matching-start 1) + + ;; + ;; found 'loop' => skip back to 'while' or 'for' + ;; if 'loop' is not on a separate line + ;; + (if (and + (looking-at "\\<loop\\>") + (save-excursion + (back-to-indentation) + (not (looking-at "\\<loop\\>")))) + (if (save-excursion + (and + (setq match-cons + (ada-search-ignore-string-comment + ada-loop-start-re t nil)) + (not (looking-at "\\<loop\\>")))) + (progn + (goto-char (car match-cons)) + (save-excursion + (beginning-of-line) + (if (looking-at ada-named-block-re) + (setq label (- ada-label-indent))))))) + + (+ (current-indentation) label)))) ;; ;; exception ;; @@ -1647,9 +1816,7 @@ (save-excursion (if (ada-goto-matching-decl-start t) (current-indentation) - (progn - (message "no matching declaration start") - prev-indent)))) + prev-indent))) ;; ;; is ;; @@ -1776,8 +1943,7 @@ ;; the current statement, if NOMOVE is nil. (let ((orgpoint (point)) - (func nil) - (stmt-start nil)) + (func nil)) ;; ;; inside a parameter-list ;; @@ -1788,14 +1954,14 @@ ;; move to beginning of current statement ;; (if (not nomove) - (setq stmt-start (ada-goto-stmt-start))) + (ada-goto-stmt-start)) ;; ;; no beginning found => don't change indentation ;; (if (and (eq orgpoint (point)) (not nomove)) - (setq func 'ada-get-indent-nochange) + (setq func 'ada-get-indent-nochange) (cond ;; @@ -1813,11 +1979,6 @@ ((looking-at ada-subprog-start-re) (setq func 'ada-get-indent-subprog)) ;; - ((looking-at "\\<package\\>") - (setq func 'ada-get-indent-subprog)) ; maybe it needs a - ; special function - ; sometimes ? - ;; ((looking-at ada-block-start-re) (setq func 'ada-get-indent-block-start)) ;; @@ -1851,7 +2012,7 @@ (defun ada-get-indent-open-paren (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be behind an open paranthesis not yet closed. + ;; Assumes point to be behind an open parenthesis not yet closed. (ada-in-open-paren-p)) @@ -1897,6 +2058,7 @@ ;; slow, if it has to search through big files with many nested blocks. ;; Signals an error if the corresponding block-start doesn't match. (let ((defun-name nil) + (label 0) (indent nil)) ;; ;; is the line already terminated by ';' ? @@ -1923,8 +2085,9 @@ (forward-word 1) (ada-goto-stmt-start))) ;; a label ? => skip it - (if (looking-at "[a-zA-Z0-9_]+[ \n\t]+:") + (if (looking-at ada-named-block-re) (progn + (setq label (- ada-label-indent)) (goto-char (match-end 0)) (ada-goto-next-non-ws))) ;; really looking-at the right thing ? @@ -1937,7 +2100,7 @@ "loop\\|select\\|if\\|case\\|" "record\\|while\\|type\\)\\>"))) (backward-word 1)) - (current-indentation))) + (+ (current-indentation) label))) ;; ;; a named block end ;; @@ -1971,7 +2134,7 @@ (defun ada-get-indent-case (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of an case-statement. + ;; Assumes point to be at the beginning of a case-statement. (let ((cur-indent (current-indentation)) (match-cons nil) (opos (point))) @@ -1980,8 +2143,12 @@ ;; case..is..when..=> ;; ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "[ \t\n]+=>" nil orgpoint))) + (setq match-cons (and + ;; the `=>' must be after the keyword `is'. + (ada-search-ignore-string-comment + "\\<is\\>" nil orgpoint) + (ada-search-ignore-string-comment + "[ \t\n]+=>" nil orgpoint)))) (save-excursion (goto-char (car match-cons)) (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos)) @@ -2092,7 +2259,7 @@ (if (save-excursion (setq match-cons (ada-search-ignore-string-comment - "\\<is\\>\\|\\<do\\>" nil orgpoint))) + "\\<\\(is\\|do\\)\\>" nil orgpoint))) ;; ;; yes, then skip to its end ;; @@ -2155,10 +2322,15 @@ (defun ada-get-indent-noindent (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. ;; Assumes point to be at the beginning of a 'noindent statement'. - (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (current-indentation) - (+ (current-indentation) ada-broken-indent))) + (let ((label 0)) + (save-excursion + (beginning-of-line) + (if (looking-at ada-named-block-re) + (setq label (- ada-label-indent)))) + (if (save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint)) + (+ (current-indentation) label) + (+ (current-indentation) ada-broken-indent label)))) (defun ada-get-indent-label (orgpoint) @@ -2183,7 +2355,7 @@ ;; ((save-excursion (setq match-cons (ada-search-ignore-string-comment - "\\<declare\\>" nil orgpoint))) + "\\<declare\\|begin\\>" nil orgpoint))) (save-excursion (goto-char (car match-cons)) (+ (current-indentation) ada-indent))) @@ -2217,7 +2389,13 @@ ;; Assumes point to be at the beginning of a loop statement ;; or (unfortunately) also a for ... use statement. (let ((match-cons nil) - (pos (point))) + (pos (point)) + (label (save-excursion + (beginning-of-line) + (if (looking-at ada-named-block-re) + (- ada-label-indent) + 0)))) + (cond ;; @@ -2225,12 +2403,12 @@ ;; ((save-excursion (ada-search-ignore-string-comment ";" nil orgpoint)) - (current-indentation)) + (+ (current-indentation) label)) ;; ;; simple loop ;; ((looking-at "loop\\>") - (ada-get-indent-block-start orgpoint)) + (+ (ada-get-indent-block-start orgpoint) label)) ;; ;; 'for'- loop (or also a for ... use statement) @@ -2274,12 +2452,12 @@ (back-to-indentation) (looking-at "\\<loop\\>"))) (goto-char pos)) - (+ (current-indentation) ada-indent)) + (+ (current-indentation) ada-indent label)) ;; ;; for-statement is broken ;; (t - (+ (current-indentation) ada-broken-indent)))) + (+ (current-indentation) ada-broken-indent label)))) ;; ;; 'while'-loop @@ -2302,9 +2480,9 @@ (back-to-indentation) (looking-at "\\<loop\\>"))) (goto-char pos)) - (+ (current-indentation) ada-indent)) - - (+ (current-indentation) ada-broken-indent)))))) + (+ (current-indentation) ada-indent label)) + + (+ (current-indentation) ada-broken-indent label)))))) (defun ada-get-indent-type (orgpoint) @@ -2387,7 +2565,7 @@ ;; (setq match-dat (ada-search-prev-end-stmt limit))) ;; - ;; if found the correct end-stetement => goto next non-ws + ;; if found the correct end-statement => goto next non-ws ;; (if match-dat (goto-char (cdr match-dat))) @@ -2418,7 +2596,6 @@ ;; End-statements are defined by 'ada-end-stmt-re'. Checks for ;; certain keywords if they follow 'end', which means they are no ;; end-statement there. - (interactive) ;; DEBUG (let ((match-dat nil) (pos nil) (found nil)) @@ -2433,18 +2610,22 @@ limit))) (goto-char (car match-dat)) - (if (not (ada-in-open-paren-p)) ;; ;; check if there is an 'end' in front of the match ;; (if (not (and - (looking-at "\\<\\(record\\|loop\\|select\\)\\>") + (looking-at + "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>") (save-excursion (ada-goto-previous-word) - (looking-at "\\<end\\>")))) - (setq found t) - + (looking-at "\\<\\(end\\|or\\|and\\)\\>")))) + (save-excursion + (goto-char (cdr match-dat)) + (ada-goto-next-word) + (if (not (looking-at "\\<\\(separate\\|new\\)\\>")) + (setq found t))) + (forward-word -1)))) ; end of loop (if found @@ -2474,18 +2655,21 @@ nil)) -(defun ada-goto-previous-word () - ;; Moves point to the beginning of the previous word of Ada code. +(defun ada-goto-next-word (&optional backward) + ;; Moves point to the beginning of the next word of Ada code. + ;; If BACKWARD is non-nil, jump to the beginning of the previous word. ;; Returns the new position of point or nil if not found. (let ((match-cons nil) (orgpoint (point))) + (if (not backward) + (skip-chars-forward "_a-zA-Z0-9\\.")) (if (setq match-cons - (ada-search-ignore-string-comment "[^ \t\n]" t nil t)) + (ada-search-ignore-string-comment "\\w" backward nil t)) ;; ;; move to the beginning of the word found ;; (progn - (goto-char (cdr match-cons)) + (goto-char (car match-cons)) (skip-chars-backward "_a-zA-Z0-9") (point)) ;; @@ -2496,6 +2680,12 @@ 'nil)))) +(defun ada-goto-previous-word () + ;; Moves point to the beginning of the previous word of Ada code. + ;; Returns the new position of point or nil if not found. + (ada-goto-next-word t)) + + (defun ada-check-matching-start (keyword) ;; Signals an error if matching block start is not KEYWORD. ;; Moves point to the matching block start. @@ -2510,45 +2700,51 @@ ;; Moves point to the beginning of the declaration. ;; - ;; 'accept' or 'package' ? - ;; - (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>")) - (ada-goto-matching-decl-start)) - ;; - ;; 'begin' of 'procedure'/'function'/'task' or 'declare' + ;; named block without a `declare' ;; - (save-excursion + (if (save-excursion + (ada-goto-previous-word) + (looking-at (concat "\\<" defun-name "\\> *:"))) + t ; do nothing ;; - ;; a named 'declare'-block ? + ;; 'accept' or 'package' ? ;; - (if (looking-at "\\<declare\\>") - (ada-goto-stmt-start) + (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>")) + (ada-goto-matching-decl-start)) + ;; + ;; 'begin' of 'procedure'/'function'/'task' or 'declare' + ;; + (save-excursion ;; - ;; no, => 'procedure'/'function'/'task'/'protected' + ;; a named 'declare'-block ? ;; - (progn - (forward-word 2) - (backward-word 1) + (if (looking-at "\\<declare\\>") + (ada-goto-stmt-start) ;; - ;; skip 'body' 'protected' 'type' + ;; no, => 'procedure'/'function'/'task'/'protected' ;; - (if (looking-at "\\<\\(body\\|type\\)\\>") - (forward-word 1)) - (forward-sexp 1) - (backward-sexp 1))) - ;; - ;; should be looking-at the correct name - ;; - (if (not (looking-at (concat "\\<" defun-name "\\>"))) - (error "matching defun has different name: %s" - (buffer-substring (point) - (progn (forward-sexp 1) (point))))))) + (progn + (forward-word 2) + (backward-word 1) + ;; + ;; skip 'body' 'type' + ;; + (if (looking-at "\\<\\(body\\|type\\)\\>") + (forward-word 1)) + (forward-sexp 1) + (backward-sexp 1))) + ;; + ;; should be looking-at the correct name + ;; + (if (not (looking-at (concat "\\<" defun-name "\\>"))) + (error "matching defun has different name: %s" + (buffer-substring (point) + (progn (forward-sexp 1) (point)))))))) (defun ada-goto-matching-decl-start (&optional noerror nogeneric) ;; Moves point to the matching declaration start of the current 'begin'. ;; If NOERROR is non-nil, it only returns nil if no match was found. - (interactive) ;; DEBUG (let ((nest-count 1) (pos nil) (first t) @@ -2578,25 +2774,26 @@ ;; ((looking-at "is") ;; check if it is only a type definition, but not a protected - ;; type definition, which should be handled like a procedure. - (if (save-excursion - (ada-goto-previous-word) - (skip-chars-backward "a-zA-Z0-9_.'") - (if (save-excursion - (backward-char 1) - (looking-at ")")) - (progn - (forward-char 1) - (backward-sexp 1) - (skip-chars-backward "a-zA-Z0-9_.'") - )) - (ada-goto-previous-word) - (and - (looking-at "\\<type\\>") - (save-match-data - (ada-goto-previous-word) - (not (looking-at "\\<protected\\>")))) - ); end of save-excursion + ;; type definition, which should be handled like a procedure. + (if (or (looking-at "is +<>") + (save-excursion + (ada-goto-previous-word) + (skip-chars-backward "a-zA-Z0-9_.'") + (if (save-excursion + (backward-char 1) + (looking-at ")")) + (progn + (forward-char 1) + (backward-sexp 1) + (skip-chars-backward "a-zA-Z0-9_.'") + )) + (ada-goto-previous-word) + (and + (looking-at "\\<type\\>") + (save-match-data + (ada-goto-previous-word) + (not (looking-at "\\<protected\\>")))) + )); end of `or' (goto-char (match-beginning 0)) (progn (setq nest-count (1- nest-count)) @@ -2625,13 +2822,11 @@ (and (zerop nest-count) (not flag) - (progn - (if (looking-at "is") - (ada-search-ignore-string-comment - ada-subprog-start-re t) - (looking-at "declare\\|generic"))))) + (if (looking-at "is") + (ada-search-ignore-string-comment ada-subprog-start-re t) + (looking-at "declare\\|generic")))) (if noerror nil - (error "no matching proc/func/task/declare/package/protected")) + (error "no matching proc/func/task/declare/package/protected")) t))) @@ -2672,7 +2867,7 @@ ;; check if keyword follows 'end' ;; (ada-goto-previous-word) - (if (looking-at "\\<end\\>") + (if (looking-at "\\<end\\> *[^;]") ;; it ends a block => increase nest depth (progn (setq nest-count (1+ nest-count)) @@ -3064,14 +3259,11 @@ (defun ada-in-comment-p () ;; Returns t if inside a comment. - ;; (save-excursion (and (re-search-backward "\\(--\\|\n\\)" nil 1) - ;; (looking-at "-")))) (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). @@ -3083,14 +3275,25 @@ (point)) (point))) ;; check if 'string quote' is only a character constant (progn - (re-search-backward "\"" nil t) ; # not a string delimiter anymore + (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 or a comment. - (or (ada-in-comment-p) - (ada-in-string-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 () @@ -3117,10 +3320,12 @@ ;; 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) - 1 - (- (point) ada-search-paren-char-count-limit))) + (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))) @@ -3169,7 +3374,7 @@ (defun ada-indent-current-function () - "Ada Mode version of the indent-line-function." + "Ada mode version of the indent-line-function." (interactive "*") (let ((starting-point (point-marker))) (ada-beginning-of-line) @@ -3209,16 +3414,17 @@ (save-match-data (save-excursion (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+$" (point-max) t) - (replace-match "" nil nil)))))) + (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)))) + (untabify (point-min) (point-max)) + nil)) (defun ada-uncomment-region (beg end) @@ -3234,6 +3440,23 @@ (and (fboundp 'ff-find-other-file) (ff-find-other-file t))) +;; inspired by Laurent.GUERBY@enst-bretagne.fr +(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 ", ")) + )) + + ;;;-------------------------------;;; ;;; Moving To Procedures/Packages ;;; @@ -3304,21 +3527,25 @@ ;; Compilation (define-key ada-mode-map "\C-c\C-c" '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) ;; 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) + (define-key ada-mode-map "\177" 'backward-delete-char-untabify) + ;; 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) ;; Change basic functionality - ;; `substitute-key-definition' is not defined equally in GNU Emacs + ;; `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 - ;; GNU Emacs as well. If you encounter any problems with the + ;; 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) @@ -3327,7 +3554,7 @@ (end-of-line . ada-end-of-line) (forward-to-indentation . ada-forward-to-indentation) )) - ;; else GNU Emacs + ;; else Emacs ;;(mapcar (lambda (pair) ;; (substitute-key-definition (car pair) (cdr pair) ;; ada-mode-map global-map)) @@ -3342,7 +3569,7 @@ (require 'easymenu) (defun ada-add-ada-menu () - "Adds the menu 'Ada' to the menu bar in Ada Mode." + "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" ["Next Package" ada-next-package t] @@ -3371,7 +3598,9 @@ ["Comment Region" comment-region t] ["Uncomment Region" ada-uncomment-region t] ["----------------" nil nil] - ["Compile" compile (fboundp 'compile)] + ["Global Make" compile (fboundp 'compile)] + ["Local Make" ada-make-local t] + ["Check Syntax" ada-check-syntax t] ["Next Error" next-error (fboundp 'next-error)] ["---------------" nil nil] ["Index" imenu (fboundp 'imenu)] @@ -3382,7 +3611,7 @@ (fboundp 'ff-find-other-file)])) (if (ada-xemacs) (progn (easy-menu-add ada-mode-menu) - (setq mode-popup-menu (cons "Ada Mode" ada-mode-menu))))) + (setq mode-popup-menu (cons "Ada mode" ada-mode-menu))))) @@ -3418,37 +3647,22 @@ )) ;;;--------------------------------------------------- -;;; support for find-file +;;; support for find-file.el ;;;--------------------------------------------------- ;;;###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 gkrunch, when we work with GNAT. It + ;; 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") - - ;; things that should really be done by the external process - ;; since gnat-2.0, gnatk8 can do these things. If you still use a - ;; previous version, just uncomment the following lines. (let (krunch-buf) (setq krunch-buf (generate-new-buffer "*gkrunch*")) (save-excursion (set-buffer krunch-buf) -; (insert (downcase adaname)) -; (goto-char (point-min)) -; (while (search-forward "." nil t) -; (replace-match "-" nil t)) -; (setq adaname (buffer-substring (point-min) -; (progn -; (goto-char (point-min)) -; (end-of-line) -; (point)))) -; ;; clean the buffer -; (delete-region (point-min) (point-max)) - ;; send adaname to external process "gnatk8" - (call-process "gnatk8" nil krunch-buf nil + ;; 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 @@ -3481,74 +3695,45 @@ ;;;--------------------------------------------------- -;;; support for imenu -;;;--------------------------------------------------- - -(defun imenu-create-ada-index (&optional regexp) - "Create index alist for Ada files." - (let ((index-alist '()) - prev-pos char) - (goto-char (point-min)) - ;(imenu-progress-message prev-pos 0) - ;; Search for functions/procedures - (save-match-data - (while (re-search-forward - (or regexp ada-procedure-start-regexp) - nil t) - ;(imenu-progress-message prev-pos) - ;; do not store forward definitions - ;; right now we store them. We want to avoid them only in - ;; package bodies, not in the specs!! ???RE??? - (save-match-data -; (if (not (looking-at (concat -; "[ \t\n]*" ; WS -; "\([^)]+\)" ; parameterlist -; "\\([ \n\t]+return[ \n\t]+"; potential return -; "[a-zA-Z0-9_\\.]+\\)?" -; "[ \t]*" ; WS -; ";" ;; THIS is what we really look for -; ))) -; ; (push (imenu-example--name-and-position) index-alist) - (setq index-alist (cons (imenu-example--name-and-position) - index-alist)) -; ) - ) - ;(imenu-progress-message 100) - )) - (nreverse index-alist))) - -;;;--------------------------------------------------- ;;; support for font-lock ;;;--------------------------------------------------- -;; Strings are a real pain in Ada because both ' and " can appear in a -;; non-string quote context (the former as an operator, the latter as -;; a character string). We follow the least losing solution, in which -;; only " is a string quote. Therefore a character string of the form -;; '"' will throw fontification off on the wrong track. +;; 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\\|" + "function\\|" + "package[ \t]+body\\|" + "package\\|" + "pragma\\|" + "procedure\\|" + "protected[ \t]+body\\|" + "protected[ \t]+type\\|" + "protected\\|" ;; "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\ ;;\\|r\\(agma\\|ocedure\\)\\)\\|" - "task\\|" "task[ \t]+body\\|" - "task[ \t]+type" + "task[ \t]+type\\|" + "task" ;; "task\\(\\|[ \t]+body\\)" "\\)\\>[ \t]*" "\\(\\sw+\\(\\.\\sw*\\)*\\)?") @@ -3575,15 +3760,15 @@ "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\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" + "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) (2 font-lock-function-name-face nil t)) + '("\\<\\(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]*" @@ -3594,7 +3779,7 @@ ;; ;; Optional keywords followed by a type name. (list (concat ; ":[ \t]*" - "\\<\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)\\>" + "\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>" "[ \t]*" "\\(\\sw+\\)?") '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) @@ -3619,19 +3804,28 @@ )) "Gaudy level highlighting for Ada mode.") -;; XEmacs change -(defvar ada-font-lock-keywords (if font-lock-maximum-decoration - ada-font-lock-keywords-2 - ada-font-lock-keywords-1) - "Default Expressions to highlight in Ada mode. -See the doc to `font-lock-maximum-decoration' for user configuration.") - -;; XEmacs change -(put 'ada-mode 'font-lock-defaults - '(ada-font-lock-keywords nil t ((?\_ . "w")))) +(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))) ;;; -;;; ???? +;;; 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.