Mercurial > emacs
changeset 25903:812005e9c20e
(ada-get-indent-*, ada-indent-current, ada-goto-*,
ada-indent-newline-indent): Rewritten to support the new indentation
scheme
(ada-case-read-exceptions, ada-create-case-exceptions):
New functions
(ada-fill-comment-paragraph): Add support for the
justification parameter
(ada-make-body, ada-gen-treat-proc,
ada-make-subprogram-body): Rewritten to benefit from the gnatstub
external program
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Thu, 07 Oct 1999 14:33:10 +0000 |
| parents | 92828b88cfcc |
| children | 5a88e84b63a4 |
| files | lisp/progmodes/ada-mode.el |
| diffstat | 1 files changed, 2706 insertions(+), 2373 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/progmodes/ada-mode.el Thu Oct 07 14:32:32 1999 +0000 +++ b/lisp/progmodes/ada-mode.el Thu Oct 07 14:33:10 1999 +0000 @@ -1,46 +1,61 @@ -;;; ada-mode.el --- An Emacs major-mode for editing Ada source. - -;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc. - -;; Authors: Rolf Ebert <re@waporo.muc.de> -;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> -;; Maintainer: Emmanual Briot <briot@gnat.com> -;; Keywords: languages oop ada -;; Rolf Ebert's version: 2.27 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify +;; @(#) ada-mode.el --- major-mode for editing Ada source. + +;; Copyright (C) 1994-1999 Free Software Foundation, Inc. + +;; Author: Rolf Ebert <ebert@inf.enst.fr> +;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> +;; Emmanuel Briot <briot@gnat.com> +;; Maintainer: Emmanuel Briot <briot@gnat.com> +;; Ada Core Technologies's version: $Revision: 1.70 $ +;; Keywords: languages ada + +;; This file is not part of GNU Emacs + +;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; GNU Emacs is distributed in the hope that it will be useful, +;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; This mode is a complete rewrite of a major mode for editing Ada 83 -;;; and Ada 95 source code under Emacs-19. It contains completely new -;;; indenting code and support for code browsing (see ada-xref). - - -;;; USAGE -;;; ===== -;;; Emacs should enter Ada mode when you load an Ada source (*.ad[abs]). +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; 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-prj.el and ada-stmt.el. Only this file (ada-mode.el) is +;;; completly independant from the GNU Ada compiler Gnat, distributed +;;; by Ada Core Technologies. All the other files rely heavily on +;;; features provides only by Gnat. ;;; -;;; When you have entered ada-mode, you may get more info by pressing -;;; C-h m. You may also get online help describing various functions by: -;;; C-h d <Name of function you want described> - - -;;; HISTORY -;;; ======= +;;; Note: this mode will not work with Emacs 19. If you are on a VMS +;;; system, where the latest version of Emacs is 19.28, you will need +;;; another file, called ada-vms.el, that provides some required +;;; functions. + +;;; Usage: +;;; Emacs should enter Ada mode automatically when you load an Ada file. +;;; By default, the valid extensions for Ada files are .ads, .adb or .ada +;;; If the ada-mode does not start automatically, then simply type the +;;; following command : +;;; M-x ada-mode +;;; +;;; By default, ada-mode is configured to take full advantage of the GNAT +;;; compiler (the menus will include the cross-referencing features,...). +;;; If you are using another compiler, you might want to set the following +;;; variable in your .emacs (Note: do not set this in the ada-mode-hook, it +;;; won't work) : +;;; (setq ada-which-compiler 'generic) +;;; +;;; This mode requires find-file.el to be present on your system. + +;;; History: ;;; The first Ada mode for GNU Emacs was written by V. Broman in ;;; 1985. He based his work on the already existing Modula-2 mode. ;;; This was distributed as ada.el in versions of Emacs prior to 19.29. @@ -55,287 +70,283 @@ ;;; Gosling Emacs. L. Slater based his development on ada.el and ;;; electric-ada.el. ;;; -;;; The current Ada mode is a complete rewrite by M. Heritsch and -;;; R. Ebert. Some ideas from the Ada mode mailing list have been +;;; A complete rewrite by M. Heritsch and R. Ebert has been done. +;;; Some ideas from the Ada mode mailing list have been ;;; added. Some of the functionality of L. Slater's mode has not ;;; (yet) been recoded in this new mode. Perhaps you prefer sticking ;;; to his version. - - -;;; KNOWN BUGS -;;; ========== ;;; -;;; In the presence of comments and/or incorrect syntax -;;; ada-format-paramlist produces weird results. -;;; ------------------- -;;; Character constants with otherwise syntactic relevant characters -;;; like `(' or `"' throw indentation off the track. Fontification -;;; should work now in Emacs-19.35 -;;; C : constant Character := Character'('"'); -;;; ------------------- - - -;;; TODO -;;; ==== -;;; -;;; o bodify-single-subprogram -;;; o make a function "separate" and put it in the corresponding file. - - - -;;; CREDITS -;;; ======= -;;; -;;; Many thanks to -;;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular, -;;; woodruff@stc.llnl.gov (John Woodruff) -;;; jj@ddci.dk (Jesper Joergensen) -;;; gse@ocsystems.com (Scott Evans) -;;; comar@LANG8.CS.NYU.EDU (Cyrille Comar) +;;; A complete rewrite for Emacs-20 / Gnat-3.11 has been done by Ada Core +;;; Technologies. Please send bugs to briot@gnat.com + +;;; Credits: +;;; Many thanks to John McCabe <john@assen.demon.co.uk> for sending so +;;; many patches included in this package. +;;; Christian Egli <Christian.Egli@hcsd.hac.com>: +;;; ada-imenu-generic-expression +;;; Many thanks also to the following persons that have contributed one day +;;; to the ada-mode +;;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular, +;;; woodruff@stc.llnl.gov (John Woodruff) +;;; jj@ddci.dk (Jesper Joergensen) +;;; gse@ocsystems.com (Scott Evans) +;;; comar@gnat.com (Cyrille Comar) +;;; stephen.leake@gsfc.nasa.gov (Stephen Leake) ;;; and others for their valuable hints. - -;;;-------------------- -;;; USER OPTIONS -;;;-------------------- - - -;; ---- customize support + +;;; Code: +;;; Note: Every function is this package is compiler-independent. +;;; The names start with ada- +;;; The variables that the user can edit can all be modified throught +;;; the customize mode. They are sorted in alphabetical order in this +;;; file. + + +;; this function is needed at compile time +(eval-and-compile + (defun ada-check-emacs-version (major minor &optional is_xemacs) + "Returns t if Emacs's version is greater or equal to major.minor. +if IS_XEMACS is non-nil, check for XEmacs instead of Emacs" + (let ((xemacs_running (or (string-match "Lucid" emacs-version) + (string-match "XEmacs" emacs-version)))) + (and (or (and is_xemacs xemacs_running) + (not (or is_xemacs xemacs_running))) + (or (> emacs-major-version major) + (and (= emacs-major-version major) + (>= emacs-minor-version minor))))))) + + +;; We create a constant for that, for efficiency only +;; This should not be evaluated at compile time, only a runtime +(defconst ada-xemacs (boundp '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) + +(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 +fully loaded. +This is a good place to add Ada environment specific bindings.") (defgroup ada nil "Major mode for editing Ada source in Emacs" :group 'languages) -;; ---- configure indentation - -(defcustom ada-indent 3 - "*Defines the size of Ada indentation." - :type 'integer - :group 'ada) +(defcustom ada-auto-case t + "*Non-nil means automatically change case of preceding word while typing. +Casing is done according to `ada-case-keyword', `ada-case-identifier' +and `ada-case-attribute'." + :type 'boolean :group 'ada) + +(defcustom ada-broken-decl-indent 0 + "*Number of columns to indent a broken declaration. + +An example is : + declare + A, + >>>>>B : Integer; -- from ada-broken-decl-indent" + :type 'integer :group 'ada) (defcustom ada-broken-indent 2 - "*# of columns to indent the continuation of a broken line." - :type 'integer - :group 'ada) - -(defcustom ada-label-indent -4 - "*# of columns to indent a label." - :type 'integer - :group 'ada) - -(defcustom ada-stmt-end-indent 0 - "*# of columns to indent a statement end keyword in a separate line. -Examples are 'is', 'loop', 'record', ..." - :type 'integer - :group 'ada) - -(defcustom ada-when-indent 3 - "*Defines the indentation for 'when' relative to 'exception' or 'case'." - :type 'integer - :group 'ada) - -(defcustom ada-indent-record-rel-type 3 - "*Defines the indentation for 'record' relative to 'type' or 'use'." - :type 'integer - :group 'ada) - -(defcustom ada-indent-comment-as-code t - "*If non-nil, comment-lines get indented as Ada code." - :type 'boolean - :group 'ada) - -(defcustom ada-indent-is-separate t - "*If non-nil, 'is separate' or 'is abstract' on a single line are indented." - :type 'boolean - :group 'ada) - -(defcustom ada-indent-to-open-paren t - "*If non-nil, indent according to the innermost open parenthesis." - :type 'boolean - :group 'ada) - -(defcustom ada-search-paren-char-count-limit 3000 - "*Search that many characters for an open parenthesis." - :type 'integer + "*Number of columns to indent the continuation of a broken line. + +An example is : + My_Var : My_Type := (Field1 => + >>>>>>>>>Value); -- from ada-broken-indent" + :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' or +`ada-capitalize-word'." + :type '(choice (const downcase-word) + (const upcase-word) + (const ada-capitalize-word) + (const ada-loose-case-word)) :group 'ada) - -;; ---- other user options - -(defcustom ada-tab-policy 'indent-auto - "*Control behaviour of the TAB key. -Must be one of `indent-rigidly', `indent-auto', `gei', `indent-af' -or `always-tab'. - -`indent-rigidly' : always adds ada-indent blanks at the beginning of the line. -`indent-auto' : use indentation functions in this file. -`gei' : use David Kågedal's Generic Indentation Engine. -`indent-af' : use Gary E. Barnes' ada-format.el -`always-tab' : do indent-relative." - :type '(choice (const indent-auto) - (const indent-rigidly) - (const gei) - (const indent-af) - (const always-tab)) - :group 'ada) - -(defcustom ada-move-to-declaration nil - "*If non-nil, `ada-move-to-start' moves point to the subprog declaration, -not to 'begin'." - :type 'boolean - :group 'ada) - -(defcustom ada-spec-suffix ".ads" - "*Suffix of Ada specification files." - :type 'string - :group 'ada) - -(defcustom ada-body-suffix ".adb" - "*Suffix of Ada body files." - :type 'string - :group 'ada) - -(defcustom ada-spec-suffix-as-regexp "\\.ads$" - "*Regexp to find Ada specification files." - :type 'string - :group 'ada) - -(defcustom ada-body-suffix-as-regexp "\\.adb$" - "*Regexp to find Ada body files." - :type 'string - :group 'ada) - -(defvar ada-other-file-alist - (list - (list ada-spec-suffix-as-regexp (list ada-body-suffix)) - (list ada-body-suffix-as-regexp (list ada-spec-suffix)) - ) - "*Alist of extensions to find given the current file's extension. - -This list should contain the most used extensions before the others, -since the search algorithm searches sequentially through each directory -specified in `ada-search-directories'. If a file is not found, a new one -is created with the first matching extension (`.adb' yields `.ads').") - -(defcustom ada-search-directories - '("." "/usr/adainclude" "/usr/local/adainclude" "/opt/gnu/adainclude") - "*List of directories to search for Ada files. -See the description for the `ff-search-directories' variable." - :type '(repeat (choice :tag "Directory" - (const :tag "default" nil) - (directory :format "%v"))) - :group 'ada) - -(defcustom ada-language-version 'ada95 - "*Do we program in `ada83' or `ada95'?" - :type '(choice (const ada83) - (const ada95)) - :group 'ada) +(defcustom ada-case-exception-file "~/.emacs_case_exceptions" + "*Name of the file that contains the list of special casing +exceptions for identifiers. +This file should contain one word per line, that gives the casing +to be used for that words in Ada files" + :type 'file :group 'ada) (defcustom ada-case-keyword 'downcase-word "*Function to call to adjust the case of Ada keywords. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'." +It may be `downcase-word', `upcase-word', `ada-loose-case-word' or +`ada-capitalize-word'." :type '(choice (const downcase-word) (const upcase-word) - (const capitalize-word) + (const ada-capitalize-word) (const ada-loose-case-word)) :group 'ada) (defcustom ada-case-identifier 'ada-loose-case-word "*Function to call to adjust the case of an Ada identifier. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'." +It may be `downcase-word', `upcase-word', `ada-loose-case-word' or +`ada-capitalize-word'." :type '(choice (const downcase-word) (const upcase-word) - (const capitalize-word) + (const ada-capitalize-word) (const ada-loose-case-word)) :group 'ada) -(defcustom ada-case-attribute 'capitalize-word - "*Function to call to adjust the case of Ada attributes. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'." - :type '(choice (const downcase-word) - (const upcase-word) - (const capitalize-word) - (const ada-loose-case-word)) - :group 'ada) - -(defcustom ada-auto-case t - "*Non-nil automatically changes case of preceding word while typing. -Casing is done according to `ada-case-keyword', `ada-case-identifier' -and `ada-case-attribute'." - :type 'boolean - :group 'ada) - (defcustom ada-clean-buffer-before-saving t - "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving." - :type 'boolean - :group 'ada) - -(defvar ada-mode-hook nil - "*List of functions to call when Ada mode is invoked. -This is a good place to add Ada environment specific bindings.") - -(defcustom ada-external-pretty-print-program "aimap" - "*External pretty printer to call from within Ada mode." - :type 'string - :group 'ada) - -(defcustom ada-tmp-directory temporary-file-directory - "*Directory to store the temporary file for the Ada pretty printer." - :type 'string - :group 'ada) - -(defcustom ada-compile-options "-c" - "*Buffer local options passed to the Ada compiler. -These options are used when the compiler is invoked on the current buffer." - :type 'string - :group 'ada) -(make-variable-buffer-local 'ada-compile-options) - -(defcustom ada-make-options "-c" - "*Buffer local options passed to `ada-compiler-make' (usually `gnatmake'). -These options are used when `gnatmake' is invoked on the current buffer." - :type 'string - :group 'ada) -(make-variable-buffer-local 'ada-make-options) - -(defcustom ada-compiler-syntax-check "gcc -c -gnats" - "*Compiler command with options for syntax checking." - :type 'string - :group 'ada) - -(defcustom ada-compiler-make "gnatmake" - "*The `make' command for the given compiler." - :type 'string - :group 'ada) + "*Non-nil means `remove-trailing-spaces' and `untabify' buffer before saving." + :type 'boolean :group 'ada) + +(defcustom ada-indent 3 + "*Size of Ada indentation. + +An example is : +procedure Foo is +begin +>>>>>>>>>>null; -- from ada-indent" + :type 'integer :group 'ada) + +(defcustom ada-indent-after-return t + "*Non-nil means automatically indent after RET or LFD." + :type 'boolean :group 'ada) + +(defcustom ada-indent-comment-as-code t + "*Non-nil means indent comment lines as code" + :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) + +(defcustom ada-indent-record-rel-type 3 + "*Indentation for 'record' relative to 'type' or 'use'. + +An example is: + type A is + >>>>>>>>>>>record -- from ada-indent-record-rel-type" + :type 'integer :group 'ada) + +(defcustom ada-indent-return 0 + "*Indentation for 'return' relative to the matching 'function' statement. +If ada-indent-return is null or negative, the indentation is done relative to +the open parenthesis (if there is no parenthesis, ada-broken-indent is used) + +An example is: + function A (B : Integer) + >>>>>return C; -- from ada-indent-return" + :type 'integer :group 'ada) + +(defcustom ada-indent-to-open-paren t + "*Non-nil means indent according to the innermost open parenthesis." + :type 'boolean :group 'ada) (defcustom ada-fill-comment-prefix "-- " - "*This is inserted in the first columns when filling a comment paragraph." - :type 'string - :group 'ada) + "*Text inserted in the first columns when filling a comment paragraph. +Note: if you modify this variable, you will have to restart the ada-mode to +reread this variable." + :type 'string :group 'ada) (defcustom ada-fill-comment-postfix " --" - "*This is inserted at the end of each line when filling a comment paragraph. + "*Text inserted at the end of each line when filling a comment paragraph. with `ada-fill-comment-paragraph-postfix'." - :type 'string + :type 'string :group 'ada) + +(defcustom ada-label-indent -4 + "*Number of columns to indent a label. + +An example is: +procedure Foo is +begin +>>>>>>>>>>>>Label: -- from ada-label-indent" + :type 'integer :group 'ada) + +(defcustom ada-language-version 'ada95 + "*Do we program in `ada83' or `ada95'?" + :type '(choice (const ada83) (const ada95)) :group 'ada) + +(defcustom ada-move-to-declaration nil + "*Non-nil means `ada-move-to-start' moves point to the subprog declaration, +not to 'begin'." + :type 'boolean :group 'ada) + +(defcustom ada-popup-key '[down-mouse-3] + "*Key used for binding the contextual menu. +if nil, no contextual menu is available") + +(defcustom ada-search-directories + '("." "$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." + :type '(repeat (choice :tag "Directory" + (const :tag "default" nil) + (directory :format "%v"))) :group 'ada) -(defcustom ada-krunch-args "0" - "*Argument of gnatkr, a string containing the max number of characters. -Set to 0, if you don't use crunched filenames." - :type 'string +(defcustom ada-stmt-end-indent 0 + "*Number of columns to indent a statement end keyword on a separate line. + +An example is: + if A = B + >>>>>>>>>>>then -- from ada-stmt-end-indent" + :type 'integer :group 'ada) + +(defcustom ada-tab-policy 'indent-auto + "*Control the behaviour of the TAB key. +This is used only in the ada-tab and ada-untab functions. +Must be one of : +`indent-rigidly' : always adds ada-indent blanks at the beginning of the line. +`indent-auto' : use indentation functions in this file. +`always-tab' : do indent-relative." + :type '(choice (const indent-auto) + (const indent-rigidly) + (const always-tab)) :group 'ada) +(defcustom ada-when-indent 3 + "*Indentation for 'when' relative to 'exception' or 'case'. + +An example is: + case A is + >>>>>>>>when B => -- from ada-when-indentx" + :type 'integer :group 'ada) + +(defcustom ada-which-compiler 'gnat + "*Name of the compiler we use. This will determine what features are +made available through the ada-mode. The possible choices are : + +`gnat': Use Ada Core Technologies' Gnat compiler. Add some cross-referencing + features +`generic': Use a generic compiler" + :type '(choice (const gnat) + (const generic)) + :group 'ada) + + ;;; ---- end of user configurable variables -(defvar ada-mode-abbrev-table nil - "Abbrev table used in Ada mode.") -(define-abbrev-table 'ada-mode-abbrev-table ()) - -(defvar ada-mode-map () +(defvar ada-body-suffixes '(".adb") + "List of possible suffixes for Ada body files. The extensions should +include a `.' if needed") + +(defvar ada-spec-suffixes '(".ads") + "List of possible suffixes for Ada spec files. The extensions should +include a `.' if needed") + +(defvar ada-mode-menu (make-sparse-keymap) + "Menu for ada-mode") + +(defvar ada-mode-map (make-sparse-keymap) "Local keymap used for Ada mode.") (defvar ada-mode-syntax-table nil @@ -344,56 +355,60 @@ (defvar ada-mode-symbol-syntax-table nil "Syntax table for Ada, where `_' is a word constituent.") +(eval-when-compile + (defconst ada-83-string-keywords + '("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin" + "body" "case" "constant" "declare" "delay" "delta" "digits" "do" + "else" "elsif" "end" "entry" "exception" "exit" "for" "function" + "generic" "goto" "if" "in" "is" "limited" "loop" "mod" "new" + "not" "null" "of" "or" "others" "out" "package" "pragma" "private" + "procedure" "raise" "range" "record" "rem" "renames" "return" + "reverse" "select" "separate" "subtype" "task" "terminate" "then" + "type" "use" "when" "while" "with" "xor") + "List of ada keywords -- This variable is not used instead to define +ada-83-keywords and ada-95-keywords")) + +(defvar ada-ret-binding nil + "Variable to save key binding of RET when casing is activated.") + +(defvar ada-case-exception '() + "Alist of words (entities) that have special casing, and should not +be reindented according to the function `ada-case-identifier'. +Its value is read from the file `ada-case-exception-file'") + +(defvar ada-lfd-binding nil + "Variable to save key binding of LFD when casing is activated.") + +(defvar ada-other-file-alist nil + "Variable used by find-file to find the name of the other package. +See `ff-other-file-alist'" + ) + +;;; ---- Below are the regexp used in this package for parsing + (defconst ada-83-keywords - "\\<\\(abort\\|abs\\|accept\\|access\\|all\\|and\\|array\\|\ -at\\|begin\\|body\\|case\\|constant\\|declare\\|delay\\|delta\\|\ -digits\\|do\\|else\\|elsif\\|end\\|entry\\|exception\\|exit\\|for\\|\ -function\\|generic\\|goto\\|if\\|in\\|is\\|limited\\|loop\\|mod\\|\ -new\\|not\\|null\\|of\\|or\\|others\\|out\\|package\\|pragma\\|\ -private\\|procedure\\|raise\\|range\\|record\\|rem\\|renames\\|\ -return\\|reverse\\|select\\|separate\\|subtype\\|task\\|terminate\\|\ -then\\|type\\|use\\|when\\|while\\|with\\|xor\\)\\>" -; "\\<\\(a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|ll\\|nd\\|rray\\|t\\)\\|\ -;b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|\ -;d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|\ -;e\\(ls\\(e\\|if\\)\\|n\\(d\\|try\\)\\|x\\(ception\\|it\\)\\)\\|\ -;f\\(or\\|unction\\)\\|g\\(eneric\\|oto\\)\\|i[fns]\\|l\\(imited\\|oop\\)\\|\ -;mod\\|n\\(ew\\|ot\\|ull\\)\\|o\\([fr]\\|thers\\|ut\\)\\|\ -;p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|\ -;r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|\ -;s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|use\\| -;t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor\\)\\>" + (eval-when-compile + (concat "\\<" (regexp-opt ada-83-string-keywords t) "\\>")) "Regular expression for looking at Ada83 keywords.") (defconst ada-95-keywords - "\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\ -all\\|and\\|array\\|at\\|begin\\|body\\|case\\|constant\\|declare\\|\ -delay\\|delta\\|digits\\|do\\|else\\|elsif\\|end\\|entry\\|\ -exception\\|exit\\|for\\|function\\|generic\\|goto\\|if\\|in\\|\ -is\\|limited\\|loop\\|mod\\|new\\|not\\|null\\|of\\|or\\|others\\|\ -out\\|package\\|pragma\\|private\\|procedure\\|protected\\|raise\\|\ -range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\ -select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\ -type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>" + (eval-when-compile + (concat "\\<" (regexp-opt + (append + '("abstract" "aliased" "protected" "requeue" + "tagged" "until") + ada-83-string-keywords) t) "\\>")) "Regular expression for looking at Ada95 keywords.") (defvar ada-keywords ada-95-keywords "Regular expression for looking at Ada keywords.") -(defvar ada-ret-binding nil - "Variable to save key binding of RET when casing is activated.") - -(defvar ada-lfd-binding nil - "Variable to save key binding of LFD when casing is activated.") - -;;; ---- Regexps to find procedures/functions/packages - -(defconst ada-ident-re - "[a-zA-Z0-9_\\.]+" +(defconst ada-ident-re + "\\(\\sw\\|[_.]\\)+" "Regexp matching Ada (qualified) identifiers.") (defvar ada-procedure-start-regexp - "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)" + "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\(\\(\\sw\\|[_.]\\)+\\)" "Regexp used to find Ada procedures/functions.") (defvar ada-package-start-regexp @@ -404,57 +419,145 @@ ;;; ---- regexps for indentation functions (defvar ada-block-start-re - "\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\ -exception\\|loop\\|else\\|\ -\\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>" + (eval-when-compile + (concat "\\<\\(" (regexp-opt '("begin" "declare" "else" + "exception" "generic" "loop" "or" + "private" "select" )) + "\\|\\(\\(limited\\|abstract\\|tagged\\)[ \t\n]+\\)*record\\)\\>")) "Regexp for keywords starting Ada blocks.") (defvar ada-end-stmt-re - "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\ -\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\ -declare\\|generic\\|private\\)\\>\\|\ -^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\ -^[ \t]*exception\\>\\)" + (eval-when-compile + (concat "\\(" + ";" "\\|" + "=>[ \t]*$" "\\|" + "^[ \t]*separate[ \t]*(\\(\\sw\\|[_.]\\)+)" "\\|" + "\\<" (regexp-opt '("begin" "declare" "is" "do" "else" "generic" "loop" + "private" "record" "select" "then") t) "\\>" "\\|" + "^[ \t]*" (regexp-opt '("function" "package" "procedure") + t) "\\>\\(\\sw\\|[ \t_.]\\)+\\<is\\>" "\\|" + "^[ \t]*exception\\>" + "\\)") ) "Regexp of possible ends for a non-broken statement. A new statement starts after these.") +(defvar ada-matching-start-re + (eval-when-compile + (concat "\\<" + (regexp-opt + '("end" "loop" "select" "begin" "case" "do" + "if" "task" "package" "record" "protected") t) + "\\>")) + "Regexp used in ada-goto-matching-start") + +(defvar ada-matching-decl-start-re + (eval-when-compile + (concat "\\<" + (regexp-opt + '("is" "separate" "end" "declare" "if" "new" "begin" "generic") t) + "\\>")) + "Regexp used in ada-goto-matching-decl-start") + + (defvar ada-loop-start-re "\\<\\(for\\|while\\|loop\\)\\>" "Regexp for the start of a loop.") (defvar ada-subprog-start-re - "\\<\\(procedure\\|protected\\|package\\|function\\|\ -task\\|accept\\|entry\\)\\>" + (eval-when-compile + (concat "\\<" (regexp-opt '("accept" "entry" "function" "package" "procedure" + "protected" "task") t) "\\>")) "Regexp for the start of a subprogram.") (defvar ada-named-block-re - "[ \t]*[a-zA-Z_0-9]+ *:[^=]" + "[ \t]*\\(\\sw\\|_\\)+[ \t]*:[^=]" "Regexp of the name of a block or loop.") + + +;;------------------------------------------------------------------ +;; Support for imenu (see imenu.el) +;;------------------------------------------------------------------ + +(defvar ada-imenu-generic-expression + (list + '(nil "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)\\)[ \t\n]*\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]" 2) + (list "*Specs*" + (concat + "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)" + "\\(" + "\\([ \t\n]+\\|[ \t\n]*([^)]+)\\)";; parameter list or simple space + "\\([ \t\n]*return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?" + "\\)?;") 2) + '("*Tasks*" "^[ \t]*task[ \t]+\\(\\(body\\|type\\)[ \t]+\\)?\\(\\(\\sw\\|_\\)+\\)" 3) + '("*Type Defs*" "^[ \t]*\\(sub\\)?type[ \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.") + -;; Written by Christian Egli <Christian.Egli@hcsd.hac.com> -;; -(defvar ada-imenu-generic-expression - '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2) - ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2)) - - "Imenu generic expression for Ada mode. See `imenu-generic-expression'.") - + +;;------------------------------------------------------------ +;; Supporte for compile.el +;;------------------------------------------------------------ + +(defun ada-compile-mouse-goto-error () + "mouse interface for ada-compile-goto-error" + (interactive) + (mouse-set-point last-input-event) + (ada-compile-goto-error (point)) + ) + +(defun ada-compile-goto-error (pos) + "replaces compile-goto-error from compile.el: if point is on an file and line +location, go to this position. It adds to compile.el the capacity to go to a +reference in an error message. +For instance, on this line: + foo.adb:61:11: missing argument for parameter set in call to size declared at foo.ads:11 +both file locations can be clicked on and jumped to" + (interactive "d") + (goto-char pos) + + (skip-chars-backward "-a-zA-Z0-9_:./\\") + (cond + ;; special case: looking at a filename:line not at the beginning of a line + ((and (not (bolp)) + (looking-at + "\\(\\(\\sw\\|[_-.]\\)+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?")) + (let ((line (match-string 3)) + (error-pos (point-marker)) + source) + (save-excursion + (save-restriction + (widen) + (set-buffer (compilation-find-file (point-marker) (match-string 1) + "./")) + (if (stringp line) + (goto-line (string-to-number line))) + (set 'source (point-marker)))) + (compilation-goto-locus (cons source error-pos)) + )) + + ;; otherwise, default behavior + (t + (compile-goto-error)) + ) + (recenter)) + ;;;------------- ;;; functions ;;;------------- -(defun ada-xemacs () - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - (defun ada-create-syntax-table () "Create the syntax table for Ada mode." ;; There are two different syntax-tables. The standard one declares - ;; `_' as a symbol constituent, in the second one, it is a word - ;; constituent. For some search and replacing routines we + ;; `_' as a symbol constituant, in the second one, it is a word + ;; constituant. For some search and replacing routines we ;; temporarily switch between the two. - (setq ada-mode-syntax-table (make-syntax-table)) + (interactive) + (set 'ada-mode-syntax-table (make-syntax-table)) (set-syntax-table ada-mode-syntax-table) ;; define string brackets (`%' is alternative string bracket, but @@ -463,8 +566,6 @@ (modify-syntax-entry ?% "$" ada-mode-syntax-table) (modify-syntax-entry ?\" "\"" ada-mode-syntax-table) - (modify-syntax-entry ?\# "$" ada-mode-syntax-table) - (modify-syntax-entry ?: "." ada-mode-syntax-table) (modify-syntax-entry ?\; "." ada-mode-syntax-table) (modify-syntax-entry ?& "." ada-mode-syntax-table) @@ -487,6 +588,17 @@ ;; a single hyphen is punctuation, but a double hyphen starts a comment (modify-syntax-entry ?- ". 12" ada-mode-syntax-table) + ;; # is set to be a matched-pair, since it is used for based numbers, + ;; as in 16#3f#. The syntax class will be modifed later when it + ;; appears at the beginning of a line for gnatprep statements. + ;; For Emacs, the modification is done in font-lock-syntactic-keywords + ;; or ada-after-change-function. + ;; For XEmacs, this is not done correctly for now, based numbers won't + ;; be handled correctly. + (if ada-xemacs + (modify-syntax-entry ?# "<" ada-mode-syntax-table) + (modify-syntax-entry ?# "$" ada-mode-syntax-table)) + ;; and \f and \n end a comment (modify-syntax-entry ?\f "> " ada-mode-syntax-table) (modify-syntax-entry ?\n "> " ada-mode-syntax-table) @@ -498,10 +610,200 @@ (modify-syntax-entry ?\( "()" ada-mode-syntax-table) (modify-syntax-entry ?\) ")(" ada-mode-syntax-table) - (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table)) + (set 'ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table)) (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table) ) +;; +;; This is to support XEmacs, which does not have the syntax-table attribute +;; as used in ada-after-change-function +;; When executing parse-partial-sexp, we simply modify the strings before and +;; after, so that the special constants '"', '(' and ')' do not interact +;; with parse-partial-sexp. + +(if ada-xemacs + (defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants) + (let (change) + (if (< to from) + (let ((tmp from)) + (setq from to to tmp))) + (save-excursion + (goto-char from) + (while (re-search-forward "'\\([(\")#]\\)'" to t) + (set 'change (cons (list (match-beginning 1) + 1 + (match-string 1)) + change)) + (replace-match "'A'")) + (goto-char from) + (while (re-search-forward "\\(#[0-9a-fA-F]*#\\)" to t) + (set 'change (cons (list (match-beginning 1) + (length (match-string 1)) + (match-string 1)) + change)) + (replace-match (make-string (length (match-string 1)) ?@)))) + ad-do-it + (save-excursion + (while change + (goto-char (caar change)) + (delete-char (cadar change)) + (insert (caddar change)) + (set 'change (cdr change))))))) + +;; +;; The following three functions handle the text properties in the buffer: +;; the problem in Ada is that ' can be both a constant character delimiter +;; and an attribute delimiter. To handle this easily (and allowing us to +;; use the standard Emacs functions for sexp... as in ada-in-string-p), we +;; change locally the syntax table every time we see a character constant. +;; The three characters are then said to be part of a string. +;; This handles nicely the '"' case (" is simply ignored in that case) +;; +;; The idea for this code was borrowed from font-lock.el, which actually +;; does the same job thanks to ada-font-lock-syntactic-keywords. No need +;; to duplicate the work if we already use font-lock +;; +;; This code is not executed for XEmacs, since the syntax-table attribute is +;; not known + +(defun ada-deactivate-properties () + "Deactivate ada-mode's properties handling, since this would be +a duplicate of font-lock" + (remove-hook 'after-change-functions 'ada-after-change-function t)) + +(defun ada-initialize-properties () + "Initialize some special text properties in the whole buffer. +In particular, character constants that contain string delimiters are said +to be strings. +We also treat #..# as numbers, instead of gnatprep comments +" + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward "'.'" nil t) + (add-text-properties (match-beginning 0) (match-end 0) + '(syntax-table ("'" . ?\")))) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*#" nil t) + (add-text-properties (match-beginning 0) (match-end 0) + '(syntax-table (11 . 10)))) + (set-buffer-modified-p nil) + + ;; 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) + ))) + +(defun ada-after-change-function (beg end old-len) + "Called every time a character is changed in the buffer" + ;; borrowed from font-lock.el + (let ((inhibit-point-motion-hooks t) + (eol (point))) + (save-excursion + (save-match-data + (beginning-of-line) + (remove-text-properties (point) eol '(syntax-table nil)) + (while (re-search-forward "'.'" eol t) + (add-text-properties (match-beginning 0) (match-end 0) + '(syntax-table ("'" . ?\")))) + (beginning-of-line) + (if (looking-at "^[ \t]*#") + (add-text-properties (match-beginning 0) (match-end 0) + '(syntax-table (11 . 10)))) + )))) + + +(defvar ada-contextual-menu-on-identifier nil) + +(defvar ada-contextual-menu + (if ada-xemacs + '("Ada" + ["Goto Declaration/Body" ada-goto-declaration + :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] + ["-" 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" + ada-point-and-xref + :visible ada-contextual-menu-on-identifier + ) t) + (define-key-after map [Prev] + '("Goto Previous Reference" .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))) + +(defun ada-popup-menu (position) + "Pops up a contextual menu, depending on where the user clicked" + (interactive "e") + (mouse-set-point last-input-event) + + (setq ada-contextual-menu-on-identifier + (and (or (= (char-syntax (char-after)) ?w) + (= (char-after) ?_)) + (not (ada-in-string-or-comment-p)) + (save-excursion (skip-syntax-forward "w") + (not (ada-after-keyword-p))) + )) + (let (choice) + (if ada-xemacs + (set 'choice (popup-menu ada-contextual-menu)) + (set 'choice (x-popup-menu position ada-contextual-menu))) + (if choice + (funcall (lookup-key ada-contextual-menu (vector (car choice))))))) + +;;;###autoload +(defun ada-add-extensions (spec body) + "Add a new set of extensions to the ones recognized by ada-mode. +The addition is done so that `goto-other-file' works as expected" + + (let* ((reg (concat (regexp-quote body) "$")) + (tmp (assoc reg ada-other-file-alist))) + (if tmp + (setcdr tmp (list (cons spec (cadr tmp)))) + (add-to-list 'ada-other-file-alist (list reg (list spec))))) + + (let* ((reg (concat (regexp-quote spec) "$")) + (tmp (assoc reg ada-other-file-alist))) + (if tmp + (setcdr tmp (list (cons body (cadr tmp)))) + (add-to-list 'ada-other-file-alist (list reg (list body))))) + + (add-to-list 'auto-mode-alist (cons spec 'ada-mode)) + (add-to-list 'auto-mode-alist (cons body 'ada-mode)) + + (add-to-list 'ada-spec-suffixes spec) + (add-to-list 'ada-body-suffixes body) + + ;; Support for speedbar (Specifies that we want to see these files in + ;; speedbar) + (condition-case nil + (progn + (require 'speedbar) + (speedbar-add-supported-extension spec) + (speedbar-add-supported-extension body))) + ) + + ;;;###autoload (defun ada-mode () @@ -514,16 +816,11 @@ Re-format the parameter-list point is in '\\[ada-format-paramlist]' Indent all lines in region '\\[ada-indent-region]' - Call external pretty printer program '\\[ada-call-pretty-printer]' Adjust case of identifiers and keywords in region '\\[ada-adjust-case-region]' Adjust case of identifiers and keywords in buffer '\\[ada-adjust-case-buffer]' - Call EXTERNAL pretty printer (if you have one) '\\[ada-call-pretty-printer]' - - Fill comment paragraph '\\[ada-fill-comment-paragraph]' - Fill comment paragraph and justify each line '\\[ada-fill-comment-paragraph-justify]' - Fill comment paragraph, justify and append postfix '\\[ada-fill-comment-paragraph-postfix]' + Fill comment paragraph, justify and append postfix '\\[fill-paragraph]' Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]' Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]' @@ -545,430 +842,374 @@ or '\\[ff-mouse-find-other-file] Switch to other file in other window '\\[ada-ff-other-window]' or '\\[ff-mouse-find-other-file-other-window] - If you use this function in a spec and no body is available, it gets created - with body stubs. + If you use this function in a spec and no body is available, it gets created with body stubs. If you use ada-xref.el: Goto declaration: '\\[ada-point-and-xref]' on the identifier or '\\[ada-goto-declaration]' with point on the identifier - Complete identifier: '\\[ada-complete-identifier]' - Execute Gnatf: '\\[ada-gnatf-current]'" + Complete identifier: '\\[ada-complete-identifier]'" (interactive) (kill-all-local-variables) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) + (set (make-local-variable 'require-final-newline) t) (make-local-variable 'comment-start) - (setq comment-start "-- ") + (if ada-fill-comment-prefix + (set 'comment-start ada-fill-comment-prefix) + (set '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]*$") + (set (make-local-variable 'paragraph-separate) "[ \t\n\f]*$") ;; comment end must be set because it may hold a wrong value if ;; this buffer had been in another mode before. RE - (make-local-variable 'comment-end) - (setq comment-end "") - - (make-local-variable 'comment-start-skip) ;; used by autofill - (setq comment-start-skip "--+[ \t]*") - - (make-local-variable 'indent-line-function) - (setq indent-line-function 'ada-indent-current-function) - - (make-local-variable 'fill-column) - (setq fill-column 75) - - (make-local-variable 'comment-column) - (setq comment-column 40) - - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - - (make-local-variable 'case-fold-search) - (setq case-fold-search t) - - (make-local-variable 'outline-regexp) - (setq outline-regexp "[^\n\^M]") - (make-local-variable 'outline-level) - (setq outline-level 'ada-outline-level) - - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'ada-fill-comment-paragraph) - ;;(make-local-variable 'adaptive-fill-regexp) - - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression ada-imenu-generic-expression) - (setq imenu-case-fold-search t) - - (if (ada-xemacs) nil ; XEmacs uses properties - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '((ada-font-lock-keywords - ada-font-lock-keywords-1 ada-font-lock-keywords-2) - nil t - ((?\_ . "w")(?\. . "w")) - beginning-of-line - (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) - - ;; Set up support for find-file.el. - (make-variable-buffer-local 'ff-other-file-alist) - (make-variable-buffer-local 'ff-search-directories) - (setq ff-other-file-alist 'ada-other-file-alist - ff-search-directories 'ada-search-directories - ff-pre-load-hooks 'ff-which-function-are-we-in - ff-post-load-hooks 'ff-set-point-accordingly - ff-file-created-hooks 'ada-make-body)) - - (setq major-mode 'ada-mode) - (setq mode-name "Ada") + (set (make-local-variable 'comment-end) "") + + ;; used by autofill and indent-new-comment-line + (set (make-local-variable 'comment-start-skip) "---*[ \t]*") + + ;; used by autofill to break a comment line and continue it on another line. + ;; The reason we need this one is that the default behavior does not work + ;; correctly with the definition of paragraph-start above when the comment + ;; is right after a multiline subprogram declaration (the comments are + ;; aligned under the latest parameter, not under the declaration start). + (set (make-local-variable 'comment-line-break-function) + (lambda (&optional soft) (let ((fill-prefix nil)) + (indent-new-comment-line soft)))) + + (set (make-local-variable 'indent-line-function) + 'ada-indent-current-function) + + (set (make-local-variable 'comment-column) 40) + + ;; 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 + (unless ada-xemacs + (progn + (if (ada-check-emacs-version 20 3) + (progn + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'comment-padding) 0))) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + )) + + (set 'case-fold-search t) + (if (boundp 'imenu-case-fold-search) + (set 'imenu-case-fold-search t)) + + (set (make-local-variable 'fill-paragraph-function) + 'ada-fill-comment-paragraph) + + (set (make-local-variable 'imenu-generic-expression) + ada-imenu-generic-expression) + + ;; Support for compile.el + ;; We just substitute our own functions to go to the error. + (add-hook 'compilation-mode-hook + '(lambda() + (set 'compile-auto-highlight 40) + (define-key compilation-minor-mode-map [mouse-2] + 'ada-compile-mouse-goto-error) + (define-key compilation-minor-mode-map "\C-c\C-c" + 'ada-compile-goto-error) + (define-key compilation-minor-mode-map "\C-m" + 'ada-compile-goto-error) + )) + + ;; font-lock support : + ;; We need to set some properties for Xemacs, and define some variables + ;; for Emacs + + (if ada-xemacs + ;; XEmacs + (put 'ada-mode 'font-lock-defaults + '(ada-font-lock-keywords + nil t ((?\_ . "w") (?# . ".")) beginning-of-line)) + ;; Emacs + (set (make-local-variable 'font-lock-defaults) + '(ada-font-lock-keywords + nil t + ((?\_ . "w") (?# . ".")) + beginning-of-line + (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) + ) + + ;; Set up support for find-file.el. + (set (make-variable-buffer-local 'ff-other-file-alist) + 'ada-other-file-alist) + (set (make-variable-buffer-local '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) + + ;; Some special constructs for find-file.el + ;; We do not need to add the construction for 'with', which is in the + ;; standard find-file.el + ;; Go to the parent package : + (make-local-variable 'ff-special-constructs) + (add-to-list 'ff-special-constructs + (cons (eval-when-compile + (concat "^\\(private[ \t]\\)?[ \t]*package[ \t]+" + "\\(body[ \t]+\\)?" + "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is")) + '(lambda () + (set 'fname (ff-get-file + ff-search-directories + (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 () + (set 'fname (ff-get-file + ff-search-directories + (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 + (add-to-list 'ff-special-constructs + (cons "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" + '(lambda () + (set 'fname (ff-get-file + ff-search-directories + (ada-make-filename-from-adaname + (match-string 1)) + ada-spec-suffixes))))) + + ;; Support for outline-minor-mode + (set (make-local-variable 'outline-regexp) + "\\([ \t]*\\(procedure\\|function\\|package\\|with\\|use\\)\\|--\\|end\\)") + (set (make-local-variable 'outline-level) 'ada-outline-level) + + ;; Support for imenu : We want a sorted index + (set 'imenu-sort-function 'imenu--sort-by-name) + + ;; Set up the contextual menu + (if ada-popup-key + (define-key ada-mode-map ada-popup-key 'ada-popup-menu)) + + ;; Support for indent-new-comment-line (Especially for XEmacs) + (set 'comment-multi-line nil) + (defconst comment-indent-function (lambda () comment-column)) + + (set 'major-mode 'ada-mode) + (set 'mode-name "Ada") (use-local-map ada-mode-map) - (if ada-mode-syntax-table - (set-syntax-table ada-mode-syntax-table) - (ada-create-syntax-table)) + (if ada-xemacs + (easy-menu-add ada-mode-menu ada-mode-map)) + + (set-syntax-table ada-mode-syntax-table) (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 'ada-remove-trailing-spaces) - ;; convert all tabs to the correct number of spaces. - (add-hook 'local-write-file-hooks 'ada-untabify-buffer))) - - - ;; add menu 'Ada' to the menu bar - (ada-add-ada-menu) + ;; remove all spaces at the end of lines in the whole buffer. + (add-hook 'local-write-file-hooks 'ada-remove-trailing-spaces) + ;; 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) + ;; Run this after the hook to give the users a chance to activate + ;; font-lock-mode + + (unless ada-xemacs + (progn + (ada-initialize-properties) + (make-local-hook 'font-lock-mode-hook) + (add-hook 'font-lock-mode-hook 'ada-deactivate-properties nil t))) + ;; the following has to be done after running the ada-mode-hook ;; because users might want to set the values of these variable ;; inside the hook (MH) + ;; Note that we add the new elements at the end of ada-other-file-alist + ;; since some user might want to give priority to some other extensions + ;; first (for instance, a .adb file could be associated with a .ads + ;; or a .ads.gp (gnatprep)). + ;; This is why we can't use add-to-list here. (cond ((eq ada-language-version 'ada83) - (setq ada-keywords ada-83-keywords)) + (set 'ada-keywords ada-83-keywords)) ((eq ada-language-version 'ada95) - (setq ada-keywords ada-95-keywords))) + (set 'ada-keywords ada-95-keywords))) (if ada-auto-case (ada-activate-keys-for-case))) -;;;-------------------------- -;;; Compile support -;;;-------------------------- - -(defun ada-check-syntax () - "Check syntax of the current buffer. -Uses the function `compile' to execute `ada-compiler-syntax-check'." - (interactive) - (let ((old-compile-command compile-command)) - (setq compile-command (concat ada-compiler-syntax-check - (if (eq ada-language-version 'ada83) - "-gnat83 ") - " " ada-compile-options " " - (buffer-name))) - (setq compile-command (read-from-minibuffer - "enter command for syntax check: " - compile-command)) - (compile compile-command) - ;; restore old compile-command - (setq compile-command old-compile-command))) - -(defun ada-make-local () - "Bring current Ada unit up-to-date. -Uses the function `compile' to execute `ada-compile-make'." - (interactive) - (let ((old-compile-command compile-command)) - (setq compile-command (concat ada-compiler-make - " " ada-make-options " " - (buffer-name))) - (setq compile-command (read-from-minibuffer - "enter command for local make: " - compile-command)) - (compile compile-command) - ;; restore old compile-command - (setq compile-command old-compile-command))) - - - - -;;;-------------------------- -;;; Fill Comment Paragraph -;;;-------------------------- - -(defun ada-fill-comment-paragraph-justify () - "Fills current comment paragraph and justifies each line as well." - (interactive) - (ada-fill-comment-paragraph t)) - - -(defun ada-fill-comment-paragraph-postfix () - "Fills current comment paragraph and justifies each line as well. -Prompts for a postfix to be appended to each line." + +;;;-------------------------------------------------------- +;;; auto-casing +;;;-------------------------------------------------------- + + +(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. +Every time the ada-mode will see the same word, the same casing will +be used. +The new words is added to the file `ada-case-exception-file'" (interactive) - (ada-fill-comment-paragraph t t)) - - -(defun ada-fill-comment-paragraph (&optional justify postfix) - "Fills the current comment paragraph. -If JUSTIFY is non-nil, each line is justified as well. -If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended -to each filled and justified line. -If `ada-indent-comment-as-code' is non-nil, the paragraph is idented." - (interactive "P") - (let ((opos (point-marker)) - (begin nil) - (end nil) - (end-2 nil) - (indent nil) - (ada-fill-comment-old-postfix "") - (fill-prefix nil)) - - ;; check if inside comment - (if (not (ada-in-comment-p)) - (error "not inside comment")) - - ;; prompt for postfix if wanted - (if (and justify - postfix) - (setq ada-fill-comment-postfix - (read-from-minibuffer "enter new postfix string: " - ada-fill-comment-postfix))) - - ;; prompt for old postfix to remove if necessary - (if (and justify - postfix) - (setq ada-fill-comment-old-postfix - (read-from-minibuffer "enter already existing postfix string: " - ada-fill-comment-postfix))) - - ;; - ;; find limits of paragraph - ;; - (message "filling comment paragraph ...") - (save-excursion - (back-to-indentation) - ;; find end of paragraph - (while (and (looking-at "--.*$") - (not (looking-at "--[ \t]*$"))) - (forward-line 1) - (back-to-indentation)) - (beginning-of-line) - (setq end (point-marker)) - (goto-char opos) - ;; find begin of paragraph - (back-to-indentation) - (while (and (looking-at "--.*$") - (not (looking-at "--[ \t]*$"))) - (forward-line -1) - (back-to-indentation)) - (forward-line 1) - ;; get indentation to calculate width for filling - (ada-indent-current) - (back-to-indentation) - (setq indent (current-column)) - (setq begin (point-marker))) - - ;; delete old postfix if necessary - (if (and justify - postfix) - (save-excursion - (goto-char begin) - (while (re-search-forward (concat ada-fill-comment-old-postfix - "\n") - end t) - (replace-match "\n")))) - - ;; delete leading whitespace and uncomment - (save-excursion - (goto-char begin) - (beginning-of-line) - (while (re-search-forward "^[ \t]*--[ \t]*" end t) - (replace-match ""))) - - ;; calculate fill width - (setq fill-column (- fill-column indent - (length ada-fill-comment-prefix) - (if postfix - (length ada-fill-comment-postfix) - 0))) - ;; fill paragraph - (fill-region begin (1- end) justify) - (setq fill-column (+ fill-column indent - (length ada-fill-comment-prefix) - (if postfix - (length ada-fill-comment-postfix) - 0))) - ;; find end of second last line - (save-excursion - (goto-char end) - (forward-line -2) - (end-of-line) - (setq end-2 (point-marker))) - - ;; re-comment and re-indent region - (save-excursion - (goto-char begin) - (indent-to indent) - (insert ada-fill-comment-prefix) - (while (re-search-forward "\n" (1- end-2) t) - (replace-match (concat "\n" ada-fill-comment-prefix)) - (beginning-of-line) - (indent-to indent))) - - ;; append postfix if wanted - (if (and justify - postfix - ada-fill-comment-postfix) - (progn - ;; append postfix up to there - (save-excursion - (goto-char begin) - (while (re-search-forward "\n" (1- end-2) t) - (replace-match (concat ada-fill-comment-postfix "\n"))) - - ;; fill last line and append postfix - (end-of-line) - (insert-char ? - (- fill-column - (current-column) - (length ada-fill-comment-postfix))) - (insert ada-fill-comment-postfix)))) - - ;; delete the extra line that gets inserted somehow(??) - (save-excursion - (goto-char (1- end)) - (end-of-line) - (delete-char 1)) - - (message "filling comment paragraph ... done") - (goto-char opos)) - t) - - -;;;--------------------------------;;; -;;; Call External Pretty Printer ;;; -;;;--------------------------------;;; - -(defun ada-call-pretty-printer () - "Calls the external Pretty Printer. -The name is specified in `ada-external-pretty-print-program'. Saves the -current buffer in a directory specified by `ada-tmp-directory', -starts the pretty printer as external process on that file and then -reloads the beautified program in the buffer and cleans up -`ada-tmp-directory'." + (let ((previous-syntax-table (syntax-table)) + (exception-list '())) + (set-syntax-table ada-mode-symbol-syntax-table) + (unless word + (save-excursion + (skip-syntax-backward "w") + (set 'word (buffer-substring-no-properties + (point) (save-excursion (forward-word 1) (point)))))) + + ;; 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 ada-case-exception-file)) + (let ((buffer (current-buffer))) + (find-file (expand-file-name ada-case-exception-file)) + (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))) + + ;; 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) + (add-to-list 'ada-case-exception (cons word t)) + ) + + ;; Save the list in the file + (find-file (expand-file-name ada-case-exception-file)) + (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) + )) + +(defun ada-case-read-exceptions () + "Read the file `ada-case-exception-file' for the list of identifiers that +have special casing" (interactive) - (let ((filename-with-path buffer-file-name) - (curbuf (current-buffer)) - (orgpos (point)) - (mesgbuf nil) ;; for byte-compiling - (file-path (file-name-directory buffer-file-name)) - (filename-without-path (file-name-nondirectory buffer-file-name)) - (tmp-file-with-directory - (concat ada-tmp-directory - (file-name-nondirectory buffer-file-name)))) - ;; - ;; save buffer in temporary file - ;; - (message "saving current buffer to temporary file ...") - (write-file tmp-file-with-directory) - (auto-save-mode nil) - (message "saving current buffer to temporary file ... done") - ;; - ;; call external pretty printer program - ;; - - (message "running external pretty printer ...") - ;; create a temporary buffer for messages of pretty printer - (setq mesgbuf (get-buffer-create "Pretty Printer Messages")) - ;; execute pretty printer on temporary file - (call-process ada-external-pretty-print-program - nil mesgbuf t - tmp-file-with-directory) - ;; display messages if there are some - (if (buffer-modified-p mesgbuf) - ;; show the message buffer - (display-buffer mesgbuf t) - ;; kill the message buffer - (kill-buffer mesgbuf)) - (message "running external pretty printer ... done") - ;; - ;; kill current buffer and load pretty printer output - ;; or restore old buffer - ;; - (if (y-or-n-p - "Really replace current buffer with pretty printer output ? ") - (progn - (set-buffer-modified-p nil) - (kill-buffer curbuf) - (find-file tmp-file-with-directory)) - (message "old buffer contents restored")) - ;; - ;; delete temporary file and restore information of current buffer - ;; - (delete-file tmp-file-with-directory) - (set-visited-file-name filename-with-path) - (auto-save-mode t) - (goto-char orgpos))) - - -;;;--------------- -;;; auto-casing -;;;--------------- - -;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be> -;; modified by RE and MH + (set 'ada-case-exception '()) + (if (file-readable-p (expand-file-name ada-case-exception-file)) + (let ((buffer (current-buffer))) + (find-file (expand-file-name ada-case-exception-file)) + (set-syntax-table ada-mode-symbol-syntax-table) + (widen) + (goto-char (point-min)) + (while (not (eobp)) + (add-to-list 'ada-case-exception + (cons + (buffer-substring-no-properties + (point) (save-excursion (forward-word 1) (point))) + t)) + (forward-line 1)) + (kill-buffer nil) + (set-buffer buffer) + ))) + +(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 the +exceptions defined in `ada-case-exception'" + + (if (or (equal ada-case-exception '()) + (equal (char-after) ?_)) + (funcall ada-case-identifier -1) + + (progn + (let ((end (point)) + (start (save-excursion (skip-syntax-backward "w") + (point))) + match) + ;; If we have an exception, replace the word by the correct casing + (if (set 'match (assoc-ignore-case (buffer-substring start end) + ada-case-exception)) + + (progn + (delete-region start end) + (insert (car match))) + + ;; Else simply recase the word + (funcall ada-case-identifier -1)))))) (defun ada-after-keyword-p () ;; returns t if cursor is after a keyword. (save-excursion (forward-word -1) - (and (save-excursion - (or - (= (point) (point-min)) - (backward-char 1)) - (not (looking-at "_"))) ; (MH) + (and (not (and (char-before) (= (char-before) ?_)));; unless we have a _ (looking-at (concat ada-keywords "[^_]"))))) -(defun ada-in-char-const-p () - ;; Returns t if point is inside a character constant. - ;; We assume to be in a constant if the previous and the next character - ;; are "'". - (save-excursion - (if (> (point) 1) - (and - (progn - (forward-char 1) - (looking-at "'")) - (progn - (forward-char -2) - (looking-at "'"))) - nil))) - - (defun ada-adjust-case (&optional force-identifier) "Adjust the case of the word before the just typed character. -Respect options `ada-case-keyword', `ada-case-identifier', and +Respect options `ada-case-keyword', `ada-case-identifier', and `ada-case-attribute'. If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." ; (MH) - (forward-char -1) - (if (and (> (point) 1) (not (or (ada-in-string-p) - (ada-in-comment-p) - (ada-in-char-const-p)))) - (if (eq (char-syntax (char-after (1- (point)))) ?w) - (if (save-excursion - (forward-word -1) - (or (= (point) (point-min)) - (backward-char 1)) - (looking-at "'")) - (funcall ada-case-attribute -1) - (if (and - (not force-identifier) ; (MH) - (ada-after-keyword-p)) - (funcall ada-case-keyword -1) - (funcall ada-case-identifier -1))))) - (forward-char 1)) - + (let ((previous-syntax-table (syntax-table))) + (set-syntax-table ada-mode-symbol-syntax-table) + + (forward-char -1) + + ;; Do nothing in some cases + (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) + (set-syntax-table previous-syntax-table) + ) + ) (defun ada-adjust-case-interactive (arg) (interactive "P") @@ -996,40 +1237,52 @@ (defun ada-activate-keys-for-case () + (interactive) ;; save original keybindings to allow swapping ret/lfd ;; when casing is activated ;; the 'or ...' is there to be sure that the value will not ;; be changed again when Ada mode is called more than once (MH) (or ada-ret-binding - (setq ada-ret-binding (key-binding "\C-M"))) + (set 'ada-ret-binding (key-binding "\C-M"))) (or ada-lfd-binding - (setq ada-lfd-binding (key-binding "\C-j"))) + (set 'ada-lfd-binding (key-binding "\C-j"))) ;; call case modifying function after certain keys. (mapcar (function (lambda(key) (define-key ada-mode-map (char-to-string key) 'ada-adjust-case-interactive))) '( ?` ?~ ?! ?@ ?# ?$ ?% ?^ ?& ?* ?( ?) ?- ?= ?+ ?[ ?{ ?] ?} - ?_ ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r ))) -;; deleted ?\t from above list + ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r ))) ;; ;; added by MH ;; (defun ada-loose-case-word (&optional arg) - "Capitalizes the first letter and the letters following `_'. -ARG is ignored, it's there to fit the standard casing functions' style." + "Capitalizes the first letter and the letters following `_' for the following +word. Ignores Arg (its there to conform to capitalize-word parameters) +Does not change other letters" + (interactive) (let ((pos (point)) (first t)) - (skip-chars-backward "a-zA-Z0-9_") + (skip-syntax-backward "w") (while (or first (search-forward "_" pos t)) (and first - (setq first nil)) + (set 'first nil)) (insert-char (upcase (following-char)) 1) (delete-char 1)) (goto-char pos))) +(defun ada-capitalize-word (&optional arg) + "Capitalizes the first letter and the letters following '_', and +lower case other letters" + (interactive) + (let ((pos (point))) + (skip-syntax-backward "w") + (modify-syntax-entry ?_ "_") + (capitalize-region (point) pos) + (goto-char pos) + (modify-syntax-entry ?_ "w"))) ;; ;; added by MH @@ -1042,45 +1295,44 @@ (let ((begin nil) (end nil) (keywordp nil) - (attribp nil)) + (attribp nil) + (previous-syntax-table (syntax-table))) + (message "Adjusting case ...") (unwind-protect - (save-excursion - (set-syntax-table ada-mode-symbol-syntax-table) - (goto-char to) - ;; - ;; loop: look for all identifiers, keywords, and attributes - ;; - (while (re-search-backward - "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]" - from - t) - ;; - ;; print status message - ;; - (message "adjusting case ... %5d characters left" (- (point) from)) - (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']")) - (forward-char 1) - (or - ;; do nothing if it is a string or comment - (ada-in-string-or-comment-p) - (progn - ;; - ;; get the identifier or keyword or attribute - ;; - (setq begin (point)) - (setq keywordp (looking-at (concat ada-keywords "[^_]"))) - (skip-chars-forward "a-zA-Z0-9_") - ;; - ;; casing according to user-option - ;; - (if keywordp - (funcall ada-case-keyword -1) - (if attribp - (funcall ada-case-attribute -1) - (funcall ada-case-identifier -1))) - (goto-char begin)))) - (message "adjusting case ... done")) - (set-syntax-table ada-mode-syntax-table)))) + (save-excursion + (set-syntax-table ada-mode-symbol-syntax-table) + (goto-char to) + ;; + ;; loop: look for all identifiers, keywords, and attributes + ;; + (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t) + (set 'end (match-end 1)) + (set 'attribp + (and (> (point) from) + (save-excursion + (forward-char -1) + (set 'attribp (looking-at "'.[^']"))))) + (or + ;; do nothing if it is a string or comment + (ada-in-string-or-comment-p) + (progn + ;; + ;; get the identifier or keyword or attribute + ;; + (set 'begin (point)) + (set 'keywordp (looking-at ada-keywords)) + (goto-char end) + ;; + ;; casing according to user-option + ;; + (if attribp + (funcall ada-case-attribute -1) + (if keywordp + (funcall ada-case-keyword -1) + (ada-adjust-case-identifier))) + (goto-char begin)))) + (message "Adjusting case ... Done")) + (set-syntax-table previous-syntax-table)))) ;; @@ -1096,7 +1348,6 @@ ;;;------------------------;;; ;;; Format Parameter Lists ;;; ;;;------------------------;;; - (defun ada-format-paramlist () "Reformats a parameter list. ATTENTION: 1) Comments inside the list are killed ! @@ -1108,57 +1359,57 @@ (let ((begin nil) (end nil) (delend nil) - (paramlist nil)) + (paramlist nil) + (previous-syntax-table (syntax-table))) (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - ;; check if really inside parameter list - (or (ada-in-paramlist-p) - (error "not in parameter list")) - ;; - ;; find start of current parameter-list - ;; - (ada-search-ignore-string-comment + (progn + (set-syntax-table ada-mode-symbol-syntax-table) + + ;; check if really inside parameter list + (or (ada-in-paramlist-p) + (error "not in parameter list")) + ;; + ;; find start of current parameter-list + ;; + (ada-search-ignore-string-comment (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) - (ada-search-ignore-string-comment "(" nil nil t) - (backward-char 1) - (setq begin (point)) - - ;; - ;; find end of parameter-list - ;; - (forward-sexp 1) - (setq delend (point)) - (delete-char -1) - - ;; - ;; find end of last parameter-declaration - ;; - (ada-search-ignore-string-comment "[^ \t\n]" t nil t) - (forward-char 1) - (setq end (point)) - - ;; - ;; build a list of all elements of the parameter-list - ;; - (setq paramlist (ada-scan-paramlist (1+ begin) end)) - - ;; - ;; delete the original parameter-list - ;; - (delete-region begin (1- delend)) - - ;; - ;; insert the new parameter-list - ;; - (goto-char begin) - (ada-insert-paramlist paramlist)) + (down-list 1) + (backward-char 1) + (set 'begin (point)) + + ;; + ;; find end of parameter-list + ;; + (forward-sexp 1) + (set 'delend (point)) + (delete-char -1) + + ;; + ;; find end of last parameter-declaration + ;; + (forward-comment -1000) + (set 'end (point)) + + ;; + ;; build a list of all elements of the parameter-list + ;; + (set 'paramlist (ada-scan-paramlist (1+ begin) end)) + + ;; + ;; delete the original parameter-list + ;; + (delete-region begin (1- delend)) + + ;; + ;; insert the new parameter-list + ;; + (goto-char begin) + (ada-insert-paramlist paramlist)) ;; ;; restore syntax-table ;; - (set-syntax-table ada-mode-syntax-table) + (set-syntax-table previous-syntax-table) ))) @@ -1190,66 +1441,59 @@ ;; find first character of parameter-declaration ;; (ada-goto-next-non-ws) - (setq apos (point)) + (set 'apos (point)) ;; ;; find last character of parameter-declaration ;; - (if (setq match-cons - (ada-search-ignore-string-comment "[ \t\n]*;" nil end t)) + (if (set 'match-cons + (ada-search-ignore-string-comment "[ \t\n]*;" nil end t)) (progn - (setq epos (car match-cons)) - (setq semipos (cdr match-cons))) - (setq epos end)) + (set 'epos (car match-cons)) + (set 'semipos (cdr match-cons))) + (set 'epos end)) ;; ;; read name(s) of parameter(s) ;; (goto-char apos) - (looking-at "\\([a-zA-Z0-9_, \t\n]*[a-zA-Z0-9_]\\)[ \t\n]*:[^=]") - - (setq param (list (buffer-substring (match-beginning 1) - (match-end 1)))) - (ada-search-ignore-string-comment ":" nil epos t) + (looking-at "\\(\\(\\sw\\|[_, \t\n]\\)*\\(\\sw\\|_\\)\\)[ \t\n]*:[^=]") + + (set 'param (list (match-string 1))) + (ada-search-ignore-string-comment ":" nil epos t 'search-forward) ;; ;; look for 'in' ;; - (setq apos (point)) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment "\\<in\\>" - nil - epos - t))))) + (set 'apos (point)) + (set 'param + (append param + (list + (consp + (ada-search-ignore-string-comment + "in" nil epos t 'word-search-forward))))) ;; ;; look for 'out' ;; (goto-char apos) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment "\\<out\\>" - nil - epos - t))))) + (set 'param + (append param + (list + (consp + (ada-search-ignore-string-comment + "out" nil epos t 'word-search-forward))))) ;; ;; look for 'access' ;; (goto-char apos) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment "\\<access\\>" - nil - epos - t))))) + (set 'param + (append param + (list + (consp + (ada-search-ignore-string-comment + "access" nil epos t 'word-search-forward))))) ;; ;; skip 'in'/'out'/'access' @@ -1261,43 +1505,38 @@ (ada-goto-next-non-ws)) ;; - ;; read type of parameter + ;; read type of parameter ;; - (looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>") - (setq param - (append param - (list - (buffer-substring (match-beginning 0) - (match-end 0))))) + (looking-at "\\<\\(\\sw\\|[_.']\\)+\\>") + (set 'param + (append param + (list (match-string 0)))) ;; ;; read default-expression, if there is one ;; - (goto-char (setq apos (match-end 0))) - (setq param - (append param - (list - (if (setq match-cons - (ada-search-ignore-string-comment ":=" - nil - epos - t)) - (buffer-substring (car match-cons) - epos) - nil)))) + (goto-char (set 'apos (match-end 0))) + (set 'param + (append param + (list + (if (set 'match-cons + (ada-search-ignore-string-comment + ":=" nil epos t 'search-forward)) + (buffer-substring (car match-cons) epos) + nil)))) ;; ;; add this parameter-declaration to the list ;; - (setq paramlist (append paramlist (list param))) + (set 'paramlist (append paramlist (list param))) ;; ;; check if it was the last parameter ;; (if (eq epos end) - (setq notend nil) + (set 'notend nil) (goto-char semipos)) - ) ; end of loop + ) ; end of loop (reverse paramlist))) @@ -1313,53 +1552,52 @@ (outp nil) (accessp nil) (column nil) - (orgpoint 0) (firstcol nil)) ;; ;; loop until last parameter ;; (while (not (zerop i)) - (setq i (1- i)) + (set 'i (1- i)) ;; ;; get max length of parameter-name ;; - (setq parlen - (if (<= parlen (setq temp - (length (nth 0 (nth i paramlist))))) - temp - parlen)) + (set 'parlen + (if (<= parlen (set 'temp + (length (nth 0 (nth i paramlist))))) + temp + parlen)) ;; ;; get max length of type-name ;; - (setq typlen - (if (<= typlen (setq temp - (length (nth 4 (nth i paramlist))))) - temp - typlen)) + (set 'typlen + (if (<= typlen (set 'temp + (length (nth 4 (nth i paramlist))))) + temp + typlen)) ;; ;; is there any 'in' ? ;; - (setq inp - (or inp - (nth 1 (nth i paramlist)))) + (set 'inp + (or inp + (nth 1 (nth i paramlist)))) ;; ;; is there any 'out' ? ;; - (setq outp - (or outp - (nth 2 (nth i paramlist)))) + (set 'outp + (or outp + (nth 2 (nth i paramlist)))) ;; ;; is there any 'access' ? ;; - (setq accessp - (or accessp - (nth 3 (nth i paramlist))))) ; end of loop + (set 'accessp + (or accessp + (nth 3 (nth i paramlist))))) ; end of loop ;; ;; does paramlist already start on a separate line ? @@ -1368,31 +1606,35 @@ (re-search-backward "^.\\|[^ \t]" nil t) (looking-at "^.")) ;; yes => re-indent it - (ada-indent-current) + (progn + (ada-indent-current) + (save-excursion + (if (looking-at "\\(is\\|return\\)") + (replace-match " \\1")))) ;; - ;; no => insert newline and indent it + ;; no => insert it where we are after removing any whitespace ;; - (progn - (ada-indent-current) - (newline) - (delete-horizontal-space) - (setq orgpoint (point)) - (setq column (save-excursion - (funcall (ada-indent-function) orgpoint))) - (indent-to column) - )) + (fixup-whitespace) + (save-excursion + (cond + ((looking-at "[ \t]*\\(\n\\|;\\)") + (replace-match "\\1")) + ((looking-at "[ \t]*\\(is\\|return\\)") + (replace-match " \\1")))) + (insert " ")) (insert "(") - - (setq firstcol (current-column)) - (setq i (length paramlist)) + (ada-indent-current) + + (set 'firstcol (current-column)) + (set 'i (length paramlist)) ;; ;; loop until last parameter ;; (while (not (zerop i)) - (setq i (1- i)) - (setq column firstcol) + (set 'i (1- i)) + (set 'column firstcol) ;; ;; insert parameter-name, space and colon @@ -1400,7 +1642,7 @@ (insert (nth 0 (nth i paramlist))) (indent-to (+ column parlen 1)) (insert ": ") - (setq column (current-column)) + (set 'column (current-column)) ;; ;; insert 'in' or space @@ -1430,7 +1672,7 @@ (if (nth 3 (nth i paramlist)) (insert "access ")) - (setq column (current-column)) + (set 'column (current-column)) ;; ;; insert type-name and, if necessary, space and default-expression @@ -1444,23 +1686,20 @@ ;; ;; check if it was the last parameter ;; - (if (not (zerop i)) - ;; no => insert ';' and newline and indent - (progn - (insert ";") - (newline) - (indent-to firstcol)) - ;; yes - (insert ")")) - - ) ; end of loop + (if (zerop i) + (insert ")") + ;; no => insert ';' and newline and indent + (insert ";") + (newline) + (indent-to firstcol)) + ) ; end of loop ;; - ;; if anything follows, except semicolon: + ;; if anything follows, except semicolon, newline, is or return ;; put it in a new line and indent it ;; - (if (not (looking-at "[ \t]*[;\n]")) - (ada-indent-newline-indent)) + (unless (looking-at "[ \t]*\\(;\\|\n\\|is\\|return\\)") + (ada-indent-newline-indent)) )) @@ -1468,117 +1707,114 @@ ;;;----------------------------;;; ;;; Move To Matching Start/End ;;; ;;;----------------------------;;; - (defun ada-move-to-start () "Moves point to the matching start of the current Ada structure." (interactive) - (let ((pos (point))) + (let ((pos (point)) + (previous-syntax-table (syntax-table))) (unwind-protect - (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 ...;' - ;; or if an error occurs during processing - ;; - (or - (ada-in-string-or-comment-p) - (and (progn - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (error "not on end ...;"))) - (ada-goto-matching-start 1) - (setq pos (point)) - - ;; - ;; on 'begin' => go on, according to user option - ;; - ada-move-to-declaration - (looking-at "\\<begin\\>") - (ada-goto-matching-decl-start) - (setq pos (point)))) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos) - (message "searching for block start ... done")) + (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 ...;' + ;; or if an error occurs during processing + ;; + (or + (ada-in-string-or-comment-p) + (and (progn + (or (looking-at "[ \t]*\\<end\\>") + (backward-word 1)) + (or (looking-at "[ \t]*\\<end\\>") + (backward-word 1)) + (or (looking-at "[ \t]*\\<end\\>") + (error "not on end ...;"))) + (ada-goto-matching-start 1) + (set 'pos (point)) + + ;; + ;; on 'begin' => go on, according to user option + ;; + ada-move-to-declaration + (looking-at "\\<begin\\>") + (ada-goto-matching-decl-start) + (set 'pos (point)))) + + ) ; end of save-excursion + + ;; now really move to the found position + (goto-char pos) + (message "searching for block start ... done")) ;; ;; restore syntax-table ;; - (set-syntax-table ada-mode-syntax-table)))) - + (set-syntax-table previous-syntax-table)))) (defun ada-move-to-end () "Moves point to the matching end of the current block around point. Moves to 'begin' if in a declarative part." (interactive) (let ((pos (point)) - (decstart nil) - (packdecl nil)) + (previous-syntax-table (syntax-table))) (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (message "searching for block end ...") - (save-excursion - - (forward-char 1) - (cond - ;; directly on 'begin' - ((save-excursion - (ada-goto-previous-word) - (looking-at "\\<begin\\>")) - (ada-goto-matching-end 1)) - ;; on first line of defun declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<function\\>\\|\\<procedure\\>" ))) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; on first line of task declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<task\\>" ) - (forward-word 1) - (ada-search-ignore-string-comment "[^ \n\t]") - (not (backward-char 1)) - (looking-at "\\<body\\>"))) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; accept block start - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<accept\\>" ))) - (ada-goto-matching-end 0)) - ;; package start - ((save-excursion - (and (ada-goto-matching-decl-start t) - (looking-at "\\<package\\>"))) - (ada-goto-matching-end 1)) - ;; inside a 'begin' ... 'end' block - ((save-excursion - (ada-goto-matching-decl-start t)) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; (hopefully ;-) everything else - (t - (ada-goto-matching-end 1))) - (setq pos (point)) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos) - (message "searching for block end ... done")) - + (progn + (set-syntax-table ada-mode-symbol-syntax-table) + + (message "searching for block end ...") + (save-excursion + + (forward-char 1) + (cond + ;; directly on 'begin' + ((save-excursion + (ada-goto-previous-word) + (looking-at "\\<begin\\>")) + (ada-goto-matching-end 1)) + ;; on first line of defun declaration + ((save-excursion + (and (ada-goto-stmt-start) + (looking-at "\\<function\\>\\|\\<procedure\\>" ))) + (ada-search-ignore-string-comment "begin" nil nil nil 'word-search-forward)) + ;; on first line of task declaration + ((save-excursion + (and (ada-goto-stmt-start) + (looking-at "\\<task\\>" ) + (forward-word 1) + (ada-goto-next-non-ws) + (looking-at "\\<body\\>"))) + (ada-search-ignore-string-comment "begin" nil nil nil 'word-search-forward)) + ;; accept block start + ((save-excursion + (and (ada-goto-stmt-start) + (looking-at "\\<accept\\>" ))) + (ada-goto-matching-end 0)) + ;; package start + ((save-excursion + (and (ada-goto-matching-decl-start t) + (looking-at "\\<package\\>"))) + (ada-goto-matching-end 1)) + ;; inside a 'begin' ... 'end' block + ((save-excursion + (ada-goto-matching-decl-start t)) + (ada-search-ignore-string-comment "begin" nil nil nil 'word-search-forward)) + ;; (hopefully ;-) everything else + (t + (ada-goto-matching-end 1))) + (set 'pos (point)) + + ) ; end of save-excursion + + ;; now really move to the found position + (goto-char pos) + (message "searching for block end ... done")) + ;; ;; restore syntax-table ;; - (set-syntax-table ada-mode-syntax-table)))) + (set-syntax-table previous-syntax-table)))) ;;;-----------------------------;;; @@ -1586,33 +1822,27 @@ ;;;-----------------------------;;; ;; ---- main functions for indentation - (defun ada-indent-region (beg end) "Indents the region using `ada-indent-current' on each line." (interactive "*r") (goto-char beg) (let ((block-done 0) - (lines-remaining (count-lines beg end)) - (msg (format "indenting %4d lines %%4d lines remaining ..." - (count-lines beg end))) + (lines-remaining (count-lines beg end)) + (msg (format "indenting %4d lines %%4d lines remaining ..." + (count-lines beg end))) (endmark (copy-marker end))) ;; catch errors while indenting - (condition-case err - (while (< (point) endmark) - (if (> block-done 9) - (progn (message msg lines-remaining) - (setq block-done 0))) - (if (looking-at "^$") nil - (ada-indent-current)) - (forward-line 1) - (setq block-done (1+ block-done)) - (setq lines-remaining (1- lines-remaining))) - ;; show line number where the error occurred - (error - (error "line %d: %s" (1+ (count-lines (point-min) (point))) err) nil)) + (while (< (point) endmark) + (if (> block-done 39) + (progn (message msg lines-remaining) + (set 'block-done 0))) + (if (looking-at "^$") nil + (ada-indent-current)) + (forward-line 1) + (set 'block-done (1+ block-done)) + (set 'lines-remaining (1- lines-remaining))) (message "indenting ... done"))) - (defun ada-indent-newline-indent () "Indents the current line, inserts a newline and then indents the new line." (interactive "*") @@ -1620,104 +1850,151 @@ (newline) (ada-indent-current)) +(defun ada-indent-newline-indent-conditional () + "If `ada-indent-after-return' is non-nil, then indents the current line, +insert a newline and indents the newline. +If `ada-indent-after-return' is nil then inserts a newline and indents the +newline. +This function is intended to be bound to the \C-m and \C-j keys" + (interactive "*") + (if ada-indent-after-return (ada-indent-current)) + (newline) + (ada-indent-current)) + +(defun ada-justified-indent-current () + "Indent the current line and explains how it was chosen" + (interactive) + + (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) + " + "))) + (save-excursion + (goto-char (car cur-indent)) + (sit-for 1)))) (defun ada-indent-current () "Indents current line as Ada code. -This works by two steps: - 1) It moves point to the end of the previous code line. - Then it calls the function to calculate the indentation for the - following line as if a newline would be inserted there. - The calculated column # is saved and the old position of point - is restored. - 2) Then another function is called to calculate the indentation for - the current line, based on the previously calculated column #." +Each of these steps returns a two element list: + - position of reference in the buffer + - offset to indent from this position (can also be a symbol or a list + that are evaluated" (interactive) - - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (let ((line-end) - (orgpoint (point-marker)) - (cur-indent) - (prev-indent) - (prevline t)) - - ;; - ;; first step - ;; + (let ((previous-syntax-table (syntax-table)) + (orgpoint (point-marker)) + cur-indent tmp-indent + prev-indent) + + (set-syntax-table ada-mode-symbol-syntax-table) + + ;; This need to be done here so that the advice is not always activated + ;; (this might interact badly with other modes) + (if ada-xemacs + (ad-activate 'parse-partial-sexp t)) + + (unwind-protect + (progn + (save-excursion - (if (ada-goto-prev-nonblank-line t) - ;; - ;; we are not in the first accessible line in the buffer - ;; - (progn - ;;(end-of-line) - ;;(forward-char 1) - ;; we are already at the BOL - (forward-line 1) - (setq line-end (point)) - (setq prev-indent - (save-excursion - (funcall (ada-indent-function) line-end)))) - (progn ; first line of buffer -> set indent - (beginning-of-line) ; to 0 - (delete-horizontal-space) - (setq prevline nil)))) - - (if prevline - ;; - ;; we are not in the first accessible line in the buffer - ;; - (progn - ;; - ;; second step - ;; - (back-to-indentation) - (setq cur-indent (ada-get-current-indent prev-indent)) - ;; only reindent if indentation is different then the current - (if (= (current-column) cur-indent) - nil - (delete-horizontal-space) - (indent-to cur-indent)) - ;; - ;; restore position of point - ;; - (goto-char orgpoint) - (if (< (current-column) (current-indentation)) - (back-to-indentation)))))) - + (set 'cur-indent + ;; Not First line in the buffer ? + + (if (save-excursion (zerop (forward-line -1))) + (progn + (back-to-indentation) + (ada-get-current-indent)) + + ;; first line in the buffer + (list (point-min) 0)))) + + ;; Evaluate the list to get the column to indent to + ;; prev-indent contains the column to indent to + (set 'prev-indent (save-excursion (goto-char (car cur-indent)) (current-column))) + (set 'tmp-indent (cdr cur-indent)) + (while (not (null tmp-indent)) + (cond + ((numberp (car tmp-indent)) + (set 'prev-indent (+ prev-indent (car tmp-indent)))) + (t + (set 'prev-indent (+ prev-indent (eval (car tmp-indent))))) + ) + (set 'tmp-indent (cdr tmp-indent))) + + ;; only reindent if indentation is different then the current + (if (= (save-excursion (back-to-indentation) (current-column)) prev-indent) + nil + (beginning-of-line) + (delete-horizontal-space) + (indent-to prev-indent)) + ;; + ;; restore position of point + ;; + (goto-char orgpoint) + (if (< (current-column) (current-indentation)) + (back-to-indentation)))) ;; ;; restore syntax-table ;; - (set-syntax-table ada-mode-syntax-table))) - - -(defun ada-get-current-indent (prev-indent) - ;; Returns the column # to indent the current line to. - ;; PREV-INDENT is the indentation resulting from the previous lines. - (let ((column nil) - (pos nil) - (match-cons nil)) - + (if ada-xemacs + (ad-deactivate 'parse-partial-sexp)) + (set-syntax-table previous-syntax-table) + cur-indent + )) + + +(defun ada-get-current-indent () + "Returns the column number to indent the current line to. + +Returns a list of two elements (same as prev-indent): + - Position in the cursor that is used as a reference (its columns + is used) + - variable used to calculate the indentation from position" + + (let (column + pos + match-cons + (orgpoint (save-excursion + (beginning-of-line) + (forward-comment -10000) + (forward-line 1) + (point)))) (cond ;; + ;; preprocessor line (gnatprep) + ;; + ((and (equal ada-which-compiler 'gnat) + (looking-at "#[ \t]*\\(if\\|else\\|elsif\\|end[ \t]*if\\)")) + (list (save-excursion (beginning-of-line) (point)) 0)) + + ;; ;; in open parenthesis, but not in parameter-list ;; ((and ada-indent-to-open-paren (not (ada-in-paramlist-p)) - (setq column (ada-in-open-paren-p))) + (set 'column (ada-in-open-paren-p))) ;; check if we have something like this (Table_Component_Type => - ;; Source_File_Record,) + ;; Source_File_Record) (save-excursion - (if (and (ada-search-ignore-string-comment "[^ \t]" t nil) - (looking-at "\n") - (ada-search-ignore-string-comment "[^ \t\n]" t nil) - (looking-at ">")) - (setq column (+ ada-broken-indent column)))) - column) + (if (and (skip-chars-backward " \t") + (= (char-before) ?\n) + (not (forward-comment -10000)) + (= (char-before) ?>)) + (list column 'ada-broken-indent);; ??? Could use a different variable + (list column 0)))) ;; ;; end @@ -1731,111 +2008,104 @@ ;; found 'loop' => skip back to 'while' or 'for' ;; if 'loop' is not on a separate line ;; - (if (and - (looking-at "\\<loop\\>") - (save-excursion - (back-to-indentation) - (not (looking-at "\\<loop\\>")))) + (if (save-excursion + (beginning-of-line) + (looking-at ".+\\<loop\\>")) (if (save-excursion (and - (setq match-cons - (ada-search-ignore-string-comment - ada-loop-start-re t nil)) + (set 'match-cons + (ada-search-ignore-string-comment ada-loop-start-re t)) (not (looking-at "\\<loop\\>")))) (progn (goto-char (car match-cons)) (save-excursion (beginning-of-line) (if (looking-at ada-named-block-re) - (setq label (- ada-label-indent))))))) - - (+ (current-indentation) label)))) + (set 'label (- ada-label-indent))))))) + + (list (+ (save-excursion (back-to-indentation) (point)) label) 0)))) ;; ;; exception ;; ((looking-at "\\<exception\\>") (save-excursion (ada-goto-matching-start 1) - (current-indentation))) + (list (save-excursion (back-to-indentation) (point)) 0))) ;; ;; when ;; ((looking-at "\\<when\\>") (save-excursion (ada-goto-matching-start 1) - (+ (current-indentation) ada-when-indent))) + (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent))) ;; ;; else ;; ((looking-at "\\<else\\>") - (if (save-excursion - (ada-goto-previous-word) - (looking-at "\\<or\\>")) - prev-indent + (if (save-excursion (ada-goto-previous-word) + (looking-at "\\<or\\>")) + (ada-indent-on-previous-lines nil orgpoint orgpoint) (save-excursion (ada-goto-matching-start 1 nil t) - (current-indentation)))) + (list (progn (back-to-indentation) (point)) 0)))) ;; ;; elsif ;; ((looking-at "\\<elsif\\>") (save-excursion (ada-goto-matching-start 1 nil t) - (current-indentation))) + (list (progn (back-to-indentation) (point)) 0))) ;; ;; then ;; ((looking-at "\\<then\\>") - (if (save-excursion - (ada-goto-previous-word) - (looking-at "\\<and\\>")) - prev-indent + (if (save-excursion (ada-goto-previous-word) + (looking-at "\\<and\\>")) + (ada-indent-on-previous-lines nil orgpoint orgpoint) (save-excursion - (ada-search-ignore-string-comment "\\<elsif\\>\\|\\<if\\>" t nil) - (+ (current-indentation) ada-stmt-end-indent)))) + ;; Select has been added for the statement: "select ... then abort" + (ada-search-ignore-string-comment "\\<\\(elsif\\|if\\|select\\)\\>" t nil) + (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))) ;; ;; loop ;; ((looking-at "\\<loop\\>") - (setq pos (point)) + (set 'pos (point)) (save-excursion (goto-char (match-end 0)) (ada-goto-stmt-start) - (if (looking-at "\\<loop\\>\\|\\<if\\>") - prev-indent - (progn - (if (not (looking-at ada-loop-start-re)) - (ada-search-ignore-string-comment ada-loop-start-re - nil pos)) - (if (looking-at "\\<loop\\>") - prev-indent - (+ (current-indentation) ada-stmt-end-indent)))))) + (if (looking-at "\\<\\(loop\\|if\\)\\>") + (ada-indent-on-previous-lines nil orgpoint orgpoint) + (unless (looking-at ada-loop-start-re) + (ada-search-ignore-string-comment ada-loop-start-re + nil pos)) + (if (looking-at "\\<loop\\>") + (ada-indent-on-previous-lines nil orgpoint orgpoint) + (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))) ;; ;; begin ;; ((looking-at "\\<begin\\>") (save-excursion (if (ada-goto-matching-decl-start t) - (current-indentation) - prev-indent))) + (list (progn (back-to-indentation) (point)) 0) + (ada-indent-on-previous-lines nil orgpoint orgpoint)))) ;; ;; is ;; ((looking-at "\\<is\\>") - (if (and - ada-indent-is-separate - (save-excursion - (goto-char (match-end 0)) - (ada-goto-next-non-ws (save-excursion - (end-of-line) - (point))) - (looking-at "\\<abstract\\>\\|\\<separate\\>"))) + (if (and ada-indent-is-separate + (save-excursion + (goto-char (match-end 0)) + (ada-goto-next-non-ws (save-excursion (end-of-line) + (point))) + (looking-at "\\<abstract\\>\\|\\<separate\\>"))) (save-excursion (ada-goto-stmt-start) - (+ (current-indentation) ada-indent)) + (list (progn (back-to-indentation) (point)) 'ada-indent)) (save-excursion (ada-goto-stmt-start) - (+ (current-indentation) ada-stmt-end-indent)))) + (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))) ;; ;; record ;; @@ -1844,46 +2114,60 @@ (ada-search-ignore-string-comment "\\<\\(type\\|use\\)\\>" t nil) (if (looking-at "\\<use\\>") - (ada-search-ignore-string-comment "\\<for\\>" t nil)) - (+ (current-indentation) ada-indent-record-rel-type))) + (ada-search-ignore-string-comment "for" t nil nil 'word-search-backward)) + (list (progn (back-to-indentation) (point)) 'ada-indent-record-rel-type))) ;; - ;; or as statement-start + ;; 'or' as statement-start + ;; 'private' as statement-start ;; - ((ada-looking-at-semi-or) + ((or (ada-looking-at-semi-or) + (ada-looking-at-semi-private)) (save-excursion (ada-goto-matching-start 1) - (current-indentation))) - ;; - ;; private as statement-start - ;; - ((ada-looking-at-semi-private) - (save-excursion - (ada-goto-matching-decl-start) - (current-indentation))) + (list (progn (back-to-indentation) (point)) 0))) ;; ;; new/abstract/separate ;; ((looking-at "\\<\\(new\\|abstract\\|separate\\)\\>") - (- prev-indent ada-indent (- ada-broken-indent))) + (ada-indent-on-previous-lines nil orgpoint orgpoint)) ;; ;; return ;; ((looking-at "\\<return\\>") (save-excursion - (forward-sexp -1) - (if (and (looking-at "(") + (forward-comment -1000) + (if (= (char-before) ?\)) + (forward-sexp -1) + (forward-word -1)) + + ;; If there is a parameter list, and we have a function declaration + (if (and (= (char-after) ?\() (save-excursion (backward-sexp 2) (looking-at "\\<function\\>"))) - (1+ (current-column)) - prev-indent))) + + ;; The indentation depends of the value of ada-indent-return + (if (<= ada-indent-return 0) + (list (point) (- ada-indent-return)) + (list (progn (backward-sexp 2) (point)) ada-indent-return)) + + ;; 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 (> ada-indent-return 0) + (save-excursion (forward-word -1) + (looking-at "\\<function\\>"))) + (list (progn (forward-word -1) (point)) ada-indent-return) + + ;; Else... + (ada-indent-on-previous-lines nil orgpoint orgpoint))))) ;; ;; do ;; ((looking-at "\\<do\\>") (save-excursion (ada-goto-stmt-start) - (+ (current-indentation) ada-stmt-end-indent))) + (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))) ;; ;; package/function/procedure ;; @@ -1896,163 +2180,178 @@ ;; look for 'generic' (if (and (ada-goto-matching-decl-start t) (looking-at "generic")) - (current-column) - prev-indent))) + (list (progn (back-to-indentation) (point)) 0) + (ada-indent-on-previous-lines nil orgpoint orgpoint)))) ;; ;; label ;; - ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*:[^=]") + ((looking-at "\\<\\(\\sw\\|_\\)+[ \t\n]*:[^=]") (if (ada-in-decl-p) - prev-indent - (+ prev-indent ada-label-indent))) + (ada-indent-on-previous-lines nil orgpoint orgpoint) + (set 'pos (ada-indent-on-previous-lines nil orgpoint orgpoint)) + (list (car pos) + (cadr pos) + 'ada-label-indent))) ;; ;; identifier and other noindent-statements ;; - ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*") - prev-indent) + ((looking-at "\\<\\(\\sw\\|_\\)+[ \t\n]*") + (ada-indent-on-previous-lines nil orgpoint orgpoint)) ;; ;; beginning of a parameter list ;; - ((looking-at "(") - prev-indent) + ((and (not (eobp)) (= (char-after) ?\()) + (ada-indent-on-previous-lines nil orgpoint orgpoint)) ;; ;; end of a parameter list ;; - ((looking-at ")") + ((and (not (eobp)) (= (char-after) ?\))) (save-excursion (forward-char 1) (backward-sexp 1) - (current-column))) + (list (point) 0))) ;; ;; comment ;; ((looking-at "--") (if ada-indent-comment-as-code - prev-indent - (current-indentation))) + ;; If previous line is a comment, indent likewise + (save-excursion + (forward-line -1) + (beginning-of-line) + (if (looking-at "[ \t]*--") + (list (progn (back-to-indentation) (point)) 0) + (ada-indent-on-previous-lines nil orgpoint orgpoint))) + (list (save-excursion (back-to-indentation) (point)) 0))) ;; ;; unknown syntax - maybe this should signal an error ? ;; (t - prev-indent)))) - - -(defun ada-indent-function (&optional nomove) - ;; Returns the function to calculate the indentation for the current - ;; line according to the previous statement, ignoring the contents - ;; of the current line after point. Moves point to the beginning of - ;; the current statement, if NOMOVE is nil. - - (let ((orgpoint (point)) - (func nil)) + (ada-indent-on-previous-lines nil orgpoint orgpoint))))) + +(defun ada-indent-on-previous-lines (&optional nomove orgpoint initial-pos) + "Calculate the indentation of the current line, based on the previous lines +in the buffer. This function does not pay any attention to the current line, +since this is the role of the second step in the indentation + (see ada-get-current-indent). + +Returns a two element list: + - position of reference in the buffer + - offset to indent from this position (can also be a symbol or a list + that are evaluated) +Moves point to the beginning of the current statement, if NOMOVE is nil." + (if initial-pos + (goto-char initial-pos)) + (let ((oldpoint (point)) + result) ;; - ;; inside a parameter-list + ;; Is inside a parameter-list ? ;; (if (ada-in-paramlist-p) - (setq func 'ada-get-indent-paramlist) - (progn - ;; - ;; move to beginning of current statement - ;; - (if (not nomove) - (ada-goto-stmt-start)) - ;; - ;; no beginning found => don't change indentation - ;; - (if (and - (eq orgpoint (point)) - (not nomove)) - (setq func 'ada-get-indent-nochange) - - (cond - ;; - ((and - ada-indent-to-open-paren - (ada-in-open-paren-p)) - (setq func 'ada-get-indent-open-paren)) - ;; - ((looking-at "\\<end\\>") - (setq func 'ada-get-indent-end)) - ;; - ((looking-at ada-loop-start-re) - (setq func 'ada-get-indent-loop)) - ;; - ((looking-at ada-subprog-start-re) - (setq func 'ada-get-indent-subprog)) - ;; - ((looking-at ada-block-start-re) - (setq func 'ada-get-indent-block-start)) - ;; - ((looking-at "\\<type\\>") - (setq func 'ada-get-indent-type)) - ;; - ((looking-at "\\<\\(els\\)?if\\>") - (setq func 'ada-get-indent-if)) - ;; - ((looking-at "\\<case\\>") - (setq func 'ada-get-indent-case)) - ;; - ((looking-at "\\<when\\>") - (setq func 'ada-get-indent-when)) - ;; - ((looking-at "--") - (setq func 'ada-get-indent-comment)) - ;; - ((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]") - (setq func 'ada-get-indent-label)) - ;; - ((looking-at "\\<separate\\>") - (setq func 'ada-get-indent-nochange)) - (t - (setq func 'ada-get-indent-noindent)))))) - - func)) + (set 'result (ada-get-indent-paramlist orgpoint)) + + ;; + ;; move to beginning of current statement + ;; + (unless nomove + (ada-goto-stmt-start)) + + (unless result + (progn + ;; + ;; no beginning found => don't change indentation + ;; + (if (and (eq oldpoint (point)) + (not nomove)) + (set 'result (ada-get-indent-nochange orgpoint)) + + (cond + ;; + ((and + ada-indent-to-open-paren + (ada-in-open-paren-p)) + (set 'result (ada-get-indent-open-paren orgpoint))) + ;; + ((looking-at "end\\>") + (set 'result (ada-get-indent-end orgpoint))) + ;; + ((looking-at ada-loop-start-re) + (set 'result (ada-get-indent-loop orgpoint))) + ;; + ((looking-at ada-subprog-start-re) + (set 'result (ada-get-indent-subprog orgpoint))) + ;; + ((looking-at ada-block-start-re) + (set 'result (ada-get-indent-block-start orgpoint))) + ;; + ((looking-at "\\(sub\\)?type\\>") + (set 'result (ada-get-indent-type orgpoint))) + ;; + ((looking-at "\\(els\\)?if\\>") + (set 'result (ada-get-indent-if orgpoint))) + ;; + ((looking-at "case\\>") + (set 'result (ada-get-indent-case orgpoint))) + ;; + ((looking-at "when\\>") + (set 'result (ada-get-indent-when orgpoint))) + ;; + ((looking-at "\\(\\sw\\|_\\)+[ \t\n]*:[^=]") + (set 'result (ada-get-indent-label orgpoint))) + ;; + ((looking-at "separate\\>") + (set 'result (ada-get-indent-nochange orgpoint))) + (t + (set 'result (ada-get-indent-noindent orgpoint)))))))) + + result)) ;; ---- functions to return indentation for special cases (defun ada-get-indent-open-paren (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be behind an open parenthesis not yet closed. - (ada-in-open-paren-p)) + "Returns the two element list for the indentation, when point is +behind an open parenthesis not yet closed" + (list (ada-in-open-paren-p) 0)) (defun ada-get-indent-nochange (orgpoint) - ;; Returns the indentation (column #) of the current line. + "Returns the two element list for the indentation of the current line" (save-excursion (forward-line -1) - (current-indentation))) + (list (progn (back-to-indentation) (point)) 0))) (defun ada-get-indent-paramlist (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be inside a parameter-list. + "Returns the classical two position list for indentation for the new line +after ORGPOINT. +Assumes point to be inside a parameter list" (save-excursion (ada-search-ignore-string-comment "[^ \t\n]" t nil t) (cond ;; ;; in front of the first parameter ;; - ((looking-at "(") + ((= (char-after) ?\() (goto-char (match-end 0)) - (current-column)) + (list (point) 0)) ;; ;; in front of another parameter ;; - ((looking-at ";") + ((= (char-after) ?\;) (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) (ada-goto-next-non-ws) - (current-column)) + (list (point) 0)) ;; ;; inside a parameter declaration ;; (t (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) (ada-goto-next-non-ws) - (+ (current-column) ada-broken-indent))))) - - -(defun ada-get-indent-end (orgpoint) + (list (point) 'ada-broken-indent))))) + + +(defun ada-get-indent-end (orgpoint &optional do-not-check-start) ;; Returns the indentation (column #) for the new line after ORGPOINT. ;; Assumes point to be at the beginning of an end-statement. ;; Therefore it has to find the corresponding start. This can be a little @@ -2065,7 +2364,7 @@ ;; is the line already terminated by ';' ? ;; (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) + (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward)) ;; ;; yes, look what's following 'end' ;; @@ -2073,206 +2372,185 @@ (forward-word 1) (ada-goto-next-non-ws) (cond + ((looking-at "\\<\\(loop\\|select\\|if\\|case\\)\\>") + (unless do-not-check-start + (save-excursion (ada-check-matching-start (match-string 0)))) + (list (save-excursion (back-to-indentation) (point)) 0)) + ;; ;; loop/select/if/case/record/select ;; - ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|record\\)\\>") + ((looking-at "\\<record\\>") (save-excursion - (ada-check-matching-start - (buffer-substring (match-beginning 0) - (match-end 0))) - (if (looking-at "\\<\\(loop\\|record\\)\\>") - (progn - (forward-word 1) - (ada-goto-stmt-start))) - ;; a label ? => skip it - (if (looking-at ada-named-block-re) - (progn - (setq label (- ada-label-indent)) - (goto-char (match-end 0)) - (ada-goto-next-non-ws))) - ;; really looking-at the right thing ? - (or (looking-at (concat "\\<\\(" - "loop\\|select\\|if\\|case\\|" - "record\\|while\\|type\\)\\>")) - (progn - (ada-search-ignore-string-comment - (concat "\\<\\(" - "loop\\|select\\|if\\|case\\|" - "record\\|while\\|type\\)\\>"))) - (backward-word 1)) - (+ (current-indentation) label))) + (ada-check-matching-start (match-string 0)) + ;; we are now looking at the matching "record" statement + (forward-word 1) + (ada-goto-stmt-start) + ;; now on the matching type declaration, or use clause + (unless (looking-at "\\(for\\|type\\)\\>") + (ada-search-ignore-string-comment "\\<type\\>" t)) + (list (progn (back-to-indentation) (point)) 0))) ;; ;; a named block end ;; ((looking-at ada-ident-re) - (setq defun-name (buffer-substring (match-beginning 0) - (match-end 0))) - (save-excursion - (ada-goto-matching-start 0) - (ada-check-defun-name defun-name) - (current-indentation))) + (unless do-not-check-start + (progn + (set 'defun-name (match-string 0)) + (save-excursion + (ada-goto-matching-start 0) + (ada-check-defun-name defun-name)))) + (list (progn (back-to-indentation) (point)) 0)) ;; ;; a block-end without name ;; - ((looking-at ";") - (save-excursion - (ada-goto-matching-start 0) - (if (looking-at "\\<begin\\>") - (progn - (setq indent (current-column)) - (if (ada-goto-matching-decl-start t) - (current-indentation) - indent))))) + ((= (char-after) ?\;) + (unless do-not-check-start + (save-excursion + (ada-goto-matching-start 0) + (if (looking-at "\\<begin\\>") + (progn + (set 'indent (list (point) 0)) + (if (ada-goto-matching-decl-start t) + (list (progn (back-to-indentation) (point)) 0) + indent)))) + (list (progn (back-to-indentation) (point)) 0))) ;; ;; anything else - should maybe signal an error ? ;; (t - (+ (current-indentation) ada-broken-indent)))) - - (+ (current-indentation) ada-broken-indent)))) + (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)))) + + (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)))) (defun ada-get-indent-case (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. ;; Assumes point to be at the beginning of a case-statement. - (let ((cur-indent (current-indentation)) - (match-cons nil) + (let ((match-cons nil) (opos (point))) (cond ;; ;; case..is..when..=> ;; ((save-excursion - (setq match-cons (and + (set 'match-cons (and ;; the `=>' must be after the keyword `is'. (ada-search-ignore-string-comment - "\\<is\\>" nil orgpoint) + "is" nil orgpoint nil 'word-search-forward) (ada-search-ignore-string-comment "[ \t\n]+=>" nil orgpoint)))) (save-excursion (goto-char (car match-cons)) - (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos)) - (error "missing 'when' between 'case' and '=>'")) - (+ (current-indentation) ada-indent))) + (unless (ada-search-ignore-string-comment "when" t opos) + (error "missing 'when' between 'case' and '=>'")) + (list (save-excursion (back-to-indentation) (point)) 'ada-indent))) ;; ;; case..is..when ;; ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<when\\>" nil orgpoint))) + (set 'match-cons (ada-search-ignore-string-comment + "when" nil orgpoint nil 'word-search-forward))) (goto-char (cdr match-cons)) - (+ (current-indentation) ada-broken-indent)) + (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) ;; ;; case..is ;; ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<is\\>" nil orgpoint))) - (+ (current-indentation) ada-when-indent)) + (set 'match-cons (ada-search-ignore-string-comment + "is" nil orgpoint nil 'word-search-forward))) + (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent)) ;; ;; incomplete case ;; (t - (+ (current-indentation) ada-broken-indent))))) + (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))))) (defun ada-get-indent-when (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. ;; Assumes point to be at the beginning of an when-statement. - (let ((cur-indent (current-indentation))) + (let ((cur-indent (save-excursion (back-to-indentation) (point)))) (if (ada-search-ignore-string-comment - "[ \t\n]+=>" nil orgpoint) - (+ cur-indent ada-indent) - (+ cur-indent ada-broken-indent)))) + "[ \t\n]*=>" nil orgpoint) + (list cur-indent 'ada-indent) + (list cur-indent 'ada-broken-indent)))) (defun ada-get-indent-if (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. ;; Assumes point to be at the beginning of an if-statement. - (let ((cur-indent (current-indentation)) + (let ((cur-indent (save-excursion (back-to-indentation) (point))) (match-cons nil)) ;; - ;; if..then ? + ;; Move to the correct then (ignore all "and then") ;; - (if (ada-search-but-not - "\\<then\\>" "\\<and\\>[ \t\n]+\\<then\\>" nil orgpoint) - + (while (and (set 'match-cons (ada-search-ignore-string-comment + "\\<\\(then\\|and[ \t]*then\\)\\>" + nil orgpoint)) + (= (char-after (car match-cons)) ?a))) + ;; If "then" was found (we are looking at it) + (if match-cons (progn ;; ;; 'then' first in separate line ? - ;; => indent according to 'then' + ;; => indent according to 'then', + ;; => else indent according to 'if' ;; (if (save-excursion (back-to-indentation) (looking-at "\\<then\\>")) - (setq cur-indent (current-indentation))) + (set 'cur-indent (save-excursion (back-to-indentation) (point)))) + ;; skip 'then' (forward-word 1) - ;; - ;; something follows 'then' ? - ;; - (if (setq match-cons - (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint)) - (progn - (goto-char (car match-cons)) - (+ ada-indent - (- cur-indent (current-indentation)) - (funcall (ada-indent-function t) orgpoint))) - - (+ cur-indent ada-indent))) - - (+ cur-indent ada-broken-indent)))) + (list cur-indent 'ada-indent)) + + (list cur-indent 'ada-broken-indent)))) (defun ada-get-indent-block-start (orgpoint) ;; Returns the indentation (column #) for the new line after ;; ORGPOINT. Assumes point to be at the beginning of a block start ;; keyword. - (let ((cur-indent (current-indentation)) - (pos nil)) + (let ((pos nil)) (cond ((save-excursion (forward-word 1) - (setq pos (car (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint)))) + (set 'pos (ada-goto-next-non-ws orgpoint))) (goto-char pos) (save-excursion - (funcall (ada-indent-function t) orgpoint))) + (ada-indent-on-previous-lines t orgpoint))) ;; ;; nothing follows the block-start ;; (t - (+ (current-indentation) ada-indent))))) + (list (save-excursion (back-to-indentation) (point)) 'ada-indent))))) (defun ada-get-indent-subprog (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. ;; Assumes point to be at the beginning of a subprog-/package-declaration. (let ((match-cons nil) - (cur-indent (current-indentation)) - (foundis nil) - (addind 0) - (fstart (point))) + (cur-indent (save-excursion (back-to-indentation) (point))) + (foundis nil)) ;; ;; is there an 'is' in front of point ? ;; (if (save-excursion - (setq match-cons - (ada-search-ignore-string-comment - "\\<\\(is\\|do\\)\\>" nil orgpoint))) + (set 'match-cons + (ada-search-ignore-string-comment + "\\<\\(is\\|do\\)\\>" nil orgpoint))) ;; ;; yes, then skip to its end ;; (progn - (setq foundis t) + (set 'foundis t) (goto-char (cdr match-cons))) ;; ;; no, then goto next non-ws, if there is one in front of point ;; (progn - (if (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint) - (ada-goto-next-non-ws) + (unless (ada-goto-next-non-ws orgpoint) (goto-char orgpoint)))) (cond @@ -2284,17 +2562,17 @@ (save-excursion (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint t)))) - (+ cur-indent ada-indent)) + (list cur-indent 'ada-indent)) ;; ;; is abstract/separate/new ... ;; ((and foundis (save-excursion - (setq match-cons - (ada-search-ignore-string-comment - "\\<\\(separate\\|new\\|abstract\\)\\>" - nil orgpoint)))) + (set 'match-cons + (ada-search-ignore-string-comment + "\\<\\(separate\\|new\\|abstract\\)\\>" + nil orgpoint)))) (goto-char (car match-cons)) (ada-search-ignore-string-comment ada-subprog-start-re t) (ada-get-indent-noindent orgpoint)) @@ -2303,21 +2581,20 @@ ;; ((and foundis - (save-excursion - (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)) - (ada-goto-next-non-ws) - (funcall (ada-indent-function t) orgpoint))) + (save-excursion (set 'match-cons (ada-goto-next-non-ws orgpoint))) + (goto-char match-cons) + (ada-indent-on-previous-lines t orgpoint))) ;; ;; no 'is' but ';' ;; ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - cur-indent) + (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward)) + (list cur-indent 0)) ;; ;; no 'is' or ';' ;; (t - (+ cur-indent ada-broken-indent))))) + (list cur-indent 'ada-broken-indent))))) (defun ada-get-indent-noindent (orgpoint) @@ -2326,13 +2603,45 @@ (let ((label 0)) (save-excursion (beginning-of-line) - (if (looking-at ada-named-block-re) - (setq label (- ada-label-indent)))) - (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (+ (current-indentation) label) - (+ (current-indentation) ada-broken-indent label)))) - + + (cond + + ;; This one is called when indenting a line preceded by a multiline + ;; subprogram declaration (in that case, we are at this point inside + ;; the parameter declaration list) + ((ada-in-paramlist-p) + (ada-previous-procedure) + (list (save-excursion (back-to-indentation) (point)) 0)) + + ;; This one is called when indenting the second line of a multiline + ;; declaration section, in a declare block or a record declaration + ((looking-at "[ \t]*\\(\\sw\\|_\\)*[ \t]*,[ \t]*$") + (list (save-excursion (back-to-indentation) (point)) + 'ada-broken-decl-indent)) + + ;; This one is called in every over case when indenting a line at the + ;; top level + (t + (if (looking-at ada-named-block-re) + (set 'label (- ada-label-indent)) + + ;; "with private" or "null record" cases + (if (or (and (re-search-forward "\\<private\\>" orgpoint t) + (save-excursion (forward-char -7);; skip back "private" + (ada-goto-previous-word) + (looking-at "with"))) + (and (re-search-forward "\\<record\\>" orgpoint t) + (save-excursion (forward-char -6);; skip back "record" + (ada-goto-previous-word) + (looking-at "null")))) + (progn + (re-search-backward "\\<\\(type\\|subtype\\)\\>" nil t) + (list (save-excursion (back-to-indentation) (point)) 0)))) + (if (save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward)) + (list (+ (save-excursion (back-to-indentation) (point)) label) 0) + (list (+ (save-excursion (back-to-indentation) (point)) label) + 'ada-broken-indent))))))) (defun ada-get-indent-label (orgpoint) ;; Returns the indentation (column #) for the new line after ORGPOINT. @@ -2340,76 +2649,62 @@ ;; Checks the context to decide if it's a label or a variable declaration. ;; This check might be a bit slow. (let ((match-cons nil) - (cur-indent (current-indentation))) - (goto-char (cdr (ada-search-ignore-string-comment ":"))) + (cur-indent (save-excursion (back-to-indentation) (point)))) + (ada-search-ignore-string-comment ":" nil) (cond - ;; ;; loop label - ;; ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - ada-loop-start-re nil orgpoint))) + (set 'match-cons (ada-search-ignore-string-comment ada-loop-start-re nil orgpoint))) (goto-char (car match-cons)) (ada-get-indent-loop orgpoint)) - ;; + ;; declare label - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<declare\\|begin\\>" nil orgpoint))) - (save-excursion - (goto-char (car match-cons)) - (+ (current-indentation) ada-indent))) - ;; - ;; complete statement following colon - ;; ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (if (ada-in-decl-p) - cur-indent ; variable-declaration - (- cur-indent ada-label-indent))) ; label - ;; - ;; broken statement - ;; - ((save-excursion - (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)) - (if (ada-in-decl-p) - (+ cur-indent ada-broken-indent) - (+ cur-indent ada-broken-indent (- ada-label-indent)))) - ;; + (set 'match-cons (ada-search-ignore-string-comment "\\<declare\\|begin\\>" nil orgpoint))) + (goto-char (car match-cons)) + (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) + + ;; variable declaration + ((ada-in-decl-p) + (if (save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint)) + (list cur-indent 0) + (list cur-indent 'ada-broken-indent))) + ;; nothing follows colon - ;; (t - (if (ada-in-decl-p) - (+ cur-indent ada-broken-indent) ; variable-declaration - (- cur-indent ada-label-indent)))))) ; label - + (list cur-indent '(- ada-label-indent)))))) (defun ada-get-indent-loop (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of a loop statement - ;; or (unfortunately) also a for ... use statement. + "Returns the two-element list for indentation. +Assumes point to be at the beginning of a loop statement +or a for ... use statement." (let ((match-cons nil) (pos (point)) + + ;; If looking at a named block, skip the label (label (save-excursion (beginning-of-line) (if (looking-at ada-named-block-re) (- ada-label-indent) 0)))) - + (cond ;; ;; statement complete ;; ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (+ (current-indentation) label)) + (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward)) + (list (+ (save-excursion (back-to-indentation) (point)) label) 0)) ;; ;; simple loop ;; ((looking-at "loop\\>") - (+ (ada-get-indent-block-start orgpoint) label)) + (set 'pos (ada-get-indent-block-start orgpoint)) + (if (equal label 0) + pos + (list (+ (car pos) label) (cdr pos)))) ;; ;; 'for'- loop (or also a for ... use statement) @@ -2422,43 +2717,42 @@ ((save-excursion (and (goto-char (match-end 0)) - (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint) - (not (backward-char 1)) - (not (zerop (skip-chars-forward "_a-zA-Z0-9'"))) - (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint) - (not (backward-char 1)) + (ada-goto-next-non-ws orgpoint) + (forward-word 1) + (if (= (char-after) ?') (forward-word 1) t) + (ada-goto-next-non-ws orgpoint) (looking-at "\\<use\\>") ;; ;; check if there is a 'record' before point ;; (progn - (setq match-cons (ada-search-ignore-string-comment - "\\<record\\>" nil orgpoint)) + (set 'match-cons (ada-search-ignore-string-comment + "record" nil orgpoint nil 'word-search-forward)) t))) (if match-cons (goto-char (car match-cons))) - (+ (current-indentation) ada-indent)) + (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) ;; ;; for..loop ;; ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<loop\\>" nil orgpoint))) + (set 'match-cons (ada-search-ignore-string-comment + "loop" nil orgpoint nil 'word-search-forward))) (goto-char (car match-cons)) ;; ;; indent according to 'loop', if it's first in the line; ;; otherwise to 'for' ;; - (if (not (save-excursion - (back-to-indentation) - (looking-at "\\<loop\\>"))) - (goto-char pos)) - (+ (current-indentation) ada-indent label)) + (unless (save-excursion + (back-to-indentation) + (looking-at "\\<loop\\>")) + (goto-char pos)) + (list (+ (save-excursion (back-to-indentation) (point)) label) 'ada-indent)) ;; ;; for-statement is broken ;; (t - (+ (current-indentation) ada-broken-indent label)))) + (list (+ (save-excursion (back-to-indentation) (point)) label) 'ada-broken-indent)))) ;; ;; 'while'-loop @@ -2468,8 +2762,8 @@ ;; while..loop ? ;; (if (save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<loop\\>" nil orgpoint))) + (set 'match-cons (ada-search-ignore-string-comment + "loop" nil orgpoint nil 'word-search-forward))) (progn (goto-char (car match-cons)) @@ -2477,13 +2771,14 @@ ;; indent according to 'loop', if it's first in the line; ;; otherwise to 'while'. ;; - (if (not (save-excursion - (back-to-indentation) - (looking-at "\\<loop\\>"))) - (goto-char pos)) - (+ (current-indentation) ada-indent label)) - - (+ (current-indentation) ada-broken-indent label)))))) + (unless (save-excursion + (back-to-indentation) + (looking-at "\\<loop\\>")) + (goto-char pos)) + (list (+ (save-excursion (back-to-indentation) (point)) label) 'ada-indent)) + + (list (+ (save-excursion (back-to-indentation) (point)) label) + 'ada-broken-indent)))))) (defun ada-get-indent-type (orgpoint) @@ -2496,44 +2791,42 @@ ;; ((save-excursion (and - (setq match-dat (ada-search-ignore-string-comment "\\<end\\>" - nil - orgpoint)) + (set 'match-dat (ada-search-ignore-string-comment + "end" nil orgpoint nil 'word-search-forward)) (ada-goto-next-non-ws) (looking-at "\\<record\\>") (forward-word 1) (ada-goto-next-non-ws) - (looking-at ";"))) + (= (char-after) ?\;))) (goto-char (car match-dat)) - (current-indentation)) + (list (save-excursion (back-to-indentation) (point)) 0)) ;; ;; record type ;; ((save-excursion - (setq match-dat (ada-search-ignore-string-comment "\\<record\\>" - nil - orgpoint))) + (set 'match-dat (ada-search-ignore-string-comment + "record" nil orgpoint nil 'word-search-forward))) (goto-char (car match-dat)) - (+ (current-indentation) ada-indent)) + (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) ;; ;; complete type declaration ;; ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (current-indentation)) + (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward)) + (list (save-excursion (back-to-indentation) (point)) 0)) ;; ;; "type ... is", but not "type ... is ...", which is broken ;; ((save-excursion - (and - (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint) - (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)))) - (+ (current-indentation) ada-indent)) + (and + (ada-search-ignore-string-comment "is" nil orgpoint nil 'word-search-forward) + (not (ada-goto-next-non-ws orgpoint)))) + (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) ;; ;; broken statement ;; (t - (+ (current-indentation) ada-broken-indent))))) + (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))))) ;;; ---- support-functions for indentation @@ -2546,31 +2839,34 @@ ;; by searching for 'ada-end-stmt-re' and then moving to the ;; following non-ws that is not a comment. LIMIT is actually not ;; used by the indentation functions. + ;; As a special case, if we are looking back at a closing parenthesis, + ;; we just skip the parenthesis (let ((match-dat nil) (orgpoint (point))) - (setq match-dat (ada-search-prev-end-stmt limit)) + (set 'match-dat (ada-search-prev-end-stmt limit)) (if match-dat + ;; ;; found a previous end-statement => check if anything follows ;; - (progn - (if (not - (save-excursion - (goto-char (cdr match-dat)) - (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint))) + (unless (looking-at "declare") + (progn + (unless (save-excursion + (goto-char (cdr match-dat)) + (ada-goto-next-non-ws orgpoint)) ;; ;; nothing follows => it's the end-statement directly in ;; front of point => search again ;; - (setq match-dat (ada-search-prev-end-stmt limit))) - ;; - ;; if found the correct end-statement => goto next non-ws - ;; - (if match-dat - (goto-char (cdr match-dat))) - (ada-goto-next-non-ws)) + (set 'match-dat (ada-search-prev-end-stmt limit))) + ;; + ;; if found the correct end-statement => goto next non-ws + ;; + (if match-dat + (goto-char (cdr match-dat))) + (ada-goto-next-non-ws) + )) ;; ;; no previous end-statement => we are at the beginning of the @@ -2581,13 +2877,9 @@ ;; ;; skip to the very first statement, if there is one ;; - (if (setq match-dat - (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint)) - (goto-char (car match-dat)) + (unless (ada-goto-next-non-ws orgpoint) (goto-char orgpoint)))) - (point))) @@ -2598,36 +2890,39 @@ ;; certain keywords if they follow 'end', which means they are no ;; end-statement there. (let ((match-dat nil) - (pos nil) - (found nil)) + (found nil) + parse) + ;; ;; search until found or beginning-of-buffer ;; (while (and (not found) - (setq match-dat (ada-search-ignore-string-comment ada-end-stmt-re - t - limit))) + (set 'match-dat (ada-search-ignore-string-comment + ada-end-stmt-re t limit))) (goto-char (car match-dat)) - (if (not (ada-in-open-paren-p)) - ;; - ;; check if there is an 'end' in front of the match - ;; - (if (not (and - (looking-at - "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>") - (save-excursion - (ada-goto-previous-word) - (looking-at "\\<\\(end\\|or\\|and\\)\\>")))) - (save-excursion - (goto-char (cdr match-dat)) - (ada-goto-next-word) - (if (not (looking-at "\\<\\(separate\\|new\\)\\>")) - (setq found t))) - - (forward-word -1)))) ; end of loop + (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) + "\\>\\|("))) + (set 'found t)))) + )) (if found match-dat @@ -2635,17 +2930,22 @@ (defun ada-goto-next-non-ws (&optional limit) - ;; Skips whitespaces, newlines and comments to next non-ws - ;; character. Signals an error if there is no more such character - ;; and limit is nil. - (let ((match-cons nil)) - (setq match-cons (ada-search-ignore-string-comment - "[^ \t\n]" nil limit t)) - (if match-cons - (goto-char (car match-cons)) - (if (not limit) - (error "no more non-ws") - nil)))) + "Skips whitespaces, newlines and comments to next non-ws +character. Signals an error if there is no more such character +and limit is nil. +Do not call this function from within a string." + (unless limit + (set 'limit (point-max))) + (while (and (<= (point) limit) + (progn (forward-comment 10000) + (if (and (not (eobp)) + (save-excursion (forward-char 1) + (ada-in-string-p))) + (progn (forward-sexp 1) t))))) + (if (< (point) limit) + (point) + nil) + ) (defun ada-goto-stmt-end (&optional limit) @@ -2661,27 +2961,32 @@ ;; If BACKWARD is non-nil, jump to the beginning of the previous word. ;; Returns the new position of point or nil if not found. (let ((match-cons nil) - (orgpoint (point))) - (if (not backward) - (skip-chars-forward "_a-zA-Z0-9\\.")) - (if (setq match-cons - (ada-search-ignore-string-comment "\\w" backward nil t)) + (orgpoint (point)) + (old-syntax (char-to-string (char-syntax ?_)))) + (modify-syntax-entry ?_ "w") + (unless backward + (skip-syntax-forward "w"));; ??? Used to have . too + (if (set 'match-cons + (if backward + (ada-search-ignore-string-comment "\\w" t nil t) + (ada-search-ignore-string-comment "\\w" nil nil t))) ;; ;; move to the beginning of the word found ;; (progn (goto-char (car match-cons)) - (skip-chars-backward "_a-zA-Z0-9") + (skip-syntax-backward "w") (point)) ;; ;; if not found, restore old position of point ;; - (progn - (goto-char orgpoint) - 'nil)))) - - -(defun ada-goto-previous-word () + (goto-char orgpoint) + 'nil) + (modify-syntax-entry ?_ old-syntax)) + ) + + +(defsubst ada-goto-previous-word () ;; Moves point to the beginning of the previous word of Ada code. ;; Returns the new position of point or nil if not found. (ada-goto-next-word t)) @@ -2691,8 +2996,8 @@ ;; Signals an error if matching block start is not KEYWORD. ;; Moves point to the matching block start. (ada-goto-matching-start 0) - (if (not (looking-at (concat "\\<" keyword "\\>"))) - (error "matching start is not '%s'" keyword))) + (unless (looking-at (concat "\\<" keyword "\\>")) + (error "matching start is not '%s'" keyword))) (defun ada-check-defun-name (defun-name) @@ -2706,12 +3011,12 @@ (if (save-excursion (ada-goto-previous-word) (looking-at (concat "\\<" defun-name "\\> *:"))) - t ; do nothing + t ; do nothing ;; ;; 'accept' or 'package' ? ;; - (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>")) - (ada-goto-matching-decl-start)) + (unless (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>") + (ada-goto-matching-decl-start)) ;; ;; 'begin' of 'procedure'/'function'/'task' or 'declare' ;; @@ -2737,28 +3042,33 @@ ;; ;; should be looking-at the correct name ;; - (if (not (looking-at (concat "\\<" defun-name "\\>"))) - (error "matching defun has different name: %s" - (buffer-substring (point) - (progn (forward-sexp 1) (point)))))))) - + (unless (looking-at (concat "\\<" defun-name "\\>")) + (error "matching defun has different name: %s" + (buffer-substring (point) + (progn (forward-sexp 1) (point)))))))) (defun ada-goto-matching-decl-start (&optional noerror nogeneric) ;; Moves point to the matching declaration start of the current 'begin'. ;; If NOERROR is non-nil, it only returns nil if no match was found. (let ((nest-count 1) - (pos nil) (first t) - (flag nil)) + (flag nil) + (count-generic nil) + ) + + (if (or + (looking-at "\\<\\(package\\|procedure\\|function\\)\\>") + (save-excursion + (ada-search-ignore-string-comment "\\<\\(package\\|procedure\\|function\\|generic\\)\\>" t) + (looking-at "generic"))) + (set 'count-generic t)) + ;; ;; search backward for interesting keywords ;; (while (and (not (zerop nest-count)) - (ada-search-ignore-string-comment - (concat "\\<\\(" - "is\\|separate\\|end\\|declare\\|new\\|begin\\|generic" - "\\)\\>") t)) + (ada-search-ignore-string-comment ada-matching-decl-start-re t)) ;; ;; calculate nest-depth ;; @@ -2766,39 +3076,79 @@ ;; ((looking-at "end") (ada-goto-matching-start 1 noerror) - (if (looking-at "begin") - (setq nest-count (1+ nest-count)))) + + ;; In some case, two begin..end block can follow each other closely, + ;; which we have to detect, as in + ;; procedure P is + ;; procedure Q is + ;; begin + ;; end; + ;; begin -- here we should go to procedure, not begin + ;; end + + (let ((loop-again 0)) + (if (looking-at "begin") + (set 'loop-again 1)) + + (save-excursion + (while (not (= loop-again 0)) + + ;; If begin was just there as the beginning of a block (with no + ;; declare) then do nothing, otherwise just register that we + ;; have to find the statement that required the begin + + (ada-search-ignore-string-comment + "declare\\|begin\\|end\\|procedure\\|function\\|task\\|package" + t) + + (if (looking-at "end") + (set 'loop-again (1+ loop-again)) + + (set 'loop-again (1- loop-again)) + (unless (looking-at "begin") + (set 'nest-count (1+ nest-count)))) + )) + )) ;; - ((looking-at "declare\\|generic") - (setq nest-count (1- nest-count)) - (setq first nil)) + ((looking-at "generic") + (if count-generic + (progn + (set 'first nil) + (set 'nest-count (1- nest-count))))) + ;; + ((looking-at "declare\\|generic\\|if") + (set 'nest-count (1- nest-count)) + (set 'first nil)) ;; ((looking-at "is") ;; check if it is only a type definition, but not a protected ;; type definition, which should be handled like a procedure. - (if (or (looking-at "is +<>") + (if (or (looking-at "is[ \t]+<>") (save-excursion - (ada-goto-previous-word) - (skip-chars-backward "a-zA-Z0-9_.'") - (if (save-excursion - (backward-char 1) - (looking-at ")")) + (forward-comment -10000) + (forward-char -1) + + ;; Detect if we have a closing parenthesis (Could be + ;; either the end of subprogram parameters or (<>) + ;; in a type definition + (if (= (char-after) ?\)) (progn (forward-char 1) (backward-sexp 1) - (skip-chars-backward "a-zA-Z0-9_.'") + (forward-comment -10000) )) + (skip-chars-backward "a-zA-Z0-9_.'") (ada-goto-previous-word) - (and - (looking-at "\\<type\\>") + (and + (looking-at "\\<\\(sub\\)?type\\>") (save-match-data (ada-goto-previous-word) (not (looking-at "\\<protected\\>")))) - )); end of `or' + )) ; end of `or' (goto-char (match-beginning 0)) (progn - (setq nest-count (1- nest-count)) - (setq first nil)))) + (set 'nest-count (1- nest-count)) + (set 'first nil)))) ;; ((looking-at "new") @@ -2809,27 +3159,26 @@ ;; ((and first (looking-at "begin")) - (setq nest-count 0) - (setq flag t)) + (set 'nest-count 0) + (set 'flag t)) ;; (t - (setq nest-count (1+ nest-count)) - (setq first nil))) - - ) ;; end of loop + (set 'nest-count (1+ nest-count)) + (set 'first nil))) + + );; end of loop ;; check if declaration-start is really found - (if (not - (and - (zerop nest-count) - (not flag) - (if (looking-at "is") - (ada-search-ignore-string-comment ada-subprog-start-re t) - (looking-at "declare\\|generic")))) - (if noerror nil - (error "no matching proc/func/task/declare/package/protected")) - t))) - + (if (and + (zerop nest-count) + (not flag) + (if (looking-at "is") + (ada-search-ignore-string-comment ada-subprog-start-re t) + (looking-at "declare\\|generic"))) + t + (if noerror nil + (error "no matching proc/func/task/declare/package/protected"))) + )) (defun ada-goto-matching-start (&optional nest-level noerror gotothen) ;; Moves point to the beginning of a block-start. Which block @@ -2846,59 +3195,97 @@ ;; (while (and (not found) - (ada-search-ignore-string-comment - (concat "\\<\\(" - "end\\|loop\\|select\\|begin\\|case\\|do\\|" - "if\\|task\\|package\\|record\\|protected\\)\\>") - t)) - - ;; - ;; calculate nest-depth - ;; - (cond - ;; found block end => increase nest depth - ((looking-at "end") - (setq nest-count (1+ nest-count))) - ;; found loop/select/record/case/if => check if it starts or - ;; ends a block - ((looking-at "loop\\|select\\|record\\|case\\|if") - (setq pos (point)) - (save-excursion + (ada-search-ignore-string-comment ada-matching-start-re t)) + + (unless (and (looking-at "\\<record\\>") + (save-excursion + (forward-word -1) + (looking-at "\\<null\\>"))) + (progn ;; - ;; check if keyword follows 'end' + ;; calculate nest-depth ;; - (ada-goto-previous-word) - (if (looking-at "\\<end\\> *[^;]") - ;; it ends a block => increase nest depth - (progn - (setq nest-count (1+ nest-count)) - (setq pos (point))) - ;; it starts a block => decrease nest depth - (setq nest-count (1- nest-count)))) - (goto-char pos)) - ;; found package start => check if it really is a block - ((looking-at "package") - (save-excursion - (ada-search-ignore-string-comment "\\<is\\>") - (ada-goto-next-non-ws) - ;; ignore it if it is only a declaration with 'new' - (if (not (looking-at "\\<new\\>")) - (setq nest-count (1- nest-count))))) - ;; found task start => check if it has a body - ((looking-at "task") - (save-excursion - (forward-word 1) - (ada-goto-next-non-ws) - ;; ignore it if it has no body - (if (not (looking-at "\\<body\\>")) - (setq nest-count (1- nest-count))))) - ;; all the other block starts - (t - (setq nest-count (1- nest-count)))) ; end of 'cond' - - ;; match is found, if nest-depth is zero - ;; - (setq found (zerop nest-count))) ; end of loop + (cond + ;; found block end => increase nest depth + ((looking-at "end") + (set 'nest-count (1+ nest-count))) + + ;; found loop/select/record/case/if => check if it starts or + ;; ends a block + ((looking-at "loop\\|select\\|record\\|case\\|if") + (set 'pos (point)) + (save-excursion + ;; + ;; check if keyword follows 'end' + ;; + (ada-goto-previous-word) + (if (looking-at "\\<end\\>[ \t]*[^;]") + ;; it ends a block => increase nest depth + (progn + (set 'nest-count (1+ nest-count)) + (set 'pos (point))) + ;; it starts a block => decrease nest depth + (set 'nest-count (1- nest-count)))) + (goto-char pos)) + + ;; found package start => check if it really is a block + ((looking-at "package") + (save-excursion + ;; ignore if this is just a renames statement + (let ((current (point)) + (pos (ada-search-ignore-string-comment + "\\<\\(is\\|renames\\|;\\)\\>" nil))) + (if pos + (goto-char (car pos)) + (error (concat + "No matching 'is' or 'renames' for 'package' at line " + (number-to-string (count-lines (point-min) (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\\)\\>")) + (set 'nest-count (1- nest-count))))))) + ;; found task start => check if it has a body + ((looking-at "task") + (save-excursion + (forward-word 1) + (ada-goto-next-non-ws) + (cond + ((looking-at "\\<body\\>")) + ((looking-at "\\<type\\>") + ;; In that case, do nothing if there is a "is" + (forward-word 2);; skip "type" + (ada-goto-next-non-ws);; skip type name + + ;; Do nothing if we are simply looking at a simple + ;; "task type name;" statement with no block + (unless (looking-at ";") + (progn + ;; Skip the parameters + (if (looking-at "(") + (ada-search-ignore-string-comment ")" nil)) + (let ((tmp (ada-search-ignore-string-comment + "\\<\\(is\\|;\\)\\>" nil))) + (if tmp + (progn + (goto-char (car tmp)) + (if (looking-at "is") + (set 'nest-count (1- nest-count))))))))) + (t + ;; Check if that task declaration had a block attached to + ;; it (i.e do nothing if we have just "task name;") + (unless (progn (forward-word 1) + (looking-at "[ \t]*;")) + (set 'nest-count (1- nest-count))))))) + ;; all the other block starts + (t + (set 'nest-count (1- nest-count)))) ; end of 'cond' + + ;; match is found, if nest-depth is zero + ;; + (set 'found (zerop nest-count))))) ; end of loop (if found ;; @@ -2914,7 +3301,7 @@ gotothen (looking-at "if") (save-excursion - (ada-search-ignore-string-comment "\\<then\\>" nil nil) + (ada-search-ignore-string-comment "then" nil nil nil 'word-search-forward) (back-to-indentation) (looking-at "\\<then\\>"))) (goto-char (match-beginning 0))) @@ -2922,8 +3309,8 @@ ;; found 'do' => skip back to 'accept' ;; ((looking-at "do") - (if (not (ada-search-ignore-string-comment "\\<accept\\>" t nil)) - (error "missing 'accept' in front of 'do'")))) + (unless (ada-search-ignore-string-comment "accept" t nil nil 'word-search-backward) + (error "missing 'accept' in front of 'do'")))) (point)) (if noerror @@ -2944,8 +3331,11 @@ (while (and (not found) (ada-search-ignore-string-comment - (concat "\\<\\(end\\|loop\\|select\\|begin\\|case\\|" - "if\\|task\\|package\\|record\\|do\\)\\>"))) + (eval-when-compile + (concat "\\<" + (regexp-opt '("end" "loop" "select" "begin" "case" + "if" "task" "package" "record" "do") t) + "\\>")) nil)) ;; ;; calculate nest-depth @@ -2954,7 +3344,7 @@ (cond ;; found block end => decrease nest depth ((looking-at "\\<end\\>") - (setq nest-count (1- nest-count)) + (set 'nest-count (1- nest-count)) ;; skip the following keyword (if (progn (skip-chars-forward "end") @@ -2963,264 +3353,116 @@ (forward-word 1))) ;; found package start => check if it really starts a block ((looking-at "\\<package\\>") - (ada-search-ignore-string-comment "\\<is\\>") + (ada-search-ignore-string-comment "is" nil nil nil 'word-search-forward) (ada-goto-next-non-ws) ;; ignore and skip it if it is only a 'new' package - (if (not (looking-at "\\<new\\>")) - (setq nest-count (1+ nest-count)) - (skip-chars-forward "new"))) + (if (looking-at "\\<new\\>") + (goto-char (match-end 0)) + (set 'nest-count (1+ nest-count)))) ;; all the other block starts (t - (setq nest-count (1+ nest-count)) - (forward-word 1))) ; end of 'cond' + (set 'nest-count (1+ nest-count)) + (forward-word 1))) ; end of 'cond' ;; match is found, if nest-depth is zero ;; - (setq found (zerop nest-count))) ; end of loop - - (if (not found) - (if noerror - nil - (error "no matching end")) - t))) - - -(defun ada-forward-sexp-ignore-comment () - ;; Skips one sexp forward, ignoring comments. - (while (looking-at "[ \t\n]*--") - (skip-chars-forward "[ \t\n]") - (end-of-line)) - (forward-sexp 1)) + (set 'found (zerop nest-count))) ; end of loop + + (if found + t + (if noerror + nil + (error "no matching end"))) + )) (defun ada-search-ignore-string-comment - (search-re &optional backward limit paramlists) + (search-re &optional backward limit paramlists search-func ) ;; Regexp-Search for SEARCH-RE, ignoring comments, strings and ;; parameter lists, if PARAMLISTS is nil. Returns a cons cell of ;; begin and end of match data or nil, if not found. - (let ((found nil) - (begin nil) - (end nil) - (pos nil) - (search-func - (if backward 're-search-backward - 're-search-forward))) + ;; The search is done using search-func, so that we can choose using + ;; regular expression search, basic search, ... + ;; Point is moved at the beginning of the search-re + (let (found + begin + end + parse-result + (previous-syntax-table (syntax-table))) + + (unless search-func + (set 'search-func (if backward 're-search-backward 're-search-forward))) ;; ;; search until found or end-of-buffer + ;; We have to test that we do not look further than limit ;; + (set-syntax-table ada-mode-symbol-syntax-table) (while (and (not found) + (or (not limit) + (or (and backward (<= limit (point))) + (>= limit (point)))) (funcall search-func search-re limit 1)) - (setq begin (match-beginning 0)) - (setq end (match-end 0)) + (set 'begin (match-beginning 0)) + (set 'end (match-end 0)) + + (set 'parse-result (parse-partial-sexp + (save-excursion (beginning-of-line) (point)) + (point))) (cond ;; - ;; found in comment => skip it + ;; If inside a string, skip it (and the following comments) ;; - ((ada-in-comment-p) - (if backward - (progn - (re-search-backward "--" nil 1) - (goto-char (match-beginning 0))) - (forward-line 1) - ;; Used to have (beginning-of-line) here, - ;; but that caused trouble at end of buffer with no newline. - )) + ((ada-in-string-p parse-result) + (if ada-xemacs + (search-backward "\"" nil t) + (goto-char (nth 8 parse-result))) + (unless backward (forward-sexp 1))) ;; - ;; found in string => skip it + ;; If inside a comment, skip it (and the following comments) + ;; There is a special code for comments at the end of the file ;; - ((ada-in-string-p) - (if backward - (progn - (re-search-backward "\"" nil 1) ; "\"\\|#" don't treat # - (goto-char (match-beginning 0)))) - (re-search-forward "\"" nil 1)) + ((ada-in-comment-p parse-result) + (if ada-xemacs + (progn + (forward-line 1) + (beginning-of-line) + (forward-comment -1)) + (goto-char (nth 8 parse-result))) + (unless backward + ;; at the end of the file, it is not possible to skip a comment + ;; so we just go at the end of the line + (if (forward-comment 1) + (progn + (forward-comment 1000) + (beginning-of-line)) + (end-of-line)))) ;; - ;; found character constant => ignore it + ;; directly in front of a comment => skip it, if searching forward ;; - ((save-excursion - (setq pos (- (point) (if backward 1 2))) - (and (char-after pos) - (= (char-after pos) ?') - (= (char-after (+ pos 2)) ?'))) - ()) + ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-)) + (unless backward (progn (forward-char -1) (forward-comment 1000)))) + ;; ;; found a parameter-list but should ignore it => skip it ;; - ((and (not paramlists) - (ada-in-paramlist-p)) + ((and (not paramlists) (ada-in-paramlist-p)) (if backward - (ada-search-ignore-string-comment "(" t nil t))) - ;; - ;; directly in front of a comment => skip it, if searching forward - ;; - ((save-excursion - (goto-char begin) - (looking-at "--")) - (if (not backward) - (progn - (forward-line 1) - (beginning-of-line)))) + (search-backward "(" nil t) + (search-forward ")" nil t))) ;; ;; found what we were looking for ;; (t - (setq found t)))) ; end of loop + (set 'found t)))) ; end of loop + + (set-syntax-table previous-syntax-table) (if found (cons begin end) nil))) - -(defun ada-search-but-not (search-re not-search-re &optional backward limit) - ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings, - ;; comments and parameter-lists. - (let ((begin nil) - (end nil) - (begin-not nil) - (begin-end nil) - (end-not nil) - (ret-cons nil) - (found nil)) - - ;; - ;; search until found or end-of-buffer - ;; - (while (and - (not found) - (save-excursion - (setq ret-cons - (ada-search-ignore-string-comment search-re - backward limit)) - (if (consp ret-cons) - (progn - (setq begin (car ret-cons)) - (setq end (cdr ret-cons)) - t) - nil))) - - (if (or - ;; - ;; if no NO-SEARCH-RE was found - ;; - (not - (save-excursion - (setq ret-cons - (ada-search-ignore-string-comment not-search-re - backward nil)) - (if (consp ret-cons) - (progn - (setq begin-not (car ret-cons)) - (setq end-not (cdr ret-cons)) - t) - nil))) - ;; - ;; or this NO-SEARCH-RE is not a part of the SEARCH-RE - ;; found before. - ;; - (or - (<= end-not begin) - (>= begin-not end))) - - (setq found t) - - ;; - ;; not found the correct match => skip this match - ;; - (goto-char (if backward - begin - end)))) ; end of loop - - (if found - (progn - (goto-char begin) - (cons begin end)) - nil))) - - -(defun ada-goto-prev-nonblank-line ( &optional ignore-comment) - ;; Moves point to the beginning of previous non-blank line, - ;; ignoring comments if IGNORE-COMMENT is non-nil. - ;; It returns t if a matching line was found. - (let ((notfound t) - (newpoint nil)) - - (save-excursion - ;; - ;; backward one line, if there is one - ;; - (if (zerop (forward-line -1)) - ;; - ;; there is some kind of previous line - ;; - (progn - (beginning-of-line) - (setq newpoint (point)) - - ;; - ;; search until found or beginning-of-buffer - ;; - (while (and (setq notfound - (or (looking-at "[ \t]*$") - (and (looking-at "[ \t]*--") - ignore-comment))) - (not (ada-in-limit-line-p))) - (forward-line -1) - ;;(beginning-of-line) - (setq newpoint (point))) ; end of loop - - )) ; end of if - - ) ; end of save-excursion - - (if notfound nil - (progn - (goto-char newpoint) - t)))) - - -(defun ada-goto-next-nonblank-line ( &optional ignore-comment) - ;; Moves point to next non-blank line, - ;; ignoring comments if IGNORE-COMMENT is non-nil. - ;; It returns t if a matching line was found. - (let ((notfound t) - (newpoint nil)) - - (save-excursion - ;; - ;; forward one line - ;; - (if (zerop (forward-line 1)) - ;; - ;; there is some kind of previous line - ;; - (progn - (beginning-of-line) - (setq newpoint (point)) - - ;; - ;; search until found or end-of-buffer - ;; - (while (and (setq notfound - (or (looking-at "[ \t]*$") - (and (looking-at "[ \t]*--") - ignore-comment))) - (not (ada-in-limit-line-p))) - (forward-line 1) - (beginning-of-line) - (setq newpoint (point))) ; end of loop - - )) ; end of if - - ) ; end of save-excursion - - (if notfound nil - (progn - (goto-char newpoint) - t)))) - - ;; ---- boolean functions for indentation (defun ada-in-decl-p () @@ -3243,60 +3485,34 @@ (defun ada-looking-at-semi-private () - ;; Returns t if looking-at an 'private' following a semicolon. + "Returns t if looking-at an 'private' following a semicolon. +Returns nil if the private is part of the package name, as in +'private package A is...' (this can only happen at top level)" (save-excursion (and (looking-at "\\<private\\>") - (progn - (forward-word 1) - (ada-goto-stmt-start) - (looking-at "\\<private\\>"))))) - - -;;; make a faster??? ada-in-limit-line-p not using count-lines -(defun ada-in-limit-line-p () - ;; return t if point is in first or last accessible line. - (or (save-excursion (beginning-of-line) (= (point-min) (point))) - (save-excursion (end-of-line) (= (point-max) (point))))) - - -(defun ada-in-comment-p () - ;; Returns t if inside a comment. - (nth 4 (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point)))) - - -(defun ada-in-string-p () - ;; Returns t if point is inside a string - ;; (Taken from pascal-mode.el, modified by MH). - (save-excursion - (and - (nth 3 (parse-partial-sexp - (save-excursion - (beginning-of-line) - (point)) (point))) - ;; check if 'string quote' is only a character constant - (progn - (re-search-backward "\"" nil t) ; `#' is not taken as a string delimiter - (not (= (char-after (1- (point))) ?')))))) - - -(defun ada-in-string-or-comment-p () - ;; Returns t if point is inside a string, a comment, or a character constant. - (let ((parse-result (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) (point)))) - (or ;; in-comment-p - (nth 4 parse-result) - ;; in-string-p - (and - (nth 3 parse-result) - ;; check if 'string quote' is only a character constant - (progn - (re-search-backward "\"" nil t) ; `#' not regarded a string delimiter - (not (= (char-after (1- (point))) ?')))) - ;; in-char-const-p - (ada-in-char-const-p)))) - + (not (looking-at "\\<private[ \t]*\\(package\\|generic\\)")) + (progn (forward-comment -1000) + (= (char-before) ?\;))))) + +(defsubst ada-in-comment-p (&optional parse-result) + "Returns t if inside a comment." + (nth 4 (or parse-result + (parse-partial-sexp + (save-excursion (beginning-of-line) (point)) (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))))) + +(defsubst ada-in-string-or-comment-p (&optional parse-result) + "Returns t if inside a comment or string" + (set 'parse-result (or parse-result + (parse-partial-sexp + (save-excursion (beginning-of-line) (point)) (point)))) + (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result))) (defun ada-in-paramlist-p () ;; Returns t if point is inside a parameter-list @@ -3305,88 +3521,86 @@ (and (re-search-backward "(\\|)" nil t) ;; inside parentheses ? - (looking-at "(") + (= (char-after) ?\() (backward-word 2) - ;; right keyword before parenthesis ? - (looking-at (concat "\\<\\(" - "procedure\\|function\\|body\\|package\\|" - "task\\|entry\\|accept\\)\\>")) - (re-search-forward ")\\|:" nil t) - ;; at least one ':' inside the parentheses ? - (not (backward-char 1)) - (looking-at ":")))) - + + ;; We should ignore the case when the reserved keyword is in a + ;; comment (for instance, when we have: + ;; -- .... package + ;; Test (A) + ;; we should return nil + + (not (ada-in-string-or-comment-p)) + + ;; right keyword two words before parenthesis ? + ;; Type is in this list because of discriminants + (looking-at (eval-when-compile + (concat "\\<\\(" + "procedure\\|function\\|body\\|" + "task\\|entry\\|accept\\|" + "access[ \t]+procedure\\|" + "access[ \t]+function\\|" + "pragma\\|" + "type\\)\\>")))))) ;; not really a boolean function ... (defun ada-in-open-paren-p () - ;; If point is somewhere behind an open parenthesis not yet closed, - ;; it returns the column # of the first non-ws behind this open - ;; parenthesis, otherwise nil." - (let ((start (if (<= (point) ada-search-paren-char-count-limit) - (point-min) - (save-excursion - (goto-char (- (point) ada-search-paren-char-count-limit)) - (beginning-of-line) - (point)))) - parse-result - (col nil)) - (setq parse-result (parse-partial-sexp start (point))) - (if (nth 1 parse-result) - (save-excursion - (goto-char (1+ (nth 1 parse-result))) - (if (save-excursion - (re-search-forward "[^ \t]" nil 1) - (backward-char 1) - (and - (not (looking-at "\n")) - (setq col (current-column)))) - col - (current-column))) - nil))) - + "If point is somewhere behind an open parenthesis not yet closed, +it returns the position of the first non-ws behind that open parenthesis, +otherwise nil" + (save-excursion + (let ((parse (parse-partial-sexp + (point) + (or (car (ada-search-ignore-string-comment "\\<\\(;\\|is\\|then\\|loop\\|begin\\|else\\)\\>" t)) + (point-min))))) + + (if (nth 1 parse) + (progn + (goto-char (1+ (nth 1 parse))) + (skip-chars-forward " \t") + (point)))))) ;;;----------------------;;; ;;; Behaviour Of TAB Key ;;; ;;;----------------------;;; - (defun ada-tab () - "Do indenting or tabbing according to `ada-tab-policy'." + "Do indenting or tabbing according to `ada-tab-policy'. + +In Transient Mark mode, if the mark is active, operate on the contents +of the region. Otherwise, operates only on the current line" (interactive) - (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented")) - ;; ada-indent-and-tab - ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard)) - ((eq ada-tab-policy 'indent-auto) (ada-indent-current)) - ((eq ada-tab-policy 'gei) (ada-tab-gei)) - ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB + (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 (region-active-p)) + (and (not ada-xemacs) + transient-mark-mode + mark-active)) + (ada-indent-region (region-beginning) (region-end)) + (ada-indent-current))) ((eq ada-tab-policy 'always-tab) (error "not implemented")) )) - (defun ada-untab (arg) "Delete leading indenting according to `ada-tab-policy'." (interactive "P") (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard)) - ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB - (prefix-numeric-value arg) ; GEB - arg)) ; GEB ((eq ada-tab-policy 'indent-auto) (error "not implemented")) ((eq ada-tab-policy 'always-tab) (error "not implemented")) )) - (defun ada-indent-current-function () "Ada mode version of the indent-line-function." (interactive "*") (let ((starting-point (point-marker))) - (ada-beginning-of-line) + (beginning-of-line) (ada-tab) (if (< (point) starting-point) (goto-char starting-point)) (set-marker starting-point nil) )) - (defun ada-tab-hard () "Indent current line to next tab stop." (interactive) @@ -3396,12 +3610,11 @@ (if (save-excursion (= (point) (progn (beginning-of-line) (point)))) (forward-char ada-indent))) - (defun ada-untab-hard () "indent current line to previous tab stop." (interactive) (let ((bol (save-excursion (progn (beginning-of-line) (point)))) - (eol (save-excursion (progn (end-of-line) (point))))) + (eol (save-excursion (progn (end-of-line) (point))))) (indent-rigidly bol eol (- 0 ada-indent)))) @@ -3411,7 +3624,7 @@ ;;;---------------;;; (defun ada-remove-trailing-spaces () - "remove trailing spaces in the whole buffer." + "remove trailing spaces in the whole buffer." (interactive) (save-match-data (save-excursion @@ -3422,19 +3635,6 @@ (replace-match "" nil nil)))))) -(defun ada-untabify-buffer () -;; change all tabs to spaces - (save-excursion - (untabify (point-min) (point-max)) - nil)) - - -(defun ada-uncomment-region (beg end) - "delete `comment-start' at the beginning of a line in the region." - (interactive "r") - (comment-region beg end -1)) - - ;; define a function to support find-file.el if loaded (defun ada-ff-other-window () "Find other file in other window using `ff-find-other-file'." @@ -3463,7 +3663,6 @@ ;;;-------------------------------;;; ;;; Moving To Procedures/Packages ;;; ;;;-------------------------------;;; - (defun ada-next-procedure () "Moves point to next procedure." (interactive) @@ -3498,208 +3697,296 @@ ;;;----------------------- -;;; define keymap for Ada +;;; define keymap and menus for Ada ;;;----------------------- -(if (not ada-mode-map) - (progn - (setq ada-mode-map (make-sparse-keymap)) - - ;; Indentation and Formatting - (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent) - (define-key ada-mode-map "\t" 'ada-tab) - (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region) - (if (ada-xemacs) - (define-key ada-mode-map '(shift tab) 'ada-untab) - (define-key ada-mode-map [S-tab] 'ada-untab)) - (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) - (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer) -;;; We don't want to make meta-characters case-specific. -;;; (define-key ada-mode-map "\M-Q" 'ada-fill-comment-paragraph-justify) - (define-key ada-mode-map "\M-\C-q" 'ada-fill-comment-paragraph-postfix) - - ;; Movement -;;; It isn't good to redefine these. What should be done instead? -- rms. -;;; (define-key ada-mode-map "\M-e" 'ada-next-package) -;;; (define-key ada-mode-map "\M-a" 'ada-previous-package) - (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure) - (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure) - (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start) - (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end) - - ;; Compilation - (define-key ada-mode-map "\C-c\C-c" 'compile) - (define-key ada-mode-map "\C-c\C-v" 'ada-check-syntax) - (define-key ada-mode-map "\C-c\C-m" 'ada-make-local) - - ;; Casing - (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region) - (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer) - - (define-key ada-mode-map "\177" 'backward-delete-char-untabify) - - ;; Use predefined function of emacs19 for comments (RE) - (define-key ada-mode-map "\C-c;" 'comment-region) - (define-key ada-mode-map "\C-c:" 'ada-uncomment-region) - - ;; Change basic functionality - - ;; `substitute-key-definition' is not defined equally in Emacs - ;; and XEmacs, you cannot put in an optional 4th parameter in - ;; XEmacs. I don't think it's necessary, so I leave it out for - ;; Emacs as well. If you encounter any problems with the - ;; following three functions, please tell me. RE - (mapcar (function (lambda (pair) - (substitute-key-definition (car pair) (cdr pair) - ada-mode-map))) - '((beginning-of-line . ada-beginning-of-line) - (end-of-line . ada-end-of-line) - (forward-to-indentation . ada-forward-to-indentation) - )) - ;; else Emacs - ;;(mapcar (lambda (pair) - ;; (substitute-key-definition (car pair) (cdr pair) - ;; ada-mode-map global-map)) - - )) +(defun ada-create-keymap () + "Create the keymap associated with the Ada mode" + + ;; Indentation and Formatting + (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent-conditional) + (define-key ada-mode-map "\C-m" 'ada-indent-newline-indent-conditional) + (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) + (if ada-xemacs + (define-key ada-mode-map '(shift tab) 'ada-untab) + (define-key ada-mode-map [S-tab] 'ada-untab)) + (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) + ;; We don't want to make meta-characters case-specific. + + ;; Movement + (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure) + (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure) + (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start) + (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end) + + ;; Compilation + (unless (lookup-key ada-mode-map "\C-c\C-c") + (define-key ada-mode-map "\C-c\C-c" 'compile)) + + ;; Casing + (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 "\177" 'backward-delete-char-untabify) + + ;; Make body + (define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body) + + ;; 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) + + ) + +(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") + (autoload 'imenu "imenu") + (easy-menu-define + ada-mode-menu ada-mode-map "Menu keymap for Ada mode" + '("Ada" + ("Help" + ["Ada Mode" (info "ada-mode") t]) + ["Customize" (customize-group 'ada) (>= emacs-major-version 20)] + ("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] + ) + ["Index" imenu t] + )) + + (if ada-xemacs + (progn + (easy-menu-add ada-mode-menu ada-mode-map) + (define-key ada-mode-map [menu-bar] ada-mode-menu) + (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu)) + ) + ) + ) -;;;------------------- -;;; define menu 'Ada' -;;;------------------- - -(require 'easymenu) - -(defun ada-add-ada-menu () - "Adds the menu 'Ada' to the menu bar in Ada mode." - (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode." - '("Ada" - ["Next Package" ada-next-package t] - ["Previous Package" ada-previous-package t] - ["Next Procedure" ada-next-procedure t] - ["Previous Procedure" ada-previous-procedure t] - ["Goto Start" ada-move-to-start t] - ["Goto End" ada-move-to-end t] - ["------------------" nil nil] - ["Indent Current Line (TAB)" - ada-indent-current-function t] - ["Indent Lines in Region" ada-indent-region t] - ["Format Parameter List" ada-format-paramlist t] - ["Pretty Print Buffer" ada-call-pretty-printer t] - ["------------" nil nil] - ["Fill Comment Paragraph" - ada-fill-comment-paragraph t] - ["Justify Comment Paragraph" - ada-fill-comment-paragraph-justify t] - ["Postfix Comment Paragraph" - ada-fill-comment-paragraph-postfix t] - ["------------" nil nil] - ["Adjust Case Region" ada-adjust-case-region t] - ["Adjust Case Buffer" ada-adjust-case-buffer t] - ["----------" nil nil] - ["Comment Region" comment-region t] - ["Uncomment Region" ada-uncomment-region t] - ["----------------" nil nil] - ["Global Make" compile (fboundp 'compile)] - ["Local Make" ada-make-local t] - ["Check Syntax" ada-check-syntax t] - ["Next Error" next-error (fboundp 'next-error)] - ["---------------" nil nil] - ["Index" imenu (fboundp 'imenu)] - ["--------------" nil nil] - ["Other File Other Window" ada-ff-other-window - (fboundp 'ff-find-other-file)] - ["Other File" ff-find-other-file - (fboundp 'ff-find-other-file)])) - (if (ada-xemacs) (progn - (easy-menu-add ada-mode-menu) - (setq mode-popup-menu (cons "Ada mode" ada-mode-menu))))) - - - -;;;------------------------------- -;;; Define Some Support Functions -;;;------------------------------- - -(defun ada-beginning-of-line (&optional arg) + + +;; +;; The two following calls are provided to enhance the standard +;; comment-region function, which only allows uncommenting if the +;; comment is at the beginning of a line. If the line have been reindented, +;; we are unable to use comment-region, which makes no sense. +;; +(defadvice comment-region (before ada-uncomment-anywhere) + (if (and arg + (< arg 0) + (string= mode-name "Ada")) + (save-excursion + (let ((cs (concat "^[ \t]*" (regexp-quote comment-start)))) + (goto-char beg) + (while (re-search-forward cs end t) + (replace-match comment-start)) + )))) + +;; +;; Handling of comments +;; + +(defun ada-uncomment-region (beg end &optional arg) + "delete `comment-start' at the beginning of a line in the region." + (interactive "r\nP") + (ad-activate 'comment-region) + (comment-region beg end (- (or arg 1))) + (ad-deactivate 'comment-region)) + +(defun ada-fill-comment-paragraph-justify () + "Fills current comment paragraph and justifies each line as well." + (interactive) + (ada-fill-comment-paragraph 'full)) + +(defun ada-fill-comment-paragraph-postfix () + "Fills current comment paragraph and justifies each line as well. +Adds `ada-fill-comment-postfix' at the end of each line" + (interactive) + (ada-fill-comment-paragraph 'full t)) + +(defun ada-fill-comment-paragraph (&optional justify postfix) + "Fills the current comment paragraph. +If JUSTIFY is non-nil, each line is justified as well. +If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended +to each filled and justified line. +The paragraph is indented on the first line." (interactive "P") - (cond - ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg)) - (t (beginning-of-line arg)) - )) - -(defun ada-end-of-line (&optional arg) - (interactive "P") - (cond - ((eq ada-tab-policy 'indent-af) (af-end-of-line arg)) - (t (end-of-line arg)) - )) - -(defun ada-current-column () - (cond - ((eq ada-tab-policy 'indent-af) (af-current-column)) - (t (current-column)) - )) - -(defun ada-forward-to-indentation (&optional arg) - (interactive "P") - (cond - ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg)) - (t (forward-to-indentation arg)) - )) + + ;; check if inside comment or just in front a comment + (if (and (not (ada-in-comment-p)) + (not (looking-at "[ \t]*--"))) + (error "not inside comment")) + + (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 + (parse-sexp-lookup-properties nil) + + fill-prefix + (fill-column (current-fill-column))) + + ;; Find end of paragraph + (back-to-indentation) + (while (and (not (eobp)) (looking-at "--[ \t]*[^ \t\n]")) + (forward-line 1) + (back-to-indentation)) + (beginning-of-line) + (set 'to (point-marker)) + (goto-char opos) + + ;; Find beginning of paragraph + (back-to-indentation) + (while (and (not (bobp)) (looking-at "--[ \t]*[^ \t\n]")) + (forward-line -1) + (back-to-indentation)) + (forward-line 1) + (beginning-of-line) + (set 'from (point-marker)) + + ;; Calculate the indentation we will need for the paragraph + (back-to-indentation) + (set 'indent (current-column)) + ;; unindent the first line of the paragraph + (delete-region from (point)) + + ;; Remove the old postfixes + (goto-char from) + (while (re-search-forward (concat ada-fill-comment-postfix "\n") to t) + (replace-match "\n")) + + (goto-char (1- to)) + (set 'to (point-marker)) + + ;; Indent and justify the paragraph + (set 'fill-prefix ada-fill-comment-prefix) + (set-left-margin from to indent) + (if postfix + (set 'fill-column (- fill-column (length ada-fill-comment-postfix)))) + + (fill-region-as-paragraph from to justify) + + ;; Add the postfixes if required + (if postfix + (save-restriction + (goto-char from) + (narrow-to-region from to) + (while (not (eobp)) + (end-of-line) + (insert-char ? (- fill-column (current-column))) + (insert ada-fill-comment-postfix) + (forward-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 + (<= emacs-major-version 19) + (and (= emacs-major-version 20) + (<= emacs-minor-version 2))) + (progn + (goto-char to) + (end-of-line) + (delete-char 1))) + + (goto-char opos))) ;;;--------------------------------------------------- ;;; support for find-file.el ;;;--------------------------------------------------- - -;;;###autoload +;;; Note : this function is overwritten when we work with GNAT: we then +;;; use gnatkrunch (defun ada-make-filename-from-adaname (adaname) - "Determine the filename of a package/procedure from its own Ada name." - ;; this is done simply by calling `gnatkr', when we work with GNAT. It - ;; must be a more complex function in other compiler environments. - (interactive "s") - (let (krunch-buf) - (setq krunch-buf (generate-new-buffer "*gkrunch*")) - (save-excursion - (set-buffer krunch-buf) - ;; send adaname to external process `gnatkr'. - (call-process "gnatkr" nil krunch-buf nil - adaname ada-krunch-args) - ;; fetch output of that process - (setq adaname (buffer-substring - (point-min) - (progn - (goto-char (point-min)) - (end-of-line) - (point)))) - (kill-buffer krunch-buf))) - (setq adaname adaname) ;; can I avoid this statement? + "Determine the filename of a package/procedure from its own Ada name. +This is a generic function, independant from any compiler." + (while (string-match "\\." adaname) + (set 'adaname (replace-match "-" t t adaname))) + adaname ) +(defun ada-other-file-name () + "Return the name of the other file (the body if current-buffer is the spec, +or the spec otherwise." + (let ((ff-always-try-to-create nil) + (buffer (current-buffer)) + name) + (ff-find-other-file nil t);; same window, ignore 'with' lines + (if (equal buffer (current-buffer)) + + ;; other file not found + "" + + ;; other file found + (set 'name (buffer-file-name)) + (switch-to-buffer buffer) + name))) ;;; functions for placing the cursor on the corresponding subprogram (defun ada-which-function-are-we-in () "Determine whether we are on a function definition/declaration. -If that is the case remember the name of that function." - - (setq ff-function-name nil) - +If that is the case remember the name of that function. +This function is used in support of the find-file.el package" + + (set 'ff-function-name nil) (save-excursion - (if (re-search-backward ada-procedure-start-regexp nil t) - (setq ff-function-name (buffer-substring (match-beginning 0) - (match-end 0))) - ; we didn't find a procedure start, perhaps there is a package - (if (re-search-backward ada-package-start-regexp nil t) - (setq ff-function-name (buffer-substring (match-beginning 0) - (match-end 0))) - )))) - + (end-of-line);; make sure we get the complete name + (if (or (re-search-backward ada-procedure-start-regexp nil t) + (re-search-backward ada-package-start-regexp nil t)) + (set 'ff-function-name (match-string 0))) + )) + +(defun ada-set-point-accordingly () + "Move to the function declaration that was set by `ff-which-function-are-we-in'" + (if ff-function-name + (progn + (goto-char (point-min)) + (unless (ada-search-ignore-string-comment (concat ff-function-name "\\b") nil) + (goto-char (point-min)))))) ;;;--------------------------------------------------- ;;; support for font-lock ;;;--------------------------------------------------- - ;; Strings are a real pain in Ada because a single quote character is ;; overloaded as a string quote and type/instance delimiter. By default, a ;; single quote is given punctuation syntax in `ada-mode-syntax-table'. @@ -3708,206 +3995,175 @@ (defconst ada-font-lock-syntactic-keywords ;; Mark single quotes as having string quote syntax in 'c' instances. - '(("\\(\'\\).\\(\'\\)" (1 (7 . ?\')) (2 (7 . ?\'))))) - -(defconst ada-font-lock-keywords-1 - (list - ;; - ;; handle "type T is access function return S;" - ;; - (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) ) - ;; - ;; accept, entry, function, package (body), protected (body|type), - ;; pragma, procedure, task (body) plus name. - (list (concat - "\\<\\(" - "accept\\|" - "entry\\|" - "function\\|" - "package[ \t]+body\\|" - "package\\|" - "pragma\\|" - "procedure\\|" - "protected[ \t]+body\\|" - "protected[ \t]+type\\|" - "protected\\|" -;; "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\ -;;\\|r\\(agma\\|ocedure\\)\\)\\|" - "task[ \t]+body\\|" - "task[ \t]+type\\|" - "task" -;; "task\\(\\|[ \t]+body\\)" - "\\)\\>[ \t]*" - "\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))) - "Subdued level highlighting for Ada mode.") - -(defconst ada-font-lock-keywords-2 - (append ada-font-lock-keywords-1 - (list - ;; - ;; Main keywords, except those treated specially below. - (concat "\\<\\(" -; ("abort" "abs" "abstract" "accept" "access" "aliased" "all" -; "and" "array" "at" "begin" "case" "declare" "delay" "delta" -; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" -; "generic" "if" "in" "is" "limited" "loop" "mod" "not" -; "null" "or" "others" "private" "protected" -; "range" "record" "rem" "renames" "requeue" "return" "reverse" -; "select" "separate" "tagged" "task" "terminate" "then" "until" -; "while" "xor") - "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|" - "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|" - "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|" - "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|" - "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|" - "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|" - "r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" - "se\\(lect\\|parate\\)\\|" - "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed - "wh\\(ile\\|en\\)\\|xor" ; "when" added - "\\)\\>") - ;; - ;; Anything following end and not already fontified is a body name. - '("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?" - (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) - ;; - ;; Variable name plus optional keywords followed by a type name. Slow. -; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*" -; "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*" -; "\\(\\sw+\\)?") -; '(1 font-lock-variable-name-face) -; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t)) - ;; - ;; Optional keywords followed by a type name. - (list (concat ; ":[ \t]*" - "\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>" - "[ \t]*" - "\\(\\sw+\\)?") - '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) - ;; - ;; Keywords followed by a type or function name. - (list (concat "\\<\\(" - "new\\|of\\|subtype\\|type" - "\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*\\((\\)?") - '(1 font-lock-keyword-face) - '(2 (if (match-beginning 4) - font-lock-function-name-face - font-lock-type-face) nil t)) - ;; - ;; Keywords followed by a (comma separated list of) reference. - (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed - ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE - "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W") - '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t)) - ;; - ;; Goto tags. - '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face) + ;; As a special case, ''' will not be hilighted, but if we do not + ;; set this special case, then the rest of the buffer is hilighted as + ;; a string + ;; This sets the properties of the characters, so that ada-in-string-p + ;; correctly handles '"' too... + '(("\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?'))) + ("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n))) )) - "Gaudy level highlighting for Ada mode.") - -(defvar ada-font-lock-keywords ada-font-lock-keywords-1 + +(defvar ada-font-lock-keywords + (eval-when-compile + (list + ;; + ;; handle "type T is access function return S;" + (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) ) + + ;; preprocessor line + (list "^[ \t]*\\(#.*\n\\)" '(1 font-lock-type-face t)) + + ;; + ;; accept, entry, function, package (body), protected (body|type), + ;; pragma, procedure, task (body) plus name. + (list (concat + "\\<\\(" + "accept\\|" + "entry\\|" + "function\\|" + "package[ \t]+body\\|" + "package\\|" + "pragma\\|" + "procedure\\|" + "protected[ \t]+body\\|" + "protected[ \t]+type\\|" + "protected\\|" + "task[ \t]+body\\|" + "task[ \t]+type\\|" + "task" + "\\)\\>[ \t]*" + "\\(\\sw+\\(\\.\\sw*\\)*\\)?") + '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)) + ;; + ;; Optional keywords followed by a type name. + (list (concat ; ":[ \t]*" + "\\<\\(access[ \t]+all\\|access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>" + "[ \t]*" + "\\(\\sw+\\(\\.\\sw*\\)*\\)?") + '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) + + ;; + ;; Main keywords, except those treated specially below. + (concat "\\<" + (regexp-opt + '("abort" "abs" "abstract" "accept" "access" "aliased" "all" + "and" "array" "at" "begin" "case" "declare" "delay" "delta" + "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" + "generic" "if" "in" "is" "limited" "loop" "mod" "not" + "null" "or" "others" "private" "protected" "raise" + "range" "record" "rem" "renames" "requeue" "return" "reverse" + "select" "separate" "tagged" "task" "terminate" "then" "until" + "when" "while" "xor") t) + "\\>") + ;; + ;; Anything following end and not already fontified is a body name. + '("\\<\\(end\\)\\>\\([ \t]+\\)?\\(\\(\\sw\\|[_.]\\)+\\)?" + (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) + ;; + ;; Keywords followed by a type or function name. + (list (concat "\\<\\(" + "new\\|of\\|subtype\\|type" + "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?") + '(1 font-lock-keyword-face) + '(2 (if (match-beginning 4) + font-lock-function-name-face + font-lock-type-face) nil t)) + ;; + ;; Keywords followed by a (comma separated list of) reference. + (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed + "[ \t\n]*\\(\\(\\sw\\|[_.|, \t\n]\\)+\\)\\W") + '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) + ;; + ;; Goto tags. + '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face) + )) "Default expressions to highlight in Ada mode.") - -;; set font-lock properties for XEmacs -(if (ada-xemacs) - (put 'ada-mode 'font-lock-defaults - '(ada-font-lock-keywords - nil t ((?\_ . "w")(?\. . "w")) beginning-of-line))) - -;;; -;;; support for outline -;;; - -;; used by outline-minor-mode +;; +;; outline-minor-mode support + (defun ada-outline-level () - ;; This so that `current-column' DTRT in otherwise-hidden text. + ;; This is so that `current-column` DTRT in otherwise-hidden text + ;; patch from Dave Love <fx@gnu.org> (let (buffer-invisibility-spec) (save-excursion - (skip-chars-forward "\t ") + (back-to-indentation) (current-column)))) -;;; -;;; generate body -;;; -(defun ada-gen-comment-until-proc () - ;; comment until spec of a procedure or a function. - (forward-line 1) - (set-mark-command (point)) - (if (re-search-forward ada-procedure-start-regexp nil t) - (progn (goto-char (match-beginning 1)) - (comment-region (mark) (point))) - (error "No more functions/procedures"))) - +;; +;; Body generation +;; (defun ada-gen-treat-proc (match) ;; make dummy body of a procedure/function specification. ;; MATCH is a cons cell containing the start and end location of the - ;; last search for ada-procedure-start-regexp. + ;; last search for ada-procedure-start-regexp. (goto-char (car match)) - (let (proc-found func-found procname functype) - (cond - ((or (setq proc-found (looking-at "^[ \t]*procedure")) - (setq func-found (looking-at "^[ \t]*function"))) - ;; treat it as a proc/func - (forward-word 2) - (forward-word -1) - (setq procname (buffer-substring (point) (cdr match))) ; store proc name - - ;; goto end of procname - (goto-char (cdr match)) - - ;; skip over parameterlist - (forward-sexp) - ;; if function, skip over 'return' and result type. - (if func-found - (progn - (forward-word 1) - (skip-chars-forward " \t\n") - (setq functype (buffer-substring (point) - (progn - (skip-chars-forward - "a-zA-Z0-9_\.") - (point)))))) - ;; look for next non WS + (let (func-found procname functype) (cond - ((looking-at "[ \t]*;") - (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';' - (ada-indent-newline-indent) - (insert " is") - (ada-indent-newline-indent) - (if func-found - (progn - (insert "Result : ") - (insert functype) - (insert ";") - (ada-indent-newline-indent))) - (insert "begin -- ") - (insert procname) - (ada-indent-newline-indent) - (insert "null;") - (ada-indent-newline-indent) + ((or (looking-at "^[ \t]*procedure") + (set 'func-found (looking-at "^[ \t]*function"))) + ;; treat it as a proc/func + (forward-word 2) + (forward-word -1) + (set 'procname (buffer-substring (point) (cdr match))) ; store proc name + + ;; goto end of procname + (goto-char (cdr match)) + + ;; skip over parameterlist + (unless (looking-at "[ \t\n]*\\(;\\|return\\)") + (forward-sexp)) + + ;; if function, skip over 'return' and result type. (if func-found - (progn - (insert "return Result;") - (ada-indent-newline-indent))) - (insert "end ") - (insert procname) - (insert ";") - (ada-indent-newline-indent) - ) - ;; else - ((looking-at "[ \t\n]*is") - ;; do nothing - ) - ((looking-at "[ \t\n]*rename") - ;; do nothing - ) + (progn + (forward-word 1) + (skip-chars-forward " \t\n") + (set 'functype (buffer-substring (point) + (progn + (skip-chars-forward + "a-zA-Z0-9_\.") + (point)))))) + ;; look for next non WS + (cond + ((looking-at "[ \t]*;") + (delete-region (match-beginning 0) (match-end 0));; delete the ';' + (ada-indent-newline-indent) + (insert "is") + (ada-indent-newline-indent) + (if func-found + (progn + (insert "Result : " functype ";") + (ada-indent-newline-indent))) + (insert "begin") + (ada-indent-newline-indent) + (if func-found + (insert "return Result;") + (insert "null;")) + (ada-indent-newline-indent) + (insert "end " procname ";") + (ada-indent-newline-indent) + ) + ;; else + ((looking-at "[ \t\n]*is") + ;; do nothing + ) + ((looking-at "[ \t\n]*rename") + ;; do nothing + ) + (t + (message "unknown syntax")))) (t - (message "unknown syntax"))) - )))) - + (if (looking-at "^[ \t]*task") + (progn + (message "Task conversion is not yet implemented") + (forward-word 2) + (if (looking-at "[ \t]*;") + (forward-line) + (ada-move-to-end)) + )))))) (defun ada-make-body () "Create an Ada package body in the current buffer. @@ -3920,27 +4176,104 @@ (insert-buffer (car (cdr (buffer-list)))) (ada-mode) - (let (found) - (if (setq found - (ada-search-ignore-string-comment ada-package-start-regexp)) - (progn (goto-char (cdr found)) - (insert " body") - ;; (forward-line -1) - ;;(comment-region (point-min) (point)) - ) + (let (found ada-procedure-or-package-start-regexp) + (if (set 'found + (ada-search-ignore-string-comment ada-package-start-regexp nil)) + (progn (goto-char (cdr found)) + (insert " body") + ) (error "No package")) - - ;; (comment-until-proc) - ;; does not work correctly - ;; must be done by hand - - (while (setq found - (ada-search-ignore-string-comment ada-procedure-start-regexp)) - (ada-gen-treat-proc found)))) - - -;;; provide ourself - + + (set 'ada-procedure-or-package-start-regexp + (concat ada-procedure-start-regexp + "\\|" + ada-package-start-regexp)) + + (while (set 'found + (ada-search-ignore-string-comment + ada-procedure-or-package-start-regexp nil)) + (progn + (goto-char (car found)) + (if (looking-at ada-package-start-regexp) + (progn (goto-char (cdr found)) + (insert " body")) + (ada-gen-treat-proc found)))))) + +(defun ada-make-subprogram-body () + "make one dummy subprogram body from spec surrounding point" + (interactive) + (let* ((found (re-search-backward ada-procedure-start-regexp nil t)) + (spec (match-beginning 0))) + (if found + (progn + (goto-char spec) + (if (and (re-search-forward "(\\|;" nil t) + (= (char-before) ?\()) + (progn + (ada-search-ignore-string-comment ")" nil) + (ada-search-ignore-string-comment ";" nil))) + (set 'spec (buffer-substring spec (point))) + + ;; If find-file.el was available, use its functions + (if (functionp 'ff-get-file) + (find-file (ff-get-file + ff-search-directories + (ada-make-filename-from-adaname + (file-name-nondirectory + (file-name-sans-extension (buffer-name)))) + ada-body-suffixes)) + ;; Else emulate it very simply + (find-file (concat (ada-make-filename-from-adaname + (file-name-nondirectory + (file-name-sans-extension (buffer-name)))) + ".adb"))) + + (save-restriction + (widen) + (goto-char (point-max)) + (forward-comment -10000) + (re-search-backward "\\<end\\>" nil t) + ;; Move to the beginning of the elaboration part, if any + (re-search-backward "^begin" nil t) + (newline) + (forward-char -1) + (insert spec) + (re-search-backward ada-procedure-start-regexp nil t) + (ada-gen-treat-proc (cons (match-beginning 0) (match-end 0))) + )) + (error "Not in subprogram spec")))) + +;; Create the keymap once and for all. If we do that in ada-mode, +;; the keys changed in the user's .emacs have to be modified +;; every time +(ada-create-keymap) +(ada-create-menu) + +;; Create the syntax tables, but do not activate them +(ada-create-syntax-table) + +;; Add the default extensions (and set up speedbar) +(ada-add-extensions ".ads" ".adb") +;; This two files are generated by GNAT when running with -gnatD +(if (equal ada-which-compiler 'gnat) + (ada-add-extensions ".ads.dg" ".adb.dg")) + +;; Read the special cases for exceptions +(ada-case-read-exceptions) + +;; include 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. + (condition-case nil (require 'ada-prj) (error nil)) + (require 'ada-xref) + )) +(condition-case nil (require 'ada-stmt) (error nil)) + +;;; provide ourselves (provide 'ada-mode) ;;; ada-mode.el ends here +