Mercurial > emacs
changeset 10705:3d356714b662
Initial revision
| author | Richard M. Stallman <rms@gnu.org> |
|---|---|
| date | Thu, 09 Feb 1995 00:01:34 +0000 |
| parents | 0b7596c02db4 |
| children | 918e43cfede6 |
| files | lisp/progmodes/ada-mode.el |
| diffstat | 1 files changed, 3788 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/ada-mode.el Thu Feb 09 00:01:34 1995 +0000 @@ -0,0 +1,3788 @@ +;;; ada-mode.el - An Emacs major-mode for editing Ada source. +;;; Copyright (C) 1994 Free Software Foundation, Inc. + +;;; Authors: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> +;;; Rolf Ebert <ebert@inf.enst.fr> + +;;; This file is part of GNU Emacs. + +;; GNU Emacs 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, +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; This mode is a complete rewrite of a major mode for editing Ada 83 +;;; and Ada 94 source code under Emacs-19. It contains completely new +;;; indenting code and support for code browsing (see ada-xref). + + +;;; COMMENTARY +;;; ========== +;;; Put the ada-mode.el file in your load-path (for .el files) and +;;; optionally byte compile it. It becomes a lot faster, if byte +;;; compiled. Don't care about the warnings; they are harmless. +;;; +;;; To make emacs start up Ada Mode when loading a ada source, add +;;; these lines to your .emacs: +;;; +;;; (autoload 'ada-mode "ada-mode" nil t) +;;; (setq auto-mode-alist (cons '("\\.ad[abs]$" . ada-mode) +;;; auto-mode-alist)) + +;;; USAGE +;;; ===== +;;; If you have modified your startup file as described above, emacs +;;; should enter ada-mode when you load an ada source into emacs. +;;; +;;; 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 +;;; ======= +;;; The first Ada mode for GNU Emacs was written by V. Bowman in +;;; 1985. He based his work on the already existing Modula-2 mode. The +;;; file is called ada.el and is currently distributed with Emacs. +;;; +;;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of +;;; several files with support for dired commands and other nice +;;; things. It is currently available from the PAL +;;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z. +;;; +;;; The probably very first Ada mode (called electric-ada.el) was +;;; written by Steven D. Litvintchouk and Steven M. Rosen for the +;;; 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 +;;; 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 / BUGREPORTS +;;; ======================= +;;; +;;; In the presence of comments and/or incorrect syntax +;;; ada-format-paramlist produces weird results. +;;; +;;; Indentation is sometimes wrong at the very beginning of the buffer. +;;; So please try it on different locations. If it's still wrong then +;;; report the bug. +;;; +;;; At the moment the browsing functions are limited to the use of the +;;; separate packages "find-file.el" and "ada-xref.el" (ada-xref.el is +;;; only for GNAT users). +;;; +;;; indenting of some tasking constructs is not yet supported. +;;; +;;; `reformat-region' sometimes generates some weird indentation. +;;; +;;;> I have the following suggestions for the function template: 1) I +;;;> don't want it automatically assigning it a name for the return variable. I +;;;> never want it to be called "Result" because that is nondescriptive. If you +;;;> must define a variable, give me the ability to specify its name. +;;;> +;;;> 2) You do not provide a type for variable 'Result'. Its type is the same +;;;> as the function's return type, which the template knows, so why force me +;;;> to type it in? +;;;> + +;;;As alwyas, different users have different tastes. +;;;It would be nice if one could configure such layout details separately +;;;without patching the LISP code. Maybe the metalanguage used in ada-stmt.el +;;;could be taken even further, providing the user with some nice syntax +;;;for describing layout. Then my own hacks would survive the next +;;;update of the package :-) + +;;;By the way, there are som more quirks: + +;;;1) text entered in prompt mode (*) is not converted to upper case (I have +;;; choosen upper case for indentifiers). +;;; (*) I would like to suggest the term "template code" instead of +;;; "pseudo code". + +;;; There are quite a few problems in the crossreferencing part. These +;;; are partly due to errors in gnatf. One of the major bugs in +;;; ada-xref is, that we do not wait for gnatf to rebuild the xref file. +;;; We start the job, but do not wait for finishing. + + +;;; LCD Archive Entry: +;;; ada-mode|Rolf Ebert|<ebert@inf.enst.fr> +;;; |Major-mode for Ada +;;; |$Date: 1994/11/28 12:12:08 $|$Revision: 2.10 $| + + +(defconst ada-mode-version (substring "$Revision: 2.10 $" 11 -2) + "$Id: ada-mode.el,v 2.10 1994/11/28 12:12:08 re Exp $ + +Report bugs to: Rolf Ebert <ebert@inf.enst.fr>") + + +;;;-------------------- +;;; USER OPTIONS +;;;-------------------- + +;; ---- configure indentation + +(defvar ada-indent 3 + "*Defines the size of Ada indentation.") + +(defvar ada-broken-indent 2 + "*# of columns to indent the continuation of a broken line.") + +(defvar ada-label-indent -4 + "*# of columns to indent a label.") + +(defvar ada-stmt-end-indent 0 + "*# of columns to indent a statement end keyword in a separate line. +Examples are 'is', 'loop', 'record', ...") + +(defvar ada-when-indent 3 + "*Defines the indentation for 'when' relative to 'exception' or 'case'.") + +(defvar ada-indent-record-rel-type 3 + "*Defines the indentation for 'record' relative to 'type' or 'use'.") + +(defvar ada-indent-comment-as-code t + "*If non-nil, comment-lines get indented as ada-code.") + +(defvar ada-indent-is-separate t + "*If non-nil, 'is separate' or 'is abstract' on a separate line are +indented.") + +(defvar ada-indent-to-open-paren t + "*If non-nil, following lines get indented according to the innermost +open parenthesis.") + +(defvar ada-search-paren-line-count-limit 5 + "*Search that many non-blank non-comment lines for an open parenthesis. +Values higher than about 5 horribly slow down the indenting.") + + +;; ---- other user options + +(defvar 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.") + +(defvar ada-move-to-declaration nil + "*If non-nil, ada-move-to-start moves point to the subprog-declaration, +not to 'begin'.") + +(defvar ada-spec-suffix ".ads" + "*Suffix of Ada specification files.") + +(defvar ada-body-suffix ".adb" + "*Suffix of Ada body files.") + +(defvar ada-language-version 'ada94 + "*Do we program in 'ada83 or 'ada94?") + +(defvar ada-case-keyword 'downcase-word + "*downcase-word, upcase-word, ada-loose-case-word or capitalize-word +to adjust ada keywords case.") + +(defvar ada-case-identifier 'ada-loose-case-word + "*downcase-word, upcase-word, ada-loose-case-word or capitalize-word +to adjust ada identifier case.") + +(defvar ada-auto-case t + "*Non-nil automatically changes casing of preceeding word while typing. +Casing is done according to ada-case-keyword and ada-case-identifier.") + +(defvar ada-clean-buffer-before-saving nil + "*If non-nil, remove-trailing-spaces and untabify buffer before saving.") + +(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.") + +(defvar ada-external-pretty-print-program "aimap" + "*External pretty printer to call from within Ada Mode.") + +(defvar ada-tmp-directory "/tmp/" + "*Directory to store the temporary file for the Ada pretty printer.") + +(defvar ada-fill-comment-prefix "-- " + "*This is inserted in the first columns when filling a comment paragraph.") + +(defvar ada-fill-comment-postfix " --" + "*This is inserted at the end of each line when filling a comment paragraph +with ada-fill-comment-paragraph postfix.") + +(defvar ada-krunch-args "250" + "*Argument of gnatk8, a string containing the max number of characters. +Set to a big number, if you dont use crunched filenames.") + +;;; ---- 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 () + "Local keymap used for ada-mode.") + +(defvar ada-mode-syntax-table nil + "Syntax table to be used for editing Ada source code.") + +(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\\)\\>" + "regular expression for looking at Ada83 keywords.") + +(defconst ada-94-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\\)\\>" + "regular expression for looking at Ad94 keywords.") + +(defvar ada-keywords ada-94-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 + +(defvar ada-procedure-start-regexp + "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)" + "Regexp used to find Ada procedures/functions.") + +(defvar ada-package-start-regexp + "^[ \t]*\\(package\\)" + "Regexp used to find Ada packages") + + +;;; ---- regexps for indentation functions + +(defvar ada-block-start-re + "\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\ +exception\\|loop\\|record\\|else\\)\\>" + "Regexp for keywords starting ada-blocks.") + +(defvar ada-end-stmt-re + "\\(;\\|=>\\|\\<\\(begin\\|record\\|loop\\|select\\|do\\|\ +exception\\|declare\\|generic\\|private\\)\\>\\)" + "Regexp of possible ends for a non-broken statement. +'end' means that there has to start a new statement after these.") + +(defvar ada-loop-start-re + "\\<\\(for\\|while\\|loop\\)\\>" + "Regexp for the start of a loop.") + +(defvar ada-subprog-start-re + "\\<\\(procedure\\|function\\|task\\|accept\\)\\>" + "Regexp for the start of a subprogram.") + + +;;;------------- +;;; functions +;;;------------- + +(defun ada-create-syntax-table () + "Create the syntax table for ada-mode." + ;; This syntax table is a merge of two syntax tables I found + ;; in the two ada modes in the old ada.el and the old + ;; electric-ada.el. (jsl) + ;; There still remains the problem, if the underscore '_' is a word + ;; constituent or not. (re) + ;; The Emacs doc clearly states that it is a symbol, and that is what most + ;; on the ada-mode list prefer. (re) + ;; For some functions, the syntactical meaning of '_' is temporaryly + ;; changed to 'w'. (mh) + (setq ada-mode-syntax-table (make-syntax-table)) + (set-syntax-table ada-mode-syntax-table) + + ;; define string brackets (% is alternative string bracket) + (modify-syntax-entry ?% "\"" ada-mode-syntax-table) + (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) + (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) + (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) + (modify-syntax-entry ?\\ "." ada-mode-syntax-table) + (modify-syntax-entry ?\' "." ada-mode-syntax-table) + + ;; a single hyphen is punctuation, but a double hyphen starts a comment + (modify-syntax-entry ?- ". 12" 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) + + ;; define what belongs in ada symbols + (modify-syntax-entry ?_ "_" ada-mode-syntax-table) + + ;; define parentheses to match + (modify-syntax-entry ?\( "()" ada-mode-syntax-table) + (modify-syntax-entry ?\) ")(" ada-mode-syntax-table) + ) + + +(defun ada-mode () + "Ada Mode is the major mode for editing Ada code. + +Bindings are as follows: (Note: 'LFD' is control-j.) + + Indent line '\\[ada-tab]' + Indent line, insert newline and indent the new line. '\\[newline-and-indent]' + + 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]' + + Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]' + Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]' + + Goto matching start of current 'end ...;' '\\[ada-move-to-start]' + Goto end of current block '\\[ada-move-to-end]' + +Comments are handled using standard GNU Emacs conventions, including: + Start a comment '\\[indent-for-comment]' + Comment region '\\[comment-region]' + Uncomment region '\\[ada-uncomment-region]' + Continue comment on next line '\\[indent-new-comment-line]' + +If you use imenu.el: + Display index-menu of functions & procedures '\\[imenu]' + +If you use find-file.el: + Switch to other file (Body <-> Spec) '\\[ff-find-other-file]' + 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 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]'" + + (interactive) + (kill-all-local-variables) + + (make-local-variable 'require-final-newline) + (setq require-final-newline t) + + (make-local-variable 'comment-start) + (setq comment-start "-- ") + + ;; 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 'font-lock-defaults) + (setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w")))) + + (setq major-mode 'ada-mode) + (setq mode-name "Ada") + + (setq blink-matching-paren t) + + (use-local-map ada-mode-map) + + (if ada-mode-syntax-table + (set-syntax-table ada-mode-syntax-table) + (ada-create-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) + + (run-hooks 'ada-mode-hook) + + ;; 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) + + (cond ((eq ada-language-version 'ada83) + (setq ada-keywords ada-83-keywords)) + ((eq ada-language-version 'ada94) + (setq ada-keywords ada-94-keywords))) + + (if ada-auto-case + (ada-activate-keys-for-case))) + + +;;;-------------------------- +;;; 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." + (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))) + + +;;;--------------------------------;;; +;;; 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 beautyfied program in the buffer and cleans up +ada-tmp-directory." + (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> +;; modifiedby RE and MH + +(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) + (looking-at (concat ada-keywords "[^_]"))))) + +(defun ada-after-char-p () + ;; returns t if after ada character "'". + (save-excursion + (if (> (point) 2) + (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, +according to ada-case-keyword and ada-case-identifier +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-after-char-p)))) + (if (eq (char-syntax (char-after (1- (point)))) ?w) + (if (and + (not force-identifier) ; (MH) + (ada-after-keyword-p)) + (funcall ada-case-keyword -1) + (funcall ada-case-identifier -1)))) + (forward-char 1)) + + +(defun ada-adjust-case-interactive (arg) + (interactive "P") + (let ((lastk last-command-char)) + (cond ((or (eq lastk ?\n) + (eq lastk ?\r)) + ;; horrible kludge + (insert " ") + (ada-adjust-case) + ;; horrible dekludge + (delete-backward-char 1) + ;; some special keys and their bindings + (cond + ((eq lastk ?\n) + (funcall ada-lfd-binding)) + ((eq lastk ?\r) + (funcall ada-ret-binding)))) + ((eq lastk ?\C-i) (ada-tab)) + ((self-insert-command (prefix-numeric-value arg)))) + ;; if there is a keyword in front of the underscore + ;; then it should be part of an identifier (MH) + (if (eq lastk ?_) + (ada-adjust-case t) + (ada-adjust-case)))) + + +(defun ada-activate-keys-for-case () + ;; 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"))) + (or ada-lfd-binding + (setq 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 + +;; +;; added by MH +;; +(defun ada-loose-case-word (&optional arg) + "Capitalizes the first and the letters following _ +ARG is ignored, it's there to fit the standard casing functions' style." + (let ((pos (point)) + (first t)) + (skip-chars-backward "a-zA-Z0-9_") + (while (or first + (search-forward "_" pos t)) + (and first + (setq first nil)) + (insert-char (upcase (following-char)) 1) + (delete-char 1)) + (goto-char pos))) + + +;; +;; added by MH +;; +(defun ada-adjust-case-region (from to) + "Adjusts the case of all identifiers and keywords in the region. +ATTENTION: This function might take very long for big regions !" + (interactive "*r") + (let ((begin nil) + (end nil) + (keywordp nil) + (reldiff nil)) + (save-excursion + (goto-char to) + ;; + ;; loop: look for all identifiers and keywords + ;; + (while (re-search-backward + "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]" + from + t) + ;; + ;; print status message + ;; + (setq reldiff (- (point) from)) + (message (format "adjusting case ... %5d characters left" + (- (point) from))) + (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 + ;; + (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) + (funcall ada-case-identifier -1)) + (goto-char begin)))) + (message "adjusting case ... done")))) + + +;; +;; added by MH +;; +(defun ada-adjust-case-buffer () + "Adjusts the case of all identifiers and keywords in the whole buffer. +ATTENTION: This function might take very long for big buffers !" + (interactive) + (ada-adjust-case-region (point-min) (point-max))) + + +;;;------------------------;;; +;;; Format Parameter Lists ;;; +;;;------------------------;;; + +(defun ada-format-paramlist () + "Re-formats a parameter-list. +ATTENTION: 1) Comments inside the list are killed ! + 2) If the syntax is not correct (especially, if there are + semicolons missing), it can get totally confused ! +In such a case, use 'undo', correct the syntax and try again." + + (interactive) + (let ((begin nil) + (end nil) + (delend nil) + (paramlist nil)) + ;; + ;; ATTENTION: modify sntax-table temporary ! + ;; + (modify-syntax-entry ?_ "w") + + ;; 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 "\\<\\(" + "procedure\\|function\\|body\\|package\\|task\\|entry\\|accept" + "\\)\\>") 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) + + ;; + ;; restore syntax-table + ;; + (modify-syntax-entry ?_ "_"))) + + +(defun ada-scan-paramlist (begin end) + ;; Scans a parameter-list between BEGIN and END and returns a list + ;; of its contents. + ;; The list has the following format: + ;; + ;; Name of Param in? out? accept? Name of Type Default-Exp or nil + ;; + ;; ( ('Name_Param_1' t nil t Type_Param_1 ':= expression') + ;; ('Name_Param_2' nil nil t Type_Param_2 nil) ) + + (let ((paramlist (list)) + (param (list)) + (notend t) + (apos nil) + (epos nil) + (semipos nil) + (match-cons nil)) + + (goto-char begin) + ;; + ;; loop until end of last parameter + ;; + (while notend + + ;; + ;; find first character of parameter-declaration + ;; + (ada-goto-next-non-ws) + (setq apos (point)) + + ;; + ;; find last character of parameter-declaration + ;; + (if (setq 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)) + + ;; + ;; 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) + + ;; + ;; look for 'in' + ;; + (setq apos (point)) + (setq param + (append param + (list + (consp + (ada-search-ignore-string-comment "\\<in\\>" + nil + epos + t))))) + + ;; + ;; look for 'out' + ;; + (goto-char apos) + (setq param + (append param + (list + (consp + (ada-search-ignore-string-comment "\\<out\\>" + nil + epos + t))))) + + ;; + ;; look for 'accept' + ;; + (goto-char apos) + (setq param + (append param + (list + (consp + (ada-search-ignore-string-comment "\\<accept\\>" + nil + epos + t))))) + + ;; + ;; skip 'in'/'out'/'accept' + ;; + (goto-char apos) + (ada-goto-next-non-ws) + (while (looking-at "\\<\\(in\\|out\\|accept\\)\\>") + (forward-word 1) + (ada-goto-next-non-ws)) + + ;; + ;; read type of parameter + ;; + (looking-at "\\<[a-zA-Z0-9_\\.]+\\>") + (setq param + (append param + (list + (buffer-substring (match-beginning 0) + (match-end 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)))) + ;; + ;; add this parameter-declaration to the list + ;; + (setq paramlist (append paramlist (list param))) + + ;; + ;; check if it was the last parameter + ;; + (if (eq epos end) + (setq notend nil) + (goto-char semipos)) + + ) ; end of loop + + (reverse paramlist))) + + +(defun ada-insert-paramlist (paramlist) + ;; Inserts a formatted PARAMLIST in the buffer. + ;; See doc of ada-scan-paramlist for the format. + (let ((i (length paramlist)) + (parlen 0) + (typlen 0) + (temp 0) + (inp nil) + (outp nil) + (acceptp nil) + (column nil) + (orgpoint 0) + (firstcol nil)) + + ;; + ;; loop until last parameter + ;; + (while (not (zerop i)) + (setq i (1- i)) + + ;; + ;; get max length of parameter-name + ;; + (setq parlen + (if (<= parlen (setq 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)) + + ;; + ;; is there any 'in' ? + ;; + (setq inp + (or inp + (nth 1 (nth i paramlist)))) + + ;; + ;; is there any 'out' ? + ;; + (setq outp + (or outp + (nth 2 (nth i paramlist)))) + + ;; + ;; is there any 'accept' ? + ;; + (setq acceptp + (or acceptp + (nth 3 (nth i paramlist))))) ; end of loop + + ;; + ;; does paramlist already start on a separate line ? + ;; + (if (save-excursion + (re-search-backward "^.\\|[^ \t]" nil t) + (looking-at "^.")) + ;; yes => re-indent it + (ada-indent-current) + ;; + ;; no => insert newline and indent it + ;; + (progn + (ada-indent-current) + (newline) + (delete-horizontal-space) + (setq orgpoint (point)) + (setq column (save-excursion + (funcall (ada-indent-function) orgpoint))) + (indent-to column) + )) + + (insert "(") + + (setq firstcol (current-column)) + (setq i (length paramlist)) + + ;; + ;; loop until last parameter + ;; + (while (not (zerop i)) + (setq i (1- i)) + (setq column firstcol) + + ;; + ;; insert parameter-name, space and colon + ;; + (insert (nth 0 (nth i paramlist))) + (indent-to (+ column parlen 1)) + (insert ": ") + (setq column (current-column)) + + ;; + ;; insert 'in' or space + ;; + (if (nth 1 (nth i paramlist)) + (insert "in ") + (if (and + (or inp + acceptp) + (not (nth 3 (nth i paramlist)))) + (insert " "))) + + ;; + ;; insert 'out' or space + ;; + (if (nth 2 (nth i paramlist)) + (insert "out ") + (if (and + (or outp + acceptp) + (not (nth 3 (nth i paramlist)))) + (insert " "))) + + ;; + ;; insert 'accept' + ;; + (if (nth 3 (nth i paramlist)) + (insert "accept ")) + + (setq column (current-column)) + + ;; + ;; insert type-name and, if necessary, space and default-expression + ;; + (insert (nth 4 (nth i paramlist))) + (if (nth 5 (nth i paramlist)) + (progn + (indent-to (+ column typlen 1)) + (insert (nth 5 (nth i paramlist))))) + + ;; + ;; 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 anything follows, except semicolon: + ;; put it in a new line and indent it + ;; + (if (not (looking-at "[ \t]*[;\n]")) + (ada-indent-newline-indent)) + + )) + + +;;;----------------------------;;; +;;; Move To Matching Start/End ;;; +;;;----------------------------;;; + +(defun ada-move-to-start () + "Moves point to the matching start of the current end ... around point." + (interactive) + (let ((pos (point))) + ;; + ;; ATTENTION: modify sntax-table temporary ! + ;; + (modify-syntax-entry ?_ "w") + + (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") + + ;; + ;; restore syntax-table + ;; + (modify-syntax-entry ?_ "_"))) + + +(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)) + ;; + ;; ATTENTION: modify sntax-table temporary ! + ;; + (modify-syntax-entry ?_ "w") + + (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") + + ;; + ;; restore syntax-table + ;; + (modify-syntax-entry ?_ "_"))) + + +;;;-----------------------------;;; +;;; Functions For Indentation ;;; +;;;-----------------------------;;; + +;; ---- 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) + ;; catch errors while indenting + (condition-case err + (while (< (point) end) + (message (format "indenting ... %4d lines left" + (count-lines (point) end))) + (ada-indent-current) + (forward-line 1)) + ;; show line number where the error occured + (error + (error (format "line %d: %s" + (1+ (count-lines (point-min) (point))) + err) nil))) + (message "indenting ... done")) + + +(defun ada-indent-newline-indent () + "Indents the current line, inserts a newline and then indents the new line." + (interactive "*") + (let ((column) + (orgpoint)) + + (ada-indent-current) + (newline) + (delete-horizontal-space) + (setq orgpoint (point)) + + ;; + ;; ATTENTION: modify syntax-table temporary ! + ;; + (modify-syntax-entry ?_ "w") + + (setq column (save-excursion + (funcall (ada-indent-function) orgpoint))) + + ;; + ;; restore syntax-table + ;; + (modify-syntax-entry ?_ "_") + + (indent-to column) + + ;; The following is needed to ensure that indentation will still be + ;; correct if something follows behind point when typing LFD + ;; For example: Imagine point to be there (*) when LFD is typed: + ;; while cond loop + ;; null; *end loop; + ;; Result without the following statement would be: + ;; while cond loop + ;; null; + ;; *end loop; + ;; You would then have to type TAB to correct it. + ;; If that doesn't bother you, you can comment out the following + ;; statement to speed up indentation a LITTLE bit. + + (if (not (looking-at "[ \t]*$")) + (ada-indent-current)) + )) + + +(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 #." + + (interactive) + + ;; + ;; ATTENTION: modify sntax-table temporary ! + ;; + (modify-syntax-entry ?_ "w") + + (let ((line-end) + (orgpoint (point-marker)) + (cur-indent) + (prev-indent) + (prevline t)) + + ;; + ;; first step + ;; + (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) + (setq line-end (point)) + (setq prev-indent (save-excursion + (funcall (ada-indent-function) line-end)))) + (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)) + (delete-horizontal-space) + (indent-to cur-indent) + + ;; + ;; restore position of point + ;; + (goto-char orgpoint) + (if (< (current-column) (current-indentation)) + (back-to-indentation))))) + + ;; + ;; restore syntax-table + ;; + (modify-syntax-entry ?_ "_")) + + +(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)) + + (cond + ;; + ;; 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))) + ;; check if we have something like this (Table_Component_Type => + ;; 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) + + ;; + ;; end + ;; + ((looking-at "\\<end\\>") + (save-excursion + (ada-goto-matching-start 1) + + ;; + ;; found 'loop' => skip back to 'while' or 'for' + ;; if 'loop' is not on a separate line + ;; + (if (and + (looking-at "\\<loop\\>") + (save-excursion + (back-to-indentation) + (not (looking-at "\\<loop\\>")))) + (if (save-excursion + (and + (setq match-cons + (ada-search-ignore-string-comment + ada-loop-start-re t nil)) + (not (looking-at "\\<loop\\>")))) + (goto-char (car match-cons)))) + + (current-indentation))) + ;; + ;; exception + ;; + ((looking-at "\\<exception\\>") + (save-excursion + (ada-goto-matching-start 1) + (current-indentation))) + ;; + ;; when + ;; + ((looking-at "\\<when\\>") + (save-excursion + (ada-goto-matching-start 1) + (+ (current-indentation) ada-when-indent))) + ;; + ;; else + ;; + ((looking-at "\\<else\\>") + (if (save-excursion + (ada-goto-previous-word) + (looking-at "\\<or\\>")) + prev-indent + (save-excursion + (ada-goto-matching-start 1 nil t) + (current-indentation)))) + ;; + ;; elsif + ;; + ((looking-at "\\<elsif\\>") + (save-excursion + (ada-goto-matching-start 1 nil t) + (current-indentation))) + ;; + ;; then + ;; + ((looking-at "\\<then\\>") + (if (save-excursion + (ada-goto-previous-word) + (looking-at "\\<and\\>")) + prev-indent + (save-excursion + (ada-search-ignore-string-comment "\\<elsif\\>\\|\\<if\\>" t nil) + (+ (current-indentation) ada-stmt-end-indent)))) + ;; + ;; loop + ;; + ((looking-at "\\<loop\\>") + (setq 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)))))) + ;; + ;; begin + ;; + ((looking-at "\\<begin\\>") + (save-excursion + (if (ada-goto-matching-decl-start t) + (current-indentation) + (progn + (message "no matching declaration start") + prev-indent)))) + ;; + ;; 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\\>"))) + (save-excursion + (ada-goto-stmt-start) + (+ (current-indentation) ada-indent)) + (save-excursion + (ada-goto-stmt-start) + (+ (current-indentation) ada-stmt-end-indent)))) + ;; + ;; record + ;; + ((looking-at "\\<record\\>") + (save-excursion + (ada-search-ignore-string-comment + "\\<\\(type\\|use\\)\\>" t nil) + (if (looking-at "\\<use\\>") + (ada-search-ignore-string-comment "\\<for\\>" t nil)) + (+ (current-indentation) ada-indent-record-rel-type))) + ;; + ;; or as statement-start + ;; + ((ada-looking-at-semi-or) + (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))) + ;; + ;; new/abstract/separate + ;; + ((looking-at "\\<\\(new\\|abstract\\|separate\\)\\>") + (- prev-indent ada-indent (- ada-broken-indent))) + ;; + ;; return + ;; + ((looking-at "\\<return\\>") + (save-excursion + (forward-sexp -1) + (if (and (looking-at "(") + (save-excursion + (backward-sexp 2) + (looking-at "\\<function\\>"))) + (1+ (current-column)) + prev-indent))) + ;; + ;; do + ;; + ((looking-at "\\<do\\>") + (save-excursion + (ada-goto-stmt-start) + (+ (current-indentation) ada-stmt-end-indent))) + ;; + ;; package/function/procedure + ;; + ((and (looking-at "\\<\\(package\\|function\\|procedure\\)\\>") + (save-excursion + (forward-char 1) + (ada-goto-stmt-start) + (looking-at "\\<\\(package\\|function\\|procedure\\)\\>"))) + (save-excursion + ;; look for 'generic' + (if (and (ada-goto-matching-decl-start t) + (looking-at "generic")) + (current-column) + prev-indent))) + ;; + ;; label + ;; + ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*:[^=]") + (if (ada-in-decl-p) + prev-indent + (+ prev-indent ada-label-indent))) + ;; + ;; identifier and other noindent-statements + ;; + ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*") + prev-indent) + ;; + ;; beginning of a parameter list + ;; + ((looking-at "(") + prev-indent) + ;; + ;; end of a parameter list + ;; + ((looking-at ")") + (save-excursion + (forward-char 1) + (backward-sexp 1) + (current-column))) + ;; + ;; comment + ;; + ((looking-at "--") + (if ada-indent-comment-as-code + prev-indent + (current-indentation))) + ;; + ;; 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) + (stmt-start nil)) + ;; + ;; 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) + (setq stmt-start (ada-goto-stmt-start))) + ;; + ;; no beginning found => don't change indentation + ;; + (if (and + (eq orgpoint (point)) + (not nomove)) + (setq func 'ada-get-indent-nochange) + + (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 "\\<package\\>") + (setq func 'ada-get-indent-subprog)) ; maybe it needs a + ; special function + ; sometimes ? + ;; + ((looking-at ada-block-start-re) + (setq func 'ada-get-indent-block-start)) + ;; + ((looking-at "\\<type\\>") + (setq func 'ada-get-indent-type)) + ;; + ((looking-at "\\<if\\>") + (setq func 'ada-get-indent-if)) + ;; + ((looking-at "\\<elsif\\>") + (setq func 'ada-get-indent-if)) ; maybe it needs a special + ; function sometimes ? + ;; + ((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)) + ;; + (t + (setq func 'ada-get-indent-noindent)))))) + + func)) + + +;; ---- 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 paranthesis not yet closed. + (ada-in-open-paren-p)) + + +(defun ada-get-indent-nochange (orgpoint) + ;; Returns the indentation (column #) of the current line. + (save-excursion + (forward-line -1) + (current-indentation))) + + +(defun ada-get-indent-paramlist (orgpoint) + ;; Returns the indentation (column #) 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 "(") + (goto-char (match-end 0)) + (current-column)) + ;; + ;; in front of another parameter + ;; + ((looking-at ";") + (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) + (ada-goto-next-non-ws) + (current-column)) + ;; + ;; 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) + ;; 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 + ;; slow, if it has to search through big files with many nested blocks. + ;; Signals an error if the corresponding block-start doesn't match. + (let ((defun-name nil) + (indent nil)) + ;; + ;; is the line already terminated by ';' ? + ;; + (if (save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint)) + ;; + ;; yes, look what's following 'end' + ;; + (progn + (forward-word 1) + (ada-goto-next-non-ws) + (cond + ;; + ;; loop/select/if/case/record/select + ;; + ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|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 "[a-zA-Z0-9_]+[ \n\t]+:") + (progn + (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))) + ;; + ;; a named block end + ;; + ((looking-at "[a-zA-Z0-9_]+") + (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))) + ;; + ;; 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))))) + ;; + ;; anything else - should maybe signal an error ? + ;; + (t + (+ (current-indentation) ada-broken-indent)))) + + (+ (current-indentation) 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 an case-statement. + (let ((cur-indent (current-indentation)) + (match-cons nil) + (opos (point))) + (cond + ;; + ;; case..is..when..=> + ;; + ((save-excursion + (setq match-cons (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))) + ;; + ;; case..is..when + ;; + ((save-excursion + (setq match-cons (ada-search-ignore-string-comment + "\\<when\\>" nil orgpoint))) + (goto-char (cdr match-cons)) + (+ (current-indentation) ada-broken-indent)) + ;; + ;; case..is + ;; + ((save-excursion + (setq match-cons (ada-search-ignore-string-comment + "\\<is\\>" nil orgpoint))) + (+ (current-indentation) ada-when-indent)) + ;; + ;; incomplete case + ;; + (t + (+ (current-indentation) 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))) + (if (ada-search-ignore-string-comment + "[ \t\n]+=>" nil orgpoint) + (+ cur-indent ada-indent) + (+ 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)) + (match-cons nil)) + ;; + ;; if..then ? + ;; + (if (ada-search-but-not + "\\<then\\>" "\\<and\\>[ \t\n]+\\<then\\>" nil orgpoint) + + (progn + ;; + ;; 'then' first in separate line ? + ;; => indent according to 'then' + ;; + (if (save-excursion + (back-to-indentation) + (looking-at "\\<then\\>")) + (setq cur-indent (current-indentation))) + (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)))) + + +(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)) + (cond + ((save-excursion + (forward-word 1) + (setq pos (car (ada-search-ignore-string-comment + "[^ \t\n]" nil orgpoint)))) + (goto-char pos) + (save-excursion + (funcall (ada-indent-function t) orgpoint))) + ;; + ;; nothing follows the block-start + ;; + (t + (+ (current-indentation) 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))) + ;; + ;; is there an 'is' in front of point ? + ;; + (if (save-excursion + (setq match-cons + (ada-search-ignore-string-comment + "\\<is\\>\\|\\<do\\>" nil orgpoint))) + ;; + ;; yes, then skip to its end + ;; + (progn + (setq 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) + (goto-char orgpoint)))) + + (cond + ;; + ;; nothing follows 'is' + ;; + ((and + foundis + (save-excursion + (not (ada-search-ignore-string-comment + "[^ \t\n]" nil orgpoint t)))) + (+ 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)))) + (goto-char (car match-cons)) + (ada-search-ignore-string-comment (concat ada-subprog-start-re + "\\|\\<package\\>") t) + (ada-get-indent-noindent orgpoint)) + ;; + ;; something follows 'is' + ;; + ((and + foundis + (save-excursion + (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)) + (ada-goto-next-non-ws) + (funcall (ada-indent-function t) orgpoint))) + ;; + ;; no 'is' but ';' + ;; + ((save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint)) + cur-indent) + ;; + ;; no 'is' or ';' + ;; + (t + (+ cur-indent ada-broken-indent))))) + + +(defun ada-get-indent-noindent (orgpoint) + ;; Returns the indentation (column #) for the new line after ORGPOINT. + ;; Assumes point to be at the beginning of a 'noindent statement'. + (if (save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint)) + (current-indentation) + (+ (current-indentation) ada-broken-indent))) + + +(defun ada-get-indent-label (orgpoint) + ;; Returns the indentation (column #) for the new line after ORGPOINT. + ;; Assumes point to be at the beginning of a label or variable declaration. + ;; 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 ":"))) + (cond + ;; + ;; loop label + ;; + ((save-excursion + (setq 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\\>" 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)))) + ;; + ;; nothing follows colon + ;; + (t + (if (ada-in-decl-p) + (+ cur-indent ada-broken-indent) ; variable-declaration + (- cur-indent ada-label-indent)))))) ; label + + +(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. + (let ((match-cons nil) + (pos (point))) + (cond + + ;; + ;; statement complete + ;; + ((save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint)) + (current-indentation)) + ;; + ;; simple loop + ;; + ((looking-at "loop\\>") + (ada-get-indent-block-start orgpoint)) + + ;; + ;; 'for'- loop (or also a for ... use statement) + ;; + ((looking-at "for\\>") + (cond + ;; + ;; for ... use + ;; + ((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)) + (looking-at "\\<use\\>") + ;; + ;; check if there is a 'record' before point + ;; + (progn + (setq match-cons (ada-search-ignore-string-comment + "\\<record\\>" nil orgpoint)) + t))) + (if match-cons + (goto-char (car match-cons))) + (+ (current-indentation) ada-indent)) + ;; + ;; for..loop + ;; + ((save-excursion + (setq match-cons (ada-search-ignore-string-comment + "\\<loop\\>" nil orgpoint))) + (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)) + ;; + ;; for-statement is broken + ;; + (t + (+ (current-indentation) ada-broken-indent)))) + + ;; + ;; 'while'-loop + ;; + ((looking-at "while\\>") + ;; + ;; while..loop ? + ;; + (if (save-excursion + (setq match-cons (ada-search-ignore-string-comment + "\\<loop\\>" nil orgpoint))) + + (progn + (goto-char (car match-cons)) + ;; + ;; 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)) + + (+ (current-indentation) ada-broken-indent)))))) + + +(defun ada-get-indent-type (orgpoint) + ;; Returns the indentation (column #) for the new line after ORGPOINT. + ;; Assumes point to be at the beginning of a type statement. + (let ((match-dat nil)) + (cond + ;; + ;; complete record declaration + ;; + ((save-excursion + (and + (setq match-dat (ada-search-ignore-string-comment "\\<end\\>" + nil + orgpoint)) + (ada-goto-next-non-ws) + (looking-at "\\<record\\>") + (forward-word 1) + (ada-goto-next-non-ws) + (looking-at ";"))) + (goto-char (car match-dat)) + (current-indentation)) + ;; + ;; record type + ;; + ((save-excursion + (setq match-dat (ada-search-ignore-string-comment "\\<record\\>" + nil + orgpoint))) + (goto-char (car match-dat)) + (+ (current-indentation) ada-indent)) + ;; + ;; complete type declaration + ;; + ((save-excursion + (ada-search-ignore-string-comment ";" nil orgpoint)) + (current-indentation)) + ;; + ;; type ... is + ;; + ((save-excursion + (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint)) + (+ (current-indentation) ada-indent)) + ;; + ;; broken statement + ;; + (t + (+ (current-indentation) ada-broken-indent))))) + + +;;; ---- support-functions for indentation + +;;; ---- searching and matching + +(defun ada-goto-stmt-start (&optional limit) + ;; Moves point to the beginning of the statement that point is in or + ;; after. Returns the new position of point. Beginnings are found + ;; 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. + (let ((match-dat nil) + (orgpoint (point))) + + (setq 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))) + ;; + ;; 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-stetement => 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 + ;; accessible part of the buffer + ;; + (progn + (goto-char (point-min)) + ;; + ;; 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)) + (goto-char orgpoint)))) + + + (point))) + + +(defun ada-search-prev-end-stmt (&optional limit) + ;; Moves point to previous end-statement. Returns a cons cell whose + ;; car is the beginning and whose cdr the end of the match. + ;; End-statements are defined by 'ada-end-stmt-re'. Checks for + ;; certain keywords if they follow 'end', which means they are no + ;; end-statement there. + (let ((match-dat nil) + (pos nil) + (found nil)) + ;; + ;; 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))) + + (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\\)\\>") + (save-excursion + (ada-goto-previous-word) + (looking-at "\\<end\\>")))) + (setq found t) + + (backward-word 1)))) ; end of loop + + (if found + match-dat + nil))) + + +(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)))) + + +(defun ada-goto-stmt-end (&optional limit) + ;; Moves point to the end of the statement that point is in or + ;; before. Returns the new position of point or nil if not found. + (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit) + (point) + nil)) + + +(defun ada-goto-previous-word () + ;; Moves point to the beginning of the previous word of ada-code. + ;; Returns the new position of point or nil if not found. + (let ((match-cons nil) + (orgpoint (point))) + (if (setq match-cons + (ada-search-ignore-string-comment "[^ \t\n]" t nil t)) + ;; + ;; move to the beginning of the word found + ;; + (progn + (goto-char (cdr match-cons)) + (skip-chars-backward "_a-zA-Z0-9") + (point)) + ;; + ;; if not found, restore old position of point + ;; + (progn + (goto-char orgpoint) + 'nil)))) + + +(defun ada-check-matching-start (keyword) + ;; 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 (concat + "matching start is not '" + keyword "'")))) + + +(defun ada-check-defun-name (defun-name) + ;; Checks if the name of the matching defun really is DEFUN-NAME. + ;; Assumes point to be already positioned by 'ada-goto-matching-start'. + ;; Moves point to the beginning of the declaration. + + ;; + ;; 'accept' or 'package' ? + ;; + (if (not (looking-at "\\<\\(accept\\|package\\|task\\)\\>")) + (ada-goto-matching-decl-start)) + ;; + ;; 'begin' of 'procedure'/'function'/'task' or 'declare' + ;; + (save-excursion + ;; + ;; a named 'declare'-block ? + ;; + (if (looking-at "\\<declare\\>") + (ada-goto-stmt-start) + ;; + ;; no, => 'procedure'/'function'/'task' + ;; + (progn + (forward-word 2) + (backward-word 1) + ;; + ;; skip 'body' or 'type' + ;; + (if (looking-at "\\<\\(body\\|type\\)\\>") + (forward-word 1)) + (forward-sexp 1) + (backward-sexp 1))) + ;; + ;; should be looking-at the correct name + ;; + (if (not (looking-at (concat "\\<" defun-name "\\>"))) + (error + (concat + "matching defun has different name: " + (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)) + ;; + ;; 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)) + ;; + ;; calculate nest-depth + ;; + (cond + ;; + ((looking-at "end") + (ada-goto-matching-start 1 noerror) + (if (progn + (looking-at "begin")) + (setq nest-count (1+ nest-count)))) + ;; + ((looking-at "declare\\|generic") + (setq nest-count (1- nest-count)) + (setq first nil)) + ;; + ((looking-at "is") + ;; check if it is only a type definition + (if (save-excursion + (ada-goto-previous-word) + (skip-chars-backward "a-zA-Z0-9_.'") + (if (save-excursion + (backward-char 1) + (looking-at ")")) + (progn + (forward-char 1) + (backward-sexp 1) + (skip-chars-backward "a-zA-Z0-9_.'") + )) + (ada-goto-previous-word) + (looking-at "\\<type\\>")) ; end of save-excursion + (goto-char (match-beginning 0)) + (progn + (setq nest-count (1- nest-count)) + (setq first nil)))) + + ;; + ((looking-at "new") + (if (save-excursion + (ada-goto-previous-word) + (looking-at "is")) + (goto-char (match-beginning 0)))) + ;; + ((and first + (looking-at "begin")) + (setq nest-count 0) + (setq flag t)) + ;; + (t + (setq nest-count (1+ nest-count)) + (setq first nil))) + + ) ;; end of loop + + ;; check if declaration-start is really found + (if (not + (and + (zerop nest-count) + (not flag) + (progn + (if (looking-at "is") + (ada-search-ignore-string-comment + "\\<\\(procedure\\|function\\|task\\|package\\)\\>" t) + (looking-at "declare\\|generic"))))) + (if noerror nil + (error "no matching procedure/function/task/declare/package")) + t))) + + +(defun ada-goto-matching-start (&optional nest-level noerror gotothen) + ;; Moves point to the beginning of a block-start. Which block + ;; depends on the value of NEST-LEVEL, which defaults to zero. If + ;; NOERROR is non-nil, it only returns nil if no matching start was + ;; found. If GOTOTHEN is non-nil, point moves to the 'then' + ;; following 'if'. + (let ((nest-count (if nest-level nest-level 0)) + (found nil) + (pos nil)) + + ;; + ;; search backward for interesting keywords + ;; + (while (and + (not found) + (ada-search-ignore-string-comment + (concat "\\<\\(" + "end\\|loop\\|select\\|begin\\|case\\|" + "if\\|task\\|package\\|record\\|do\\)\\>") + 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 + ;; + ;; check if keyword follows 'end' + ;; + (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 + + (if found + ;; + ;; match found => is there anything else to do ? + ;; + (progn + (cond + ;; + ;; found 'if' => skip to 'then', if it's on a separate line + ;; and GOTOTHEN is non-nil + ;; + ((and + gotothen + (looking-at "if") + (save-excursion + (ada-search-ignore-string-comment "\\<then\\>" nil nil) + (back-to-indentation) + (looking-at "\\<then\\>"))) + (goto-char (match-beginning 0))) + ;; + ;; 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'")))) + (point)) + + (if noerror + nil + (error "no matching start"))))) + + +(defun ada-goto-matching-end (&optional nest-level noerror) + ;; Moves point to the end of a block. Which block depends on the + ;; value of NEST-LEVEL, which defaults to zero. If NOERROR is + ;; non-nil, it only returns nil if found no matching start. + (let ((nest-count (if nest-level nest-level 0)) + (found nil)) + + ;; + ;; search forward for interesting keywords + ;; + (while (and + (not found) + (ada-search-ignore-string-comment + (concat "\\<\\(end\\|loop\\|select\\|begin\\|case\\|" + "if\\|task\\|package\\|record\\|do\\)\\>"))) + + ;; + ;; calculate nest-depth + ;; + (backward-word 1) + (cond + ;; found block end => decrease nest depth + ((looking-at "\\<end\\>") + (setq nest-count (1- nest-count)) + ;; skip the following keyword + (if (progn + (skip-chars-forward "end") + (ada-goto-next-non-ws) + (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>")) + (forward-word 1))) + ;; found package start => check if it really starts a block + ((looking-at "\\<package\\>") + (ada-search-ignore-string-comment "\\<is\\>") + (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"))) + ;; all the other block starts + (t + (setq 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)) + + +(defun ada-search-ignore-string-comment + (search-re &optional backward limit paramlists) + ;; 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))) + + ;; + ;; search until found or end-of-buffer + ;; + (while (and (not found) + (funcall search-func search-re limit 1)) + (setq begin (match-beginning 0)) + (setq end (match-end 0)) + + (cond + ;; + ;; found in comment => skip it + ;; + ((ada-in-comment-p) + (if backward + (progn + (re-search-backward "--" nil 1) + (goto-char (match-beginning 0))) + (progn + (forward-line 1) + (beginning-of-line)))) + ;; + ;; found in string => skip it + ;; + ((ada-in-string-p) + (if backward + (progn + (re-search-backward "\"\\|#" nil 1) + (goto-char (match-beginning 0)))) + (re-search-forward "\"\\|#" nil 1)) + ;; + ;; found character constant => ignore it + ;; + ((save-excursion + (setq pos (- (point) (if backward 1 2))) + (and (char-after pos) + (= (char-after pos) ?') + (= (char-after (+ pos 2)) ?'))) + ()) + ;; + ;; found a parameter-list but should ignore it => skip it + ;; + ((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)))) + ;; + ;; found what we were looking for + ;; + (t + (setq found t)))) ; end of loop + + (if found + (cons begin end) + nil))) + + +(defun ada-search-but-not (search-re not-search-re &optional backward limit) + ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings, + ;; comments and parameter-lists. + (let ((begin nil) + (end nil) + (begin-not nil) + (begin-end nil) + (end-not nil) + (ret-cons nil) + (found nil)) + + ;; + ;; search until found or end-of-buffer + ;; + (while (and + (not found) + (save-excursion + (setq ret-cons + (ada-search-ignore-string-comment search-re + backward limit)) + (if (consp ret-cons) + (progn + (setq begin (car ret-cons)) + (setq end (cdr ret-cons)) + t) + nil))) + + (if (or + ;; + ;; if no NO-SEARCH-RE was found + ;; + (not + (save-excursion + (setq ret-cons + (ada-search-ignore-string-comment not-search-re + backward nil)) + (if (consp ret-cons) + (progn + (setq begin-not (car ret-cons)) + (setq end-not (cdr ret-cons)) + t) + nil))) + ;; + ;; or this NO-SEARCH-RE is not a part of the SEARCH-RE + ;; found before. + ;; + (or + (<= end-not begin) + (>= begin-not end))) + + (setq found t) + + ;; + ;; not found the correct match => skip this match + ;; + (goto-char (if backward + begin + end)))) ; end of loop + + (if found + (progn + (goto-char begin) + (cons begin end)) + nil))) + + +(defun ada-goto-prev-nonblank-line ( &optional ignore-comment) + ;; Moves point to 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 (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 (in-limit-line-p))) + (forward-line 1) + (beginning-of-line) + (setq newpoint (point))) ; end of loop + + )) ; end of if + + ) ; end of save-excursion + + (if notfound nil + (progn + (goto-char newpoint) + t)))) + + +;; ---- boolean functions for indentation + +(defun ada-in-decl-p () + ;; Returns t if point is inside a declarative part. + ;; Assumes point to be at the end of a statement. + (or + (ada-in-paramlist-p) + (save-excursion + (ada-goto-matching-decl-start t)))) + + +(defun ada-looking-at-semi-or () + ;; Returns t if looking-at an 'or' following a semicolon. + (save-excursion + (and (looking-at "\\<or\\>") + (progn + (forward-word 1) + (ada-goto-stmt-start) + (looking-at "\\<or\\>"))))) + + +(defun ada-looking-at-semi-private () + ;; Returns t if looking-at an 'private' following a semicolon. + (save-excursion + (and (looking-at "\\<private\\>") + (progn + (forward-word 1) + (ada-goto-stmt-start) + (looking-at "\\<private\\>"))))) + + +(defun in-limit-line-p () + ;; Returns t if point is in first or last accessible line. + (or + (>= 1 (count-lines (point-min) (point))) + (>= 1 (count-lines (point) (point-max))))) + + +(defun ada-in-comment-p () + ;; Returns t if inside a comment. + (save-excursion (and (re-search-backward "\\(--\\|\n\\)" nil 1) + (looking-at "-")))) + + +(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) + (not (= (char-after (1- (point))) ?')))))) + + +(defun ada-in-string-or-comment-p () + ;; Returns t if point is inside a string or a comment. + (or (ada-in-comment-p) + (ada-in-string-p))) + + +(defun ada-in-paramlist-p () + ;; Returns t if point is inside a parameter-list + ;; following 'function'/'procedure'/'package'. + (save-excursion + (and + (re-search-backward "(\\|)" nil t) + ;; inside parentheses ? + (looking-at "(") + (backward-word 2) + ;; right keyword before paranthesis ? + (looking-at (concat "\\<\\(" + "procedure\\|function\\|body\\|package\\|" + "task\\|entry\\|accept\\)\\>")) + (re-search-forward ")\\|:" nil t) + ;; at least one ':' inside the parentheses ? + (not (backward-char 1)) + (looking-at ":")))) + + +;; not really a boolean function ... +(defun ada-in-open-paren-p () + ;; If point is somewhere behind an open parenthesis not yet closed, + ;; it returns the column # of the first non-ws behind this open + ;; parenthesis, otherwise nil." + (let ((nest-count 1) + (limit nil) + (found nil) + (pos nil) + (col nil) + (counter ada-search-paren-line-count-limit)) + + ;; + ;; get search-limit + ;; + (if ada-search-paren-line-count-limit + (setq limit + (save-excursion + (while (not (zerop counter)) + (ada-goto-prev-nonblank-line) + (setq counter (1- counter))) + (beginning-of-line) + (point)))) + + (save-excursion + + ;; + ;; loop until found or limit + ;; + (while (and + (not found) + (ada-search-ignore-string-comment "(\\|)" t limit t)) + (setq nest-count + (if (looking-at ")") + (1+ nest-count) + (1- nest-count))) + (setq found (zerop nest-count))) ; end of loop + + (if found + ;; if found => return column of first non-ws after the parenthesis + (progn + (forward-char 1) + (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)))) + + +;;;-----------------------------;;; +;;; Simple Completion Functions ;;; +;;;-----------------------------;;; + +;; These are my first steps in Emacs-Lisp ... :-) They can be replaced +;; by functions based on the output of the Gnatf Tool that comes with +;; the GNAT Ada compiler. See the file ada-xref.el (MH) But you might +;; use these functions if you don't use GNAT + +(defun ada-use-last-with () + "Inserts the package name of the last 'with' statement after use." + (interactive) + (let ((pakname nil)) + (save-excursion + (forward-word -1) + (if (looking-at "use") + ;; + ;; find last 'with' + ;; + (progn (re-search-backward + "\\(\\<with\\s-+\\)\\([a-zA-Z0-9_.]+\\)\\(\\s-*;\\)") + ;; + ;; get the name of the package + ;; + (setq pakname (concat + (buffer-substring (match-beginning 2) + (match-end 2)) + ";"))) + (setq pakname ""))) + (insert pakname))) + + +(defun ada-complete-symbol (symboldef position symalist) + ;; Tries to complete a symbol in the buffer. + ;; SYMBOLDEF is the regexp to find the definition of the desired symbol. + ;; POSITION is the position of the subexpression in SYMBOLDEF to match + ;; the symbol itself. + ;; SYMALIST is an alist with possibly predefined completions." + (let ((sofar nil) + (completed nil) + (insertpos nil)) + (save-excursion + ;; + ;; get the part of the symbol already typed + ;; + (re-search-backward "\\([^a-zA-Z0-9_\\.]\\)\\([a-zA-Z0-9_\\.]+\\)") + (setq sofar (buffer-substring (match-beginning 2) + (match-end 2))) + ;; + ;; delete it + ;; + (delete-region (setq insertpos (match-beginning 2)) + (match-end 2)) + ;; + ;; find all possible completions by searching for definitions of + ;; this kind of symbol + ;; + (while (re-search-backward symboldef nil t) + ;; + ;; build an alist of these possible completions + ;; + (setq symalist (cons (cons (buffer-substring (match-beginning position) + (match-end position)) + nil) + symalist))) + + (or + ;; + ;; symbol gets completed as far as possible + ;; + (stringp (setq completed (try-completion sofar symalist))) + ;; + ;; or is already complete + ;; + (setq completed sofar))) + ;; + ;; insert the completed symbol + ;; + (goto-char insertpos) + (insert completed))) + + +(defun ada-complete-use () + "Tries to complete the package name in an 'use' statement in the buffer. +Searches through former 'with' statements for possible completions." + (interactive) + (ada-complete-symbol + "\\(\\<with\\s-+\\)\\([a-zA-Z0-9_.]+\\)\\(\\s-*;\\)" 2 nil) + (insert ";")) + + +(defun ada-complete-procedure () + "Tries to complete a procedure/function name in the buffer." + (interactive) + (ada-complete-symbol ada-procedure-start-regexp 2 nil)) + + +(defun ada-complete-variable () + "Tries to complete a variable name in the buffer." + (interactive) + (ada-complete-symbol + "\\([^a-zA-Z0-9_]\\)\\([a-zA-Z0-9_]+\\)[ \t\n]+\\(:\\)" 2 nil)) + + +(defun ada-complete-type () + "Tries to complete a type name in the buffer." + (interactive) + (ada-complete-symbol "\\(type\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)" + 2 + '(("Integer" nil) + ("Long_Integer" nil) + ("Natural" nil) + ("Positive" nil) + ("Short_Integer" nil)))) + + +;;;----------------------;;; +;;; Behaviour Of TAB Key ;;; +;;;----------------------;;; + +(defun ada-tab () + "Do indenting or tabbing according to `ada-tab-policy'." + (interactive) + (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented")) + ;; ada-indent-and-tab + ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard)) + ((eq ada-tab-policy 'indent-auto) (ada-indent-current)) + ((eq ada-tab-policy 'gei) (ada-tab-gei)) + ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB + ((eq ada-tab-policy 'always-tab) (error "not implemented")) + )) + + +(defun ada-untab (arg) + "Delete leading indenting according to `ada-tab-policy'." + (interactive "P") + (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard)) + ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB + (prefix-numeric-value arg) ; GEB + arg)) ; GEB + ((eq ada-tab-policy 'indent-auto) (error "not implemented")) + ((eq ada-tab-policy 'always-tab) (error "not implemented")) + )) + + +(defun ada-indent-current-function () + "ada-mode version of the indent-line-function." + (interactive "*") + (let ((starting-point (point-marker))) + (ada-beginning-of-line) + (ada-tab) + (if (< (point) starting-point) + (goto-char starting-point)) + (set-marker starting-point nil) + )) + + + + +(defun ada-tab-hard () + "Indent current line to next tab stop." + (interactive) + (save-excursion + (beginning-of-line) + (insert-char ? ada-indent)) + (if (save-excursion (= (point) (progn (beginning-of-line) (point)))) + (forward-char ada-indent))) + + +(defun ada-untab-hard () + "indent current line to previous tab stop." + (interactive) + (let ((bol (save-excursion (progn (beginning-of-line) (point)))) + (eol (save-excursion (progn (end-of-line) (point))))) + (indent-rigidly bol eol (- 0 ada-indent)))) + + +(defun ada-tabsize (s) + "changes spacing used for indentation. Reads spacing from minibuffer." + (interactive "nnew indentation spacing: ") + (setq ada-indent s)) + + +;;;---------------;;; +;;; Miscellaneous ;;; +;;;---------------;;; + +(defun ada-remove-trailing-spaces () +;; remove all trailing spaces at the end of lines. + "remove trailing spaces in the whole buffer." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "[ \t]+$" nil t) + (replace-match "" nil nil)))) + + +(defun ada-untabify-buffer () +;; change all tabs to spaces + (save-excursion + (untabify (point-min) (point-max)))) + + +(defun ada-uncomment-region (beg end) + "delete comment-start at the beginning of a line in the region." + (interactive "r") + (comment-region beg end -1)) + + +;; define a function to support find-file.el if loaded +(defun ada-ff-other-window () + "Find other file in other window using ff-find-other-file." + (interactive) + (and (fboundp 'ff-find-other-file) + (ff-find-other-file t))) + + +;;;-------------------------------;;; +;;; Moving To Procedures/Packages ;;; +;;;-------------------------------;;; + +(defun ada-next-procedure () + "Moves point to next procedure." + (interactive) + (end-of-line) + (if (re-search-forward ada-procedure-start-regexp nil t) + (goto-char (match-beginning 1)) + (error "No more functions/procedures/tasks"))) + +(defun ada-previous-procedure () + "Moves point to previous procedure." + (interactive) + (beginning-of-line) + (if (re-search-backward ada-procedure-start-regexp nil t) + (goto-char (match-beginning 1)) + (error "No more functions/procedures/tasks"))) + +(defun ada-next-package () + "Moves point to next package." + (interactive) + (end-of-line) + (if (re-search-forward ada-package-start-regexp nil t) + (goto-char (match-beginning 1)) + (error "No more packages"))) + +(defun ada-previous-package () + "Moves point to previous package." + (interactive) + (beginning-of-line) + (if (re-search-backward ada-package-start-regexp nil t) + (goto-char (match-beginning 1)) + (error "No more packages"))) + + +;;;----------------------- +;;; define keymap for Ada +;;;----------------------- + +(if (not ada-mode-map) + (progn + (setq ada-mode-map (make-sparse-keymap)) + + ;; Indentation and Formatting + (define-key ada-mode-map "\C-M" 'newline) + (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) + ;; How do I write this for working with Lucid Emacs? + (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) + (define-key ada-mode-map "\M-q" 'ada-fill-comment-paragraph) + (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 + (define-key ada-mode-map "\M-e" 'ada-next-procedure) + (define-key ada-mode-map "\M-a" 'ada-previous-procedure) + (define-key ada-mode-map "\M-\C-e" 'ada-next-package) + (define-key ada-mode-map "\M-\C-a" 'ada-previous-package) + (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) + + ;; 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 + (mapcar (lambda (pair) + (substitute-key-definition (car pair) (cdr pair) + ada-mode-map global-map)) + '((beginning-of-line . ada-beginning-of-line) + (end-of-line . ada-end-of-line) + (forward-to-indentation . ada-forward-to-indentation) + )) + )) + + +;;;------------------- +;;; define menu 'Ada' +;;;------------------- + +(defun ada-add-ada-menu () + "Adds the menu 'Ada' to the menu-bar in Ada Mode." + (easy-menu-define t ada-mode-map t + '("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] + ["compile" compile (fboundp 'compile)] + ["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)]))) + + +;;;------------------------------- +;;; Define Some Support Functions +;;;------------------------------- + +(defun ada-beginning-of-line (&optional arg) + (interactive "P") + (cond + ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg)) + (t (beginning-of-line arg)) + )) + +(defun ada-end-of-line (&optional arg) + (interactive "P") + (cond + ((eq ada-tab-policy 'indent-af) (af-end-of-line arg)) + (t (end-of-line arg)) + )) + +(defun ada-current-column () + (cond + ((eq ada-tab-policy 'indent-af) (af-current-column)) + (t (current-column)) + )) + +(defun ada-forward-to-indentation (&optional arg) + (interactive "P") + (cond + ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg)) + (t (forward-to-indentation arg)) + )) + +;;;--------------------------------------------------- +;;; support for find-file +;;;--------------------------------------------------- + +(defvar ada-krunch-args "8" + "*Argument of gnatk8, a string containing the max number of characters. +Set to a big number, if you dont use crunched filenames.") + +(defun ada-make-filename-from-adaname (adaname) + "determine the filename of a package/procedure from its own Ada name." + ;; this is done simply by calling gkrunch, when we work with GNAT. It + ;; must be a more complex function in other compiler environments. + (interactive "s") + + ;; things that should really be done by the external process + (let (krunch-buf) + (setq krunch-buf (generate-new-buffer "*gkrunch*")) + (save-excursion + (set-buffer krunch-buf) + (insert (downcase adaname)) + (goto-char (point-min)) + (while (search-forward "." nil t) + (replace-match "-" nil t)) + (setq adaname (buffer-substring (point-min) + (progn + (goto-char (point-min)) + (end-of-line) + (point)))) + ;; clean the buffer + (delete-region (point-min) (point-max)) + ;; send adaname to external process "gnatk8" + (call-process "gnatk8" nil krunch-buf nil + 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? + ) + +;;;--------------------------------------------------- +;;; support for imenu +;;;--------------------------------------------------- + +(defun imenu-create-ada-index (&optional regexp) + "create index alist for Ada files." + (let ((index-alist '()) + prev-pos char) + (goto-char (point-min)) + ;(imenu-progress-message prev-pos 0) + ;; Search for functions/procedures + (save-match-data + (while (re-search-forward + (or regexp ada-procedure-start-regexp) + nil t) + ;(imenu-progress-message prev-pos) + ;;(backward-up-list 1) ;; needed in Ada ???? + ;; do not store forward definitions + (save-match-data + (if (not (looking-at (concat + "[ \t\n]*" ; WS + "\([^)]+\)" ; parameterlist + "\\([ \n\t]+return[ \n\t]+"; potential return + "[a-zA-Z0-9_\\.]+\\)?" + "[ \t]*" ; WS + ";" ;; THIS is what we really look for + ))) + ; (push (imenu-example--name-and-position) index-alist) + (setq index-alist (cons (imenu-example--name-and-position) + index-alist)) + )) + ;(imenu-progress-message 100) + )) + (nreverse index-alist))) + +;;;--------------------------------------------------- +;;; support for font-lock +;;;--------------------------------------------------- + +;; Strings are a real pain in Ada because both ' and " can appear in a +;; non-string quote context (the former as an operator, the latter as +;; a character string). We follow the least losing solution, in which +;; only " is a string quote. Therefore a character string of the form +;; '"' will throw fontification off on the wrong track. + +(defconst ada-font-lock-keywords-1 + (list + ;; + ;; Function, package (body), pragma, procedure, task (body) plus name. + (list (concat "\\<\\(" + "function\\|" + "p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|" + "task\\(\\|[ \t]+body\\)" + "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") + '(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t))) + "For consideration as a value of `ada-font-lock-keywords'. +This does fairly subdued highlighting.") + +(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\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" + "se\\(lect\\|parate\\)\\|" + "t\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor" + "\\)\\>") + ;; + ;; Anything following end and not already fontified is a body name. + '("\\<\\(end\\)\\>[ \t]*\\(\\sw+\\)?" + (1 font-lock-keyword-face) (2 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\\|in[ \t]+out\\|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\\|when\\|with\\)\\>" + ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE + "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W") + '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) + ;; + ;; Goto tags. + '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face) + )) + "For consideration as a value of `ada-font-lock-keywords'. +This does a lot more highlighting.") + +(defvar ada-font-lock-keywords ada-font-lock-keywords-2 + "*Expressions to highlight in Ada mode.") + +;;; +;;; ???? +;;; +(defun ada-gen-comment-until-proc () + ;; comment until spec of a procedure or a function. + (forward-line 1) + (set-mark-command (point)) + (if (re-search-forward ada-procedure-start-regexp nil t) + (progn (goto-char (match-beginning 1)) + (comment-region (mark) (point))) + (error "No more functions/procedures"))) + + +(defun ada-gen-treat-proc nil + ;; make dummy body of a procedure/function specification. + (goto-char (match-end 0)) + (let ((wend (point)) + (wstart (progn (re-search-backward "[ ][a-zA-Z0-9_\"]+" nil t) + (+ (match-beginning 0) 1)))) ; delete leading WS + (copy-region-as-kill wstart wend) ; store proc name in kill-buffer + + + ;; if the next notWS char is '(' ==> parameterlist follows + ;; if the next notWS char is ';' ==> no paramterlist + ;; if the next notWS char is 'r' ==> paramterless function, search ';' + + ;; goto end of regex before last (= end of procname) + (goto-char (match-end 0)) + ;; look for next non WS + (backward-char) + (re-search-forward "[ ]*.") + (if (char-equal (char-after (match-end 0)) ?;) + (delete-char 1) ;; delete the ';' + ;; else + ;; find ');' or 'return <id> ;' + (re-search-forward + "\\()[ \t]*;\\)\\|\\(return[ \t]+[a-zA-Z0-9_]+[ \t]*;\\)" nil t) + (goto-char (match-end 0)) + (delete-backward-char 1) ;; delete the ';' + ) + + (insert " is") + ;; if it is a function, we should generate a return variable and a + ;; return statement. Sth. like "Result : <return-type>;" and a + ;; "return Result;". + (ada-indent-newline-indent) + (insert "begin -- ") + (yank) + (newline) + (insert "null;") + (newline) + (insert "end ") + (yank) + (insert ";") + (ada-indent-newline-indent)) + + +(defun ada-gen-make-bodyfile (spec-filename) + "Create a new buffer containing the correspondig Ada body +to the current specs." + (interactive "b") +;;; (let* ( +;;; (file-name (ada-body-filename spec-filename)) +;;; (buf (get-buffer-create file-name))) +;;; (switch-to-buffer buf) +;;; (ada-mode) + (ff-find-other-file t t) +;;; (if (= (buffer-size) 0) +;;; (make-header) +;;; ;; make nothing, autoinsert.el had put something in already +;;; ) + (end-of-buffer) + (let ((hlen (count-lines (point-min) (point-max)))) + (insert-buffer spec-filename) + ;; hlen lines have already been inserted automatically + ) + + (if (re-search-forward ada-package-start-regexp nil t) + (progn (goto-char (match-end 1)) + (insert " body")) + (error "No package")) + ; (comment-until-proc) + ; does not work correctly + ; must be done by hand + + (while (re-search-forward ada-procedure-start-regexp nil t) + (ada-gen-treat-proc)) + + ; don't overwrite an eventually + ; existing file +; (if (file-exists-p file-name) +; (error "File with this name already exists!") +; (write-file file-name)) + )) + +;;; provide ourself + +(provide 'ada-mode) + +;;; package ada-mode ends here + +