Mercurial > emacs
changeset 44465:0a0f75d152df
(ada-case-exception-file, ada-indent-handle-comment-special): New variables.
(ada-case-exception-substring): New variable. Casing exceptions can
now also be defined for substrings, in addition to full identifier
names. This provides more flexibility.
(ada-align-list): New function, provide support for align.el in ada-mode.
(ada-procedure-start-regexp): Add support for operators and generic formal
subprograms and packages.
(ada-imenu-comment-re): New variable.
(ada-imenu-generic-expression): Add support for protected types.
(ada-mode): Set comment-start only after running ada-mode-hook, so that the
user can change ada-comment-start in the hook.
Add support for ispell in comments. Add support for align.el.
(ada-save-exception-file, ada-create-case-exception-substring)
(ada-adjust-case-substring): New functions.
(ada-get-current-indent): Properly handles keywords with uppercases.
(ada-goto-matching-end): Rewritten, fixes problems in the handling of
nested blocks.
(ada-untab-hard): Do not touch the contents of comments and strings.
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Tue, 09 Apr 2002 18:50:17 +0000 |
| parents | ca04149c39a4 |
| children | f200fce92816 |
| files | lisp/progmodes/ada-mode.el |
| diffstat | 1 files changed, 868 insertions(+), 359 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/progmodes/ada-mode.el Tue Apr 09 18:41:56 2002 +0000 +++ b/lisp/progmodes/ada-mode.el Tue Apr 09 18:50:17 2002 +0000 @@ -7,7 +7,7 @@ ;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> ;; Emmanuel Briot <briot@gnat.com> ;; Maintainer: Emmanuel Briot <briot@gnat.com> -;; Ada Core Technologies's version: $Revision: 1.47 $ +;; Ada Core Technologies's version: $Revision: 1.48 $ ;; Keywords: languages ada ;; This file is part of GNU Emacs. @@ -94,6 +94,7 @@ ;;; gse@ocsystems.com (Scott Evans) ;;; comar@gnat.com (Cyrille Comar) ;;; stephen.leake@gsfc.nasa.gov (Stephen Leake) +;;; robin-reply@reagans.org ;;; and others for their valuable hints. ;;; Code: @@ -103,6 +104,28 @@ ;;; the customize mode. They are sorted in alphabetical order in this ;;; file. +;;; Supported packages. +;;; This package supports a number of other Emacs modes. These other modes +;;; should be loaded before the ada-mode, which will then setup some variables +;;; to improve the support for Ada code. +;;; Here is the list of these modes: +;;; `which-function-mode': Display the name of the subprogram the cursor is +;;; in in the mode line. +;;; `outline-mode': Provides the capability to collapse or expand the code +;;; for specific language constructs, for instance if you want to hide the +;;; code corresponding to a subprogram +;;; `align': This mode is now provided with Emacs 21, but can also be +;;; installed manually for older versions of Emacs. It provides the +;;; capability to automatically realign the selected region (for instance +;;; all ':=', ':' and '--' will be aligned on top of each other. +;;; `imenu': Provides a menu with the list of entities defined in the current +;;; buffer, and an easy way to jump to any of them +;;; `speedbar': Provides a separate file browser, and the capability for each +;;; file to see the list of entities defined in it and to jump to them +;;; easily +;;; `abbrev-mode': Provides the capability to define abbreviations, which +;;; are automatically expanded when you type them. See the Emacs manual. + ;; this function is needed at compile time (eval-and-compile @@ -133,7 +156,8 @@ ;; This call should not be made in the release that is done for the ;; official FSF Emacs, since it does nothing useful for the latest version -;; (require 'ada-support) +(if (not (ada-check-emacs-version 21 1)) + (require 'ada-support)) (defvar ada-mode-hook nil "*List of functions to call when Ada mode is invoked. @@ -179,13 +203,17 @@ (const ada-no-auto-case)) :group 'ada) -(defcustom ada-case-exception-file '("~/.emacs_case_exceptions") +(defcustom ada-case-exception-file + (list (convert-standard-filename' "~/.emacs_case_exceptions")) "*List of special casing exceptions dictionaries for identifiers. The first file is the one where new exceptions will be saved by Emacs when you call `ada-create-case-exception'. These files should contain one word per line, that gives the casing -to be used for that word in Ada files. Each line can be terminated by +to be used for that word in Ada files. If the line starts with the +character *, then the exception will be used for substrings that either +start at the beginning of a word or after a _ character, and end either +at the end of the word or at a _ character. Each line can be terminated by a comment." :type '(repeat (file)) :group 'ada) @@ -244,6 +272,29 @@ nil means do not auto-indent comments." :type 'boolean :group 'ada) +(defcustom ada-indent-handle-comment-special nil + "*Non-nil if comment lines should be handled specially inside +parenthesis. +By default, if the line that contains the open parenthesis has some +text following it, then the following lines will be indented in the +same column as this text. This will not be true if the first line is +a comment and `ada-indent-handle-comment-special' is t. + +type A is + ( Value_1, -- common behavior, when not a comment + Value_2); + +type A is + ( -- `ada-indent-handle-comment-special' is nil + Value_1, + Value_2); + +type A is + ( -- `ada-indent-handle-comment-special' is non-nil + Value_1, + Value_2);" + :type 'boolean :group 'ada) + (defcustom ada-indent-is-separate t "*Non-nil means indent 'is separate' or 'is abstract' if on a single line." :type 'boolean :group 'ada) @@ -429,6 +480,12 @@ (defvar ada-case-exception '() "Alist of words (entities) that have special casing.") +(defvar ada-case-exception-substring '() + "Alist of substrings (entities) that have special casing. +The substrings are detected for word constituant when the word +is not itself in ada-case-exception, and only for substrings that +either are at the beginning or end of the word, or start after '_'.") + (defvar ada-lfd-binding nil "Variable to save key binding of LFD when casing is activated.") @@ -436,6 +493,56 @@ "Variable used by find-file to find the name of the other package. See `ff-other-file-alist'.") +(defvar ada-align-list + '(("[^:]\\(\\s-*\\):[^:]" 1 t) + ("[^=]\\(\\s-+\\)=[^=]" 1 t) + ("\\(\\s-*\\)use\\s-" 1) + ("\\(\\s-*\\)--" 1)) + "Ada support for align.el <= 2.2 +This variable provides regular expressions on which to align different lines. +See `align-mode-alist' for more information.") + +(defvar ada-align-modes + '((ada-declaration + (regexp . "[^:]\\(\\s-*\\):[^:]") + (valid . (lambda() (not (ada-in-comment-p)))) + (modes . '(ada-mode))) + (ada-assignment + (regexp . "[^=]\\(\\s-+\\)=[^=]") + (valid . (lambda() (not (ada-in-comment-p)))) + (modes . '(ada-mode))) + (ada-comment + (regexp . "\\(\\s-*\\)--") + (modes . '(ada-mode))) + (ada-use + (regexp . "\\(\\s-*\\)use\\s-") + (valid . (lambda() (not (ada-in-comment-p)))) + (modes . '(ada-mode))) + ) + "Ada support for align.el >= 2.8 +This variable defines several rules to use to align different lines.") + +(defconst ada-align-region-separate + (concat + "^\\s-*\\($\\|\\(" + "begin\\|" + "declare\\|" + "else\\|" + "end\\|" + "exception\\|" + "for\\|" + "function\\|" + "generic\\|" + "if\\|" + "is\\|" + "procedure\\|" + "record\\|" + "return\\|" + "type\\|" + "when" + "\\)\\>\\)") + "see the variable `align-region-separate' for more information.") + ;;; ---- Below are the regexp used in this package for parsing (defconst ada-83-keywords @@ -459,8 +566,20 @@ "\\(\\sw\\|[_.]\\)+" "Regexp matching Ada (qualified) identifiers.") +;; "with" needs to be included in the regexp, so that we can insert new lines +;; after the declaration of the parameter for a generic. (defvar ada-procedure-start-regexp - "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\(\\(\\sw\\|[_.]\\)+\\)" + (concat + "^[ \t]*\\(with[ \t]+\\)?\\(procedure\\|function\\|task\\)[ \t\n]+" + + ;; subprogram name: operator ("[+/=*]") + "\\(" + "\\(\"[^\"]+\"\\)" + + ;; subprogram name: name + "\\|" + "\\(\\(\\sw\\|[_.]\\)+\\)" + "\\)") "Regexp used to find Ada procedures/functions.") (defvar ada-package-start-regexp @@ -595,8 +714,14 @@ ;; Support for imenu (see imenu.el) ;;------------------------------------------------------------------ +(defconst ada-imenu-comment-re "\\([ \t]*--.*\\)?") + (defconst ada-imenu-subprogram-menu-re - "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)\\)[ \t\n]*\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]") + (concat "^[ \t]*\\(procedure\\|function\\)[ \t\n]+" + "\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)" + ada-imenu-comment-re + "\\)[ \t\n]*" + "\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]")) (defvar ada-imenu-generic-expression (list @@ -605,17 +730,18 @@ (concat "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)" "\\(" - "\\([ \t\n]+\\|[ \t\n]*([^)]+)\\)";; parameter list or simple space + "\\(" ada-imenu-comment-re "[ \t\n]+\\|[ \t\n]*([^)]+)" + ada-imenu-comment-re "\\)";; parameter list or simple space "\\([ \t\n]*return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?" "\\)?;") 2) - '("*Tasks*" "^[ \t]*task[ \t]+\\(\\(body\\|type\\)[ \t]+\\)?\\(\\(\\sw\\|_\\)+\\)" 3) + '("*Tasks*" "^[ \t]*task[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2) '("*Type Defs*" "^[ \t]*\\(sub\\)?type[ \t]+\\(\\(\\sw\\|_\\)+\\)" 2) + '("*Protected*" + "^[ \t]*protected[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2) '("*Packages*" "^[ \t]*package[ \t]+\\(\\(body[ \t]+\\)?\\(\\sw\\|[_.]\\)+\\)" 1)) "Imenu generic expression for Ada mode. -See `imenu-generic-expression'. This variable will create two submenus, one -for type and subtype definitions, the other for subprograms declarations. -The main menu will reference the bodies of the subprograms.") - +See `imenu-generic-expression'. This variable will create several submenus for +each type of entity that can be found in an Ada file.") ;;------------------------------------------------------------ @@ -959,8 +1085,10 @@ ;;;###autoload (defun ada-mode () "Ada mode is the major mode for editing Ada code. +This version was built on $Date: 2001/12/26 14:40:09 $. Bindings are as follows: (Note: 'LFD' is control-j.) +\\{ada-mode-map} Indent line '\\[ada-tab]' Indent line, insert newline and indent the new line. '\\[newline-and-indent]' @@ -1005,11 +1133,6 @@ (set (make-local-variable 'require-final-newline) t) - (make-local-variable 'comment-start) - (if ada-fill-comment-prefix - (setq comment-start ada-fill-comment-prefix) - (setq comment-start "-- ")) - ;; Set the paragraph delimiters so that one can select a whole block ;; simply with M-h (set (make-local-variable 'paragraph-start) "[ \t\n\f]*$") @@ -1039,12 +1162,18 @@ ;; Emacs 20.3 defines a comment-padding to insert spaces between ;; the comment and the text. We do not want any, this is already ;; included in comment-start - (set (make-local-variable 'comment-padding) 0) - (set (make-local-variable 'parse-sexp-ignore-comments) t) - (set (make-local-variable 'parse-sexp-lookup-properties) t) - - (setq case-fold-search t) - (setq imenu-case-fold-search t) + (unless ada-xemacs + (progn + (if (ada-check-emacs-version 20 3) + (progn + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'comment-padding) 0))) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + )) + + (set 'case-fold-search t) + (if (boundp 'imenu-case-fold-search) + (set 'imenu-case-fold-search t)) (set (make-local-variable 'fill-paragraph-function) 'ada-fill-comment-paragraph) @@ -1065,13 +1194,23 @@ (define-key compilation-minor-mode-map "\C-m" 'ada-compile-goto-error))) - ;; font-lock support - (set (make-local-variable 'font-lock-defaults) - '(ada-font-lock-keywords - nil t - ((?\_ . "w") (?# . ".")) - beginning-of-line - (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) + ;; font-lock support : + ;; We need to set some properties for XEmacs, and define some variables + ;; for Emacs + + (if ada-xemacs + ;; XEmacs + (put 'ada-mode 'font-lock-defaults + '(ada-font-lock-keywords + nil t ((?\_ . "w") (?# . ".")) beginning-of-line)) + ;; Emacs + (set (make-local-variable 'font-lock-defaults) + '(ada-font-lock-keywords + nil t + ((?\_ . "w") (?# . ".")) + beginning-of-line + (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) + ) ;; Set up support for find-file.el. (set (make-local-variable 'ff-other-file-alist) @@ -1094,7 +1233,7 @@ "\\(body[ \t]+\\)?" "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is")) (lambda () - (setq fname (ff-get-file + (set 'fname (ff-get-file ada-search-directories (ada-make-filename-from-adaname (match-string 3)) @@ -1104,7 +1243,7 @@ (add-to-list 'ff-special-constructs (cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))" (lambda () - (setq fname (ff-get-file + (set 'fname (ff-get-file ada-search-directories (ada-make-filename-from-adaname (match-string 1)) @@ -1119,7 +1258,7 @@ (assoc "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" ff-special-constructs)) (new-cdr (lambda () - (setq fname (ff-get-file + (set 'fname (ff-get-file ada-search-directories (ada-make-filename-from-adaname (match-string 1)) @@ -1138,6 +1277,24 @@ ;; Support for imenu : We want a sorted index (setq imenu-sort-function 'imenu--sort-by-name) + ;; Support for ispell : Check only comments + (set (make-local-variable 'ispell-check-comments) 'exclusive) + + ;; Support for align.el <= 2.2, if present + ;; align.el is distributed with Emacs 21, but not with earlier versions. + (if (boundp 'align-mode-alist) + (add-to-list 'align-mode-alist '(ada-mode . ada-align-list))) + + ;; Support for align.el >= 2.8, if present + (if (boundp 'align-dq-string-modes) + (progn + (add-to-list 'align-dq-string-modes 'ada-mode) + (add-to-list 'align-open-comment-modes 'ada-mode) + (set 'align-mode-rules-list ada-align-modes) + (set (make-variable-buffer-local 'align-region-separate) + ada-align-region-separate) + )) + ;; Support for which-function-mode is provided in ada-support (support ;; for nested subprograms) @@ -1152,8 +1309,8 @@ ;; Support for indent-new-comment-line (Especially for XEmacs) (setq comment-multi-line nil) - (setq major-mode 'ada-mode) - (setq mode-name "Ada") + (setq major-mode 'ada-mode + mode-name "Ada") (use-local-map ada-mode-map) @@ -1171,12 +1328,21 @@ (run-hooks 'ada-mode-hook) + ;; To be run after the hook, in case the user modified + ;; ada-fill-comment-prefix + (make-local-variable 'comment-start) + (if ada-fill-comment-prefix + (set 'comment-start ada-fill-comment-prefix) + (set 'comment-start "-- ")) + ;; Run this after the hook to give the users a chance to activate ;; font-lock-mode (unless ada-xemacs - (ada-initialize-properties) - (add-hook 'font-lock-mode-hook 'ada-deactivate-properties nil t)) + (progn + (ada-initialize-properties) + (make-local-hook 'font-lock-mode-hook) + (add-hook 'font-lock-mode-hook 'ada-deactivate-properties nil t))) ;; the following has to be done after running the ada-mode-hook ;; because users might want to set the values of these variable @@ -1190,6 +1356,15 @@ (if ada-auto-case (ada-activate-keys-for-case))) + +;; transient-mark-mode and mark-active are not defined in XEmacs +(defun ada-region-selected () + "t if a region has been selected by the user and is still active." + (or (and ada-xemacs (funcall (symbol-function 'region-active-p))) + (and (not ada-xemacs) + (symbol-value 'transient-mark-mode) + (symbol-value 'mark-active)))) + ;;----------------------------------------------------------------- ;; auto-casing @@ -1205,6 +1380,23 @@ ;; For backward compatibility, this variable can also be a string. ;;----------------------------------------------------------------- +(defun ada-save-exceptions-to-file (file-name) + "Save the exception lists `ada-case-exception' and +`ada-case-exception-substring' to the file FILE-NAME." + + ;; Save the list in the file + (find-file (expand-file-name file-name)) + (erase-buffer) + (mapcar (lambda (x) (insert (car x) "\n")) + (sort (copy-sequence ada-case-exception) + (lambda(a b) (string< (car a) (car b))))) + (mapcar (lambda (x) (insert "*" (car x) "\n")) + (sort (copy-sequence ada-case-exception-substring) + (lambda(a b) (string< (car a) (car b))))) + (save-buffer) + (kill-buffer nil) + ) + (defun ada-create-case-exception (&optional word) "Defines WORD as an exception for the casing system. If WORD is not given, then the current word in the buffer is used instead. @@ -1212,7 +1404,6 @@ The standard casing rules will no longer apply to this word." (interactive) (let ((previous-syntax-table (syntax-table)) - (exception-list '()) file-name ) @@ -1221,7 +1412,8 @@ ((listp ada-case-exception-file) (setq file-name (car ada-case-exception-file))) (t - (error "No exception file specified"))) + (error (concat "No exception file specified. " + "See variable ada-case-exception-file.")))) (set-syntax-table ada-mode-symbol-syntax-table) (unless word @@ -1229,55 +1421,76 @@ (skip-syntax-backward "w") (setq word (buffer-substring-no-properties (point) (save-excursion (forward-word 1) (point)))))) + (set-syntax-table previous-syntax-table) ;; Reread the exceptions file, in case it was modified by some other, - ;; and to keep the end-of-line comments that may exist in it. - (if (file-readable-p (expand-file-name file-name)) - (let ((buffer (current-buffer))) - (find-file (expand-file-name file-name)) - (set-syntax-table ada-mode-symbol-syntax-table) - (widen) - (goto-char (point-min)) - (while (not (eobp)) - (add-to-list 'exception-list - (list - (buffer-substring-no-properties - (point) (save-excursion (forward-word 1) (point))) - (buffer-substring-no-properties - (save-excursion (forward-word 1) (point)) - (save-excursion (end-of-line) (point))) - t)) - (forward-line 1)) - (kill-buffer nil) - (set-buffer buffer))) + (ada-case-read-exceptions-from-file file-name) ;; If the word is already in the list, even with a different casing ;; we simply want to replace it. - (if (and (not (equal exception-list '())) - (assoc-ignore-case word exception-list)) - (setcar (assoc-ignore-case word exception-list) - word) - (add-to-list 'exception-list (list word "" t)) - ) - (if (and (not (equal ada-case-exception '())) (assoc-ignore-case word ada-case-exception)) - (setcar (assoc-ignore-case word ada-case-exception) - word) + (setcar (assoc-ignore-case word ada-case-exception) word) (add-to-list 'ada-case-exception (cons word t)) ) - ;; Save the list in the file - (find-file (expand-file-name file-name)) - (erase-buffer) - (mapcar (lambda (x) (insert (car x) (nth 1 x) "\n")) - (sort exception-list - (lambda(a b) (string< (car a) (car b))))) - (save-buffer) - (kill-buffer nil) - (set-syntax-table previous-syntax-table) + (ada-save-exceptions-to-file file-name) )) +(defun ada-create-case-exception-substring (&optional word) + "Defines the substring WORD as an exception for the casing system. +If WORD is not given, then the current word in the buffer is used instead, +or the selected region if any is active. +The new words is added to the first file in `ada-case-exception-file'. +When auto-casing a word, this substring will be special-cased, unless the +word itself has a special casing." + (interactive) + (let ((file-name + (cond ((stringp ada-case-exception-file) + ada-case-exception-file) + ((listp ada-case-exception-file) + (car ada-case-exception-file)) + (t + (error (concat "No exception file specified. " + "See variable ada-case-exception-file.")))))) + + ;; Find the substring to define as an exception. Order is: the parameter, + ;; if any, or the selected region, or the word under the cursor + (cond + (word nil) + + ((ada-region-selected) + (setq word (buffer-substring-no-properties + (region-beginning) (region-end)))) + + (t + (let ((underscore-syntax (char-syntax ?_))) + (unwind-protect + (progn + (modify-syntax-entry ?_ "." (syntax-table)) + (save-excursion + (skip-syntax-backward "w") + (set 'word (buffer-substring-no-properties + (point) + (save-excursion (forward-word 1) (point)))))) + (modify-syntax-entry ?_ (make-string 1 underscore-syntax) + (syntax-table)))))) + + ;; Reread the exceptions file, in case it was modified by some other, + (ada-case-read-exceptions-from-file file-name) + + ;; If the word is already in the list, even with a different casing + ;; we simply want to replace it. + (if (and (not (equal ada-case-exception-substring '())) + (assoc-ignore-case word ada-case-exception-substring)) + (setcar (assoc-ignore-case word ada-case-exception-substring) word) + (add-to-list 'ada-case-exception-substring (cons word t)) + ) + + (ada-save-exceptions-to-file file-name) + + (message (concat "Defining " word " as a casing exception")))) + (defun ada-case-read-exceptions-from-file (file-name) "Read the content of the casing exception file FILE-NAME." (if (file-readable-p (expand-file-name file-name)) @@ -1293,8 +1506,15 @@ ;; priority should be applied to each casing exception (let ((word (buffer-substring-no-properties (point) (save-excursion (forward-word 1) (point))))) - (unless (assoc-ignore-case word ada-case-exception) - (add-to-list 'ada-case-exception (cons word t)))) + + ;; Handling a substring ? + (if (char-equal (string-to-char word) ?*) + (progn + (setq word (substring word 1)) + (unless (assoc-ignore-case word ada-case-exception-substring) + (add-to-list 'ada-case-exception-substring (cons word t)))) + (unless (assoc-ignore-case word ada-case-exception) + (add-to-list 'ada-case-exception (cons word t))))) (forward-line 1)) (kill-buffer nil) @@ -1306,7 +1526,8 @@ (interactive) ;; Reinitialize the casing exception list - (setq ada-case-exception '()) + (setq ada-case-exception '() + ada-case-exception-substring '()) (cond ((stringp ada-case-exception-file) (ada-case-read-exceptions-from-file ada-case-exception-file)) @@ -1315,6 +1536,34 @@ (mapcar 'ada-case-read-exceptions-from-file ada-case-exception-file)))) +(defun ada-adjust-case-substring () + "Adjust case of substrings in the previous word." + (interactive) + (let ((substrings ada-case-exception-substring) + (max (point)) + (case-fold-search t) + (underscore-syntax (char-syntax ?_)) + re) + + (save-excursion + (forward-word -1) + + (unwind-protect + (progn + (modify-syntax-entry ?_ "." (syntax-table)) + + (while substrings + (setq re (concat "\\b" (regexp-quote (caar substrings)) "\\b")) + + (save-excursion + (while (re-search-forward re max t) + (replace-match (caar substrings)))) + (setq substrings (cdr substrings)) + ) + ) + (modify-syntax-entry ?_ (make-string 1 underscore-syntax) (syntax-table))) + ))) + (defun ada-adjust-case-identifier () "Adjust case of the previous identifier. The auto-casing is done according to the value of `ada-case-identifier' and @@ -1322,7 +1571,9 @@ (interactive) (if (or (equal ada-case-exception '()) (equal (char-after) ?_)) - (funcall ada-case-identifier -1) + (progn + (funcall ada-case-identifier -1) + (ada-adjust-case-substring)) (progn (let ((end (point)) @@ -1338,7 +1589,8 @@ (insert (car match))) ;; Else simply re-case the word - (funcall ada-case-identifier -1)))))) + (funcall ada-case-identifier -1) + (ada-adjust-case-substring)))))) (defun ada-after-keyword-p () "Returns t if cursor is after a keyword that is not an attribute." @@ -1352,28 +1604,31 @@ (defun ada-adjust-case (&optional force-identifier) "Adjust the case of the word before the just typed character. If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." - (forward-char -1) - (if (and (> (point) 1) - ;; or if at the end of a character constant - (not (and (eq (char-after) ?') - (eq (char-before (1- (point))) ?'))) - ;; or if the previous character was not part of a word - (eq (char-syntax (char-before)) ?w) - ;; if in a string or a comment - (not (ada-in-string-or-comment-p)) - ) - (if (save-excursion - (forward-word -1) - (or (= (point) (point-min)) - (backward-char 1)) - (= (char-after) ?')) - (funcall ada-case-attribute -1) - (if (and - (not force-identifier) ; (MH) - (ada-after-keyword-p)) - (funcall ada-case-keyword -1) - (ada-adjust-case-identifier)))) - (forward-char 1) + (if (not (bobp)) + (progn + (forward-char -1) + (if (and (not (bobp)) + ;; or if at the end of a character constant + (not (and (eq (following-char) ?') + (eq (char-before (1- (point))) ?'))) + ;; or if the previous character was not part of a word + (eq (char-syntax (char-before)) ?w) + ;; if in a string or a comment + (not (ada-in-string-or-comment-p)) + ) + (if (save-excursion + (forward-word -1) + (or (= (point) (point-min)) + (backward-char 1)) + (= (following-char) ?')) + (funcall ada-case-attribute -1) + (if (and + (not force-identifier) ; (MH) + (ada-after-keyword-p)) + (funcall ada-case-keyword -1) + (ada-adjust-case-identifier)))) + (forward-char 1) + )) ) (defun ada-adjust-case-interactive (arg) @@ -1880,20 +2135,23 @@ (let ((cur-indent (ada-indent-current))) - (message nil) - (if (equal (cdr cur-indent) '(0)) - (message "same indentation") - (message (mapconcat (lambda(x) - (cond - ((symbolp x) - (symbol-name x)) - ((numberp x) - (number-to-string x)) - ((listp x) - (concat "- " (symbol-name (cadr x)))) - )) - (cdr cur-indent) - " + "))) + (let ((line (save-excursion + (goto-char (car cur-indent)) + (count-lines (point-min) (point))))) + + (if (equal (cdr cur-indent) '(0)) + (message (concat "same indentation as line " (number-to-string line))) + (message (mapconcat (lambda(x) + (cond + ((symbolp x) + (symbol-name x)) + ((numberp x) + (number-to-string x)) + ((listp x) + (concat "- " (symbol-name (cadr x)))) + )) + (cdr cur-indent) + " + ")))) (save-excursion (goto-char (car cur-indent)) (sit-for 1)))) @@ -2016,13 +2274,41 @@ ;; check if we have something like this (Table_Component_Type => ;; Source_File_Record) (save-excursion - (if (and (skip-chars-backward " \t") - (= (char-before) ?\n) - (not (forward-comment -10000)) - (= (char-before) ?>)) - ;; ??? Could use a different variable - (list column 'ada-broken-indent) - (list column 0)))) + + ;; Align the closing parenthesis on the opening one + (if (= (following-char) ?\)) + (save-excursion + (goto-char column) + (skip-chars-backward " \t") + (list (1- (point)) 0)) + + (if (and (skip-chars-backward " \t") + (= (char-before) ?\n) + (not (forward-comment -10000)) + (= (char-before) ?>)) + ;; ??? Could use a different variable + (list column 'ada-broken-indent) + + ;; Correctly indent named parameter lists ("name => ...") for + ;; all the following lines + (goto-char column) + (if (and (progn (forward-comment 1000) + (looking-at "\\sw+\\s *=>")) + (progn (goto-char orgpoint) + (forward-comment 1000) + (not (looking-at "\\sw+\\s *=>")))) + (list column 'ada-broken-indent) + + ;; ??? Would be nice that lines like + ;; A + ;; (B, + ;; C + ;; (E)); -- would be nice if this was correctly indented +; (if (= (char-before (1- orgpoint)) ?,) + (list column 0) +; (list column 'ada-broken-indent) +; ) + ))))) ;;--------------------------- ;; at end of buffer @@ -2035,7 +2321,7 @@ ;; starting with e ;;--------------------------- - ((= (char-after) ?e) + ((= (downcase (char-after)) ?e) (cond ;; ------- end ------ @@ -2068,8 +2354,25 @@ (beginning-of-line) (if (looking-at ada-named-block-re) (setq label (- ada-label-indent)))))))) - - (list (+ (save-excursion (back-to-indentation) (point)) label) 0)))) + + ;; found 'record' => + ;; if the keyword is found at the beginning of a line (or just + ;; after limited, we indent on it, otherwise we indent on the + ;; beginning of the type declaration) + ;; type A is (B : Integer; + ;; C : Integer) is record + ;; end record; -- This is badly indented otherwise + (if (looking-at "record") + (if (save-excursion + (beginning-of-line) + (looking-at "^[ \t]*\\(record\\|limited record\\)")) + (list (save-excursion (back-to-indentation) (point)) 0) + (list (save-excursion + (car (ada-search-ignore-string-comment "\\<type\\>" t))) + 0)) + + ;; Else keep the same indentation as the beginning statement + (list (+ (save-excursion (back-to-indentation) (point)) label) 0))))) ;; ------ exception ---- @@ -2089,7 +2392,7 @@ (list (progn (back-to-indentation) (point)) 0)))) ;; elsif - + ((looking-at "elsif\\>") (save-excursion (ada-goto-matching-start 1 nil t) @@ -2100,8 +2403,8 @@ ;;--------------------------- ;; starting with w (when) ;;--------------------------- - - ((and (= (char-after) ?w) + + ((and (= (downcase (char-after)) ?w) (looking-at "when\\>")) (save-excursion (ada-goto-matching-start 1) @@ -2112,7 +2415,7 @@ ;; starting with t (then) ;;--------------------------- - ((and (= (char-after) ?t) + ((and (= (downcase (char-after)) ?t) (looking-at "then\\>")) (if (save-excursion (ada-goto-previous-word) (looking-at "and\\>")) @@ -2127,8 +2430,8 @@ ;;--------------------------- ;; starting with l (loop) ;;--------------------------- - - ((and (= (char-after) ?l) + + ((and (= (downcase (char-after)) ?l) (looking-at "loop\\>")) (setq pos (point)) (save-excursion @@ -2143,11 +2446,29 @@ (ada-indent-on-previous-lines nil orgpoint orgpoint) (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))) + ;;---------------------------- + ;; starting with l (limited) or r (record) + ;;---------------------------- + + ((or (and (= (downcase (char-after)) ?l) + (looking-at "limited\\>")) + (and (= (downcase (char-after)) ?r) + (looking-at "record\\>"))) + + (save-excursion + (ada-search-ignore-string-comment + "\\<\\(type\\|use\\)\\>" t nil) + (if (looking-at "\\<use\\>") + (ada-search-ignore-string-comment "for" t nil nil + 'word-search-backward)) + (list (progn (back-to-indentation) (point)) + 'ada-indent-record-rel-type))) + ;;--------------------------- ;; starting with b (begin) ;;--------------------------- - ((and (= (char-after) ?b) + ((and (= (downcase (char-after)) ?b) (looking-at "begin\\>")) (save-excursion (if (ada-goto-matching-decl-start t) @@ -2158,7 +2479,7 @@ ;; starting with i (is) ;;--------------------------- - ((and (= (char-after) ?i) + ((and (= (downcase (char-after)) ?i) (looking-at "is\\>")) (if (and ada-indent-is-separate @@ -2175,93 +2496,79 @@ (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))) ;;--------------------------- - ;; starting with r (record, return, renames) + ;; starting with r (return, renames) ;;--------------------------- - ((= (char-after) ?r) - - (cond - - ;; ----- record ------ - - ((looking-at "record\\>") - (save-excursion - (ada-search-ignore-string-comment - "\\<\\(type\\|use\\)\\>" t nil) - (if (looking-at "\\<use\\>") - (ada-search-ignore-string-comment "for" t nil nil 'word-search-backward)) - (list (progn (back-to-indentation) (point)) 'ada-indent-record-rel-type))) - - ;; ----- return or renames ------ - - ((looking-at "re\\(turn\\|names\\)\\>") - (save-excursion - (let ((var 'ada-indent-return)) - ;; If looking at a renames, skip the 'return' statement too - (if (looking-at "renames") - (let (pos) - (save-excursion - (setq pos (ada-search-ignore-string-comment ";\\|return\\>" t))) - (if (and pos - (= (char-after (car pos)) ?r)) - (goto-char (car pos))) - (setq var 'ada-indent-renames))) - - (forward-comment -1000) - (if (= (char-before) ?\)) - (forward-sexp -1) - (forward-word -1)) - - ;; If there is a parameter list, and we have a function declaration - ;; or a access to subprogram declaration - (let ((num-back 1)) - (if (and (= (char-after) ?\() - (save-excursion - (or (progn - (backward-word 1) - (looking-at "function\\>")) - (progn - (backward-word 1) - (setq num-back 2) - (looking-at "function\\>"))))) - - ;; The indentation depends of the value of ada-indent-return - (if (<= (eval var) 0) - (list (point) (list '- var)) - (list (progn (backward-word num-back) (point)) - var)) - - ;; Else there is no parameter list, but we have a function - ;; Only do something special if the user want to indent - ;; relative to the "function" keyword - (if (and (> (eval var) 0) - (save-excursion (forward-word -1) - (looking-at "function\\>"))) - (list (progn (forward-word -1) (point)) var) - - ;; Else... - (ada-indent-on-previous-lines nil orgpoint orgpoint))))))) - )) - + ((and (= (downcase (char-after)) ?r) + (looking-at "re\\(turn\\|names\\)\\>")) + + (save-excursion + (let ((var 'ada-indent-return)) + ;; If looking at a renames, skip the 'return' statement too + (if (looking-at "renames") + (let (pos) + (save-excursion + (set 'pos (ada-search-ignore-string-comment ";\\|return\\>" t))) + (if (and pos + (= (downcase (char-after (car pos))) ?r)) + (goto-char (car pos))) + (set 'var 'ada-indent-renames))) + + (forward-comment -1000) + (if (= (char-before) ?\)) + (forward-sexp -1) + (forward-word -1)) + + ;; If there is a parameter list, and we have a function declaration + ;; or a access to subprogram declaration + (let ((num-back 1)) + (if (and (= (following-char) ?\() + (save-excursion + (or (progn + (backward-word 1) + (looking-at "\\(function\\|procedure\\)\\>")) + (progn + (backward-word 1) + (set 'num-back 2) + (looking-at "\\(function\\|procedure\\)\\>"))))) + + ;; The indentation depends of the value of ada-indent-return + (if (<= (eval var) 0) + (list (point) (list '- var)) + (list (progn (backward-word num-back) (point)) + var)) + + ;; Else there is no parameter list, but we have a function + ;; Only do something special if the user want to indent + ;; relative to the "function" keyword + (if (and (> (eval var) 0) + (save-excursion (forward-word -1) + (looking-at "function\\>"))) + (list (progn (forward-word -1) (point)) var) + + ;; Else... + (ada-indent-on-previous-lines nil orgpoint orgpoint))))))) + ;;-------------------------------- ;; starting with 'o' or 'p' ;; 'or' as statement-start ;; 'private' as statement-start ;;-------------------------------- - ((and (or (= (char-after) ?o) - (= (char-after) ?p)) + ((and (or (= (downcase (char-after)) ?o) + (= (downcase (char-after)) ?p)) (or (ada-looking-at-semi-or) (ada-looking-at-semi-private))) (save-excursion - (ada-goto-matching-start 1) - (list (progn (back-to-indentation) (point)) 0))) + ;; ??? Wasn't this done already in ada-looking-at-semi-or ? + (ada-goto-matching-start 1) + (list (progn (back-to-indentation) (point)) 0))) ;;-------------------------------- ;; starting with 'd' (do) ;;-------------------------------- - ((and (= (char-after) ?d) + ((and (= (downcase (char-after)) ?d) (looking-at "do\\>")) (save-excursion (ada-goto-stmt-start) @@ -2329,7 +2636,7 @@ ;; package/function/procedure ;;--------------------------------- - ((and (or (= (char-after) ?p) (= (char-after) ?f)) + ((and (or (= (downcase (char-after)) ?p) (= (downcase (char-after)) ?f)) (looking-at "\\<\\(package\\|function\\|procedure\\)\\>")) (save-excursion ;; Go up until we find either a generic section, or the end of the @@ -2467,11 +2774,17 @@ (ada-goto-next-non-ws) (list (point) 0)) + ;; After an affectation (default parameter value in subprogram + ;; declaration) + ((and (= (following-char) ?=) (= (preceding-char) ?:)) + (back-to-indentation) + (list (point) 'ada-broken-indent)) + ;; inside a parameter declaration (t (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) (ada-goto-next-non-ws) - (list (point) 'ada-broken-indent))))) + (list (point) 0))))) (defun ada-get-indent-end (orgpoint) "Calculates the indentation when point is just before an end_statement. @@ -2526,7 +2839,9 @@ (setq indent (list (point) 0)) (if (ada-goto-matching-decl-start t) (list (progn (back-to-indentation) (point)) 0) - indent))))) + indent)) + (list (progn (back-to-indentation) (point)) 0) + ))) ;; ;; anything else - should maybe signal an error ? ;; @@ -2599,7 +2914,7 @@ (while (and (setq match-cons (ada-search-ignore-string-comment "\\<\\(then\\|and[ \t]*then\\)\\>" nil orgpoint)) - (= (char-after (car match-cons)) ?a))) + (= (downcase (char-after (car match-cons))) ?a))) ;; If "then" was found (we are looking at it) (if match-cons (progn @@ -2630,6 +2945,23 @@ (save-excursion (ada-indent-on-previous-lines t orgpoint))) + ;; Special case for record types, for instance for: + ;; type A is (B : Integer; + ;; C : Integer) is record + ;; null; -- This is badly indented otherwise + ((looking-at "record") + + ;; If record is at the beginning of the line, indent from there + (if (save-excursion + (beginning-of-line) + (looking-at "^[ \t]*\\(record\\|limited record\\)")) + (list (save-excursion (back-to-indentation) (point)) 'ada-indent) + + ;; else indent relative to the type command + (list (save-excursion + (car (ada-search-ignore-string-comment "\\<type\\>" t))) + 'ada-indent))) + ;; nothing follows the block-start (t (list (save-excursion (back-to-indentation) (point)) 'ada-indent))))) @@ -3154,6 +3486,9 @@ "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." (let ((nest-count 1) + + ;; first should be set to t if we should stop at the first + ;; "begin" we encounter. (first (not recursive)) (count-generic nil) (stop-at-when nil) @@ -3210,7 +3545,8 @@ t) (if (looking-at "end") - (ada-goto-matching-decl-start noerror t) + (ada-goto-matching-start 1 noerror t) + ;; (ada-goto-matching-decl-start noerror t) (setq loop-again nil) (unless (looking-at "begin") @@ -3235,7 +3571,7 @@ ;; ((looking-at "declare\\|generic") (setq nest-count (1- nest-count)) - (setq first nil)) + (setq first t)) ;; ((looking-at "is") ;; check if it is only a type definition, but not a protected @@ -3279,9 +3615,16 @@ (setq nest-count 0)) ;; ((looking-at "when") - (if stop-at-when - (setq nest-count (1- nest-count))) - (setq first nil)) + (save-excursion + (forward-word -1) + (unless (looking-at "\\<exit[ \t\n]*when\\>") + (progn + (if stop-at-when + (setq nest-count (1- nest-count))) + (setq first nil))))) + ;; + ((looking-at "begin") + (setq first nil)) ;; (t (setq nest-count (1+ nest-count)) @@ -3340,9 +3683,9 @@ (ada-goto-previous-word) (if (looking-at "\\<end\\>[ \t]*[^;]") ;; it ends a block => increase nest depth - (progn - (setq nest-count (1+ nest-count)) - (setq pos (point))) + (setq nest-count (1+ nest-count) + pos (point)) + ;; it starts a block => decrease nest depth (setq nest-count (1- nest-count)))) (goto-char pos)) @@ -3366,7 +3709,11 @@ (forward-word 1) (ada-goto-next-non-ws) ;; ignore it if it is only a declaration with 'new' - (if (not (looking-at "\\<\\(new\\|separate\\)\\>")) + ;; We could have package Foo is new .... + ;; or package Foo is separate; + ;; or package Foo is begin null; end Foo + ;; for elaboration code (elaboration) + (if (not (looking-at "\\<\\(new\\|separate\\|begin\\)\\>")) (setq nest-count (1- nest-count))))))) ;; found task start => check if it has a body ((looking-at "task") @@ -3408,73 +3755,116 @@ ;; (setq found (zerop nest-count))))) ; end of loop - (if found - ;; - ;; match found => is there anything else to do ? - ;; - (progn - (cond - ;; - ;; found 'if' => skip to 'then', if it's on a separate line - ;; and GOTOTHEN is non-nil - ;; - ((and - gotothen - (looking-at "if") - (save-excursion - (ada-search-ignore-string-comment "then" nil nil nil - 'word-search-forward) - (back-to-indentation) - (looking-at "\\<then\\>"))) - (goto-char (match-beginning 0))) - ;; - ;; found 'do' => skip back to 'accept' - ;; - ((looking-at "do") - (unless (ada-search-ignore-string-comment "accept" t nil nil - 'word-search-backward) - (error "missing 'accept' in front of 'do'")))) - (point)) - - (if noerror - nil - (error "no matching start"))))) + (if (bobp) + (point) + (if found + ;; + ;; match found => is there anything else to do ? + ;; + (progn + (cond + ;; + ;; found 'if' => skip to 'then', if it's on a separate line + ;; and GOTOTHEN is non-nil + ;; + ((and + gotothen + (looking-at "if") + (save-excursion + (ada-search-ignore-string-comment "then" nil nil nil + 'word-search-forward) + (back-to-indentation) + (looking-at "\\<then\\>"))) + (goto-char (match-beginning 0))) + + ;; + ;; found 'do' => skip back to 'accept' + ;; + ((looking-at "do") + (unless (ada-search-ignore-string-comment + "accept" t nil nil + 'word-search-backward) + (error "missing 'accept' in front of 'do'")))) + (point)) + + (if noerror + nil + (error "no matching start")))))) (defun ada-goto-matching-end (&optional nest-level noerror) "Moves point to the end of a block. Which block depends on the value of NEST-LEVEL, which defaults to zero. If NOERROR is non-nil, it only returns nil if found no matching start." - (let ((nest-count (if nest-level nest-level 0)) - (found nil)) + (let ((nest-count (or nest-level 0)) + (regex (eval-when-compile + (concat "\\<" + (regexp-opt '("end" "loop" "select" "begin" "case" + "if" "task" "package" "record" "do" + "procedure" "function") t) + "\\>"))) + found + + ;; First is used for subprograms: they are generally handled + ;; recursively, but of course we do not want to do that the + ;; first time (see comment below about subprograms) + (first (not (looking-at "declare")))) + + ;; If we are already looking at one of the keywords, this shouldn't count + ;; in the nesting loop below, so we just make sure we don't count it. + ;; "declare" is a special case because we need to look after the "begin" + ;; keyword + (if (and (not first) (looking-at regex)) + (forward-char 1)) ;; ;; search forward for interesting keywords ;; (while (and (not found) - (ada-search-ignore-string-comment - (eval-when-compile - (concat "\\<" - (regexp-opt '("end" "loop" "select" "begin" "case" - "if" "task" "package" "record" "do") t) - "\\>")) nil)) + (ada-search-ignore-string-comment regex nil)) ;; ;; calculate nest-depth ;; (backward-word 1) (cond + ;; procedures and functions need to be processed recursively, in + ;; case they are defined in a declare/begin block, as in: + ;; declare -- NL 0 (nested level) + ;; A : Boolean; + ;; procedure B (C : D) is + ;; begin -- NL 1 + ;; null; + ;; end B; -- NL 0, and we would exit + ;; begin + ;; end; -- we should exit here + ;; processing them recursively avoids the need for any special + ;; handling. + ;; Nothing should be done if we have only the specs or a + ;; generic instantion. + + ((and (looking-at "\\<procedure\\|function\\>")) + (if first + (forward-word 1) + (ada-search-ignore-string-comment "is\\|;") + (ada-goto-next-non-ws) + (unless (looking-at "\\<new\\>") + (ada-goto-matching-end 0 t)))) + ;; found block end => decrease nest depth ((looking-at "\\<end\\>") - (setq nest-count (1- nest-count)) - ;; skip the following keyword - (if (progn - (skip-chars-forward "end") - (ada-goto-next-non-ws) - (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>")) - (forward-word 1))) - ;; found package start => check if it really starts a block + (setq nest-count (1- nest-count) + found (<= nest-count 0)) + ;; skip the following keyword + (if (progn + (skip-chars-forward "end") + (ada-goto-next-non-ws) + (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>")) + (forward-word 1))) + + ;; found package start => check if it really starts a block, and is not + ;; in fact a generic instantiation for instance ((looking-at "\\<package\\>") (ada-search-ignore-string-comment "is" nil nil nil 'word-search-forward) @@ -3482,15 +3872,16 @@ ;; ignore and skip it if it is only a 'new' package (if (looking-at "\\<new\\>") (goto-char (match-end 0)) - (setq nest-count (1+ nest-count)))) + (setq nest-count (1+ nest-count) + found (<= nest-count 0)))) + ;; all the other block starts (t - (setq nest-count (1+ nest-count)) + (setq nest-count (1+ nest-count) + found (<= nest-count 0)) (forward-word 1))) ; end of 'cond' - ;; match is found, if nest-depth is zero - ;; - (setq found (zerop nest-count))) ; end of loop + (setq first nil)) (if found t @@ -3622,10 +4013,15 @@ ;; Make sure this is the start of a private section (ie after ;; a semicolon or just after the package declaration, but not ;; after a 'type ... is private' or 'is new ... with private' + ;; + ;; Note that a 'private' statement at the beginning of the buffer + ;; does not indicate a private section, since this is instead a + ;; 'private procedure ...' (progn (forward-comment -1000) - (or (= (char-before) ?\;) - (and (forward-word -3) - (looking-at "\\<package\\>"))))))) + (and (not (bobp)) + (or (= (char-before) ?\;) + (and (forward-word -3) + (looking-at "\\<package\\>")))))))) (defun ada-in-paramlist-p () @@ -3641,7 +4037,7 @@ ;; subprogram definition: procedure .... ( ;; Let's skip back over the first one (progn - (skip-syntax-backward " ") + (skip-chars-backward " \t\n") (if (= (char-before) ?\") (backward-char 3) (backward-word 1)) @@ -3692,7 +4088,18 @@ (if (nth 1 parse) (progn (goto-char (1+ (nth 1 parse))) - (skip-chars-forward " \t") + + ;; Skip blanks, if they are not followed by a comment + ;; See: + ;; type A is ( Value_0, + ;; Value_1); + ;; type B is ( -- comment + ;; Value_2); + + (if (or (not ada-indent-handle-comment-special) + (not (looking-at "[ \t]+--"))) + (skip-chars-forward " \t")) + (point)))))) @@ -3707,11 +4114,7 @@ (interactive) (cond ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard)) ((eq ada-tab-policy 'indent-auto) - ;; transient-mark-mode and mark-active are not defined in XEmacs - (if (or (and ada-xemacs (funcall (symbol-function 'region-active-p))) - (and (not ada-xemacs) - (symbol-value 'transient-mark-mode) - (symbol-value 'mark-active))) + (if (ada-region-selected) (ada-indent-region (region-beginning) (region-end)) (ada-indent-current))) ((eq ada-tab-policy 'always-tab) (error "not implemented")) @@ -3758,44 +4161,87 @@ ;; -- Miscellaneous ;; ------------------------------------------------------------ +;; Not needed any more for Emacs 21.2, but still needed for backward +;; compatibility +(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-gnat-style () "Clean up comments, `(' and `,' for GNAT style checking switch." (interactive) (save-excursion + + ;; The \n is required, or the line after an empty comment line is + ;; simply ignored. (goto-char (point-min)) - (while (re-search-forward "--[ \t]*\\([^-]\\)" nil t) - (replace-match "-- \\1")) + (while (re-search-forward "--[ \t]*\\([^-\n]\\)" nil t) + (replace-match "-- \\1") + (forward-line 1) + (beginning-of-line)) + (goto-char (point-min)) (while (re-search-forward "\\>(" nil t) - (replace-match " (")) + (if (not (ada-in-string-or-comment-p)) + (replace-match " ("))) + (goto-char (point-min)) + (while (re-search-forward ";--" nil t) + (forward-char -1) + (if (not (ada-in-string-or-comment-p)) + (replace-match "; --"))) (goto-char (point-min)) (while (re-search-forward "([ \t]+" nil t) - (replace-match "(")) + (if (not (ada-in-string-or-comment-p)) + (replace-match "("))) (goto-char (point-min)) (while (re-search-forward ")[ \t]+)" nil t) - (replace-match "))")) + (if (not (ada-in-string-or-comment-p)) + (replace-match "))"))) (goto-char (point-min)) (while (re-search-forward "\\>:" nil t) - (replace-match " :")) + (if (not (ada-in-string-or-comment-p)) + (replace-match " :"))) + + ;; Make sure there is a space after a ','. + ;; Always go back to the beginning of the match, since otherwise + ;; a statement like ('F','D','E') is incorrectly modified. (goto-char (point-min)) - (while (re-search-forward ",\\<" nil t) - (replace-match ", ")) - (goto-char (point-min)) - (while (re-search-forward "[ \t]*\\.\\.[ \t]*" nil t) - (replace-match " .. ")) + (while (re-search-forward ",[ \t]*\\(.\\)" nil t) + (if (not (save-excursion + (goto-char (match-beginning 0)) + (ada-in-string-or-comment-p))) + (replace-match ", \\1"))) + + ;; Operators should be surrounded by spaces. (goto-char (point-min)) - (while (re-search-forward "[ \t]*\\([-:+*/]\\)[ \t]*" nil t) - (if (not (ada-in-string-or-comment-p)) + (while (re-search-forward + "[ \t]*\\(/=\\|\\*\\*\\|:=\\|\\.\\.\\|[-:+*/]\\)[ \t]*" + nil t) + (goto-char (match-beginning 1)) + (if (or (looking-at "--") + (ada-in-string-or-comment-p)) (progn - (forward-char -1) - (cond - ((looking-at "/=") - (replace-match " /= ")) - ((looking-at ":=") - (replace-match ":= ")) - ((not (looking-at "--")) - (replace-match " \\1 "))) - (forward-char 2)))) + (forward-line 1) + (beginning-of-line)) + (cond + ((string= (match-string 1) "/=") + (replace-match " /= ")) + ((string= (match-string 1) "..") + (replace-match " .. ")) + ((string= (match-string 1) "**") + (replace-match " ** ")) + ((string= (match-string 1) ":=") + (replace-match " := ")) + (t + (replace-match " \\1 "))) + (forward-char 1))) )) @@ -3813,7 +4259,6 @@ (progn (set-syntax-table ada-mode-symbol-syntax-table) - (message "searching for block start ...") (save-excursion ;; ;; do nothing if in string or comment or not on 'end ...;' @@ -3842,8 +4287,7 @@ ) ; end of save-excursion ;; now really move to the found position - (goto-char pos) - (message "searching for block start ... done")) + (goto-char pos)) ;; restore syntax-table (set-syntax-table previous-syntax-table)))) @@ -3853,27 +4297,34 @@ Moves to 'begin' if in a declarative part." (interactive) (let ((pos (point)) + decl-start (previous-syntax-table (syntax-table))) (unwind-protect (progn (set-syntax-table ada-mode-symbol-syntax-table) - (message "searching for block end ...") (save-excursion - (forward-char 1) (cond ;; directly on 'begin' - ((save-excursion - (ada-goto-previous-word) - (looking-at "\\<begin\\>")) - (ada-goto-matching-end 1)) - ;; on first line of defun declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<function\\>\\|\\<procedure\\>" ))) - (ada-search-ignore-string-comment "begin" nil nil nil - 'word-search-forward)) + ((save-excursion + (ada-goto-previous-word) + (looking-at "\\<begin\\>")) + (ada-goto-matching-end 1)) + + ;; on first line of subprogram body + ;; Do nothing for specs or generic instantion, since these are + ;; handled as the general case (find the enclosing block) + ;; We also need to make sure that we ignore nested subprograms + ((save-excursion + (and (skip-syntax-backward "w") + (looking-at "\\<function\\>\\|\\<procedure\\>" ) + (ada-search-ignore-string-comment "is\\|;") + (not (= (char-before) ?\;)) + )) + (skip-syntax-backward "w") + (ada-goto-matching-end 0 t)) + ;; on first line of task declaration ((save-excursion (and (ada-goto-stmt-start) @@ -3890,14 +4341,15 @@ (ada-goto-matching-end 0)) ;; package start ((save-excursion - (and (ada-goto-matching-decl-start t) - (looking-at "\\<package\\>"))) + (setq decl-start (and (ada-goto-matching-decl-start t) (point))) + (and decl-start (looking-at "\\<package\\>"))) (ada-goto-matching-end 1)) + ;; inside a 'begin' ... 'end' block - ((save-excursion - (ada-goto-matching-decl-start t)) - (ada-search-ignore-string-comment "begin" nil nil nil - 'word-search-forward)) + (decl-start + (goto-char decl-start) + (ada-goto-matching-end 0 t)) + ;; (hopefully ;-) everything else (t (ada-goto-matching-end 1))) @@ -3905,8 +4357,7 @@ ) ;; now really move to the position found - (goto-char pos) - (message "searching for block end ... done")) + (goto-char pos)) ;; restore syntax-table (set-syntax-table previous-syntax-table)))) @@ -3916,7 +4367,7 @@ (interactive) (end-of-line) (if (re-search-forward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 1)) + (goto-char (match-beginning 2)) (error "No more functions/procedures/tasks"))) (defun ada-previous-procedure () @@ -3924,7 +4375,7 @@ (interactive) (beginning-of-line) (if (re-search-backward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 1)) + (goto-char (match-beginning 2)) (error "No more functions/procedures/tasks"))) (defun ada-next-package () @@ -3957,7 +4408,9 @@ (define-key ada-mode-map "\t" 'ada-tab) (define-key ada-mode-map "\C-c\t" 'ada-justified-indent-current) (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region) - (define-key ada-mode-map [(shift tab)] 'ada-untab) + (if ada-xemacs + (define-key ada-mode-map '(shift tab) 'ada-untab) + (define-key ada-mode-map [(shift tab)] 'ada-untab)) (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) ;; We don't want to make meta-characters case-specific. @@ -3975,6 +4428,7 @@ (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer) (define-key ada-mode-map "\C-c\C-t" 'ada-case-read-exceptions) (define-key ada-mode-map "\C-c\C-y" 'ada-create-case-exception) + (define-key ada-mode-map "\C-c\C-\M-y" 'ada-create-case-exception-substring) ;; On XEmacs, you can easily specify whether DEL should deletes ;; one character forward or one character backward. Take this into @@ -4030,8 +4484,10 @@ ["Fill Comment Paragraph Postfix" ada-fill-comment-paragraph-postfix t] ["---" nil nil] ["Adjust Case Selection" ada-adjust-case-region t] - ["Adjust Case Buffer" ada-adjust-case-buffer t] + ["Adjust Case in File" ada-adjust-case-buffer t] ["Create Case Exception" ada-create-case-exception t] + ["Create Case Exception Substring" + ada-create-case-exception-substring t] ["Reload Case Exceptions" ada-case-read-exceptions t] ["----" nil nil] ["Make body for subprogram" ada-make-subprogram-body t])) @@ -4040,7 +4496,7 @@ ;; Option menu present only if in Ada mode (setq m (append m (list (append '("Options" - :included (eq major-mode 'ada-mode)) + :included '(eq major-mode 'ada-mode)) option)))) ;; Customize menu always present @@ -4060,7 +4516,7 @@ (when ada-xemacs ;; This looks bogus to me! -stef (define-key ada-mode-map [menu-bar] ada-mode-menu) - (setq mode-popup-menu (cons "Ada mode" ada-mode-menu))))) + (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu))))) ;; ------------------------------------------------------- @@ -4076,7 +4532,8 @@ (defadvice comment-region (before ada-uncomment-anywhere) (if (and arg - (< arg 0) + (listp arg) ;; a prefix with \C-u is of the form '(4), whereas + ;; \C-u 2 sets arg to '2' (fixed by S.Leake) (string= mode-name "Ada")) (save-excursion (let ((cs (concat "^[ \t]*" (regexp-quote comment-start)))) @@ -4094,9 +4551,9 @@ (if (or (<= emacs-major-version 20) (boundp 'running-xemacs)) (progn (ad-activate 'comment-region) - (comment-region beg end (- (or arg 1))) + (comment-region beg end (- (or arg 2))) (ad-deactivate 'comment-region)) - (comment-region beg end (list (- (or arg 1)))))) + (comment-region beg end (list (- (or arg 2)))))) (defun ada-fill-comment-paragraph-justify () "Fills current comment paragraph and justifies each line as well." @@ -4141,7 +4598,7 @@ ;; If we were at the last line in the buffer, create a dummy empty ;; line at the end of the buffer. - (if (eolp) + (if (eobp) (insert "\n") (back-to-indentation))) (beginning-of-line) @@ -4149,13 +4606,16 @@ (goto-char opos) ;; Find beginning of paragraph + (back-to-indentation) + (while (and (not (bobp)) (looking-at "--[ \t]*[^ \t\n]")) + (forward-line -1) + (back-to-indentation)) + + ;; We want one line to above the first one, unless we are at the beginning + ;; of the buffer + (unless (bobp) + (forward-line 1)) (beginning-of-line) - (while (and (not (bobp)) (looking-at "[ \t]*--[ \t]*[^ \t\n]")) - (forward-line -1)) - ;; If we found a paragraph-separating line, - ;; don't actually include it in the paragraph. - (unless (looking-at "[ \t]*--[ \t]*[^ \t\n]") - (forward-line 1)) (setq from (point-marker)) ;; Calculate the indentation we will need for the paragraph @@ -4276,8 +4736,20 @@ (setq is-spec name) (while suffixes - (if (file-exists-p (concat name (car suffixes))) - (setq is-spec (concat name (car suffixes)))) + + ;; If we are using project file, search for the other file in all + ;; the possible src directories. + + (if (functionp 'ada-find-src-file-in-dir) + (let ((other + (ada-find-src-file-in-dir + (file-name-nondirectory (concat name (car suffixes)))))) + (if other + (set 'is-spec other))) + + ;; Else search in the current directory + (if (file-exists-p (concat name (car suffixes))) + (setq is-spec (concat name (car suffixes))))) (setq suffixes (cdr suffixes))) is-spec))) @@ -4306,14 +4778,12 @@ "Returns the name of the function whose body the point is in. This function works even in the case of nested subprograms, whereas the standard Emacs function which-function does not. -Note that this function expects subprogram bodies to be terminated by -'end <name>;', not 'end;'. Since the search can be long, the results are cached." (let ((line (count-lines (point-min) (point))) (pos (point)) end-pos - func-name + func-name indent found) ;; If this is the same line as before, simply return the same result @@ -4323,28 +4793,46 @@ (save-excursion ;; In case the current line is also the beginning of the body (end-of-line) - (while (and (ada-in-paramlist-p) - (= (forward-line 1) 0)) - (end-of-line)) - + + ;; Are we looking at "function Foo\n (paramlist)" + (skip-chars-forward " \t\n(") + + (condition-case nil + (up-list) + (error nil)) + + (skip-chars-forward " \t\n") + (if (looking-at "return") + (progn + (forward-word 1) + (skip-chars-forward " \t\n") + (skip-chars-forward "a-zA-Z0-9_'"))) + ;; Can't simply do forward-word, in case the "is" is not on the ;; same line as the closing parenthesis (skip-chars-forward "is \t\n") ;; No look for the closest subprogram body that has not ended yet. - ;; Not that we expect all the bodies to be finished by "end <name", - ;; not simply "end" + ;; Not that we expect all the bodies to be finished by "end <name>", + ;; or a simple "end;" indented in the same column as the start of + ;; the subprogram. The goal is to be as efficient as possible. (while (and (not found) (re-search-backward ada-imenu-subprogram-menu-re nil t)) - (setq func-name (match-string 2)) + + ;; Get the function name, but not the properties, or this changes + ;; the face in the modeline on Emacs 21 + (setq func-name (match-string-no-properties 2)) (if (and (not (ada-in-comment-p)) (not (save-excursion (goto-char (match-end 0)) (looking-at "[ \t\n]*new")))) (save-excursion + (back-to-indentation) + (setq indent (current-column)) (if (ada-search-ignore-string-comment - (concat "end[ \t]+" func-name "[ \t]*;")) + (concat "end[ \t]+" func-name "[ \t]*;\\|^" + (make-string indent ? ) "end;")) (setq end-pos (point)) (setq end-pos (point-max))) (if (>= end-pos pos) @@ -4378,6 +4866,18 @@ (unless spec-name (setq spec-name (buffer-file-name))) + ;; Remove the spec extension. We can not simply remove the file extension, + ;; but we need to take into account the specific non-GNAT extensions that the + ;; user might have specified. + + (let ((suffixes ada-spec-suffixes) + end) + (while suffixes + (setq end (- (length spec-name) (length (car suffixes)))) + (if (string-equal (car suffixes) (substring spec-name end)) + (setq spec-name (substring spec-name 0 end))) + (setq suffixes (cdr suffixes)))) + ;; If find-file.el was available, use its functions (if (functionp 'ff-get-file) (ff-get-file-name ada-search-directories @@ -4411,7 +4911,7 @@ ;; a string ;; This sets the properties of the characters, so that ada-in-string-p ;; correctly handles '"' too... - '(("\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?'))) + '(("[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?'))) ("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n))) )) @@ -4449,7 +4949,7 @@ ;; ;; Optional keywords followed by a type name. (list (concat ; ":[ \t]*" - "\\<\\(access[ \t]+all\\|access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>" + "\\<\\(access[ \t]+all\\|access[ \t]+constant\\|access\\|constant\\|in[ \t]+reverse\\|\\|in[ \t]+out\\|in\\|out\\)\\>" "[ \t]*" "\\(\\sw+\\(\\.\\sw*\\)*\\)?") '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) @@ -4482,12 +4982,21 @@ font-lock-type-face) nil t)) ;; ;; Keywords followed by a (comma separated list of) reference. - (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed - "[ \t\n]*\\(\\(\\sw\\|[_.|, \t\n]\\)+\\)\\W") + ;; Note that font-lock only works on single lines, thus we can not + ;; correctly highlight a with_clause that spans multiple lines. + (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)" + "[ \t]+\\([a-zA-Z0-9_., \t]+\\)\\W") '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) ;; ;; Goto tags. '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face) + + ;; Highlight based-numbers (R. Reagan <robin-reply@reagans.org>) + (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t)) + + ;; Ada unnamed numerical constants + (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face)) + )) "Default expressions to highlight in Ada mode.")