X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f0529b5b1aeb64a7df9765781948a5edbfc80b1e..199143f1fbc4f791ba20405ed1767e1cac099066:/lisp/progmodes/ada-mode.el diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el index 7707e50ea3..f7688e2406 100644 --- a/lisp/progmodes/ada-mode.el +++ b/lisp/progmodes/ada-mode.el @@ -1,13 +1,13 @@ ;;; ada-mode.el --- major-mode for editing Ada sources -;; Copyright (C) 1994, 95, 97, 98, 99, 2000, 2001 +;; Copyright (C) 1994, 95, 97, 98, 99, 2000, 2001, 2002, 03, 2004 ;; Free Software Foundation, Inc. ;; Author: Rolf Ebert ;; Markus Heritsch ;; Emmanuel Briot ;; Maintainer: Emmanuel Briot -;; Ada Core Technologies's version: $Revision: 1.46 $ +;; Ada Core Technologies's version: Revision: 1.188 ;; Keywords: languages ada ;; This file is part of GNU Emacs. @@ -30,7 +30,7 @@ ;;; Commentary: ;;; This mode is a major mode for editing Ada83 and Ada95 source code. ;;; This is a major rewrite of the file packaged with Emacs-20. The -;;; ada-mode is composed of four lisp file, ada-mode.el, ada-xref.el, +;;; ada-mode is composed of four lisp files, ada-mode.el, ada-xref.el, ;;; ada-prj.el and ada-stmt.el. Only this file (ada-mode.el) is ;;; completely independent from the GNU Ada compiler Gnat, distributed ;;; by Ada Core Technologies. All the other files rely heavily on @@ -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,34 @@ ;;; 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. + +(eval-when-compile + (require 'ispell nil t) + (require 'find-file nil t) + (require 'align nil t) + (require 'which-func nil t) + (require 'compile nil t)) ;; this function is needed at compile time (eval-and-compile @@ -118,26 +147,14 @@ If IS-XEMACS is non-nil, check for XEmacs instead of Emacs." (>= emacs-minor-version minor))))))) -;; We create a constant for that, for efficiency only -;; This should be evaluated both at compile time, only a runtime -(eval-and-compile - (defconst ada-xemacs (and (boundp 'running-xemacs) - (symbol-value 'running-xemacs)) - "Return t if we are using XEmacs.")) - -(unless ada-xemacs - (require 'outline)) - -(eval-and-compile - (condition-case nil (require 'find-file) (error nil))) - ;; 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) +;; official Emacs, since it does nothing useful for the latest version +;;(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. -This hook is automatically executed after the ada-mode is +This hook is automatically executed after the `ada-mode' is fully loaded. This is a good place to add Ada environment specific bindings.") @@ -168,6 +185,15 @@ An example is : >>>>>>>>>Value); -- from ada-broken-indent" :type 'integer :group 'ada) +(defcustom ada-continuation-indent ada-broken-indent + "*Number of columns to indent the continuation of broken lines in +parenthesis. + +An example is : + Func (Param1, + >>>>>Param2);" + :type 'integer :group 'ada) + (defcustom ada-case-attribute 'ada-capitalize-word "*Function to call to adjust the case of Ada attributes. It may be `downcase-word', `upcase-word', `ada-loose-case-word', @@ -179,13 +205,17 @@ It may be `downcase-word', `upcase-word', `ada-loose-case-word', (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 +274,29 @@ For instance: 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) @@ -298,7 +351,9 @@ with `ada-fill-comment-paragraph-postfix'." An example is: procedure Foo is begin ->>>>>>>>>>>>Label: -- from ada-label-indent" +>>>>>>>>>>>>Label: -- from ada-label-indent + +This is also used for <<..>> labels" :type 'integer :group 'ada) (defcustom ada-language-version 'ada95 @@ -317,18 +372,25 @@ If nil, no contextual menu is available." :group 'ada) (defcustom ada-search-directories - '("." "$ADA_INCLUDE_PATH" "/usr/adainclude" "/usr/local/adainclude" - "/opt/gnu/adainclude") + (append '(".") + (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":") + '("/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. -Emacs will automatically add the paths defined in your project file, and if you -are using the GNAT compiler the output of the gnatls command to find where the -runtime really is." +See the description for the `ff-search-directories' variable. This variable +is the initial value of this variable, and is copied and modified in +`ada-search-directories-internal'." :type '(repeat (choice :tag "Directory" (const :tag "default" nil) (directory :format "%v"))) :group 'ada) +(defvar ada-search-directories-internal ada-search-directories + "Internal version of `ada-search-directories'. +Its value is the concatenation of the search path as read in the project file +and the standard runtime location, and the value of the user-defined +ada-search-directories.") + (defcustom ada-stmt-end-indent 0 "*Number of columns to indent the end of a statement on a separate line. @@ -429,6 +491,12 @@ This variable is used to define `ada-83-keywords' and `ada-95-keywords'")) (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 +504,56 @@ This variable is used to define `ada-83-keywords' and `ada-95-keywords'")) "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 +577,20 @@ See `ff-other-file-alist'.") "\\(\\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 @@ -538,65 +668,37 @@ To get the original region, restore the point to this position before calling `region-end' and `region-beginning'. Modify this variable if you want to restore the point to another position.") -(defvar ada-contextual-menu - (if ada-xemacs - '("Ada" - ["Goto Declaration/Body" - (ada-call-from-contextual-menu 'ada-point-and-xref) - :included (and (functionp 'ada-point-and-xref) - ada-contextual-menu-on-identifier)] - ["Goto Previous Reference" - (ada-call-from-contextual-menu 'ada-xref-goto-previous-reference) - :included (functionp 'ada-xref-goto-previous-reference)] - ["List References" ada-find-references - :included ada-contextual-menu-on-identifier] - ["-" nil nil] - ["Other File" ff-find-other-file] - ["Goto Parent Unit" ada-goto-parent] - ) - - (let ((map (make-sparse-keymap "Ada"))) - ;; The identifier part - (if (equal ada-which-compiler 'gnat) - (progn - (define-key-after map [Ref] - '(menu-item "Goto Declaration/Body" - (lambda()(interactive) - (ada-call-from-contextual-menu - 'ada-point-and-xref)) - :visible - (and (functionp 'ada-point-and-xref) - ada-contextual-menu-on-identifier)) - t) - (define-key-after map [Prev] - '(menu-item "Goto Previous Reference" - (lambda()(interactive) - (ada-call-from-contextual-menu - 'ada-xref-goto-previous-reference)) - :visible - (functionp 'ada-xref-goto-previous-reference)) - t) - (define-key-after map [List] - '(menu-item "List References" - ada-find-references - :visible ada-contextual-menu-on-identifier) t) - (define-key-after map [-] '("-" nil) t) - )) - (define-key-after map [Other] '("Other file" . ff-find-other-file) t) - (define-key-after map [Parent] '("Goto Parent Unit" . ada-goto-parent)t) - map)) - "Defines the menu to use when the user presses the right mouse button. +(easy-menu-define ada-contextual-menu nil + "Menu to use when the user presses the right mouse button. The variable `ada-contextual-menu-on-identifier' will be set to t before displaying the menu if point was on an identifier." - ) + '("Ada" + ["Goto Declaration/Body" ada-point-and-xref + :included ada-contextual-menu-on-identifier] + ["Goto Body" ada-point-and-xref-body + :included ada-contextual-menu-on-identifier] + ["Goto Previous Reference" ada-xref-goto-previous-reference] + ["List References" ada-find-references + :included ada-contextual-menu-on-identifier] + ["List Local References" ada-find-local-references + :included ada-contextual-menu-on-identifier] + ["-" nil nil] + ["Other File" ff-find-other-file] + ["Goto Parent Unit" ada-goto-parent])) ;;------------------------------------------------------------------ ;; 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 +707,18 @@ displaying the menu if point was on an identifier." (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.") ;;------------------------------------------------------------ @@ -646,15 +749,26 @@ both file locations can be clicked on and jumped to." (looking-at "\\([-_.a-zA-Z0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?")) (let ((line (match-string 2)) + file (error-pos (point-marker)) source) (save-excursion (save-restriction (widen) ;; Use funcall so as to prevent byte-compiler warnings - (set-buffer (funcall (symbol-function 'compilation-find-file) - (point-marker) (match-string 1) - "./")) + ;; `ada-find-file' is not defined if ada-xref wasn't loaded. But + ;; if we can find it, we should use it instead of + ;; `compilation-find-file', since the latter doesn't know anything + ;; about source path. + + (if (functionp 'ada-find-file) + (setq file (funcall (symbol-function 'ada-find-file) + (match-string 1))) + (setq file (funcall (symbol-function 'compilation-find-file) + (point-marker) (match-string 1) + "./"))) + (set-buffer file) + (if (stringp line) (goto-line (string-to-number line))) (setq source (point-marker)))) @@ -737,7 +851,7 @@ declares it as a word constituent." ;; See the comment above on grammar related function for the special ;; setup for '#'. - (if ada-xemacs + (if (featurep 'xemacs) (modify-syntax-entry ?# "<" ada-mode-syntax-table) (modify-syntax-entry ?# "$" ada-mode-syntax-table)) @@ -759,7 +873,7 @@ declares it as a word constituent." ;; Support of special characters in XEmacs (see the comments at the beginning ;; of the section on Grammar related functions). -(if ada-xemacs +(if (featurep 'xemacs) (defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants) "Handles special character constants and gnatprep statements." (let (change) @@ -814,7 +928,6 @@ as numbers instead of gnatprep comments." ;; Setting this only if font-lock is not set won't work ;; if the user activates or deactivates font-lock-mode, ;; but will make things faster most of the time - (make-local-hook 'after-change-functions) (add-hook 'after-change-functions 'ada-after-change-function nil t) ))) @@ -833,8 +946,7 @@ OLD-LEN indicates what the length of the replaced text was." (beginning-of-line) (if (looking-at "^[ \t]*#") (add-text-properties (match-beginning 0) (match-end 0) - '(syntax-table (11 . 10)))) - )))) + '(syntax-table (11 . 10)))))))) ;;------------------------------------------------------------------ ;; Testing the grammatical context @@ -844,20 +956,20 @@ OLD-LEN indicates what the length of the replaced text was." "Returns t if inside a comment." (nth 4 (or parse-result (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) (point))))) + (line-beginning-position) (point))))) (defsubst ada-in-string-p (&optional parse-result) "Returns t if point is inside a string. If parse-result is non-nil, use is instead of calling parse-partial-sexp." (nth 3 (or parse-result (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) (point))))) + (line-beginning-position) (point))))) (defsubst ada-in-string-or-comment-p (&optional parse-result) "Returns t if inside a comment or string." (setq parse-result (or parse-result (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) (point)))) + (line-beginning-position) (point)))) (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result))) @@ -902,13 +1014,13 @@ where the mouse button was clicked." (save-excursion (skip-syntax-forward "w") (not (ada-after-keyword-p))) )) - (let (choice) - (if ada-xemacs - (setq choice (funcall (symbol-function 'popup-menu) - ada-contextual-menu)) - (setq choice (x-popup-menu position ada-contextual-menu))) - (if choice - (funcall (lookup-key ada-contextual-menu (vector (car choice)))))) + (if (fboundp 'popup-menu) + (funcall (symbol-function 'popup-menu) ada-contextual-menu) + (let (choice) + (setq choice (x-popup-menu position ada-contextual-menu)) + (if choice + (funcall (lookup-key ada-contextual-menu (vector (car choice))))))) + (set-buffer (cadr ada-contextual-menu-last-point)) (goto-char (car ada-contextual-menu-last-point)) )) @@ -947,9 +1059,8 @@ name" ;; Support for speedbar (Specifies that we want to see these files in ;; speedbar) - (condition-case nil + (if (fboundp 'speedbar-add-supported-extension) (progn - (require 'speedbar) (funcall (symbol-function 'speedbar-add-supported-extension) spec) (funcall (symbol-function 'speedbar-add-supported-extension) @@ -962,6 +1073,7 @@ name" "Ada mode is the major mode for editing Ada code. 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]' @@ -1006,11 +1118,6 @@ If you use ada-xref.el: (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]*$") @@ -1040,12 +1147,18 @@ If you use ada-xref.el: ;; 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) + (unless (featurep '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) + )) - (setq case-fold-search t) - (setq imenu-case-fold-search 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) @@ -1066,22 +1179,32 @@ If you use ada-xref.el: (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 (featurep '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) 'ada-other-file-alist) (set (make-local-variable 'ff-search-directories) - 'ada-search-directories) - (setq ff-post-load-hooks 'ada-set-point-accordingly - ff-file-created-hooks 'ada-make-body) - (add-hook 'ff-pre-load-hooks 'ada-which-function-are-we-in) + 'ada-search-directories-internal) + (setq ff-post-load-hook 'ada-set-point-accordingly + ff-file-created-hook 'ada-make-body) + (add-hook 'ff-pre-load-hook 'ada-which-function-are-we-in) ;; Some special constructs for find-file.el ;; We do not need to add the construction for 'with', which is in the @@ -1095,21 +1218,26 @@ If you use ada-xref.el: "\\(body[ \t]+\\)?" "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is")) (lambda () - (setq fname (ff-get-file - ada-search-directories - (ada-make-filename-from-adaname - (match-string 3)) - ada-spec-suffixes))))) + (if (fboundp 'ff-get-file) + (if (boundp 'fname) + (set 'fname (ff-get-file + ada-search-directories-internal + (ada-make-filename-from-adaname + (match-string 3)) + ada-spec-suffixes))))))) ;; Another special construct for find-file.el : when in a separate clause, ;; go to the correct package. (add-to-list 'ff-special-constructs (cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))" (lambda () - (setq fname (ff-get-file - ada-search-directories - (ada-make-filename-from-adaname - (match-string 1)) - ada-spec-suffixes))))) + (if (fboundp 'ff-get-file) + (if (boundp 'fname) + (setq fname (ff-get-file + ada-search-directories-internal + (ada-make-filename-from-adaname + (match-string 1)) + ada-spec-suffixes))))))) + ;; Another special construct, that redefines the one in find-file.el. The ;; old one can handle only one possible type of extension for Ada files ;; remove from the list the standard "with..." that is put by find-file.el, @@ -1120,11 +1248,13 @@ If you use ada-xref.el: (assoc "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" ff-special-constructs)) (new-cdr (lambda () - (setq fname (ff-get-file - ada-search-directories - (ada-make-filename-from-adaname - (match-string 1)) - ada-spec-suffixes))))) + (if (fboundp 'ff-get-file) + (if (boundp 'fname) + (set 'fname (ff-get-file + ada-search-directories-internal + (ada-make-filename-from-adaname + (match-string 1)) + ada-spec-suffixes))))))) (if old-construct (setcdr old-construct new-cdr) (add-to-list 'ff-special-constructs @@ -1139,8 +1269,62 @@ If you use ada-xref.el: ;; Support for imenu : We want a sorted index (setq imenu-sort-function 'imenu--sort-by-name) - ;; Support for which-function-mode is provided in ada-support (support - ;; for nested subprograms) + ;; 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 (make-variable-buffer-local 'align-region-separate) + ada-align-region-separate) + + ;; Exclude comments alone on line from alignment. + (add-to-list 'align-exclude-rules-list + '(ada-solo-comment + (regexp . "^\\(\\s-*\\)--") + (modes . '(ada-mode)))) + (add-to-list 'align-exclude-rules-list + '(ada-solo-use + (regexp . "^\\(\\s-*\\)\\") + (modes . '(ada-mode)))) + + (setq ada-align-modes nil) + + (add-to-list 'ada-align-modes + '(ada-declaration-assign + (regexp . "[^:]\\(\\s-*\\):[^:]") + (valid . (lambda() (not (ada-in-comment-p)))) + (repeat . t) + (modes . '(ada-mode)))) + (add-to-list 'ada-align-modes + '(ada-associate + (regexp . "[^=]\\(\\s-*\\)=>") + (valid . (lambda() (not (ada-in-comment-p)))) + (modes . '(ada-mode)))) + (add-to-list 'ada-align-modes + '(ada-comment + (regexp . "\\(\\s-*\\)--") + (modes . '(ada-mode)))) + (add-to-list 'ada-align-modes + '(ada-use + (regexp . "\\(\\s-*\\)\\") + (modes . '(ada-mode)))) + + + (setq align-mode-rules-list ada-align-modes) + )) ;; Set up the contextual menu (if ada-popup-key @@ -1150,11 +1334,21 @@ If you use ada-xref.el: (define-abbrev-table 'ada-mode-abbrev-table ()) (setq local-abbrev-table ada-mode-abbrev-table) + ;; Support for which-function mode + ;; which-function-mode does not work with nested subprograms, since it is + ;; based only on the regexps generated by imenu, and thus can only detect the + ;; beginning of subprograms, not the end. + ;; Fix is: redefine a new function ada-which-function, and call it when the + ;; major-mode is ada-mode. + + (make-local-variable 'which-func-functions) + (setq which-func-functions '(ada-which-function)) + ;; 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) @@ -1165,20 +1359,27 @@ If you use ada-xref.el: (if ada-clean-buffer-before-saving (progn ;; remove all spaces at the end of lines in the whole buffer. - (add-hook 'local-write-file-hooks 'delete-trailing-whitespace) + (add-hook 'local-write-file-hooks 'delete-trailing-whitespace) ;; convert all tabs to the correct number of spaces. (add-hook 'local-write-file-hooks (lambda () (untabify (point-min) (point-max)))))) (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) - (make-local-hook 'font-lock-mode-hook) - (add-hook 'font-lock-mode-hook 'ada-deactivate-properties nil t)) + (unless (featurep 'xemacs) + (progn + (ada-initialize-properties) + (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 @@ -1192,6 +1393,15 @@ If you use ada-xref.el: (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 (featurep 'xemacs) (funcall (symbol-function 'region-active-p))) + (and (not (featurep 'xemacs)) + (symbol-value 'transient-mark-mode) + (symbol-value 'mark-active)))) + ;;----------------------------------------------------------------- ;; auto-casing @@ -1207,6 +1417,23 @@ If you use ada-xref.el: ;; 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. @@ -1214,7 +1441,6 @@ The new words is added to the first file in `ada-case-exception-file'. The standard casing rules will no longer apply to this word." (interactive) (let ((previous-syntax-table (syntax-table)) - (exception-list '()) file-name ) @@ -1223,7 +1449,8 @@ The standard casing rules will no longer apply to this word." ((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 @@ -1231,55 +1458,76 @@ The standard casing rules will no longer apply to this word." (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) + (assoc-string word ada-case-exception t)) + (setcar (assoc-string word ada-case-exception t) 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-string word ada-case-exception-substring t)) + (setcar (assoc-string word ada-case-exception-substring t) 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)) @@ -1295,8 +1543,15 @@ The standard casing rules will no longer apply to this word." ;; 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-string word ada-case-exception-substring t) + (add-to-list 'ada-case-exception-substring (cons word t)))) + (unless (assoc-string word ada-case-exception t) + (add-to-list 'ada-case-exception (cons word t))))) (forward-line 1)) (kill-buffer nil) @@ -1308,7 +1563,8 @@ The standard casing rules will no longer apply to this word." (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)) @@ -1317,6 +1573,34 @@ The standard casing rules will no longer apply to this word." (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) t))) + (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 @@ -1324,7 +1608,9 @@ the exceptions defined in `ada-case-exception-file'." (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)) @@ -1332,15 +1618,16 @@ the exceptions defined in `ada-case-exception-file'." (point))) match) ;; If we have an exception, replace the word by the correct casing - (if (setq match (assoc-ignore-case (buffer-substring start end) - ada-case-exception)) + (if (setq match (assoc-string (buffer-substring start end) + ada-case-exception t)) (progn (delete-region start end) (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." @@ -1354,28 +1641,31 @@ the exceptions defined in `ada-case-exception-file'." (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) @@ -1882,20 +2172,23 @@ This function is intended to be bound to the \C-m and \C-j keys." (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 1 (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)))) @@ -1938,7 +2231,7 @@ offset." ;; This need to be done here so that the advice is not always ;; activated (this might interact badly with other modes) - (if ada-xemacs + (if (featurep 'xemacs) (ad-activate 'parse-partial-sexp t)) (save-excursion @@ -1985,7 +2278,7 @@ offset." ;; restore syntax-table (set-syntax-table previous-syntax-table) - (if ada-xemacs + (if (featurep 'xemacs) (ad-deactivate 'parse-partial-sexp)) ) @@ -2018,13 +2311,40 @@ offset." ;; 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) + + ;; We want all continuation lines to be indented the same + ;; (ada-broken-line from the opening parenthesis. However, in + ;; parameter list, each new parameter should be indented at the + ;; column as the opening parenthesis. + + ;; A special case to handle nested boolean expressions, as in + ;; ((B + ;; and then C) -- indented by ada-broken-indent + ;; or else D) -- indenting this line. + ;; ??? This is really a hack, we should have a proper way to go to + ;; ??? the beginning of the statement + + (if (= (char-before) ?\)) + (backward-sexp)) + + (if (memq (char-before) '(?, ?\; ?\( ?\))) + (list column 0) + (list column 'ada-continuation-indent) + ))))) ;;--------------------------- ;; at end of buffer @@ -2037,7 +2357,7 @@ offset." ;; starting with e ;;--------------------------- - ((= (char-after) ?e) + ((= (downcase (char-after)) ?e) (cond ;; ------- end ------ @@ -2071,7 +2391,24 @@ offset." (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 "\\" t))) + 0)) + + ;; Else keep the same indentation as the beginning statement + (list (+ (save-excursion (back-to-indentation) (point)) label) 0))))) ;; ------ exception ---- @@ -2103,7 +2440,7 @@ offset." ;; starting with w (when) ;;--------------------------- - ((and (= (char-after) ?w) + ((and (= (downcase (char-after)) ?w) (looking-at "when\\>")) (save-excursion (ada-goto-matching-start 1) @@ -2114,7 +2451,7 @@ offset." ;; 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\\>")) @@ -2130,7 +2467,7 @@ offset." ;; starting with l (loop) ;;--------------------------- - ((and (= (char-after) ?l) + ((and (= (downcase (char-after)) ?l) (looking-at "loop\\>")) (setq pos (point)) (save-excursion @@ -2145,11 +2482,29 @@ offset." (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 "\\") + (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) @@ -2160,7 +2515,7 @@ offset." ;; starting with i (is) ;;--------------------------- - ((and (= (char-after) ?i) + ((and (= (downcase (char-after)) ?i) (looking-at "is\\>")) (if (and ada-indent-is-separate @@ -2174,76 +2529,63 @@ offset." (list (progn (back-to-indentation) (point)) 'ada-indent)) (save-excursion (ada-goto-stmt-start) - (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))) + (if (looking-at "\\") + (list (progn (back-to-indentation) (point)) 0) + (list (progn (back-to-indentation) (point)) 'ada-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 "\\") - (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))) + ((and (= (downcase (char-after)) ?r) + (looking-at "re\\(turn\\|names\\)\\>")) - (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))))))) - )) + (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' @@ -2251,19 +2593,20 @@ offset." ;; '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) @@ -2331,7 +2674,7 @@ offset." ;; 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 @@ -2428,6 +2771,12 @@ if INITIAL-POS is non-nil, moves point to INITIAL-POS before calculation." ;; ((looking-at "separate\\>") (ada-get-indent-nochange)) + + ;; A label + ((looking-at "<<") + (list (+ (save-excursion (back-to-indentation) (point)) + (- ada-label-indent)))) + ;; ((looking-at "with\\>\\|use\\>") ;; Are we still in that statement, or are we in fact looking at @@ -2469,11 +2818,17 @@ if INITIAL-POS is non-nil, moves point to INITIAL-POS before calculation." (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. @@ -2528,7 +2883,9 @@ ORGPOINT is the limit position used in the calculation." (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 ? ;; @@ -2601,7 +2958,7 @@ ORGPOINT is the limit position used in the calculation." (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 @@ -2632,6 +2989,23 @@ ORGPOINT is the limit position used in the calculation." (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 "\\" t))) + 'ada-indent))) + ;; nothing follows the block-start (t (list (save-excursion (back-to-indentation) (point)) 'ada-indent))))) @@ -2846,8 +3220,12 @@ ORGPOINT is the limit position used in the calculation." "record" nil orgpoint nil 'word-search-forward)) t))) (if match-cons - (goto-char (car match-cons))) - (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) + (progn + (goto-char (car match-cons)) + (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) + (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) + ) + ;; ;; for..loop ;; @@ -3016,26 +3394,35 @@ match." (goto-char (car match-dat)) (unless (ada-in-open-paren-p) - (if (and (looking-at - "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>") - (save-excursion - (ada-goto-previous-word) - (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]"))) - (forward-word -1) - - (save-excursion - (goto-char (cdr match-dat)) - (ada-goto-next-non-ws) - (looking-at "(") - ;; words that can go after an 'is' - (unless (looking-at - (eval-when-compile - (concat "\\<" - (regexp-opt '("separate" "access" "array" - "abstract" "new") t) - "\\>\\|("))) - (setq found t)))) - )) + (cond + + ((and (looking-at + "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>") + (save-excursion + (ada-goto-previous-word) + (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]"))) + (forward-word -1)) + + ((looking-at "is") + (setq found + (and (save-excursion (ada-goto-previous-word) + (ada-goto-previous-word) + (not (looking-at "subtype"))) + + (save-excursion (goto-char (cdr match-dat)) + (ada-goto-next-non-ws) + ;; words that can go after an 'is' + (not (looking-at + (eval-when-compile + (concat "\\<" + (regexp-opt + '("separate" "access" "array" + "abstract" "new") t) + "\\>\\|(")))))))) + + (t + (setq found t)) + ))) (if found match-dat @@ -3156,9 +3543,12 @@ Moves point to the beginning of the declaration." "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) + (stop-at-when nil) ) ;; Ignore "when" most of the time, except if we are looking at the @@ -3212,7 +3602,8 @@ If NOERROR is non-nil, it only returns nil if no match was found." 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") @@ -3237,7 +3628,7 @@ If NOERROR is non-nil, it only returns nil if no match was found." ;; ((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 @@ -3259,7 +3650,7 @@ If NOERROR is non-nil, it only returns nil if no match was found." (skip-chars-backward "a-zA-Z0-9_.'") (ada-goto-previous-word) (and - (looking-at "\\<\\(sub\\)?type\\>") + (looking-at "\\<\\(sub\\)?type\\|case\\>") (save-match-data (ada-goto-previous-word) (not (looking-at "\\")))) @@ -3281,9 +3672,16 @@ If NOERROR is non-nil, it only returns nil if no match was found." (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 "\\") + (progn + (if stop-at-when + (setq nest-count (1- nest-count))) + )))) + ;; + ((looking-at "begin") + (setq first nil)) ;; (t (setq nest-count (1+ nest-count)) @@ -3342,9 +3740,9 @@ If GOTOTHEN is non-nil, point moves to the 'then' following 'if'." (ada-goto-previous-word) (if (looking-at "\\[ \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)) @@ -3361,14 +3759,17 @@ If GOTOTHEN is non-nil, point moves to the 'then' following 'if'." (error (concat "No matching 'is' or 'renames' for 'package' at" " line " - (number-to-string (count-lines (point-min) - (1+ current))))))) + (number-to-string (count-lines 1 (1+ current))))))) (unless (looking-at "renames") (progn (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") @@ -3410,73 +3811,123 @@ If GOTOTHEN is non-nil, point moves to the 'then' following 'if'." ;; (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 "\\"))) - (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 "\\"))) + (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 + pos + + ;; 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 (looking-at "\\") + (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 "\\")) + (if first + (forward-word 1) + + (setq pos (point)) + (ada-search-ignore-string-comment "is\\|;") + (if (= (char-before) ?s) + (progn + (ada-goto-next-non-ws) + (unless (looking-at "\\") + (progn + (goto-char pos) + (ada-goto-matching-end 0 t))))))) + ;; found block end => decrease nest depth ((looking-at "\\") - (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 "\\") (ada-search-ignore-string-comment "is" nil nil nil 'word-search-forward) @@ -3484,15 +3935,17 @@ If NOERROR is non-nil, it only returns nil if found no matching start." ;; ignore and skip it if it is only a 'new' package (if (looking-at "\\") (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)) + (if (not first) + (setq nest-count (1+ nest-count))) + (setq 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 @@ -3543,7 +3996,7 @@ Point is moved at the beginning of the search-re." ;; If inside a string, skip it (and the following comments) ;; ((ada-in-string-p parse-result) - (if ada-xemacs + (if (featurep 'xemacs) (search-backward "\"" nil t) (goto-char (nth 8 parse-result))) (unless backward (forward-sexp 1))) @@ -3552,7 +4005,7 @@ Point is moved at the beginning of the search-re." ;; There is a special code for comments at the end of the file ;; ((ada-in-comment-p parse-result) - (if ada-xemacs + (if (featurep 'xemacs) (progn (forward-line 1) (beginning-of-line) @@ -3624,10 +4077,15 @@ Returns nil if the private is part of the package name, as in ;; 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 "\\"))))))) + (and (not (bobp)) + (or (= (char-before) ?\;) + (and (forward-word -3) + (looking-at "\\")))))))) (defun ada-in-paramlist-p () @@ -3643,7 +4101,7 @@ Returns nil if the private is part of the package name, as in ;; 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)) @@ -3694,7 +4152,18 @@ parenthesis, or nil." (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)))))) @@ -3709,11 +4178,7 @@ of the region. Otherwise, operates only on the current line." (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")) @@ -3760,44 +4225,87 @@ of the region. Otherwise, operates only on the current line." ;; -- 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 " :")) - (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 "[ \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))) )) @@ -3815,7 +4323,6 @@ of the region. Otherwise, operates only on the current line." (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 ...;' @@ -3844,8 +4351,7 @@ of the region. Otherwise, operates only on the current line." ) ; 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)))) @@ -3855,27 +4361,36 @@ of the region. Otherwise, operates only on the current line." 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 + ;; Go to the beginning of the current word, and check if we are ;; directly on 'begin' - ((save-excursion - (ada-goto-previous-word) - (looking-at "\\")) - (ada-goto-matching-end 1)) - ;; on first line of defun declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\\\|\\" ))) - (ada-search-ignore-string-comment "begin" nil nil nil - 'word-search-forward)) + ((save-excursion + (skip-syntax-backward "w") + (looking-at "\\")) + (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 "\\\\|\\" ) + (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) @@ -3892,14 +4407,21 @@ Moves to 'begin' if in a declarative part." (ada-goto-matching-end 0)) ;; package start ((save-excursion - (and (ada-goto-matching-decl-start t) - (looking-at "\\"))) + (setq decl-start (and (ada-goto-matching-decl-start t) (point))) + (and decl-start (looking-at "\\"))) (ada-goto-matching-end 1)) + + ;; On a "declare" keyword + ((save-excursion + (skip-syntax-backward "w") + (looking-at "\\")) + (ada-goto-matching-end 0 t)) + ;; 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))) @@ -3907,8 +4429,7 @@ Moves to 'begin' if in a declarative part." ) ;; 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)))) @@ -3918,7 +4439,7 @@ Moves to 'begin' if in a declarative part." (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 () @@ -3926,7 +4447,7 @@ Moves to 'begin' if in a declarative part." (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 () @@ -3959,7 +4480,9 @@ Moves to 'begin' if in a declarative part." (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 (featurep '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. @@ -3977,6 +4500,7 @@ Moves to 'begin' if in a declarative part." (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 @@ -3991,78 +4515,227 @@ Moves to 'begin' if in a declarative part." ;; 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) + + ;; The following keys are bound to functions defined in ada-xref.el or + ;; ada-prj,el., However, RMS rightly thinks that the code should be shared, + ;; and activated only if the right compiler is used + (if (featurep 'xemacs) + (progn + (define-key ada-mode-map '(shift button3) 'ada-point-and-xref) + (define-key ada-mode-map '(control tab) 'ada-complete-identifier)) + (define-key ada-mode-map [C-tab] 'ada-complete-identifier) + (define-key ada-mode-map [S-mouse-3] 'ada-point-and-xref)) + + (define-key ada-mode-map "\C-co" 'ff-find-other-file) + (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame) + (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration) + (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference) + (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) + (define-key ada-mode-map "\C-cc" 'ada-change-prj) + (define-key ada-mode-map "\C-cd" 'ada-set-default-project-file) + (define-key ada-mode-map "\C-cg" 'ada-gdb-application) + (define-key ada-mode-map "\C-cr" 'ada-run-application) + (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) + (define-key ada-mode-map "\C-c\C-r" 'ada-find-references) + (define-key ada-mode-map "\C-cl" 'ada-find-local-references) + (define-key ada-mode-map "\C-c\C-v" 'ada-check-current) + (define-key ada-mode-map "\C-cf" 'ada-find-file) + + (define-key ada-mode-map "\C-cu" 'ada-prj-edit) + + ;; The templates, defined in ada-stmt.el + + (let ((map (make-sparse-keymap))) + (define-key map "h" 'ada-header) + (define-key map "\C-a" 'ada-array) + (define-key map "b" 'ada-exception-block) + (define-key map "d" 'ada-declare-block) + (define-key map "c" 'ada-case) + (define-key map "\C-e" 'ada-elsif) + (define-key map "e" 'ada-else) + (define-key map "\C-k" 'ada-package-spec) + (define-key map "k" 'ada-package-body) + (define-key map "\C-p" 'ada-procedure-spec) + (define-key map "p" 'ada-subprogram-body) + (define-key map "\C-f" 'ada-function-spec) + (define-key map "f" 'ada-for-loop) + (define-key map "i" 'ada-if) + (define-key map "l" 'ada-loop) + (define-key map "\C-r" 'ada-record) + (define-key map "\C-s" 'ada-subtype) + (define-key map "S" 'ada-tabsize) + (define-key map "\C-t" 'ada-task-spec) + (define-key map "t" 'ada-task-body) + (define-key map "\C-y" 'ada-type) + (define-key map "\C-v" 'ada-private) + (define-key map "u" 'ada-use) + (define-key map "\C-u" 'ada-with) + (define-key map "\C-w" 'ada-when) + (define-key map "w" 'ada-while-loop) + (define-key map "\C-x" 'ada-exception) + (define-key map "x" 'ada-exit) + (define-key ada-mode-map "\C-ct" map)) ) (defun ada-create-menu () - "Create the ada menu as shown in the menu bar. -This function is designed to be extensible, so that each compiler-specific file -can add its own items." - ;; Note that the separators must have different length in the submenus - (autoload 'easy-menu-define "easymenu") - - (let ((m '("Ada" - ("Help" ["Ada Mode" (info "ada-mode") t]))) - (option '(["Auto Casing" (setq ada-auto-case (not ada-auto-case)) - :style toggle :selected ada-auto-case] - ["Auto Indent After Return" - (setq ada-indent-after-return (not ada-indent-after-return)) - :style toggle :selected ada-indent-after-return])) - (goto '(["Next compilation error" next-error t] - ["Previous Package" ada-previous-package t] - ["Next Package" ada-next-package t] - ["Previous Procedure" ada-previous-procedure t] - ["Next Procedure" ada-next-procedure t] - ["Goto Start Of Statement" ada-move-to-start t] - ["Goto End Of Statement" ada-move-to-end t] - ["-" nil nil] - ["Other File" ff-find-other-file t] - ["Other File Other Window" ada-ff-other-window t])) - (edit '(["Indent Line" ada-indent-current-function t] - ["Justify Current Indentation" ada-justified-indent-current t] - ["Indent Lines in Selection" ada-indent-region t] - ["Indent Lines in File" (ada-indent-region (point-min) (point-max)) t] - ["Format Parameter List" ada-format-paramlist t] - ["-" nil nil] - ["Comment Selection" comment-region t] - ["Uncomment Selection" ada-uncomment-region t] - ["--" nil nil] - ["Fill Comment Paragraph" fill-paragraph t] - ["Fill Comment Paragraph Justify" ada-fill-comment-paragraph-justify t] - ["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] - ["Create Case Exception" ada-create-case-exception t] - ["Reload Case Exceptions" ada-case-read-exceptions t] - ["----" nil nil] - ["Make body for subprogram" ada-make-subprogram-body t])) - - ) - - ;; Option menu present only if in Ada mode - (setq m (append m (list (append '("Options" - :included (eq major-mode 'ada-mode)) - option)))) - - ;; Customize menu always present - (when (fboundp 'customize-group) - (setq m (append m '(["Customize" (customize-group 'ada)])))) - - ;; Goto and Edit menus present only if in Ada mode - (setq m (append m (list (append '("Goto" - :included (eq major-mode 'ada-mode)) - goto) - (append '("Edit" - :included (eq major-mode 'ada-mode)) - edit)))) + "Create the ada menu as shown in the menu bar." + (let ((m '("Ada" + ("Help" + ["Ada Mode" (info "ada-mode") t] + ["GNAT User's Guide" (info "gnat_ugn") + (eq ada-which-compiler 'gnat)] + ["GNAT Reference Manual" (info "gnat_rm") + (eq ada-which-compiler 'gnat)] + ["Gcc Documentation" (info "gcc") + (eq ada-which-compiler 'gnat)] + ["Gdb Documentation" (info "gdb") + (eq ada-which-compiler 'gnat)] + ["Ada95 Reference Manual" (info "arm95") + (eq ada-which-compiler 'gnat)]) + ("Options" :included (eq major-mode 'ada-mode) + ["Auto Casing" (setq ada-auto-case (not ada-auto-case)) + :style toggle :selected ada-auto-case] + ["Auto Indent After Return" + (setq ada-indent-after-return (not ada-indent-after-return)) + :style toggle :selected ada-indent-after-return] + ["Automatically Recompile For Cross-references" + (setq ada-xref-create-ali (not ada-xref-create-ali)) + :style toggle :selected ada-xref-create-ali + :included (eq ada-which-compiler 'gnat)] + ["Confirm Commands" + (setq ada-xref-confirm-compile (not ada-xref-confirm-compile)) + :style toggle :selected ada-xref-confirm-compile + :included (eq ada-which-compiler 'gnat)] + ["Show Cross-references In Other Buffer" + (setq ada-xref-other-buffer (not ada-xref-other-buffer)) + :style toggle :selected ada-xref-other-buffer + :included (eq ada-which-compiler 'gnat)] + ["Tight Integration With GNU Visual Debugger" + (setq ada-tight-gvd-integration (not ada-tight-gvd-integration)) + :style toggle :selected ada-tight-gvd-integration + :included (string-match "gvd" ada-prj-default-debugger)]) + ["Customize" (customize-group 'ada) + :included (fboundp 'customize-group)] + ["Check file" ada-check-current (eq ada-which-compiler 'gnat)] + ["Compile file" ada-compile-current (eq ada-which-compiler 'gnat)] + ["Build" ada-compile-application + (eq ada-which-compiler 'gnat)] + ["Run" ada-run-application t] + ["Debug" ada-gdb-application (eq ada-which-compiler 'gnat)] + ["------" nil nil] + ("Project" + :included (eq ada-which-compiler 'gnat) + ["Load..." ada-set-default-project-file t] + ["New..." ada-prj-new t] + ["Edit..." ada-prj-edit t]) + ("Goto" :included (eq major-mode 'ada-mode) + ["Goto Declaration/Body" ada-goto-declaration + (eq ada-which-compiler 'gnat)] + ["Goto Body" ada-goto-body + (eq ada-which-compiler 'gnat)] + ["Goto Declaration Other Frame" + ada-goto-declaration-other-frame + (eq ada-which-compiler 'gnat)] + ["Goto Previous Reference" ada-xref-goto-previous-reference + (eq ada-which-compiler 'gnat)] + ["List Local References" ada-find-local-references + (eq ada-which-compiler 'gnat)] + ["List References" ada-find-references + (eq ada-which-compiler 'gnat)] + ["Goto Reference To Any Entity" ada-find-any-references + (eq ada-which-compiler 'gnat)] + ["Goto Parent Unit" ada-goto-parent + (eq ada-which-compiler 'gnat)] + ["--" nil nil] + ["Next compilation error" next-error t] + ["Previous Package" ada-previous-package t] + ["Next Package" ada-next-package t] + ["Previous Procedure" ada-previous-procedure t] + ["Next Procedure" ada-next-procedure t] + ["Goto Start Of Statement" ada-move-to-start t] + ["Goto End Of Statement" ada-move-to-end t] + ["-" nil nil] + ["Other File" ff-find-other-file t] + ["Other File Other Window" ada-ff-other-window t]) + ("Edit" :included (eq major-mode 'ada-mode) + ["Search File On Source Path" ada-find-file t] + ["------" nil nil] + ["Complete Identifier" ada-complete-identifier t] + ["-----" nil nil] + ["Indent Line" ada-indent-current-function t] + ["Justify Current Indentation" ada-justified-indent-current t] + ["Indent Lines in Selection" ada-indent-region t] + ["Indent Lines in File" + (ada-indent-region (point-min) (point-max)) t] + ["Format Parameter List" ada-format-paramlist t] + ["-" nil nil] + ["Comment Selection" comment-region t] + ["Uncomment Selection" ada-uncomment-region t] + ["--" nil nil] + ["Fill Comment Paragraph" fill-paragraph t] + ["Fill Comment Paragraph Justify" + ada-fill-comment-paragraph-justify t] + ["Fill Comment Paragraph Postfix" + ada-fill-comment-paragraph-postfix t] + ["---" nil nil] + ["Adjust Case Selection" ada-adjust-case-region 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] + ["-----" nil nil] + ["Narrow to subprogram" ada-narrow-to-defun t]) + ("Templates" + :included (eq major-mode 'ada-mode) + ["Header" ada-header t] + ["-" nil nil] + ["Package Body" ada-package-body t] + ["Package Spec" ada-package-spec t] + ["Function Spec" ada-function-spec t] + ["Procedure Spec" ada-procedure-spec t] + ["Proc/func Body" ada-subprogram-body t] + ["Task Body" ada-task-body t] + ["Task Spec" ada-task-spec t] + ["Declare Block" ada-declare-block t] + ["Exception Block" ada-exception-block t] + ["--" nil nil] + ["Entry" ada-entry t] + ["Entry family" ada-entry-family t] + ["Select" ada-select t] + ["Accept" ada-accept t] + ["Or accept" ada-or-accep t] + ["Or delay" ada-or-delay t] + ["Or terminate" ada-or-terminate t] + ["---" nil nil] + ["Type" ada-type t] + ["Private" ada-private t] + ["Subtype" ada-subtype t] + ["Record" ada-record t] + ["Array" ada-array t] + ["----" nil nil] + ["If" ada-if t] + ["Else" ada-else t] + ["Elsif" ada-elsif t] + ["Case" ada-case t] + ["-----" nil nil] + ["While Loop" ada-while-loop t] + ["For Loop" ada-for-loop t] + ["Loop" ada-loop t] + ["------" nil nil] + ["Exception" ada-exception t] + ["Exit" ada-exit t] + ["When" ada-when t]) + ))) (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode" m) - (easy-menu-add ada-mode-menu ada-mode-map) - (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))))) + (if (featurep 'xemacs) + (progn + (define-key ada-mode-map [menu-bar] ada-mode-menu) + (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) ;; ------------------------------------------------------- @@ -4076,9 +4749,10 @@ can add its own items." ;; function for justifying the comments. ;; ------------------------------------------------------- -(defadvice comment-region (before ada-uncomment-anywhere) +(defadvice comment-region (before ada-uncomment-anywhere disable) (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)))) @@ -4093,12 +4767,13 @@ can add its own items." ;; This advice is not needed anymore with Emacs21. However, for older ;; versions, as well as for XEmacs, we still need to enable it. - (if (or (<= emacs-major-version 20) (boundp 'running-xemacs)) + (if (or (<= emacs-major-version 20) (featurep '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)))) + (ada-indent-region beg end))) (defun ada-fill-comment-paragraph-justify () "Fills current comment paragraph and justifies each line as well." @@ -4124,10 +4799,8 @@ The paragraph is indented on the first line." (not (looking-at "[ \t]*--"))) (error "not inside comment")) - (let* ((indent) - (from) - (to) - (opos (point-marker)) + (let* (indent from to + (opos (point-marker)) ;; Sets this variable to nil, otherwise it prevents ;; fill-region-as-paragraph to work on Emacs <= 20.2 @@ -4138,12 +4811,12 @@ The paragraph is indented on the first line." ;; Find end of paragraph (back-to-indentation) - (while (and (not (eobp)) (looking-at "--[ \t]*[^ \t\n]")) + (while (and (not (eobp)) (looking-at ".*--[ \t]*[^ \t\n]")) (forward-line 1) ;; 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) @@ -4151,13 +4824,16 @@ The paragraph is indented on the first line." (goto-char opos) ;; Find beginning of paragraph - (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]") + (back-to-indentation) + (while (and (not (bobp)) (looking-at ".*--[ \t]*[^ \t\n]")) + (forward-line -1) + (back-to-indentation)) + + ;; We want one line above the first one, unless we are at the beginning + ;; of the buffer + (unless (bobp) (forward-line 1)) + (beginning-of-line) (setq from (point-marker)) ;; Calculate the indentation we will need for the paragraph @@ -4171,13 +4847,6 @@ The paragraph is indented on the first line." (while (re-search-forward "--\n" to t) (replace-match "\n")) - ;; Remove the old prefixes (so that the number of spaces after -- is not - ;; relevant), except on the first one since `fill-region-as-paragraph' - ;; would not put it back on the first line. - (goto-char (+ from 2)) - (while (re-search-forward "^-- *" to t) - (replace-match " ")) - (goto-char (1- to)) (setq to (point-marker)) @@ -4203,7 +4872,7 @@ The paragraph is indented on the first line." ;; In Emacs <= 20.2 and XEmacs <=20.4, there is a bug, and a newline is ;; inserted at the end. Delete it - (if (or ada-xemacs + (if (or (featurep 'xemacs) (<= emacs-major-version 19) (and (= emacs-major-version 20) (<= emacs-minor-version 2))) @@ -4278,8 +4947,20 @@ otherwise." (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 (fboundp '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))) @@ -4307,15 +4988,13 @@ Redefines the function `ff-which-function-are-we-in'." (defun ada-which-function () "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 ;', not 'end;'. +standard Emacs function `which-function' does not. Since the search can be long, the results are cached." - (let ((line (count-lines (point-min) (point))) + (let ((line (count-lines 1 (point))) (pos (point)) end-pos - func-name + func-name indent found) ;; If this is the same line as before, simply return the same result @@ -4325,28 +5004,46 @@ Since the search can be long, the results are cached." (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 1) + (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 ", + ;; 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) @@ -4380,9 +5077,21 @@ Returns nil if no body was found." (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 + (if (fboundp 'ff-get-file-name) + (ff-get-file-name ada-search-directories-internal (ada-make-filename-from-adaname (file-name-nondirectory (file-name-sans-extension spec-name))) @@ -4413,7 +5122,7 @@ Returns nil if no body was found." ;; 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))) )) @@ -4451,7 +5160,7 @@ Returns nil if no body was found." ;; ;; 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)) @@ -4467,7 +5176,7 @@ Returns nil if no body was found." "null" "or" "others" "private" "protected" "raise" "range" "record" "rem" "renames" "requeue" "return" "reverse" "select" "separate" "tagged" "task" "terminate" "then" "until" - "when" "while" "xor") t) + "when" "while" "with" "xor") t) "\\>") ;; ;; Anything following end and not already fontified is a body name. @@ -4484,12 +5193,22 @@ Returns nil if no body was found." 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 ) + (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.") @@ -4506,6 +5225,33 @@ Returns nil if no body was found." (back-to-indentation) (current-column)))) +;; --------------------------------------------------------- +;; Support for narrow-to-region +;; --------------------------------------------------------- + +(defun ada-narrow-to-defun (&optional arg) + "make text outside current subprogram invisible. +The subprogram visible is the one that contains or follow point. +Optional ARG is ignored. +Use `M-x widen' to go back to the full visibility for the buffer" + + (interactive) + (save-excursion + (let (end) + (widen) + (forward-line 1) + (ada-previous-procedure) + + (save-excursion + (beginning-of-line) + (setq end (point))) + + (ada-move-to-end) + (end-of-line) + (narrow-to-region end (point)) + (message + "Use M-x widen to get back to full visibility in the buffer")))) + ;; --------------------------------------------------------- ;; Automatic generation of code ;; The Ada-mode has a set of function to automatically generate a subprogram @@ -4640,7 +5386,7 @@ This function typically is to be hooked into `ff-file-created-hooks'." (setq body-file (ada-get-body-name)) (if body-file (find-file body-file) - (error "No body found for the package. Create it first")) + (error "No body found for the package. Create it first.")) (save-restriction (widen) @@ -4679,17 +5425,68 @@ This function typically is to be hooked into `ff-file-created-hooks'." ;; Read the special cases for exceptions (ada-case-read-exceptions) -;; include the other ada-mode files +;; Setup auto-loading of the other ada-mode files. (if (equal ada-which-compiler 'gnat) (progn - ;; The order here is important: ada-xref defines the Project - ;; submenu, and ada-prj adds to it. - (require 'ada-xref) - (condition-case nil (require 'ada-prj) (error nil)) + (autoload 'ada-change-prj "ada-xref" nil t) + (autoload 'ada-check-current "ada-xref" nil t) + (autoload 'ada-compile-application "ada-xref" nil t) + (autoload 'ada-compile-current "ada-xref" nil t) + (autoload 'ada-complete-identifier "ada-xref" nil t) + (autoload 'ada-find-file "ada-xref" nil t) + (autoload 'ada-find-any-references "ada-xref" nil t) + (autoload 'ada-find-src-file-in-dir "ada-xref" nil t) + (autoload 'ada-find-local-references "ada-xref" nil t) + (autoload 'ada-find-references "ada-xref" nil t) + (autoload 'ada-gdb-application "ada-xref" nil t) + (autoload 'ada-goto-declaration "ada-xref" nil t) + (autoload 'ada-goto-declaration-other-frame "ada-xref" nil t) + (autoload 'ada-goto-parent "ada-xref" nil t) + (autoload 'ada-make-body-gnatstub "ada-xref" nil t) + (autoload 'ada-point-and-xref "ada-xref" nil t) + (autoload 'ada-reread-prj-file "ada-xref" nil t) + (autoload 'ada-run-application "ada-xref" nil t) + (autoload 'ada-set-default-project-file "ada-xref" nil nil) + (autoload 'ada-set-default-project-file "ada-xref" nil t) + (autoload 'ada-xref-goto-previous-reference "ada-xref" nil t) + + (autoload 'ada-customize "ada-prj" nil t) + (autoload 'ada-prj-edit "ada-prj" nil t) + (autoload 'ada-prj-new "ada-prj" nil t) + (autoload 'ada-prj-save "ada-prj" nil t) )) -(condition-case nil (require 'ada-stmt) (error nil)) + +(autoload 'ada-array "ada-stmt" nil t) +(autoload 'ada-case "ada-stmt" nil t) +(autoload 'ada-declare-block "ada-stmt" nil t) +(autoload 'ada-else "ada-stmt" nil t) +(autoload 'ada-elsif "ada-stmt" nil t) +(autoload 'ada-exception "ada-stmt" nil t) +(autoload 'ada-exception-block "ada-stmt" nil t) +(autoload 'ada-exit "ada-stmt" nil t) +(autoload 'ada-for-loop "ada-stmt" nil t) +(autoload 'ada-function-spec "ada-stmt" nil t) +(autoload 'ada-header "ada-stmt" nil t) +(autoload 'ada-if "ada-stmt" nil t) +(autoload 'ada-loop "ada-stmt" nil t) +(autoload 'ada-package-body "ada-stmt" nil t) +(autoload 'ada-package-spec "ada-stmt" nil t) +(autoload 'ada-private "ada-stmt" nil t) +(autoload 'ada-procedure-spec "ada-stmt" nil t) +(autoload 'ada-record "ada-stmt" nil t) +(autoload 'ada-subprogram-body "ada-stmt" nil t) +(autoload 'ada-subtype "ada-stmt" nil t) +(autoload 'ada-tabsize "ada-stmt" nil t) +(autoload 'ada-task-body "ada-stmt" nil t) +(autoload 'ada-task-spec "ada-stmt" nil t) +(autoload 'ada-type "ada-stmt" nil t) +(autoload 'ada-use "ada-stmt" nil t) +(autoload 'ada-when "ada-stmt" nil t) +(autoload 'ada-while-loop "ada-stmt" nil t) +(autoload 'ada-with "ada-stmt" nil t) ;;; provide ourselves (provide 'ada-mode) +;;; arch-tag: 1b7d45ec-1698-43b5-8d4a-e479ea023270 ;;; ada-mode.el ends here