diff options
Diffstat (limited to 'lisp/progmodes')
26 files changed, 0 insertions, 27907 deletions
diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el deleted file mode 100644 index cf74a914ea2..00000000000 --- a/lisp/progmodes/ada-mode.el +++ /dev/null @@ -1,3741 +0,0 @@ -;;; ada-mode.el --- An Emacs major-mode for editing Ada source. -;;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. - -;;; Authors: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> -;;; Rolf Ebert <ebert@inf.enst.fr> - -;;; This file is part of 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; This mode is a complete rewrite of a major mode for editing Ada 83 -;;; and Ada 95 source code under Emacs-19. It contains completely new -;;; indenting code and support for code browsing (see ada-xref). - - -;;; USAGE -;;; ===== -;;; Emacs should enter ada-mode when you load an ada source (*.ad[abs]). -;;; -;;; 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. Broman in -;;; 1985. He based his work on the already existing Modula-2 mode. -;;; This was distributed as ada.el in versions of Emacs prior to 19.29. -;;; -;;; 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 -;;; ========== -;;; -;;; In the presence of comments and/or incorrect syntax -;;; ada-format-paramlist produces weird results. -;;; ------------------- -;;; Indenting of some tasking constructs is still buggy. -;;; ------------------- -;;; package Test is -;;; -- If I hit return on the "type" line it will indent the next line -;;; -- in another 3 space instead of heading out to the "(". If I hit -;;; -- tab or return it reindents the line correctly but does not initially. -;;; type Wait_Return is (Read_Success, Read_Timeout, Wait_Timeout, -;;; Nothing_To_Wait_For_In_Wait_List); -;;; ------------------- - - - -;;; CREDITS -;;; ======= -;;; -;;; Many thanks to -;;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular, -;;; woodruff@stc.llnl.gov (John Woodruff) -;;; jj@ddci.dk (Jesper Joergensen) -;;; gse@ocsystems.com (Scott Evans) -;;; comar@LANG8.CS.NYU.EDU (Cyrille Comar) -;;; and others for their valuable hints. - -;;;-------------------- -;;; 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 single line are indented.") - -(defvar ada-indent-to-open-paren t - "*If non-nil, indent according to the innermost open parenthesis.") - -(defvar ada-search-paren-char-count-limit 3000 - "*Search that many characters for an open parenthesis.") - - -;; ---- 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 'ada95 - "*Do we program in `ada83' or `ada95'?") - -(defvar ada-case-keyword 'downcase-word - "*Function to call to adjust the case of Ada keywords. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'.") - -(defvar ada-case-identifier 'ada-loose-case-word - "*Function to call to adjust the case of an Ada identifier. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'.") - -(defvar ada-case-attribute 'capitalize-word - "*Function to call to adjust the case of Ada attributes. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'.") - -(defvar ada-auto-case t - "*Non-nil automatically changes case of preceding word while typing. -Casing is done according to `ada-case-keyword', `ada-case-identifier' -and `ada-cacse-attribute'.") - -(defvar ada-clean-buffer-before-saving nil - "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving.") - -(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 "0" - "*Argument of gnatk8, a string containing the max number of characters. -Set to 0, if you don't 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.") - -(defvar ada-mode-symbol-syntax-table nil - "Syntax table for Ada, where `_' is a word constituent.") - -(defconst ada-83-keywords - "\\<\\(abort\\|abs\\|accept\\|access\\|all\\|and\\|array\\|\ -at\\|begin\\|body\\|case\\|constant\\|declare\\|delay\\|delta\\|\ -digits\\|do\\|else\\|elsif\\|end\\|entry\\|exception\\|exit\\|for\\|\ -function\\|generic\\|goto\\|if\\|in\\|is\\|limited\\|loop\\|mod\\|\ -new\\|not\\|null\\|of\\|or\\|others\\|out\\|package\\|pragma\\|\ -private\\|procedure\\|raise\\|range\\|record\\|rem\\|renames\\|\ -return\\|reverse\\|select\\|separate\\|subtype\\|task\\|terminate\\|\ -then\\|type\\|use\\|when\\|while\\|with\\|xor\\)\\>" -; "\\<\\(a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|ll\\|nd\\|rray\\|t\\)\\|\ -;b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|\ -;d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|\ -;e\\(ls\\(e\\|if\\)\\|n\\(d\\|try\\)\\|x\\(ception\\|it\\)\\)\\|\ -;f\\(or\\|unction\\)\\|g\\(eneric\\|oto\\)\\|i[fns]\\|l\\(imited\\|oop\\)\\|\ -;mod\\|n\\(ew\\|ot\\|ull\\)\\|o\\([fr]\\|thers\\|ut\\)\\|\ -;p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|\ -;r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|\ -;s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|use\\| -;t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor\\)\\>" - "regular expression for looking at Ada83 keywords.") - -(defconst ada-95-keywords - "\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\ -all\\|and\\|array\\|at\\|begin\\|body\\|case\\|constant\\|declare\\|\ -delay\\|delta\\|digits\\|do\\|else\\|elsif\\|end\\|entry\\|\ -exception\\|exit\\|for\\|function\\|generic\\|goto\\|if\\|in\\|\ -is\\|limited\\|loop\\|mod\\|new\\|not\\|null\\|of\\|or\\|others\\|\ -out\\|package\\|pragma\\|private\\|procedure\\|protected\\|raise\\|\ -range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\ -select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\ -type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>" - "regular expression for looking at Ada95 keywords.") - -(defvar ada-keywords ada-95-keywords - "Regular expression for looking at Ada keywords.") - -(defvar ada-ret-binding nil - "Variable to save key binding of RET when casing is activated.") - -(defvar ada-lfd-binding nil - "Variable to save key binding of LFD when casing is activated.") - -;;; ---- Regexps to find procedures/functions/packages - -(defconst ada-ident-re - "[a-zA-Z0-9_\\.]+" - "Regexp matching Ada (qualified) identifiers.") - -(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\\|else\\|\ -\\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>" - "Regexp for keywords starting Ada blocks.") - -(defvar ada-end-stmt-re - "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\ -\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|\ -declare\\|generic\\|private\\)\\>\\|\ -^[ \t]*\\(package\\|procedure\\|function\\)[ \ta-zA-Z0-9_\\.]+is\\|\ -^[ \t]*exception\\>\\)" - "Regexp of possible ends for a non-broken statement. -A new statement starts after these.") - -(defvar ada-loop-start-re - "\\<\\(for\\|while\\|loop\\)\\>" - "Regexp for the start of a loop.") - -(defvar ada-subprog-start-re - "\\<\\(procedure\\|protected\\|package\\|function\\|\ -task\\|accept\\|entry\\)\\>" - "Regexp for the start of a subprogram.") - - -;; Written by Christian Egli <Christian.Egli@hcsd.hac.com> -;; -(defvar ada-imenu-generic-expression - '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2) - ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2)) - - "Imenu generic expression for Ada mode. See `imenu-generic-expression'.") - -;;;------------- -;;; functions -;;;------------- - -(defun ada-xemacs () - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - -(defun ada-create-syntax-table () - "Create the syntax table for Ada Mode." - ;; There are two different syntax-tables. The standard one declares - ;; `_' as a symbol constituent, in the second one, it is a word - ;; constituent. For some search and replacing routines we - ;; temporarily switch between the two. - (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) - - (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table)) - (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table) - ) - - -;;;###autoload -(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 this function in a spec and no body is available, it gets created - with body stubs. - -If you use ada-xref.el: - Goto declaration: '\\[ada-point-and-xref]' on the identifier - or '\\[ada-goto-declaration]' with point on the identifier - Complete identifier: '\\[ada-complete-identifier]' - Execute Gnatf: '\\[ada-gnatf-current]'" - - (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 'fill-paragraph-function) - (setq fill-paragraph-function 'ada-fill-comment-paragraph) - - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression ada-imenu-generic-expression) - - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((ada-font-lock-keywords - ada-font-lock-keywords-1 - ada-font-lock-keywords-2) - nil t - ((?\_ . "w")) - beginning-of-line)) - - (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 'ada95) - (setq ada-keywords ada-95-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)) - t) - - -;;;--------------------------------;;; -;;; Call External Pretty Printer ;;; -;;;--------------------------------;;; - -(defun ada-call-pretty-printer () - "Calls the external Pretty Printer. -The name is specified in `ada-external-pretty-print-program'. Saves the -current buffer in a directory specified by `ada-tmp-directory', -starts the pretty printer as external process on that file and then -reloads the beautified program in the buffer and cleans up -`ada-tmp-directory'." - (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 "'". This is interpreted as being - ;; in a character constant. - (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. -Respect options `ada-case-keyword', `ada-case-identifier', and -`ada-case-attribute'. -If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." ; (MH) - (forward-char -1) - (if (and (> (point) 1) (not (or (ada-in-string-p) - (ada-in-comment-p) - (ada-after-char-p)))) - (if (eq (char-syntax (char-after (1- (point)))) ?w) - (if (save-excursion - (forward-word -1) - (or (= (point) (point-min)) - (backward-char 1)) - (looking-at "'")) - (funcall ada-case-attribute -1) - (if (and - (not force-identifier) ; (MH) - (ada-after-keyword-p)) - (funcall ada-case-keyword -1) - (funcall ada-case-identifier -1))))) - (forward-char 1)) - - -(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 letter 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 words in the region. -Attention: This function might take very long for big regions !" - (interactive "*r") - (let ((begin nil) - (end nil) - (keywordp nil) - (reldiff nil)) - (unwind-protect - (save-excursion - (set-syntax-table ada-mode-symbol-syntax-table) - (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 "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")) - (set-syntax-table ada-mode-syntax-table)))) - - -;; -;; added by MH -;; -(defun ada-adjust-case-buffer () - "Adjusts the case of all words in the whole buffer. -ATTENTION: This function might take very long for big buffers !" - (interactive "*") - (ada-adjust-case-region (point-min) (point-max))) - - -;;;------------------------;;; -;;; Format Parameter Lists ;;; -;;;------------------------;;; - -(defun ada-format-paramlist () - "Reformats a parameter list. -ATTENTION: 1) Comments inside the list are killed ! - 2) If the syntax is not correct (especially, if there are - semicolons missing), it can get totally confused ! -In such a case, use `undo', correct the syntax and try again." - - (interactive) - (let ((begin nil) - (end nil) - (delend nil) - (paramlist nil)) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - ;; check if really inside parameter list - (or (ada-in-paramlist-p) - (error "not in parameter list")) - ;; - ;; find start of current parameter-list - ;; - (ada-search-ignore-string-comment - (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) - (ada-search-ignore-string-comment "(" nil nil t) - (backward-char 1) - (setq begin (point)) - - ;; - ;; find end of parameter-list - ;; - (forward-sexp 1) - (setq delend (point)) - (delete-char -1) - - ;; - ;; find end of last parameter-declaration - ;; - (ada-search-ignore-string-comment "[^ \t\n]" t nil t) - (forward-char 1) - (setq end (point)) - - ;; - ;; build a list of all elements of the parameter-list - ;; - (setq paramlist (ada-scan-paramlist (1+ begin) end)) - - ;; - ;; delete the original parameter-list - ;; - (delete-region begin (1- delend)) - - ;; - ;; insert the new parameter-list - ;; - (goto-char begin) - (ada-insert-paramlist paramlist)) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table) - ))) - - -(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? access? 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 'access' - ;; - (goto-char apos) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment "\\<access\\>" - nil - epos - t))))) - - ;; - ;; skip 'in'/'out'/'access' - ;; - (goto-char apos) - (ada-goto-next-non-ws) - (while (looking-at "\\<\\(in\\|out\\|access\\)\\>") - (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) - (accessp 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 'access' ? - ;; - (setq accessp - (or accessp - (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 - accessp) - (not (nth 3 (nth i paramlist)))) - (insert " "))) - - ;; - ;; insert 'out' or space - ;; - (if (nth 2 (nth i paramlist)) - (insert "out ") - (if (and - (or outp - accessp) - (not (nth 3 (nth i paramlist)))) - (insert " "))) - - ;; - ;; insert 'access' - ;; - (if (nth 3 (nth i paramlist)) - (insert "access ")) - - (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 Ada structure." - (interactive) - (let ((pos (point))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (message "searching for block start ...") - (save-excursion - ;; - ;; do nothing if in string or comment or not on 'end ...;' - ;; or if an error occurs during processing - ;; - (or - (ada-in-string-or-comment-p) - (and (progn - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (error "not on end ...;"))) - (ada-goto-matching-start 1) - (setq pos (point)) - - ;; - ;; on 'begin' => go on, according to user option - ;; - ada-move-to-declaration - (looking-at "\\<begin\\>") - (ada-goto-matching-decl-start) - (setq pos (point)))) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos) - (message "searching for block start ... done")) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table)))) - - -(defun ada-move-to-end () - "Moves point to the matching end of the current block around point. -Moves to 'begin' if in a declarative part." - (interactive) - (let ((pos (point)) - (decstart nil) - (packdecl nil)) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (message "searching for block end ...") - (save-excursion - - (forward-char 1) - (cond - ;; directly on 'begin' - ((save-excursion - (ada-goto-previous-word) - (looking-at "\\<begin\\>")) - (ada-goto-matching-end 1)) - ;; on first line of defun declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<function\\>\\|\\<procedure\\>" ))) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; on first line of task declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<task\\>" ) - (forward-word 1) - (ada-search-ignore-string-comment "[^ \n\t]") - (not (backward-char 1)) - (looking-at "\\<body\\>"))) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; accept block start - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<accept\\>" ))) - (ada-goto-matching-end 0)) - ;; package start - ((save-excursion - (and (ada-goto-matching-decl-start t) - (looking-at "\\<package\\>"))) - (ada-goto-matching-end 1)) - ;; inside a 'begin' ... 'end' block - ((save-excursion - (ada-goto-matching-decl-start t)) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; (hopefully ;-) everything else - (t - (ada-goto-matching-end 1))) - (setq pos (point)) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos) - (message "searching for block end ... done")) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table)))) - - -;;;-----------------------------;;; -;;; 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) - (let ((block-done 0) - (lines-remaining (count-lines beg end)) - (msg (format "indenting %4d lines %%4d lines remaining ..." - (count-lines beg end))) - (endmark (copy-marker end))) - ;; catch errors while indenting - (condition-case err - (while (< (point) endmark) - (if (> block-done 9) - (progn (message msg lines-remaining) - (setq block-done 0))) - (if (looking-at "^$") nil - (ada-indent-current)) - (forward-line 1) - (setq block-done (1+ block-done)) - (setq lines-remaining (1- lines-remaining))) - ;; show line number where the error occurred - (error - (error "line %d: %s" (1+ (count-lines (point-min) (point))) err))) - (message "indenting ... done"))) - - -(defun ada-indent-newline-indent () - "Indents the current line, inserts a newline and then indents the new line." - (interactive "*") - (let ((column) - (orgpoint)) - - (ada-indent-current) - (newline) - (delete-horizontal-space) - (setq orgpoint (point)) - - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (setq column (save-excursion - (funcall (ada-indent-function) orgpoint)))) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table)) - - (indent-to column) - - ;; The following is needed to ensure that indentation will still be - ;; correct if something follows behind point when typing LFD - ;; For example: Imagine point to be there (*) when LFD is typed: - ;; while cond loop - ;; null; *end loop; - ;; Result without the following statement would be: - ;; while cond loop - ;; null; - ;; *end loop; - ;; You would then have to type TAB to correct it. - ;; If that doesn't bother you, you can comment out the following - ;; statement to speed up indentation a LITTLE bit. - - (if (not (looking-at "[ \t]*$")) - (ada-indent-current)) - )) - - -(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) - - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (let ((line-end) - (orgpoint (point-marker)) - (cur-indent) - (prev-indent) - (prevline t)) - - ;; - ;; first step - ;; - (save-excursion - (if (ada-goto-prev-nonblank-line t) - ;; - ;; we are not in the first accessible line in the buffer - ;; - (progn - ;;(end-of-line) - ;;(forward-char 1) - ;; we are already at the BOL - (forward-line 1) - (setq line-end (point)) - (setq prev-indent - (save-excursion - (funcall (ada-indent-function) line-end)))) - (progn ; first line of buffer -> set indent - (beginning-of-line) ; to 0 - (delete-horizontal-space) - (setq prevline nil)))) - - (if prevline - ;; - ;; we are not in the first accessible line in the buffer - ;; - (progn - ;; - ;; second step - ;; - (back-to-indentation) - (setq cur-indent (ada-get-current-indent prev-indent)) - ;; only reindent if indentation is different then the current - (if (= (current-column) cur-indent) - nil - (delete-horizontal-space) - (indent-to cur-indent)) - ;; - ;; restore position of point - ;; - (goto-char orgpoint) - (if (< (current-column) (current-indentation)) - (back-to-indentation)))))) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table))) - - -(defun ada-get-current-indent (prev-indent) - ;; Returns the column # to indent the current line to. - ;; PREV-INDENT is the indentation resulting from the previous lines. - (let ((column nil) - (pos nil) - (match-cons nil)) - - (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 "\\<\\(els\\)?if\\>") - (setq func 'ada-get-indent-if)) - ;; - ((looking-at "\\<case\\>") - (setq func 'ada-get-indent-case)) - ;; - ((looking-at "\\<when\\>") - (setq func 'ada-get-indent-when)) - ;; - ((looking-at "--") - (setq func 'ada-get-indent-comment)) - ;; - ((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]") - (setq func 'ada-get-indent-label)) - ;; - ((looking-at "\\<separate\\>") - (setq func 'ada-get-indent-nochange)) - (t - (setq func 'ada-get-indent-noindent)))))) - - func)) - - -;; ---- functions to return indentation for special cases - -(defun ada-get-indent-open-paren (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be behind an open parenthesis not yet closed. - (ada-in-open-paren-p)) - - -(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 ada-ident-re) - (setq defun-name (buffer-substring (match-beginning 0) - (match-end 0))) - (save-excursion - (ada-goto-matching-start 0) - (ada-check-defun-name defun-name) - (current-indentation))) - ;; - ;; 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 ada-subprog-start-re 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", but not "type ... is ...", which is broken - ;; - ((save-excursion - (and - (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint) - (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)))) - (+ (current-indentation) ada-indent)) - ;; - ;; 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-statement => goto next non-ws - ;; - (if match-dat - (goto-char (cdr match-dat))) - (ada-goto-next-non-ws)) - - ;; - ;; no previous end-statement => we are at the beginning of the - ;; 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. - (interactive) ;; DEBUG - (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) - - (forward-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 "matching start is not '%s'" 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\\|protected\\)\\>")) - (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'/'protected' - ;; - (progn - (forward-word 2) - (backward-word 1) - ;; - ;; skip 'body' 'protected' 'type' - ;; - (if (looking-at "\\<\\(body\\|type\\)\\>") - (forward-word 1)) - (forward-sexp 1) - (backward-sexp 1))) - ;; - ;; should be looking-at the correct name - ;; - (if (not (looking-at (concat "\\<" defun-name "\\>"))) - (error "matching defun has different name: %s" - (buffer-substring (point) - (progn (forward-sexp 1) (point))))))) - - -(defun ada-goto-matching-decl-start (&optional noerror nogeneric) - ;; Moves point to the matching declaration start of the current 'begin'. - ;; If NOERROR is non-nil, it only returns nil if no match was found. - (interactive) ;; DEBUG - (let ((nest-count 1) - (pos nil) - (first t) - (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 (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, but not a protected - ;; type definition, which should be handled like a procedure. - (if (save-excursion - (ada-goto-previous-word) - (skip-chars-backward "a-zA-Z0-9_.'") - (if (save-excursion - (backward-char 1) - (looking-at ")")) - (progn - (forward-char 1) - (backward-sexp 1) - (skip-chars-backward "a-zA-Z0-9_.'") - )) - (ada-goto-previous-word) - (and - (looking-at "\\<type\\>") - (save-match-data - (ada-goto-previous-word) - (not (looking-at "\\<protected\\>")))) - ); end of save-excursion - (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 - ada-subprog-start-re t) - (looking-at "declare\\|generic"))))) - (if noerror nil - (error "no matching proc/func/task/declare/package/protected")) - 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\\|do\\|" - "if\\|task\\|package\\|record\\|protected\\)\\>") - t)) - - ;; - ;; calculate nest-depth - ;; - (cond - ;; found block end => increase nest depth - ((looking-at "end") - (setq nest-count (1+ nest-count))) - ;; found loop/select/record/case/if => check if it starts or - ;; ends a block - ((looking-at "loop\\|select\\|record\\|case\\|if") - (setq pos (point)) - (save-excursion - ;; - ;; 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) ; "\"\\|#" don't treat # - (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 the beginning of previous non-blank line, - ;; ignoring comments if IGNORE-COMMENT is non-nil. - ;; It returns t if a matching line was found. - (let ((notfound t) - (newpoint nil)) - - (save-excursion - ;; - ;; backward one line, if there is one - ;; - (if (zerop (forward-line -1)) - ;; - ;; there is some kind of previous line - ;; - (progn - (beginning-of-line) - (setq newpoint (point)) - - ;; - ;; search until found or beginning-of-buffer - ;; - (while (and (setq notfound - (or (looking-at "[ \t]*$") - (and (looking-at "[ \t]*--") - ignore-comment))) - (not (ada-in-limit-line-p))) - (forward-line -1) - ;;(beginning-of-line) - (setq newpoint (point))) ; end of loop - - )) ; end of if - - ) ; end of save-excursion - - (if notfound nil - (progn - (goto-char newpoint) - t)))) - - -(defun ada-goto-next-nonblank-line ( &optional ignore-comment) - ;; Moves point to next non-blank line, - ;; ignoring comments if IGNORE-COMMENT is non-nil. - ;; It returns t if a matching line was found. - (let ((notfound t) - (newpoint nil)) - - (save-excursion - ;; - ;; forward one line - ;; - (if (zerop (forward-line 1)) - ;; - ;; there is some kind of previous line - ;; - (progn - (beginning-of-line) - (setq newpoint (point)) - - ;; - ;; search until found or end-of-buffer - ;; - (while (and (setq notfound - (or (looking-at "[ \t]*$") - (and (looking-at "[ \t]*--") - ignore-comment))) - (not (ada-in-limit-line-p))) - (forward-line 1) - (beginning-of-line) - (setq newpoint (point))) ; end of loop - - )) ; end of if - - ) ; end of save-excursion - - (if notfound nil - (progn - (goto-char newpoint) - t)))) - - -;; ---- boolean functions for indentation - -(defun ada-in-decl-p () - ;; 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\\>"))))) - - -;;; make a faster??? ada-in-limit-line-p not using count-lines -(defun ada-in-limit-line-p () - ;; return t if point is in first or last accessible line. - (or (save-excursion (beginning-of-line) (= (point-min) (point))) - (save-excursion (end-of-line) (= (point-max) (point))))) - - -(defun ada-in-comment-p () - ;; Returns t if inside a comment. - ;; (save-excursion (and (re-search-backward "\\(--\\|\n\\)" nil 1) - ;; (looking-at "-")))) - (nth 4 (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point)))) - - - -(defun ada-in-string-p () - ;; Returns t if point is inside a string - ;; (Taken from pascal-mode.el, modified by MH). - (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 a string delimiter anymore - (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 parenthesis ? - (looking-at (concat "\\<\\(" - "procedure\\|function\\|body\\|package\\|" - "task\\|entry\\|accept\\)\\>")) - (re-search-forward ")\\|:" nil t) - ;; at least one ':' inside the parentheses ? - (not (backward-char 1)) - (looking-at ":")))) - - -;; not really a boolean function ... -(defun ada-in-open-paren-p () - ;; If point is somewhere behind an open parenthesis not yet closed, - ;; it returns the column # of the first non-ws behind this open - ;; parenthesis, otherwise nil." - - (let ((start (if (< (point) ada-search-paren-char-count-limit) - 1 - (- (point) ada-search-paren-char-count-limit))) - parse-result - (col nil)) - (setq parse-result (parse-partial-sexp start (point))) - (if (nth 1 parse-result) - (save-excursion - (goto-char (1+ (nth 1 parse-result))) - (if (save-excursion - (re-search-forward "[^ \t]" nil 1) - (backward-char 1) - (and - (not (looking-at "\n")) - (setq col (current-column)))) - col - (current-column))) - nil))) - - - -;;;----------------------;;; -;;; 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)))) - - - -;;;---------------;;; -;;; Miscellaneous ;;; -;;;---------------;;; - -(defun ada-remove-trailing-spaces () - "remove trailing spaces in the whole buffer." - (interactive) - (save-match-data - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+$" (point-max) t) - (replace-match "" nil nil)))))) - - -(defun ada-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-j" 'ada-indent-newline-indent) - (define-key ada-mode-map "\t" 'ada-tab) - (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region) - (if (ada-xemacs) - (define-key ada-mode-map '(shift tab) 'ada-untab) - (define-key ada-mode-map [S-tab] 'ada-untab)) - (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) - (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer) -;;; We don't want to make meta-characters case-specific. -;;; (define-key ada-mode-map "\M-Q" 'ada-fill-comment-paragraph-justify) - (define-key ada-mode-map "\M-\C-q" 'ada-fill-comment-paragraph-postfix) - - ;; Movement -;;; It isn't good to redefine these. What should be done instead? -- rms. -;;; (define-key ada-mode-map "\M-e" 'ada-next-package) -;;; (define-key ada-mode-map "\M-a" 'ada-previous-package) - (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure) - (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure) - (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start) - (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end) - - ;; Compilation - (define-key ada-mode-map "\C-c\C-c" 'compile) - - ;; Casing - (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region) - (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer) - - (define-key ada-mode-map "\177" 'backward-delete-char-untabify) - - ;; Use predefined function of emacs19 for comments (RE) - (define-key ada-mode-map "\C-c;" 'comment-region) - (define-key ada-mode-map "\C-c:" 'ada-uncomment-region) - - ;; Change basic functionality - - ;; `substitute-key-definition' is not defined equally in GNU Emacs - ;; and XEmacs, you cannot put in an optional 4th parameter in - ;; XEmacs. I don't think it's necessary, so I leave it out for - ;; GNU Emacs as well. If you encounter any problems with the - ;; following three functions, please tell me. RE - (mapcar (function (lambda (pair) - (substitute-key-definition (car pair) (cdr pair) - ada-mode-map))) - '((beginning-of-line . ada-beginning-of-line) - (end-of-line . ada-end-of-line) - (forward-to-indentation . ada-forward-to-indentation) - )) - ;; else GNU Emacs - ;;(mapcar (lambda (pair) - ;; (substitute-key-definition (car pair) (cdr pair) - ;; ada-mode-map global-map)) - - )) - - -;;;------------------- -;;; define menu 'Ada' -;;;------------------- - -(require 'easymenu) - -(defun ada-add-ada-menu () - "Adds the menu 'Ada' to the menu bar in Ada Mode." - (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode." - '("Ada" - ["Next Package" ada-next-package t] - ["Previous Package" ada-previous-package t] - ["Next Procedure" ada-next-procedure t] - ["Previous Procedure" ada-previous-procedure t] - ["Goto Start" ada-move-to-start t] - ["Goto End" ada-move-to-end t] - ["------------------" nil nil] - ["Indent Current Line (TAB)" - ada-indent-current-function t] - ["Indent Lines in Region" ada-indent-region t] - ["Format Parameter List" ada-format-paramlist t] - ["Pretty Print Buffer" ada-call-pretty-printer t] - ["------------" nil nil] - ["Fill Comment Paragraph" - ada-fill-comment-paragraph t] - ["Justify Comment Paragraph" - ada-fill-comment-paragraph-justify t] - ["Postfix Comment Paragraph" - ada-fill-comment-paragraph-postfix t] - ["------------" nil nil] - ["Adjust Case Region" ada-adjust-case-region t] - ["Adjust Case Buffer" ada-adjust-case-buffer t] - ["----------" nil nil] - ["Comment Region" comment-region t] - ["Uncomment Region" ada-uncomment-region t] - ["----------------" nil nil] - ["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)])) - (if (ada-xemacs) (progn - (easy-menu-add ada-mode-menu) - (setq mode-popup-menu (cons "Ada Mode" ada-mode-menu))))) - - - -;;;------------------------------- -;;; Define Some Support Functions -;;;------------------------------- - -(defun ada-beginning-of-line (&optional arg) - (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 -;;;--------------------------------------------------- - - -;;;###autoload -(defun ada-make-filename-from-adaname (adaname) - "Determine the filename of a package/procedure from its own Ada name." - ;; this is done simply by calling gkrunch, when we work with GNAT. It - ;; must be a more complex function in other compiler environments. - (interactive "s") - - ;; things that should really be done by the external process - ;; since gnat-2.0, gnatk8 can do these things. If you still use a - ;; previous version, just uncomment the following lines. - (let (krunch-buf) - (setq krunch-buf (generate-new-buffer "*gkrunch*")) - (save-excursion - (set-buffer krunch-buf) -; (insert (downcase adaname)) -; (goto-char (point-min)) -; (while (search-forward "." nil t) -; (replace-match "-" nil t)) -; (setq adaname (buffer-substring (point-min) -; (progn -; (goto-char (point-min)) -; (end-of-line) -; (point)))) -; ;; clean the buffer -; (delete-region (point-min) (point-max)) - ;; send adaname to external process "gnatk8" - (call-process "gnatk8" nil krunch-buf nil - 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? - ) - - -;;; functions for placing the cursor on the corresponding subprogram -(defun ada-which-function-are-we-in () - "Determine whether we are on a function definition/declaration. -If that is the case remember the name of that function." - - (setq ff-function-name nil) - - (save-excursion - (if (re-search-backward ada-procedure-start-regexp nil t) - (setq ff-function-name (buffer-substring (match-beginning 0) - (match-end 0))) - ; we didn't find a procedure start, perhaps there is a package - (if (re-search-backward ada-package-start-regexp nil t) - (setq ff-function-name (buffer-substring (match-beginning 0) - (match-end 0))) - )))) - - -;;;--------------------------------------------------- -;;; support for imenu -;;;--------------------------------------------------- - -(defun imenu-create-ada-index (&optional regexp) - "Create index alist for Ada files." - (let ((index-alist '()) - prev-pos char) - (goto-char (point-min)) - ;(imenu-progress-message prev-pos 0) - ;; Search for functions/procedures - (save-match-data - (while (re-search-forward - (or regexp ada-procedure-start-regexp) - nil t) - ;(imenu-progress-message prev-pos) - ;; do not store forward definitions - ;; right now we store them. We want to avoid them only in - ;; package bodies, not in the specs!! ???RE??? - (save-match-data -; (if (not (looking-at (concat -; "[ \t\n]*" ; WS -; "\([^)]+\)" ; parameterlist -; "\\([ \n\t]+return[ \n\t]+"; potential return -; "[a-zA-Z0-9_\\.]+\\)?" -; "[ \t]*" ; WS -; ";" ;; THIS is what we really look for -; ))) -; ; (push (imenu-example--name-and-position) index-alist) - (setq index-alist (cons (imenu-example--name-and-position) - index-alist)) -; ) - ) - ;(imenu-progress-message 100) - )) - (nreverse index-alist))) - -;;;--------------------------------------------------- -;;; support for font-lock -;;;--------------------------------------------------- - -;; Strings are a real pain in Ada because both ' and " can appear in a -;; non-string quote context (the former as an operator, the latter as -;; a character string). We follow the least losing solution, in which -;; only " is a string quote. Therefore a character string of the form -;; '"' will throw fontification off on the wrong track. - -(defconst ada-font-lock-keywords-1 - (list - ;; - ;; accept, entry, function, package (body), protected (body|type), - ;; pragma, procedure, task (body) plus name. - (list (concat - "\\<\\(" - "accept\\|" - "entry\\|" - "function\\|" - "package[ \t]+body\\|" - "package\\|" - "pragma\\|" - "procedure\\|" - "protected[ \t]+body\\|" - "protected[ \t]+type\\|" - "protected\\|" -;; "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\ -;;\\|r\\(agma\\|ocedure\\)\\)\\|" - "task\\|" - "task[ \t]+body\\|" - "task[ \t]+type" -;; "task\\(\\|[ \t]+body\\)" - "\\)\\>[ \t]*" - "\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))) - "Subdued level highlighting for Ada mode.") - -(defconst ada-font-lock-keywords-2 - (append ada-font-lock-keywords-1 - (list - ;; - ;; Main keywords, except those treated specially below. - (concat "\\<\\(" -; ("abort" "abs" "abstract" "accept" "access" "aliased" "all" -; "and" "array" "at" "begin" "case" "declare" "delay" "delta" -; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" -; "generic" "if" "in" "is" "limited" "loop" "mod" "not" -; "null" "or" "others" "private" "protected" -; "range" "record" "rem" "renames" "requeue" "return" "reverse" -; "select" "separate" "tagged" "task" "terminate" "then" "until" -; "while" "xor") - "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|" - "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|" - "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|" - "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|" - "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|" - "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|" - "r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" - "se\\(lect\\|parate\\)\\|" - "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed - "wh\\(ile\\|en\\)\\|xor" ; "when" added - "\\)\\>") - ;; - ;; Anything following end and not already fontified is a body name. - '("\\<\\(end\\)\\>[ \t]+\\([a-zA-Z0-9_\\.]+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ;; - ;; 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\\|with\\)\\>" ; "when" removed - ; "[ \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) - )) - "Gaudy level highlighting for Ada mode.") - -(defvar ada-font-lock-keywords ada-font-lock-keywords-2 - "Default Expressions to highlight in Ada mode. -See the doc to `font-lock-maximum-decoration' for user configuration.") - -;;; -;;; ???? -;;; -(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 (match) - ;; make dummy body of a procedure/function specification. - ;; MATCH is a cons cell containing the start and end location of the - ;; last search for ada-procedure-start-regexp. - (goto-char (car match)) - (let (proc-found func-found procname functype) - (cond - ((or (setq proc-found (looking-at "^[ \t]*procedure")) - (setq func-found (looking-at "^[ \t]*function"))) - ;; treat it as a proc/func - (forward-word 2) - (forward-word -1) - (setq procname (buffer-substring (point) (cdr match))) ; store proc name - - ;; goto end of procname - (goto-char (cdr match)) - - ;; skip over parameterlist - (forward-sexp) - ;; if function, skip over 'return' and result type. - (if func-found - (progn - (forward-word 1) - (skip-chars-forward " \t\n") - (setq functype (buffer-substring (point) - (progn - (skip-chars-forward - "a-zA-Z0-9_\.") - (point)))))) - ;; look for next non WS - (cond - ((looking-at "[ \t]*;") - (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';' - (ada-indent-newline-indent) - (insert " is") - (ada-indent-newline-indent) - (if func-found - (progn - (insert "Result : ") - (insert functype) - (insert ";") - (ada-indent-newline-indent))) - (insert "begin -- ") - (insert procname) - (ada-indent-newline-indent) - (insert "null;") - (ada-indent-newline-indent) - (if func-found - (progn - (insert "return Result;") - (ada-indent-newline-indent))) - (insert "end ") - (insert procname) - (insert ";") - (ada-indent-newline-indent) - ) - ;; else - ((looking-at "[ \t\n]*is") - ;; do nothing - ) - ((looking-at "[ \t\n]*rename") - ;; do nothing - ) - (t - (message "unknown syntax"))) - )))) - - -(defun ada-make-body () - "Create an Ada package body in the current buffer. -The potential old buffer contents is deleted first, then we copy the -spec buffer in here and modify it to make it a body. - -This function typically is to be hooked into `ff-file-created-hooks'." - (interactive) - (delete-region (point-min) (point-max)) - (insert-buffer (car (cdr (buffer-list)))) - (ada-mode) - - (let (found) - (if (setq found - (ada-search-ignore-string-comment ada-package-start-regexp)) - (progn (goto-char (cdr found)) - (insert " body") - ;; (forward-line -1) - ;;(comment-region (point-min) (point)) - ) - (error "No package")) - - ;; (comment-until-proc) - ;; does not work correctly - ;; must be done by hand - - (while (setq found - (ada-search-ignore-string-comment ada-procedure-start-regexp)) - (ada-gen-treat-proc found)))) - - -;;; provide ourself - -(provide 'ada-mode) - -;;; ada-mode.el ends here diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el deleted file mode 100644 index 3a0370bdaaf..00000000000 --- a/lisp/progmodes/asm-mode.el +++ /dev/null @@ -1,231 +0,0 @@ -;;; asm-mode.el --- mode for editing assembler code - -;; Copyright (C) 1991 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: FSF -;; Keywords: tools, languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This mode was written by Eric S. Raymond <esr@snark.thyrsus.com>, -;; inspired by an earlier asm-mode by Martin Neitzel. - -;; This minor mode is based on text mode. It defines a private abbrev table -;; that can be used to save abbrevs for assembler mnemonics. It binds just -;; five keys: -;; -;; TAB tab to next tab stop -;; : outdent preceding label, tab to tab stop -;; comment char place or move comment -;; asm-comment-char specifies which character this is; -;; you can use a different character in different -;; Asm mode buffers. -;; C-j, C-m newline and tab to tab stop -;; -;; Code is indented to the first tab stop level. - -;; This mode runs two hooks: -;; 1) An asm-mode-set-comment-hook before the part of the initialization -;; depending on asm-comment-char, and -;; 2) an asm-mode-hook at the end of initialization. - -;;; Code: - -(defvar asm-comment-char ?; - "*The comment-start character assumed by Asm mode.") - -(defvar asm-mode-syntax-table nil - "Syntax table used while in Asm mode.") - -(defvar asm-mode-abbrev-table nil - "Abbrev table used while in Asm mode.") -(define-abbrev-table 'asm-mode-abbrev-table ()) - -(defvar asm-mode-map nil - "Keymap for Asm mode.") - -(if asm-mode-map - nil - (setq asm-mode-map (make-sparse-keymap)) - ;; Note that the comment character isn't set up until asm-mode is called. - (define-key asm-mode-map ":" 'asm-colon) - (define-key asm-mode-map "\C-c;" 'comment-region) - (define-key asm-mode-map "\C-i" 'tab-to-tab-stop) - (define-key asm-mode-map "\C-j" 'asm-newline) - (define-key asm-mode-map "\C-m" 'asm-newline) - ) - -(defconst asm-font-lock-keywords - '(("^\\(\\(\\sw\\|\\s_\\)+\\)\\>:?[ \t]*\\(\\sw+\\)?" - (1 font-lock-function-name-face) (3 font-lock-keyword-face nil t)) - ("^\\s +\\(\\(\\sw\\|\\s_\\)+\\)" 1 font-lock-keyword-face)) - "Additional expressions to highlight in Assembler mode.") - -(defvar asm-code-level-empty-comment-pattern nil) -(defvar asm-flush-left-empty-comment-pattern nil) -(defvar asm-inline-empty-comment-pattern nil) - -;;;###autoload -(defun asm-mode () - "Major mode for editing typical assembler code. -Features a private abbrev table and the following bindings: - -\\[asm-colon]\toutdent a preceding label, tab to next tab stop. -\\[tab-to-tab-stop]\ttab to next tab stop. -\\[asm-newline]\tnewline, then tab to next tab stop. -\\[asm-comment]\tsmart placement of assembler comments. - -The character used for making comments is set by the variable -`asm-comment-char' (which defaults to `?;'). - -Alternatively, you may set this variable in `asm-mode-set-comment-hook', -which is called near the beginning of mode initialization. - -Turning on Asm mode runs the hook `asm-mode-hook' at the end of initialization. - -Special commands: -\\{asm-mode-map} -" - (interactive) - (kill-all-local-variables) - (setq mode-name "Assembler") - (setq major-mode 'asm-mode) - (setq local-abbrev-table asm-mode-abbrev-table) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(asm-font-lock-keywords)) - (make-local-variable 'asm-mode-syntax-table) - (setq asm-mode-syntax-table (make-syntax-table)) - (set-syntax-table asm-mode-syntax-table) - - (run-hooks 'asm-mode-set-comment-hook) - ;; Make our own local child of asm-mode-map - ;; so we can define our own comment character. - (use-local-map (nconc (make-sparse-keymap) asm-mode-map)) - (local-set-key (vector asm-comment-char) 'asm-comment) - - (modify-syntax-entry asm-comment-char - "<" asm-mode-syntax-table) - (modify-syntax-entry ?\n - ">" asm-mode-syntax-table) - (let ((cs (regexp-quote (char-to-string asm-comment-char)))) - (make-local-variable 'comment-start) - (setq comment-start (concat cs " ")) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip (concat cs "+[ \t]*")) - (setq asm-inline-empty-comment-pattern (concat "^.+" cs "+ *$")) - (setq asm-code-level-empty-comment-pattern (concat "^[\t ]+" cs cs " *$")) - (setq asm-flush-left-empty-comment-pattern (concat "^" cs cs cs " *$")) - ) - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (setq fill-prefix "\t") - (run-hooks 'asm-mode-hook)) - -(defun asm-colon () - "Insert a colon; if it follows a label, delete the label's indentation." - (interactive) - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]+\\(\\sw\\|\\s_\\)+$") - (delete-horizontal-space))) - (insert ":") - (tab-to-tab-stop) - ) - -(defun asm-newline () - "Insert LFD + fill-prefix, to bring us back to code-indent level." - (interactive) - (if (eolp) (delete-horizontal-space)) - (insert "\n") - (tab-to-tab-stop) - ) - -(defun asm-line-matches (pattern &optional withcomment) - (save-excursion - (beginning-of-line) - (looking-at pattern))) - -(defun asm-pop-comment-level () - ;; Delete an empty comment ending current line. Then set up for a new one, - ;; on the current line if it was all comment, otherwise above it - (end-of-line) - (delete-horizontal-space) - (while (= (preceding-char) asm-comment-char) - (delete-backward-char 1)) - (delete-horizontal-space) - (if (bolp) - nil - (beginning-of-line) - (open-line 1)) - ) - - -(defun asm-comment () - "Convert an empty comment to a `larger' kind, or start a new one. -These are the known comment classes: - - 1 -- comment to the right of the code (at the comment-column) - 2 -- comment on its own line, indented like code - 3 -- comment on its own line, beginning at the left-most column. - -Suggested usage: while writing your code, trigger asm-comment -repeatedly until you are satisfied with the kind of comment." - (interactive) - (cond - - ;; Blank line? Then start comment at code indent level. - ((asm-line-matches "^[ \t]*$") - (delete-horizontal-space) - (tab-to-tab-stop) - (insert asm-comment-char comment-start)) - - ;; Nonblank line with no comment chars in it? - ;; Then start a comment at the current comment column - ((asm-line-matches (format "^[^%c\n]+$" asm-comment-char)) - (indent-for-comment)) - - ;; Flush-left comment present? Just insert character. - ((asm-line-matches asm-flush-left-empty-comment-pattern) - (insert asm-comment-char)) - - ;; Empty code-level comment already present? - ;; Then start flush-left comment, on line above if this one is nonempty. - ((asm-line-matches asm-code-level-empty-comment-pattern) - (asm-pop-comment-level) - (insert asm-comment-char asm-comment-char comment-start)) - - ;; Empty comment ends line? - ;; Then make code-level comment, on line above if this one is nonempty. - ((asm-line-matches asm-inline-empty-comment-pattern) - (asm-pop-comment-level) - (tab-to-tab-stop) - (insert asm-comment-char comment-start)) - - ;; If all else fails, insert character - (t - (insert asm-comment-char)) - - ) - (end-of-line)) - -;;; asm-mode.el ends here diff --git a/lisp/progmodes/awk-mode.el b/lisp/progmodes/awk-mode.el deleted file mode 100644 index 3ba782bac38..00000000000 --- a/lisp/progmodes/awk-mode.el +++ /dev/null @@ -1,153 +0,0 @@ -;;; awk-mode.el --- AWK code editing commands for Emacs - -;; Copyright (C) 1988, 1994, 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: unix, languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Sets up C-mode with support for awk-style #-comments and a lightly -;; hacked syntax table. - -;;; Code: - -(defvar awk-mode-syntax-table nil - "Syntax table in use in Awk-mode buffers.") - -(if awk-mode-syntax-table - () - (setq awk-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" awk-mode-syntax-table) - (modify-syntax-entry ?\n "> " awk-mode-syntax-table) - (modify-syntax-entry ?\f "> " awk-mode-syntax-table) - (modify-syntax-entry ?\# "< " awk-mode-syntax-table) - (modify-syntax-entry ?/ "." awk-mode-syntax-table) - (modify-syntax-entry ?* "." awk-mode-syntax-table) - (modify-syntax-entry ?+ "." awk-mode-syntax-table) - (modify-syntax-entry ?- "." awk-mode-syntax-table) - (modify-syntax-entry ?= "." awk-mode-syntax-table) - (modify-syntax-entry ?% "." awk-mode-syntax-table) - (modify-syntax-entry ?< "." awk-mode-syntax-table) - (modify-syntax-entry ?> "." awk-mode-syntax-table) - (modify-syntax-entry ?& "." awk-mode-syntax-table) - (modify-syntax-entry ?| "." awk-mode-syntax-table) - (modify-syntax-entry ?_ "_" awk-mode-syntax-table) - (modify-syntax-entry ?\' "\"" awk-mode-syntax-table)) - -(defvar awk-mode-abbrev-table nil - "Abbrev table in use in Awk-mode buffers.") -(define-abbrev-table 'awk-mode-abbrev-table ()) - -;; Regexps written with help from Peter Galbraith <galbraith@mixing.qc.dfo.ca>. -(defconst awk-font-lock-keywords - (eval-when-compile - (list - ;; - ;; Function names. - '("^[ \t]*\\(function\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ;; - ;; Variable names. - (cons (concat "\\<\\(" -; ("ARGC" "ARGIND" "ARGV" "CONVFMT" "ENVIRON" "ERRNO" -; "FIELDWIDTHS" "FILENAME" "FNR" "FS" "IGNORECASE" "NF" "NR" -; "OFMT" "OFS" "ORS" "RLENGTH" "RS" "RSTART" "SUBSEP") - "ARG\\([CV]\\|IND\\)\\|CONVFMT\\|E\\(NVIRON\\|RRNO\\)\\|" - "F\\(I\\(ELDWIDTHS\\|LENAME\\)\\|NR\\|S\\)\\|IGNORECASE\\|" - "N[FR]\\|O\\(F\\(MT\\|S\\)\\|RS\\)\\|" - "R\\(LENGTH\\|S\\(\\|TART\\)\\)\\|SUBSEP" - "\\)\\>") - 'font-lock-variable-name-face) - ;; - ;; Keywords. - (concat "\\<\\(" -; ("BEGIN" "END" "break" "continue" "delete" "exit" "for" -; "getline" "if" "next" "print" "printf" "return" "while") - "BEGIN\\|END\\|break\\|continue\\|delete\\|exit\\|for\\|" - "getline\\|if\\|next\\|printf?\\|return\\|while" - "\\)\\>") - ;; - ;; Builtins. - (list (concat "\\<\\(" -; ("atan2" "close" "cos" "ctime" "exp" "gsub" "index" "int" -; "length" "log" "match" "rand" "sin" "split" "sprintf" -; "sqrt" "srand" "sub" "substr" "system" "time" -; "tolower" "toupper") - "atan2\\|c\\(lose\\|os\\|time\\)\\|exp\\|gsub\\|" - "in\\(dex\\|t\\)\\|l\\(ength\\|og\\)\\|match\\|rand\\|" - "s\\(in\\|p\\(lit\\|rintf\\)\\|qrt\\|rand\\|" - "ub\\(\\|str\\)\\|ystem\\)\\|" - "t\\(ime\\|o\\(lower\\|upper\\)\\)" - "\\)(") - 1 'font-lock-builtin-face) - ;; - ;; Operators. Is this too much? - (cons (mapconcat 'identity - '("&&" "||" "<=" "<" ">=" ">" "==" "!=" "!~" "~") - "\\|") - 'font-lock-reference-face) - )) - "Default expressions to highlight in AWK mode.") - -;;;###autoload -(defun awk-mode () - "Major mode for editing AWK code. -This is much like C mode except for the syntax of comments. It uses -the same keymap as C mode and has the same variables for customizing -indentation. It has its own abbrev table and its own syntax table. - -Turning on AWK mode calls the value of the variable `awk-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (require 'cc-mode) - (use-local-map c-mode-map) - (setq major-mode 'awk-mode) - (setq mode-name "AWK") - (setq local-abbrev-table awk-mode-abbrev-table) - (set-syntax-table awk-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'c-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(awk-font-lock-keywords nil nil ((?_ . "w")))) - (run-hooks 'awk-mode-hook)) - -(provide 'awk-mode) - -;;; awk-mode.el ends here diff --git a/lisp/progmodes/c-mode.el b/lisp/progmodes/c-mode.el deleted file mode 100644 index f3364457e18..00000000000 --- a/lisp/progmodes/c-mode.el +++ /dev/null @@ -1,1650 +0,0 @@ -;;; c-mode.el --- C code editing commands for Emacs - -;; Copyright (C) 1985, 86, 87, 92, 94, 95 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: c - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; A smart editing mode for C code. It knows a lot about C syntax and tries -;; to position the cursor according to C layout conventions. You can -;; change the details of the layout style with option variables. Load it -;; and do M-x describe-mode for details. - -;;; Code: - -(defvar c-mode-abbrev-table nil - "Abbrev table in use in C mode.") -(define-abbrev-table 'c-mode-abbrev-table ()) - -(defvar c-mode-map (make-sparse-keymap) - "Keymap used in C mode.") - -(define-key c-mode-map "{" 'electric-c-brace) -(define-key c-mode-map "}" 'electric-c-brace) -(define-key c-mode-map ";" 'electric-c-semi) -(define-key c-mode-map "#" 'electric-c-sharp-sign) -(define-key c-mode-map ":" 'electric-c-terminator) -(define-key c-mode-map "\e\C-h" 'mark-c-function) -(define-key c-mode-map "\e\C-q" 'indent-c-exp) -(define-key c-mode-map "\ea" 'c-beginning-of-statement) -(define-key c-mode-map "\ee" 'c-end-of-statement) -(define-key c-mode-map "\C-c\C-n" 'c-forward-conditional) -(define-key c-mode-map "\C-c\C-p" 'c-backward-conditional) -(define-key c-mode-map "\C-c\C-u" 'c-up-conditional) -(define-key c-mode-map "\177" 'backward-delete-char-untabify) -(define-key c-mode-map "\t" 'c-indent-command) - -(define-key c-mode-map [menu-bar] (make-sparse-keymap)) - -;; "C-mode" is not strictly the right punctuation--it should be "C -;; mode"--but that would look like two menu items. "C-mode" is the -;; best alternative I can think of. -(define-key c-mode-map [menu-bar c] - (cons "C-mode" (make-sparse-keymap "C-mode"))) - -(define-key c-mode-map [menu-bar c comment-region] - '("Comment Out Region" . comment-region)) -(define-key c-mode-map [menu-bar c c-macro-expand] - '("Macro Expand Region" . c-macro-expand)) -(define-key c-mode-map [menu-bar c c-backslash-region] - '("Backslashify" . c-backslash-region)) -(define-key c-mode-map [menu-bar c indent-exp] - '("Indent Expression" . indent-c-exp)) -(define-key c-mode-map [menu-bar c indent-line] - '("Indent Line" . c-indent-command)) -(define-key c-mode-map [menu-bar c fill] - '("Fill Comment Paragraph" . c-fill-paragraph)) -(define-key c-mode-map [menu-bar c cpp-highlight-buffer] - '("Highlight Conditionals" . cpp-highlight-buffer)) -(define-key c-mode-map [menu-bar c up] - '("Up Conditional" . c-up-conditional)) -(define-key c-mode-map [menu-bar c backward] - '("Backward Conditional" . c-backward-conditional)) -(define-key c-mode-map [menu-bar c forward] - '("Forward Conditional" . c-forward-conditional)) -(define-key c-mode-map [menu-bar c backward-stmt] - '("Backward Statement" . c-beginning-of-statement)) -(define-key c-mode-map [menu-bar c forward-stmt] - '("Forward Statement" . c-end-of-statement)) - -(put 'comment-region 'menu-enable 'mark-active) -(put 'c-macro-expand 'menu-enable 'mark-active) -(put 'c-backslash-region 'menu-enable 'mark-active) - -(autoload 'c-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar c-mode-syntax-table nil - "Syntax table in use in C-mode buffers.") - -(if c-mode-syntax-table - () - (setq c-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" c-mode-syntax-table) - (modify-syntax-entry ?/ ". 14" c-mode-syntax-table) - (modify-syntax-entry ?* ". 23" c-mode-syntax-table) - (modify-syntax-entry ?+ "." c-mode-syntax-table) - (modify-syntax-entry ?- "." c-mode-syntax-table) - (modify-syntax-entry ?= "." c-mode-syntax-table) - (modify-syntax-entry ?% "." c-mode-syntax-table) - (modify-syntax-entry ?< "." c-mode-syntax-table) - (modify-syntax-entry ?> "." c-mode-syntax-table) - (modify-syntax-entry ?& "." c-mode-syntax-table) - (modify-syntax-entry ?| "." c-mode-syntax-table) - (modify-syntax-entry ?\' "\"" c-mode-syntax-table)) - -(defconst c-indent-level 2 - "*Indentation of C statements with respect to containing block.") -(defconst c-brace-imaginary-offset 0 - "*Imagined indentation of a C open brace that actually follows a statement.") -(defconst c-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defconst c-argdecl-indent 5 - "*Indentation level of declarations of C function arguments.") -(defconst c-label-offset -2 - "*Offset of C label lines and case statements relative to usual indentation.") -(defconst c-continued-statement-offset 2 - "*Extra indent for lines not starting new statements.") -(defconst c-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to `c-continued-statement-offset'.") -(defconst c-style-alist - '(("GNU" - (c-indent-level . 2) - (c-argdecl-indent . 5) - (c-brace-offset . 0) - (c-continued-brace-offset . 0) - (c-label-offset . -2) - (c-continued-statement-offset . 2)) - ("K&R" - (c-indent-level . 5) - (c-argdecl-indent . 0) - (c-brace-offset . 0) - (c-continued-brace-offset . -5) - (c-label-offset . -5) - (c-continued-statement-offset . 5)) - ("BSD" - (c-indent-level . 4) - (c-argdecl-indent . 4) - (c-brace-offset . 0) - (c-continued-brace-offset . -4) - (c-label-offset . -4) - (c-continued-statement-offset . 4)) - ("C++" - (c-indent-level . 4) - (c-argdecl-indent . 0) - (c-brace-offset . 0) - (c-continued-brace-offset . -4) - (c-label-offset . -4) - (c-continued-statement-offset . 4) - (c-auto-newline . t)) - ("Whitesmith" - (c-indent-level . 4) - (c-argdecl-indent . 4) - (c-brace-offset . 0) - (c-continued-brace-offset . 0) - (c-label-offset . -4) - (c-continued-statement-offset . 4)))) - -(defconst c-auto-newline nil - "*Non-nil means automatically newline before and after braces, -and after colons and semicolons, inserted in C code. -If you do not want a leading newline before braces then use: - (define-key c-mode-map \"{\" 'electric-c-semi)") - -(defconst c-tab-always-indent t - "*Non-nil means TAB in C mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used.") - -;;; Regular expression used internally to recognize labels in switch -;;; statements. -(defconst c-switch-label-regexp "case[ \t'/(]\\|default[ \t]*:") - -;; This is actually the expression for C++ mode, but it's used for C too. -(defvar c-imenu-generic-expression - (` - ((nil - (, - (concat - "^" ; beginning of line is required - "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>" - "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no - "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right? - - "\\(" ; last type spec including */& - "[a-zA-Z0-9_:]+" - "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace - "\\)?" ; if there is a last type spec - "\\(" ; name; take that into the imenu entry - "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor... - ; (may not contain * because then - ; "a::operator char*" would become "char*"!) - "\\|" - "\\([a-zA-Z0-9_:~]*::\\)?operator" - "[^a-zA-Z1-9_][^(]*" ; ...or operator - " \\)" - "[ \t]*([^)]*)[ \t\n]*[^ ;]" ; require something other than a ; after - ; the (...) to avoid prototypes. Can't - ; catch cases with () inside the parentheses - ; surrounding the parameters - ; (like "int foo(int a=bar()) {...}" - - )) 6) - ("Class" - (, (concat - "^" ; beginning of line is required - "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>" - "class[ \t]+" - "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get - "[ \t]*[:{]" - )) 2) -;; Example of generic expression for finding prototypes, structs, unions, enums. -;; Uncomment if you want to find these too. It will be a bit slower gathering -;; the indexes. -; ("Prototypes" -; (, -; (concat -; "^" ; beginning of line is required -; "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>" -; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no -; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right? - -; "\\(" ; last type spec including */& -; "[a-zA-Z0-9_:]+" -; "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace -; "\\)?" ; if there is a last type spec -; "\\(" ; name; take that into the imenu entry -; "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor... -; ; (may not contain * because then -; ; "a::operator char*" would become "char*"!) -; "\\|" -; "\\([a-zA-Z0-9_:~]*::\\)?operator" -; "[^a-zA-Z1-9_][^(]*" ; ...or operator -; " \\)" -; "[ \t]*([^)]*)[ \t\n]*;" ; require ';' after -; ; the (...) Can't -; ; catch cases with () inside the parentheses -; ; surrounding the parameters -; ; (like "int foo(int a=bar());" -; )) 6) -; ("Struct" -; (, (concat -; "^" ; beginning of line is required -; "\\(static[ \t]+\\)?" ; there may be static or const. -; "\\(const[ \t]+\\)?" -; "struct[ \t]+" -; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get -; "[ \t]*[{]" -; )) 3) -; ("Enum" -; (, (concat -; "^" ; beginning of line is required -; "\\(static[ \t]+\\)?" ; there may be static or const. -; "\\(const[ \t]+\\)?" -; "enum[ \t]+" -; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get -; "[ \t]*[{]" -; )) 3) -; ("Union" -; (, (concat -; "^" ; beginning of line is required -; "\\(static[ \t]+\\)?" ; there may be static or const. -; "\\(const[ \t]+\\)?" -; "union[ \t]+" -; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get -; "[ \t]*[{]" -; )) 3) - )) - "Imenu generic expression for C mode. See `imenu-generic-expression'.") - -(defun c-mode () - "Major mode for editing C code. -Expression and list commands understand all C brackets. -Tab indents for C code. -Comments are delimited with /* ... */. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{c-mode-map} -Variables controlling indentation style: - c-tab-always-indent - Non-nil means TAB in C mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - c-auto-newline - Non-nil means automatically newline before and after braces, - and after colons and semicolons, inserted in C code. - c-indent-level - Indentation of C statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - c-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - c-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to c-continued-statement-offset. - c-brace-offset - Extra indentation for line if it starts with an open brace. - c-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - c-argdecl-indent - Indentation level of declarations of C function arguments. - c-label-offset - Extra indentation for line that is a label, or case or default. - -Settings for K&R and BSD indentation styles are - c-indent-level 5 8 - c-continued-statement-offset 5 8 - c-brace-offset -5 -8 - c-argdecl-indent 0 8 - c-label-offset -5 -8 - -Turning on C mode calls the value of the variable c-mode-hook with no args, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map c-mode-map) - (setq major-mode 'c-mode) - (setq mode-name "C") - (setq local-abbrev-table c-mode-abbrev-table) - (set-syntax-table c-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'c-fill-paragraph) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'c-indent-line) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'c-indent-region) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'outline-regexp) - (setq outline-regexp "[^#\n\^M]") - (make-local-variable 'outline-level) - (setq outline-level 'c-outline-level) - (make-local-variable 'comment-start) - (setq comment-start "/* ") - (make-local-variable 'comment-end) - (setq comment-end " */") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "/\\*+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (make-local-variable 'comment-multi-line) - (setq comment-multi-line t) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression c-imenu-generic-expression) - (run-hooks 'c-mode-hook)) - -(defun c-outline-level () - (save-excursion - (skip-chars-forward "\t ") - (current-column))) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in C code -;; based on its context. -(defun c-comment-indent () - (if (looking-at "^/\\*") - 0 ;Existing comment at bol stays there. - (let ((opoint (point))) - (save-excursion - (beginning-of-line) - (cond ((looking-at "[ \t]*}[ \t]*\\($\\|/\\*\\)") - ;; A comment following a solitary close-brace - ;; should have only one space. - (search-forward "}") - (1+ (current-column))) - ((or (looking-at "^#[ \t]*endif[ \t]*") - (looking-at "^#[ \t]*else[ \t]*")) - 7) ;2 spaces after #endif - ((progn - (goto-char opoint) - (skip-chars-backward " \t") - (and (= comment-column 0) (bolp))) - ;; If comment-column is 0, and nothing but space - ;; before the comment, align it at 0 rather than 1. - 0) - (t - (max (1+ (current-column)) ;Else indent at comment column - comment-column))))))) ; except leave at least one space. - -(defun c-fill-paragraph (&optional arg) - "Like \\[fill-paragraph] but handle C comments. -If any of the current line is a comment or within a comment, -fill the comment or the paragraph of it that point is in, -preserving the comment indentation or line-starting decorations." - (interactive "P") - (let* (comment-start-place - (first-line - ;; Check for obvious entry to comment. - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t\n") - (and (looking-at comment-start-skip) - (setq comment-start-place (point)))))) - (if (and (eq major-mode 'c++-mode) - (save-excursion - (beginning-of-line) - (looking-at ".*//"))) - (let (fill-prefix - (paragraph-start - ;; Lines containing just a comment start or just an end - ;; should not be filled into paragraphs they are next to. - (concat - paragraph-start - "\\|[ \t]*/\\*[ \t]*$\\|[ \t]*\\*/[ \t]*$\\|[ \t/*]*$")) - (paragraph-separate - (concat - paragraph-separate - "\\|[ \t]*/\\*[ \t]*$\\|[ \t]*\\*/[ \t]*$\\|[ \t/*]*$"))) - (save-excursion - (beginning-of-line) - ;; Move up to first line of this comment. - (while (and (not (bobp)) (looking-at "[ \t]*//")) - (forward-line -1)) - (if (not (looking-at ".*//")) - (forward-line 1)) - ;; Find the comment start in this line. - (re-search-forward "[ \t]*//[ \t]*") - ;; Set the fill-prefix to be what all lines except the first - ;; should start with. - (let ((endcol (current-column))) - (skip-chars-backward " \t") - (setq fill-prefix - (concat (make-string (- (current-column) 2) ?\ ) - "//" - (make-string (- endcol (current-column)) ?\ )))) - (save-restriction - ;; Narrow down to just the lines of this comment. - (narrow-to-region (point) - (save-excursion - (forward-line 1) - (while (looking-at "[ \t]*//") - (forward-line 1)) - (point))) - (insert fill-prefix) - (fill-paragraph arg) - (delete-region (point-min) - (+ (point-min) (length fill-prefix)))))) - (if (or first-line - ;; t if we enter a comment between start of function and this line. - (eq (calculate-c-indent) t) - ;; t if this line contains a comment starter. - (setq first-line - (save-excursion - (beginning-of-line) - (prog1 - (re-search-forward comment-start-skip - (save-excursion (end-of-line) - (point)) - t) - (setq comment-start-place (point)))))) - ;; Inside a comment: fill one comment paragraph. - (let ((fill-prefix - ;; The prefix for each line of this paragraph - ;; is the appropriate part of the start of this line, - ;; up to the column at which text should be indented. - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*/\\*.*\\*/") - (progn (re-search-forward comment-start-skip) - (make-string (current-column) ?\ )) - (if first-line (forward-line 1)) - - (let ((line-width (progn (end-of-line) (current-column)))) - (beginning-of-line) - (prog1 - (buffer-substring - (point) - - ;; How shall we decide where the end of the - ;; fill-prefix is? - ;; calculate-c-indent-within-comment bases its value - ;; on the indentation of previous lines; if they're - ;; indented specially, it could return a column - ;; that's well into the current line's text. So - ;; we'll take at most that many space, tab, or * - ;; characters, and use that as our fill prefix. - (let ((max-prefix-end - (progn - (move-to-column - (calculate-c-indent-within-comment t) - t) - (point)))) - (beginning-of-line) - (skip-chars-forward " \t*" max-prefix-end) - ;; Don't include part of comment terminator - ;; in the fill-prefix. - (and (eq (following-char) ?/) - (eq (preceding-char) ?*) - (backward-char 1)) - (point))) - - ;; If the comment is only one line followed by a blank - ;; line, calling move-to-column above may have added - ;; some spaces and tabs to the end of the line; the - ;; fill-paragraph function will then delete it and the - ;; newline following it, so we'll lose a blank line - ;; when we shouldn't. So delete anything - ;; move-to-column added to the end of the line. We - ;; record the line width instead of the position of the - ;; old line end because move-to-column might break a - ;; tab into spaces, and the new characters introduced - ;; there shouldn't be deleted. - - ;; If you can see a better way to do this, please make - ;; the change. This seems very messy to me. - (delete-region (progn (move-to-column line-width) - (point)) - (progn (end-of-line) (point)))))))) - - (paragraph-start - ;; Lines containing just a comment start or just an end - ;; should not be filled into paragraphs they are next to. - (concat - paragraph-start - "\\|[ \t]*/\\*[ \t]*$\\|[ \t]*\\*/[ \t]*$\\|[ \t/*]*$")) - (paragraph-separate - (concat - paragraph-separate - "\\|[ \t]*/\\*[ \t]*$\\|[ \t]*\\*/[ \t]*$\\|[ \t/*]*$")) - (chars-to-delete 0)) - (save-restriction - ;; Don't fill the comment together with the code following it. - ;; So temporarily exclude everything before the comment start, - ;; and everything after the line where the comment ends. - ;; If comment-start-place is non-nil, the comment starter is there. - ;; Otherwise, point is inside the comment. - (narrow-to-region (save-excursion - (if comment-start-place - (goto-char comment-start-place) - (search-backward "/*")) - ;; Protect text before the comment start - ;; by excluding it. Add spaces to bring back - ;; proper indentation of that point. - (let ((column (current-column))) - (prog1 (point) - (setq chars-to-delete column) - (insert-char ?\ column)))) - (save-excursion - (if comment-start-place - (goto-char (+ comment-start-place 2))) - (search-forward "*/" nil 'move) - (forward-line 1) - (point))) - (save-excursion - (goto-char (point-max)) - (forward-line -1) - ;; And comment terminator was on a separate line before, - ;; keep it that way. - ;; This also avoids another problem: - ;; if the fill-prefix ends in a *, it could eat up - ;; the * of the comment terminator. - (if (looking-at "[ \t]*\\*/") - (narrow-to-region (point-min) (point)))) - (fill-paragraph arg) - (save-excursion - ;; Delete the chars we inserted to avoid clobbering - ;; the stuff before the comment start. - (goto-char (point-min)) - (if (> chars-to-delete 0) - (delete-region (point) (+ (point) chars-to-delete))) - ;; Find the comment ender (should be on last line of buffer, - ;; given the narrowing) and don't leave it on its own line. - ;; Do this with a fill command, so as to preserve sentence - ;; boundaries. - (goto-char (point-max)) - (forward-line -1) - (search-forward "*/" nil 'move) - (beginning-of-line) - (if (looking-at "[ \t]*\\*/") - (let ((fill-column (+ fill-column 9999))) - (forward-line -1) - (fill-region-as-paragraph (point) (point-max))))))) - ;; Outside of comments: do ordinary filling. - (fill-paragraph arg))) - t)) - -(defun electric-c-brace (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos) - (if (and (not arg) - (eolp) - (or (save-excursion - (skip-chars-backward " \t") - (bolp)) - (if c-auto-newline (progn (c-indent-line) (newline) t) nil))) - (progn - (insert last-command-char) - (c-indent-line) - (if c-auto-newline - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (c-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun electric-c-sharp-sign (arg) - "Insert character and correct line's indentation." - (interactive "P") - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - (let ((c-auto-newline nil)) - (electric-c-terminator arg)) - (self-insert-command (prefix-numeric-value arg)))) - -(defun electric-c-semi (arg) - "Insert character and correct line's indentation." - (interactive "P") - (if c-auto-newline - (electric-c-terminator arg) - (self-insert-command (prefix-numeric-value arg)))) - -(defun electric-c-terminator (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos (end (point))) - (if (and (not arg) (eolp) - (not (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (or (= (following-char) ?#) - ;; Colon is special only after a label, or case .... - ;; So quickly rule out most other uses of colon - ;; and do no indentation for them. - (and (eq last-command-char ?:) - (not (looking-at c-switch-label-regexp)) - (save-excursion - (skip-chars-forward "a-zA-Z0-9_$") - (skip-chars-forward " \t") - (< (point) end))) - (progn - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) end))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) - (progn - (insert last-command-char) - (c-indent-line) - (and c-auto-newline - (not (c-inside-parens-p)) - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (c-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun c-inside-parens-p () - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (beginning-of-defun) (point))) - (goto-char (point-max)) - (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) - (error nil))) - -(defun c-indent-command (&optional whole-exp) - "Indent current line as C code, or in some cases insert a tab character. -If `c-tab-always-indent' is non-nil (the default), always indent current line. -Otherwise, indent the current line only if point is at the left margin or -in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, means indent rigidly all the -lines of the expression starting after point so that this line becomes -properly indented. The relative indentation among the lines of the -expression are preserved." - (interactive "P") - (if whole-exp - ;; If arg, always indent this line as C - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (c-indent-line)) - beg end) - (save-excursion - (if c-tab-always-indent - (beginning-of-line)) - ;; Find beginning of following line. - (save-excursion - (forward-line 1) (setq beg (point))) - ;; Find first beginning-of-sexp for sexp extending past this line. - (while (< (point) beg) - (forward-sexp 1) - (setq end (point)) - (skip-chars-forward " \t\n"))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not c-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (c-indent-line)))) - -(defun c-indent-line () - "Indent current line as C code. -Return the amount the indentation changed by." - (let ((indent (calculate-c-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - ((eq indent t) - (setq indent (calculate-c-indent-within-comment))) - ((looking-at "[ \t]*#") - (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((or (looking-at c-switch-label-regexp) - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":")))) - (setq indent (max 1 (+ indent c-label-offset)))) - ((and (looking-at "else\\b") - (not (looking-at "else\\s_"))) - (setq indent (save-excursion - (c-backward-to-start-of-if) - (current-indentation)))) - ((and (looking-at "}[ \t]*else\\b") - (not (looking-at "}[ \t]*else\\s_"))) - (setq indent (save-excursion - (forward-char) - (backward-sexp) - (c-backward-to-start-of-if) - (current-indentation)))) - ((and (looking-at "while\\b") - (not (looking-at "while\\s_")) - (save-excursion - (c-backward-to-start-of-do))) - ;; This is a `while' that ends a do-while. - (setq indent (save-excursion - (c-backward-to-start-of-do) - (current-indentation)))) - ((= (following-char) ?}) - (setq indent (- indent c-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent c-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun calculate-c-indent (&optional parse-start) - "Return appropriate indentation for current line as C code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - state - containing-sexp) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; return nil or t if should not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. May be data or function definition, - ;; or may be function argument declaration. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (goto-char indent-point) - (skip-chars-forward " \t") - (if (= (following-char) ?{) - 0 ; Unless it starts a function body - (c-backward-to-noncomment (or parse-start (point-min))) - ;; Look at previous line that's at column 0 - ;; to determine whether we are in top-level decls - ;; or function's arg decls. Set basic-indent accordingly. - (let ((basic-indent - (save-excursion - (re-search-backward "^[^ \^L\t\n#]" nil 'move) - (let (comment lim) - ;; Recognize the DEFUN macro in Emacs. - (if (save-excursion - ;; Move down to the (putative) argnames line. - (while (and (not (eobp)) - (not (looking-at " *[({}#/]"))) - (forward-line 1)) - ;; Go back to the DEFUN, if it is one. - (condition-case nil - (backward-sexp 1) - (error)) - (beginning-of-line) - (looking-at "DEFUN\\b")) - c-argdecl-indent - (if (and (looking-at "\\sw\\|\\s_") - ;; This is careful to stop at the first - ;; paren if we have - ;; int foo Proto ((int, int)); - (looking-at "[^\"\n=(]*(") - (progn - (goto-char (1- (match-end 0))) - ;; Skip any number of paren-groups. - ;; Consider typedef int (*fcn) (int); - (while (= (following-char) ?\() - (setq lim (point)) - (condition-case nil - (forward-sexp 1) - (error)) - (skip-chars-forward " \t\f")) - ;; Have we reached something - ;; that shows this isn't a function - ;; definition? - (and (< (point) indent-point) - (not (memq (following-char) - '(?\, ?\;))))) - ;; Make sure the "function decl" we found - ;; is not inside a comment. - (progn - ;; Move back to the `(' starting arglist - (goto-char lim) - (beginning-of-line) - (while (and (not comment) - (search-forward "/*" lim t)) - (setq comment - (not (search-forward "*/" lim t)))) - (not comment))) - c-argdecl-indent 0)))))) - basic-indent))) - -;; ;; Now add a little if this is a continuation line. -;; (+ basic-indent (if (or (bobp) -;; (memq (preceding-char) '(?\) ?\; ?\})) -;; ;; Line with zero indentation -;; ;; is probably the return-type -;; ;; of a function definition, -;; ;; so following line is function name. -;; (= (current-indentation) 0)) -;; 0 c-continued-statement-offset)) - - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (goto-char indent-point) - (c-backward-to-noncomment containing-sexp) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (or (eq (char-after (- (point) 2)) ?\') - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_))))) - (if (eq (preceding-char) ?\,) - (progn (forward-char -1) - (c-backward-to-start-of-continued-exp containing-sexp))) - (beginning-of-line) - (c-backward-to-noncomment containing-sexp)) - ;; Check for a preprocessor statement or its continuation lines. - ;; Move back to end of previous non-preprocessor line, - ;; or possibly beginning of buffer. - (let ((found (point)) stop) - (while (not stop) - (beginning-of-line) - (cond ((bobp) - (setq found (point) - stop t)) - ((save-excursion (forward-char -1) - (= (preceding-char) ?\\)) - (forward-char -1)) - ;; This line is not preceded by a backslash. - ;; So either it starts a preprocessor command - ;; or any following continuation lines - ;; should not be skipped. - ((= (following-char) ?#) - (forward-char -1) - (setq found (point))) - (t (setq stop t)))) - (goto-char found)) - ;; Now we get the answer. - (if (and (not (memq (preceding-char) '(0 ?\, ?\; ?\} ?\{))) - ;; But don't treat a line with a close-brace - ;; as a continuation. It is probably the - ;; end of an enum type declaration. - (save-excursion - (goto-char indent-point) - (skip-chars-forward " \t") - (not (= (following-char) ?})))) - ;; This line is continuation of preceding line's statement; - ;; indent c-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (c-backward-to-start-of-continued-exp containing-sexp) - (+ c-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (skip-chars-forward " \t") - (eq (following-char) ?{)) - c-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - (let ((colon-line-end 0)) - (while (progn (skip-chars-forward " \t\n") - (looking-at "#\\|/\\*\\|case[ \t\n'/(].*:\\|[a-zA-Z0-9_$]*:")) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - (forward-line 1)) - ((= (following-char) ?\/) - (forward-char 2) - (search-forward "*/" nil 'move)) - ;; case or label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (- - (if (> colon-line-end (point)) - (- (current-indentation) c-label-offset) - (current-column)) - ;; If prev stmt starts with open-brace, that - ;; open brace was offset by c-brace-offset. - ;; Compensate to get the column where - ;; an ordinary statement would start. - (if (= (following-char) ?\{) c-brace-offset 0))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - (calculate-c-indent-after-brace)))))))) - -(defun calculate-c-indent-after-brace () - "Return the proper C indent for the first line after an open-brace. -This function is called with point before the brace." - ;; For open brace in column zero, don't let statement - ;; start there too. If c-indent-level is zero, - ;; use c-brace-offset + c-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in c-brace-imaginary-offset. - (+ (if (and (bolp) (zerop c-indent-level)) - (+ c-brace-offset c-continued-statement-offset) - c-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the c-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 c-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))) - -(defun calculate-c-indent-within-comment (&optional after-star) - "Return the indentation amount for line inside a block comment. -Optional arg AFTER-STAR means, if lines in the comment have a leading star, -return the indentation of the text that would follow this star." - (let (end star-start) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (setq star-start (= (following-char) ?\*)) - (skip-chars-backward " \t\n") - (setq end (point)) - (beginning-of-line) - (skip-chars-forward " \t") - (if after-star - (and (looking-at "\\*") - (re-search-forward "\\*[ \t]*"))) - (and (re-search-forward "/\\*[ \t]*" end t) - star-start - (not after-star) - (goto-char (1+ (match-beginning 0)))) - (if (and (looking-at "[ \t]*$") (= (preceding-char) ?\*)) - (1+ (current-column)) - (current-column))))) - - -(defun c-backward-to-noncomment (lim) - (let (opoint stop) - (while (not stop) - (skip-chars-backward " \t\n\f" lim) - (setq opoint (point)) - (if (and (>= (point) (+ 2 lim)) - (save-excursion - (forward-char -2) - (looking-at "\\*/"))) - (search-backward "/*" lim 'move) - (setq stop (or (<= (point) lim) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (not (looking-at "#"))))) - (or stop (beginning-of-line)))))) - -(defun c-backward-to-start-of-continued-exp (lim) - (if (memq (preceding-char) '(?\) ?\")) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t")) - -(defun c-backward-to-start-of-if (&optional limit) - "Move to the start of the last \"unbalanced\" `if'." - (or limit (setq limit (save-excursion (beginning-of-defun) (point)))) - (let ((if-level 1) - (case-fold-search nil)) - (while (and (not (bobp)) (not (zerop if-level))) - (backward-sexp 1) - (cond ((and (looking-at "else\\b") - (not (looking-at "else\\s_"))) - (setq if-level (1+ if-level))) - ((and (looking-at "if\\b") - (not (looking-at "if\\s_"))) - (setq if-level (1- if-level))) - ((< (point) limit) - (setq if-level 0) - (goto-char limit)))))) - -(defun c-backward-to-start-of-do (&optional limit) - "If point follows a `do' statement, move to beginning of it and return t. -Otherwise return nil and don't move point." - (or limit (setq limit (save-excursion (beginning-of-defun) (point)))) - (let ((first t) - (startpos (point)) - (done nil)) - (while (not done) - (let ((next-start (point))) - (condition-case nil - ;; Move back one token or one brace or paren group. - (backward-sexp 1) - ;; If we find an open-brace, we lose. - (error (setq done 'fail))) - (if done - nil - ;; If we reached a `do', we win. - (if (looking-at "do\\b") - (setq done 'succeed) - ;; Otherwise, if we skipped a semicolon, we lose. - ;; (Exception: we can skip one semicolon before getting - ;; to a the last token of the statement, unless that token - ;; is a close brace.) - (if (save-excursion - (forward-sexp 1) - (or (and (not first) (= (preceding-char) ?})) - (search-forward ";" next-start t - (if (and first - (/= (preceding-char) ?})) - 2 1)))) - (setq done 'fail) - (setq first nil) - ;; If we go too far back in the buffer, we lose. - (if (< (point) limit) - (setq done 'fail))))))) - (if (eq done 'succeed) - t - (goto-char startpos) - nil))) - -(defun c-beginning-of-statement (count) - "Go to the beginning of the innermost C statement. -With prefix arg, go back N - 1 statements. If already at the beginning of a -statement then go to the beginning of the preceding one. -If within a string or comment, or next to a comment (only whitespace between), -move by sentences instead of statements." - (interactive "p") - (let ((here (point)) state) - (save-excursion - (beginning-of-defun) - (setq state (parse-partial-sexp (point) here nil nil))) - (if (or (nth 3 state) (nth 4 state) - (looking-at (concat "[ \t]*" comment-start-skip)) - (save-excursion (skip-chars-backward " \t") - (goto-char (- (point) 2)) - (looking-at "\\*/"))) - (forward-sentence (- count)) - (while (> count 0) - (c-beginning-of-statement-1) - (setq count (1- count))) - (while (< count 0) - (c-end-of-statement-1) - (setq count (1+ count)))))) - -(defun c-end-of-statement (count) - "Go to the end of the innermost C statement. -With prefix arg, go forward N - 1 statements. -Move forward to end of the next statement if already at end. -If within a string or comment, move by sentences instead of statements." - (interactive "p") - (c-beginning-of-statement (- count))) - -(defun c-beginning-of-statement-1 () - (let ((last-begin (point)) - (first t)) - (condition-case () - (progn - (while (and (not (bobp)) - (progn - (backward-sexp 1) - (or first - (not (re-search-forward "[;{}]" last-begin t))))) - (setq last-begin (point) first nil)) - (goto-char last-begin)) - (error (if first (backward-up-list 1) (goto-char last-begin)))))) - -(defun c-end-of-statement-1 () - (condition-case () - (progn - (while (and (not (eobp)) - (let ((beg (point))) - (forward-sexp 1) - (let ((end (point))) - (save-excursion - (goto-char beg) - (not (re-search-forward "[;{}]" end t))))))) - (re-search-backward "[;}]") - (forward-char 1)) - (error - (let ((beg (point))) - (backward-up-list -1) - (let ((end (point))) - (goto-char beg) - (search-forward ";" end 'move)))))) - -(defun mark-c-function () - "Put mark at end of C function, point at beginning." - (interactive) - (push-mark (point)) - (end-of-defun) - (push-mark (point) nil t) - (beginning-of-defun) - (backward-paragraph)) - -;; Idea of ENDPOS is, indent each line, stopping when -;; ENDPOS is encountered. But it's too much of a pain to make that work. -(defun indent-c-exp (&optional endpos) - "Indent each line of the C grouping following point." - (interactive) - (let* ((indent-stack (list nil)) - (opoint (point)) ;; May be altered below. - (contain-stack - (list (if endpos - (let (funbeg) - ;; Find previous fcn-start. - (save-excursion (forward-char 1) - (beginning-of-defun) - (setq funbeg (point))) - (setq opoint funbeg) - ;; Try to find containing open, - ;; but don't scan past that fcn-start. - (save-restriction - (narrow-to-region funbeg (point)) - (condition-case nil - (save-excursion - (backward-up-list 1) - (point)) - ;; We gave up: must be between fcns. - ;; Set opoint to beg of prev fcn - ;; since otherwise calculate-c-indent - ;; will get wrong answers. - (error (setq opoint funbeg) - (point))))) - (point)))) - (case-fold-search nil) - restart outer-loop-done inner-loop-done state ostate - this-indent last-sexp - at-else at-brace at-while - last-depth this-point - (next-depth 0)) - ;; If the braces don't match, get an error right away. - (save-excursion - (forward-sexp 1)) - ;; Realign the comment on the first line, even though we don't reindent it. - (save-excursion - (let ((beg (point))) - (and (re-search-forward - comment-start-skip - (save-excursion (end-of-line) (point)) t) - ;; Make sure this isn't a comment alone on a line - ;; (which should be indented like code instead). - (save-excursion - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (not (bolp))) - ;; Make sure the comment starter we found - ;; is not actually in a string or quoted. - (let ((new-state - (parse-partial-sexp beg (point) - nil nil state))) - (and (not (nth 3 new-state)) (not (nth 5 new-state)))) - (progn (indent-for-comment) (beginning-of-line))))) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) - (if endpos (< (point) endpos) - (not outer-loop-done))) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq inner-loop-done nil) - (while (and (not inner-loop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - ;; If this line started within a comment, indent it as such. - (if (or (nth 4 ostate) (nth 7 ostate)) - (c-indent-line)) - ;; If it ends outside of comments or strings, exit the inner loop. - ;; Otherwise move on to next line. - (if (or (nth 3 state) (nth 4 state) (nth 7 state)) - (forward-line 1) - (setq inner-loop-done t))) - (and endpos - (while (< next-depth 0) - (setq indent-stack (append indent-stack (list nil))) - (setq contain-stack (append contain-stack (list nil))) - (setq next-depth (1+ next-depth)) - (setq last-depth (1+ last-depth)) - (setcar (nthcdr 6 state) (1+ (nth 6 state))))) - (setq outer-loop-done (and (not endpos) (<= next-depth 0))) - (if outer-loop-done - nil - ;; If this line had ..))) (((.. in it, pop out of the levels - ;; that ended anywhere in this line, even if the final depth - ;; doesn't indicate that they ended. - (while (> last-depth (nth 6 state)) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (if (/= last-depth next-depth) - (setq last-sexp nil)) - ;; Add levels for any parens that were started in this line. - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack (or (car (cdr state)) - (save-excursion (forward-sexp -1) - (point))))) - (forward-line 1) - (skip-chars-forward " \t") - ;; Don't really reindent if the line is just whitespace, - ;; or if it is past the endpos. - ;; (The exit test in the outer while - ;; does not exit until we have passed the first line - ;; past the region.) - (if (or (eolp) (and endpos (>= (point) endpos))) - nil - ;; Is this line in a new nesting level? - ;; In other words, is this the first line that - ;; starts in the new level? - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - nil - ;; Yes. - ;; Compute the standard indent for this level. - (let (val) - (if (= (char-after (car contain-stack)) ?{) - (save-excursion - (goto-char (car contain-stack)) - (setq val (calculate-c-indent-after-brace))) - (setq val (calculate-c-indent - (if (car indent-stack) - (- (car indent-stack)) - opoint)))) - ;; t means we are in a block comment and should - ;; calculate accordingly. - (if (eq val t) - (setq val (calculate-c-indent-within-comment))) - (setcar indent-stack val))) - ;; Adjust indent of this individual line - ;; based on its predecessor. - ;; Handle continuation lines, if, else, while, and so on. - (if (/= (char-after (car contain-stack)) ?{) - (setq this-indent (car indent-stack)) - ;; Line is at statement level. - ;; Is it a new statement? Is it an else? - ;; Find last non-comment character before this line - (save-excursion - (setq this-point (point)) - (setq at-else (and (looking-at "else\\b") - (not (looking-at "else\\s_")))) - (setq at-brace (= (following-char) ?{)) - (setq at-while (and (looking-at "while\\b") - (not (looking-at "while\\s_")))) - (if (= (following-char) ?}) - (setq this-indent (car indent-stack)) - (c-backward-to-noncomment opoint) - (if (not (memq (preceding-char) '(0 ?\, ?\; ?} ?: ?{))) - ;; Preceding line did not end in comma or semi; - ;; indent this line c-continued-statement-offset - ;; more than previous. - (progn - (c-backward-to-start-of-continued-exp (car contain-stack)) - (setq this-indent - (+ c-continued-statement-offset (current-column) - (if at-brace c-continued-brace-offset 0)))) - ;; Preceding line ended in comma or semi; - ;; use the standard indent for this level. - (cond (at-else (progn (c-backward-to-start-of-if opoint) - (setq this-indent - (current-indentation)))) - ((and at-while (c-backward-to-start-of-do opoint)) - (setq this-indent (current-indentation))) - ((eq (preceding-char) ?\,) - (goto-char this-point) - (setq this-indent (calculate-c-indent))) - (t (setq this-indent (car indent-stack)))))))) - ;; Adjust line indentation according to its contents - (if (or (looking-at c-switch-label-regexp) - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":")))) - (setq this-indent (max 1 (+ this-indent c-label-offset)))) - (if (= (following-char) ?}) - (setq this-indent (- this-indent c-indent-level))) - (if (= (following-char) ?{) - ;; Don't move an open-brace in column 0. - ;; This is good when constructs such as - ;; `extern "C" {' surround a function definition - ;; that should be indented as usual. - ;; It is also good for nested functions. - ;; It is bad when an open-brace is indented at column 0 - ;; and you want to fix that, but we can't win 'em all. - (if (zerop (current-column)) - (setq this-indent 0) - (setq this-indent (+ this-indent c-brace-offset)))) - ;; Don't leave indentation in empty lines. - (if (eolp) (setq this-indent 0)) - ;; Put chosen indentation into effect. - (or (= (current-column) this-indent) - (= (following-char) ?\#) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to this-indent))) - ;; Indent any comment following the text. - (or (looking-at comment-start-skip) - (save-excursion - (let ((beg (point))) - (and (re-search-forward - comment-start-skip - (save-excursion (end-of-line) (point)) t) - ;; Make sure the comment starter we found - ;; is not actually in a string or quoted. - (let ((new-state - (parse-partial-sexp beg (point) - nil nil state))) - (and (not (nth 3 new-state)) (not (nth 5 new-state)))) - (indent-for-comment))))))))))) - -;; Look at all comment-start strings in the current line after point. -;; Return t if one of them starts a real comment. -;; This is not used yet, because indent-for-comment -;; isn't smart enough to handle the cases this can find. -(defun indent-c-find-real-comment () - (let (win) - (while (and (not win) - (re-search-forward comment-start-skip - (save-excursion (end-of-line) (point)) - t)) - ;; Make sure the comment start is not quoted. - (let ((state-1 - (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point) nil nil state))) - (setq win (and (null (nth 3 state-1)) (null (nth 5 state-1)))))) - win)) - -;; Indent every line whose first char is between START and END inclusive. -(defun c-indent-region (start end) - (save-excursion - (goto-char start) - ;; Advance to first nonblank line. - (skip-chars-forward " \t\n") - (beginning-of-line) - (let ((endmark (copy-marker end)) - (c-tab-always-indent t)) - (while (and (bolp) (not (eobp)) (< (point) endmark)) - ;; Indent one line as with TAB. - (let ((shift-amt (c-indent-line)) - nextline sexpbeg sexpend) - (if (save-excursion (beginning-of-line) (looking-at "[ \t]*#")) - (forward-line 1) - (save-excursion - ;; Find beginning of following line. - (save-excursion - (forward-line 1) (setq nextline (point))) - ;; Find first beginning-of-sexp for sexp extending past this line. - (beginning-of-line) - (while (< (point) nextline) - (condition-case nil - (progn - (forward-sexp 1) - (setq sexpend (point-marker))) - (error (setq sexpend nil) - (goto-char nextline))) - (skip-chars-forward " \t\n")) - (if sexpend - (progn - ;; Make sure the sexp we found really starts on the - ;; current line and extends past it. - (goto-char sexpend) - (backward-sexp 1) - (setq sexpbeg (point))))) - ;; If that sexp ends within the region, - ;; indent it all at once, fast. - (if (and sexpend (> sexpend nextline) (<= sexpend endmark) - (< sexpbeg nextline)) - (progn - (indent-c-exp) - (goto-char sexpend))) - ;; Move to following line and try again. - (and sexpend (set-marker sexpend nil)) - (forward-line 1)))) - (set-marker endmark nil)))) - -(defun set-c-style (style &optional global) - "Set C-mode variables to use one of several different indentation styles. -The arguments are a string representing the desired style -and a flag which, if non-nil, means to set the style globally. -\(Interactively, the flag comes from the prefix argument.) -Available styles are GNU, K&R, BSD and Whitesmith." - (interactive (list (let ((completion-ignore-case t)) - (completing-read "Use which C indentation style? " - c-style-alist nil t)) - current-prefix-arg)) - (let ((vars (cdr (assoc style c-style-alist)))) - (or vars - (error "Invalid C indentation style `%s'" style)) - (while vars - (or global - (make-local-variable (car (car vars)))) - (set (car (car vars)) (cdr (car vars))) - (setq vars (cdr vars))))) - -;;; This page handles insertion and removal of backslashes for C macros. - -(defvar c-backslash-column 48 - "*Minimum column for end-of-line backslashes of macro definitions.") - -(defun c-backslash-region (from to delete-flag) - "Insert, align, or delete end-of-line backslashes on the lines in the region. -With no argument, inserts backslashes and aligns existing backslashes. -With an argument, deletes the backslashes. - -This function does not modify the last line of the region if the region ends -right at the start of the following line; it does not modify blank lines -at the start of the region. So you can put the region around an entire macro -definition and conveniently use this command." - (interactive "r\nP") - (save-excursion - (goto-char from) - (let ((column c-backslash-column) - (endmark (make-marker))) - (move-marker endmark to) - ;; Compute the smallest column number past the ends of all the lines. - (if (not delete-flag) - (while (< (point) to) - (end-of-line) - (if (= (preceding-char) ?\\) - (progn (forward-char -1) - (skip-chars-backward " \t"))) - (setq column (max column (1+ (current-column)))) - (forward-line 1))) - ;; Adjust upward to a tab column, if that doesn't push past the margin. - (if (> (% column tab-width) 0) - (let ((adjusted (* (/ (+ column tab-width -1) tab-width) tab-width))) - (if (< adjusted (window-width)) - (setq column adjusted)))) - ;; Don't modify blank lines at start of region. - (goto-char from) - (while (and (< (point) endmark) (eolp)) - (forward-line 1)) - ;; Add or remove backslashes on all the lines. - (while (and (< (point) endmark) - ;; Don't backslashify the last line - ;; if the region ends right at the start of the next line. - (save-excursion - (forward-line 1) - (< (point) endmark))) - (if (not delete-flag) - (c-append-backslash column) - (c-delete-backslash)) - (forward-line 1)) - (move-marker endmark nil)))) - -(defun c-append-backslash (column) - (end-of-line) - ;; Note that "\\\\" is needed to get one backslash. - (if (= (preceding-char) ?\\) - (progn (forward-char -1) - (delete-horizontal-space) - (indent-to column)) - (indent-to column) - (insert "\\"))) - -(defun c-delete-backslash () - (end-of-line) - (or (bolp) - (progn - (forward-char -1) - (if (looking-at "\\\\") - (delete-region (1+ (point)) - (progn (skip-chars-backward " \t") (point))))))) - -(defun c-up-conditional (count) - "Move back to the containing preprocessor conditional, leaving mark behind. -A prefix argument acts as a repeat count. With a negative argument, -move forward to the end of the containing preprocessor conditional. -When going backwards, `#elif' is treated like `#else' followed by `#if'. -When going forwards, `#elif' is ignored." - (interactive "p") - (c-forward-conditional (- count) t)) - -(defun c-backward-conditional (count &optional up-flag) - "Move back across a preprocessor conditional, leaving mark behind. -A prefix argument acts as a repeat count. With a negative argument, -move forward across a preprocessor conditional." - (interactive "p") - (c-forward-conditional (- count) up-flag)) - -(defun c-forward-conditional (count &optional up-flag) - "Move forward across a preprocessor conditional, leaving mark behind. -A prefix argument acts as a repeat count. With a negative argument, -move backward across a preprocessor conditional." - (interactive "p") - (let* ((forward (> count 0)) - (increment (if forward -1 1)) - (search-function (if forward 're-search-forward 're-search-backward)) - (opoint (point)) - (new)) - (save-excursion - (while (/= count 0) - (let ((depth (if up-flag 0 -1)) found) - (save-excursion - ;; Find the "next" significant line in the proper direction. - (while (and (not found) - ;; Rather than searching for a # sign that comes - ;; at the beginning of a line aside from whitespace, - ;; search first for a string starting with # sign. - ;; Then verify what precedes it. - ;; This is faster on account of the fastmap feature of - ;; the regexp matcher. - (funcall search-function - "#[ \t]*\\(if\\|elif\\|endif\\)" - nil t)) - (beginning-of-line) - ;; Now verify it is really a preproc line. - (if (looking-at "^[ \t]*#[ \t]*\\(if\\|elif\\|endif\\)") - (let ((prev depth)) - ;; Update depth according to what we found. - (beginning-of-line) - (cond ((looking-at "[ \t]*#[ \t]*endif") - (setq depth (+ depth increment))) - ((looking-at "[ \t]*#[ \t]*elif") - (if (and forward (= depth 0)) - (setq found (point)))) - (t (setq depth (- depth increment)))) - ;; If we are trying to move across, and we find - ;; an end before we find a beginning, get an error. - (if (and (< prev 0) (< depth prev)) - (error (if forward - "No following conditional at this level" - "No previous conditional at this level"))) - ;; When searching forward, start from next line - ;; so that we don't find the same line again. - (if forward (forward-line 1)) - ;; If this line exits a level of conditional, exit inner loop. - (if (< depth 0) - (setq found (point)))) - ;; If the line is not really a conditional, skip past it. - (if forward (end-of-line))))) - (or found - (error "No containing preprocessor conditional")) - (goto-char (setq new found))) - (setq count (+ count increment)))) - (push-mark) - (goto-char new))) - -(provide 'c-mode) - -;;; c-mode.el ends here diff --git a/lisp/progmodes/cmacexp.el b/lisp/progmodes/cmacexp.el deleted file mode 100644 index f030ade3f67..00000000000 --- a/lisp/progmodes/cmacexp.el +++ /dev/null @@ -1,371 +0,0 @@ -;;; cmacexp.el --- expand C macros in a region - -;; Copyright (C) 1992, 1994, 1996 Free Software Foundation, Inc. - -;; Author: Francesco Potorti` <pot@cnuce.cnr.it> -;; Version: $Id: cmacexp.el,v 1.25 1996/05/21 15:42:13 kwzh Exp rms $ -;; Adapted-By: ESR -;; Keywords: c - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; USAGE ============================================================= - -;; In C mode C-C C-e is bound to c-macro-expand. The result of the -;; expansion is put in a separate buffer. A user option allows the -;; window displaying the buffer to be optimally sized. -;; -;; When called with a C-u prefix, c-macro-expand replaces the selected -;; region with the expansion. Both the preprocessor name and the -;; initial flag can be set by the user. If c-macro-prompt-flag is set -;; to a non-nil value the user is offered to change the options to the -;; preprocessor each time c-macro-expand is invoked. Preprocessor -;; arguments default to the last ones entered. If c-macro-prompt-flag -;; is nil, one must use M-x set-variable to set a different value for -;; c-macro-cppflags. - -;; A c-macro-expansion function is provided for non-interactive use. - -;; INSTALLATION ====================================================== - -;; Put the following in your ~/.emacs file. - -;; If you want the *Macroexpansion* window to be not higher than -;; necessary: -;;(setq c-macro-shrink-window-flag t) -;; -;; If you use a preprocessor other than /lib/cpp (be careful to set a -;; -C option or equivalent in order to make the preprocessor not to -;; strip the comments): -;;(setq c-macro-preprocessor "gpp -C") -;; -;; If you often use a particular set of flags: -;;(setq c-macro-cppflags "-I /usr/include/local -DDEBUG" -;; -;; If you want the "Preprocessor arguments: " prompt: -;;(setq c-macro-prompt-flag t) - -;; BUG REPORTS ======================================================= - -;; Please report bugs, suggestions, complaints and so on to -;; pot@cnuce.cnr.it (Francesco Potorti`). - -;; IMPROVEMENTS OVER emacs 18.xx cmacexp.el ========================== - -;; - A lot of user and programmer visible changes. See above. -;; - #line directives are inserted, so __LINE__ and __FILE__ are -;; correctly expanded. Works even with START inside a string, a -;; comment or a region #ifdef'd away by cpp. cpp is invoked with -C, -;; making comments visible in the expansion. -;; - All work is done in core memory, no need for temporary files. - -;; ACKNOWLEDGEMENTS ================================================== - -;; A lot of thanks to Don Maszle who did a great work of testing, bug -;; reporting and suggestion of new features. This work has been -;; partially inspired by Don Maszle and Jonathan Segal's. - -;; BUGS ============================================================== - -;; If the start point of the region is inside a macro definition the -;; macro expansion is often inaccurate. - - -(require 'cc-mode) - -(provide 'cmacexp) - -(defvar c-macro-shrink-window-flag nil - "*Non-nil means shrink the *Macroexpansion* window to fit its contents.") - -(defvar c-macro-prompt-flag nil - "*Non-nil makes `c-macro-expand' prompt for preprocessor arguments.") - -(defvar c-macro-preprocessor - ;; Cannot rely on standard directory on MS-DOS to find CPP. - (cond ((eq system-type 'ms-dos) "cpp -C") - ;; Solaris has it in an unusual place. - ((and (string-match "^[^-]*-[^-]*-\\(solaris\\|sunos5\\)" - system-configuration) - (file-exists-p "/opt/SUNWspro/SC3.0.1/bin/acomp")) - "/opt/SUNWspro/SC3.0.1/bin/acomp -C -E") - (t "/lib/cpp -C")) - "The preprocessor used by the cmacexp package. - -If you change this, be sure to preserve the `-C' (don't strip comments) -option, or to set an equivalent one.") - -(defvar c-macro-cppflags "" - "*Preprocessor flags used by `c-macro-expand'.") - -(defconst c-macro-buffer-name "*Macroexpansion*") - -(defun c-macro-expand (start end subst) - "Expand C macros in the region, using the C preprocessor. -Normally display output in temp buffer, but -prefix arg means replace the region with it. - -`c-macro-preprocessor' specifies the preprocessor to use. -Prompt for arguments to the preprocessor \(e.g. `-DDEBUG -I ./include') -if the user option `c-macro-prompt-flag' is non-nil. - -Noninteractive args are START, END, SUBST. -For use inside Lisp programs, see also `c-macro-expansion'." - - (interactive "r\nP") - (let ((inbuf (current-buffer)) - (displaybuf (if subst - (get-buffer c-macro-buffer-name) - (get-buffer-create c-macro-buffer-name))) - (expansion "")) - ;; Build the command string. - (if c-macro-prompt-flag - (setq c-macro-cppflags - (read-string "Preprocessor arguments: " - c-macro-cppflags))) - ;; Decide where to display output. - (if (and subst - (and buffer-read-only (not inhibit-read-only)) - (not (eq inbuf displaybuf))) - (progn - (message - "Buffer is read only: displaying expansion in alternate window") - (sit-for 2) - (setq subst nil) - (or displaybuf - (setq displaybuf (get-buffer-create c-macro-buffer-name))))) - ;; Expand the macro and output it. - (setq expansion (c-macro-expansion start end - (concat c-macro-preprocessor " " - c-macro-cppflags) t)) - (if subst - (let ((exchange (= (point) start))) - (delete-region start end) - (insert expansion) - (if exchange - (exchange-point-and-mark))) - (set-buffer displaybuf) - (setq buffer-read-only nil) - (buffer-disable-undo displaybuf) - (erase-buffer) - (insert expansion) - (set-buffer-modified-p nil) - (if (string= "" expansion) - (message "Null expansion") - (c-macro-display-buffer)) - (setq buffer-read-only t) - (setq buffer-auto-save-file-name nil) - (bury-buffer displaybuf)))) - - -;; Display the current buffer in a window which is either just large -;; enough to contain the entire buffer, or half the size of the -;; screen, whichever is smaller. Do not select the new -;; window. -;; -;; Several factors influence window resizing so that the window is -;; sized optimally if it is created anew, and so that it is messed -;; with minimally if it has been created by the user. If the window -;; chosen for display exists already but contains something else, the -;; window is not re-sized. If the window already contains the current -;; buffer, it is never shrunk, but possibly expanded. Finally, if the -;; variable c-macro-shrink-window-flag is nil the window size is *never* -;; changed. -(defun c-macro-display-buffer () - (goto-char (point-min)) - (c-mode) - (let ((oldwinheight (window-height)) - (alreadythere ;the window was already there - (get-buffer-window (current-buffer))) - (popped nil)) ;the window popped changing the layout - (or alreadythere - (progn - (display-buffer (current-buffer) t) - (setq popped (/= oldwinheight (window-height))))) - (if (and c-macro-shrink-window-flag ;user wants fancy shrinking :\) - (or alreadythere popped)) - ;; Enlarge up to half screen, or shrink properly. - (let ((oldwin (selected-window)) - (minheight 0) - (maxheight 0)) - (save-excursion - (select-window (get-buffer-window (current-buffer))) - (setq minheight (if alreadythere - (window-height) - window-min-height)) - (setq maxheight (/ (frame-height) 2)) - (enlarge-window (- (min maxheight - (max minheight - (+ 2 (vertical-motion (point-max))))) - (window-height))) - (goto-char (point-min)) - (select-window oldwin)))))) - - -(defun c-macro-expansion (start end cppcommand &optional display) - "Run a preprocessor on region and return the output as a string. -Expand the region between START and END in the current buffer using -the shell command CPPCOMMAND (e.g. \"/lib/cpp -C -DDEBUG\"). -Be sure to use a -C (don't strip comments) or equivalent option. -Optional arg DISPLAY non-nil means show messages in the echo area." - -;; Copy the current buffer's contents to a temporary hidden buffer. -;; Delete from END to end of buffer. Insert a preprocessor #line -;; directive at START and after each #endif following START that are -;; not inside a comment or a string. Put all the strings thus -;; inserted (without the "line" substring) in a list named linelist. -;; If START is inside a comment, prepend "*/" and append "/*" to the -;; #line directive. If inside a string, prepend and append "\"". -;; Preprocess the buffer contents, then look for all the lines stored -;; in linelist starting from end of buffer. The last line so found is -;; where START was, so return the substring from point to end of -;; buffer. - (let ((inbuf (current-buffer)) - (outbuf (get-buffer-create " *C Macro Expansion*")) - (filename (if (and buffer-file-name - (string-match (regexp-quote default-directory) - buffer-file-name)) - (substring buffer-file-name (match-end 0)) - (buffer-name))) - (mymsg (format "Invoking %s%s%s on region..." - c-macro-preprocessor - (if (string= "" c-macro-cppflags) "" " ") - c-macro-cppflags)) - (uniquestring "??? !!! ??? start of c-macro expansion ??? !!! ???") - (startlinenum 0) - (linenum 0) - (startstat ()) - (startmarker "") - (exit-status 0) - (tempname (make-temp-name (concat - (or (getenv "TMPDIR") (getenv "TEMP") - (getenv "TMP") "/tmp") - "/")))) - (unwind-protect - (save-excursion - (save-restriction - (widen) - (let ((in-syntax-table (syntax-table))) - (set-buffer outbuf) - (setq buffer-read-only nil) - (erase-buffer) - (set-syntax-table in-syntax-table)) - (insert-buffer-substring inbuf 1 end)) - - ;; We have copied inbuf to outbuf. Point is at end of - ;; outbuf. Inset a newline at the end, so cpp can correctly - ;; parse a token ending at END. - (insert "\n") - - ;; Save sexp status and line number at START. - (setq startstat (parse-partial-sexp 1 start)) - (setq startlinenum (+ (count-lines 1 (point)) - (if (bolp) 1 0))) - - ;; Now we insert the #line directives after all #endif or - ;; #else following START going backward, so the lines we - ;; insert don't change the line numbers. - ;(switch-to-buffer outbuf) (debug) ;debugging instructions - (goto-char (point-max)) - (while (re-search-backward "\n#\\(endif\\|else\\)\\>" start 'move) - (if (equal (nthcdr 3 (parse-partial-sexp start (point) - nil nil startstat)) - '(nil nil nil 0 nil)) ;neither in string nor in - ;comment nor after quote - (progn - (goto-char (match-end 0)) - (setq linenum (+ startlinenum - (count-lines start (point)))) - (insert (format "\n#line %d \"%s\"\n" linenum filename)) - (goto-char (match-beginning 0))))) - - ;; Now we are at START. Insert the first #line directive. - ;; This must work even inside a string or comment, or after a - ;; quote. - (let* ((startinstring (nth 3 startstat)) - (startincomment (nth 4 startstat)) - (startafterquote (nth 5 startstat)) - (startinbcomment (nth 7 startstat))) - (insert (if startafterquote " " "") - (cond (startinstring - (char-to-string startinstring)) - (startincomment "*/") - ("")) - (setq startmarker - (concat "\n" uniquestring - (cond (startinstring - (char-to-string startinstring)) - (startincomment "/*") - (startinbcomment "//")) - (if startafterquote "\\"))) - (format "\n#line %d \"%s\"\n" startlinenum filename))) - - ;; Call the preprocessor. - (if display (message mymsg)) - (setq exit-status - (call-process-region 1 (point-max) - shell-file-name - t (list t tempname) nil "-c" - cppcommand)) - (if display (message (concat mymsg "done"))) - (if (= (buffer-size) 0) - ;; Empty output is normal after a fatal error. - (insert "\nPreprocessor produced no output\n") - ;; Find and delete the mark of the start of the expansion. - ;; Look for `# nn "file.c"' lines and delete them. - (goto-char (point-min)) - (search-forward startmarker) - (delete-region 1 (point))) - (while (re-search-forward (concat "^# [0-9]+ \"" - (regexp-quote filename) - "\"") nil t) - (beginning-of-line) - (let ((beg (point))) - (forward-line 1) - (delete-region beg (point)))) - - ;; If CPP got errors, show them at the beginning. - ;; MS-DOS shells don't return the exit code of their children. - ;; Look at the size of the error message file instead, but - ;; don't punish those MS-DOS users who have a shell that does - ;; return an error code. - (or (and (or (not (boundp 'msdos-shells)) - (not (member (file-name-nondirectory shell-file-name) - msdos-shells))) - (eq exit-status 0)) - (zerop (nth 7 (file-attributes (expand-file-name tempname)))) - (progn - (goto-char (point-min)) - ;; Put the messages inside a comment, so they won't get in - ;; the way of font-lock, highlighting etc. - (insert - (format "/* Preprocessor terminated with status %s\n\n Messages from `%s\':\n\n" - exit-status cppcommand)) - (goto-char (+ (point) - (nth 1 (insert-file-contents tempname)))) - (insert "\n\n*/\n"))) - (delete-file tempname) - - ;; Compute the return value, keeping in account the space - ;; inserted at the end of the buffer. - (buffer-substring 1 (max 1 (- (point-max) 1)))) - - ;; Cleanup. - (kill-buffer outbuf)))) - -;;; cmacexp.el ends here diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el deleted file mode 100644 index 4c9b9c56e76..00000000000 --- a/lisp/progmodes/compile.el +++ /dev/null @@ -1,1583 +0,0 @@ -;;; compile.el --- run compiler as inferior of Emacs, parse error messages. - -;; Copyright (C) 1985, 86, 87, 93, 94, 1995, 1996 Free Software Foundation, Inc. - -;; Author: Roland McGrath <roland@prep.ai.mit.edu> -;; Maintainer: FSF -;; Keywords: tools, processes - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package provides the compile and grep facilities documented in -;; the Emacs user's manual. - -;;; Code: - -;;;###autoload -(defvar compilation-mode-hook nil - "*List of hook functions run by `compilation-mode' (see `run-hooks').") - -;;;###autoload -(defvar compilation-window-height nil - "*Number of lines in a compilation window. If nil, use Emacs default.") - -(defvar compile-auto-highlight nil - "*Specify how many compiler errors to highlight (and parse) initially. -\(Highlighting applies to ean error message when the mouse is over it.) -If this is a number N, all compiler error messages in the first N lines -are highlighted and parsed as soon as they arrive in Emacs. -If t, highlight and parse the whole compilation output as soon as it arrives. -If nil, don't highlight or parse any of the buffer until you try to -move to the error messages. - -Those messages which are not parsed and highlighted initially -will be parsed and highlighted as soon as you try to move to them.") - -(defvar compilation-error-list nil - "List of error message descriptors for visiting erring functions. -Each error descriptor is a cons (or nil). Its car is a marker pointing to -an error message. If its cdr is a marker, it points to the text of the -line the message is about. If its cdr is a cons, it is a list -\(\(DIRECTORY . FILE\) LINE [COLUMN]\). Or its cdr may be nil if that -error is not interesting. - -The value may be t instead of a list; this means that the buffer of -error messages should be reparsed the next time the list of errors is wanted. - -Some other commands (like `diff') use this list to control the error -message tracking facilities; if you change its structure, you should make -sure you also change those packages. Perhaps it is better not to change -it at all.") - -(defvar compilation-old-error-list nil - "Value of `compilation-error-list' after errors were parsed.") - -(defvar compilation-parse-errors-function 'compilation-parse-errors - "Function to call to parse error messages from a compilation. -It takes args LIMIT-SEARCH and FIND-AT-LEAST. -If LIMIT-SEARCH is non-nil, don't bother parsing past that location. -If FIND-AT-LEAST is non-nil, don't bother parsing after finding that -many new errors. -It should read in the source files which have errors and set -`compilation-error-list' to a list with an element for each error message -found. See that variable for more info.") - -;;;###autoload -(defvar compilation-buffer-name-function nil - "Function to compute the name of a compilation buffer. -The function receives one argument, the name of the major mode of the -compilation buffer. It should return a string. -nil means compute the name with `(concat \"*\" (downcase major-mode) \"*\")'.") - -;;;###autoload -(defvar compilation-finish-function nil - "*Function to call when a compilation process finishes. -It is called with two arguments: the compilation buffer, and a string -describing how the process finished.") - -;;;###autoload -(defvar compilation-finish-functions nil - "*Functions to call when a compilation process finishes. -Each function is called with two arguments: the compilation buffer, -and a string describing how the process finished.") - -(defvar compilation-last-buffer nil - "The most recent compilation buffer. -A buffer becomes most recent when its compilation is started -or when it is used with \\[next-error] or \\[compile-goto-error].") - -(defvar compilation-in-progress nil - "List of compilation processes now running.") -(or (assq 'compilation-in-progress minor-mode-alist) - (setq minor-mode-alist (cons '(compilation-in-progress " Compiling") - minor-mode-alist))) - -(defvar compilation-parsing-end nil - "Position of end of buffer when last error messages were parsed.") - -(defvar compilation-error-message "No more errors" - "Message to print when no more matches are found.") - -(defvar compilation-num-errors-found) - -(defvar compilation-error-regexp-alist - '( - ;; NOTE! See also grep-regexp-alist, below. - - ;; 4.3BSD grep, cc, lint pass 1: - ;; /usr/src/foo/foo.c(8): warning: w may be used before set - ;; or GNU utilities: - ;; foo.c:8: error message - ;; or HP-UX 7.0 fc: - ;; foo.f :16 some horrible error message - ;; or GNU utilities with column (GNAT 1.82): - ;; foo.adb:2:1: Unit name does not match file name - ;; - ;; We'll insist that the number be followed by a colon or closing - ;; paren, because otherwise this matches just about anything - ;; containing a number with spaces around it. - ("\n\ -\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\)\\([) \t]\\|\ -:\\([^0-9\n]\\|\\([0-9]+:\\)\\)\\)" 1 2 5) - - ;; Microsoft C/C++: - ;; keyboard.c(537) : warning C4005: 'min' : macro redefinition - ;; d:\tmp\test.c(23) : error C2143: syntax error : missing ';' before 'if' - ("\n\\(\\([a-zA-Z]:\\)?[^:( \t\n-]+\\)[:(][ \t]*\\([0-9]+\\)[:) \t]" 1 3) - - ;; Borland C++: - ;; Error ping.c 15: Unable to open include file 'sys/types.h' - ;; Warning ping.c 68: Call to function 'func' with no prototype - ("\n\\(Error\\|Warning\\) \\([a-zA-Z]?:?[^:( \t\n]+\\)\ - \\([0-9]+\\)\\([) \t]\\|:[^0-9\n]\\)" 2 3) - - ;; 4.3BSD lint pass 2 - ;; strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8) - ("[ \t:]\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(](+[ \t]*\\([0-9]+\\))[:) \t]*$" - 1 2) - - ;; 4.3BSD lint pass 3 - ;; bloofle defined( /users/wolfgang/foo.c(4) ), but never used - ;; This used to be - ;; ("[ \t(]+\\([a-zA-Z]?:?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]+" 1 2) - ;; which is regexp Impressionism - it matches almost anything! - ("([ \t]*\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\))" 1 2) - - ;; MIPS lint pass<n>; looks good for SunPro lint also - ;; TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomon.c due to truncation - ("[^ ]+ (\\([0-9]+\\)) in \\([^ ]+\\)" 2 1) - ;; name defined but never used: LinInt in cmap_calc.c(199) - ("in \\([^(]+\\)(\\([0-9]+\\))$" 1 2) - - ;; Ultrix 3.0 f77: - ;; fort: Severe: addstf.f, line 82: Missing operator or delimiter symbol - ;; Some SGI cc version: - ;; cfe: Warning 835: foo.c, line 2: something - ("\n\\(cfe\\|fort\\): [^:\n]*: \\([^ \n]*\\), line \\([0-9]+\\):" 2 3) - ;; Error on line 3 of t.f: Execution error unclassifiable statement - ;; Unknown who does this: - ;; Line 45 of "foo.c": bloofle undefined - ;; Absoft FORTRAN 77 Compiler 3.1.3 - ;; error on line 19 of fplot.f: spelling error? - ;; warning on line 17 of fplot.f: data type is undefined for variable d - ("\\(\n\\|on \\)[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ -of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2) - - ;; Apollo cc, 4.3BSD fc: - ;; "foo.f", line 3: Error: syntax error near end of statement - ;; IBM RS6000: - ;; "vvouch.c", line 19.5: 1506-046 (S) Syntax error. - ;; Unknown compiler: - ;; File "foobar.ml", lines 5-8, characters 20-155: blah blah - ;; Microtec mcc68k: - ;; "foo.c", line 32 pos 1; (E) syntax error; unexpected symbol: "lossage" - ;; GNAT (as of July 94): - ;; "foo.adb", line 2(11): warning: file name does not match ... - ;; IBM AIX xlc compiler: - ;; "src/swapping.c", line 30.34: 1506-342 (W) "/*" detected in comment. - ("\"\\([^,\" \n\t]+\\)\", lines? \ -\\([0-9]+\\)\\([\(.]\\([0-9]+\\)\)?\\)?[:., (-]" 1 2 4) - - ;; MIPS RISC CC - the one distributed with Ultrix: - ;; ccom: Error: foo.c, line 2: syntax error - ;; DEC AXP OSF/1 cc - ;; /usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah - ("rror: \\([^,\" \n\t]+\\)[,:] \\(line \\)?\\([0-9]+\\):" 1 3) - - ;; IBM AIX PS/2 C version 1.1: - ;; ****** Error number 140 in line 8 of file errors.c ****** - ("in line \\([0-9]+\\) of file \\([^ \n]+[^. \n]\\)\\.? " 2 1) - ;; IBM AIX lint is too painful to do right this way. File name - ;; prefixes entire sections rather than being on each line. - - ;; Lucid Compiler, lcc 3.x - ;; E, file.cc(35,52) Illegal operation on pointers - ("\n[EW], \\([^(\n]*\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" 1 2 3) - - ;; GNU messages with program name and optional column number. - ("\n[a-zA-Z]?:?[^0-9 \n\t:]+:[ \t]*\\([^ \n\t:]+\\):\ -\\([0-9]+\\):\\(\\([0-9]+\\)[: \t]\\)?" 1 2 4) - - ;; Cray C compiler error messages - ("\n\\(cc\\| cft\\)-[0-9]+ c\\(c\\|f77\\): ERROR \\([^,\n]+, \\)* File = \\([^,\n]+\\), Line = \\([0-9]+\\)" 4 5) - - ;; IBM C/C++ Tools 2.01: - ;; foo.c(2:0) : informational EDC0804: Function foo is not referenced. - ;; foo.c(3:8) : warning EDC0833: Implicit return statement encountered. - ;; foo.c(5:5) : error EDC0350: Syntax error. - ("\n\\([^( \n\t]+\\)(\\([0-9]+\\):\\([0-9]+\\)) : " 1 2 3) - - ;; Sun ada (VADS, Solaris): - ;; /home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: "," inserted - ("\n\\([^, ]+\\), line \\([0-9]+\\), char \\([0-9]+\\)[:., \(-]" 1 2 3) - ) - "Alist that specifies how to match errors in compiler output. -Each elt has the form (REGEXP FILE-IDX LINE-IDX [COLUMN-IDX FILE-FORMAT...]) -If REGEXP matches, the FILE-IDX'th subexpression gives the file name, and -the LINE-IDX'th subexpression gives the line number. If COLUMN-IDX is -given, the COLUMN-IDX'th subexpression gives the column number on that line. -If any FILE-FORMAT is given, each is a format string to produce a file name to -try; %s in the string is replaced by the text matching the FILE-IDX'th -subexpression.") - -(defvar compilation-read-command t - "If not nil, M-x compile reads the compilation command to use. -Otherwise, M-x compile just uses the value of `compile-command'.") - -(defvar compilation-ask-about-save t - "If not nil, M-x compile asks which buffers to save before compiling. -Otherwise, it saves all modified buffers without asking.") - -(defvar grep-regexp-alist - '(("^\\([a-zA-Z]?:?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 2)) - "Regexp used to match grep hits. See `compilation-error-regexp-alist'.") - -(defvar grep-command "grep -n " - "Last grep command used in \\[grep]; default for next grep.") - -;;;###autoload -(defvar compilation-search-path '(nil) - "*List of directories to search for source files named in error messages. -Elements should be directory names, not file names of directories. -nil as an element means to try the default directory.") - -(defvar compile-command "make -k " - "Last shell command used to do a compilation; default for next compilation. - -Sometimes it is useful for files to supply local values for this variable. -You might also use mode hooks to specify it in certain modes, like this: - - (setq c-mode-hook - '(lambda () (or (file-exists-p \"makefile\") (file-exists-p \"Makefile\") - (progn (make-local-variable 'compile-command) - (setq compile-command - (concat \"make -k \" - buffer-file-name))))))") - -(defvar compilation-enter-directory-regexp - ": Entering directory `\\(.*\\)'$" - "Regular expression matching lines that indicate a new current directory. -This must contain one \\(, \\) pair around the directory name. - -The default value matches lines printed by the `-w' option of GNU Make.") - -(defvar compilation-leave-directory-regexp - ": Leaving directory `\\(.*\\)'$" - "Regular expression matching lines that indicate restoring current directory. -This may contain one \\(, \\) pair around the name of the directory -being moved from. If it does not, the last directory entered \(by a -line matching `compilation-enter-directory-regexp'\) is assumed. - -The default value matches lines printed by the `-w' option of GNU Make.") - -(defvar compilation-directory-stack nil - "Stack of previous directories for `compilation-leave-directory-regexp'. -The head element is the directory the compilation was started in.") - -(defvar compilation-exit-message-function nil "\ -If non-nil, called when a compilation process dies to return a status message. -This should be a function of three arguments: process status, exit status, -and exit message; it returns a cons (MESSAGE . MODELINE) of the strings to -write into the compilation buffer, and to put in its mode line.") - -;; History of compile commands. -(defvar compile-history nil) -;; History of grep commands. -(defvar grep-history nil) - -(defvar compilation-mode-font-lock-keywords - ;; This regexp needs a bit of rewriting. What is the third grouping for? - '(("^\\([a-zA-Z]?:?[^ \n:]*:\\([0-9]+:\\)+\\)\\(.*\\)$" - 1 font-lock-function-name-face)) -;;; ("^\\([^\n:]*:\\([0-9]+:\\)+\\)\\(.*\\)$" 0 font-lock-keyword-face keep) - "Additional expressions to highlight in Compilation mode.") - -;;;###autoload -(defun compile (command) - "Compile the program including the current buffer. Default: run `make'. -Runs COMMAND, a shell command, in a separate process asynchronously -with output going to the buffer `*compilation*'. - -You can then use the command \\[next-error] to find the next error message -and move to the source code that caused it. - -Interactively, prompts for the command if `compilation-read-command' is -non-nil; otherwise uses `compile-command'. With prefix arg, always prompts. - -To run more than one compilation at once, start one and rename the -\`*compilation*' buffer to some other name with \\[rename-buffer]. -Then start the next one. - -The name used for the buffer is actually whatever is returned by -the function in `compilation-buffer-name-function', so you can set that -to a function that generates a unique name." - (interactive - (if (or compilation-read-command current-prefix-arg) - (list (read-from-minibuffer "Compile command: " - compile-command nil nil - '(compile-history . 1))) - (list compile-command))) - (setq compile-command command) - (save-some-buffers (not compilation-ask-about-save) nil) - (compile-internal compile-command "No more errors")) - -;;; run compile with the default command line -(defun recompile () - "Re-compile the program including the current buffer." - (interactive) - (save-some-buffers (not compilation-ask-about-save) nil) - (compile-internal compile-command "No more errors")) - -;; The system null device. (Should reference NULL_DEVICE from C.) -(defvar grep-null-device "/dev/null" "The system null device.") - -;;;###autoload -(defun grep (command-args) - "Run grep, with user-specified args, and collect output in a buffer. -While grep runs asynchronously, you can use the \\[next-error] command -to find the text that grep hits refer to. - -This command uses a special history list for its arguments, so you can -easily repeat a grep command." - (interactive - (list (read-from-minibuffer "Run grep (like this): " - grep-command nil nil 'grep-history))) - (let ((buf (compile-internal (concat command-args " " grep-null-device) - "No more grep hits" "grep" - ;; Give it a simpler regexp to match. - nil grep-regexp-alist))) - (save-excursion - (set-buffer buf) - (set (make-local-variable 'compilation-exit-message-function) - (lambda (status code msg) - (if (eq status 'exit) - (cond ((zerop code) - '("finished (matches found)\n" . "matched")) - ((= code 1) - '("finished with no matches found\n" . "no match")) - (t - (cons msg code))) - (cons msg code))))))) - -(defun compile-internal (command error-message - &optional name-of-mode parser regexp-alist - name-function) - "Run compilation command COMMAND (low level interface). -ERROR-MESSAGE is a string to print if the user asks to see another error -and there are no more errors. Third argument NAME-OF-MODE is the name -to display as the major mode in the compilation buffer. - -Fourth arg PARSER is the error parser function (nil means the default). Fifth -arg REGEXP-ALIST is the error message regexp alist to use (nil means the -default). Sixth arg NAME-FUNCTION is a function called to name the buffer (nil -means the default). The defaults for these variables are the global values of -\`compilation-parse-errors-function', `compilation-error-regexp-alist', and -\`compilation-buffer-name-function', respectively. - -Returns the compilation buffer created." - (let (outbuf) - (save-excursion - (or name-of-mode - (setq name-of-mode "Compilation")) - (setq outbuf - (get-buffer-create - (funcall (or name-function compilation-buffer-name-function - (function (lambda (mode) - (concat "*" (downcase mode) "*")))) - name-of-mode))) - (set-buffer outbuf) - (let ((comp-proc (get-buffer-process (current-buffer)))) - (if comp-proc - (if (or (not (eq (process-status comp-proc) 'run)) - (yes-or-no-p - (format "A %s process is running; kill it? " - name-of-mode))) - (condition-case () - (progn - (interrupt-process comp-proc) - (sit-for 1) - (delete-process comp-proc)) - (error nil)) - (error "Cannot have two processes in `%s' at once" - (buffer-name)) - ))) - ;; In case the compilation buffer is current, make sure we get the global - ;; values of compilation-error-regexp-alist, etc. - (kill-all-local-variables)) - (let ((regexp-alist (or regexp-alist compilation-error-regexp-alist)) - (parser (or parser compilation-parse-errors-function)) - (thisdir default-directory) - outwin) - (save-excursion - ;; Clear out the compilation buffer and make it writable. - ;; Change its default-directory to the directory where the compilation - ;; will happen, and insert a `cd' command to indicate this. - (set-buffer outbuf) - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (buffer-enable-undo (current-buffer)) - (setq default-directory thisdir) - (insert "cd " thisdir "\n" command "\n") - (set-buffer-modified-p nil)) - ;; If we're already in the compilation buffer, go to the end - ;; of the buffer, so point will track the compilation output. - (if (eq outbuf (current-buffer)) - (goto-char (point-max))) - ;; Pop up the compilation buffer. - (setq outwin (display-buffer outbuf)) - (save-excursion - (set-buffer outbuf) - (compilation-mode) - ;; (setq buffer-read-only t) ;;; Non-ergonomic. - (set (make-local-variable 'compilation-parse-errors-function) parser) - (set (make-local-variable 'compilation-error-message) error-message) - (set (make-local-variable 'compilation-error-regexp-alist) regexp-alist) - (setq default-directory thisdir - compilation-directory-stack (list default-directory)) - (set-window-start outwin (point-min)) - (setq mode-name name-of-mode) - (or (eq outwin (selected-window)) - (set-window-point outwin (point-min))) - (compilation-set-window-height outwin) - ;; Start the compilation. - (if (fboundp 'start-process) - (let* ((process-environment (cons "EMACS=t" process-environment)) - (proc (start-process-shell-command (downcase mode-name) - outbuf - command))) - (set-process-sentinel proc 'compilation-sentinel) - (set-process-filter proc 'compilation-filter) - (set-marker (process-mark proc) (point) outbuf) - (setq compilation-in-progress - (cons proc compilation-in-progress))) - ;; No asynchronous processes available. - (message "Executing `%s'..." command) - ;; Fake modeline display as if `start-process' were run. - (setq mode-line-process ":run") - (force-mode-line-update) - (sit-for 0) ; Force redisplay - (let ((status (call-process shell-file-name nil outbuf nil "-c" - command))) - (cond ((numberp status) - (compilation-handle-exit 'exit status - (if (zerop status) - "finished\n" - (format "\ -exited abnormally with code %d\n" - status)))) - ((stringp status) - (compilation-handle-exit 'signal status - (concat status "\n"))) - (t - (compilation-handle-exit 'bizarre status status)))) - (message "Executing `%s'...done" command)))) - ;; Make it so the next C-x ` will use this buffer. - (setq compilation-last-buffer outbuf))) - -;; Set the height of WINDOW according to compilation-window-height. -(defun compilation-set-window-height (window) - (and compilation-window-height - (= (window-width window) (frame-width (window-frame window))) - ;; If window is alone in its frame, aside from a minibuffer, - ;; don't change its height. - (not (eq window (frame-root-window (window-frame window)))) - ;; This save-excursion prevents us from changing the current buffer, - ;; which might not be the same as the selected window's buffer. - (save-excursion - (let ((w (selected-window))) - (unwind-protect - (progn - (select-window window) - (enlarge-window (- compilation-window-height - (window-height)))) - (select-window w)))))) - -(defvar compilation-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'compile-mouse-goto-error) - (define-key map "\C-c\C-c" 'compile-goto-error) - (define-key map "\C-m" 'compile-goto-error) - (define-key map "\C-c\C-k" 'kill-compilation) - (define-key map "\M-n" 'compilation-next-error) - (define-key map "\M-p" 'compilation-previous-error) - (define-key map "\M-{" 'compilation-previous-file) - (define-key map "\M-}" 'compilation-next-file) - map) - "Keymap for `compilation-minor-mode'.") - -(defvar compilation-mode-map - (let ((map (cons 'keymap compilation-minor-mode-map))) - (define-key map " " 'scroll-up) - (define-key map "\^?" 'scroll-down) - ;; Set up the menu-bar - (define-key map [menu-bar compilation-menu] - (cons "Compile" (make-sparse-keymap "Compile"))) - - (define-key map [menu-bar compilation-menu compilation-mode-kill-compilation] - '("Stop Compilation" . kill-compilation)) - (define-key map [menu-bar compilation-menu compilation-mode-separator2] - '("----" . nil)) - (define-key map [menu-bar compilation-menu compilation-mode-first-error] - '("First Error" . first-error)) - (define-key map [menu-bar compilation-menu compilation-mode-previous-error] - '("Previous Error" . previous-error)) - (define-key map [menu-bar compilation-menu compilation-mode-next-error] - '("Next Error" . next-error)) - (define-key map [menu-bar compilation-menu compilation-separator2] - '("----" . nil)) - (define-key map [menu-bar compilation-menu compilation-mode-grep] - '("Grep" . grep)) - (define-key map [menu-bar compilation-menu compilation-mode-recompile] - '("Recompile" . recompile)) - (define-key map [menu-bar compilation-menu compilation-mode-compile] - '("Compile" . compile)) - map) - "Keymap for compilation log buffers. -`compilation-minor-mode-map' is a cdr of this.") - -;;;###autoload -(defun compilation-mode () - "Major mode for compilation log buffers. -\\<compilation-mode-map>To visit the source for a line-numbered error, -move point to the error message line and type \\[compile-goto-error]. -To kill the compilation, type \\[kill-compilation]. - -Runs `compilation-mode-hook' with `run-hooks' (which see)." - (interactive) - (kill-all-local-variables) - (use-local-map compilation-mode-map) - (setq major-mode 'compilation-mode - mode-name "Compilation") - (compilation-setup) - (set (make-local-variable 'font-lock-defaults) - '(compilation-mode-font-lock-keywords t)) - (run-hooks 'compilation-mode-hook)) - -;; Prepare the buffer for the compilation parsing commands to work. -(defun compilation-setup () - ;; Make the buffer's mode line show process state. - (setq mode-line-process '(":%s")) - (set (make-local-variable 'compilation-error-list) nil) - (set (make-local-variable 'compilation-old-error-list) nil) - (set (make-local-variable 'compilation-parsing-end) 1) - (set (make-local-variable 'compilation-directory-stack) nil) - (setq compilation-last-buffer (current-buffer))) - -(defvar compilation-minor-mode nil - "Non-nil when in compilation-minor-mode. -In this minor mode, all the error-parsing commands of the -Compilation major mode are available.") -(make-variable-buffer-local 'compilation-minor-mode) - -(or (assq 'compilation-minor-mode minor-mode-alist) - (setq minor-mode-alist (cons '(compilation-minor-mode " Compilation") - minor-mode-alist))) -(or (assq 'compilation-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist (cons (cons 'compilation-minor-mode - compilation-minor-mode-map) - minor-mode-map-alist))) - -;;;###autoload -(defun compilation-minor-mode (&optional arg) - "Toggle compilation minor mode. -With arg, turn compilation mode on if and only if arg is positive. -See `compilation-mode'. -Turning the mode on runs the normal hook `compilation-minor-mode-hook'." - (interactive "P") - (if (setq compilation-minor-mode (if (null arg) - (null compilation-minor-mode) - (> (prefix-numeric-value arg) 0))) - (progn - (compilation-setup) - (run-hooks 'compilation-minor-mode-hook)))) - -;; Write msg in the current buffer and hack its mode-line-process. -(defun compilation-handle-exit (process-status exit-status msg) - (let ((buffer-read-only nil) - (status (if compilation-exit-message-function - (funcall compilation-exit-message-function - process-status exit-status msg) - (cons msg exit-status))) - (omax (point-max)) - (opoint (point))) - ;; Record where we put the message, so we can ignore it - ;; later on. - (goto-char omax) - (insert ?\n mode-name " " (car status)) - (forward-char -1) - (insert " at " (substring (current-time-string) 0 19)) - (forward-char 1) - (setq mode-line-process (format ":%s [%s]" process-status (cdr status))) - ;; Force mode line redisplay soon. - (force-mode-line-update) - (if (and opoint (< opoint omax)) - (goto-char opoint)) - ;; Automatically parse (and mouse-highlight) error messages: - (cond ((eq compile-auto-highlight t) - (compile-reinitialize-errors nil (point-max))) - ((numberp compile-auto-highlight) - (compile-reinitialize-errors nil - (save-excursion - (goto-line compile-auto-highlight) - (point))))) - (if compilation-finish-function - (funcall compilation-finish-function (current-buffer) msg)) - (let ((functions compilation-finish-functions)) - (while functions - (funcall (car functions) (current-buffer) msg) - (setq functions (cdr functions)))))) - -;; Called when compilation process changes state. -(defun compilation-sentinel (proc msg) - "Sentinel for compilation buffers." - (let ((buffer (process-buffer proc))) - (if (memq (process-status proc) '(signal exit)) - (progn - (if (null (buffer-name buffer)) - ;; buffer killed - (set-process-buffer proc nil) - (let ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in the compilation buffer - ;; and hack its mode line. - (set-buffer buffer) - (compilation-handle-exit (process-status proc) - (process-exit-status proc) - msg) - ;; Since the buffer and mode line will show that the - ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - (set-buffer obuf)))) - (setq compilation-in-progress (delq proc compilation-in-progress)) - )))) - -(defun compilation-filter (proc string) - "Process filter for compilation buffers. -Just inserts the text, but uses `insert-before-markers'." - (if (buffer-name (process-buffer proc)) - (save-excursion - (set-buffer (process-buffer proc)) - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (process-mark proc)) - (insert-before-markers string) - (run-hooks 'compilation-filter-hook) - (set-marker (process-mark proc) (point))))))) - -;; Return the cdr of compilation-old-error-list for the error containing point. -(defun compile-error-at-point () - (compile-reinitialize-errors nil (point)) - (let ((errors compilation-old-error-list)) - (while (and errors - (> (point) (car (car errors)))) - (setq errors (cdr errors))) - errors)) - -(defsubst compilation-buffer-p (buffer) - (save-excursion - (set-buffer buffer) - (or compilation-minor-mode (eq major-mode 'compilation-mode)))) - -(defun compilation-next-error (n) - "Move point to the next error in the compilation buffer. -Does NOT find the source line like \\[next-error]." - (interactive "p") - (or (compilation-buffer-p (current-buffer)) - (error "Not in a compilation buffer.")) - (setq compilation-last-buffer (current-buffer)) - - (let ((errors (compile-error-at-point))) - - ;; Move to the error after the one containing point. - (goto-char (car (if (< n 0) - (let ((i 0) - (e compilation-old-error-list)) - ;; See how many cdrs away ERRORS is from the start. - (while (not (eq e errors)) - (setq i (1+ i) - e (cdr e))) - (if (> (- n) i) - (error "Moved back past first error") - (nth (+ i n) compilation-old-error-list))) - (let ((compilation-error-list (cdr errors))) - (compile-reinitialize-errors nil nil n) - (if compilation-error-list - (nth (1- n) compilation-error-list) - (error "Moved past last error")))))))) - -(defun compilation-previous-error (n) - "Move point to the previous error in the compilation buffer. -Does NOT find the source line like \\[next-error]." - (interactive "p") - (compilation-next-error (- n))) - - -;; Given an elt of `compilation-error-list', return an object representing -;; the referenced file which is equal to (but not necessarily eq to) what -;; this function would return for another error in the same file. -(defsubst compilation-error-filedata (data) - (setq data (cdr data)) - (if (markerp data) - (marker-buffer data) - (car data))) - -;; Return a string describing a value from compilation-error-filedata. -;; This value is not necessarily useful as a file name, but should be -;; indicative to the user of what file's errors are being referred to. -(defsubst compilation-error-filedata-file-name (filedata) - (if (bufferp filedata) - (buffer-file-name filedata) - (car filedata))) - -(defun compilation-next-file (n) - "Move point to the next error for a different file than the current one." - (interactive "p") - (or (compilation-buffer-p (current-buffer)) - (error "Not in a compilation buffer.")) - (setq compilation-last-buffer (current-buffer)) - - (let ((reversed (< n 0)) - errors filedata) - - (if (not reversed) - (setq errors (or (compile-error-at-point) - (error "Moved past last error"))) - - ;; Get a reversed list of the errors up through the one containing point. - (compile-reinitialize-errors nil (point)) - (setq errors (reverse compilation-old-error-list) - n (- n)) - - ;; Ignore errors after point. (car ERRORS) will be the error - ;; containing point, (cadr ERRORS) the one before it. - (while (and errors - (< (point) (car (car errors)))) - (setq errors (cdr errors)))) - - (while (> n 0) - (setq filedata (compilation-error-filedata (car errors))) - - ;; Skip past the following errors for this file. - (while (equal filedata - (compilation-error-filedata - (car (or errors - (if reversed - (error "%s the first erring file" - (compilation-error-filedata-file-name - filedata)) - (let ((compilation-error-list nil)) - ;; Parse some more. - (compile-reinitialize-errors nil nil 2) - (setq errors compilation-error-list))) - (error "%s is the last erring file" - (compilation-error-filedata-file-name - filedata)))))) - (setq errors (cdr errors))) - - (setq n (1- n))) - - ;; Move to the following error. - (goto-char (car (car (or errors - (if reversed - (error "This is the first erring file") - (let ((compilation-error-list nil)) - ;; Parse the last one. - (compile-reinitialize-errors nil nil 1) - compilation-error-list)))))))) - -(defun compilation-previous-file (n) - "Move point to the previous error for a different file than the current one." - (interactive "p") - (compilation-next-file (- n))) - - -(defun kill-compilation () - "Kill the process made by the \\[compile] command." - (interactive) - (let ((buffer (compilation-find-buffer))) - (if (get-buffer-process buffer) - (interrupt-process (get-buffer-process buffer)) - (error "The compilation process is not running.")))) - - -;; Parse any new errors in the compilation buffer, -;; or reparse from the beginning if the user has asked for that. -(defun compile-reinitialize-errors (reparse - &optional limit-search find-at-least) - (save-excursion - (set-buffer compilation-last-buffer) - ;; If we are out of errors, or if user says "reparse", - ;; discard the info we have, to force reparsing. - (if (or (eq compilation-error-list t) - reparse) - (compilation-forget-errors)) - (if (and compilation-error-list - (or (not limit-search) - (> compilation-parsing-end limit-search)) - (or (not find-at-least) - (>= (length compilation-error-list) find-at-least))) - ;; Since compilation-error-list is non-nil, it points to a specific - ;; error the user wanted. So don't move it around. - nil - ;; This was here for a long time (before my rewrite); why? --roland - ;;(switch-to-buffer compilation-last-buffer) - (set-buffer-modified-p nil) - (if (< compilation-parsing-end (point-max)) - ;; compilation-error-list might be non-nil if we have a non-nil - ;; LIMIT-SEARCH or FIND-AT-LEAST arg. In that case its value - ;; records the current position in the error list, and we must - ;; preserve that after reparsing. - (let ((error-list-pos compilation-error-list)) - (funcall compilation-parse-errors-function - limit-search - (and find-at-least - ;; We only need enough new parsed errors to reach - ;; FIND-AT-LEAST errors past the current - ;; position. - (- find-at-least (length compilation-error-list)))) - ;; Remember the entire list for compilation-forget-errors. If - ;; this is an incremental parse, append to previous list. If - ;; we are parsing anew, compilation-forget-errors cleared - ;; compilation-old-error-list above. - (setq compilation-old-error-list - (nconc compilation-old-error-list compilation-error-list)) - (if error-list-pos - ;; We started in the middle of an existing list of parsed - ;; errors before parsing more; restore that position. - (setq compilation-error-list error-list-pos)) - ;; Mouse-Highlight (the first line of) each error message when the - ;; mouse pointer moves over it: - (let ((inhibit-read-only t) - (error-list compilation-error-list)) - (while error-list - (save-excursion - (put-text-property (goto-char (car (car error-list))) - (progn (end-of-line) (point)) - 'mouse-face 'highlight)) - (setq error-list (cdr error-list)))) - ))))) - -(defun compile-mouse-goto-error (event) - (interactive "e") - (save-excursion - (set-buffer (window-buffer (posn-window (event-end event)))) - (goto-char (posn-point (event-end event))) - - (or (compilation-buffer-p (current-buffer)) - (error "Not in a compilation buffer.")) - (setq compilation-last-buffer (current-buffer)) - (compile-reinitialize-errors nil (point)) - - ;; Move to bol; the marker for the error on this line will point there. - (beginning-of-line) - - ;; Move compilation-error-list to the elt of compilation-old-error-list - ;; we want. - (setq compilation-error-list compilation-old-error-list) - (while (and compilation-error-list - (> (point) (car (car compilation-error-list)))) - (setq compilation-error-list (cdr compilation-error-list))) - (or compilation-error-list - (error "No error to go to"))) - (select-window (posn-window (event-end event))) - ;; Move to another window, so that next-error's window changes - ;; result in the desired setup. - (or (one-window-p) - (progn - (other-window -1) - ;; other-window changed the selected buffer, - ;; but we didn't want to do that. - (set-buffer compilation-last-buffer))) - - (push-mark) - (next-error 1)) - -(defun compile-goto-error (&optional argp) - "Visit the source for the error message point is on. -Use this command in a compilation log buffer. Sets the mark at point there. -\\[universal-argument] as a prefix arg means to reparse the buffer's error messages first; -other kinds of prefix arguments are ignored." - (interactive "P") - (or (compilation-buffer-p (current-buffer)) - (error "Not in a compilation buffer.")) - (setq compilation-last-buffer (current-buffer)) - (compile-reinitialize-errors (consp argp) (point)) - - ;; Move to bol; the marker for the error on this line will point there. - (beginning-of-line) - - ;; Move compilation-error-list to the elt of compilation-old-error-list - ;; we want. - (setq compilation-error-list compilation-old-error-list) - (while (and compilation-error-list - (> (point) (car (car compilation-error-list)))) - (setq compilation-error-list (cdr compilation-error-list))) - - ;; Move to another window, so that next-error's window changes - ;; result in the desired setup. - (or (one-window-p) - (progn - (other-window -1) - ;; other-window changed the selected buffer, - ;; but we didn't want to do that. - (set-buffer compilation-last-buffer))) - - (push-mark) - (next-error 1)) - -;; Return a compilation buffer. -;; If the current buffer is a compilation buffer, return it. -;; If compilation-last-buffer is set to a live buffer, use that. -;; Otherwise, look for a compilation buffer and signal an error -;; if there are none. -(defun compilation-find-buffer (&optional other-buffer) - (if (and (not other-buffer) - (compilation-buffer-p (current-buffer))) - ;; The current buffer is a compilation buffer. - (current-buffer) - (if (and compilation-last-buffer (buffer-name compilation-last-buffer) - (compilation-buffer-p compilation-last-buffer) - (or (not other-buffer) (not (eq compilation-last-buffer - (current-buffer))))) - compilation-last-buffer - (let ((buffers (buffer-list))) - (while (and buffers (or (not (compilation-buffer-p (car buffers))) - (and other-buffer - (eq (car buffers) (current-buffer))))) - (setq buffers (cdr buffers))) - (if buffers - (car buffers) - (or (and other-buffer - (compilation-buffer-p (current-buffer)) - ;; The current buffer is a compilation buffer. - (progn - (if other-buffer - (message "This is the only compilation buffer.")) - (current-buffer))) - (error "No compilation started!"))))))) - -;;;###autoload -(defun next-error (&optional argp) - "Visit next compilation error message and corresponding source code. -This operates on the output from the \\[compile] command. -If all preparsed error messages have been processed, -the error message buffer is checked for new ones. - -A prefix arg specifies how many error messages to move; -negative means move back to previous error messages. -Just C-u as a prefix means reparse the error message buffer -and start at the first error. - -\\[next-error] normally applies to the most recent compilation started, -but as long as you are in the middle of parsing errors from one compilation -output buffer, you stay with that compilation output buffer. - -Use \\[next-error] in a compilation output buffer to switch to -processing errors from that compilation. - -See variables `compilation-parse-errors-function' and -\`compilation-error-regexp-alist' for customization ideas." - (interactive "P") - (setq compilation-last-buffer (compilation-find-buffer)) - (compilation-goto-locus (compilation-next-error-locus - ;; We want to pass a number here only if - ;; we got a numeric prefix arg, not just C-u. - (and (not (consp argp)) - (prefix-numeric-value argp)) - (consp argp)))) -;;;###autoload (define-key ctl-x-map "`" 'next-error) - -(defun previous-error () - "Visit previous compilation error message and corresponding source code. -This operates on the output from the \\[compile] command." - (interactive) - (next-error -1)) - -(defun first-error () - "Reparse the error message buffer and start at the first error -Visit corresponding source code. -This operates on the output from the \\[compile] command." - (interactive) - (next-error '(4))) - -(defvar compilation-skip-to-next-location nil - "*If non-nil, skip multiple error messages for the same source location.") - -(defun compilation-next-error-locus (&optional move reparse silent) - "Visit next compilation error and return locus in corresponding source code. -This operates on the output from the \\[compile] command. -If all preparsed error messages have been processed, -the error message buffer is checked for new ones. - -Returns a cons (ERROR . SOURCE) of two markers: ERROR is a marker at the -location of the error message in the compilation buffer, and SOURCE is a -marker at the location in the source code indicated by the error message. - -Optional first arg MOVE says how many error messages to move forwards (or -backwards, if negative); default is 1. Optional second arg REPARSE, if -non-nil, says to reparse the error message buffer and reset to the first -error (plus MOVE - 1). If optional third argument SILENT is non-nil, return -nil instead of raising an error if there are no more errors. - -The current buffer should be the desired compilation output buffer." - (or move (setq move 1)) - (compile-reinitialize-errors reparse nil (and (not reparse) - (if (< move 1) 0 (1- move)))) - (let (next-errors next-error) - (catch 'no-next-error - (save-excursion - (set-buffer compilation-last-buffer) - ;; compilation-error-list points to the "current" error. - (setq next-errors - (if (> move 0) - (nthcdr (1- move) - compilation-error-list) - ;; Zero or negative arg; we need to move back in the list. - (let ((n (1- move)) - (i 0) - (e compilation-old-error-list)) - ;; See how many cdrs away the current error is from the start. - (while (not (eq e compilation-error-list)) - (setq i (1+ i) - e (cdr e))) - (if (> (- n) i) - (error "Moved back past first error") - (nthcdr (+ i n) compilation-old-error-list)))) - next-error (car next-errors)) - (while - (if (null next-error) - (progn - (and move (/= move 1) - (error (if (> move 0) - "Moved past last error") - "Moved back past first error")) - ;; Forget existing error messages if compilation has finished. - (if (not (and (get-buffer-process (current-buffer)) - (eq (process-status - (get-buffer-process - (current-buffer))) - 'run))) - (compilation-forget-errors)) - (if silent - (throw 'no-next-error nil) - (error (concat compilation-error-message - (and (get-buffer-process (current-buffer)) - (eq (process-status - (get-buffer-process - (current-buffer))) - 'run) - " yet"))))) - (setq compilation-error-list (cdr next-errors)) - (if (null (cdr next-error)) - ;; This error is boring. Go to the next. - t - (or (markerp (cdr next-error)) - ;; This error has a filename/lineno pair. - ;; Find the file and turn it into a marker. - (let* ((fileinfo (car (cdr next-error))) - (buffer (apply 'compilation-find-file - (car next-error) fileinfo))) - (if (null buffer) - ;; We can't find this error's file. - ;; Remove all errors in the same file. - (progn - (setq next-errors compilation-old-error-list) - (while next-errors - (and (consp (cdr (car next-errors))) - (equal (car (cdr (car next-errors))) - fileinfo) - (progn - (set-marker (car (car next-errors)) nil) - (setcdr (car next-errors) nil))) - (setq next-errors (cdr next-errors))) - ;; Look for the next error. - t) - ;; We found the file. Get a marker for this error. - ;; compilation-old-error-list is a buffer-local - ;; variable, so we must be careful to extract its value - ;; before switching to the source file buffer. - (let ((errors compilation-old-error-list) - (last-line (nth 1 (cdr next-error))) - (column (nth 2 (cdr next-error)))) - (set-buffer buffer) - (save-excursion - (save-restriction - (widen) - (goto-line last-line) - (if (and column (> column 0)) - ;; Columns in error msgs are 1-origin. - (move-to-column (1- column)) - (beginning-of-line)) - (setcdr next-error (point-marker)) - ;; Make all the other error messages referring - ;; to the same file have markers into the buffer. - (while errors - (and (consp (cdr (car errors))) - (equal (car (cdr (car errors))) fileinfo) - (let* ((this (nth 1 (cdr (car errors)))) - (column (nth 2 (cdr (car errors)))) - (lines (- this last-line))) - (if (eq selective-display t) - ;; When selective-display is t, - ;; each C-m is a line boundary, - ;; as well as each newline. - (if (< lines 0) - (re-search-backward "[\n\C-m]" - nil 'end - (- lines)) - (re-search-forward "[\n\C-m]" - nil 'end - lines)) - (forward-line lines)) - (if (and column (> column 1)) - (move-to-column (1- column)) - (beginning-of-line)) - (setq last-line this) - (setcdr (car errors) (point-marker)))) - (setq errors (cdr errors))))))))) - ;; If we didn't get a marker for this error, or this - ;; marker's buffer was killed, go on to the next one. - (or (not (markerp (cdr next-error))) - (not (marker-buffer (cdr next-error)))))) - (setq next-errors compilation-error-list - next-error (car next-errors))))) - - (if compilation-skip-to-next-location - ;; Skip over multiple error messages for the same source location, - ;; so the next C-x ` won't go to an error in the same place. - (while (and compilation-error-list - (equal (cdr (car compilation-error-list)) (cdr next-error))) - (setq compilation-error-list (cdr compilation-error-list)))) - - ;; We now have a marker for the position of the error source code. - ;; NEXT-ERROR is a cons (ERROR . SOURCE) of two markers. - next-error)) - -(defun compilation-goto-locus (next-error) - "Jump to an error locus returned by `compilation-next-error-locus'. -Takes one argument, a cons (ERROR . SOURCE) of two markers. -Selects a window with point at SOURCE, with another window displaying ERROR." - (if (and (window-dedicated-p (selected-window)) - (eq (selected-window) (frame-root-window))) - (switch-to-buffer-other-frame (marker-buffer (cdr next-error))) - (switch-to-buffer (marker-buffer (cdr next-error)))) - (goto-char (cdr next-error)) - ;; If narrowing got in the way of - ;; going to the right place, widen. - (or (= (point) (marker-position (cdr next-error))) - (progn - (widen) - (goto-char (cdr next-error)))) - - ;; Show compilation buffer in other window, scrolled to this error. - (let* ((pop-up-windows t) - ;; Use an existing window if it is in a visible frame. - (w (or (get-buffer-window (marker-buffer (car next-error)) 'visible) - ;; Pop up a window. - (display-buffer (marker-buffer (car next-error)))))) - (set-window-point w (car next-error)) - (set-window-start w (car next-error)) - (compilation-set-window-height w))) - -;; Find a buffer for file FILENAME. -;; Search the directories in compilation-search-path. -;; A nil in compilation-search-path means to try the -;; current directory, which is passed in DIR. -;; If FILENAME is not found at all, ask the user where to find it. -;; Pop up the buffer containing MARKER and scroll to MARKER if we ask the user. -(defun compilation-find-file (marker filename dir &rest formats) - (or formats (setq formats '("%s"))) - (let ((dirs compilation-search-path) - buffer thisdir fmts name) - (if (file-name-absolute-p filename) - ;; The file name is absolute. Use its explicit directory as - ;; the first in the search path, and strip it from FILENAME. - (setq filename (abbreviate-file-name (expand-file-name filename)) - dirs (cons (file-name-directory filename) dirs) - filename (file-name-nondirectory filename))) - ;; Now search the path. - (while (and dirs (null buffer)) - (setq thisdir (or (car dirs) dir) - fmts formats) - ;; For each directory, try each format string. - (while (and fmts (null buffer)) - (setq name (expand-file-name (format (car fmts) filename) thisdir) - buffer (and (file-exists-p name) - (find-file-noselect name)) - fmts (cdr fmts))) - (setq dirs (cdr dirs))) - (or buffer - ;; The file doesn't exist. - ;; Ask the user where to find it. - ;; If he hits C-g, then the next time he does - ;; next-error, he'll skip past it. - (let* ((pop-up-windows t) - (w (display-buffer (marker-buffer marker)))) - (set-window-point w marker) - (set-window-start w marker) - (let ((name (expand-file-name - (read-file-name - (format "Find this error in: (default %s) " - filename) - dir filename t)))) - (if (file-directory-p name) - (setq name (expand-file-name filename name))) - (and (file-exists-p name) - (find-file-noselect name))))))) - -;; Set compilation-error-list to nil, and unchain the markers that point to the -;; error messages and their text, so that they no longer slow down gap motion. -;; This would happen anyway at the next garbage collection, but it is better to -;; do it right away. -(defun compilation-forget-errors () - (while compilation-old-error-list - (let ((next-error (car compilation-old-error-list))) - (set-marker (car next-error) nil) - (if (markerp (cdr next-error)) - (set-marker (cdr next-error) nil))) - (setq compilation-old-error-list (cdr compilation-old-error-list))) - (setq compilation-error-list nil - compilation-directory-stack nil - compilation-parsing-end 1) - ;; Remove the highlighting added by compile-reinitialize-errors: - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(mouse-face highlight))) - ) - - -(defun count-regexp-groupings (regexp) - "Return the number of \\( ... \\) groupings in REGEXP (a string)." - (let ((groupings 0) - (len (length regexp)) - (i 0) - c) - (while (< i len) - (setq c (aref regexp i) - i (1+ i)) - (cond ((= c ?\[) - ;; Find the end of this [...]. - (while (and (< i len) - (not (= (aref regexp i) ?\]))) - (setq i (1+ i)))) - ((= c ?\\) - (if (< i len) - (progn - (setq c (aref regexp i) - i (1+ i)) - (if (= c ?\)) - ;; We found the end of a grouping, - ;; so bump our counter. - (setq groupings (1+ groupings)))))))) - groupings)) - -(defun compilation-parse-errors (limit-search find-at-least) - "Parse the current buffer as grep, cc or lint error messages. -See variable `compilation-parse-errors-function' for the interface it uses." - (setq compilation-error-list nil) - (message "Parsing error messages...") - (let (text-buffer orig orig-expanded parent-expanded - regexp enter-group leave-group error-group - alist subexpr error-regexp-groups - (found-desired nil) - (compilation-num-errors-found 0)) - - ;; Don't reparse messages already seen at last parse. - (goto-char compilation-parsing-end) - ;; Don't parse the first two lines as error messages. - ;; This matters for grep. - (if (bobp) - (progn - (forward-line 2) - ;; Move back so point is before the newline. - ;; This matters because some error regexps use \n instead of ^ - ;; to be faster. - (forward-char -1))) - - ;; Compile all the regexps we want to search for into one. - (setq regexp (concat "\\(" compilation-enter-directory-regexp "\\)\\|" - "\\(" compilation-leave-directory-regexp "\\)\\|" - "\\(" (mapconcat (function - (lambda (elt) - (concat "\\(" (car elt) "\\)"))) - compilation-error-regexp-alist - "\\|") "\\)")) - - ;; Find out how many \(...\) groupings are in each of the regexps, and set - ;; *-GROUP to the grouping containing each constituent regexp (whose - ;; subgroups will come immediately thereafter) of the big regexp we have - ;; just constructed. - (setq enter-group 1 - leave-group (+ enter-group - (count-regexp-groupings - compilation-enter-directory-regexp) - 1) - error-group (+ leave-group - (count-regexp-groupings - compilation-leave-directory-regexp) - 1)) - - ;; Compile an alist (IDX FILE LINE [COL]), where IDX is the number of - ;; the subexpression for an entire error-regexp, and FILE and LINE (and - ;; possibly COL) are the numbers for the subexpressions giving the file - ;; name and line number (and possibly column number). - (setq alist (or compilation-error-regexp-alist - (error "compilation-error-regexp-alist is empty!")) - subexpr (1+ error-group)) - (while alist - (setq error-regexp-groups - (cons (list subexpr - (+ subexpr (nth 1 (car alist))) - (+ subexpr (nth 2 (car alist))) - (and (nth 3 (car alist)) - (+ subexpr (nth 3 (car alist))))) - error-regexp-groups)) - (setq subexpr (+ subexpr 1 (count-regexp-groupings (car (car alist))))) - (setq alist (cdr alist))) - - ;; Set up now the expanded, abbreviated directory variables - ;; that compile-abbreviate-directory will need, so we can - ;; compute them just once here. - (setq orig (abbreviate-file-name default-directory) - orig-expanded (abbreviate-file-name - (file-truename default-directory)) - parent-expanded (abbreviate-file-name - (expand-file-name "../" orig-expanded))) - - (while (and (not found-desired) - ;; We don't just pass LIMIT-SEARCH to re-search-forward - ;; because we want to find matches containing LIMIT-SEARCH - ;; but which extend past it. - (re-search-forward regexp nil t)) - - ;; Figure out which constituent regexp matched. - (cond ((match-beginning enter-group) - ;; The match was the enter-directory regexp. - (let ((dir - (file-name-as-directory - (expand-file-name - (buffer-substring (match-beginning (+ enter-group 1)) - (match-end (+ enter-group 1))))))) - ;; The directory name in the "entering" message - ;; is a truename. Try to convert it to a form - ;; like what the user typed in. - (setq dir - (compile-abbreviate-directory dir orig orig-expanded - parent-expanded)) - (setq compilation-directory-stack - (cons dir compilation-directory-stack)) - (and (file-directory-p dir) - (setq default-directory dir))) - - (and limit-search (>= (point) limit-search) - ;; The user wanted a specific error, and we're past it. - ;; We do this check here (and in the leave-group case) - ;; rather than at the end of the loop because if the last - ;; thing seen is an error message, we must carefully - ;; discard the last error when it is the first in a new - ;; file (see below in the error-group case). - (setq found-desired t))) - - ((match-beginning leave-group) - ;; The match was the leave-directory regexp. - (let ((beg (match-beginning (+ leave-group 1))) - (stack compilation-directory-stack)) - (if beg - (let ((dir - (file-name-as-directory - (expand-file-name - (buffer-substring beg - (match-end (+ leave-group - 1))))))) - ;; The directory name in the "leaving" message - ;; is a truename. Try to convert it to a form - ;; like what the user typed in. - (setq dir - (compile-abbreviate-directory dir orig orig-expanded - parent-expanded)) - (while (and stack - (not (string-equal (car stack) dir))) - (setq stack (cdr stack))))) - (setq compilation-directory-stack (cdr stack)) - (setq stack (car compilation-directory-stack)) - (if stack - (setq default-directory stack)) - ) - - (and limit-search (>= (point) limit-search) - ;; The user wanted a specific error, and we're past it. - ;; We do this check here (and in the enter-group case) - ;; rather than at the end of the loop because if the last - ;; thing seen is an error message, we must carefully - ;; discard the last error when it is the first in a new - ;; file (see below in the error-group case). - (setq found-desired t))) - - ((match-beginning error-group) - ;; The match was the composite error regexp. - ;; Find out which individual regexp matched. - (setq alist error-regexp-groups) - (while (and alist - (null (match-beginning (car (car alist))))) - (setq alist (cdr alist))) - (if alist - (setq alist (car alist)) - (error "compilation-parse-errors: impossible regexp match!")) - - ;; Extract the file name and line number from the error message. - (let ((beginning-of-match (match-beginning 0)) ;looking-at nukes - (filename (buffer-substring (match-beginning (nth 1 alist)) - (match-end (nth 1 alist)))) - (linenum (string-to-int - (buffer-substring - (match-beginning (nth 2 alist)) - (match-end (nth 2 alist))))) - (column (and (nth 3 alist) - (match-beginning (nth 3 alist)) - (string-to-int - (buffer-substring - (match-beginning (nth 3 alist)) - (match-end (nth 3 alist))))))) - - ;; Check for a comint-file-name-prefix and prepend it if - ;; appropriate. (This is very useful for - ;; compilation-minor-mode in an rlogin-mode buffer.) - (and (boundp 'comint-file-name-prefix) - ;; If the file name is relative, default-directory will - ;; already contain the comint-file-name-prefix (done by - ;; compile-abbreviate-directory). - (file-name-absolute-p filename) - (setq filename (concat comint-file-name-prefix filename))) - - ;; Some compilers (e.g. Sun's java compiler, reportedly) - ;; produce bogus file names like "./bar//foo.c" for the file - ;; "bar/foo.c"; expand-file-name will collapse these into - ;; "/foo.c" and fail to find the appropriate file. So we look - ;; for doubled slashes in the file name and fix them up in the - ;; buffer. - (setq filename (command-line-normalize-file-name filename)) - (setq filename (cons filename (cons default-directory - (nthcdr 4 alist)))) - - - ;; Locate the erring file and line. - ;; Cons a new elt onto compilation-error-list, - ;; giving a marker for the current compilation buffer - ;; location, and the file and line number of the error. - (save-excursion - ;; Save as the start of the error the beginning of the - ;; line containing the match unless the match starts at a - ;; newline, in which case the beginning of the next line. - (goto-char beginning-of-match) - (forward-line (if (eolp) 1 0)) - (let ((this (cons (point-marker) - (list filename linenum column)))) - ;; Don't add the same source line more than once. - (if (and compilation-skip-to-next-location - (equal (cdr this) - (cdr (car compilation-error-list)))) - nil - (setq compilation-error-list - (cons this - compilation-error-list)) - (setq compilation-num-errors-found - (1+ compilation-num-errors-found))))) - (and (or (and find-at-least (> compilation-num-errors-found - find-at-least)) - (and limit-search (>= (point) limit-search))) - ;; We have found as many new errors as the user wants, - ;; or past the buffer position he indicated. We - ;; continue to parse until we have seen all the - ;; consecutive errors in the same file, so the error - ;; positions will be recorded as markers in this buffer - ;; that might change. - (cdr compilation-error-list) ; Must check at least two. - (not (equal (car (cdr (nth 0 compilation-error-list))) - (car (cdr (nth 1 compilation-error-list))))) - (progn - ;; Discard the error just parsed, so that the next - ;; parsing run can get it and the following errors in - ;; the same file all at once. If we didn't do this, we - ;; would have the same problem we are trying to avoid - ;; with the test above, just delayed until the next run! - (setq compilation-error-list - (cdr compilation-error-list)) - (goto-char beginning-of-match) - (setq found-desired t))) - ) - ) - (t - (error "compilation-parse-errors: known groups didn't match!"))) - - (message "Parsing error messages...%d (%.0f%% of buffer)" - compilation-num-errors-found - ;; Use floating-point because (* 100 (point)) frequently - ;; exceeds the range of Emacs Lisp integers. - (/ (* 100.0 (point)) (point-max))) - - (and limit-search (>= (point) limit-search) - ;; The user wanted a specific error, and we're past it. - (setq found-desired t))) - (setq compilation-parsing-end (if found-desired - (point) - ;; We have searched the whole buffer. - (point-max)))) - (setq compilation-error-list (nreverse compilation-error-list)) - (message "Parsing error messages...done")) - -;; If directory DIR is a subdir of ORIG or of ORIG's parent, -;; return a relative name for it starting from ORIG or its parent. -;; ORIG-EXPANDED is an expanded version of ORIG. -;; PARENT-EXPANDED is an expanded version of ORIG's parent. -;; Those two args could be computed here, but we run faster by -;; having the caller compute them just once. -(defun compile-abbreviate-directory (dir orig orig-expanded parent-expanded) - ;; Apply canonical abbreviations to DIR first thing. - ;; Those abbreviations are already done in the other arguments passed. - (setq dir (abbreviate-file-name dir)) - - ;; Check for a comint-file-name-prefix and prepend it if appropriate. - ;; (This is very useful for compilation-minor-mode in an rlogin-mode - ;; buffer.) - (if (boundp 'comint-file-name-prefix) - (setq dir (concat comint-file-name-prefix dir))) - - (if (and (> (length dir) (length orig-expanded)) - (string= orig-expanded - (substring dir 0 (length orig-expanded)))) - (setq dir - (concat orig - (substring dir (length orig-expanded))))) - (if (and (> (length dir) (length parent-expanded)) - (string= parent-expanded - (substring dir 0 (length parent-expanded)))) - (setq dir - (concat (file-name-directory - (directory-file-name orig)) - (substring dir (length parent-expanded))))) - dir) - -(provide 'compile) - -;;; compile.el ends here diff --git a/lisp/progmodes/cplus-md.el b/lisp/progmodes/cplus-md.el deleted file mode 100644 index 9848adcf40b..00000000000 --- a/lisp/progmodes/cplus-md.el +++ /dev/null @@ -1,1061 +0,0 @@ -;;; cplus-md.el --- C++ code editing commands for Emacs - -;; Copyright (C) 1985, 1992, 1994, 1995 Free Software Foundation, Inc. - -;; Maintainer: Dave Detlefs <dld@cs.cmu.edu> -;; Keywords: c - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; 1987 Dave Detlefs <dld@cs.cmu.edu> -;; and Stewart Clamen <clamen@cs.cmu.edu>. -;; Done by fairly faithful modification of: - -;;; Change Log: - -;; Feb, 1990 (Dave Detlefs, dld@cs.cmu.edu) -;; Fixed electric-c++-terminator to handle double colons, at the -;; request of John Hagerman. -;; -;; Jan, 1990 (Doug Lea, dl@oswego.edu) -;; Replaced c++-comment-region and c++-uncomment-region with -;; versions from Igor Metz that avoid potential infinite loops. -;; -;; Oct, 1989 (Dave Detlefs, dld@cs.cmu.edu) -;; Added contribution from Igor Metz <metz@iam.unibe.ch>: -;; functions c++-comment-region and c++-uncomment-region and -;; corresponding key-binding. -;; Also fixed bug in indentation of second line after an empty -;; arglist with empty-arglist non-null. -;; -;; Sept, 1989 (Glen Ditchfield, gjditchfield@violet.uwaterloo.ca): -;; Textual changes to more closely imitate Emacs 18.55's c-mode. -;; Fixed handling of "default:", where ":" was the last character in the -;; buffer. Fixed indentation of comments starting in column 0, and when -;; previous line contained more than one comment start string. Fixed -;; handling of "friend". -;; -;; Aug 7, 1989; John Hagerman (hagerman@ece.cmu.edu): -;; Changed calculate-c++-indent to handle member initializations -;; more flexibly. Two new variables are used to control behavior: -;; c++-member-init-indent and c++-continued-member-init-offset. -;; Note the assumption that member initializations and argument -;; declarations are not mixed in one function definition. -;; -;; June 1989 (Dave Detlefs, dld@cs.cmu.edu) -;; Fixed calculate-c++-indent to handle continued lines ending in -;; {'s. (I wasn't following C-mode closely enough, or C-mode -;; changed.) Made ' a quote character, at the behest of someone -;; whose mail I apparently deleted (if they send me mail I'll credit -;; them here in a future revision.) -;; Dan Weinreb (dlw@odi.com) pointed out that 'c++-mode successively -;; bound c++-indent-exp and c++-indent-defun to ESC-^q. ESC-^q is -;; now bound to c++-indent-exp, while, c++-indent-defun is invoked -;; with ESC-^x. - -;; February 1989 (Dave Detlefs, dld@cs.cmu.edu) -;; Fixed some errors in c++-indent-defun, as pointed out by Sam -;; Haradhvala (odi!sam@talcott.harvard.edu). -;; October 1988 (Dave Detlefs, dld@cs.cmu.edu) -;; It turns out I had only *thought* I had made -;; beginning(end)-of-defun work. It should work better now -- you -;; can either attempt to match defun headers "strongly," using a -;; very complicated regexp, or "weakly," using a simple one. This -;; is settable by a variable; the default is the cheaper weak -;; method. (Stewart Clamen was intimately involved in this, too.) -;; -;; I made "'" *not* be a string delimiter, because that was causing -;; comments containing contractions to ("// don't") to mess up paren -;; balancing. -;; -;; I also incorporated another slight indentation fix from Glen -;; Ditchfield. -;; -;; We hope this is will make into version 19 of gnu-emacs. -;; -;; September 1988: incorporated changes from Fred Calm at Schlumberger. -;; Also, made beginning(end)-of-defun, indent-defun work. -;; -;; August 1987: incorporated changes done by Glen Ditchfield of Waterloo. - -;;; Code: - -(defvar c++-mode-abbrev-table nil - "Abbrev table used in C++ mode.") -(define-abbrev-table 'c++-mode-abbrev-table ()) - -(defvar c++-mode-map () - "Keymap used in C++ mode.") -(if c++-mode-map - () - (setq c++-mode-map (make-sparse-keymap)) - (define-key c++-mode-map "\C-j" 'reindent-then-newline-and-indent) - (define-key c++-mode-map "{" 'electric-c++-brace) - (define-key c++-mode-map "}" 'electric-c++-brace) - (define-key c++-mode-map ";" 'electric-c++-semi) - (define-key c++-mode-map "\e\C-h" 'mark-c-function) - (define-key c++-mode-map "\e\C-q" 'indent-c++-exp) - (define-key c++-mode-map "\177" 'backward-delete-char-untabify) - (define-key c++-mode-map "\t" 'c++-indent-command) -;; (define-key c++-mode-map "\C-c\C-i" 'c++-insert-header) - (define-key c++-mode-map "\C-c\C-\\" 'c-backslash-region)) -;; (define-key c++-mode-map "\e\C-a" 'c++-beginning-of-defun) -;; (define-key c++-mode-map "\e\C-e" 'c++-end-of-defun) -;; (define-key c++-mode-map "\e\C-x" 'c++-indent-defun)) - -(defvar c++-mode-syntax-table nil - "Syntax table used in C++ mode.") - -(if c++-mode-syntax-table - () - (setq c++-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" c++-mode-syntax-table) - (modify-syntax-entry ?/ ". 14" c++-mode-syntax-table) - (modify-syntax-entry ?* ". 23" c++-mode-syntax-table) - (modify-syntax-entry ?+ "." c++-mode-syntax-table) - (modify-syntax-entry ?- "." c++-mode-syntax-table) - (modify-syntax-entry ?= "." c++-mode-syntax-table) - (modify-syntax-entry ?% "." c++-mode-syntax-table) - (modify-syntax-entry ?< "." c++-mode-syntax-table) - (modify-syntax-entry ?> "." c++-mode-syntax-table) - (modify-syntax-entry ?& "." c++-mode-syntax-table) - (modify-syntax-entry ?| "." c++-mode-syntax-table) - (modify-syntax-entry ?\' "\"" c++-mode-syntax-table) - (modify-syntax-entry ?* ". 23b" c++-mode-syntax-table) - (modify-syntax-entry ?/ ". 124" c++-mode-syntax-table) - (modify-syntax-entry ?\n ">" c++-mode-syntax-table) - (modify-syntax-entry ?\^m ">" c++-mode-syntax-table)) - -(defvar c++-continued-member-init-offset nil - "*Extra indent for continuation lines of member inits; -nil means to align with previous initializations rather than -with the colon on the first line.") -(defvar c++-member-init-indent 0 - "*Indentation level of member initializations in function declarations.") -(defvar c++-friend-offset -4 - "*Offset of C++ friend declarations relative to member declarations.") -(defvar c++-electric-colon t - "*If t, colon is an electric terminator.") -(defvar c++-empty-arglist-indent nil - "*Indicates how far to indent an line following an empty argument -list. Nil indicates to just after the paren.") - -(defvar c++-imenu-generic-expression - (` - ((nil - (, - (concat - "^" ; beginning of line is required - "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>" - "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no - "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right? - - "\\(" ; last type spec including */& - "[a-zA-Z0-9_:]+" - "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace - "\\)?" ; if there is a last type spec - "\\(" ; name; take that into the imenu entry - "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor... - ; (may not contain * because then - ; "a::operator char*" would become "char*"!) - "\\|" - "\\([a-zA-Z0-9_:~]*::\\)?operator" - "[^a-zA-Z1-9_][^(]*" ; ...or operator - " \\)" - "[ \t]*([^)]*)[ \t\n]*[^ ;]" ; require something other than a ; after - ; the (...) to avoid prototypes. Can't - ; catch cases with () inside the parentheses - ; surrounding the parameters - ; (like "int foo(int a=bar()) {...}" - - )) 6) - ("Class" - (, (concat - "^" ; beginning of line is required - "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>" - "class[ \t]+" - "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get - "[ \t]*[:{]" - )) 2) -;; Example of generic expression for finding prototypes, structs, unions, enums. -;; Uncomment if you want to find these too. It will be a bit slower gathering -;; the indexes. -; ("Prototypes" -; (, -; (concat -; "^" ; beginning of line is required -; "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>" -; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no -; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right? - -; "\\(" ; last type spec including */& -; "[a-zA-Z0-9_:]+" -; "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace -; "\\)?" ; if there is a last type spec -; "\\(" ; name; take that into the imenu entry -; "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor... -; ; (may not contain * because then -; ; "a::operator char*" would become "char*"!) -; "\\|" -; "\\([a-zA-Z0-9_:~]*::\\)?operator" -; "[^a-zA-Z1-9_][^(]*" ; ...or operator -; " \\)" -; "[ \t]*([^)]*)[ \t\n]*;" ; require ';' after -; ; the (...) Can't -; ; catch cases with () inside the parentheses -; ; surrounding the parameters -; ; (like "int foo(int a=bar());" -; )) 6) -; ("Struct" -; (, (concat -; "^" ; beginning of line is required -; "\\(static[ \t]+\\)?" ; there may be static or const. -; "\\(const[ \t]+\\)?" -; "struct[ \t]+" -; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get -; "[ \t]*[{]" -; )) 3) -; ("Enum" -; (, (concat -; "^" ; beginning of line is required -; "\\(static[ \t]+\\)?" ; there may be static or const. -; "\\(const[ \t]+\\)?" -; "enum[ \t]+" -; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get -; "[ \t]*[{]" -; )) 3) -; ("Union" -; (, (concat -; "^" ; beginning of line is required -; "\\(static[ \t]+\\)?" ; there may be static or const. -; "\\(const[ \t]+\\)?" -; "union[ \t]+" -; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get -; "[ \t]*[{]" -; )) 3) - )) - "Imenu generic expression for C++ mode. See `imenu-generic-expression'.") - -(defun c++-mode () - "Major mode for editing C++ code. Very much like editing C code. -Expression and list commands understand all C++ brackets. -Tab at left margin indents for C++ code -Comments are delimited with /* ... */ {or with // ... <newline>} -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{c++-mode-map} -Variables controlling indentation style: - c-tab-always-indent - Non-nil means TAB in C mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - Default is t. - c-auto-newline - Non-nil means automatically newline before and after braces, - and after colons and semicolons, inserted in C code. - c-indent-level - Indentation of C statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - c-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - c-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to c-continued-statement-offset. - c-brace-offset - Extra indentation for line if it starts with an open brace. - c-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - c-argdecl-indent - Indentation level of declarations of C function arguments. - c-label-offset - Extra indentation for line that is a label, or case or ``default:'', or - ``public:'' or ``private:'', or ``protected:''. - c++-electric-colon - If non-nil at invocation of c++-mode (t is the default) colon electrically - indents. - c++-empty-arglist-indent - If non-nil, a function declaration or invocation which ends a line with a - left paren is indented this many extra spaces, instead of flush with the - left paren. - c++-friend-offset - Offset of C++ friend declarations relative to member declarations. - c++-member-init-indent - Indentation level of member initializations in function declarations, - if they are on a separate line beginning with a colon. - c++-continued-member-init-offset - Extra indentation for continuation lines of member initializations; NIL - means to align with previous initializations rather than with the colon. - -Settings for K&R, BSD, and Stroustrup indentation styles are - c-indent-level 5 8 4 - c-continued-statement-offset 5 8 4 - c-continued-brace-offset 0 - c-brace-offset -5 -8 0 - c-brace-imaginary-offset 0 - c-argdecl-indent 0 8 4 - c-label-offset -5 -8 -4 - c++-empty-arglist-indent 4 - c++-friend-offset 0 - -Turning on C++ mode calls the value of the variable `c++-mode-hook' with -no args if that value is non-nil." - (interactive) - (kill-all-local-variables) - ;; This code depends on the old C mode. - (require 'c-mode) - (use-local-map c++-mode-map) - (set-syntax-table c++-mode-syntax-table) - (setq major-mode 'c++-mode - mode-name "C++" - comment-column 32 - local-abbrev-table c++-mode-abbrev-table) - (set (make-local-variable 'indent-line-function) 'c++-indent-line) - (set (make-local-variable 'comment-start) "// ") - (set (make-local-variable 'comment-end) "") - (set (make-local-variable 'comment-start-skip) "/\\*+ *\\|// *") - (set (make-local-variable 'comment-indent-function) 'c++-comment-indent) - (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter)) - (set (make-local-variable 'paragraph-separate) paragraph-start) - (set (make-local-variable 'paragraph-ignore-fill-prefix) t) - (set (make-local-variable 'require-final-newline) t) - (set (make-local-variable 'parse-sexp-ignore-comments) t) - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression c++-imenu-generic-expression) - (run-hooks 'c++-mode-hook) - (if c++-electric-colon - (define-key c++-mode-map ":" 'electric-c++-terminator))) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in C++ code -;; based on its context. -(defun c++-comment-indent () - (if (looking-at "^\\(/\\*\\|//\\)") - 0 ; Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max - ;; Leave at least one space on non-empty lines. - (if (zerop (current-column)) 0 (1+ (current-column))) - (let ((cur-pt (point))) - (beginning-of-line 0) - ;; If previous line had a comment, use its indentation. - (if (re-search-forward comment-start-skip cur-pt t) - (progn - (goto-char (match-beginning 0)) - (current-column)) - comment-column)))))) ; otherwise indent at comment column. - -(defun electric-c++-brace (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos) - (if (and (not arg) - (eolp) - (or (save-excursion - (skip-chars-backward " \t") - (bolp)) - (if c-auto-newline (progn (c++-indent-line) (newline) t)))) - (progn - (insert last-command-char) - (c++-indent-line) - (if c-auto-newline - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (c++-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun electric-c++-semi (arg) - "Insert character and correct line's indentation." - (interactive "P") - (if c-auto-newline - (electric-c++-terminator arg) - (self-insert-command (prefix-numeric-value arg)))) - -(defun electric-c++-terminator (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos (end (point))) - (if (and (not arg) (eolp) - (not (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (or (= (following-char) ?#) - ;; Colon is special only after a label, or - ;; case, or another colon. - ;; So quickly rule out most other uses of colon - ;; and do no indentation for them. - (and (eq last-command-char ?:) - (or (not (or (looking-at "case[ \t]") - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (>= (point) end)))) - ;; Do re-indent double colons - (save-excursion - (end-of-line 1) - (looking-at ":")))) - (progn - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) end))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) - (progn - (insert last-command-char) - (c++-indent-line) - (and c-auto-newline - (not (c-inside-parens-p)) - (progn - ;; the new marker object, used to be just an integer - (setq insertpos (make-marker)) - ;; changed setq to set-marker - (set-marker insertpos (1- (point))) - ;; do this before the newline, since in auto fill can break - (newline) - (c-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun c++-indent-command (&optional whole-exp) - "Indent current line as C++ code, or in some cases insert a tab character. -If `c-tab-always-indent' is non-nil (the default), always indent current -line. Otherwise, indent the current line only if point is at the left -margin or in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, means indent rigidly all means -indent rigidly all the lines of the expression starting after point so that -this line becomes properly indented. The relative indentation among the -lines of the expression are preserved." - (interactive "P") - (if whole-exp - ;; If arg, always indent this line as C - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (c++-indent-line)) - beg end) - (save-excursion - (if c-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not c-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (c++-indent-line)))) - -(defun c++-indent-line () - "Indent current line as C++ code. -Return the amount the indentation changed by." - (let ((indent (calculate-c++-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - ((eq indent t) - (setq indent (calculate-c-indent-within-comment))) - ((looking-at "[ \t]*#") - (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((looking-at "\\(default\\|public\\|private\\|protected\\):") - (setq indent (+ indent c-label-offset))) - ((or (looking-at "case\\b") - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":[^:]")))) - (setq indent (max 1 (+ indent c-label-offset)))) - ((and (looking-at "else\\b") - (not (looking-at "else\\s_"))) - (setq indent (save-excursion - (c-backward-to-start-of-if) - (current-indentation)))) - ((looking-at "friend\[ \t]") - (setq indent (+ indent c++-friend-offset))) - ((= (following-char) ?}) - (setq indent (- indent c-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent c-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun calculate-c++-indent (&optional parse-start) - "Return appropriate indentation for current line as C++ code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - state - containing-sexp) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; return nil or t if should not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. May be data or function definition, or - ;; may be function argument declaration or member initialization. - ;; Indent like the previous top level line unless - ;; (1) the previous line ends in a closeparen without semicolon, - ;; in which case this line is the first argument declaration or - ;; member initialization, or - ;; (2) the previous line begins with a colon, - ;; in which case this is the second line of member inits. - ;; It is assumed that arg decls and member inits are not mixed. - (goto-char indent-point) - (skip-chars-forward " \t") - (if (= (following-char) ?{) - 0 ; Unless it starts a function body - (c++-backward-to-noncomment (or parse-start (point-min))) - (if (= (preceding-char) ?\)) - (progn ; first arg decl or member init - (goto-char indent-point) - (skip-chars-forward " \t") - (if (= (following-char) ?:) - c++-member-init-indent - c-argdecl-indent)) - (if (= (preceding-char) ?\;) - (backward-char 1)) - (if (= (preceding-char) ?}) - 0 - (if (= (preceding-char) ?\)) - (forward-list -1)) - (beginning-of-line) ; continued arg decls or member inits - (skip-chars-forward " \t") - (if (= (following-char) ?:) - (if c++-continued-member-init-offset - (+ (current-indentation) - c++-continued-member-init-offset) - (progn - (forward-char 1) - (skip-chars-forward " \t") - (current-column))) - (current-indentation))) - ))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open -- unless - ;; empty arg list, in which case we do what - ;; c++-empty-arglist-indent says to do. - (if (and c++-empty-arglist-indent - (or (null (nth 2 state)) ;; indicates empty arg - ;; list. - ;; Use a heuristic: if the first - ;; non-whitespace following left paren on - ;; same line is not a comment, - ;; is not an empty arglist. - (save-excursion - (goto-char (1+ containing-sexp)) - (not - (looking-at "\\( \\|\t\\)*[^/\n]"))))) - (progn - (goto-char containing-sexp) - (beginning-of-line) - (skip-chars-forward " \t") - (goto-char (min (+ (point) c++-empty-arglist-indent) - (1+ containing-sexp))) - (current-column)) - ;; In C-mode, we would always indent to one after the - ;; left paren. Here, though, we may have an - ;; empty-arglist, so we'll indent to the min of that - ;; and the beginning of the first argument. - (goto-char (1+ containing-sexp)) - (current-column))) - (t - ;; Statement. Find previous non-comment character. - (goto-char indent-point) - (c++-backward-to-noncomment containing-sexp) - (if (and (not (memq (preceding-char) '(0 ?\, ?\; ?\} ?\{))) - ;; But don't treat a line with a close-brace - ;; as a continuation. It is probably the - ;; end of an enum type declaration. - (save-excursion - (goto-char indent-point) - (skip-chars-forward " \t") - (not (= (following-char) ?})))) - ;; This line is continuation of preceding line's statement; - ;; indent c-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (c-backward-to-start-of-continued-exp containing-sexp) - (+ c-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (skip-chars-forward " \t") - (eq (following-char) ?{)) - c-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - (let ((colon-line-end 0)) - (while (progn (skip-chars-forward " \t\n") - (looking-at - (concat - "#\\|/\\*\\|//" - "\\|case[ \t]" - "\\|[a-zA-Z0-9_$]*:[^:]" - "\\|friend[ \t]"))) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - (forward-line 1)) - ((looking-at "/\\*") - (search-forward "*/" nil 'move)) - ((looking-at "//\\|friend[ \t]") - (forward-line 1)) - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (- - (if (> colon-line-end (point)) - (- (current-indentation) c-label-offset) - (current-column)) - ;; If prev stmt starts with open-brace, that - ;; open brace was offset by c-brace-offset. - ;; Compensate to get the column where - ;; an ordinary statement would start. - (if (= (following-char) ?\{) c-brace-offset 0))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If c-indent-offset is zero, - ;; use c-brace-offset + c-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in c-brace-imaginary-offset. - (+ (if (and (bolp) (zerop c-indent-level)) - (+ c-brace-offset c-continued-statement-offset) - c-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the c-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 c-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -(defun c++-backward-to-noncomment (lim) - (let (opoint stop) - (while (not stop) - (skip-chars-backward " \t\n\r\f" lim) - (setq opoint (point)) - (cond ((and (>= (point) (+ 2 lim)) - (save-excursion - (forward-char -2) - (looking-at "\\*/"))) - (search-backward "/*" lim 'move)) - ((and - (search-backward "//" (max (c++-point-bol) lim) 'move) - (not (c++-within-string-p (point) opoint)))) - ;; No comment to be found. - ;; If there's a # command on this line, - ;; move back to it. - (t (beginning-of-line) - (skip-chars-forward " \t") - ;; But don't get fooled if we are already before the #. - (if (and (looking-at "#") (< (point) opoint)) - (setq stop (<= (point) lim)) - (setq stop t) - (goto-char opoint))))))) - -(defun indent-c++-exp () - "Indent each line of the C++ grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - restart outer-loop-done inner-loop-done state ostate - this-indent last-sexp last-depth - at-else at-brace - (opoint (point)) - (next-depth 0)) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq inner-loop-done nil) - (while (and (not inner-loop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (c++-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq inner-loop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - ;; If this line had ..))) (((.. in it, pop out of the levels - ;; that ended anywhere in this line, even if the final depth - ;; doesn't indicate that they ended. - (while (> last-depth (nth 6 state)) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (if (/= last-depth next-depth) - (setq last-sexp nil)) - ;; Add levels for any parens that were started in this line. - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack (or (car (cdr state)) - (save-excursion (forward-sexp -1) - (point))))) - (forward-line 1) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - ;; Lines inside parens are handled specially. - nil - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let (val) - (if (= (char-after (car contain-stack)) ?{) - (save-excursion - (goto-char (car contain-stack)) - (setq val (calculate-c-indent-after-brace))) - (setq val (calculate-c++-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack val))) - ;; Adjust line indentation according to its predecessor. - (if (/= (char-after (car contain-stack)) ?\{) - (setq this-indent (car indent-stack)) - ;; Line is at statement level. - ;; Is it a new statement? Is it an else? - ;; Find last non-comment character before this line - (save-excursion - (setq at-else (looking-at "else\\W")) - (setq at-brace (= (following-char) ?\{)) - (c++-backward-to-noncomment opoint) - (if (not (memq (preceding-char) '(nil ?\, ?\; ?\} ?: ?\{))) - ;; Preceding line did not end in comma or semi; - ;; indent this line c-continued-statement-offset - ;; more than previous. - (progn - (c-backward-to-start-of-continued-exp - (car contain-stack)) - (setq this-indent - (+ c-continued-statement-offset - (current-column) - (if at-brace c-continued-brace-offset 0)))) - ;; Preceding line ended in comma or semi; - ;; use the standard indent for this level. - (if at-else - (progn (c-backward-to-start-of-if opoint) - (setq this-indent (current-indentation))) - (setq this-indent (car indent-stack)))))) - ;; Adjust line indentation according to its contents - (if (looking-at "\\(public\\|private\\|protected\\):") - (setq this-indent (- this-indent c-indent-level)) - (if (or (looking-at "case[ \t]") - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":[^:]")))) - (setq this-indent (max 1 (+ this-indent c-label-offset))))) - (if (looking-at "friend[ \t]") - (setq this-indent (+ this-indent c++-friend-offset))) - (if (= (following-char) ?\}) - (setq this-indent (- this-indent c-indent-level))) - (if (= (following-char) ?\{) - (setq this-indent (+ this-indent c-brace-offset))) - ;; Put chosen indentation into effect. - (or (= (current-column) this-indent) - (= (following-char) ?\#) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to this-indent))) - ;; Indent any comment following the text. - (or (looking-at comment-start-skip) - (if (re-search-forward comment-start-skip - (save-excursion (end-of-line) - (point)) t) - (progn - (indent-for-comment) - (beginning-of-line)))))))))) - -(defun fill-c++-comment () - "Fill a comment contained in consecutive lines containing point. -The fill lines remain a comment." - (interactive) - (save-excursion - (let ((save fill-prefix)) - (beginning-of-line 1) - (save-excursion - (re-search-forward comment-start-skip - (save-excursion (end-of-line) (point)) - t) - (goto-char (match-end 0)) - (set-fill-prefix)) - (while (looking-at fill-prefix) - (previous-line 1)) - (next-line 1) - (insert-string "\n") - (fill-paragraph nil) - (delete-char -1) - (setq fill-prefix save)))) - -(defun c++-point-bol () - "Returns the value of the point at the beginning of the current line." - (save-excursion - (beginning-of-line) - (point))) - -;; (defun c++-insert-header () -;; "Insert header denoting C++ code at top of buffer." -;; (interactive) -;; (save-excursion -;; (goto-char (point-min)) -;; (insert "// " -;; "This may look like C code, but it is really " -;; "-*- C++ -*-" -;; "\n\n"))) - -(defun c++-within-string-p (point1 point2) - "Returns true if number of double quotes between two points is odd." - (let ((s (buffer-substring point1 point2))) - (not (zerop (% (c++-count-char-in-string ?\" s) 2))))) - -(defun c++-count-char-in-string (c s) - (let ((count 0) - (pos 0)) - (while (< pos (length s)) - (setq count (+ count (if (\= (aref s pos) c) 1 0))) - (setq pos (1+ pos))) - count)) - -;; rms: This page is creeping featurism, and not worth having. - -;;; Below are two regular expressions that attempt to match defuns -;;; "strongly" and "weakly." The strong one almost reconstructs the -;;; grammar of C++; the weak one just figures anything id or curly on -;;; the left begins a defun. The constant "c++-match-header-strongly" -;;; determines which to use; the default is the weak one. - -;; (defvar c++-match-header-strongly nil -;; "*If nil, use `c++-defun-header-weak' to identify beginning of definitions. -;; If non-nil, use `c++-defun-header-strong'.") -;; -;; (defvar c++-defun-header-strong-struct-equivs "\\(class\\|struct\\|enum\\)" -;; "Regexp to match names of structure declaration blocks in C++.") -;; -;; (defconst c++-defun-header-strong -;; (let* -;; (; valid identifiers -;; ;; There's a real weirdness here -- if I switch the below -;; (id "\\(\\w\\|_\\)+") -;; ;; to be -;; ;; (id "\\(_\\|\\w\\)+") -;; ;; things no longer work right. Try it and see! -;; -;; ; overloadable operators -;; (op-sym1 -;; "[-+*/%^&|~!=<>]\\|[-+*/%^&|<>=!]=\\|<<=?\\|>>=?") -;; (op-sym2 -;; "&&\\|||\\|\\+\\+\\|--\\|()\\|\\[\\]") -;; (op-sym (concat "\\(" op-sym1 "\\|" op-sym2 "\\)")) -;; ; whitespace -;; (middle "[^\\*]*\\(\\*+[^/\\*][^\\*]*\\)*") -;; (c-comment (concat "/\\*" middle "\\*+/")) -;; (wh (concat "\\(\\s \\|\n\\|//.*$\\|" c-comment "\\)")) -;; (wh-opt (concat wh "*")) -;; (wh-nec (concat wh "+")) -;; (oper (concat "\\(" "operator" "\\(" -;; wh-opt op-sym "\\|" wh-nec id "\\)" "\\)")) -;; (dcl-list "([^():]*)") -;; (func-name (concat "\\(" oper "\\|" id "::" id "\\|" id "\\)")) -;; (inits -;; (concat "\\(:" -;; "\\(" wh-opt id "(.*\\()" wh-opt "," "\\)\\)*" -;; wh-opt id "(.*)" wh-opt "{" -;; "\\|" wh-opt "{\\)")) -;; (type-name (concat -;; "\\(" c++-defun-header-strong-struct-equivs wh-nec "\\)?" -;; id)) -;; (type (concat "\\(const" wh-nec "\\)?" -;; "\\(" type-name "\\|" type-name wh-opt "\\*+" "\\|" -;; type-name wh-opt "&" "\\)")) -;; (modifier "\\(inline\\|virtual\\|overload\\|auto\\|static\\)") -;; (modifiers (concat "\\(" modifier wh-nec "\\)*")) -;; (func-header -;; ;; type arg-dcl -;; (concat modifiers type wh-nec func-name wh-opt dcl-list wh-opt inits)) -;; (inherit (concat "\\(:" wh-opt "\\(public\\|private\\)?" -;; wh-nec id "\\)")) -;; (cs-header (concat -;; c++-defun-header-strong-struct-equivs -;; wh-nec id wh-opt inherit "?" wh-opt "{"))) -;; (concat "^\\(" func-header "\\|" cs-header "\\)")) -;; "Strongly-defined regexp to match beginning of structure or function def.") -;; -;; -;; ;; This part has to do with recognizing defuns. -;; -;; ;; The weak convention we will use is that a defun begins any time -;; ;; there is a left curly brace, or some identifier on the left margin, -;; ;; followed by a left curly somewhere on the line. (This will also -;; ;; incorrectly match some continued strings, but this is after all -;; ;; just a weak heuristic.) Suggestions for improvement (short of the -;; ;; strong scheme shown above) are welcomed. -;; -;; (defconst c++-defun-header-weak "^{\\|^[_a-zA-Z].*{" -;; "Weakly-defined regexp to match beginning of structure or function def.") -;; -;; (defun c++-beginning-of-defun (arg) -;; (interactive "p") -;; (let ((c++-defun-header (if c++-match-header-strongly -;; c++-defun-header-strong -;; c++-defun-header-weak))) -;; (cond ((or (= arg 0) (and (> arg 0) (bobp))) nil) -;; ((and (not (looking-at c++-defun-header)) -;; (let ((curr-pos (point)) -;; (open-pos (if (search-forward "{" nil 'move) -;; (point))) -;; (beg-pos -;; (if (re-search-backward c++-defun-header nil 'move) -;; (match-beginning 0)))) -;; (if (and open-pos beg-pos -;; (< beg-pos curr-pos) -;; (> open-pos curr-pos)) -;; (progn -;; (goto-char beg-pos) -;; (if (= arg 1) t nil));; Are we done? -;; (goto-char curr-pos) -;; nil)))) -;; (t -;; (if (and (looking-at c++-defun-header) (not (bobp))) -;; (forward-char (if (< arg 0) 1 -1))) -;; (and (re-search-backward c++-defun-header nil 'move (or arg 1)) -;; (goto-char (match-beginning 0))))))) -;; -;; -;; (defun c++-end-of-defun (arg) -;; (interactive "p") -;; (let ((c++-defun-header (if c++-match-header-strongly -;; c++-defun-header-strong -;; c++-defun-header-weak))) -;; (if (and (eobp) (> arg 0)) -;; nil -;; (if (and (> arg 0) (looking-at c++-defun-header)) (forward-char 1)) -;; (let ((pos (point))) -;; (c++-beginning-of-defun -;; (if (< arg 0) -;; (- (- arg (if (eobp) 0 1))) -;; arg)) -;; (if (and (< arg 0) (bobp)) -;; t -;; (if (re-search-forward c++-defun-header nil 'move) -;; (progn (forward-char -1) -;; (forward-sexp) -;; (beginning-of-line 2))) -;; (if (and (= pos (point)) -;; (re-search-forward c++-defun-header nil 'move)) -;; (c++-end-of-defun 1)))) -;; t))) -;; -;; (defun c++-indent-defun () -;; "Indents the current function definition, struct or class declaration." -;; (interactive) -;; (let ((restore (point))) -;; (c++-end-of-defun 1) -;; (beginning-of-line 1) -;; (let ((end (point))) -;; (c++-beginning-of-defun 1) -;; (while (<= (point) end) -;; (c++-indent-line) -;; (next-line 1) -;; (beginning-of-line 1))) -;; (goto-char restore))) - -;;; cplus-md.el ends here diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el deleted file mode 100644 index fa0ed911e2e..00000000000 --- a/lisp/progmodes/cpp.el +++ /dev/null @@ -1,782 +0,0 @@ -;;; cpp.el --- Highlight or hide text according to cpp conditionals. - -;; Copyright (C) 1994, 1995 Free Software Foundation - -;; Author: Per Abrahamsen <abraham@iesd.auc.dk> -;; Keywords: c, faces, tools - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Parse a text for C preprocessor conditionals, and highlight or hide -;; the text inside the conditionals as you wish. - -;; This package is inspired by Jim Coplien's delta editor for SCCS. - -;;; Todo: - -;; Should parse "#if" and "#elif" expressions and merge the faces -;; somehow. - -;; Somehow it is sometimes possible to make changes near a read only -;; area which you can't undo. Their are other strange effects in that -;; area. - -;; The Edit buffer should -- optionally -- appear in its own frame. - -;; Conditionals seem to be rear-sticky. They shouldn't be. - -;; Restore window configurations when exiting CPP Edit buffer. - -;;; Code: - -;;; Customization: - -(defvar cpp-config-file (convert-standard-filename ".cpp.el") - "*File name to save cpp configuration.") - -(defvar cpp-known-face 'invisible - "*Face used for known cpp symbols.") - -(defvar cpp-unknown-face 'highlight - "*Face used for unknown cpp symbols.") - -(defvar cpp-face-type 'light - "*Indicate what background face type you prefer. -Can be either light or dark for color screens, mono for monochrome -screens, and none if you don't use a window system.") - -(defvar cpp-known-writable t - "*Non-nil means you are allowed to modify the known conditionals.") - -(defvar cpp-unknown-writable t - "*Non-nil means you are allowed to modify the unknown conditionals.") - -(defvar cpp-edit-list nil - "Alist of cpp macros and information about how they should be displayed. -Each entry is a list with the following elements: -0. The name of the macro (a string). -1. Face used for text that is `ifdef' the macro. -2. Face used for text that is `ifndef' the macro. -3. `t', `nil', or `both' depending on what text may be edited.") - -(defvar cpp-overlay-list nil) -;; List of cpp overlays active in the current buffer. -(make-variable-buffer-local 'cpp-overlay-list) - -(defvar cpp-callback-data) -(defvar cpp-state-stack) - -(defconst cpp-face-type-list - '(("light color background" . light) - ("dark color background" . dark) - ("monochrome" . mono) - ("tty" . none)) - "Alist of strings and names of the defined face collections.") - -(defconst cpp-writable-list - ;; Names used for the writable property. - '(("writable" . t) - ("read-only" . nil))) - -(defvar cpp-button-event nil) -;; This will be t in the callback for `cpp-make-button'. - -(defvar cpp-edit-buffer nil) -;; Real buffer whose cpp display information we are editing. -(make-variable-buffer-local 'cpp-edit-buffer) - -(defconst cpp-branch-list - ;; Alist of branches. - '(("false" . nil) - ("true" . t) - ("both" . both))) - -(defvar cpp-face-default-list nil - "List of faces you can choose from for cpp conditionals.") - -(defvar cpp-face-light-name-list - '("light gray" "light blue" "light cyan" "light yellow" "light pink" - "pale green" "beige" "orange" "magenta" "violet" "medium purple" - "turquoise") - "Background colours useful with dark foreground colors.") - -(defvar cpp-face-dark-name-list - '("dim gray" "blue" "cyan" "yellow" "red" - "dark green" "brown" "dark orange" "dark khaki" "dark violet" "purple" - "dark turquoise") - "Background colours useful with light foreground colors.") - -(defvar cpp-face-light-list nil - "Alist of names and faces to be used for light backgrounds.") - -(defvar cpp-face-dark-list nil - "Alist of names and faces to be used for dark backgrounds.") - -(defvar cpp-face-mono-list - '(("bold" . 'bold) - ("bold-italic" . 'bold-italic) - ("italic" . 'italic) - ("underline" . 'underline)) - "Alist of names and faces to be used for monochrome screens.") - -(defvar cpp-face-none-list - '(("default" . default) - ("invisible" . invisible)) - "Alist of names and faces available even if you don't use a window system.") - -(defvar cpp-face-all-list - (append cpp-face-light-list - cpp-face-dark-list - cpp-face-mono-list - cpp-face-none-list) - "All faces used for highlighting text inside cpp conditionals.") - -;;; Parse Buffer: - -(defvar cpp-parse-symbols nil - "List of cpp macros used in the local buffer.") -(make-variable-buffer-local 'cpp-parse-symbols) - -(defconst cpp-parse-regexp - ;; Regexp matching all tokens needed to find conditionals. - (concat - "'\\|\"\\|/\\*\\|//\\|" - "\\(^[ \t]*#[ \t]*\\(ifdef\\|ifndef\\|if\\|" - "elif\\|else\\|endif\\)\\b\\)")) - -;;;###autoload -(defun cpp-highlight-buffer (arg) - "Highlight C code according to preprocessor conditionals. -This command pops up a buffer which you should edit to specify -what kind of highlighting to use, and the criteria for highlighting. -A prefix arg suppresses display of that buffer." - (interactive "P") - (setq cpp-parse-symbols nil) - (cpp-parse-reset) - (if (null cpp-edit-list) - (cpp-edit-load)) - (let (cpp-state-stack) - (save-excursion - (goto-char (point-min)) - (cpp-progress-message "Parsing...") - (while (re-search-forward cpp-parse-regexp nil t) - (cpp-progress-message "Parsing...%d%%" - (/ (* 100 (- (point) (point-min))) (buffer-size))) - (let ((match (buffer-substring (match-beginning 0) (match-end 0)))) - (cond ((or (string-equal match "'") - (string-equal match "\"")) - (goto-char (match-beginning 0)) - (condition-case nil - (forward-sexp) - (error (cpp-parse-error - "Unterminated string or character")))) - ((string-equal match "/*") - (or (search-forward "*/" nil t) - (error "Unterminated comment"))) - ((string-equal match "//") - (skip-chars-forward "^\n\r")) - (t - (end-of-line 1) - (let ((from (match-beginning 1)) - (to (1+ (point))) - (type (buffer-substring (match-beginning 2) - (match-end 2))) - (expr (buffer-substring (match-end 1) (point)))) - (cond ((string-equal type "ifdef") - (cpp-parse-open t expr from to)) - ((string-equal type "ifndef") - (cpp-parse-open nil expr from to)) - ((string-equal type "if") - (cpp-parse-open t expr from to)) - ((string-equal type "elif") - (let (cpp-known-face cpp-unknown-face) - (cpp-parse-close from to)) - (cpp-parse-open t expr from to)) - ((string-equal type "else") - (or cpp-state-stack - (cpp-parse-error "Top level #else")) - (let ((entry (list (not (nth 0 (car cpp-state-stack))) - (nth 1 (car cpp-state-stack)) - from to))) - (cpp-parse-close from to) - (setq cpp-state-stack (cons entry cpp-state-stack)))) - ((string-equal type "endif") - (cpp-parse-close from to)) - (t - (cpp-parse-error "Parser error")))))))) - (message "Parsing...done")) - (if cpp-state-stack - (save-excursion - (goto-char (nth 3 (car cpp-state-stack))) - (cpp-parse-error "Unclosed conditional")))) - (or arg - (null cpp-parse-symbols) - (cpp-parse-edit))) - -(defun cpp-parse-open (branch expr begin end) - "Push information about conditional-beginning onto `cpp-state-stack'." - ;; Discard comments within this line. - (while (string-match "\\b[ \t]*/\\*.*\\*/[ \t]*\\b" expr) - (setq expr (concat (substring expr 0 (match-beginning 0)) - (substring expr (match-end 0))))) - ;; If a comment starts on this line and continues past, discard it. - (if (string-match "\\b[ \t]*/\\*" expr) - (setq expr (substring expr 0 (match-beginning 0)))) - ;; Delete any C++ comment from the line. - (if (string-match "\\b[ \t]*\\(//.*\\)?$" expr) - (setq expr (substring expr 0 (match-beginning 0)))) - (while (string-match "[ \t]+" expr) - (setq expr (concat (substring expr 0 (match-beginning 0)) - (substring expr (match-end 0))))) - (setq cpp-state-stack (cons (list branch expr begin end) cpp-state-stack)) - (or (member expr cpp-parse-symbols) - (setq cpp-parse-symbols - (cons expr cpp-parse-symbols))) - (if (assoc expr cpp-edit-list) - (cpp-make-known-overlay begin end) - (cpp-make-unknown-overlay begin end))) - -(defun cpp-parse-close (from to) - ;; Pop top of cpp-state-stack and create overlay. - (let ((entry (assoc (nth 1 (car cpp-state-stack)) cpp-edit-list)) - (branch (nth 0 (car cpp-state-stack))) - (begin (nth 2 (car cpp-state-stack))) - (end (nth 3 (car cpp-state-stack)))) - (setq cpp-state-stack (cdr cpp-state-stack)) - (if entry - (let ((face (nth (if branch 1 2) entry)) - (read-only (eq (not branch) (nth 3 entry))) - (priority (length cpp-state-stack)) - (overlay (make-overlay end from))) - (cpp-make-known-overlay from to) - (setq cpp-overlay-list (cons overlay cpp-overlay-list)) - (if priority (overlay-put overlay 'priority priority)) - (cond ((eq face 'invisible) - (cpp-make-overlay-hidden overlay)) - ((eq face 'default)) - (t - (overlay-put overlay 'face face))) - (if read-only - (cpp-make-overlay-read-only overlay) - (cpp-make-overlay-sticky overlay))) - (cpp-make-unknown-overlay from to)))) - -(defun cpp-parse-error (error) - ;; Error message issued by the cpp parser. - (error "%s at line %d" error (count-lines (point-min) (point)))) - -(defun cpp-parse-reset () - "Reset display of cpp conditionals to normal." - (interactive) - (while cpp-overlay-list - (delete-overlay (car cpp-overlay-list)) - (setq cpp-overlay-list (cdr cpp-overlay-list)))) - -;;;###autoload -(defun cpp-parse-edit () - "Edit display information for cpp conditionals." - (interactive) - (or cpp-parse-symbols - (cpp-highlight-buffer t)) - (let ((buffer (current-buffer))) - (pop-to-buffer "*CPP Edit*") - (cpp-edit-mode) - (setq cpp-edit-buffer buffer) - (cpp-edit-reset))) - -;;; Overlays: - -(defun cpp-make-known-overlay (start end) - ;; Create an overlay for a known cpp command from START to END. - (let ((overlay (make-overlay start end))) - (if (eq cpp-known-face 'invisible) - (cpp-make-overlay-hidden overlay) - (or (eq cpp-known-face 'default) - (overlay-put overlay 'face cpp-known-face)) - (if cpp-known-writable - () - (overlay-put overlay 'modification-hooks '(cpp-signal-read-only)) - (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only)))) - (setq cpp-overlay-list (cons overlay cpp-overlay-list)))) - -(defun cpp-make-unknown-overlay (start end) - ;; Create an overlay for an unknown cpp command from START to END. - (let ((overlay (make-overlay start end))) - (cond ((eq cpp-unknown-face 'invisible) - (cpp-make-overlay-hidden overlay)) - ((eq cpp-unknown-face 'default)) - (t - (overlay-put overlay 'face cpp-unknown-face))) - (if cpp-unknown-writable - () - (overlay-put overlay 'modification-hooks '(cpp-signal-read-only)) - (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only))) - (setq cpp-overlay-list (cons overlay cpp-overlay-list)))) - -(defun cpp-make-overlay-hidden (overlay) - ;; Make overlay hidden and intangible. - (overlay-put overlay 'invisible t) - (overlay-put overlay 'intangible t) - ;; Unfortunately `intangible' is not implemented for overlays yet, - ;; so we make is read-only instead. - (overlay-put overlay 'modification-hooks '(cpp-signal-read-only)) - (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only))) - -(defun cpp-make-overlay-read-only (overlay) - ;; Make overlay read only. - (overlay-put overlay 'modification-hooks '(cpp-signal-read-only)) - (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only)) - (overlay-put overlay 'insert-behind-hooks '(cpp-signal-read-only))) - -(defun cpp-make-overlay-sticky (overlay) - ;; Make OVERLAY grow when you insert text at either end. - (overlay-put overlay 'insert-in-front-hooks '(cpp-grow-overlay)) - (overlay-put overlay 'insert-behind-hooks '(cpp-grow-overlay))) - -(defun cpp-signal-read-only (overlay after start end &optional len) - ;; Only allow deleting the whole overlay. - ;; Trying to change a read-only overlay. - (if (and (not after) - (or (< (overlay-start overlay) start) - (> (overlay-end overlay) end))) - (error "This text is read only"))) - -(defun cpp-grow-overlay (overlay after start end &optional len) - ;; Make OVERLAY grow to contain range START to END. - (if after - (move-overlay overlay - (min start (overlay-start overlay)) - (max end (overlay-end overlay))))) - -;;; Edit Buffer: - -(defvar cpp-edit-map nil) -;; Keymap for `cpp-edit-mode'. - -(if cpp-edit-map - () - (setq cpp-edit-map (make-keymap)) - (suppress-keymap cpp-edit-map) - (define-key cpp-edit-map [ down-mouse-2 ] 'cpp-push-button) - (define-key cpp-edit-map [ mouse-2 ] 'ignore) - (define-key cpp-edit-map " " 'scroll-up) - (define-key cpp-edit-map "\C-?" 'scroll-down) - (define-key cpp-edit-map [ delete ] 'scroll-down) - (define-key cpp-edit-map "\C-c\C-c" 'cpp-edit-apply) - (define-key cpp-edit-map "a" 'cpp-edit-apply) - (define-key cpp-edit-map "A" 'cpp-edit-apply) - (define-key cpp-edit-map "r" 'cpp-edit-reset) - (define-key cpp-edit-map "R" 'cpp-edit-reset) - (define-key cpp-edit-map "s" 'cpp-edit-save) - (define-key cpp-edit-map "S" 'cpp-edit-save) - (define-key cpp-edit-map "l" 'cpp-edit-load) - (define-key cpp-edit-map "L" 'cpp-edit-load) - (define-key cpp-edit-map "h" 'cpp-edit-home) - (define-key cpp-edit-map "H" 'cpp-edit-home) - (define-key cpp-edit-map "b" 'cpp-edit-background) - (define-key cpp-edit-map "B" 'cpp-edit-background) - (define-key cpp-edit-map "k" 'cpp-edit-known) - (define-key cpp-edit-map "K" 'cpp-edit-known) - (define-key cpp-edit-map "u" 'cpp-edit-unknown) - (define-key cpp-edit-map "u" 'cpp-edit-unknown) - (define-key cpp-edit-map "t" 'cpp-edit-true) - (define-key cpp-edit-map "T" 'cpp-edit-true) - (define-key cpp-edit-map "f" 'cpp-edit-false) - (define-key cpp-edit-map "F" 'cpp-edit-false) - (define-key cpp-edit-map "w" 'cpp-edit-write) - (define-key cpp-edit-map "W" 'cpp-edit-write) - (define-key cpp-edit-map "X" 'cpp-edit-toggle-known) - (define-key cpp-edit-map "x" 'cpp-edit-toggle-known) - (define-key cpp-edit-map "Y" 'cpp-edit-toggle-unknown) - (define-key cpp-edit-map "y" 'cpp-edit-toggle-unknown) - (define-key cpp-edit-map "q" 'bury-buffer) - (define-key cpp-edit-map "Q" 'bury-buffer)) - -(defvar cpp-edit-symbols nil) -;; Symbols defined in the edit buffer. -(make-variable-buffer-local 'cpp-edit-symbols) - -(defun cpp-edit-mode () - "Major mode for editing the criteria for highlighting cpp conditionals. -Click on objects to change them. -You can also use the keyboard accelerators indicated like this: [K]ey." - (kill-all-local-variables) - (buffer-disable-undo) - (auto-save-mode -1) - (setq buffer-read-only t) - (setq major-mode 'cpp-edit-mode) - (setq mode-name "CPP Edit") - (use-local-map cpp-edit-map)) - -(defun cpp-edit-apply () - "Apply edited display information to original buffer." - (interactive) - (cpp-edit-home) - (cpp-highlight-buffer t)) - -(defun cpp-edit-reset () - "Reset display information from original buffer." - (interactive) - (let ((buffer (current-buffer)) - (buffer-read-only nil) - (start (window-start)) - (pos (point)) - symbols) - (set-buffer cpp-edit-buffer) - (setq symbols cpp-parse-symbols) - (set-buffer buffer) - (setq cpp-edit-symbols symbols) - (erase-buffer) - (insert "CPP Display Information for `") - (cpp-make-button (buffer-name cpp-edit-buffer) 'cpp-edit-home) - (insert "\n\nClick mouse-2 on item you want to change or use\n" - "or switch to this buffer and type the keyboard equivalents.\n" - "Keyboard equivalents are indicated with brackets like [T]his.\n\n") - (cpp-make-button "[H]ome (display the C file)" 'cpp-edit-home) - (insert " ") - (cpp-make-button "[A]pply new settings" 'cpp-edit-apply) - (insert "\n") - (cpp-make-button "[S]ave settings" 'cpp-edit-save) - (insert " ") - (cpp-make-button "[L]oad settings" 'cpp-edit-load) - (insert "\n\n") - - (insert "[B]ackground: ") - (cpp-make-button (car (rassq cpp-face-type cpp-face-type-list)) - 'cpp-edit-background) - (insert "\n[K]nown conditionals: ") - (cpp-make-button (cpp-face-name cpp-known-face) - 'cpp-edit-known nil t) - (insert " [X] ") - (cpp-make-button (car (rassq cpp-known-writable cpp-writable-list)) - 'cpp-edit-toggle-known) - (insert "\n[U]nknown conditionals: ") - (cpp-make-button (cpp-face-name cpp-unknown-face) - 'cpp-edit-unknown nil t) - (insert " [Y] ") - (cpp-make-button (car (rassq cpp-unknown-writable cpp-writable-list)) - 'cpp-edit-toggle-unknown) - (insert (format "\n\n\n%39s: %14s %14s %7s\n\n" "Expression" - "[T]rue Face" "[F]alse Face" "[W]rite")) - (while symbols - (let* ((symbol (car symbols)) - (entry (assoc symbol cpp-edit-list)) - (true (nth 1 entry)) - (false (nth 2 entry)) - (write (if entry (nth 3 entry) 'both))) - (setq symbols (cdr symbols)) - - (if (and entry ; Make default entries unknown. - (or (null true) (eq true 'default)) - (or (null false) (eq false 'default)) - (eq write 'both)) - (setq cpp-edit-list (delq entry cpp-edit-list) - entry nil)) - - (if (> (length symbol) 39) - (insert (substring symbol 0 39) ": ") - (insert (format "%39s: " symbol))) - - (cpp-make-button (cpp-face-name true) - 'cpp-edit-true symbol t 14) - (insert " ") - (cpp-make-button (cpp-face-name false) - 'cpp-edit-false symbol t 14) - (insert " ") - (cpp-make-button (car (rassq write cpp-branch-list)) - 'cpp-edit-write symbol nil 6) - (insert "\n"))) - (insert "\n\n") - (set-window-start nil start) - (goto-char pos))) - -(defun cpp-edit-load () - "Load cpp configuration." - (interactive) - (cond ((null init-file-user) - ;; If -q was specified, don't load any init files. - nil) - ((file-readable-p cpp-config-file) - (load-file cpp-config-file)) - ((file-readable-p (concat "~/" cpp-config-file)) - (load-file cpp-config-file))) - (if (eq major-mode 'cpp-edit-mode) - (cpp-edit-reset))) - -(defun cpp-edit-save () - "Save the current cpp configuration in a file." - (interactive) - (require 'pp) - (save-excursion - (set-buffer cpp-edit-buffer) - (let ((buffer (find-file-noselect cpp-config-file))) - (set-buffer buffer) - (erase-buffer) - (pp (list 'setq 'cpp-known-face - (list 'quote cpp-known-face)) buffer) - (pp (list 'setq 'cpp-unknown-face - (list 'quote cpp-unknown-face)) buffer) - (pp (list 'setq 'cpp-face-type - (list 'quote cpp-face-type)) buffer) - (pp (list 'setq 'cpp-known-writable - (list 'quote cpp-known-writable)) buffer) - (pp (list 'setq 'cpp-unknown-writable - (list 'quote cpp-unknown-writable)) buffer) - (pp (list 'setq 'cpp-edit-list - (list 'quote cpp-edit-list)) buffer) - (write-file cpp-config-file)))) - -(defun cpp-edit-home () - "Switch back to original buffer." - (interactive) - (if cpp-button-event - (read-event)) - (pop-to-buffer cpp-edit-buffer)) - -(defun cpp-edit-background () - "Change default face collection." - (interactive) - (call-interactively 'cpp-choose-default-face) - (cpp-edit-reset)) - -(defun cpp-edit-known () - "Select default for known conditionals." - (interactive) - (setq cpp-known-face (cpp-choose-face "Known face" cpp-known-face)) - (cpp-edit-reset)) - -(defun cpp-edit-unknown () - "Select default for unknown conditionals." - (interactive) - (setq cpp-unknown-face (cpp-choose-face "Unknown face" cpp-unknown-face)) - (cpp-edit-reset)) - -(defun cpp-edit-toggle-known (arg) - "Toggle writable status for known conditionals. -With optional argument ARG, make them writable iff ARG is positive." - (interactive "@P") - (if (or (and (null arg) cpp-known-writable) - (<= (prefix-numeric-value arg) 0)) - (setq cpp-known-writable nil) - (setq cpp-known-writable t)) - (cpp-edit-reset)) - -(defun cpp-edit-toggle-unknown (arg) - "Toggle writable status for unknown conditionals. -With optional argument ARG, make them writable iff ARG is positive." - (interactive "@P") - (if (or (and (null arg) cpp-unknown-writable) - (<= (prefix-numeric-value arg) 0)) - (setq cpp-unknown-writable nil) - (setq cpp-unknown-writable t)) - (cpp-edit-reset)) - -(defun cpp-edit-true (symbol face) - "Select SYMBOL's true FACE used for highlighting taken conditionals." - (interactive - (let ((symbol (cpp-choose-symbol))) - (list symbol - (cpp-choose-face "True face" - (nth 1 (assoc symbol cpp-edit-list)))))) - (setcar (nthcdr 1 (cpp-edit-list-entry-get-or-create symbol)) face) - (cpp-edit-reset)) - -(defun cpp-edit-false (symbol face) - "Select SYMBOL's false FACE used for highlighting untaken conditionals." - (interactive - (let ((symbol (cpp-choose-symbol))) - (list symbol - (cpp-choose-face "False face" - (nth 2 (assoc symbol cpp-edit-list)))))) - (setcar (nthcdr 2 (cpp-edit-list-entry-get-or-create symbol)) face) - (cpp-edit-reset)) - -(defun cpp-edit-write (symbol branch) - "Set which branches of SYMBOL should be writable to BRANCH. -BRANCH should be either nil (false branch), t (true branch) or 'both." - (interactive (list (cpp-choose-symbol) (cpp-choose-branch))) - (setcar (nthcdr 3 (cpp-edit-list-entry-get-or-create symbol)) branch) - (cpp-edit-reset)) - -(defun cpp-edit-list-entry-get-or-create (symbol) - ;; Return the entry for SYMBOL in `cpp-edit-list'. - ;; If it does not exist, create it. - (let ((entry (assoc symbol cpp-edit-list))) - (or entry - (setq entry (list symbol nil nil 'both nil) - cpp-edit-list (cons entry cpp-edit-list))) - entry)) - -;;; Prompts: - -(defun cpp-choose-symbol () - ;; Choose a symbol if called from keyboard, otherwise use the one clicked on. - (if cpp-button-event - cpp-callback-data - (completing-read "Symbol: " (mapcar 'list cpp-edit-symbols) nil t))) - -(defun cpp-choose-branch () - ;; Choose a branch, either nil, t, or both. - (if cpp-button-event - (x-popup-menu cpp-button-event - (list "Branch" (cons "Branch" cpp-branch-list))) - (cdr (assoc (completing-read "Branch: " cpp-branch-list nil t) - cpp-branch-list)))) - -(defun cpp-choose-face (prompt default) - ;; Choose a face from cpp-face-defalt-list. - ;; PROMPT is what to say to the user. - ;; DEFAULT is the default face. - (or (if cpp-button-event - (x-popup-menu cpp-button-event - (list prompt (cons prompt cpp-face-default-list))) - (let ((name (car (rassq default cpp-face-default-list)))) - (cdr (assoc (completing-read (if name - (concat prompt - " (default " name "): ") - (concat prompt ": ")) - cpp-face-default-list nil t) - cpp-face-all-list)))) - default)) - -(defun cpp-choose-default-face (type) - ;; Choose default face list for screen of TYPE. - ;; Type must be one of the types defined in `cpp-face-type-list'. - (interactive (list (if cpp-button-event - (x-popup-menu cpp-button-event - (list "Screen type" - (cons "Screen type" - cpp-face-type-list))) - (cdr (assoc (completing-read "Screen type: " - cpp-face-type-list - nil t) - cpp-face-type-list))))) - (cond ((null type)) - ((eq type 'light) - (if cpp-face-light-list - () - (setq cpp-face-light-list - (mapcar 'cpp-create-bg-face cpp-face-light-name-list)) - (setq cpp-face-all-list - (append cpp-face-all-list cpp-face-light-list))) - (setq cpp-face-type 'light) - (setq cpp-face-default-list - (append cpp-face-light-list cpp-face-none-list))) - ((eq type 'dark) - (if cpp-face-dark-list - () - (setq cpp-face-dark-list - (mapcar 'cpp-create-bg-face cpp-face-dark-name-list)) - (setq cpp-face-all-list - (append cpp-face-all-list cpp-face-dark-list))) - (setq cpp-face-type 'dark) - (setq cpp-face-default-list - (append cpp-face-dark-list cpp-face-none-list))) - ((eq type 'mono) - (setq cpp-face-type 'mono) - (setq cpp-face-default-list - (append cpp-face-mono-list cpp-face-none-list))) - (t - (setq cpp-face-type 'none) - (setq cpp-face-default-list cpp-face-none-list)))) - -;;; Buttons: - -(defun cpp-make-button (name callback &optional data face padding) - ;; Create a button at point. - ;; NAME is the name of the button. - ;; CALLBACK is the function to call when the button is pushed. - ;; DATA will be made available to CALLBACK - ;;in the free variable cpp-callback-data. - ;; FACE means that NAME is the name of a face in `cpp-face-all-list'. - ;; PADDING means NAME will be right justified at that length. - (let ((name (format "%s" name)) - from to) - (cond ((null padding) - (setq from (point)) - (insert name)) - ((> (length name) padding) - (setq from (point)) - (insert (substring name 0 padding))) - (t - (insert (make-string (- padding (length name)) ? )) - (setq from (point)) - (insert name))) - (setq to (point)) - (setq face - (if face - (let ((check (cdr (assoc name cpp-face-all-list)))) - (if (memq check '(default invisible)) - 'bold - check)) - 'bold)) - (add-text-properties from to - (append (list 'face face) - '(mouse-face highlight) - (list 'cpp-callback callback) - (if data (list 'cpp-data data)))))) - -(defun cpp-push-button (event) - ;; Pushed a CPP button. - (interactive "@e") - (set-buffer (window-buffer (posn-window (event-start event)))) - (let ((pos (posn-point (event-start event)))) - (let ((cpp-callback-data (get-text-property pos 'cpp-data)) - (fun (get-text-property pos 'cpp-callback)) - (cpp-button-event event)) - (cond (fun - (call-interactively (get-text-property pos 'cpp-callback))) - ((lookup-key global-map [ down-mouse-2]) - (call-interactively (lookup-key global-map [ down-mouse-2]))))))) - -;;; Faces: - -(defun cpp-create-bg-face (color) - ;; Create entry for face with background COLOR. - (let ((name (intern (concat "cpp " color)))) - (make-face name) - (set-face-background name color) - (cons color name))) - -(cpp-choose-default-face (if window-system cpp-face-type 'none)) - -(defun cpp-face-name (face) - ;; Return the name of FACE from `cpp-face-all-list'. - (let ((entry (rassq (if face face 'default) cpp-face-all-list))) - (if entry - (car entry) - (format "<%s>" face)))) - -;;; Utilities: - -(defvar cpp-progress-time 0) -;; Last time we issued a progress message. - -(defun cpp-progress-message (&rest args) - ;; Report progress at most once a second. Take same ARGS as `message'. - (let ((time (nth 1 (current-time)))) - (if (= time cpp-progress-time) - () - (setq cpp-progress-time time) - (apply 'message args)))) - -(provide 'cpp) - -;;; cpp.el ends here diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el deleted file mode 100644 index 80d56df9329..00000000000 --- a/lisp/progmodes/etags.el +++ /dev/null @@ -1,1606 +0,0 @@ -;;; etags.el --- etags facility for Emacs - -;; Copyright (C) 1985, 1986, 1988, 1989, 1992, 1993, 1994, 1995 -;; Free Software Foundation, Inc. - -;; Author: Roland McGrath <roland@gnu.ai.mit.edu> -;; Keywords: tools - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;;###autoload -(defvar tags-file-name nil - "*File name of tags table. -To switch to a new tags table, setting this variable is sufficient. -If you set this variable, do not also set `tags-table-list'. -Use the `etags' program to make a tags table file.") -;; Make M-x set-variable tags-file-name like M-x visit-tags-table. -;;;###autoload (put 'tags-file-name 'variable-interactive "fVisit tags table: ") - -;;;###autoload -;; Use `visit-tags-table-buffer' to cycle through tags tables in this list. -(defvar tags-table-list nil - "*List of file names of tags tables to search. -An element that is a directory means the file \"TAGS\" in that directory. -To switch to a new list of tags tables, setting this variable is sufficient. -If you set this variable, do not also set `tags-file-name'. -Use the `etags' program to make a tags table file.") - -;;;###autoload -(defvar tags-add-tables 'ask-user - "*Control whether to add a new tags table to the current list. -t means do; nil means don't (always start a new list). -Any other value means ask the user whether to add a new tags table -to the current list (as opposed to starting a new list).") - -(defvar tags-table-computed-list nil - "List of tags tables to search, computed from `tags-table-list'. -This includes tables implicitly included by other tables. The list is not -always complete: the included tables of a table are not known until that -table is read into core. An element that is `t' is a placeholder -indicating that the preceding element is a table that has not been read -into core and might contain included tables to search. -See `tags-table-check-computed-list'.") - -(defvar tags-table-computed-list-for nil - "Value of `tags-table-list' that `tags-table-computed-list' corresponds to. -If `tags-table-list' changes, `tags-table-computed-list' is thrown away and -recomputed; see `tags-table-check-computed-list'.") - -(defvar tags-table-list-pointer nil - "Pointer into `tags-table-computed-list' for the current state of searching. -Use `visit-tags-table-buffer' to cycle through tags tables in this list.") - -(defvar tags-table-list-started-at nil - "Pointer into `tags-table-computed-list', where the current search started.") - -(defvar tags-table-set-list nil - "List of sets of tags table which have been used together in the past. -Each element is a list of strings which are file names.") - -;;;###autoload -(defvar find-tag-hook nil - "*Hook to be run by \\[find-tag] after finding a tag. See `run-hooks'. -The value in the buffer in which \\[find-tag] is done is used, -not the value in the buffer \\[find-tag] goes to.") - -;;;###autoload -(defvar find-tag-default-function nil - "*A function of no arguments used by \\[find-tag] to pick a default tag. -If nil, and the symbol that is the value of `major-mode' -has a `find-tag-default-function' property (see `put'), that is used. -Otherwise, `find-tag-default' is used.") - -(defvar default-tags-table-function nil - "If non-nil, a function to choose a default tags file for a buffer. -This function receives no arguments and should return the default -tags table file to use for the current buffer.") - -(defvar tags-location-stack nil - "List of markers which are locations visited by \\[find-tag]. -Pop back to the last location with \\[negative-argument] \\[find-tag].") - -;; Tags table state. -;; These variables are local in tags table buffers. - -(defvar tags-table-files nil - "List of file names covered by current tags table. -nil means it has not yet been computed; use `tags-table-files' to do so.") - -(defvar tags-completion-table nil - "Alist of tag names defined in current tags table.") - -(defvar tags-included-tables nil - "List of tags tables included by the current tags table.") - -(defvar next-file-list nil - "List of files for \\[next-file] to process.") - -;; Hooks for file formats. - -(defvar tags-table-format-hooks '(etags-recognize-tags-table - recognize-empty-tags-table) - "List of functions to be called in a tags table buffer to identify -the type of tags table. The functions are called in order, with no arguments, -until one returns non-nil. The function should make buffer-local bindings -of the format-parsing tags function variables if successful.") - -(defvar file-of-tag-function nil - "Function to do the work of `file-of-tag' (which see).") -(defvar tags-table-files-function nil - "Function to do the work of `tags-table-files' (which see).") -(defvar tags-completion-table-function nil - "Function to build the tags-completion-table.") -(defvar snarf-tag-function nil - "Function to get info about a matched tag for `goto-tag-location-function'.") -(defvar goto-tag-location-function nil - "Function of to go to the location in the buffer specified by a tag. -One argument, the tag info returned by `snarf-tag-function'.") -(defvar find-tag-regexp-search-function nil - "Search function passed to `find-tag-in-order' for finding a regexp tag.") -(defvar find-tag-regexp-tag-order nil - "Tag order passed to `find-tag-in-order' for finding a regexp tag.") -(defvar find-tag-regexp-next-line-after-failure-p nil - "Flag passed to `find-tag-in-order' for finding a regexp tag.") -(defvar find-tag-search-function nil - "Search function passed to `find-tag-in-order' for finding a tag.") -(defvar find-tag-tag-order nil - "Tag order passed to `find-tag-in-order' for finding a tag.") -(defvar find-tag-next-line-after-failure-p nil - "Flag passed to `find-tag-in-order' for finding a tag.") -(defvar list-tags-function nil - "Function to do the work of `list-tags' (which see).") -(defvar tags-apropos-function nil - "Function to do the work of `tags-apropos' (which see).") -(defvar tags-included-tables-function nil - "Function to do the work of `tags-included-tables' (which see).") -(defvar verify-tags-table-function nil - "Function to return t iff the current buffer contains a valid -\(already initialized\) tags file.") - -;; Initialize the tags table in the current buffer. -;; Returns non-nil iff it is a valid tags table. On -;; non-nil return, the tags table state variable are -;; made buffer-local and initialized to nil. -(defun initialize-new-tags-table () - (set (make-local-variable 'tags-table-files) nil) - (set (make-local-variable 'tags-completion-table) nil) - (set (make-local-variable 'tags-included-tables) nil) - ;; Value is t if we have found a valid tags table buffer. - (let ((hooks tags-table-format-hooks)) - (while (and hooks - (not (funcall (car hooks)))) - (setq hooks (cdr hooks))) - hooks)) - -;;;###autoload -(defun visit-tags-table (file &optional local) - "Tell tags commands to use tags table file FILE. -FILE should be the name of a file created with the `etags' program. -A directory name is ok too; it means file TAGS in that directory. - -Normally \\[visit-tags-table] sets the global value of `tags-file-name'. -With a prefix arg, set the buffer-local value instead. -When you find a tag with \\[find-tag], the buffer it finds the tag -in is given a local value of this variable which is the name of the tags -file the tag was in." - (interactive (list (read-file-name "Visit tags table: (default TAGS) " - default-directory - (expand-file-name "TAGS" - default-directory) - t) - current-prefix-arg)) - (or (stringp file) (signal 'wrong-type-argument (list 'stringp file))) - ;; Bind tags-file-name so we can control below whether the local or - ;; global value gets set. Calling visit-tags-table-buffer will - ;; initialize a buffer for the file and set tags-file-name to the - ;; Calling visit-tags-table-buffer with tags-file-name set to FILE will - ;; initialize a buffer for FILE and set tags-file-name to the - ;; fully-expanded name. - (let ((tags-file-name file)) - (save-excursion - (or (visit-tags-table-buffer file) - (signal 'file-error (list "Visiting tags table" - "file does not exist" - file))) - ;; Set FILE to the expanded name. - (setq file tags-file-name))) - (if local - ;; Set the local value of tags-file-name. - (set (make-local-variable 'tags-file-name) file) - ;; Set the global value of tags-file-name. - (setq-default tags-file-name file))) - -(defun tags-table-check-computed-list () - "Compute `tags-table-computed-list' from `tags-table-list' if necessary." - (let ((expanded-list (mapcar 'tags-expand-table-name tags-table-list))) - (or (equal tags-table-computed-list-for expanded-list) - ;; The list (or default-directory) has changed since last computed. - (let* ((compute-for (mapcar 'copy-sequence expanded-list)) - (tables (copy-sequence compute-for)) ;Mutated in the loop. - (computed nil) - table-buffer) - - (while tables - (setq computed (cons (car tables) computed) - table-buffer (get-file-buffer (car tables))) - (if (and table-buffer - ;; There is a buffer visiting the file. Now make sure - ;; it is initialized as a tag table buffer. - (save-excursion - (tags-verify-table (buffer-file-name table-buffer)))) - (save-excursion - (set-buffer table-buffer) - (if (tags-included-tables) - ;; Insert the included tables into the list we - ;; are processing. - (setcdr tables (nconc (mapcar 'tags-expand-table-name - (tags-included-tables)) - (cdr tables))))) - ;; This table is not in core yet. Insert a placeholder - ;; saying we must read it into core to check for included - ;; tables before searching the next table in the list. - (setq computed (cons t computed))) - (setq tables (cdr tables))) - - ;; Record the tags-table-list value (and the context of the - ;; current directory) we computed from. - (setq tags-table-computed-list-for compute-for - tags-table-computed-list (nreverse computed)))))) - -;; Extend `tags-table-computed-list' to remove the first `t' placeholder. -;; An element of the list that is `t' is a placeholder indicating that the -;; preceding element is a table that has not been read into core and might -;; contain included tables to search. On return, the first placeholder -;; element will be gone and the element before it read into core and its -;; included tables inserted into the list. -(defun tags-table-extend-computed-list () - (let ((list tags-table-computed-list)) - (while (not (eq (nth 1 list) t)) - (setq list (cdr list))) - (save-excursion - (if (tags-verify-table (car list)) - ;; We are now in the buffer visiting (car LIST). Extract its - ;; list of included tables and insert it into the computed list. - (let ((tables (tags-included-tables)) - (computed nil) - table-buffer) - (while tables - (setq computed (cons (car tables) computed) - table-buffer (get-file-buffer (car tables))) - (if table-buffer - (save-excursion - (set-buffer table-buffer) - (if (tags-included-tables) - ;; Insert the included tables into the list we - ;; are processing. - (setcdr tables (append (tags-included-tables) - tables)))) - ;; This table is not in core yet. Insert a placeholder - ;; saying we must read it into core to check for included - ;; tables before searching the next table in the list. - (setq computed (cons t computed))) - (setq tables (cdr tables))) - (setq computed (nreverse computed)) - ;; COMPUTED now contains the list of included tables (and - ;; tables included by them, etc.). Now splice this into the - ;; current list. - (setcdr list (nconc computed (cdr (cdr list))))) - ;; It was not a valid table, so just remove the following placeholder. - (setcdr list (cdr (cdr list))))))) - -;; Expand tags table name FILE into a complete file name. -(defun tags-expand-table-name (file) - (setq file (expand-file-name file)) - (if (file-directory-p file) - (expand-file-name "TAGS" file) - file)) - -;; Like member, but comparison is done after tags-expand-table-name on both -;; sides and elements of LIST that are t are skipped. -(defun tags-table-list-member (file list) - (setq file (tags-expand-table-name file)) - (while (and list - (or (eq (car list) t) - (not (string= file (tags-expand-table-name (car list)))))) - (setq list (cdr list))) - list) - -(defun tags-verify-table (file) - "Read FILE into a buffer and verify that it is a valid tags table. -Sets the current buffer to one visiting FILE (if it exists). -Returns non-nil iff it is a valid table." - (if (get-file-buffer file) - ;; The file is already in a buffer. Check for the visited file - ;; having changed since we last used it. - (let (win) - (set-buffer (get-file-buffer file)) - (setq win (or verify-tags-table-function (initialize-new-tags-table))) - (if (or (verify-visited-file-modtime (current-buffer)) - (not (yes-or-no-p - (format "Tags file %s has changed, read new contents? " - file)))) - (and win (funcall verify-tags-table-function)) - (revert-buffer t t) - (initialize-new-tags-table))) - (and (file-exists-p file) - (progn - (set-buffer (find-file-noselect file)) - (or (string= file buffer-file-name) - ;; find-file-noselect has changed the file name. - ;; Propagate the change to tags-file-name and tags-table-list. - (let ((tail (member file tags-table-list))) - (if tail - (setcar tail buffer-file-name)) - (if (eq file tags-file-name) - (setq tags-file-name buffer-file-name)))) - (initialize-new-tags-table))))) - -;; Subroutine of visit-tags-table-buffer. Search the current tags tables -;; for one that has tags for THIS-FILE (or that includes a table that -;; does). Return the name of the first table table listing THIS-FILE; if -;; the table is one included by another table, it is the master table that -;; we return. If CORE-ONLY is non-nil, check only tags tables that are -;; already in buffers--don't visit any new files. -(defun tags-table-including (this-file core-only) - (let ((tables tags-table-computed-list) - (found nil)) - ;; Loop over the list, looking for a table containing tags for THIS-FILE. - (while (and (not found) - tables) - - (if core-only - ;; Skip tables not in core. - (while (eq (nth 1 tables) t) - (setq tables (cdr (cdr tables)))) - (if (eq (nth 1 tables) t) - ;; This table has not been read into core yet. Read it in now. - (tags-table-extend-computed-list))) - - (if tables - ;; Select the tags table buffer and get the file list up to date. - (let ((tags-file-name (car tables))) - (visit-tags-table-buffer 'same) - (if (member this-file (mapcar 'expand-file-name - (tags-table-files))) - ;; Found it. - (setq found tables)))) - (setq tables (cdr tables))) - (if found - ;; Now determine if the table we found was one included by another - ;; table, not explicitly listed. We do this by checking each - ;; element of the computed list to see if it appears in the user's - ;; explicit list; the last element we will check is FOUND itself. - ;; Then we return the last one which did in fact appear in - ;; tags-table-list. - (let ((could-be nil) - (elt tags-table-computed-list)) - (while (not (eq elt (cdr found))) - (if (tags-table-list-member (car elt) tags-table-list) - ;; This table appears in the user's list, so it could be - ;; the one which includes the table we found. - (setq could-be (car elt))) - (setq elt (cdr elt)) - (if (eq t (car elt)) - (setq elt (cdr elt)))) - ;; The last element we found in the computed list before FOUND - ;; that appears in the user's list will be the table that - ;; included the one we found. - could-be)))) - -;; Subroutine of visit-tags-table-buffer. Move tags-table-list-pointer -;; along and set tags-file-name. Returns nil when out of tables. -(defun tags-next-table () - ;; If there is a placeholder element next, compute the list to replace it. - (while (eq (nth 1 tags-table-list-pointer) t) - (tags-table-extend-computed-list)) - - ;; Go to the next table in the list. - (setq tags-table-list-pointer (cdr tags-table-list-pointer)) - (or tags-table-list-pointer - ;; Wrap around. - (setq tags-table-list-pointer tags-table-computed-list)) - - (if (eq tags-table-list-pointer tags-table-list-started-at) - ;; We have come full circle. No more tables. - (setq tags-table-list-pointer nil) - ;; Set tags-file-name to the name from the list. It is already expanded. - (setq tags-file-name (car tags-table-list-pointer)))) - -(defun visit-tags-table-buffer (&optional cont) - "Select the buffer containing the current tags table. -If optional arg is a string, visit that file as a tags table. -If optional arg is t, visit the next table in `tags-table-list'. -If optional arg is the atom `same', don't look for a new table; - just select the buffer visiting `tags-file-name'. -If arg is nil or absent, choose a first buffer from information in - `tags-file-name', `tags-table-list', `tags-table-list-pointer'. -Returns t if it visits a tags table, or nil if there are no more in the list." - - ;; Set tags-file-name to the tags table file we want to visit. - (cond ((eq cont 'same) - ;; Use the ambient value of tags-file-name. - (or tags-file-name - (error "%s" - (substitute-command-keys - (concat "No tags table in use! " - "Use \\[visit-tags-table] to select one."))))) - - ((eq t cont) - ;; Find the next table. - (if (tags-next-table) - ;; Skip over nonexistent files. - (while (and (not (or (get-file-buffer tags-file-name) - (file-exists-p tags-file-name))) - (tags-next-table))))) - - (t - ;; Pick a table out of our hat. - (tags-table-check-computed-list) ;Get it up to date, we might use it. - (setq tags-file-name - (or - ;; If passed a string, use that. - (if (stringp cont) - (prog1 cont - (setq cont nil))) - ;; First, try a local variable. - (cdr (assq 'tags-file-name (buffer-local-variables))) - ;; Second, try a user-specified function to guess. - (and default-tags-table-function - (funcall default-tags-table-function)) - ;; Third, look for a tags table that contains tags for the - ;; current buffer's file. If one is found, the lists will - ;; be frobnicated, and CONT will be set non-nil so we don't - ;; do it below. - (and buffer-file-name - (or - ;; First check only tables already in buffers. - (tags-table-including buffer-file-name t) - ;; Since that didn't find any, now do the - ;; expensive version: reading new files. - (tags-table-including buffer-file-name nil))) - ;; Fourth, use the user variable tags-file-name, if it is - ;; not already in the current list. - (and tags-file-name - (not (tags-table-list-member tags-file-name - tags-table-computed-list)) - tags-file-name) - ;; Fifth, use the user variable giving the table list. - ;; Find the first element of the list that actually exists. - (let ((list tags-table-list) - file) - (while (and list - (setq file (tags-expand-table-name (car list))) - (not (get-file-buffer file)) - (not (file-exists-p file))) - (setq list (cdr list))) - (car list)) - ;; Finally, prompt the user for a file name. - (expand-file-name - (read-file-name "Visit tags table: (default TAGS) " - default-directory - "TAGS" - t)))))) - - ;; Expand the table name into a full file name. - (setq tags-file-name (tags-expand-table-name tags-file-name)) - - (if (and (eq cont t) - (null tags-table-list-pointer)) - ;; All out of tables. - nil - - ;; Verify that tags-file-name names a valid tags table. - ;; Bind another variable with the value of tags-file-name - ;; before we switch buffers, in case tags-file-name is buffer-local. - (let ((curbuf (current-buffer)) - (local-tags-file-name tags-file-name)) - (if (tags-verify-table local-tags-file-name) - - ;; We have a valid tags table. - (progn - ;; Bury the tags table buffer so it - ;; doesn't get in the user's way. - (bury-buffer (current-buffer)) - - ;; If this was a new table selection (CONT is nil), make - ;; sure tags-table-list includes the chosen table, and - ;; update the list pointer variables. - (or cont - ;; Look in the list for the table we chose. - (let ((found (tags-table-list-member - local-tags-file-name - tags-table-computed-list))) - (if found - ;; There it is. Just switch to it. - (setq tags-table-list-pointer found - tags-table-list-started-at found) - - ;; The table is not in the current set. - ;; Try to find it in another previously used set. - (let ((sets tags-table-set-list)) - (while (and sets - (not (tags-table-list-member - local-tags-file-name - (car sets)))) - (setq sets (cdr sets))) - (if sets - ;; Found in some other set. Switch to that set. - (progn - (or (memq tags-table-list tags-table-set-list) - ;; Save the current list. - (setq tags-table-set-list - (cons tags-table-list - tags-table-set-list))) - (setq tags-table-list (car sets))) - - ;; Not found in any existing set. - (if (and tags-table-list - (or (eq t tags-add-tables) - (and tags-add-tables - (y-or-n-p - (concat "Keep current list of " - "tags tables also? "))))) - ;; Add it to the current list. - (setq tags-table-list (cons local-tags-file-name - tags-table-list)) - - ;; Make a fresh list, and store the old one. - (message "Starting a new list of tags tables") - (or (null tags-table-list) - (memq tags-table-list tags-table-set-list) - (setq tags-table-set-list - (cons tags-table-list - tags-table-set-list))) - (setq tags-table-list (list local-tags-file-name)))) - - ;; Recompute tags-table-computed-list. - (tags-table-check-computed-list) - ;; Set the tags table list state variables to start - ;; over from tags-table-computed-list. - (setq tags-table-list-started-at tags-table-computed-list - tags-table-list-pointer - tags-table-computed-list))))) - - ;; Return of t says the tags table is valid. - t) - - ;; The buffer was not valid. Don't use it again. - (set-buffer curbuf) - (kill-local-variable 'tags-file-name) - (if (eq local-tags-file-name tags-file-name) - (setq tags-file-name nil)) - (error "File %s is not a valid tags table" local-tags-file-name))))) - -(defun tags-reset-tags-tables () - "Reset tags state to cancel effect of any previous \\[visit-tags-table] -or \\[find-tag]." - (interactive) - (setq tags-file-name nil - tags-location-stack nil - tags-table-list nil - tags-table-computed-list nil - tags-table-computed-list-for nil - tags-table-list-pointer nil - tags-table-list-started-at nil - tags-table-set-list nil)) - -(defun file-of-tag () - "Return the file name of the file whose tags point is within. -Assumes the tags table is the current buffer. -File name returned is relative to tags table file's directory." - (funcall file-of-tag-function)) - -;;;###autoload -(defun tags-table-files () - "Return a list of files in the current tags table. -Assumes the tags table is the current buffer. The file names are returned -as they appeared in the `etags' command that created the table, usually -without directory names." - (or tags-table-files - (setq tags-table-files - (funcall tags-table-files-function)))) - -(defun tags-included-tables () - "Return a list of tags tables included by the current table. -Assumes the tags table is the current buffer." - (or tags-included-tables - (setq tags-included-tables (funcall tags-included-tables-function)))) - -;; Build tags-completion-table on demand. The single current tags table -;; and its included tags tables (and their included tables, etc.) have -;; their tags included in the completion table. -(defun tags-completion-table () - (or tags-completion-table - (condition-case () - (prog2 - (message "Making tags completion table for %s..." buffer-file-name) - (let ((included (tags-included-tables)) - (table (funcall tags-completion-table-function))) - (save-excursion - ;; Iterate over the list of included tables, and combine each - ;; included table's completion obarray to the parent obarray. - (while included - ;; Visit the buffer. - (let ((tags-file-name (car included))) - (visit-tags-table-buffer 'same)) - ;; Recurse in that buffer to compute its completion table. - (if (tags-completion-table) - ;; Combine the tables. - (mapatoms (function - (lambda (sym) - (intern (symbol-name sym) table))) - tags-completion-table)) - (setq included (cdr included)))) - (setq tags-completion-table table)) - (message "Making tags completion table for %s...done" - buffer-file-name)) - (quit (message "Tags completion table construction aborted.") - (setq tags-completion-table nil))))) - -;; Completion function for tags. Does normal try-completion, -;; but builds tags-completion-table on demand. -(defun tags-complete-tag (string predicate what) - (save-excursion - ;; If we need to ask for the tag table, allow that. - (let ((enable-recursive-minibuffers t)) - (visit-tags-table-buffer)) - (if (eq what t) - (all-completions string (tags-completion-table) predicate) - (try-completion string (tags-completion-table) predicate)))) - -;; Return a default tag to search for, based on the text at point. -(defun find-tag-default () - (save-excursion - (while (looking-at "\\sw\\|\\s_") - (forward-char 1)) - (if (or (re-search-backward "\\sw\\|\\s_" - (save-excursion (beginning-of-line) (point)) - t) - (re-search-forward "\\(\\sw\\|\\s_\\)+" - (save-excursion (end-of-line) (point)) - t)) - (progn (goto-char (match-end 0)) - (buffer-substring (point) - (progn (forward-sexp -1) - (while (looking-at "\\s'") - (forward-char 1)) - (point)))) - nil))) - -;; Read a tag name from the minibuffer with defaulting and completion. -(defun find-tag-tag (string) - (let* ((default (funcall (or find-tag-default-function - (get major-mode 'find-tag-default-function) - 'find-tag-default))) - (spec (completing-read (if default - (format "%s(default %s) " string default) - string) - 'tags-complete-tag))) - (if (equal spec "") - (or default (error "There is no default tag")) - spec))) - -(defvar last-tag nil - "Last tag found by \\[find-tag].") - -;; Get interactive args for find-tag{-noselect,-other-window,-regexp}. -(defun find-tag-interactive (prompt &optional no-default) - (if current-prefix-arg - (list nil (if (< (prefix-numeric-value current-prefix-arg) 0) - '- - t)) - (list (if no-default - (read-string prompt) - (find-tag-tag prompt))))) - -(defvar find-tag-history nil) - -;;;###autoload -(defun find-tag-noselect (tagname &optional next-p regexp-p) - "Find tag (in current tags table) whose name contains TAGNAME. -Returns the buffer containing the tag's definition and moves its point there, -but does not select the buffer. -The default for TAGNAME is the expression in the buffer near point. - -If second arg NEXT-P is t (interactively, with prefix arg), search for -another tag that matches the last tagname or regexp used. When there are -multiple matches for a tag, more exact matches are found first. If NEXT-P -is the atom `-' (interactively, with prefix arg that is a negative number -or just \\[negative-argument]), pop back to the previous tag gone to. - -If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp. - -See documentation of variable `tags-file-name'." - (interactive (find-tag-interactive "Find tag: ")) - - (setq find-tag-history (cons tagname find-tag-history)) - ;; Save the current buffer's value of `find-tag-hook' before selecting the - ;; tags table buffer. - (let ((local-find-tag-hook find-tag-hook)) - (if (eq '- next-p) - ;; Pop back to a previous location. - (if (null tags-location-stack) - (error "No previous tag locations") - (let ((marker (car tags-location-stack))) - ;; Pop the stack. - (setq tags-location-stack (cdr tags-location-stack)) - (prog1 - ;; Move to the saved location. - (set-buffer (marker-buffer marker)) - (goto-char (marker-position marker)) - ;; Kill that marker so it doesn't slow down editing. - (set-marker marker nil nil) - ;; Run the user's hook. Do we really want to do this for pop? - (run-hooks 'local-find-tag-hook)))) - (if next-p - ;; Find the same table we last used. - (visit-tags-table-buffer 'same) - ;; Pick a table to use. - (visit-tags-table-buffer) - ;; Record TAGNAME for a future call with NEXT-P non-nil. - (setq last-tag tagname)) - ;; Record the location so we can pop back to it later. - (let ((marker (make-marker))) - (save-excursion - (set-buffer - ;; find-tag-in-order does the real work. - (find-tag-in-order - (if next-p last-tag tagname) - (if regexp-p - find-tag-regexp-search-function - find-tag-search-function) - (if regexp-p - find-tag-regexp-tag-order - find-tag-tag-order) - (if regexp-p - find-tag-regexp-next-line-after-failure-p - find-tag-next-line-after-failure-p) - (if regexp-p "matching" "containing") - (not next-p))) - (set-marker marker (point)) - (run-hooks 'local-find-tag-hook) - (setq tags-location-stack - (cons marker tags-location-stack)) - (current-buffer)))))) - -;;;###autoload -(defun find-tag (tagname &optional next-p regexp-p) - "Find tag (in current tags table) whose name contains TAGNAME. -Select the buffer containing the tag's definition, and move point there. -The default for TAGNAME is the expression in the buffer around or before point. - -If second arg NEXT-P is t (interactively, with prefix arg), search for -another tag that matches the last tagname or regexp used. When there are -multiple matches for a tag, more exact matches are found first. If NEXT-P -is the atom `-' (interactively, with prefix arg that is a negative number -or just \\[negative-argument]), pop back to the previous tag gone to. - -See documentation of variable `tags-file-name'." - (interactive (find-tag-interactive "Find tag: ")) - (switch-to-buffer (find-tag-noselect tagname next-p regexp-p))) -;;;###autoload (define-key esc-map "." 'find-tag) - -;;;###autoload -(defun find-tag-other-window (tagname &optional next-p regexp-p) - "Find tag (in current tags table) whose name contains TAGNAME. -Select the buffer containing the tag's definition in another window, and -move point there. The default for TAGNAME is the expression in the buffer -around or before point. - -If second arg NEXT-P is t (interactively, with prefix arg), search for -another tag that matches the last tagname or regexp used. When there are -multiple matches for a tag, more exact matches are found first. If NEXT-P -is negative (interactively, with prefix arg that is a negative number or -just \\[negative-argument]), pop back to the previous tag gone to. - -See documentation of variable `tags-file-name'." - (interactive (find-tag-interactive "Find tag other window: ")) - - ;; This hair is to deal with the case where the tag is found in the - ;; selected window's buffer; without the hair, point is moved in both - ;; windows. To prevent this, we save the selected window's point before - ;; doing find-tag-noselect, and restore it after. - (let* ((window-point (window-point (selected-window))) - (tagbuf (find-tag-noselect tagname next-p regexp-p)) - (tagpoint (progn (set-buffer tagbuf) (point)))) - (set-window-point (prog1 - (selected-window) - (switch-to-buffer-other-window tagbuf) - ;; We have to set this new window's point; it - ;; might already have been displaying a - ;; different portion of tagbuf, in which case - ;; switch-to-buffer-other-window doesn't set - ;; the window's point from the buffer. - (set-window-point (selected-window) tagpoint)) - window-point))) -;;;###autoload (define-key ctl-x-4-map "." 'find-tag-other-window) - -;;;###autoload -(defun find-tag-other-frame (tagname &optional next-p) - "Find tag (in current tags table) whose name contains TAGNAME. -Select the buffer containing the tag's definition in another frame, and -move point there. The default for TAGNAME is the expression in the buffer -around or before point. - -If second arg NEXT-P is t (interactively, with prefix arg), search for -another tag that matches the last tagname or regexp used. When there are -multiple matches for a tag, more exact matches are found first. If NEXT-P -is negative (interactively, with prefix arg that is a negative number or -just \\[negative-argument]), pop back to the previous tag gone to. - -See documentation of variable `tags-file-name'." - (interactive (find-tag-interactive "Find tag other frame: ")) - (let ((pop-up-frames t)) - (find-tag-other-window tagname next-p))) -;;;###autoload (define-key ctl-x-5-map "." 'find-tag-other-frame) - -;;;###autoload -(defun find-tag-regexp (regexp &optional next-p other-window) - "Find tag (in current tags table) whose name matches REGEXP. -Select the buffer containing the tag's definition and move point there. - -If second arg NEXT-P is t (interactively, with prefix arg), search for -another tag that matches the last tagname or regexp used. When there are -multiple matches for a tag, more exact matches are found first. If NEXT-P -is negative (interactively, with prefix arg that is a negative number or -just \\[negative-argument]), pop back to the previous tag gone to. - -If third arg OTHER-WINDOW is non-nil, select the buffer in another window. - -See documentation of variable `tags-file-name'." - (interactive (find-tag-interactive "Find tag regexp: " t)) - ;; We go through find-tag-other-window to do all the display hair there. - (funcall (if other-window 'find-tag-other-window 'find-tag) - regexp next-p t)) -;;;###autoload (define-key esc-map [?\C-.] 'find-tag-regexp) - -;; Internal tag finding function. - -;; PATTERN is a string to pass to second arg SEARCH-FORWARD-FUNC, and to -;; any member of the function list ORDER (third arg). If ORDER is nil, -;; use saved state to continue a previous search. - -;; Fourth arg MATCHING is a string, an English '-ing' word, to be used in -;; an error message. - -;; Fifth arg NEXT-LINE-AFTER-FAILURE-P is non-nil if after a failed match, -;; point should be moved to the next line. - -;; Algorithm is as follows. For each qualifier-func in ORDER, go to -;; beginning of tags file, and perform inner loop: for each naive match for -;; PATTERN found using SEARCH-FORWARD-FUNC, qualify the naive match using -;; qualifier-func. If it qualifies, go to the specified line in the -;; specified source file and return. Qualified matches are remembered to -;; avoid repetition. State is saved so that the loop can be continued. - -(defvar tag-lines-already-matched nil) ;matches remembered here between calls - -(defun find-tag-in-order (pattern - search-forward-func - order - next-line-after-failure-p - matching - first-search) - (let (file ;name of file containing tag - tag-info ;where to find the tag in FILE - (first-table t) - (tag-order order) - (match-marker (make-marker)) - goto-func - ) - (save-excursion - - (if first-search - ;; This is the start of a search for a fresh tag. - ;; Clear the list of tags matched by the previous search. - ;; find-tag-noselect has already put us in the first tags table - ;; buffer before we got called. - (setq tag-lines-already-matched nil) - ;; Continuing to search for the tag specified last time. - ;; tag-lines-already-matched lists locations matched in previous - ;; calls so we don't visit the same tag twice if it matches twice - ;; during two passes with different qualification predicates. - ;; Switch to the current tags table buffer. - (visit-tags-table-buffer 'same)) - - ;; Get a qualified match. - (catch 'qualified-match-found - - ;; Iterate over the list of tags tables. - (while (or first-table - (visit-tags-table-buffer t)) - - (and first-search first-table - ;; Start at beginning of tags file. - (goto-char (point-min))) - - (setq first-table nil) - - ;; Iterate over the list of ordering predicates. - (while order - (while (funcall search-forward-func pattern nil t) - ;; Naive match found. Qualify the match. - (and (funcall (car order) pattern) - ;; Make sure it is not a previous qualified match. - (not (member (set-marker match-marker (save-excursion - (beginning-of-line) - (point))) - tag-lines-already-matched)) - (throw 'qualified-match-found nil)) - (if next-line-after-failure-p - (forward-line 1))) - ;; Try the next flavor of match. - (setq order (cdr order)) - (goto-char (point-min))) - (setq order tag-order)) - ;; We throw out on match, so only get here if there were no matches. - ;; Clear out the markers we use to avoid duplicate matches so they - ;; don't slow down editting and are immediately available for GC. - (while tag-lines-already-matched - (set-marker (car tag-lines-already-matched) nil nil) - (setq tag-lines-already-matched (cdr tag-lines-already-matched))) - (set-marker match-marker nil nil) - (error "No %stags %s %s" (if first-search "" "more ") - matching pattern)) - - ;; Found a tag; extract location info. - (beginning-of-line) - (setq tag-lines-already-matched (cons match-marker - tag-lines-already-matched)) - ;; Expand the filename, using the tags table buffer's default-directory. - (setq file (expand-file-name (file-of-tag)) - tag-info (funcall snarf-tag-function)) - - ;; Get the local value in the tags table buffer before switching buffers. - (setq goto-func goto-tag-location-function) - - ;; Find the right line in the specified file. - (set-buffer (find-file-noselect file)) - (widen) - (push-mark) - (funcall goto-func tag-info) - - ;; Return the buffer where the tag was found. - (current-buffer)))) - -;; `etags' TAGS file format support. - -;; If the current buffer is a valid etags TAGS file, give it local values of -;; the tags table format variables, and return non-nil. -(defun etags-recognize-tags-table () - (and (etags-verify-tags-table) - ;; It is annoying to flash messages on the screen briefly, - ;; and this message is not useful. -- rms - ;; (message "%s is an `etags' TAGS file" buffer-file-name) - (mapcar (function (lambda (elt) - (set (make-local-variable (car elt)) (cdr elt)))) - '((file-of-tag-function . etags-file-of-tag) - (tags-table-files-function . etags-tags-table-files) - (tags-completion-table-function . etags-tags-completion-table) - (snarf-tag-function . etags-snarf-tag) - (goto-tag-location-function . etags-goto-tag-location) - (find-tag-regexp-search-function . re-search-forward) - (find-tag-regexp-tag-order . (tag-re-match-p)) - (find-tag-regexp-next-line-after-failure-p . t) - (find-tag-search-function . search-forward) - (find-tag-tag-order . (tag-exact-file-name-match-p - tag-exact-match-p - tag-symbol-match-p - tag-word-match-p - tag-any-match-p)) - (find-tag-next-line-after-failure-p . nil) - (list-tags-function . etags-list-tags) - (tags-apropos-function . etags-tags-apropos) - (tags-included-tables-function . etags-tags-included-tables) - (verify-tags-table-function . etags-verify-tags-table) - )))) - -;; Return non-nil iff the current buffer is a valid etags TAGS file. -(defun etags-verify-tags-table () - ;; Use eq instead of = in case char-after returns nil. - (eq (char-after 1) ?\f)) - -(defun etags-file-of-tag () - (save-excursion - (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n") - (expand-file-name (buffer-substring (match-beginning 1) (match-end 1)) - (file-truename default-directory)))) - - -(defun etags-tags-completion-table () - (let ((table (make-vector 511 0))) - (save-excursion - (goto-char (point-min)) - ;; This monster regexp matches an etags tag line. - ;; \1 is the string to match; - ;; \2 is not interesting; - ;; \3 is the guessed tag name; XXX guess should be better eg DEFUN - ;; \4 is not interesting; - ;; \5 is the explicitly-specified tag name. - ;; \6 is the line to start searching at; - ;; \7 is the char to start searching at. - (while (re-search-forward - "^\\(\\([^\177]+[^-a-zA-Z0-9_$\177]+\\)?\\([-a-zA-Z0-9_$?:]+\\)\ -\[^-a-zA-Z0-9_$?:\177]*\\)\177\\(\\([^\n\001]+\\)\001\\)?\ -\\([0-9]+\\)?,\\([0-9]+\\)?\n" - nil t) - (intern (if (match-beginning 5) - ;; There is an explicit tag name. - (buffer-substring (match-beginning 5) (match-end 5)) - ;; No explicit tag name. Best guess. - (buffer-substring (match-beginning 3) (match-end 3))) - table))) - table)) - -(defun etags-snarf-tag () - (let (tag-text line startpos) - (if (save-excursion - (forward-line -1) - (looking-at "\f\n")) - ;; The match was for a source file name, not any tag within a file. - ;; Give text of t, meaning to go exactly to the location we specify, - ;; the beginning of the file. - (setq tag-text t - line nil - startpos 1) - - ;; Find the end of the tag and record the whole tag text. - (search-forward "\177") - (setq tag-text (buffer-substring (1- (point)) - (save-excursion (beginning-of-line) - (point)))) - ;; Skip explicit tag name if present. - (search-forward "\001" (save-excursion (forward-line 1) (point)) t) - (if (looking-at "[0-9]") - (setq line (string-to-int (buffer-substring - (point) - (progn (skip-chars-forward "0-9") - (point)))))) - (search-forward ",") - (if (looking-at "[0-9]") - (setq startpos (string-to-int (buffer-substring - (point) - (progn (skip-chars-forward "0-9") - (point))))))) - ;; Leave point on the next line of the tags file. - (forward-line 1) - (cons tag-text (cons line startpos)))) - -;; TAG-INFO is a cons (TEXT LINE . POSITION) where TEXT is the initial part -;; of a line containing the tag and POSITION is the character position of -;; TEXT within the file (starting from 1); LINE is the line number. If -;; TEXT is t, it means the tag refers to exactly LINE or POSITION -;; (whichever is present, LINE having preference, no searching. Either -;; LINE or POSITION may be nil; POSITION is used if present. If the tag -;; isn't exactly at the given position then look around that position using -;; a search window which expands until it hits the start of file. -(defun etags-goto-tag-location (tag-info) - (let ((startpos (cdr (cdr tag-info))) - (line (car (cdr tag-info))) - offset found pat) - (if (eq (car tag-info) t) - ;; Direct file tag. - (cond (line (goto-line line)) - (startpos (goto-char startpos)) - (t (error "etags.el BUG: bogus direct file tag"))) - ;; This constant is 1/2 the initial search window. - ;; There is no sense in making it too small, - ;; since just going around the loop once probably - ;; costs about as much as searching 2000 chars. - (setq offset 1000 - found nil - pat (concat (if (eq selective-display t) - "\\(^\\|\^m\\)" "^") - (regexp-quote (car tag-info)))) - ;; The character position in the tags table is 0-origin. - ;; Convert it to a 1-origin Emacs character position. - (if startpos (setq startpos (1+ startpos))) - ;; If no char pos was given, try the given line number. - (or startpos - (if line - (setq startpos (progn (goto-line line) - (point))))) - (or startpos - (setq startpos (point-min))) - ;; First see if the tag is right at the specified location. - (goto-char startpos) - (setq found (looking-at pat)) - (while (and (not found) - (progn - (goto-char (- startpos offset)) - (not (bobp)))) - (setq found - (re-search-forward pat (+ startpos offset) t) - offset (* 3 offset))) ; expand search window - (or found - (re-search-forward pat nil t) - (error "Rerun etags: `%s' not found in %s" - pat buffer-file-name))) - ;; Position point at the right place - ;; if the search string matched an extra Ctrl-m at the beginning. - (and (eq selective-display t) - (looking-at "\^m") - (forward-char 1)) - (beginning-of-line))) - -(defun etags-list-tags (file) - (goto-char 1) - (if (not (search-forward (concat "\f\n" file ",") nil t)) - nil - (forward-line 1) - (while (not (or (eobp) (looking-at "\f"))) - (let ((tag (buffer-substring (point) - (progn (skip-chars-forward "^\177") - (point))))) - (princ (if (looking-at "[^\n]+\001") - ;; There is an explicit tag name; use that. - (buffer-substring (1+ (point)) ;skip \177 - (progn (skip-chars-forward "^\001") - (point))) - tag))) - (terpri) - (forward-line 1)) - t)) - -(defun etags-tags-apropos (string) - (goto-char 1) - (while (re-search-forward string nil t) - (beginning-of-line) - (princ (buffer-substring (point) - (progn (skip-chars-forward "^\177") - (point)))) - (terpri) - (forward-line 1))) - -(defun etags-tags-table-files () - (let ((files nil) - beg) - (goto-char (point-min)) - (while (search-forward "\f\n" nil t) - (setq beg (point)) - (end-of-line) - (skip-chars-backward "^," beg) - (or (looking-at "include$") - (setq files (cons (buffer-substring beg (1- (point))) files)))) - (nreverse files))) - -(defun etags-tags-included-tables () - (let ((files nil) - beg) - (goto-char (point-min)) - (while (search-forward "\f\n" nil t) - (setq beg (point)) - (end-of-line) - (skip-chars-backward "^," beg) - (if (looking-at "include$") - ;; Expand in the default-directory of the tags table buffer. - (setq files (cons (expand-file-name (buffer-substring beg (1- (point)))) - files)))) - (nreverse files))) - -;; Empty tags file support. - -;; Recognize an empty file and give it local values of the tags table format -;; variables which do nothing. -(defun recognize-empty-tags-table () - (and (zerop (buffer-size)) - (mapcar (function (lambda (sym) - (set (make-local-variable sym) 'ignore))) - '(tags-table-files-function - tags-completion-table-function - find-tag-regexp-search-function - find-tag-search-function - tags-apropos-function - tags-included-tables-function)) - (set (make-local-variable 'verify-tags-table-function) - (function (lambda () - (zerop (buffer-size))))))) - -;;; Match qualifier functions for tagnames. -;;; XXX these functions assume etags file format. - -;; This might be a neat idea, but it's too hairy at the moment. -;;(defmacro tags-with-syntax (&rest body) -;; (` (let ((current (current-buffer)) -;; (otable (syntax-table)) -;; (buffer (find-file-noselect (file-of-tag))) -;; table) -;; (unwind-protect -;; (progn -;; (set-buffer buffer) -;; (setq table (syntax-table)) -;; (set-buffer current) -;; (set-syntax-table table) -;; (,@ body)) -;; (set-syntax-table otable))))) -;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form)) - -;; t if point is at a tag line that matches TAG exactly. -;; point should be just after a string that matches TAG. -(defun tag-exact-match-p (tag) - ;; The match is really exact if there is an explicit tag name. - (or (and (eq (char-after (point)) ?\001) - (eq (char-after (- (point) (length tag) 1)) ?\177)) - ;; We are not on the explicit tag name, but perhaps it follows. - (looking-at (concat "[^\177\n]*\177" (regexp-quote tag) "\001")))) - -;; t if point is at a tag line that matches TAG as a symbol. -;; point should be just after a string that matches TAG. -(defun tag-symbol-match-p (tag) - (and (looking-at "\\Sw.*\177") (looking-at "\\S_.*\177") - (save-excursion - (backward-char (1+ (length tag))) - (and (looking-at "\\Sw") (looking-at "\\S_"))))) - -;; t if point is at a tag line that matches TAG as a word. -;; point should be just after a string that matches TAG. -(defun tag-word-match-p (tag) - (and (looking-at "\\b.*\177") - (save-excursion (backward-char (length tag)) - (looking-at "\\b")))) - -(defun tag-exact-file-name-match-p (tag) - (and (looking-at ",") - (save-excursion (backward-char (length tag)) - (looking-at "\f\n")))) - -;; t if point is in a tag line with a tag containing TAG as a substring. -(defun tag-any-match-p (tag) - (looking-at ".*\177")) - -;; t if point is at a tag line that matches RE as a regexp. -(defun tag-re-match-p (re) - (save-excursion - (beginning-of-line) - (let ((bol (point))) - (and (search-forward "\177" (save-excursion (end-of-line) (point)) t) - (re-search-backward re bol t))))) - -;;;###autoload -(defun next-file (&optional initialize novisit) - "Select next file among files in current tags table. - -A first argument of t (prefix arg, if interactive) initializes to the -beginning of the list of files in the tags table. If the argument is -neither nil nor t, it is evalled to initialize the list of files. - -Non-nil second argument NOVISIT means use a temporary buffer - to save time and avoid uninteresting warnings. - -Value is nil if the file was already visited; -if the file was newly read in, the value is the filename." - ;; Make the interactive arg t if there was any prefix arg. - (interactive (list (if current-prefix-arg t))) - (cond ((not initialize) - ;; Not the first run. - ) - ((eq initialize t) - ;; Initialize the list from the tags table. - (save-excursion - ;; Visit the tags table buffer to get its list of files. - (visit-tags-table-buffer) - ;; Copy the list so we can setcdr below, and expand the file - ;; names while we are at it, in this buffer's default directory. - (setq next-file-list (mapcar 'expand-file-name (tags-table-files))) - ;; Iterate over all the tags table files, collecting - ;; a complete list of referenced file names. - (while (visit-tags-table-buffer t) - ;; Find the tail of the working list and chain on the new - ;; sublist for this tags table. - (let ((tail next-file-list)) - (while (cdr tail) - (setq tail (cdr tail))) - ;; Use a copy so the next loop iteration will not modify the - ;; list later returned by (tags-table-files). - (if tail - (setcdr tail (mapcar 'expand-file-name (tags-table-files))) - (setq next-file-list (mapcar 'expand-file-name - (tags-table-files)))))))) - (t - ;; Initialize the list by evalling the argument. - (setq next-file-list (eval initialize)))) - (if next-file-list - () - (and novisit - (get-buffer " *next-file*") - (kill-buffer " *next-file*")) - (error "All files processed.")) - (let* ((next (car next-file-list)) - (new (not (get-file-buffer next)))) - ;; Advance the list before trying to find the file. - ;; If we get an error finding the file, don't get stuck on it. - (setq next-file-list (cdr next-file-list)) - (if (not (and new novisit)) - (set-buffer (find-file-noselect next novisit)) - ;; Like find-file, but avoids random warning messages. - (set-buffer (get-buffer-create " *next-file*")) - (kill-all-local-variables) - (erase-buffer) - (setq new next) - (insert-file-contents new nil)) - new)) - -(defvar tags-loop-operate nil - "Form for `tags-loop-continue' to eval to change one file.") - -(defvar tags-loop-scan - '(error "%s" - (substitute-command-keys - "No \\[tags-search] or \\[tags-query-replace] in progress.")) - "Form for `tags-loop-continue' to eval to scan one file. -If it returns non-nil, this file needs processing by evalling -\`tags-loop-operate'. Otherwise, move on to the next file.") - -;;;###autoload -(defun tags-loop-continue (&optional first-time) - "Continue last \\[tags-search] or \\[tags-query-replace] command. -Used noninteractively with non-nil argument to begin such a command (the -argument is passed to `next-file', which see). - -Two variables control the processing we do on each file: the value of -`tags-loop-scan' is a form to be executed on each file to see if it is -interesting (it returns non-nil if so) and `tags-loop-operate' is a form to -evaluate to operate on an interesting file. If the latter evaluates to -nil, we exit; otherwise we scan the next file." - (interactive) - (let (new - (messaged nil)) - (while - (progn - ;; Scan files quickly for the first or next interesting one. - (while (or first-time - (save-restriction - (widen) - (not (eval tags-loop-scan)))) - (setq new (next-file first-time t)) - ;; If NEW is non-nil, we got a temp buffer, - ;; and NEW is the file name. - (if (or messaged - (and (not first-time) - (> baud-rate search-slow-speed) - (setq messaged t))) - (message "Scanning file %s..." (or new buffer-file-name))) - (setq first-time nil) - (goto-char (point-min))) - - ;; If we visited it in a temp buffer, visit it now for real. - (if new - (let ((pos (point))) - (erase-buffer) - (set-buffer (find-file-noselect new)) - (setq new nil) ;No longer in a temp buffer. - (widen) - (goto-char pos))) - - (switch-to-buffer (current-buffer)) - - ;; Now operate on the file. - ;; If value is non-nil, continue to scan the next file. - (eval tags-loop-operate))) - (and messaged - (null tags-loop-operate) - (message "Scanning file %s...found" buffer-file-name)))) -;;;###autoload (define-key esc-map "," 'tags-loop-continue) - -;;;###autoload -(defun tags-search (regexp &optional file-list-form) - "Search through all files listed in tags table for match for REGEXP. -Stops when a match is found. -To continue searching for next match, use command \\[tags-loop-continue]. - -See documentation of variable `tags-file-name'." - (interactive "sTags search (regexp): ") - (if (and (equal regexp "") - (eq (car tags-loop-scan) 're-search-forward) - (null tags-loop-operate)) - ;; Continue last tags-search as if by M-,. - (tags-loop-continue nil) - (setq tags-loop-scan - (list 're-search-forward (list 'quote regexp) nil t) - tags-loop-operate nil) - (tags-loop-continue (or file-list-form t)))) - -;;;###autoload -(defun tags-query-replace (from to &optional delimited file-list-form) - "Query-replace-regexp FROM with TO through all files listed in tags table. -Third arg DELIMITED (prefix arg) means replace only word-delimited matches. -If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace -with the command \\[tags-loop-continue]. - -See documentation of variable `tags-file-name'." - (interactive (query-replace-read-args "Tags query replace (regexp)" t)) - (setq tags-loop-scan (list 'prog1 - (list 'if (list 're-search-forward - (list 'quote from) nil t) - ;; When we find a match, move back - ;; to the beginning of it so perform-replace - ;; will see it. - '(goto-char (match-beginning 0)))) - tags-loop-operate (list 'perform-replace - (list 'quote from) (list 'quote to) - t t (list 'quote delimited))) - (tags-loop-continue (or file-list-form t))) - -(defun tags-complete-tags-table-file (string predicate what) - (save-excursion - ;; If we need to ask for the tag table, allow that. - (let ((enable-recursive-minibuffers t)) - (visit-tags-table-buffer)) - (if (eq what t) - (all-completions string (mapcar 'list (tags-table-files)) - predicate) - (try-completion string (mapcar 'list (tags-table-files)) - predicate)))) - -;;;###autoload -(defun list-tags (file &optional next-match) - "Display list of tags in file FILE. -This searches only the first table in the list, and no included tables. -FILE should be as it appeared in the `etags' command, usually without a -directory specification." - (interactive (list (completing-read "List tags in file: " - 'tags-complete-tags-table-file - nil t nil))) - (with-output-to-temp-buffer "*Tags List*" - (princ "Tags in file ") - (princ file) - (terpri) - (save-excursion - (let ((first-time t) - (gotany nil)) - (while (visit-tags-table-buffer (not first-time)) - (setq first-time nil) - (if (funcall list-tags-function file) - (setq gotany t))) - (or gotany - (error "File %s not in current tags tables" file)))))) - -;;;###autoload -(defun tags-apropos (regexp) - "Display list of all tags in tags table REGEXP matches." - (interactive "sTags apropos (regexp): ") - (with-output-to-temp-buffer "*Tags List*" - (princ "Tags matching regexp ") - (prin1 regexp) - (terpri) - (save-excursion - (let ((first-time t)) - (while (visit-tags-table-buffer (not first-time)) - (setq first-time nil) - (funcall tags-apropos-function regexp)))))) - -;;; XXX Kludge interface. - -;; XXX If a file is in multiple tables, selection may get the wrong one. -;;;###autoload -(defun select-tags-table () - "Select a tags table file from a menu of those you have already used. -The list of tags tables to select from is stored in `tags-table-set-list'; -see the doc of that variable if you want to add names to the list." - (interactive) - (pop-to-buffer "*Tags Table List*") - (setq buffer-read-only nil) - (erase-buffer) - (let ((set-list tags-table-set-list) - (desired-point nil)) - (if tags-table-list - (progn - (setq desired-point (point-marker)) - (princ tags-table-list (current-buffer)) - (insert "\C-m") - (prin1 (car tags-table-list) (current-buffer)) ;invisible - (insert "\n"))) - (while set-list - (if (eq (car set-list) tags-table-list) - ;; Already printed it. - () - (princ (car set-list) (current-buffer)) - (insert "\C-m") - (prin1 (car (car set-list)) (current-buffer)) ;invisible - (insert "\n")) - (setq set-list (cdr set-list))) - (if tags-file-name - (progn - (or desired-point - (setq desired-point (point-marker))) - (insert tags-file-name "\C-m") - (prin1 tags-file-name (current-buffer)) ;invisible - (insert "\n"))) - (setq set-list (delete tags-file-name - (apply 'nconc (cons (copy-sequence tags-table-list) - (mapcar 'copy-sequence - tags-table-set-list))))) - (while set-list - (insert (car set-list) "\C-m") - (prin1 (car set-list) (current-buffer)) ;invisible - (insert "\n") - (setq set-list (delete (car set-list) set-list))) - (goto-char 1) - (insert-before-markers - "Type `t' to select a tags table or set of tags tables:\n\n") - (if desired-point - (goto-char desired-point)) - (set-window-start (selected-window) 1 t)) - (set-buffer-modified-p nil) - (select-tags-table-mode)) - -(defvar select-tags-table-mode-map) -(let ((map (make-sparse-keymap))) - (define-key map "t" 'select-tags-table-select) - (define-key map " " 'next-line) - (define-key map "\^?" 'previous-line) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "q" 'select-tags-table-quit) - (setq select-tags-table-mode-map map)) - -(defun select-tags-table-mode () - "Major mode for choosing a current tags table among those already loaded. - -\\{select-tags-table-mode-map}" - (interactive) - (kill-all-local-variables) - (setq buffer-read-only t - major-mode 'select-tags-table-mode - mode-name "Select Tags Table") - (use-local-map select-tags-table-mode-map) - (setq selective-display t - selective-display-ellipses nil)) - -(defun select-tags-table-select () - "Select the tags table named on this line." - (interactive) - (search-forward "\C-m") - (let ((name (read (current-buffer)))) - (visit-tags-table name) - (select-tags-table-quit) - (message "Tags table now %s" name))) - -(defun select-tags-table-quit () - "Kill the buffer and delete the selected window." - (interactive) - (kill-buffer (current-buffer)) - (or (one-window-p) - (delete-window))) - -;;; Note, there is another definition of this function in bindings.el. -;;;###autoload -(defun complete-tag () - "Perform tags completion on the text around point. -Completes to the set of names listed in the current tags table. -The string to complete is chosen in the same way as the default -for \\[find-tag] (which see)." - (interactive) - (or tags-table-list - tags-file-name - (error "%s" - (substitute-command-keys - "No tags table loaded. Try \\[visit-tags-table]."))) - (let ((pattern (funcall (or find-tag-default-function - (get major-mode 'find-tag-default-function) - 'find-tag-default))) - beg - completion) - (or pattern - (error "Nothing to complete")) - (search-backward pattern) - (setq beg (point)) - (forward-char (length pattern)) - (setq completion (try-completion pattern 'tags-complete-tag nil)) - (cond ((eq completion t)) - ((null completion) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((not (string= pattern completion)) - (delete-region beg (point)) - (insert completion)) - (t - (message "Making completion list...") - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (all-completions pattern 'tags-complete-tag nil))) - (message "Making completion list...%s" "done"))))) - -;;;###autoload (define-key esc-map "\t" 'complete-tag) - -(provide 'etags) - -;;; etags.el ends here diff --git a/lisp/progmodes/executable.el b/lisp/progmodes/executable.el deleted file mode 100644 index 62d6f59fbbb..00000000000 --- a/lisp/progmodes/executable.el +++ /dev/null @@ -1,235 +0,0 @@ -;;; executable.el --- base functionality for executable interpreter scripts - -;; Copyright (C) 1994, 1995, 1996 by Free Software Foundation, Inc. - -;; Author: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 -;; Keywords: languages, unix - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; executable.el is used by certain major modes to insert a suitable -;; #! line at the beginning of the file, if the file does not already -;; have one. - -;; Unless it has a magic number, a Unix file with executable mode is passed to -;; a new instance of the running shell (or to a Bourne shell if a csh is -;; running and the file starts with `:'). Only a shell can start such a file, -;; exec() cannot, which is why it is important to have a magic number in every -;; executable script. Such a magic number is made up by the characters `#!' -;; the filename of an interpreter (in COFF, ELF or somesuch format) and one -;; optional argument. - -;; This library is for certain major modes like sh-, awk-, perl-, tcl- or -;; makefile-mode to insert or update a suitable #! line at the beginning of -;; the file, if the file does not already have one and the file is not a -;; default file of that interpreter (like .profile or makefile). It also -;; makes the file executable if it wasn't, as soon as it's saved. - -;; It also allows debugging scripts, with an adaptation of compile, as far -;; as interpreters give out meaningful error messages. - -;; Modes that use this should nconc `executable-map' to the end of their own -;; keymap and `executable-font-lock-keywords' to the end of their own font -;; lock keywords. Their mode-setting commands should call -;; `executable-set-magic'. - -;;; Code: - -(defvar executable-insert t - "*Non-nil means offer to add a magic number to a file. -This takes effect when you switch to certain major modes, -including Shell-script mode (`sh-mode'). -When you type \\[executable-set-magic], it always offers to add or -update the magic number.") - -(defvar executable-query 'function - "*If non-nil, ask user before changing an existing magic number. -When this is `function', only ask when called non-interactively.") - - -(defvar executable-magicless-file-regexp "/[Mm]akefile$\\|/\\.\\(z?profile\\|bash_profile\\|z?login\\|bash_login\\|z?logout\\|bash_logout\\|.+shrc\\|esrc\\|rcrc\\|[kz]shenv\\)$" - "*On files with this kind of name no magic is inserted or changed.") - - -(defvar executable-prefix "#! " - "*Interpreter magic number prefix inserted when there was no magic number.") - - - -(defvar executable-chmod 73 - "*After saving, if the file is not executable, set this mode. -This mode passed to `set-file-modes' is taken absolutely when negative, or -relative to the files existing modes. Do nothing if this is nil. -Typical values are 73 (+x) or -493 (rwxr-xr-x).") - - -(defvar executable-command nil) - -(defvar executable-self-display "tail" - "*Command you use with argument `+2' to make text files self-display. -Note that the like of `more' doesn't work too well under Emacs \\[shell].") - - -(defvar executable-font-lock-keywords - '(("\\`#!.*/\\([^ \t\n]+\\)" 1 font-lock-keyword-face t)) - "*Rules for highlighting executable scripts' magic number. -This can be included in `font-lock-keywords' by modes that call `executable'.") - - -(defvar executable-error-regexp-alist - '(;; /bin/xyz: syntax error at line 14: `(' unexpected - ;; /bin/xyz[5]: syntax error at line 8 : ``' unmatched - ("^\\(.*[^[/]\\)\\(\\[[0-9]+\\]\\)?: .* error .* line \\([0-9]+\\)" 1 3) - ;; /bin/xyz[27]: ehco: not found - ("^\\(.*[^/]\\)\\[\\([0-9]+\\)\\]: .*: " 1 2) - ;; /bin/xyz: syntax error near unexpected token `)' - ;; /bin/xyz: /bin/xyz: line 2: `)' - ("^\\(.*[^/]\\): [^0-9\n]+\n\\1: \\1: line \\([0-9]+\\):" 1 2) - ;; /usr/bin/awk: syntax error at line 5 of file /bin/xyz - (" error .* line \\([0-9]+\\) of file \\(.+\\)$" 2 1) - ;; /usr/bin/awk: calling undefined function toto - ;; input record number 3, file awktestdata - ;; source line 4 of file /bin/xyz - ("^[^ ].+\n\\( .+\n\\)* line \\([0-9]+\\) of file \\(.+\\)$" 3 2) - ;; makefile:1: *** target pattern contains no `%'. Stop. - ("^\\(.+\\):\\([0-9]+\\): " 1 2)) - "Alist of regexps used to match script errors. -See `compilation-error-regexp-alist'.") - -;; The C function openp slightly modified would do the trick fine -(defun executable-find (command) - "Search for COMMAND in exec-path and return the absolute file name. -Return nil if COMMAND is not found anywhere in `exec-path'." - (let ((list exec-path) - file) - (while list - (setq list (if (and (setq file (expand-file-name command (car list))) - (file-executable-p file) - (not (file-directory-p file))) - nil - (setq file nil) - (cdr list)))) - file)) - - -(defun executable-chmod () - "This gets called after saving a file to assure that it be executable. -You can set the absolute or relative mode in variable `executable-chmod' for -non-executable files." - (and executable-chmod - buffer-file-name - (or (file-executable-p buffer-file-name) - (set-file-modes buffer-file-name - (if (< executable-chmod 0) - (- executable-chmod) - (logior executable-chmod - (file-modes buffer-file-name))))))) - - -(defun executable-interpret (command) - "Run script with user-specified args, and collect output in a buffer. -While script runs asynchronously, you can use the \\[next-error] command -to find the next error." - (interactive (list (read-string "Run script: " - (or executable-command - buffer-file-name)))) - (require 'compile) - (save-some-buffers (not compilation-ask-about-save)) - (make-local-variable 'executable-command) - (compile-internal (setq executable-command command) - "No more errors." "Interpretation" - ;; Give it a simpler regexp to match. - nil executable-error-regexp-alist)) - - - -;;;###autoload -(defun executable-set-magic (interpreter &optional argument - no-query-flag insert-flag) - "Set this buffer's interpreter to INTERPRETER with optional ARGUMENT. -The variables `executable-magicless-file-regexp', `executable-prefix', -`executable-insert', `executable-query' and `executable-chmod' control -when and how magic numbers are inserted or replaced and scripts made -executable." - (interactive - (let* ((name (read-string "Name or file name of interpreter: ")) - (arg (read-string (format "Argument for %s: " name)))) - (list name arg (eq executable-query 'function) t))) - (setq interpreter (if (file-name-absolute-p interpreter) - interpreter - (or (executable-find interpreter) - (error "Interpreter %s not recognized" interpreter))) - argument (concat interpreter - (and argument (string< "" argument) " ") - argument)) - (or buffer-read-only - (if buffer-file-name - (string-match executable-magicless-file-regexp - buffer-file-name)) - (not (or insert-flag executable-insert)) - (> (point-min) 1) - (save-excursion - (let ((point (point-marker)) - (buffer-modified-p (buffer-modified-p))) - (goto-char (point-min)) - (make-local-hook 'after-save-hook) - (add-hook 'after-save-hook 'executable-chmod nil t) - (if (looking-at "#![ \t]*\\(.*\\)$") - (and (goto-char (match-beginning 1)) - ;; If the line ends in a space, - ;; don't offer to change it. - (not (= (char-after (1- (match-end 1))) ?\ )) - (not (string= argument - (buffer-substring (point) (match-end 1)))) - (if (or (not executable-query) no-query-flag - (save-window-excursion - ;; Make buffer visible before question. - (switch-to-buffer (current-buffer)) - (y-or-n-p (concat "Replace magic number by `" - executable-prefix argument "'? ")))) - (progn - (replace-match argument t t nil 1) - (message "Magic number changed to `%s'" - (concat executable-prefix argument))))) - (insert executable-prefix argument ?\n) - (message "Magic number changed to `%s'" - (concat executable-prefix argument))) -;;; (or insert-flag -;;; (eq executable-insert t) -;;; (set-buffer-modified-p buffer-modified-p)) - ))) - interpreter) - - - -;;;###autoload -(defun executable-self-display () - "Turn a text file into a self-displaying Un*x command. -The magic number of such a command displays all lines but itself." - (interactive) - (if (eq this-command 'executable-self-display) - (setq this-command 'executable-set-magic)) - (executable-set-magic executable-self-display "+2")) - - - -(provide 'executable) - -;; executable.el ends here diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el deleted file mode 100644 index ada277ffc05..00000000000 --- a/lisp/progmodes/f90.el +++ /dev/null @@ -1,1697 +0,0 @@ -;;; f90.el --- Fortran-90 mode (free format) - -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. - -;; Author: Torbj\"orn Einarsson <T.Einarsson@clab.ericsson.se> -;; Last Change: Oct. 14, 1996 -;; Keywords: fortran, f90, languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Smart mode for editing F90 programs in FREE FORMAT. -;; Knows about continuation lines, named structured statements, and other -;; new features in F90 including HPF (High Performance Fortran) structures. -;; The basic feature is to provide an accurate indentation of F90 programs. -;; In addition, there are many more features like automatic matching of all -;; end statements, an auto-fill function to break long lines, a join-lines -;; function which joins continued lines etc etc. -;; To facilitate typing, a fairly complete list of abbreviations is provided. -;; For example, `i is short-hand for integer (if abbrev-mode is on). - -;; There are two separate features for highlighting the code. -;; 1) Upcasing or capitalizing of all keywords. -;; 2) Colors/fonts using font-lock-mode. (only when using X-windows) -;; Automatic upcase of downcase of keywords is controlled by the parameter -;; f90-auto-keyword-case. - -;; The indentations of lines starting with ! is determined by the first of the -;; following matches (the values in the left column are the default values): - -;; start-string/regexp indent variable holding start-string/regexp -;; !!! 0 -;; !hpf\\$ (re) 0 f90-directive-comment-re -;; !!$ 0 f90-comment-region -;; ! (re) as code f90-indented-comment-re -;; default comment-column - -;; Ex: Here is the result of 3 different settings of f90-indented-comment-re -;; f90-indented-comment-re !-indentation !!-indentation -;; ! as code as code -;; !! comment-column as code -;; ![^!] as code comment-column -;; Trailing comments are indented to comment-column with indent-for-comment M-; -;; f90-comment-region (C-c;) toggles insertion of f90-comment-region in region. - -;; One common convention for free vs. fixed format is that free-format files -;; have the ending .f90 while the fixed format files have the ending .f. -;; To make f90-mode work, put this file in, for example, your directory -;; ~/lisp, and be sure that you have the following in your .emacs-file -;; (setq load-path (append load-path '("~/lisp"))) -;; (autoload 'f90-mode "f90" -;; "Major mode for editing Fortran 90 code in free format." t) -;; (setq auto-mode-alist (append auto-mode-alist -;; (list '("\\.f90$" . f90-mode)))) -;; Once you have entered f90-mode, you may get more info by using -;; the command describe-mode (C-h m). For online help describing various -;; functions use C-h f <Name of function you want described> - -;; To customize the f90-mode for your taste, use, for example: -;; (you don't have to specify values for all the parameters below) -;;(setq f90-mode-hook -;; '(lambda () (setq f90-do-indent 3 -;; f90-if-indent 3 -;; f90-type-indent 3 -;; f90-program-indent 2 -;; f90-continuation-indent 5 -;; f90-comment-region "!!$" -;; f90-directive-comment-re "!hpf\\$" -;; f90-indented-comment-re "!" -;; f90-break-delimiters "[-+\\*/,><=% \t]" -;; f90-break-before-delimiters t -;; f90-beginning-ampersand t -;; f90-smart-end 'blink -;; f90-auto-keyword-case nil -;; f90-leave-line-no nil -;; f90-startup-message t -;; indent-tabs-mode nil -;; f90-font-lock-keywords f90-font-lock-keywords-2 -;; ) -;; ;;The rest is not default. -;; (abbrev-mode 1) ; turn on abbreviation mode -;; (turn-on-font-lock) ; for highlighting -;; (f90-add-imenu-menu) ; extra menu with functions etc. -;; (if f90-auto-keyword-case ; change case of all keywords on startup -;; (f90-change-keywords f90-auto-keyword-case)) -;; )) -;; in your .emacs file (the shown values are the defaults). You can also -;; change the values of the lists f90-keywords etc. -;; The auto-fill and abbreviation minor modes are accessible from the menu, -;; or by using M-x auto-fill-mode and M-x abbrev-mode, respectively. - -;; Remarks -;; 1) Line numbers are by default left-justified. If f90-leave-line-no is -;; non-nil, the line numbers are never touched. -;; 2) Multi-; statements like > do i=1,20 ; j=j+i ; end do < are not handled -;; correctly, but I imagine them to be rare. -;; 3) Regexps for hilit19 are no longer supported. -;; 4) For FIXED FORMAT code, use the ordinary fortran mode. -;; 5) This mode does not work under emacs-18.x. -;; 6) Preprocessor directives, i.e., lines starting with # are left-justified -;; and are untouched by all case-changing commands. There is, at present, no -;; mechanism for treating multi-line directives (continued by \ ). -;; 7) f77 do-loops do 10 i=.. ; ; 10 continue are not correctly indented. -;; You are urged to use f90-do loops (with labels if you wish). -;; 8) The highlighting mode under XEmacs is not as complete as under Emacs. - -;; List of user commands -;; f90-previous-statement f90-next-statement -;; f90-beginning-of-subprogram f90-end-of-subprogram f90-mark-subprogram -;; f90-comment-region -;; f90-indent-line f90-indent-new-line -;; f90-indent-region (can be called by calling indent-region) -;; f90-indent-subprogram -;; f90-break-line f90-join-lines -;; f90-fill-region -;; f90-insert-end -;; f90-upcase-keywords f90-upcase-region-keywords -;; f90-downcase-keywords f90-downcase-region-keywords -;; f90-capitalize-keywords f90-capitalize-region-keywords -;; f90-add-imenu-menu -;; f90-font-lock-1, f90-font-lock-2, f90-font-lock-3, f90-font-lock-4 - -;; Thanks to all the people who have tested the mode. Special thanks to Jens -;; Bloch Helmers for encouraging me to write this code, for creative -;; suggestions as well as for the lists of hpf-commands. -;; Also thanks to the authors of the fortran and pascal modes, on which some -;; of this code is built. - -;;; Code: - -(defconst bug-f90-mode "T.Einarsson@clab.ericsson.se" - "Address of mailing list for F90 mode bugs.") - -;; User options -(defvar f90-do-indent 3 - "*Extra indentation applied to DO blocks.") - -(defvar f90-if-indent 3 - "*Extra indentation applied to IF, SELECT CASE, WHERE and FORALL blocks.") - -(defvar f90-type-indent 3 - "*Extra indentation applied to TYPE, INTERFACE and BLOCK DATA blocks.") - -(defvar f90-program-indent 2 - "*Extra indentation applied to PROGRAM/MODULE/SUBROUTINE/FUNCTION blocks.") - -(defvar f90-continuation-indent 5 - "*Extra indentation applied to F90 continuation lines.") - -(defvar f90-comment-region "!!$" - "*String inserted by \\[f90-comment-region]\ - at start of each line in region.") - -(defvar f90-indented-comment-re "!" - "*Regexp saying which comments to be indented like code.") - -(defvar f90-directive-comment-re "!hpf\\$" - "*Regexp of comment-like directive like \"!HPF\\\\$\", not to be indented.") - -(defvar f90-beginning-ampersand t - "*t makes automatic insertion of \& at beginning of continuation line.") - -(defvar f90-smart-end 'blink - "*From an END statement, check and fill the end using matching block start. -Allowed values are 'blink, 'no-blink, and nil, which determine -whether to blink the matching beginning.") - -(defvar f90-break-delimiters "[-+\\*/><=,% \t]" - "*Regexp holding list of delimiters at which lines may be broken.") - -(defvar f90-break-before-delimiters t - "*Non-nil causes `f90-do-auto-fill' to break lines before delimiters.") - -(defvar f90-auto-keyword-case nil - "*Automatic case conversion of keywords. - The options are 'downcase-word, 'upcase-word, 'capitalize-word and nil") - -(defvar f90-leave-line-no nil - "*If nil, left-justify linenumbers.") - -(defvar f90-startup-message t - "*Non-nil displays a startup message when F90 mode is first called.") - -(defconst f90-keywords-re - ;;("allocate" "allocatable" "assign" "assignment" "backspace" "block" - ;;"call" "case" "character" "close" "common" "complex" "contains" - ;;"continue" "cycle" "data" "deallocate" "dimension" "do" "double" "else" - ;;"elseif" "elsewhere" "end" "enddo" "endfile" "endif" "entry" "equivalence" - ;;"exit" "external" "forall" "format" "function" "goto" "if" "implicit" - ;;"include" "inquire" "integer" "intent" "interface" "intrinsic" "logical" - ;;"module" "namelist" "none" "nullify" "only" "open" "operator" "optional" "parameter" - ;;"pause" "pointer" "precision" "print" "private" "procedure" "program" - ;;"public" "read" "real" "recursive" "result" "return" "rewind" "save" "select" - ;;"sequence" "stop" "subroutine" "target" "then" "type" "use" "where" - ;;"while" "write") - (concat - "\\<\\(a\\(llocat\\(able\\|e\\)\\|ssign\\(\\|ment\\)\\)\\|b\\(ackspace\\|" - "lock\\)\\|c\\(a\\(ll\\|se\\)\\|haracter\\|lose\\|o\\(m\\(mon\\|plex\\)\\|" - "nt\\(ains\\|inue\\)\\)\\|ycle\\)\\|d\\(ata\\|eallocate\\|imension\\|" - "o\\(\\|uble\\)\\)\\|e\\(lse\\(\\|if\\|where\\)\\|n\\(d\\(\\|do\\|file\\|" - "if\\)\\|try\\)\\|quivalence\\|x\\(it\\|ternal\\)\\)\\|f\\(or\\(all\\|" - "mat\\)\\|unction\\)\\|goto\\|i\\(f\\|mplicit\\|n\\(clude\\|quire\\|t\\(" - "e\\(ger\\|nt\\|rface\\)\\|rinsic\\)\\)\\)\\|logical\\|module\\|n\\(" - "amelist\\|one\\|ullify\\)\\|o\\(nly\\|p\\(en\\|erator\\|tional\\)\\)\\|p\\(a\\(" - "rameter\\|use\\)\\|ointer\\|r\\(ecision\\|i\\(nt\\|vate\\)\\|o\\(" - "cedure\\|gram\\)\\)\\|ublic\\)\\|re\\(a[dl]\\|cursive\\|sult\\|turn\\|wind\\)\\|" - "s\\(ave\\|e\\(lect\\|quence\\)\\|top\\|ubroutine\\)\\|t\\(arget\\|hen\\|" - "ype\\)\\|use\\|w\\(h\\(ere\\|ile\\)\\|rite\\)\\)\\>") - "Regexp for F90 keywords.") - -(defconst f90-keywords-level-3-re - ;; ("allocate" "allocatable" "assign" "assignment" "backspace" "close" - ;; "deallocate" "dimension" "endfile" "entry" "equivalence" "external" - ;; "inquire" "intent" "intrinsic" "nullify" "only" "open" "operator" - ;; "optional" "parameter" "pause" "pointer" "print" "private" "public" - ;; "read" "recursive" "result" "rewind" "save" "select" "sequence" - ;; "target" "write") - (concat - "\\<\\(a\\(llocat\\(able\\|e\\)\\|ssign\\(\\|ment\\)\\)\\|backspace\\|" - "close\\|d\\(eallocate\\|imension\\)\\|e\\(n\\(dfile\\|try\\)\\|" - "quivalence\\|xternal\\)\\|" - "in\\(quire\\|t\\(ent\\|rinsic\\)\\)\\|nullify\\|" - "o\\(nly\\|p\\(en\\|erator\\|tional\\)\\)\\|" - "p\\(a\\(rameter\\|use\\)\\|ointer\\|ri\\(nt\\|vate\\)\\|ublic\\)\\|re\\(" - "ad\\|cursive\\|sult\\|wind\\)\\|s\\(ave\\|e\\(lect\\|quence\\)\\)\\|target\\|" - "write\\)\\>") -"Keyword-regexp for font-lock level >= 3.") - - -(defconst f90-procedures-re - ;; ("abs" "achar" "acos" "adjustl" "adjustr" "aimag" "aint" "all" "allocated" - ;; "anint" "any" "asin" "associated" "atan" "atan2" "bit_size" "btest" - ;; "ceiling" "char" "cmplx" "conjg" "cos" "cosh" "count" "cshift" - ;; "date_and_time" "dble" "digits" "dim" "dot_product" "dprod" "eoshift" - ;; "epsilon" "exp" "exponent" "floor" "fraction" "huge" "iachar" "iand" - ;; "ibclr" "ibits" "ibset" "ichar" "ieor" "index" "int" "ior" "ishft" - ;; "ishftc" "kind" "lbound" "len" "len_trim" "lge" "lgt" "lle" "llt" "log" - ;; "logical" "log10" "matmul" "max" "maxexponent" "maxloc" "maxval" "merge" - ;; "min" "minexponent" "minloc" "minval" "mod" "modulo" "mvbits" "nearest" - ;; "nint" "not" "pack" "precision" "present" "product" "radix" - ;; "random_number" "random_seed" "range" "real" "repeat" "reshape" - ;; "rrspacing" "scale" "scan" "selected_int_kind" "selected_real_kind" - ;; "set_exponent" "shape" "sign" "sin" "sinh" "size" "spacing" "spread" - ;; "sqrt" "sum" "system_clock" "tan" "tanh" "tiny" "transfer" "transpose" - ;; "trim" "ubound" "unpack" "verify") - ;; A left parenthesis to avoid highlighting non-procedures. - ;; Real is taken out here to avoid highlighting declarations. - (concat - "\\<\\(a\\(bs\\|c\\(har\\|os\\)\\|djust[lr]\\|i\\(mag\\|nt\\)\\|ll\\(\\|" - "ocated\\)\\|n\\(int\\|y\\)\\|s\\(in\\|sociated\\)\\|tan2?\\)\\|b\\(" - "it_size\\|test\\)\\|c\\(eiling\\|har\\|mplx\\|o\\(njg\\|sh?\\|unt\\)\\|" - "shift\\)\\|d\\(ate_and_time\\|ble\\|i\\(gits\\|m\\)\\|ot_product\\|prod" - "\\)\\|e\\(oshift\\|psilon\\|xp\\(\\|onent\\)\\)\\|f\\(loor\\|" - "raction\\)\\|huge\\|i\\(a\\(char\\|nd\\)\\|b\\(clr\\|its\\|set\\)\\|" - "char\\|eor\\|n\\(dex\\|t\\)\\|or\\|shftc?\\)\\|kind\\|l\\(bound\\|" - "en\\(\\|_trim\\)\\|g[et]\\|l[et]\\|og\\(\\|10\\|ical\\)\\)\\|m\\(a\\(" - "tmul\\|x\\(\\|exponent\\|loc\\|val\\)\\)\\|erge\\|in\\(\\|exponent\\|" - "loc\\|val\\)\\|od\\(\\|ulo\\)\\|vbits\\)\\|n\\(earest\\|int\\|ot\\)\\|" - "p\\(ack\\|r\\(e\\(cision\\|sent\\)\\|oduct\\)\\)\\|r\\(a\\(dix\\|n\\(" - "dom_\\(number\\|seed\\)\\|ge\\)\\)\\|e\\(peat\\|shape\\)\\|rspacing\\)\\|" - "s\\(ca\\(le\\|n\\)\\|e\\(lected_\\(int_kind\\|real_kind\\)\\|" - "t_exponent\\)\\|hape\\|i\\(gn\\|nh?\\|ze\\)\\|p\\(acing\\|read\\)\\|" - "qrt\\|um\\|ystem_clock\\)\\|t\\(anh?\\|iny\\|r\\(ans\\(fer\\|pose\\)\\|" - "im\\)\\)\\|u\\(bound\\|npack\\)\\|verify\\)[ \t]*(") - "Regexp whose first part matches F90 intrinsic procedures.") - -(defconst f90-operators-re -;; "and" "or" "not" "eqv" "neqv" "eq" "ne" "lt" "le" "gt" "ge" "true" "false" - (concat - "\\.\\(and\\|eqv?\\|false\\|g[et]\\|l[et]\\|n\\(e\\(\\|qv\\)\\|" - "ot\\)\\|or\\|true\\)\\.") - "Regexp matching intrinsic operators.") - -(defconst f90-hpf-keywords-re - ;; Intrinsic procedures - ;; ("all_prefix" "all_scatter" "all_suffix" "any_prefix" "any_scatter" - ;; "any_suffix" "copy_prefix" "copy_scatter" "copy_suffix" "count_prefix" - ;; "count_scatter" "count_suffix" "grade_down" "grade_up" "hpf_alignment" - ;; "hpf_template" "hpf_distribution" "iall" "iall_prefix" "iall_scatter" - ;; "iall_suffix" "iany" "iany_prefix" "iany_scatter" "iany_suffix" "iparity" - ;; "iparity_prefix" "iparity_scatter" "iparity_suffix" "leadz" - ;; "maxval_prefix" "maxval_scatter" "maxval_suffix" "minval_prefix" - ;; "minval_scatter" "minval_suffix" "parity" "parity_prefix" - ;; "parity_scatter" "parity_suffix" "popcnt" "poppar" "product_prefix" - ;; "product_scatter" "product_suffix" "sum_prefix" "sum_scatter" - ;; "sum_suffix" "ilen" "number_of_processors" "processors_shape") - ;; Directives - ;; ("align" "distribute" "dynamic" "inherit" "template" "processors" - ;; "realign" "redistribute" "independent") - ;; Keywords - ;; ("pure" "extrinsic" "new" "with" "onto" "block" "cyclic") - (concat - "\\<\\(a\\(l\\(ign\\|l_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|ny_\\(" - "prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|block\\|c\\(o\\(py_\\(prefix\\|" - "s\\(catter\\|uffix\\)\\)\\|unt_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|" - "yclic\\)\\|d\\(istribute\\|ynamic\\)\\|extrinsic\\|grade_\\(down\\|" - "up\\)\\|hpf_\\(alignment\\|distribution\\|template\\)\\|i\\(a\\(ll\\(\\|" - "_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|ny\\(\\|_\\(prefix\\|s\\(" - "catter\\|uffix\\)\\)\\)\\)\\|len\\|n\\(dependent\\|herit\\)\\|parity\\(\\|" - "_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\)\\|leadz\\|m\\(axval_\\(" - "prefix\\|s\\(catter\\|uffix\\)\\)\\|inval_\\(prefix\\|s\\(catter\\|" - "uffix\\)\\)\\)\\|n\\(ew\\|umber_of_processors\\)\\|onto\\|p\\(arity\\(\\|" - "_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|op\\(cnt\\|par\\)\\|ro\\(" - "cessors\\(\\|_shape\\)\\|duct_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|" - "ure\\)\\|re\\(align\\|distribute\\)\\|sum_\\(prefix\\|s\\(catter\\|" - "uffix\\)\\)\\|template\\|with\\)\\>") - "Regexp for all HPF keywords, procedures and directives.") - -;; Highlighting patterns - -(defvar f90-font-lock-keywords-1 - (list ; Emacs - '("\\<\\(end[ \t]*\\(program\\|module\\|function\\|subroutine\\|type\\)\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) - '("\\<\\(program\\|call\\|module\\|subroutine\\|function\\|use\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ;; Special highlighting of "module procedure foo-list" - '("\\<\\(module[ \t]*procedure\\)\\>" (1 font-lock-keyword-face t)) - ;; Highlight definition of new type - '("\\<\\(type\\)[ \t]*\\(,.*::[ \t]*\\|[ \t]+\\)\\(\\sw+\\)" - (1 font-lock-keyword-face) (3 font-lock-function-name-face)) - "\\<\\(\\(end[ \t]*\\)?\\(interface\\|block[ \t]*data\\)\\|contains\\)\\>") - "This does fairly subdued highlighting of comments and function calls.") - -(defvar f90-font-lock-keywords-2 - (append f90-font-lock-keywords-1 - (list - ;; Variable declarations (avoid the real function call) - '("^[ \t0-9]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\)\\(.*::\\|[ \t]*(.*)\\)?\\([^!\n]*\\)" - (1 font-lock-type-face) (4 font-lock-variable-name-face)) - ;; do, if, select, where, and forall constructs - '("\\<\\(end[ \t]*\\(do\\|if\\|select\\|forall\\|where\\)\\)\\>\\([ \t]+\\(\\sw+\\)\\)?" - (1 font-lock-keyword-face) (3 font-lock-reference-face nil t)) - '("^[ \t0-9]*\\(\\(\\sw+\\)[ \t]*:[ \t]*\\)?\\(\\(if\\|do\\([ \t]*while\\)?\\|select[ \t]*case\\|where\\|forall\\)\\)\\>" - (2 font-lock-reference-face nil t) (3 font-lock-keyword-face)) - ;; implicit declaration - '("\\<\\(implicit\\)[ \t]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\|none\\)\\>" (1 font-lock-keyword-face) (2 font-lock-type-face)) - '("\\<\\(namelist\\|common\\)[ \t]*\/\\(\\sw+\\)?\/" (1 font-lock-keyword-face) (2 font-lock-reference-face nil t)) - "\\<else\\([ \t]*if\\|where\\)?\\>" - "\\<\\(then\\|continue\\|format\\|include\\|stop\\|return\\)\\>" - '("\\<\\(exit\\|cycle\\)[ \t]*\\(\\sw+\\)?\\>" - (1 font-lock-keyword-face) (2 font-lock-reference-face nil t)) - '("\\<\\(case\\)[ \t]*\\(default\\|(\\)" . 1) - '("\\<\\(do\\|go *to\\)\\>[ \t]*\\([0-9]+\\)" - (1 font-lock-keyword-face) (2 font-lock-reference-face)) - ;; line numbers (lines whose first character after number is letter) - '("^[ \t]*\\([0-9]+\\)[ \t]*[a-z]+" (1 font-lock-reference-face t)))) - "Highlights declarations, do-loops and other constructions") - -(defvar f90-font-lock-keywords-3 - (append f90-font-lock-keywords-2 - (list - f90-keywords-level-3-re - f90-operators-re - (if (string-match "XEmacs" emacs-version) - (append (list f90-procedures-re) '(1 font-lock-keyword-face t)) - (list f90-procedures-re '(1 font-lock-keyword-face t))) - "\\<real\\>" ; Avoid overwriting real defs. - )) - "Highlights all F90 keywords and intrinsic procedures.") - -(defvar f90-font-lock-keywords-4 - (append f90-font-lock-keywords-3 - (list f90-hpf-keywords-re)) - "Highlights all F90 and HPF keywords.") - -(defvar f90-font-lock-keywords - f90-font-lock-keywords-2 - "*Default expressions to highlight in F90 mode.") - -;; syntax table -(defvar f90-mode-syntax-table nil - "Syntax table in use in F90 mode buffers.") - -(if f90-mode-syntax-table - () - (setq f90-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\! "<" f90-mode-syntax-table) ; beg. comment - (modify-syntax-entry ?\n ">" f90-mode-syntax-table) ; end comment - (modify-syntax-entry ?_ "w" f90-mode-syntax-table) ; underscore in names - (modify-syntax-entry ?\' "\"" f90-mode-syntax-table) ; string quote - (modify-syntax-entry ?\" "\"" f90-mode-syntax-table) ; string quote - (modify-syntax-entry ?\` "w" f90-mode-syntax-table) ; for abbrevs - (modify-syntax-entry ?\r " " f90-mode-syntax-table) ; return is whitespace - (modify-syntax-entry ?+ "." f90-mode-syntax-table) - (modify-syntax-entry ?- "." f90-mode-syntax-table) - (modify-syntax-entry ?= "." f90-mode-syntax-table) - (modify-syntax-entry ?* "." f90-mode-syntax-table) - (modify-syntax-entry ?/ "." f90-mode-syntax-table) - (modify-syntax-entry ?\\ "/" f90-mode-syntax-table)) ; escape chars - -;; keys -(defvar f90-mode-map () - "Keymap used in F90 mode.") - -(if f90-mode-map - () - (setq f90-mode-map (make-sparse-keymap)) - (define-key f90-mode-map "`" 'f90-abbrev-start) - (define-key f90-mode-map "\C-c;" 'f90-comment-region) - (define-key f90-mode-map "\C-\M-a" 'f90-beginning-of-subprogram) - (define-key f90-mode-map "\C-\M-e" 'f90-end-of-subprogram) - (define-key f90-mode-map "\C-\M-h" 'f90-mark-subprogram) - (define-key f90-mode-map "\C-\M-q" 'f90-indent-subprogram) - (define-key f90-mode-map "\C-j" 'f90-indent-new-line) ; LFD equals C-j - (define-key f90-mode-map "\r" 'newline) - (define-key f90-mode-map "\C-c\r" 'f90-break-line) - ;; (define-key f90-mode-map [M-return] 'f90-break-line) - (define-key f90-mode-map "\C-c\C-d" 'f90-join-lines) - (define-key f90-mode-map "\C-c\C-f" 'f90-fill-region) - (define-key f90-mode-map "\C-c\C-p" 'f90-previous-statement) - (define-key f90-mode-map "\C-c\C-n" 'f90-next-statement) - (define-key f90-mode-map "\C-c\C-w" 'f90-insert-end) - (define-key f90-mode-map "\t" 'f90-indent-line) - (define-key f90-mode-map "," 'f90-electric-insert) - (define-key f90-mode-map "+" 'f90-electric-insert) - (define-key f90-mode-map "-" 'f90-electric-insert) - (define-key f90-mode-map "*" 'f90-electric-insert) - (define-key f90-mode-map "/" 'f90-electric-insert)) - - -;; menus -(if (string-match "XEmacs" emacs-version) - (defvar f90-xemacs-menu - '("F90" - ["Indent Subprogram" f90-indent-subprogram t] - ["Mark Subprogram" f90-mark-subprogram t] - ["Beginning of Subprogram" f90-beginning-of-subprogram t] - ["End of Subprogram" f90-end-of-subprogram t] - "-----" - ["(Un)Comment Region" f90-comment-region t] - ["Indent Region" indent-region t] - ["Fill Region" f90-fill-region t] - "-----" - ["Break Line at Point" f90-break-line t] - ["Join with Next Line" f90-join-lines t] - ["Insert Newline" newline t] - ["Insert Block End" f90-insert-end t] - "-----" - ["Upcase Keywords (buffer)" f90-upcase-keywords t] - ["Upcase Keywords (region)" f90-upcase-region-keywords - t] - ["Capitalize Keywords (buffer)" f90-capitalize-keywords t] - ["Capitalize Keywords (region)" - f90-capitalize-region-keywords t] - ["Downcase Keywords (buffer)" f90-downcase-keywords t] - ["Downcase Keywords (region)" - f90-downcase-region-keywords t] - "-----" - ["Toggle abbrev-mode" abbrev-mode t] - ["Toggle auto-fill" auto-fill-mode t]) - "XEmacs menu for F90 mode.") - ;; Emacs - - (defvar f90-change-case-menu - (let ((map (make-sparse-keymap "Change Keyword Case"))) - - (define-key map [dkr] (cons "Downcase Keywords (region)" - 'f90-downcase-region-keywords)) - (put 'f90-downcase-region-keywords 'menu-enable 'mark-active) - - (define-key map [ckr] (cons "Capitalize Keywords (region)" - 'f90-capitalize-region-keywords)) - (put 'f90-capitalize-region-keywords 'menu-enable 'mark-active) - - (define-key map [ukr] (cons "Upcase Keywords (region)" - 'f90-upcase-region-keywords)) - (put 'f90-upcase-region-keywords 'menu-enable 'mark-active) - - (define-key map [line] (list "-----------------")) - - (define-key map [dkb] (cons "Downcase Keywords (buffer)" - 'f90-downcase-keywords)) - - (define-key map [ckb] (cons "Capitalize Keywords (buffer)" - 'f90-capitalize-keywords)) - - (define-key map [ukb] (cons "Upcase Keywords (buffer)" - 'f90-upcase-keywords)) - map) - "Submenu for change of case.") - (defalias 'f90-change-case-menu f90-change-case-menu) - - ;; font-lock-menu and function calls - (defalias 'f90-font-lock-on 'font-lock-mode) - (defalias 'f90-font-lock-off 'font-lock-mode) - (put 'f90-font-lock-on 'menu-enable 'font-lock-mode) - (put 'f90-font-lock-off 'menu-enable '(not font-lock-mode)) - - (defun f90-font-lock-1 () - (interactive) - "Set font-lock-keywords to f90-font-lock-keywords-1." - (font-lock-mode 1) - (setq font-lock-keywords f90-font-lock-keywords-1) - (font-lock-fontify-buffer)) - - (defun f90-font-lock-2 () - (interactive) - "Set font-lock-keywords to f90-font-lock-keywords-2." - (font-lock-mode 1) - (setq font-lock-keywords f90-font-lock-keywords-2) - (font-lock-fontify-buffer)) - - (defun f90-font-lock-3 () - (interactive) - "Set font-lock-keywords to f90-font-lock-keywords-3." - (font-lock-mode 1) - (setq font-lock-keywords f90-font-lock-keywords-3) - (font-lock-fontify-buffer)) - - (defun f90-font-lock-4 () - (interactive) - "Set font-lock-keywords to f90-font-lock-keywords-4." - (font-lock-mode 1) - (setq font-lock-keywords f90-font-lock-keywords-4) - (font-lock-fontify-buffer)) - - (defvar f90-font-lock-menu - (let ((map (make-sparse-keymap "f90-font-lock-menu"))) - (define-key map [h4] (cons "Maximum highlighting (level 4)" - 'f90-font-lock-4)) - (define-key map [h3] (cons "Heavy highlighting (level 3)" - 'f90-font-lock-3)) - (define-key map [h2] (cons "Default highlighting (level 2)" - 'f90-font-lock-2)) - (define-key map [h1] (cons "Light highlighting (level 1)" - 'f90-font-lock-1)) - (define-key map [line] (list "-----------------")) - (define-key map [floff] (cons "Turn off font-lock-mode" - 'f90-font-lock-on)) - (define-key map [flon] (cons "Turn on font-lock-mode" - 'f90-font-lock-off)) - map) - "Submenu for highlighting using font-lock-mode.") - (defalias 'f90-font-lock-menu f90-font-lock-menu) - - (define-key f90-mode-map [menu-bar] (make-sparse-keymap)) - (define-key f90-mode-map [menu-bar f90] - (cons "F90" (make-sparse-keymap "f90"))) - - (define-key f90-mode-map [menu-bar f90 f90-imenu-menu] - '("Add imenu Menu" . f90-add-imenu-menu)) - (define-key f90-mode-map [menu-bar f90 abbrev-mode] - '("Toggle abbrev-mode" . abbrev-mode)) - (define-key f90-mode-map [menu-bar f90 auto-fill-mode] - '("Toggle auto-fill" . auto-fill-mode)) - (define-key f90-mode-map [menu-bar f90 line1] - '("----")) - (define-key f90-mode-map [menu-bar f90 f90-change-case-menu] - (cons "Change Keyword Case" 'f90-change-case-menu)) - (define-key f90-mode-map [menu-bar f90 f90-font-lock-menu] - (cons "Highlighting" 'f90-font-lock-menu)) - (define-key f90-mode-map [menu-bar f90 line2] - '("----")) - - (define-key f90-mode-map [menu-bar f90 f90-insert-end] - '("Insert Block End" . f90-insert-end)) - (define-key f90-mode-map [menu-bar f90 f90-join-lines] - '("Join with Next Line" . f90-join-lines)) - (define-key f90-mode-map [menu-bar f90 f90-break-line] - '("Break Line at Point" . f90-break-line)) - - (define-key f90-mode-map [menu-bar f90 line3] - '("----")) - - (define-key f90-mode-map [menu-bar f90 f90-fill-region] - '("Fill Region" . f90-fill-region)) - (put 'f90-fill-region 'menu-enable 'mark-active) - - (define-key f90-mode-map [menu-bar f90 indent-region] - '("Indent Region" . indent-region)) - - (define-key f90-mode-map [menu-bar f90 f90-comment-region] - '("(Un)Comment Region" . f90-comment-region)) - (put 'f90-comment-region 'menu-enable 'mark-active) - - (define-key f90-mode-map [menu-bar f90 line4] - '("----")) - - (define-key f90-mode-map [menu-bar f90 f90-end-of-subprogram] - '("End of Subprogram" . f90-end-of-subprogram)) - (define-key f90-mode-map [menu-bar f90 f90-beginning-of-subprogram] - '("Beginning of Subprogram" . f90-beginning-of-subprogram)) - (define-key f90-mode-map [menu-bar f90 f90-mark-subprogram] - '("Mark Subprogram" . f90-mark-subprogram)) - (define-key f90-mode-map [menu-bar f90 f90-indent-subprogram] - '("Indent Subprogram" . f90-indent-subprogram)) - ) - -;; Regexps for finding program structures. -(defconst f90-blocks-re - "\\(block[ \t]*data\\|do\\|if\\|interface\\|function\\|module\\|\ -program\\|select\\|subroutine\\|type\\|where\\|forall\\)\\>") -(defconst f90-program-block-re - "\\(program\\|module\\|subroutine\\|function\\)") -(defconst f90-else-like-re - "\\(else\\([ \t]*if\\|where\\)?\\|case[ \t]*\\(default\\|(\\)\\)") -(defconst f90-end-if-re - "end[ \t]*\\(if\\|select\\|where\\|forall\\)\\>") -(defconst f90-end-type-re - "end[ \t]*\\(type\\|interface\\|block[ \t]*data\\)") -(defconst f90-type-def-re - "\\<\\(type\\)[ \t]*\\(,.*::[ \t]*\\|[ \t]+\\)\\(\\sw+\\)") -(defconst f90-no-break-re "\\(\\*\\*\\|//\\|=>\\)") -;; A temporary position to make region operators faster -(defvar f90-cache-position nil) -(make-variable-buffer-local 'f90-cache-position) -;; A flag to tell whether f90-imenu is turned on. -(defvar f90-imenu nil) -(make-variable-buffer-local 'f90-imenu) - - -;; Imenu support -(defvar f90-imenu-generic-expression - (let ((good-char "[^!\"\&\n \t]") (not-e "[^e!\n\"\& \t]") - (not-n "[^n!\n\"\& \t]") (not-d "[^d!\n\"\& \t]")) - (list - '(nil "^[ \t0-9]*program[ \t]+\\(\\sw+\\)" 1) - '("Modules" "^[ \t0-9]*module[ \t]+\\(\\sw+\\)[ \t]*\\(!\\|$\\)" 1) - '("Types" "^[ \t0-9]*type[ \t]+\\(\\sw+\\)" 1) - (list - "Procedures" - (concat - "^[ \t0-9]*" - "\\(" - ;; At least three non-space characters before function/subroutine - ;; Check that the last three non-space characters don't spell E N D - "[^!\"\&\n]*\\(" - not-e good-char good-char "\\|" - good-char not-n good-char "\\|" - good-char good-char not-d "\\)" - "\\|" - ;; Less than three non-space characters before function/subroutine - good-char "?" good-char "?" - "\\)" - "[ \t]*\\(function\\|subroutine\\)[ \t]+\\(\\sw+\\)") - 4))) - "imenu generic expression for F90 mode.") - -(defun f90-add-imenu-menu () - (interactive) - "Add an imenu menu to the menubar." - (if (not f90-imenu) - (progn - (imenu-add-to-menubar "F90-imenu") - (redraw-frame (selected-frame)) - (setq f90-imenu t)) - (message "%s" "F90-imenu already exists."))) -(put 'f90-add-imenu-menu 'menu-enable '(not f90-imenu)) - - -;; When compiling under GNU Emacs, load imenu during compilation. If -;; you have 19.22 or earlier, comment this out, or get imenu. -(and (fboundp 'eval-when-compile) - (eval-when-compile - (if (not (string-match "XEmacs" emacs-version)) - (require 'imenu)) - ())) - -;; abbrevs have generally two letters, except standard types `c, `i, `r, `t -(defvar f90-mode-abbrev-table nil) -(if f90-mode-abbrev-table - () - (let ((ac abbrevs-changed)) - (define-abbrev-table 'f90-mode-abbrev-table ()) - (define-abbrev f90-mode-abbrev-table "`al" "allocate" nil) - (define-abbrev f90-mode-abbrev-table "`ab" "allocatable" nil) - (define-abbrev f90-mode-abbrev-table "`as" "assignment" nil) - (define-abbrev f90-mode-abbrev-table "`ba" "backspace" nil) - (define-abbrev f90-mode-abbrev-table "`bd" "block data" nil) - (define-abbrev f90-mode-abbrev-table "`c" "character" nil) - (define-abbrev f90-mode-abbrev-table "`cl" "close" nil) - (define-abbrev f90-mode-abbrev-table "`cm" "common" nil) - (define-abbrev f90-mode-abbrev-table "`cx" "complex" nil) - (define-abbrev f90-mode-abbrev-table "`cn" "contains" nil) - (define-abbrev f90-mode-abbrev-table "`cy" "cycle" nil) - (define-abbrev f90-mode-abbrev-table "`de" "deallocate" nil) - (define-abbrev f90-mode-abbrev-table "`df" "define" nil) - (define-abbrev f90-mode-abbrev-table "`di" "dimension" nil) - (define-abbrev f90-mode-abbrev-table "`dw" "do while" nil) - (define-abbrev f90-mode-abbrev-table "`el" "else" nil) - (define-abbrev f90-mode-abbrev-table "`eli" "else if" nil) - (define-abbrev f90-mode-abbrev-table "`elw" "elsewhere" nil) - (define-abbrev f90-mode-abbrev-table "`eq" "equivalence" nil) - (define-abbrev f90-mode-abbrev-table "`ex" "external" nil) - (define-abbrev f90-mode-abbrev-table "`ey" "entry" nil) - (define-abbrev f90-mode-abbrev-table "`fl" "forall" nil) - (define-abbrev f90-mode-abbrev-table "`fo" "format" nil) - (define-abbrev f90-mode-abbrev-table "`fu" "function" nil) - (define-abbrev f90-mode-abbrev-table "`fa" ".false." nil) - (define-abbrev f90-mode-abbrev-table "`im" "implicit none" nil) - (define-abbrev f90-mode-abbrev-table "`in " "include" nil) - (define-abbrev f90-mode-abbrev-table "`i" "integer" nil) - (define-abbrev f90-mode-abbrev-table "`it" "intent" nil) - (define-abbrev f90-mode-abbrev-table "`if" "interface" nil) - (define-abbrev f90-mode-abbrev-table "`lo" "logical" nil) - (define-abbrev f90-mode-abbrev-table "`mo" "module" nil) - (define-abbrev f90-mode-abbrev-table "`na" "namelist" nil) - (define-abbrev f90-mode-abbrev-table "`nu" "nullify" nil) - (define-abbrev f90-mode-abbrev-table "`op" "optional" nil) - (define-abbrev f90-mode-abbrev-table "`pa" "parameter" nil) - (define-abbrev f90-mode-abbrev-table "`po" "pointer" nil) - (define-abbrev f90-mode-abbrev-table "`pr" "print" nil) - (define-abbrev f90-mode-abbrev-table "`pi" "private" nil) - (define-abbrev f90-mode-abbrev-table "`pm" "program" nil) - (define-abbrev f90-mode-abbrev-table "`pu" "public" nil) - (define-abbrev f90-mode-abbrev-table "`r" "real" nil) - (define-abbrev f90-mode-abbrev-table "`rc" "recursive" nil) - (define-abbrev f90-mode-abbrev-table "`rt" "return" nil) - (define-abbrev f90-mode-abbrev-table "`rw" "rewind" nil) - (define-abbrev f90-mode-abbrev-table "`se" "select" nil) - (define-abbrev f90-mode-abbrev-table "`sq" "sequence" nil) - (define-abbrev f90-mode-abbrev-table "`su" "subroutine" nil) - (define-abbrev f90-mode-abbrev-table "`ta" "target" nil) - (define-abbrev f90-mode-abbrev-table "`tr" ".true." nil) - (define-abbrev f90-mode-abbrev-table "`t" "type" nil) - (define-abbrev f90-mode-abbrev-table "`wh" "where" nil) - (define-abbrev f90-mode-abbrev-table "`wr" "write" nil) - (setq abbrevs-changed ac))) - -;;;###autoload -(defun f90-mode () - "Major mode for editing Fortran 90 code in free format. - -\\[f90-indent-new-line] corrects current indentation and creates new\ - indented line. -\\[f90-indent-line] indents the current line correctly. -\\[f90-indent-subprogram] indents the current subprogram. - -Type `? or `\\[help-command] to display a list of built-in\ - abbrevs for F90 keywords. - -Key definitions: -\\{f90-mode-map} - -Variables controlling indentation style and extra features: - - f90-do-indent - Extra indentation within do blocks. (default 3) - f90-if-indent - Extra indentation within if/select case/where/forall blocks. (default 3) - f90-type-indent - Extra indentation within type/interface/block-data blocks. (default 3) - f90-program-indent - Extra indentation within program/module/subroutine/function blocks. - (default 2) - f90-continuation-indent - Extra indentation applied to continuation lines. (default 5) - f90-comment-region - String inserted by \\[f90-comment-region] at start of each line in - region. (default \"!!!$\") - f90-indented-comment-re - Regexp determining the type of comment to be intended like code. - (default \"!\") - f90-directive-comment-re - Regexp of comment-like directive like \"!HPF\\\\$\", not to be indented. - (default \"!hpf\\\\$\") - f90-break-delimiters - Regexp holding list of delimiters at which lines may be broken. - (default \"[-+*/><=,% \\t]\") - f90-break-before-delimiters - Non-nil causes `f90-do-auto-fill' to break lines before delimiters. - (default t) - f90-beginning-ampersand - Automatic insertion of \& at beginning of continuation lines. (default t) - f90-smart-end - From an END statement, check and fill the end using matching block start. - Allowed values are 'blink, 'no-blink, and nil, which determine - whether to blink the matching beginning.) (default 'blink) - f90-auto-keyword-case - Automatic change of case of keywords. (default nil) - The possibilities are 'downcase-word, 'upcase-word, 'capitalize-word. - f90-leave-line-no - Do not left-justify line numbers. (default nil) - f90-startup-message - Set to nil to inhibit message first time F90 mode is used. (default t) - f90-keywords-re - List of keywords used for highlighting/upcase-keywords etc. - -Turning on F90 mode calls the value of the variable `f90-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (setq major-mode 'f90-mode) - (setq mode-name "F90") - (setq local-abbrev-table f90-mode-abbrev-table) - (set-syntax-table f90-mode-syntax-table) - (use-local-map f90-mode-map) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'f90-indent-line) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'f90-indent-region) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "!") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "!+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'f90-comment-indent) - (make-local-variable 'abbrev-all-caps) - (setq abbrev-all-caps t) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'f90-do-auto-fill) - (setq indent-tabs-mode nil) - ;; Setting up things for font-lock - (if (string-match "XEmacs" emacs-version) - (progn - (put 'f90-mode 'font-lock-keywords-case-fold-search t) - (if (and current-menubar - (not (assoc "F90" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-submenu nil f90-xemacs-menu))) - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords f90-font-lock-keywords)) - ;; Emacs - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(f90-font-lock-keywords nil t)) - - ;; Tell imenu how to handle f90. - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression f90-imenu-generic-expression)) - (run-hooks 'f90-mode-hook) - (if f90-startup-message - (message "Emacs F90 mode; please report bugs to %s" bug-f90-mode)) - (setq f90-startup-message nil)) - -;; inline-functions -(defsubst f90-get-beg-of-line () - (save-excursion (beginning-of-line) (point))) - -(defsubst f90-get-end-of-line () - (save-excursion (end-of-line) (point))) - -(defsubst f90-in-string () - (let ((beg-pnt - (if (and f90-cache-position (> (point) f90-cache-position)) - f90-cache-position - (point-min)))) - (nth 3 (parse-partial-sexp beg-pnt (point))))) - -(defsubst f90-in-comment () - (let ((beg-pnt - (if (and f90-cache-position (> (point) f90-cache-position)) - f90-cache-position - (point-min)))) - (nth 4 (parse-partial-sexp beg-pnt (point))))) - -(defsubst f90-line-continued () - (save-excursion - (let ((bol (f90-get-beg-of-line))) - (end-of-line) - (while (f90-in-comment) - (search-backward "!" bol) - (skip-chars-backward "!")) - (skip-chars-backward " \t") - (= (preceding-char) ?&)))) - -(defsubst f90-current-indentation () - "Return indentation of current line. -Line-numbers are considered whitespace characters." - (save-excursion - (beginning-of-line) (skip-chars-forward " \t0-9") - (current-column))) - -(defsubst f90-indent-to (col &optional no-line-number) - "Indent current line to column COL. -If no-line-number nil, jump over a possible line-number." - (beginning-of-line) - (if (not no-line-number) - (skip-chars-forward " \t0-9")) - (delete-horizontal-space) - (if (zerop (current-column)) - (indent-to col) - (indent-to col 1))) - -(defsubst f90-match-piece (arg) - (if (match-beginning arg) - (buffer-substring (match-beginning arg) (match-end arg)))) - -(defsubst f90-get-present-comment-type () - (save-excursion - (let ((type nil) (eol (f90-get-end-of-line))) - (if (f90-in-comment) - (progn - (beginning-of-line) - (re-search-forward "[!]+" eol) - (while (f90-in-string) - (re-search-forward "[!]+" eol)) - (setq type (buffer-substring (match-beginning 0) (match-end 0))))) - type))) - -(defsubst f90-equal-symbols (a b) - "Compare strings neglecting case and allowing for nil value." - (let ((a-local (if a (downcase a) nil)) - (b-local (if b (downcase b) nil))) - (equal a-local b-local))) - -;; XEmacs 19.11 & 19.12 gives back a single char when matching an empty regular -;; expression. Therefore, the next 2 functions are longer than necessary. - -(defsubst f90-looking-at-do () - "Return (\"do\" name) if a do statement starts after point. -Name is nil if the statement has no label." - (if (looking-at "\\(\\(\\sw+\\)[ \t]*\:\\)?[ \t]*\\(do\\)\\>") - (let (label - (struct (f90-match-piece 3))) - (if (looking-at "\\(\\sw+\\)[ \t]*\:") - (setq label (f90-match-piece 1))) - (list struct label)))) - -(defsubst f90-looking-at-select-case () - "Return (\"select\" name) if a select-case statement starts after point. -Name is nil if the statement has no label." - (if (looking-at "\\(\\(\\sw+\\)[ \t]*\:\\)?[ \t]*\\(select\\)[ \t]*case[ \t]*(") - (let (label - (struct (f90-match-piece 3))) - (if (looking-at "\\(\\sw+\\)[ \t]*\:") - (setq label (f90-match-piece 1))) - (list struct label)))) - -(defsubst f90-looking-at-if-then () - "Return (\"if\" name) if an if () then statement starts after point. -Name is nil if the statement has no label." - (save-excursion - (let (struct (label nil)) - (if (looking-at "\\(\\(\\sw+\\)[ \t]*\:\\)?[ \t]*\\(if\\)\\>") - (progn - (setq struct (f90-match-piece 3)) - (if (looking-at "\\(\\sw+\\)[ \t]*\:") - (setq label (f90-match-piece 1))) - (goto-char (scan-lists (point) 1 0)) - (skip-chars-forward " \t") - (if (or (looking-at "then\\>") - (if (f90-line-continued) - (progn - (f90-next-statement) - (skip-chars-forward " \t0-9&") - (looking-at "then\\>")))) - (list struct label))))))) - -(defsubst f90-looking-at-where-or-forall () - "Return (kind name) if a where or forall statement starts after point. -Name is nil if the statement has no label." - (if (looking-at "\\(\\(\\sw+\\)[ \t]*\:\\)?[ \t]*\\(where\\|forall\\)[ \t]*(") - (let (label - (struct (f90-match-piece 3))) - (if (looking-at "\\(\\sw+\\)[ \t]*\:") - (setq label (f90-match-piece 1))) - (list struct label)))) - -(defsubst f90-looking-at-type-like () - "Return (kind name) at the start of a type/interface/block-data block. -Name is non-nil only for type." - (cond - ((looking-at f90-type-def-re) - (list (f90-match-piece 1) (f90-match-piece 3))) - ((looking-at "\\(interface\\|block[\t]*data\\)\\>") - (list (f90-match-piece 1) nil)))) - -(defsubst f90-looking-at-program-block-start () - "Return (kind name) if a program block with name name starts after point." - (cond - ((looking-at "\\(program\\)[ \t]+\\(\\sw+\\)\\>") - (list (f90-match-piece 1) (f90-match-piece 2))) - ((and (not (looking-at "module[ \t]*procedure\\>")) - (looking-at "\\(module\\)[ \t]+\\(\\sw+\\)\\>")) - (list (f90-match-piece 1) (f90-match-piece 2))) - ((and (not (looking-at "end[ \t]*\\(function\\|subroutine\\)")) - (looking-at "[^!\"\&\n]*\\(function\\|subroutine\\)[ \t]+\\(\\sw+\\)")) - (list (f90-match-piece 1) (f90-match-piece 2))))) - -(defsubst f90-looking-at-program-block-end () - "Return list of type and name of end of block." - (if (looking-at (concat "end[ \t]*" f90-blocks-re - "?\\([ \t]+\\(\\sw+\\)\\)?\\>")) - (list (f90-match-piece 1) (f90-match-piece 3)))) - -(defsubst f90-comment-indent () - (cond ((looking-at "!!!") 0) - ((and f90-directive-comment-re - (looking-at f90-directive-comment-re)) 0) - ((looking-at (regexp-quote f90-comment-region)) 0) - ((looking-at f90-indented-comment-re) - (f90-calculate-indent)) - (t (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) comment-column)))) - -(defsubst f90-present-statement-cont () - "Return continuation properties of present statement." - (let (pcont cont) - (save-excursion - (setq pcont (if (f90-previous-statement) (f90-line-continued) nil))) - (setq cont (f90-line-continued)) - (cond ((and (not pcont) (not cont)) 'single) - ((and (not pcont) cont) 'begin) - ((and pcont (not cont)) 'end) - ((and pcont cont) 'middle) - (t (error))))) - -(defsubst f90-indent-line-no () - (if f90-leave-line-no - () - (if (and (not (zerop (skip-chars-forward " \t"))) - (looking-at "[0-9]")) - (delete-horizontal-space))) - (skip-chars-forward " \t0-9")) - -(defsubst f90-no-block-limit () - (let ((eol (f90-get-end-of-line))) - (save-excursion - (not (or (looking-at "end") - (looking-at "\\(do\\|if\\|else\\(if\\|where\\)?\ -\\|select[ \t]*case\\|case\\|where\\|forall\\)\\>") - (looking-at "\\(program\\|module\\|interface\\|\ -block[ \t]*data\\)\\>") - (looking-at "\\(contains\\|\\sw+[ \t]*:\\)") - (looking-at f90-type-def-re) - (re-search-forward "\\(function\\|subroutine\\)" eol t)))))) - -(defsubst f90-update-line () - (let (bol eol) - (if f90-auto-keyword-case - (progn (setq bol (f90-get-beg-of-line) - eol (f90-get-end-of-line)) - (if f90-auto-keyword-case - (f90-change-keywords f90-auto-keyword-case bol eol)))))) - -(defun f90-electric-insert () - (interactive) - "Calls f90-do-auto-fill at each operator insertion." - (self-insert-command 1) - (f90-update-line) - (if auto-fill-function (f90-do-auto-fill))) - -(defun f90-get-correct-indent () - "Get correct indent for a line starting with line number. -Does not check type and subprogram indentation." - (let ((epnt (f90-get-end-of-line)) icol cont) - (save-excursion - (while (and (f90-previous-statement) - (or (progn - (setq cont (f90-present-statement-cont)) - (or (eq cont 'end) (eq cont 'middle))) - (looking-at "[ \t]*[0-9]")))) - (setq icol (current-indentation)) - (beginning-of-line) - (if (re-search-forward "\\(if\\|do\\|select\\|where\\|forall\\)" - (f90-get-end-of-line) t) - (progn - (beginning-of-line) (skip-chars-forward " \t") - (cond ((f90-looking-at-do) - (setq icol (+ icol f90-do-indent))) - ((or (f90-looking-at-if-then) - (f90-looking-at-where-or-forall) - (f90-looking-at-select-case)) - (setq icol (+ icol f90-if-indent)))) - (end-of-line))) - (while (re-search-forward - "\\(if\\|do\\|select\\|where\\|forall\\)" epnt t) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond ((f90-looking-at-do) - (setq icol (+ icol f90-do-indent))) - ((or (f90-looking-at-if-then) - (f90-looking-at-where-or-forall) - (f90-looking-at-select-case)) - (setq icol (+ icol f90-if-indent))) - ((looking-at f90-end-if-re) - (setq icol (- icol f90-if-indent))) - ((looking-at "end[ \t]*do\\>") - (setq icol (- icol f90-do-indent)))) - (end-of-line)) - icol))) - - -(defun f90-calculate-indent () - "Calculate the indent column based on previous statements." - (interactive) - (let (icol cont (case-fold-search t) (pnt (point))) - (save-excursion - (if (not (f90-previous-statement)) - (setq icol 0) - (setq cont (f90-present-statement-cont)) - (if (eq cont 'end) - (while (not (eq 'begin (f90-present-statement-cont))) - (f90-previous-statement))) - (cond ((eq cont 'begin) - (setq icol (+ (f90-current-indentation) - f90-continuation-indent))) - ((eq cont 'middle) (setq icol(current-indentation))) - (t (setq icol (f90-current-indentation)) - (skip-chars-forward " \t") - (if (looking-at "[0-9]") - (setq icol (f90-get-correct-indent)) - (cond ((or (f90-looking-at-if-then) - (f90-looking-at-where-or-forall) - (f90-looking-at-select-case) - (looking-at f90-else-like-re)) - (setq icol (+ icol f90-if-indent))) - ((f90-looking-at-do) - (setq icol (+ icol f90-do-indent))) - ((f90-looking-at-type-like) - (setq icol (+ icol f90-type-indent))) - ((or (f90-looking-at-program-block-start) - (looking-at "contains[ \t]*\\($\\|!\\)")) - (setq icol (+ icol f90-program-indent))))) - (goto-char pnt) - (beginning-of-line) - (cond ((looking-at "[ \t]*$")) - ((looking-at "[ \t]*#") ; Check for cpp directive. - (setq icol 0)) - (t - (skip-chars-forward " \t0-9") - (cond ((or (looking-at f90-else-like-re) - (looking-at f90-end-if-re)) - (setq icol (- icol f90-if-indent))) - ((looking-at "end[ \t]*do\\>") - (setq icol (- icol f90-do-indent))) - ((looking-at f90-end-type-re) - (setq icol (- icol f90-type-indent))) - ((or (looking-at "contains[ \t]*\\(!\\|$\\)") - (f90-looking-at-program-block-end)) - (setq icol (- icol f90-program-indent)))))) - )))) - icol)) - -;; Statement = statement line, a line which is neither blank, nor a comment. -(defun f90-previous-statement () - "Move point to beginning of the previous F90 statement. -Return nil if no previous statement is found." - (interactive) - (let (not-first-statement) - (beginning-of-line) - (while (and (setq not-first-statement (zerop (forward-line -1))) - (looking-at "[ \t0-9]*\\(!\\|$\\|#\\)"))) - not-first-statement)) - -(defun f90-next-statement () - "Move point to beginning of the next F90 statement. -Return nil if no later statement is found." - (interactive) - (let (not-last-statement) - (beginning-of-line) - (while (and (setq not-last-statement - (and (zerop (forward-line 1)) - (not (eobp)))) - (looking-at "[ \t0-9]*\\(!\\|$\\)"))) - not-last-statement)) - -(defun f90-beginning-of-subprogram () - "Move point to the beginning of subprogram. -Return (type name) or nil if not found." - (interactive) - (let ((count 1) (case-fold-search t) matching-beg) - (beginning-of-line) (skip-chars-forward " \t0-9") - (if (setq matching-beg (f90-looking-at-program-block-start)) - (setq count (- count 1))) - (while (and (not (zerop count)) - (re-search-backward f90-program-block-re nil 'move)) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond - ((setq matching-beg (f90-looking-at-program-block-start)) - (setq count (- count 1))) - ((f90-looking-at-program-block-end) - (setq count (+ count 1))))) - (beginning-of-line) - (if (zerop count) - matching-beg - (message "No beginning-found.") - nil))) - -(defun f90-end-of-subprogram () - "Move point to the end of subprogram. -Return (type name) or nil if not found." - (interactive) - (let ((count 1) (case-fold-search t) matching-end) - (beginning-of-line) (skip-chars-forward " \t0-9") - (if (setq matching-end (f90-looking-at-program-block-end)) - (setq count (1- count))) - (end-of-line) - (while (and (not (zerop count)) - (re-search-forward f90-program-block-re nil 'move)) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond ((f90-looking-at-program-block-start) - (setq count (+ count 1))) - ((setq matching-end (f90-looking-at-program-block-end)) - (setq count (1- count )))) - (end-of-line)) - (forward-line 1) - (if (zerop count) - matching-end - (message "No end found.") - nil))) - -(defun f90-mark-subprogram () - "Put mark at end of F90 subprogram, point at beginning. -Marks are pushed and highlight (grey shadow) is turned on." - (interactive) - (let ((pos (point)) program) - (f90-end-of-subprogram) - (push-mark (point) t) - (goto-char pos) - (setq program (f90-beginning-of-subprogram)) - ;; The keywords in the preceding lists assume case-insensitivity. - (if (string-match "XEmacs" emacs-version) - (zmacs-activate-region) - (setq mark-active t) - (setq deactivate-mark nil)) - program)) - -(defun f90-comment-region (beg-region end-region) - "Comment/uncomment every line in the region. -Insert f90-comment-region at the beginning of every line in the region -or, if already present, remove it." - (interactive "*r") - (let ((end (make-marker))) - (set-marker end end-region) - (goto-char beg-region) - (beginning-of-line) - (if (looking-at (regexp-quote f90-comment-region)) - (delete-region (point) (match-end 0)) - (insert f90-comment-region)) - (while (and (zerop (forward-line 1)) - (< (point) (marker-position end))) - (if (looking-at (regexp-quote f90-comment-region)) - (delete-region (point) (match-end 0)) - (insert f90-comment-region))) - (set-marker end nil))) - -(defun f90-indent-line (&optional no-update) - "Indent current line as F90 code." - (interactive) - (let (indent (no-line-number nil) (pos (make-marker)) (case-fold-search t)) - (set-marker pos (point)) - (beginning-of-line) ; Digits after & \n are not line-no - (if (save-excursion (and (f90-previous-statement) (f90-line-continued))) - (progn (setq no-line-number t) (skip-chars-forward " \t")) - (f90-indent-line-no)) - (if (looking-at "!") - (setq indent (f90-comment-indent)) - (if (and (looking-at "end") f90-smart-end) - (f90-match-end)) - (setq indent (f90-calculate-indent))) - (if (zerop (- indent (current-column))) - nil - (f90-indent-to indent no-line-number)) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (< (point) (marker-position pos)) - (goto-char (marker-position pos))) - (if (not no-update) (f90-update-line)) - (if auto-fill-function (f90-do-auto-fill)) - (set-marker pos nil))) - -(defun f90-indent-new-line () - "Reindent the current F90 line, insert a newline and indent the newline. -An abbrev before point is expanded if `abbrev-mode' is non-nil. -If run in the middle of a line, the line is not broken." - (interactive) - (let (string cont (case-fold-search t)) - (if abbrev-mode (expand-abbrev)) - (beginning-of-line) ; Reindent where likely to be needed. - (f90-indent-line-no) - (if (or (looking-at "\\(end\\|else\\|!\\)")) - (f90-indent-line 'no-update)) - (end-of-line) - (delete-horizontal-space) ;Destroy trailing whitespace - (setq string (f90-in-string)) - (setq cont (f90-line-continued)) - (if (and string (not cont)) (insert "&")) - (f90-update-line) - (newline) - (if (or string (and cont f90-beginning-ampersand)) (insert "&")) - (f90-indent-line 'no-update))) - - -(defun f90-indent-region (beg-region end-region) - "Indent every line in region by forward parsing." - (interactive "*r") - (let ((end-region-mark (make-marker)) (save-point (point-marker)) - (block-list nil) ind-lev ind-curr ind-b cont - struct beg-struct end-struct) - (set-marker end-region-mark end-region) - (goto-char beg-region) - ;; first find a line which is not a continuation line or comment - (beginning-of-line) - (while (and (looking-at "[ \t]*[0-9]*\\(!\\|#\\|[ \t]*$\\)") - (progn (f90-indent-line 'no-update) - (zerop (forward-line 1))) - (< (point) end-region-mark))) - (setq cont (f90-present-statement-cont)) - (while (and (or (eq cont 'middle) (eq cont 'end)) - (f90-previous-statement)) - (setq cont (f90-present-statement-cont))) - ;; process present line for beginning of block - (setq f90-cache-position (point)) - (f90-indent-line 'no-update) - (setq ind-lev (f90-current-indentation)) - (setq ind-curr ind-lev) - (beginning-of-line) (skip-chars-forward " \t0-9") - (setq struct nil) - (setq ind-b (cond ((setq struct (f90-looking-at-do)) f90-do-indent) - ((or (setq struct (f90-looking-at-if-then)) - (setq struct (f90-looking-at-select-case)) - (setq struct (f90-looking-at-where-or-forall)) - (looking-at f90-else-like-re)) - f90-if-indent) - ((setq struct (f90-looking-at-type-like)) - f90-type-indent) - ((or(setq struct (f90-looking-at-program-block-start)) - (looking-at "contains[ \t]*\\($\\|!\\)")) - f90-program-indent))) - (if ind-b (setq ind-lev (+ ind-lev ind-b))) - (if struct (setq block-list (cons struct block-list))) - (while (and (f90-line-continued) (zerop (forward-line 1)) - (< (point) end-region-mark)) - (if (not (zerop (- (current-indentation) - (+ ind-curr f90-continuation-indent)))) - (f90-indent-to (+ ind-curr f90-continuation-indent) 'no-line-no))) - ;; process all following lines - (while (and (zerop (forward-line 1)) (< (point) end-region-mark)) - (beginning-of-line) - (f90-indent-line-no) - (setq f90-cache-position (point)) - (cond ((looking-at "[ \t]*$") (setq ind-curr 0)) - ((looking-at "[ \t]*#") (setq ind-curr 0)) - ((looking-at "!") (setq ind-curr (f90-comment-indent))) - ((f90-no-block-limit) (setq ind-curr ind-lev)) - ((looking-at f90-else-like-re) (setq ind-curr - (- ind-lev f90-if-indent))) - ((looking-at "contains[ \t]*\\($\\|!\\)") - (setq ind-curr (- ind-lev f90-program-indent))) - ((setq ind-b - (cond ((setq struct (f90-looking-at-do)) f90-do-indent) - ((or (setq struct (f90-looking-at-if-then)) - (setq struct (f90-looking-at-select-case)) - (setq struct (f90-looking-at-where-or-forall))) - f90-if-indent) - ((setq struct (f90-looking-at-type-like)) - f90-type-indent) - ((setq struct (f90-looking-at-program-block-start)) - f90-program-indent))) - (setq ind-curr ind-lev) - (if ind-b (setq ind-lev (+ ind-lev ind-b))) - (setq block-list (cons struct block-list))) - ((setq end-struct (f90-looking-at-program-block-end)) - (setq beg-struct (car block-list) - block-list (cdr block-list)) - (if f90-smart-end - (save-excursion - (f90-block-match (car beg-struct)(car (cdr beg-struct)) - (car end-struct)(car (cdr end-struct))))) - (setq ind-b - (cond ((looking-at f90-end-if-re) f90-if-indent) - ((looking-at "end[ \t]*do\\>") f90-do-indent) - ((looking-at f90-end-type-re) f90-type-indent) - ((f90-looking-at-program-block-end) - f90-program-indent))) - (if ind-b (setq ind-lev (- ind-lev ind-b))) - (setq ind-curr ind-lev)) - (t (setq ind-curr ind-lev))) - ;; do the indentation if necessary - (if (not (zerop (- ind-curr (current-column)))) - (f90-indent-to ind-curr)) - (while (and (f90-line-continued) (zerop (forward-line 1)) - (< (point) end-region-mark)) - (if (not (zerop (- (current-indentation) - (+ ind-curr f90-continuation-indent)))) - (f90-indent-to (+ ind-curr f90-continuation-indent) 'no-line-no)))) - ;; restore point etc - (setq f90-cache-position nil) - (goto-char save-point) - (set-marker end-region-mark nil) - (set-marker save-point nil) - (if (string-match "XEmacs" emacs-version) - (zmacs-deactivate-region) - (deactivate-mark)))) - -(defun f90-indent-subprogram () - "Properly indent the subprogram which contains point." - (interactive) - (save-excursion - (let (program) - (setq program (f90-mark-subprogram)) - (if program - (progn - (message "Indenting %s %s..." - (car program) (car (cdr program))) - (f90-indent-region (point) (mark)) - (message "Indenting %s %s...done" - (car program) (car (cdr program)))) - (message "Indenting the whole file...") - (f90-indent-region (point) (mark)) - (message "Indenting the whole file...done"))))) - -;; autofill and break-line -(defun f90-break-line (&optional no-update) - "Break line at point, insert continuation marker(s) and indent." - (interactive) - (let (ctype) - (cond ((f90-in-string) - (insert "&") (newline) (insert "&")) - ((f90-in-comment) - (setq ctype (f90-get-present-comment-type)) - (newline) - (insert ctype)) - (t (insert "&") - (if (not no-update) (f90-update-line)) - (newline) - (if f90-beginning-ampersand (insert "&"))))) - (f90-indent-line)) - -(defun f90-find-breakpoint () - "From fill-column, search backward for break-delimiter." - (let ((bol (f90-get-beg-of-line))) - (re-search-backward f90-break-delimiters bol) - (if f90-break-before-delimiters - (progn (backward-char) - (if (not (looking-at f90-no-break-re)) - (forward-char))) - (if (looking-at f90-no-break-re) - (forward-char 2) - (forward-char))))) - -(defun f90-do-auto-fill () - "Break line if non-white characters beyond fill-column. Also, update line. " - (interactive) - ;; Break the line before or after the last delimiter (non-word char) if - ;; position is beyond fill-column. - ;; Will not break **, //, or => (specified by f90-no-break-re). - (f90-update-line) - (while (> (current-column) fill-column) - (let ((pos-mark (point-marker))) - (move-to-column fill-column) - (if (not (f90-in-string)) - (f90-find-breakpoint)) - (f90-break-line) - (goto-char pos-mark) - (set-marker pos-mark nil)))) - - -(defun f90-join-lines () - "Join present line with next line, if this line ends with \&." - (interactive) - (let (pos (oldpos (point))) - (end-of-line) - (skip-chars-backward " \t") - (cond ((= (preceding-char) ?&) - (delete-char -1) - (setq pos (point)) - (forward-line 1) - (skip-chars-forward " \t") - (if (looking-at "\&") (delete-char 1)) - (delete-region pos (point)) - (if (not (f90-in-string)) - (progn (delete-horizontal-space) (insert " "))) - (if (and auto-fill-function - (> (save-excursion (end-of-line) - (current-column)) - fill-column)) - (f90-do-auto-fill)) - (goto-char oldpos) - t)))) - -(defun f90-fill-region (beg-region end-region) - "Fill every line in region by forward parsing. Join lines if possible." - (interactive "*r") - (let ((end-region-mark (make-marker)) - (f90-smart-end nil) (f90-auto-keyword-case nil) (go-on t) - (auto-fill-function nil)) - (set-marker end-region-mark end-region) - (goto-char beg-region) - (while go-on - ;; join as much as possible - (while (f90-join-lines)) - ;; chop the line if necessary - (while (> (save-excursion (end-of-line) (current-column)) - fill-column) - (move-to-column fill-column) - (f90-find-breakpoint) - (f90-break-line 'no-update)) - (setq go-on (and (< (point) (marker-position end-region-mark)) - (zerop (forward-line 1)))) - (setq f90-cache-position (point))) - (setq f90-cache-position nil) - (if (string-match "XEmacs" emacs-version) - (zmacs-deactivate-region) - (deactivate-mark)))) - -(defun f90-block-match (beg-block beg-name end-block end-name) - "Match end-struct with beg-struct and complete end-block if possible. -Leave point at the end of line." - (search-forward "end" (f90-get-end-of-line)) - (catch 'no-match - (if (not (f90-equal-symbols beg-block end-block)) - (if end-block - (progn - (message "END %s does not match %s." end-block beg-block) - (end-of-line) - (throw 'no-match nil)) - (message "Inserting %s." beg-block) - (insert (concat " " beg-block))) - (search-forward end-block)) - (if (not (f90-equal-symbols beg-name end-name)) - (cond ((and beg-name (not end-name)) - (message "Inserting %s." beg-name) - (insert (concat " " beg-name))) - ((and beg-name end-name) - (message "Replacing %s with %s." end-name beg-name) - (search-forward end-name) - (replace-match beg-name)) - ((and (not beg-name) end-name) - (message "Deleting %s." end-name) - (search-forward end-name) - (replace-match ""))) - (if end-name (search-forward end-name))) - (if (not (looking-at "[ \t]*!")) (delete-horizontal-space)))) - -(defun f90-match-end () - "From an end foo statement, find the corresponding foo including name." - (interactive) - (let ((count 1) (top-of-window (window-start)) (matching-beg nil) - (end-point (point)) (case-fold-search t) - beg-name end-name beg-block end-block end-struct) - (if (save-excursion (beginning-of-line) (skip-chars-forward " \t0-9") - (setq end-struct (f90-looking-at-program-block-end))) - (progn - (setq end-block (car end-struct)) - (setq end-name (car (cdr end-struct))) - (save-excursion - (beginning-of-line) - (while - (and (not (zerop count)) - (let ((stop nil) notexist) - (while (not stop) - (setq notexist - (not (re-search-backward - (concat "\\(" f90-blocks-re "\\)") nil t))) - (if notexist - (setq stop t) - (setq stop - (not (or (f90-in-string) - (f90-in-comment)))))) - (not notexist))) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond ((setq matching-beg - (cond - ((f90-looking-at-do)) - ((f90-looking-at-if-then)) - ((f90-looking-at-where-or-forall)) - ((f90-looking-at-select-case)) - ((f90-looking-at-type-like)) - ((f90-looking-at-program-block-start)))) - (setq count (- count 1))) - ((looking-at (concat "end[ \t]*" f90-blocks-re "\\b")) - (setq count (+ count 1))))) - (if (not (zerop count)) - (message "No matching beginning.") - (f90-update-line) - (if (eq f90-smart-end 'blink) - (if (< (point) top-of-window) - (message "Matches %s: %s" - (what-line) - (buffer-substring - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point)))) - (sit-for 1))) - (setq beg-block (car matching-beg)) - (setq beg-name (car (cdr matching-beg))) - (goto-char end-point) - (beginning-of-line) - (f90-block-match beg-block beg-name end-block end-name))))))) - -(defun f90-insert-end () - "Inserts an complete end statement matching beginning of present block." - (interactive) - (let ((f90-smart-end (if f90-smart-end f90-smart-end 'blink))) - (insert "end") - (f90-indent-new-line))) - -;; abbrevs and keywords - -(defun f90-abbrev-start () - "Typing `\\[help-command] or `? lists all the F90 abbrevs. -Any other key combination is executed normally." - (interactive) - (let (e c) - (insert last-command-char) - (if (string-match "XEmacs" emacs-version) - (progn - (setq e (next-command-event)) - (setq c (event-to-character e))) - (setq c (read-event))) - ;; insert char if not equal to `?' - (if (or (= c ??) (eq c help-char)) - (f90-abbrev-help) - (if (string-match "XEmacs" emacs-version) - (setq unread-command-event e) - (setq unread-command-events (list c)))))) - -(defun f90-abbrev-help () - "List the currently defined abbrevs in F90 mode." - (interactive) - (message "Listing abbrev table...") - (display-buffer (f90-prepare-abbrev-list-buffer)) - (message "Listing abbrev table...done")) - -(defun f90-prepare-abbrev-list-buffer () - (save-excursion - (set-buffer (get-buffer-create "*Abbrevs*")) - (erase-buffer) - (insert-abbrev-table-description 'f90-mode-abbrev-table t) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (edit-abbrevs-mode)) - (get-buffer-create "*Abbrevs*")) - -(defun f90-upcase-keywords () - "Upcase all F90 keywords in the buffer." - (interactive) - (f90-change-keywords 'upcase-word)) - -(defun f90-capitalize-keywords () - "Capitalize all F90 keywords in the buffer." - (interactive) - (f90-change-keywords 'capitalize-word)) - -(defun f90-downcase-keywords () - "Downcase all F90 keywords in the buffer." - (interactive) - (f90-change-keywords 'downcase-word)) - -(defun f90-upcase-region-keywords (beg end) - "Upcase all F90 keywords in the region." - (interactive "*r") - (f90-change-keywords 'upcase-word beg end)) - -(defun f90-capitalize-region-keywords (beg end) - "Capitalize all F90 keywords in the region." - (interactive "*r") - (f90-change-keywords 'capitalize-word beg end)) - -(defun f90-downcase-region-keywords (beg end) - "Downcase all F90 keywords in the region." - (interactive "*r") - (f90-change-keywords 'downcase-word beg end)) - -;; Change the keywords according to argument. -(defun f90-change-keywords (change-word &optional beg end) - (save-excursion - (setq beg (if beg beg (point-min))) - (setq end (if end end (point-max))) - (let ((keyword-re - (concat "\\(" - f90-keywords-re "\\|" f90-procedures-re "\\|" - f90-hpf-keywords-re "\\|" f90-operators-re "\\)")) - (ref-point (point-min)) state - (modified (buffer-modified-p)) saveword back-point) - (goto-char beg) - (unwind-protect - (while (re-search-forward keyword-re end t) - (if (progn - (setq state (parse-partial-sexp ref-point (point))) - (or (nth 3 state) (nth 4 state) - (save-excursion ; Check for cpp directive. - (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "#")))) - () - (setq ref-point (point) - back-point (save-excursion (backward-word 1) (point))) - (setq saveword (buffer-substring back-point ref-point)) - (funcall change-word -1) - (or (string= saveword (buffer-substring back-point ref-point)) - (setq modified t)))) - (or modified (set-buffer-modified-p nil)))))) - -(provide 'f90) - -;;; f90.el ends here diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el deleted file mode 100644 index 1c255b12a8c..00000000000 --- a/lisp/progmodes/fortran.el +++ /dev/null @@ -1,1589 +0,0 @@ -;;; fortran.el --- Fortran mode for GNU Emacs - -;; Copyright (c) 1986, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Michael D. Prange <prange@erl.mit.edu> -;; Maintainer: bug-fortran-mode@erl.mit.edu (Steve Gildea and others) -;; Version 1.30.6 (July 27, 1995) -;; Keywords: languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Fortran mode has been upgraded and is now maintained by Stephen A. Wood -;; (saw@cebaf.gov). It now will use either fixed format continuation line -;; markers (character in 6th column), or tab format continuation line style -;; (digit after a TAB character.) A auto-fill mode has been added to -;; automatically wrap fortran lines that get too long. - -;; We acknowledge many contributions and valuable suggestions by -;; Lawrence R. Dodd, Ralf Fassel, Ralph Finch, Stephen Gildea, -;; Dr. Anil Gokhale, Ulrich Mueller, Mark Neale, Eric Prestemon, -;; Gary Sabot and Richard Stallman. - -;; This file may be used with GNU Emacs version 18.xx if the following -;; variable and function substitutions are made. -;; Replace: -;; frame-width with screen-width -;; auto-fill-function with auto-fill-hook -;; comment-indent-function with comment-indent-hook -;; (setq unread-command-events (list c)) with (setq unread-command-char c) - -;; Bugs to bug-fortran-mode@erl.mit.edu - -;;; Code: - -(defconst fortran-mode-version "version 1.30.6") - -;;;###autoload -(defvar fortran-tab-mode-default nil - "*Default tabbing/carriage control style for empty files in Fortran mode. -A value of t specifies tab-digit style of continuation control. -A value of nil specifies that continuation lines are marked -with a character in column 6.") - -;; Buffer local, used to display mode line. -(defvar fortran-tab-mode-string nil - "String to appear in mode line when TAB format mode is on.") - -(defvar fortran-do-indent 3 - "*Extra indentation applied to DO blocks.") - -(defvar fortran-if-indent 3 - "*Extra indentation applied to IF blocks.") - -(defvar fortran-structure-indent 3 - "*Extra indentation applied to STRUCTURE, UNION, MAP and INTERFACE blocks.") - -(defvar fortran-continuation-indent 5 - "*Extra indentation applied to Fortran continuation lines.") - -(defvar fortran-comment-indent-style 'fixed - "*nil forces comment lines not to be touched, -'fixed makes fixed comment indentation to `fortran-comment-line-extra-indent' -columns beyond `fortran-minimum-statement-indent-fixed' (for -`indent-tabs-mode' of nil) or `fortran-minimum-statement-indent-tab' (for -`indent-tabs-mode' of t), and 'relative indents to current -Fortran indentation plus `fortran-comment-line-extra-indent'.") - -(defvar fortran-comment-line-extra-indent 0 - "*Amount of extra indentation for text within full-line comments.") - -(defvar comment-line-start nil - "*Delimiter inserted to start new full-line comment.") - -(defvar comment-line-start-skip nil - "*Regexp to match the start of a full-line comment.") - -(defvar fortran-minimum-statement-indent-fixed 6 - "*Minimum statement indentation for fixed format continuation style.") - -(defvar fortran-minimum-statement-indent-tab (max tab-width 6) - "*Minimum statement indentation for TAB format continuation style.") - -;; Note that this is documented in the v18 manuals as being a string -;; of length one rather than a single character. -;; The code in this file accepts either format for compatibility. -(defvar fortran-comment-indent-char " " - "*Single-character string inserted for Fortran comment indentation. -Normally a space.") - -(defvar fortran-line-number-indent 1 - "*Maximum indentation for Fortran line numbers. -5 means right-justify them within their five-column field.") - -(defvar fortran-check-all-num-for-matching-do nil - "*Non-nil causes all numbered lines to be treated as possible DO loop ends.") - -(defvar fortran-blink-matching-if nil - "*Non-nil causes \\[fortran-indent-line] on ENDIF statement to blink on matching IF. -Also, from an ENDDO statement blink on matching DO [WHILE] statement.") - -(defvar fortran-continuation-string "$" - "*Single-character string used for Fortran continuation lines. -In fixed format continuation style, this character is inserted in -column 6 by \\[fortran-split-line] to begin a continuation line. -Also, if \\[fortran-indent-line] finds this at the beginning of a line, it will -convert the line into a continuation line of the appropriate style. -Normally $.") - -(defvar fortran-comment-region "c$$$" - "*String inserted by \\[fortran-comment-region]\ - at start of each line in region.") - -(defvar fortran-electric-line-number t - "*Non-nil causes line number digits to be moved to the correct column as\ - typed.") - -(defvar fortran-startup-message t - "*Non-nil displays a startup message when Fortran mode is first called.") - -(defvar fortran-column-ruler-fixed - "0 4 6 10 20 30 40 5\ -\0 60 70\n\ -\[ ]|{ | | | | | | | | \ -\| | | | |}\n" - "*String displayed above current line by \\[fortran-column-ruler]. -This variable used in fixed format mode.") - -(defvar fortran-column-ruler-tab - "0 810 20 30 40 5\ -\0 60 70\n\ -\[ ]| { | | | | | | | | \ -\| | | | |}\n" - "*String displayed above current line by \\[fortran-column-ruler]. -This variable used in TAB format mode.") - -(defconst bug-fortran-mode "bug-fortran-mode@erl.mit.edu" - "Address of mailing list for Fortran mode bugs.") - -(defvar fortran-mode-syntax-table nil - "Syntax table in use in Fortran mode buffers.") - -(defvar fortran-analyze-depth 100 - "Number of lines to scan to determine whether to use fixed or TAB format\ - style.") - -(defvar fortran-break-before-delimiters t - "*Non-nil causes `fortran-fill' to break lines before delimiters.") - -(if fortran-mode-syntax-table - () - (setq fortran-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\; "w" fortran-mode-syntax-table) - (modify-syntax-entry ?\r " " fortran-mode-syntax-table) - (modify-syntax-entry ?+ "." fortran-mode-syntax-table) - (modify-syntax-entry ?- "." fortran-mode-syntax-table) - (modify-syntax-entry ?= "." fortran-mode-syntax-table) - (modify-syntax-entry ?* "." fortran-mode-syntax-table) - (modify-syntax-entry ?/ "." fortran-mode-syntax-table) - (modify-syntax-entry ?\' "\"" fortran-mode-syntax-table) - (modify-syntax-entry ?\" "\"" fortran-mode-syntax-table) - (modify-syntax-entry ?\\ "/" fortran-mode-syntax-table) - (modify-syntax-entry ?. "w" fortran-mode-syntax-table) - (modify-syntax-entry ?_ "w" fortran-mode-syntax-table) - (modify-syntax-entry ?\! "<" fortran-mode-syntax-table) - (modify-syntax-entry ?\n ">" fortran-mode-syntax-table)) - -;; Comments are real pain in Fortran because there is no way to represent the -;; standard comment syntax in an Emacs syntax table (we can for VAX-style). -;; Therefore an unmatched quote in a standard comment will throw fontification -;; off on the wrong track. So we do syntactic fontification with regexps. - -;; Regexps done by simon@gnu with help from Ulrik Dickow <dickow@nbi.dk> and -;; probably others Si's forgotten about (sorry). - -(defconst fortran-font-lock-keywords-1 nil - "Subdued level highlighting for Fortran mode.") - -(defconst fortran-font-lock-keywords-2 nil - "Medium level highlighting for Fortran mode.") - -(defconst fortran-font-lock-keywords-3 nil - "Gaudy level highlighting for Fortran mode.") - -(let ((comment-chars "c!*") - (fortran-type-types -; (make-regexp -; (let ((simple-types '("character" "byte" "integer" "logical" -; "none" "real" "complex" -; "double[ \t]*precision" "double[ \t]*complex")) -; (structured-types '("structure" "union" "map")) -; (other-types '("record" "dimension" "parameter" "common" "save" -; "external" "intrinsic" "data" "equivalence"))) -; (append -; (mapcar (lambda (x) (concat "implicit[ \t]*" x)) simple-types) -; simple-types -; (mapcar (lambda (x) (concat "end[ \t]*" x)) structured-types) -; structured-types -; other-types))) - (concat "byte\\|c\\(haracter\\|om\\(mon\\|plex\\)\\)\\|" - "d\\(ata\\|imension\\|ouble" - "[ \t]*\\(complex\\|precision\\)\\)\\|" - "e\\(nd[ \t]*\\(map\\|structure\\|union\\)\\|" - "quivalence\\|xternal\\)\\|" - "i\\(mplicit[ \t]*\\(byte\\|" - "c\\(haracter\\|omplex\\)\\|" - "double[ \t]*\\(complex\\|precision\\)\\|" - "integer\\|logical\\|none\\|real\\)\\|" - "nt\\(eger\\|rinsic\\)\\)\\|" - "logical\\|map\\|none\\|parameter\\|re\\(al\\|cord\\)\\|" - "s\\(ave\\|tructure\\)\\|union")) - (fortran-keywords -; ("continue" "format" "end" "enddo" "if" "then" "else" "endif" -; "elseif" "while" "inquire" "stop" "return" "include" "open" -; "close" "read" "write" "format" "print") - (concat "c\\(lose\\|ontinue\\)\\|" - "e\\(lse\\(\\|if\\)\\|nd\\(\\|do\\|if\\)\\)\\|format\\|" - "i\\(f\\|n\\(clude\\|quire\\)\\)\\|open\\|print\\|" - "re\\(ad\\|turn\\)\\|stop\\|then\\|w\\(hile\\|rite\\)")) - (fortran-logicals -; ("and" "or" "not" "lt" "le" "eq" "ge" "gt" "ne" "true" "false") - "and\\|eq\\|false\\|g[et]\\|l[et]\\|n\\(e\\|ot\\)\\|or\\|true")) - - (setq fortran-font-lock-keywords-1 - (list - ;; - ;; Fontify syntactically (assuming strings cannot be quoted or span lines). - (cons (concat "^[" comment-chars "].*") 'font-lock-comment-face) - '(fortran-match-!-comment . font-lock-comment-face) - (list (concat "^[^" comment-chars "\t\n]" (make-string 71 ?.) "\\(.*\\)") - '(1 font-lock-comment-face)) - '("'[^'\n]*'?" . font-lock-string-face) - ;; - ;; Program, subroutine and function declarations, plus calls. - (list (concat "\\<\\(block[ \t]*data\\|call\\|entry\\|function\\|" - "program\\|subroutine\\)\\>[ \t]*\\(\\sw+\\)?") - '(1 font-lock-keyword-face) - '(2 font-lock-function-name-face nil t)))) - - (setq fortran-font-lock-keywords-2 - (append fortran-font-lock-keywords-1 - (list - ;; - ;; Fontify all type specifiers (must be first; see below). - (cons (concat "\\<\\(" fortran-type-types "\\)\\>") 'font-lock-type-face) - ;; - ;; Fontify all builtin keywords (except logical, do and goto; see below). - (concat "\\<\\(" fortran-keywords "\\)\\>") - ;; - ;; Fontify all builtin operators. - (concat "\\.\\(" fortran-logicals "\\)\\.") - ;; - ;; Fontify do/goto keywords and targets, and goto tags. - (list "\\<\\(do\\|go *to\\)\\>[ \t]*\\([0-9]+\\)?" - '(1 font-lock-keyword-face) - '(2 font-lock-reference-face nil t)) - (cons "^ *\\([0-9]+\\)" 'font-lock-reference-face)))) - - (setq fortran-font-lock-keywords-3 - (append - ;; - ;; The list `fortran-font-lock-keywords-1'. - fortran-font-lock-keywords-1 - ;; - ;; Fontify all type specifiers plus their declared items. - (list - (list (concat "\\<\\(" fortran-type-types "\\)\\>[ \t(/]*\\(*\\)?") - ;; Fontify the type specifier. - '(1 font-lock-type-face) - ;; Fontify each declaration item (or just the /.../ block name). - '(font-lock-match-c-style-declaration-item-and-skip-to-next - ;; Start after any *(...) expression. - (and (match-beginning 15) (forward-sexp 1)) - ;; No need to clean up. - nil - ;; Fontify as a variable name, functions are fontified elsewhere. - (1 font-lock-variable-name-face nil t)))) - ;; - ;; Things extra to `fortran-font-lock-keywords-3' (must be done first). - (list - ;; - ;; Fontify goto-like `err=label'/`end=label' in read/write statements. - '(", *\\(e\\(nd\\|rr\\)\\)\\> *\\(= *\\([0-9]+\\)\\)?" - (1 font-lock-keyword-face) (4 font-lock-reference-face nil t)) - ;; - ;; Highlight standard continuation character and in a TAB-formatted line. - '("^ \\([^ 0]\\)" 1 font-lock-string-face) - '("^\t\\([1-9]\\)" 1 font-lock-string-face)) - ;; - ;; The list `fortran-font-lock-keywords-2' less that for types (see above). - (cdr (nthcdr (length fortran-font-lock-keywords-1) - fortran-font-lock-keywords-2)))) - ) - -(defvar fortran-font-lock-keywords fortran-font-lock-keywords-1 - "Default expressions to highlight in Fortran mode.") - - -(defvar fortran-mode-map () - "Keymap used in Fortran mode.") -(if fortran-mode-map - () - (setq fortran-mode-map (make-sparse-keymap)) - (define-key fortran-mode-map ";" 'fortran-abbrev-start) - (define-key fortran-mode-map "\C-c;" 'fortran-comment-region) - (define-key fortran-mode-map "\e\C-a" 'beginning-of-fortran-subprogram) - (define-key fortran-mode-map "\e\C-e" 'end-of-fortran-subprogram) - (define-key fortran-mode-map "\e;" 'fortran-indent-comment) - (define-key fortran-mode-map "\e\C-h" 'mark-fortran-subprogram) - (define-key fortran-mode-map "\e\n" 'fortran-split-line) - (define-key fortran-mode-map "\n" 'fortran-indent-new-line) - (define-key fortran-mode-map "\e\C-q" 'fortran-indent-subprogram) - (define-key fortran-mode-map "\C-c\C-w" 'fortran-window-create-momentarily) - (define-key fortran-mode-map "\C-c\C-r" 'fortran-column-ruler) - (define-key fortran-mode-map "\C-c\C-p" 'fortran-previous-statement) - (define-key fortran-mode-map "\C-c\C-n" 'fortran-next-statement) - (define-key fortran-mode-map "\t" 'fortran-indent-line) - (define-key fortran-mode-map "0" 'fortran-electric-line-number) - (define-key fortran-mode-map "1" 'fortran-electric-line-number) - (define-key fortran-mode-map "2" 'fortran-electric-line-number) - (define-key fortran-mode-map "3" 'fortran-electric-line-number) - (define-key fortran-mode-map "4" 'fortran-electric-line-number) - (define-key fortran-mode-map "5" 'fortran-electric-line-number) - (define-key fortran-mode-map "6" 'fortran-electric-line-number) - (define-key fortran-mode-map "7" 'fortran-electric-line-number) - (define-key fortran-mode-map "8" 'fortran-electric-line-number) - (define-key fortran-mode-map "9" 'fortran-electric-line-number)) - -(defvar fortran-mode-abbrev-table nil) -(if fortran-mode-abbrev-table - () - (let ((ac abbrevs-changed)) - (define-abbrev-table 'fortran-mode-abbrev-table ()) - (define-abbrev fortran-mode-abbrev-table ";au" "automatic" nil) - (define-abbrev fortran-mode-abbrev-table ";b" "byte" nil) - (define-abbrev fortran-mode-abbrev-table ";bd" "block data" nil) - (define-abbrev fortran-mode-abbrev-table ";ch" "character" nil) - (define-abbrev fortran-mode-abbrev-table ";cl" "close" nil) - (define-abbrev fortran-mode-abbrev-table ";c" "continue" nil) - (define-abbrev fortran-mode-abbrev-table ";cm" "common" nil) - (define-abbrev fortran-mode-abbrev-table ";cx" "complex" nil) - (define-abbrev fortran-mode-abbrev-table ";df" "define" nil) - (define-abbrev fortran-mode-abbrev-table ";di" "dimension" nil) - (define-abbrev fortran-mode-abbrev-table ";do" "double" nil) - (define-abbrev fortran-mode-abbrev-table ";dc" "double complex" nil) - (define-abbrev fortran-mode-abbrev-table ";dp" "double precision" nil) - (define-abbrev fortran-mode-abbrev-table ";dw" "do while" nil) - (define-abbrev fortran-mode-abbrev-table ";e" "else" nil) - (define-abbrev fortran-mode-abbrev-table ";ed" "enddo" nil) - (define-abbrev fortran-mode-abbrev-table ";el" "elseif" nil) - (define-abbrev fortran-mode-abbrev-table ";en" "endif" nil) - (define-abbrev fortran-mode-abbrev-table ";eq" "equivalence" nil) - (define-abbrev fortran-mode-abbrev-table ";ew" "endwhere" nil) - (define-abbrev fortran-mode-abbrev-table ";ex" "external" nil) - (define-abbrev fortran-mode-abbrev-table ";ey" "entry" nil) - (define-abbrev fortran-mode-abbrev-table ";f" "format" nil) - (define-abbrev fortran-mode-abbrev-table ";fa" ".false." nil) - (define-abbrev fortran-mode-abbrev-table ";fu" "function" nil) - (define-abbrev fortran-mode-abbrev-table ";g" "goto" nil) - (define-abbrev fortran-mode-abbrev-table ";im" "implicit" nil) - (define-abbrev fortran-mode-abbrev-table ";ib" "implicit byte" nil) - (define-abbrev fortran-mode-abbrev-table ";ic" "implicit complex" nil) - (define-abbrev fortran-mode-abbrev-table ";ich" "implicit character" nil) - (define-abbrev fortran-mode-abbrev-table ";ii" "implicit integer" nil) - (define-abbrev fortran-mode-abbrev-table ";il" "implicit logical" nil) - (define-abbrev fortran-mode-abbrev-table ";ir" "implicit real" nil) - (define-abbrev fortran-mode-abbrev-table ";inc" "include" nil) - (define-abbrev fortran-mode-abbrev-table ";in" "integer" nil) - (define-abbrev fortran-mode-abbrev-table ";intr" "intrinsic" nil) - (define-abbrev fortran-mode-abbrev-table ";l" "logical" nil) - (define-abbrev fortran-mode-abbrev-table ";n" "namelist" nil) - (define-abbrev fortran-mode-abbrev-table ";o" "open" nil) ; was ;op - (define-abbrev fortran-mode-abbrev-table ";pa" "parameter" nil) - (define-abbrev fortran-mode-abbrev-table ";pr" "program" nil) - (define-abbrev fortran-mode-abbrev-table ";ps" "pause" nil) - (define-abbrev fortran-mode-abbrev-table ";p" "print" nil) - (define-abbrev fortran-mode-abbrev-table ";rc" "record" nil) - (define-abbrev fortran-mode-abbrev-table ";re" "real" nil) - (define-abbrev fortran-mode-abbrev-table ";r" "read" nil) - (define-abbrev fortran-mode-abbrev-table ";rt" "return" nil) - (define-abbrev fortran-mode-abbrev-table ";rw" "rewind" nil) - (define-abbrev fortran-mode-abbrev-table ";s" "stop" nil) - (define-abbrev fortran-mode-abbrev-table ";sa" "save" nil) - (define-abbrev fortran-mode-abbrev-table ";st" "structure" nil) - (define-abbrev fortran-mode-abbrev-table ";sc" "static" nil) - (define-abbrev fortran-mode-abbrev-table ";su" "subroutine" nil) - (define-abbrev fortran-mode-abbrev-table ";tr" ".true." nil) - (define-abbrev fortran-mode-abbrev-table ";ty" "type" nil) - (define-abbrev fortran-mode-abbrev-table ";vo" "volatile" nil) - (define-abbrev fortran-mode-abbrev-table ";w" "write" nil) - (define-abbrev fortran-mode-abbrev-table ";wh" "where" nil) - (setq abbrevs-changed ac))) - -;;;###autoload -(defun fortran-mode () - "Major mode for editing Fortran code. -\\[fortran-indent-line] indents the current Fortran line correctly. -DO statements must not share a common CONTINUE. - -Type ;? or ;\\[help-command] to display a list of built-in\ - abbrevs for Fortran keywords. - -Key definitions: -\\{fortran-mode-map} - -Variables controlling indentation style and extra features: - - comment-start - Normally nil in Fortran mode. If you want to use comments - starting with `!', set this to the string \"!\". - fortran-do-indent - Extra indentation within do blocks. (default 3) - fortran-if-indent - Extra indentation within if blocks. (default 3) - fortran-structure-indent - Extra indentation within structure, union, map and interface blocks. - (default 3) - fortran-continuation-indent - Extra indentation applied to continuation statements. (default 5) - fortran-comment-line-extra-indent - Amount of extra indentation for text within full-line comments. (default 0) - fortran-comment-indent-style - nil means don't change indentation of text in full-line comments, - fixed means indent that text at `fortran-comment-line-extra-indent' beyond - the value of `fortran-minimum-statement-indent-fixed' (for fixed - format continuation style) or `fortran-minimum-statement-indent-tab' - (for TAB format continuation style). - relative means indent at `fortran-comment-line-extra-indent' beyond the - indentation for a line of code. - (default 'fixed) - fortran-comment-indent-char - Single-character string to be inserted instead of space for - full-line comment indentation. (default \" \") - fortran-minimum-statement-indent-fixed - Minimum indentation for Fortran statements in fixed format mode. (def.6) - fortran-minimum-statement-indent-tab - Minimum indentation for Fortran statements in TAB format mode. (default 9) - fortran-line-number-indent - Maximum indentation for line numbers. A line number will get - less than this much indentation if necessary to avoid reaching - column 5. (default 1) - fortran-check-all-num-for-matching-do - Non-nil causes all numbered lines to be treated as possible \"continue\" - statements. (default nil) - fortran-blink-matching-if - Non-nil causes \\[fortran-indent-line] on an ENDIF statement to blink on - matching IF. Also, from an ENDDO statement, blink on matching DO [WHILE] - statement. (default nil) - fortran-continuation-string - Single-character string to be inserted in column 5 of a continuation - line. (default \"$\") - fortran-comment-region - String inserted by \\[fortran-comment-region] at start of each line in - region. (default \"c$$$\") - fortran-electric-line-number - Non-nil causes line number digits to be moved to the correct column - as typed. (default t) - fortran-break-before-delimiters - Non-nil causes `fortran-fill' breaks lines before delimiters. - (default t) - fortran-startup-message - Set to nil to inhibit message first time Fortran mode is used. - -Turning on Fortran mode calls the value of the variable `fortran-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (if fortran-startup-message - (message "Emacs Fortran mode %s. Bugs to %s" - fortran-mode-version bug-fortran-mode)) - (setq fortran-startup-message nil) - (setq local-abbrev-table fortran-mode-abbrev-table) - (set-syntax-table fortran-mode-syntax-table) - ;; Font Lock mode support. - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((fortran-font-lock-keywords - fortran-font-lock-keywords-1 - fortran-font-lock-keywords-2 - fortran-font-lock-keywords-3) - t t ((?/ . "$/")))) - (make-local-variable 'fortran-break-before-delimiters) - (setq fortran-break-before-delimiters t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'fortran-indent-line) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'fortran-comment-hook) - (make-local-variable 'comment-line-start-skip) - (setq comment-line-start-skip - "^[Cc*]\\(\\([^ \t\n]\\)\\2\\2*\\)?[ \t]*\\|^#.*") - (make-local-variable 'comment-line-start) - (setq comment-line-start "c") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "![ \t]*") - (make-local-variable 'comment-start) - (setq comment-start nil) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'abbrev-all-caps) - (setq abbrev-all-caps t) - (make-local-variable 'indent-tabs-mode) - (setq indent-tabs-mode nil) -;;;(setq abbrev-mode t) ; ?? (abbrev-mode 1) instead?? - (setq fill-column 72) ; Already local? - (use-local-map fortran-mode-map) - (setq mode-name "Fortran") - (setq major-mode 'fortran-mode) -;;;(make-local-variable 'fortran-tab-mode) - (make-local-variable 'fortran-comment-line-extra-indent) - (make-local-variable 'fortran-minimum-statement-indent-fixed) - (make-local-variable 'fortran-minimum-statement-indent-tab) - (make-local-variable 'fortran-column-ruler-fixed) - (make-local-variable 'fortran-column-ruler-tab) - (make-local-variable 'fortran-tab-mode-string) - (setq fortran-tab-mode-string " TAB-format") - (setq indent-tabs-mode (fortran-analyze-file-format)) - (run-hooks 'fortran-mode-hook)) - -(defun fortran-comment-hook () - (save-excursion - (skip-chars-backward " \t") - (max (+ 1 (current-column)) - comment-column))) - -(defun fortran-indent-comment () - "Align or create comment on current line. -Existing comments of all types are recognized and aligned. -If the line has no comment, a side-by-side comment is inserted and aligned -if the value of comment-start is not nil. -Otherwise, a separate-line comment is inserted, on this line -or on a new line inserted before this line if this line is not blank." - (interactive) - (beginning-of-line) - ;; Recognize existing comments of either kind. - (cond ((looking-at comment-line-start-skip) - (fortran-indent-line)) - ((fortran-find-comment-start-skip) ; catches any inline comment and - ; leaves point after comment-start-skip - (if comment-start-skip - (progn (goto-char (match-beginning 0)) - (if (not (= (current-column) (fortran-comment-hook))) - (progn (delete-horizontal-space) - (indent-to (fortran-comment-hook))))) - (end-of-line))) ; otherwise goto end of line or sth else? - ;; No existing comment. - ;; If side-by-side comments are defined, insert one, - ;; unless line is now blank. - ((and comment-start (not (looking-at "^[ \t]*$"))) - (end-of-line) - (delete-horizontal-space) - (indent-to (fortran-comment-hook)) - (insert comment-start)) - ;; Else insert separate-line comment, making a new line if nec. - (t - (if (looking-at "^[ \t]*$") - (delete-horizontal-space) - (beginning-of-line) - (insert "\n") - (forward-char -1)) - (insert comment-line-start) - (insert-char (if (stringp fortran-comment-indent-char) - (aref fortran-comment-indent-char 0) - fortran-comment-indent-char) - (- (calculate-fortran-indent) (current-column)))))) - -(defun fortran-comment-region (beg-region end-region arg) - "Comments every line in the region. -Puts fortran-comment-region at the beginning of every line in the region. -BEG-REGION and END-REGION are args which specify the region boundaries. -With non-nil ARG, uncomments the region." - (interactive "*r\nP") - (let ((end-region-mark (make-marker)) (save-point (point-marker))) - (set-marker end-region-mark end-region) - (goto-char beg-region) - (beginning-of-line) - (if (not arg) ;comment the region - (progn (insert fortran-comment-region) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (insert fortran-comment-region))) - (let ((com (regexp-quote fortran-comment-region))) ;uncomment the region - (if (looking-at com) - (delete-region (point) (match-end 0))) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (if (looking-at com) - (delete-region (point) (match-end 0)))))) - (goto-char save-point) - (set-marker end-region-mark nil) - (set-marker save-point nil))) - -(defun fortran-abbrev-start () - "Typing ;\\[help-command] or ;? lists all the Fortran abbrevs. -Any other key combination is executed normally." - (interactive) - (let (c) - (insert last-command-char) - (if (or (eq (setq c (read-event)) ??) ;insert char if not equal to `?' - (eq c help-char)) - (fortran-abbrev-help) - (setq unread-command-events (list c))))) - -(defun fortran-abbrev-help () - "List the currently defined abbrevs in Fortran mode." - (interactive) - (message "Listing abbrev table...") - (display-buffer (fortran-prepare-abbrev-list-buffer)) - (message "Listing abbrev table...done")) - -(defun fortran-prepare-abbrev-list-buffer () - (save-excursion - (set-buffer (get-buffer-create "*Abbrevs*")) - (erase-buffer) - (insert-abbrev-table-description 'fortran-mode-abbrev-table t) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (edit-abbrevs-mode)) - (get-buffer-create "*Abbrevs*")) - -(defun fortran-column-ruler () - "Inserts a column ruler momentarily above current line, till next keystroke. -The ruler is defined by the value of `fortran-column-ruler-fixed' when in fixed -format mode, and `fortran-column-ruler-tab' when in TAB format mode. -The key typed is executed unless it is SPC." - (interactive) - (momentary-string-display - (if indent-tabs-mode - fortran-column-ruler-tab - fortran-column-ruler-fixed) - (save-excursion - (beginning-of-line) - (if (eq (window-start (selected-window)) - (window-point (selected-window))) - (progn (forward-line) (point)) - (point))) - nil "Type SPC or any command to erase ruler.")) - -(defun fortran-window-create () - "Makes the window 72 columns wide. -See also `fortran-window-create-momentarily'." - (interactive) - (condition-case error - (progn - (let ((window-min-width 2)) - (if (< (window-width) (frame-width)) - (enlarge-window-horizontally (- (frame-width) - (window-width) 1))) - (split-window-horizontally 73) - (other-window 1) - (switch-to-buffer " fortran-window-extra" t) - (select-window (previous-window)))) - (error (message "No room for Fortran window.") - 'error))) - -(defun fortran-window-create-momentarily (&optional arg) - "Momentarily makes the window 72 columns wide. -Optional ARG non-nil and non-unity disables the momentary feature. -See also `fortran-window-create'." - (interactive "p") - (if (or (not arg) - (= arg 1)) - (save-window-excursion - (if (not (equal (fortran-window-create) 'error)) - (progn (message "Type SPC to continue editing.") - (let ((char (read-event))) - (or (equal char (string-to-char " ")) - (setq unread-command-events (list char))))))) - (fortran-window-create))) - -(defun fortran-split-line () - "Break line at point and insert continuation marker and alignment." - (interactive) - (delete-horizontal-space) - (if (save-excursion (beginning-of-line) (looking-at comment-line-start-skip)) - (insert "\n" comment-line-start " ") - (if indent-tabs-mode - (progn - (insert "\n\t") - (insert-char (fortran-numerical-continuation-char) 1)) - (insert "\n " fortran-continuation-string)));Space after \n important - (fortran-indent-line)) ;when the cont string is C, c or *. - -(defun fortran-numerical-continuation-char () - "Return a digit for tab-digit style of continuation lines. -If, previous line is a tab-digit continuation line, returns that digit -plus one. Otherwise return 1. Zero not allowed." - (save-excursion - (forward-line -1) - (if (looking-at "\t[1-9]") - (+ ?1 (% (- (char-after (+ (point) 1)) ?0) 9)) - ?1))) - -(defun delete-horizontal-regexp (chars) - "Delete all characters in CHARS around point. -CHARS is like the inside of a [...] in a regular expression -except that ] is never special and \ quotes ^, - or \." - (interactive "*s") - (skip-chars-backward chars) - (delete-region (point) (progn (skip-chars-forward chars) (point)))) - -(defun fortran-electric-line-number (arg) - "Self insert, but if part of a Fortran line number indent it automatically. -Auto-indent does not happen if a numeric arg is used." - (interactive "P") - (if (or arg (not fortran-electric-line-number)) - (if arg - (self-insert-command (prefix-numeric-value arg)) - (self-insert-command 1)) - (if (or (and (= 5 (current-column)) - (save-excursion - (beginning-of-line) - (looking-at " ")));In col 5 with only spaces to left. - (and (= (if indent-tabs-mode - fortran-minimum-statement-indent-tab - fortran-minimum-statement-indent-fixed) (current-column)) - (save-excursion - (beginning-of-line) - (looking-at "\t"));In col 8 with a single tab to the left. - (not (or (eq last-command 'fortran-indent-line) - (eq last-command - 'fortran-indent-new-line)))) - (save-excursion - (re-search-backward "[^ \t0-9]" - (save-excursion - (beginning-of-line) - (point)) - t)) ;not a line number - (looking-at "[0-9]") ;within a line number - ) - (self-insert-command (prefix-numeric-value arg)) - (skip-chars-backward " \t") - (insert last-command-char) - (fortran-indent-line)))) - -(defun beginning-of-fortran-subprogram () - "Moves point to the beginning of the current Fortran subprogram." - (interactive) - (let ((case-fold-search t)) - (beginning-of-line -1) - (re-search-backward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move) - (if (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]") - (forward-line 1)))) - -(defun end-of-fortran-subprogram () - "Moves point to the end of the current Fortran subprogram." - (interactive) - (let ((case-fold-search t)) - (beginning-of-line 2) - (re-search-forward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move) - (goto-char (match-beginning 0)) - (forward-line 1))) - -(defun mark-fortran-subprogram () - "Put mark at end of Fortran subprogram, point at beginning. -The marks are pushed." - (interactive) - (end-of-fortran-subprogram) - (push-mark (point)) - (beginning-of-fortran-subprogram)) - -(defun fortran-previous-statement () - "Moves point to beginning of the previous Fortran statement. -Returns `first-statement' if that statement is the first -non-comment Fortran statement in the file, and nil otherwise." - (interactive) - (let (not-first-statement continue-test) - (beginning-of-line) - (setq continue-test - (and - (not (looking-at comment-line-start-skip)) - (or (looking-at - (concat "[ \t]*" (regexp-quote fortran-continuation-string))) - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]"))))) - (while (and (setq not-first-statement (= (forward-line -1) 0)) - (or (looking-at comment-line-start-skip) - (looking-at "[ \t]*$") - (looking-at " [^ 0\n]") - (looking-at "\t[1-9]") - (looking-at (concat "[ \t]*" comment-start-skip))))) - (cond ((and continue-test - (not not-first-statement)) - (message "Incomplete continuation statement.")) - (continue-test - (fortran-previous-statement)) - ((not not-first-statement) - 'first-statement)))) - -(defun fortran-next-statement () - "Moves point to beginning of the next Fortran statement. -Returns `last-statement' if that statement is the last -non-comment Fortran statement in the file, and nil otherwise." - (interactive) - (let (not-last-statement) - (beginning-of-line) - (while (and (setq not-last-statement - (and (= (forward-line 1) 0) - (not (eobp)))) - (or (looking-at comment-line-start-skip) - (looking-at "[ \t]*$") - (looking-at " [^ 0\n]") - (looking-at "\t[1-9]") - (looking-at (concat "[ \t]*" comment-start-skip))))) - (if (not not-last-statement) - 'last-statement))) - -(defun fortran-blink-matching-if () - ;; From a Fortran ENDIF statement, blink the matching IF statement. - (let ((top-of-window (window-start)) matching-if - (endif-point (point)) message) - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*if\\b")) - (progn - (if (not (setq matching-if (fortran-beginning-if))) - (setq message "No matching if.") - (if (< matching-if top-of-window) - (save-excursion - (goto-char matching-if) - (beginning-of-line) - (setq message - (concat "Matches " - (buffer-substring - (point) (progn (end-of-line) (point)))))))) - (if message - (message "%s" message) - (goto-char matching-if) - (sit-for 1) - (goto-char endif-point)))))) - -(defun fortran-blink-matching-do () - ;; From a Fortran ENDDO statement, blink on the matching DO or DO WHILE - ;; statement. This is basically copied from fortran-blink-matching-if. - (let ((top-of-window (window-start)) matching-do - (enddo-point (point)) message) - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*do\\b")) - (progn - (if (not (setq matching-do (fortran-beginning-do))) - (setq message "No matching do.") - (if (< matching-do top-of-window) - (save-excursion - (goto-char matching-do) - (beginning-of-line) - (setq message - (concat "Matches " - (buffer-substring - (point) (progn (end-of-line) (point)))))))) - (if message - (message "%s" message) - (goto-char matching-do) - (sit-for 1) - (goto-char enddo-point)))))) - -(defun fortran-mark-do () - "Put mark at end of Fortran DO [WHILE]-ENDDO construct, point at beginning. -The marks are pushed." - (interactive) - (let (enddo-point do-point) - (if (setq enddo-point (fortran-end-do)) - (if (not (setq do-point (fortran-beginning-do))) - (message "No matching do.") - ;; Set mark, move point. - (goto-char enddo-point) - (push-mark) - (goto-char do-point))))) - -(defun fortran-end-do () - ;; Search forward for first unmatched ENDDO. Return point or nil. - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*do\\b")) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-next-statement) 'last-statement)) - ;; Keep local to subprogram - (not (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "end[ \t]*do\\b") - (setq count (- count 1))) - ((looking-at "do[ \t]+[^0-9]") - (setq count (+ count 1))))) - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-beginning-do () - ;; Search backwards for first unmatched DO [WHILE]. Return point or nil. - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "do[ \t]+")) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-previous-statement) 'first-statement)) - ;; Keep local to subprogram - (not (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "do[ \t]+[^0-9]") - (setq count (- count 1))) - ((looking-at "end[ \t]*do\\b") - (setq count (+ count 1))))) - - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-mark-if () - "Put mark at end of Fortran IF-ENDIF construct, point at beginning. -The marks are pushed." - (interactive) - (let (endif-point if-point) - (if (setq endif-point (fortran-end-if)) - (if (not (setq if-point (fortran-beginning-if))) - (message "No matching if.") - ;; Set mark, move point. - (goto-char endif-point) - (push-mark) - (goto-char if-point))))) - -(defun fortran-end-if () - ;; Search forwards for first unmatched ENDIF. Return point or nil. - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*if\\b")) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. The point has been already been moved to first - ;; letter on line but this should not cause troubles. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-next-statement) 'last-statement)) - ;; Keep local to subprogram. - (not (looking-at - "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "end[ \t]*if\\b") - (setq count (- count 1))) - - ((looking-at "if[ \t]*(") - (save-excursion - (if (or - (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]") - (let (then-test) ; Multi-line if-then. - (while - (and (= (forward-line 1) 0) - ;; Search forward for then. - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not - (setq then-test - (looking-at - ".*then\\b[ \t]*[^ \t(=a-z0-9]"))))) - then-test)) - (setq count (+ count 1))))))) - - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-beginning-if () - ;; Search backwards for first unmatched IF-THEN. Return point or nil. - (if (save-excursion - ;; May be sitting on multi-line if-then statement, first move to - ;; beginning of current statement. Note: `fortran-previous-statement' - ;; moves to previous statement *unless* current statement is first - ;; one. Only move forward if not first-statement. - (if (not (eq (fortran-previous-statement) 'first-statement)) - (fortran-next-statement)) - (skip-chars-forward " \t0-9") - (and - (looking-at "if[ \t]*(") - (save-match-data - (or (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]") - ;; Multi-line if-then. - (let (then-test) - (while - (and (= (forward-line 1) 0) - ;; Search forward for then. - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not - (setq then-test - (looking-at - ".*then\\b[ \t]*[^ \t(=a-z0-9]"))))) - then-test))))) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-previous-statement) 'first-statement)) - ;; Keep local to subprogram. - (not (looking-at - "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "if[ \t]*(") - (save-excursion - (if (or - (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]") - (let (then-test) ; Multi-line if-then. - (while - (and (= (forward-line 1) 0) - ;; Search forward for then. - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not - (setq then-test - (looking-at - ".*then\\b[ \t]*[^ \t(=a-z0-9]"))))) - then-test)) - (setq count (- count 1))))) - ((looking-at "end[ \t]*if\\b") - (setq count (+ count 1))))) - - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-indent-line () - "Indents current Fortran line based on its contents and on previous lines." - (interactive) - (let ((cfi (calculate-fortran-indent))) - (save-excursion - (beginning-of-line) - (if (or (not (= cfi (fortran-current-line-indentation))) - (and (re-search-forward "^[ \t]*[0-9]+" (+ (point) 4) t) - (not (fortran-line-number-indented-correctly-p)))) - (fortran-indent-to-column cfi) - (beginning-of-line) - (if (and (not (looking-at comment-line-start-skip)) - (fortran-find-comment-start-skip)) - (fortran-indent-comment)))) - ;; Never leave point in left margin. - (if (< (current-column) cfi) - (move-to-column cfi)) - (if (and auto-fill-function - (> (save-excursion (end-of-line) (current-column)) fill-column)) - (save-excursion - (end-of-line) - (fortran-fill))) - (if fortran-blink-matching-if - (progn - (fortran-blink-matching-if) - (fortran-blink-matching-do))))) - -(defun fortran-indent-new-line () - "Reindent the current Fortran line, insert a newline and indent the newline. -An abbrev before point is expanded if `abbrev-mode' is non-nil." - (interactive) - (if abbrev-mode (expand-abbrev)) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (if (or (looking-at "[0-9]") ;Reindent only where it is most - (looking-at "end") ;likely to be necessary - (looking-at "else") - (looking-at (regexp-quote fortran-continuation-string))) - (fortran-indent-line))) - (newline) - (fortran-indent-line)) - -(defun fortran-indent-subprogram () - "Properly indents the Fortran subprogram which contains point." - (interactive) - (save-excursion - (mark-fortran-subprogram) - (message "Indenting subprogram...") - (indent-region (point) (mark) nil)) - (message "Indenting subprogram...done.")) - -(defun calculate-fortran-indent () - "Calculates the Fortran indent column based on previous lines." - (let (icol first-statement (case-fold-search t) - (fortran-minimum-statement-indent - (if indent-tabs-mode - fortran-minimum-statement-indent-tab - fortran-minimum-statement-indent-fixed))) - (save-excursion - (setq first-statement (fortran-previous-statement)) - (if first-statement - (setq icol fortran-minimum-statement-indent) - (progn - (if (= (point) (point-min)) - (setq icol fortran-minimum-statement-indent) - (setq icol (fortran-current-line-indentation))) - (skip-chars-forward " \t0-9") - (cond ((looking-at "if[ \t]*(") - (if (or (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t_$(=a-z0-9]") - (let (then-test) ;multi-line if-then - (while (and (= (forward-line 1) 0) - ;;search forward for then - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not (setq then-test (looking-at - ".*then\\b[ \t]\ -*[^ \t_$(=a-z0-9]"))))) - then-test)) - (setq icol (+ icol fortran-if-indent)))) - ((looking-at "\\(else\\|elseif\\)\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "select[ \t]*case[ \t](.*)\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "case[ \t]*(.*)[ \t]*\n") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "case[ \t]*default\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "\\(otherwise\\|else[ \t]*where\\)\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "where[ \t]*(.*)[ \t]*\n") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "do\\b") - (setq icol (+ icol fortran-do-indent))) - ((looking-at - "\\(structure\\|union\\|map\\|interface\\)\\b[ \t]*[^ \t=(a-z]") - (setq icol (+ icol fortran-structure-indent))) - ((looking-at "end\\b[ \t]*[^ \t=(a-z]") - ;; Previous END resets indent to minimum - (setq icol fortran-minimum-statement-indent)))))) - (save-excursion - (beginning-of-line) - (cond ((looking-at "[ \t]*$")) - ((looking-at comment-line-start-skip) - (cond ((eq fortran-comment-indent-style 'relative) - (setq icol (+ icol fortran-comment-line-extra-indent))) - ((eq fortran-comment-indent-style 'fixed) - (setq icol (+ fortran-minimum-statement-indent - fortran-comment-line-extra-indent)))) - (setq fortran-minimum-statement-indent 0)) - ((or (looking-at (concat "[ \t]*" - (regexp-quote - fortran-continuation-string))) - (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (setq icol (+ icol fortran-continuation-indent))) - ((looking-at "[ \t]*#") ; Check for cpp directive. - (setq fortran-minimum-statement-indent 0 icol 0)) - (first-statement) - ((and fortran-check-all-num-for-matching-do - (looking-at "[ \t]*[0-9]+") - (fortran-check-for-matching-do)) - (setq icol (- icol fortran-do-indent))) - (t - (skip-chars-forward " \t0-9") - (cond ((looking-at "end[ \t]*if\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "\\(else\\|elseif\\)\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "case[ \t]*(.*)[ \t]*\n") - (setq icol (- icol fortran-if-indent))) - ((looking-at "case[ \t]*default\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "\\(otherwise\\|else[ \t]*where\\)\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "end[ \t]*where\\b") - (setq icol (- icol fortran-if-indent))) - ((and (looking-at "continue\\b") - (fortran-check-for-matching-do)) - (setq icol (- icol fortran-do-indent))) - ((looking-at "end[ \t]*do\\b") - (setq icol (- icol fortran-do-indent))) - ((looking-at - "end[ \t]*\ -\\(structure\\|union\\|map\\|interface\\)\\b[ \t]*[^ \t=(a-z]") - (setq icol (- icol fortran-structure-indent))) - ((looking-at - "end[ \t]*select\\b[ \t]*[^ \t=(a-z]") - (setq icol (- icol fortran-if-indent))) - ((and (looking-at "end\\b[ \t]*[^ \t=(a-z]") - (not (= icol fortran-minimum-statement-indent))) - (message "Warning: `end' not in column %d. Probably\ - an unclosed block." fortran-minimum-statement-indent)))))) - (max fortran-minimum-statement-indent icol))) - -(defun fortran-current-line-indentation () - "Indentation of current line, ignoring Fortran line number or continuation. -This is the column position of the first non-whitespace character -aside from the line number and/or column 5/8 line-continuation character. -For comment lines, returns indentation of the first -non-indentation text within the comment." - (save-excursion - (beginning-of-line) - (cond ((looking-at comment-line-start-skip) - (goto-char (match-end 0)) - (skip-chars-forward - (if (stringp fortran-comment-indent-char) - fortran-comment-indent-char - (char-to-string fortran-comment-indent-char)))) - ((or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (goto-char (match-end 0))) - (t - ;; Move past line number. - (skip-chars-forward "[ \t0-9]");From Uli - )) - ;; Move past whitespace. - (skip-chars-forward " \t") - (current-column))) - -(defun fortran-indent-to-column (col) - "Indents current line with spaces to column COL. -notes: 1) A non-zero/non-blank character in column 5 indicates a continuation - line, and this continuation character is retained on indentation; - 2) If `fortran-continuation-string' is the first non-whitespace - character, this is a continuation line; - 3) A non-continuation line which has a number as the first - non-whitespace character is a numbered line. - 4) A TAB followed by a digit indicates a continuation line." - (save-excursion - (beginning-of-line) - (if (looking-at comment-line-start-skip) - (if fortran-comment-indent-style - (let ((char (if (stringp fortran-comment-indent-char) - (aref fortran-comment-indent-char 0) - fortran-comment-indent-char))) - (goto-char (match-end 0)) - (delete-horizontal-regexp (concat " \t" (char-to-string char))) - (insert-char char (- col (current-column))))) - (if (looking-at "\t[1-9]") - (if indent-tabs-mode - (goto-char (match-end 0)) - (delete-char 2) - (insert " ") - (insert fortran-continuation-string)) - (if (looking-at " [^ 0\n]") - (if indent-tabs-mode - (progn (delete-char 6) - (insert "\t") - (insert-char (fortran-numerical-continuation-char) 1)) - (forward-char 6)) - (delete-horizontal-space) - ;; Put line number in columns 0-4 - ;; or put continuation character in column 5. - (cond ((eobp)) - ((looking-at (regexp-quote fortran-continuation-string)) - (if indent-tabs-mode - (progn - (indent-to - (if indent-tabs-mode - fortran-minimum-statement-indent-tab - fortran-minimum-statement-indent-fixed)) - (delete-char 1) - (insert-char (fortran-numerical-continuation-char) 1)) - (indent-to 5) - (forward-char 1))) - ((looking-at "[0-9]+") - (let ((extra-space (- 5 (- (match-end 0) (point))))) - (if (< extra-space 0) - (message "Warning: line number exceeds 5-digit limit.") - (indent-to (min fortran-line-number-indent extra-space)))) - (skip-chars-forward "0-9"))))) - ;; Point is now after any continuation character or line number. - ;; Put body of statement where specified. - (delete-horizontal-space) - (indent-to col) - ;; Indent any comment following code on the same line. - (if (and comment-start-skip - (fortran-find-comment-start-skip)) - (progn (goto-char (match-beginning 0)) - (if (not (= (current-column) (fortran-comment-hook))) - (progn (delete-horizontal-space) - (indent-to (fortran-comment-hook))))))))) - -(defun fortran-line-number-indented-correctly-p () - "Return t if current line's line number is correctly indented. -Do not call if there is no line number." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (and (<= (current-column) fortran-line-number-indent) - (or (= (current-column) fortran-line-number-indent) - (progn (skip-chars-forward "0-9") - (= (current-column) 5)))))) - -(defun fortran-check-for-matching-do () - "When called from a numbered statement, returns t if matching DO is found. -Otherwise return a nil." - (let (charnum - (case-fold-search t)) - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*[0-9]+") - (progn - (skip-chars-forward " \t") - (skip-chars-forward "0") ;skip past leading zeros - (setq charnum (buffer-substring (point) - (progn (skip-chars-forward "0-9") - (point)))) - (beginning-of-line) - (and (re-search-backward - (concat "\\(^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]\\)\\|" - "\\(^[ \t0-9]*do[ \t]*0*" charnum "\\b\\)\\|" - "\\(^[ \t]*0*" charnum "\\b\\)") - nil t) - (looking-at (concat "^[ \t0-9]*do[ \t]*0*" charnum)))))))) - -(defun fortran-find-comment-start-skip () - "Move to past `comment-start-skip' found on current line. -Return t if `comment-start-skip' found, nil if not." -;;; In order to move point only if comment-start-skip is found, -;;; this one uses a lot of save-excursions. Note that re-search-forward -;;; moves point even if comment-start-skip is inside a string-constant. -;;; Some code expects certain values for match-beginning and end - (interactive) - (if (save-excursion - (re-search-forward comment-start-skip - (save-excursion (end-of-line) (point)) t)) - (let ((save-match-beginning (match-beginning 0)) - (save-match-end (match-end 0))) - (if (fortran-is-in-string-p (match-beginning 0)) - (save-excursion - (goto-char save-match-end) - (fortran-find-comment-start-skip)) ; recurse for rest of line - (goto-char save-match-beginning) - (re-search-forward comment-start-skip - (save-excursion (end-of-line) (point)) t) - (goto-char (match-end 0)) - t)) - nil)) - -;;;From: simon@gnu (Simon Marshall) -;;; Find the next ! not in a string. -(defun fortran-match-!-comment (limit) - (let (found) - (while (and (setq found (search-forward "!" limit t)) - (fortran-is-in-string-p (point)))) - (if (not found) - nil - ;; Cheaper than `looking-at' "!.*". - (store-match-data - (list (1- (point)) (progn (end-of-line) (min (point) limit)))) - t))) - -;; The above function is about 10% faster than the below... -;;(defun fortran-match-!-comment (limit) -;; (let (found) -;; (while (and (setq found (re-search-forward "!.*" limit t)) -;; (fortran-is-in-string-p (match-beginning 0)))) -;; found)) - -;;;From: ralf@up3aud1.gwdg.de (Ralf Fassel) -;;; Test if TAB format continuation lines work. -(defun fortran-is-in-string-p (where) - "Return non-nil if POS (a buffer position) is inside a Fortran string, -nil else." - (save-excursion - (goto-char where) - (cond - ((bolp) nil) ; bol is never inside a string - ((save-excursion ; comment lines too - (beginning-of-line)(looking-at comment-line-start-skip)) nil) - (t (let (;; ok, serious now. Init some local vars: - (parse-state '(0 nil nil nil nil nil 0)) - (quoted-comment-start (if comment-start - (regexp-quote comment-start))) - (not-done t) - parse-limit - end-of-line - ) - ;; move to start of current statement - (fortran-next-statement) - (fortran-previous-statement) - ;; now parse up to WHERE - (while not-done - (if (or ;; skip to next line if: - ;; - comment line? - (looking-at comment-line-start-skip) - ;; - at end of line? - (eolp) - ;; - not in a string and after comment-start? - (and (not (nth 3 parse-state)) - comment-start - (equal comment-start - (char-to-string (preceding-char))))) - ;; get around a bug in forward-line in versions <= 18.57 - (if (or (> (forward-line 1) 0) (eobp)) - (setq not-done nil)) - ;; else: - ;; if we are at beginning of code line, skip any - ;; whitespace, labels and tab continuation markers. - (if (bolp) (skip-chars-forward " \t0-9")) - ;; if we are in column <= 5 now, check for continuation char - (cond ((= 5 (current-column)) (forward-char 1)) - ((and (< (current-column) 5) - (equal fortran-continuation-string - (char-to-string (following-char))) - (forward-char 1)))) - ;; find out parse-limit from here - (setq end-of-line (save-excursion (end-of-line)(point))) - (setq parse-limit (min where end-of-line)) - ;; parse max up to comment-start, if non-nil and in current line - (if comment-start - (save-excursion - (if (re-search-forward quoted-comment-start end-of-line t) - (setq parse-limit (min (point) parse-limit))))) - ;; now parse if still in limits - (if (< (point) where) - (setq parse-state (parse-partial-sexp - (point) parse-limit nil nil parse-state)) - (setq not-done nil)) - )) - ;; result is - (nth 3 parse-state)))))) - -(defun fortran-auto-fill-mode (arg) - "Toggle fortran-auto-fill mode. -With ARG, turn `fortran-auto-fill' mode on iff ARG is positive. -In `fortran-auto-fill' mode, inserting a space at a column beyond `fill-column' -automatically breaks the line at a previous space." - (interactive "P") - (prog1 (setq auto-fill-function - (if (if (null arg) - (not auto-fill-function) - (> (prefix-numeric-value arg) 0)) - 'fortran-do-auto-fill - nil)) - (force-mode-line-update))) - -(defun fortran-do-auto-fill () - (if (> (current-column) fill-column) - (fortran-indent-line))) - -(defun fortran-fill () - (interactive) - (let* ((opoint (point)) - (bol (save-excursion (beginning-of-line) (point))) - (eol (save-excursion (end-of-line) (point))) - (bos (min eol (+ bol (fortran-current-line-indentation)))) - (quote - (save-excursion - (goto-char bol) - (if (looking-at comment-line-start-skip) - nil ; OK to break quotes on comment lines. - (move-to-column fill-column) - (cond ((fortran-is-in-string-p (point)) - (save-excursion (re-search-backward "[^']'[^']" bol t) - (if fortran-break-before-delimiters - (point) - (1+ (point))))) - (t nil))))) - ;; - ;; decide where to split the line. If a position for a quoted - ;; string was found above then use that, else break the line - ;; before the last delimiter. - ;; Delimiters are whitespace, commas, and operators. - ;; Will break before a pair of *'s. - ;; - (fill-point - (or quote - (save-excursion - (move-to-column (1+ fill-column)) - (skip-chars-backward "^ \t\n,'+-/*=)" -;;; (if fortran-break-before-delimiters -;;; "^ \t\n,'+-/*=" "^ \t\n,'+-/*=)") - ) - (if (<= (point) (1+ bos)) - (progn - (move-to-column (1+ fill-column)) -;;;what is this doing??? - (if (not (re-search-forward "[\t\n,'+-/*)=]" eol t)) - (goto-char bol)))) - (if (bolp) - (re-search-forward "[ \t]" opoint t) - (forward-char -1) - (if (looking-at "'") - (forward-char 1) - (skip-chars-backward " \t\*"))) - (if fortran-break-before-delimiters - (point) - (1+ (point)))))) - ) - ;; if we are in an in-line comment, don't break unless the - ;; line of code is longer than it should be. Otherwise - ;; break the line at the column computed above. - ;; - ;; Need to use fortran-find-comment-start-skip to make sure that quoted !'s - ;; don't prevent a break. - (if (not (or (save-excursion - (if (and (re-search-backward comment-start-skip bol t) - (not (fortran-is-in-string-p (point)))) - (progn - (skip-chars-backward " \t") - (< (current-column) (1+ fill-column))))) - (save-excursion - (goto-char fill-point) - (bolp)))) - (if (> (save-excursion - (goto-char fill-point) (current-column)) - (1+ fill-column)) - (progn (goto-char fill-point) - (fortran-break-line)) - (save-excursion - (if (> (save-excursion - (goto-char fill-point) - (current-column)) - (+ (calculate-fortran-indent) fortran-continuation-indent)) - (progn - (goto-char fill-point) - (fortran-break-line)))))) - )) -(defun fortran-break-line () - (let ((opoint (point)) - (bol (save-excursion (beginning-of-line) (point))) - (eol (save-excursion (end-of-line) (point))) - (comment-string nil)) - - (save-excursion - (if (and comment-start-skip (fortran-find-comment-start-skip)) - (progn - (re-search-backward comment-start-skip bol t) - (setq comment-string (buffer-substring (point) eol)) - (delete-region (point) eol)))) -;;; Forward line 1 really needs to go to next non white line - (if (save-excursion (forward-line 1) - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]"))) - (progn - (end-of-line) - (delete-region (point) (match-end 0)) - (delete-horizontal-space) - (fortran-fill)) - (fortran-split-line)) - (if comment-string - (save-excursion - (goto-char bol) - (end-of-line) - (delete-horizontal-space) - (indent-to (fortran-comment-hook)) - (insert comment-string))))) - -(defun fortran-analyze-file-format () - "Returns nil if fixed format is used, t if TAB formatting is used. -Use `fortran-tab-mode-default' if no non-comment statements are found in the -file before the end or the first `fortran-analyze-depth' lines." - (let ((i 0)) - (save-excursion - (goto-char (point-min)) - (setq i 0) - (while (not (or - (eobp) - (looking-at "\t") - (looking-at " ") - (> i fortran-analyze-depth))) - (forward-line) - (setq i (1+ i))) - (cond - ((looking-at "\t") t) - ((looking-at " ") nil) - (fortran-tab-mode-default t) - (t nil))))) - -(or (assq 'fortran-tab-mode-string minor-mode-alist) - (setq minor-mode-alist (cons - '(fortran-tab-mode-string - (indent-tabs-mode fortran-tab-mode-string)) - minor-mode-alist))) - -(provide 'fortran) - -;;; fortran.el ends here diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el deleted file mode 100644 index 5c97d41255e..00000000000 --- a/lisp/progmodes/hideif.el +++ /dev/null @@ -1,1048 +0,0 @@ -;;; hide-ifdef-mode.el --- hides selected code within ifdef. - -;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. - -;; Author: Dan LaLiberte <liberte@a.cs.uiuc.edu> -;; Maintainer: FSF -;; Keywords: c, outlines - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; To initialize, toggle the hide-ifdef minor mode with -;; -;; M-x hide-ifdef-mode -;; -;; This will set up key bindings and call hide-ifdef-mode-hook if it -;; has a value. To explicitly hide ifdefs using a buffer-local -;; define list (default empty), type -;; -;; M-x hide-ifdefs or C-c @ h -;; -;; Hide-ifdef suppresses the display of code that the preprocessor wouldn't -;; pass through. The support of constant expressions in #if lines is -;; limited to identifiers, parens, and the operators: &&, ||, !, and -;; "defined". Please extend this. -;; -;; The hidden code is marked by ellipses (...). Be -;; cautious when editing near ellipses, since the hidden text is -;; still in the buffer, and you can move the point into it and modify -;; text unawares. If you don't want to see the ellipses, set -;; selective-display-ellipses to nil. But this can be dangerous. -;; You can make your buffer read-only while hide-ifdef-hiding by setting -;; hide-ifdef-read-only to a non-nil value. You can toggle this -;; variable with hide-ifdef-toggle-read-only (C-c @ C-q). -;; -;; You can undo the effect of hide-ifdefs by typing -;; -;; M-x show-ifdefs or C-c @ s -;; -;; Use M-x hide-ifdef-define (C-c @ d) to define a symbol. -;; Use M-x hide-ifdef-undef (C-c @ u) to undefine a symbol. -;; -;; If you define or undefine a symbol while hide-ifdef-mode is in effect, -;; the display will be updated. Only the define list for the current -;; buffer will be affected. You can save changes to the local define -;; list with hide-ifdef-set-define-alist. This adds entries -;; to hide-ifdef-define-alist. -;; -;; If you have defined a hide-ifdef-mode-hook, you can set -;; up a list of symbols that may be used by hide-ifdefs as in the -;; following example: -;; -;; (setq hide-ifdef-mode-hook -;; '(lambda () -;; (if (not hide-ifdef-define-alist) -;; (setq hide-ifdef-define-alist -;; '((list1 ONE TWO) -;; (list2 TWO THREE) -;; ))) -;; (hide-ifdef-use-define-alist 'list2) ; use list2 by default -;; )) -;; -;; You can call hide-ifdef-use-define-alist (C-c @ u) at any time to specify -;; another list to use. -;; -;; To cause ifdefs to be hidden as soon as hide-ifdef-mode is called, -;; set hide-ifdef-initially to non-nil. -;; -;; If you set hide-ifdef-lines to t, hide-ifdefs hides all the #ifdef lines. -;; In the absence of highlighting, that might be a bad idea. If you set -;; hide-ifdef-lines to nil (the default), the surrounding preprocessor -;; lines will be displayed. That can be confusing in its own -;; right. Other variations on display are possible, but not much -;; better. -;; -;; You can explicitly hide or show individual ifdef blocks irrespective -;; of the define list by using hide-ifdef-block and show-ifdef-block. -;; -;; You can move the point between ifdefs with forward-ifdef, backward-ifdef, -;; up-ifdef, down-ifdef, next-ifdef, and previous-ifdef. -;; -;; If you have minor-mode-alist in your mode line (the default) two labels -;; may appear. "Ifdef" will appear when hide-ifdef-mode is active. "Hiding" -;; will appear when text may be hidden ("hide-ifdef-hiding" is non-nil). -;; -;; Written by Brian Marick, at Gould, Computer Systems Division, Urbana IL. -;; Extensively modified by Daniel LaLiberte (while at Gould). -;; -;; You may freely modify and distribute this, but keep a record -;; of modifications and send comments to: -;; liberte@a.cs.uiuc.edu or ihnp4!uiucdcs!liberte -;; I will continue to upgrade hide-ifdef-mode -;; with your contributions. - -;;; Code: - -(require 'cc-mode) - -(defvar hide-ifdef-mode-submap nil - "Keymap used with Hide-Ifdef mode.") - -(defvar hide-ifdef-mode-map nil - "Keymap used with Hide-Ifdef mode.") - -(defconst hide-ifdef-mode-prefix-key "\C-c@" - "Prefix key for all Hide-Ifdef mode commands.") - -;; Set up the submap that goes after the prefix key. -(if hide-ifdef-mode-submap - () ; Don't redefine it. - (setq hide-ifdef-mode-submap (make-sparse-keymap)) - (define-key hide-ifdef-mode-submap "d" 'hide-ifdef-define) - (define-key hide-ifdef-mode-submap "u" 'hide-ifdef-undef) - (define-key hide-ifdef-mode-submap "D" 'hide-ifdef-set-define-alist) - (define-key hide-ifdef-mode-submap "U" 'hide-ifdef-use-define-alist) - - (define-key hide-ifdef-mode-submap "h" 'hide-ifdefs) - (define-key hide-ifdef-mode-submap "s" 'show-ifdefs) - (define-key hide-ifdef-mode-submap "\C-d" 'hide-ifdef-block) - (define-key hide-ifdef-mode-submap "\C-s" 'show-ifdef-block) - - (define-key hide-ifdef-mode-submap "\C-q" 'hide-ifdef-toggle-read-only) - (let ((where (where-is-internal 'toggle-read-only '(keymap) t))) - (if where - (define-key hide-ifdef-mode-submap - where - 'hide-ifdef-toggle-outside-read-only))) - ) - -;; Set up the mode's main map, which leads via the prefix key to the submap. -(if hide-ifdef-mode-map - () - (setq hide-ifdef-mode-map (make-sparse-keymap)) - (define-key hide-ifdef-mode-map hide-ifdef-mode-prefix-key - hide-ifdef-mode-submap)) - -(defvar hide-ifdef-mode nil - "Non-nil when hide-ifdef-mode is activated.") - -(defvar hide-ifdef-hiding nil - "Non-nil when text may be hidden.") - -;; Arrange to use the mode's map when the mode is enabled. -(or (assq 'hide-ifdef-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'hide-ifdef-mode hide-ifdef-mode-map) - minor-mode-map-alist))) - -(or (assq 'hide-ifdef-hiding minor-mode-alist) - (setq minor-mode-alist - (cons '(hide-ifdef-hiding " Hiding") - minor-mode-alist))) - -(or (assq 'hide-ifdef-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(hide-ifdef-mode " Ifdef") - minor-mode-alist))) - -;; fix c-mode syntax table so we can recognize whole symbols. -(defvar hide-ifdef-syntax-table - (copy-syntax-table c-mode-syntax-table) - "Syntax table used for tokenizing #if expressions.") - -(modify-syntax-entry ?_ "w" hide-ifdef-syntax-table) -(modify-syntax-entry ?& "." hide-ifdef-syntax-table) -(modify-syntax-entry ?\| "." hide-ifdef-syntax-table) - -;;;###autoload -(defun hide-ifdef-mode (arg) - "Toggle Hide-Ifdef mode. This is a minor mode, albeit a large one. -With ARG, turn Hide-Ifdef mode on if arg is positive, off otherwise. -In Hide-Ifdef mode, code within #ifdef constructs that the C preprocessor -would eliminate may be hidden from view. Several variables affect -how the hiding is done: - -hide-ifdef-env - An association list of defined and undefined symbols for the - current buffer. Initially, the global value of `hide-ifdef-env' - is used. - -hide-ifdef-define-alist - An association list of defined symbol lists. - Use `hide-ifdef-set-define-alist' to save the current `hide-ifdef-env' - and `hide-ifdef-use-define-alist' to set the current `hide-ifdef-env' - from one of the lists in `hide-ifdef-define-alist'. - -hide-ifdef-lines - Set to non-nil to not show #if, #ifdef, #ifndef, #else, and - #endif lines when hiding. - -hide-ifdef-initially - Indicates whether `hide-ifdefs' should be called when Hide-Ifdef mode - is activated. - -hide-ifdef-read-only - Set to non-nil if you want to make buffers read only while hiding. - After `show-ifdefs', read-only status is restored to previous value. - -\\{hide-ifdef-mode-map}" - - (interactive "P") - (make-local-variable 'hide-ifdef-mode) - (setq hide-ifdef-mode - (if (null arg) - (not hide-ifdef-mode) - (> (prefix-numeric-value arg) 0))) - - (force-mode-line-update) - - (if hide-ifdef-mode - (progn - ; inherit global values - (make-local-variable 'hide-ifdef-env) - (setq hide-ifdef-env (default-value 'hide-ifdef-env)) - - (make-local-variable 'hide-ifdef-hiding) - (setq hide-ifdef-hiding (default-value 'hide-ifdef-hiding)) - - (make-local-variable 'hif-outside-read-only) - (setq hif-outside-read-only buffer-read-only) - - (run-hooks 'hide-ifdef-mode-hook) - - (if hide-ifdef-initially - (hide-ifdefs) - (show-ifdefs)) - (message "Enter Hide-Ifdef mode") - ) - ; else end hide-ifdef-mode - (if hide-ifdef-hiding - (show-ifdefs)) - (message "Exit Hide-Ifdef mode") - )) - - -;; from outline.el with docstring fixed. -(defun hif-outline-flag-region (from to flag) - "Hides or shows lines from FROM to TO, according to FLAG. -If FLAG is \\n (newline character) then text is shown, while if FLAG is \\^M -\(control-M) the text is hidden." - (let ((modp (buffer-modified-p))) - (unwind-protect (progn - (subst-char-in-region from to - (if (= flag ?\n) ?\^M ?\n) - flag t) ) - (set-buffer-modified-p modp)) - )) - -(defun hif-show-all () - "Show all of the text in the current buffer." - (interactive) - (hif-outline-flag-region (point-min) (point-max) ?\n)) - -;; By putting this on after-revert-hook, we arrange that it only -;; does anything when revert-buffer avoids turning off the mode. -;; (That can happen in VC.) -(defun hif-before-revert-function () - (and hide-ifdef-mode hide-ifdef-hiding - (hide-ifdefs t))) -(add-hook 'after-revert-hook 'hif-before-revert-function) - -(defun hide-ifdef-region (start end) - "START is the start of a #if or #else form. END is the ending part. -Everything including these lines is made invisible." - (hif-outline-flag-region start end ?\^M) - ) - -(defun hif-show-ifdef-region (start end) - "Everything between START and END is made visible." - (hif-outline-flag-region start end ?\n) - ) - - - -;===%%SF%% evaluation (Start) === - -;; It is not useful to set this to anything but `eval'. -;; In fact, the variable might as well be eliminated. -(defvar hide-ifdef-evaluator 'eval - "The function to use to evaluate a form. -The evaluator is given a canonical form and returns t if text under -that form should be displayed.") - -(defvar hif-undefined-symbol nil - "...is by default considered to be false.") - -(defvar hide-ifdef-env nil - "An alist of defined symbols and their values.") - - -(defun hif-set-var (var value) - "Prepend (var value) pair to hide-ifdef-env." - (setq hide-ifdef-env (cons (cons var value) hide-ifdef-env))) - - -(defun hif-lookup (var) -; (message "hif-lookup %s" var) - (let ((val (assoc var hide-ifdef-env))) - (if val - (cdr val) - hif-undefined-symbol))) - -(defun hif-defined (var) - (hif-lookup var) - ; when #if expressions are fully supported, defined result should be 1 - ; (if (assoc var hide-ifdef-env) - ; 1 - ; nil) -) - - -;===%%SF%% evaluation (End) === - - - -;===%%SF%% parsing (Start) === -;;; The code that understands what ifs and ifdef in files look like. - -(defconst hif-cpp-prefix "\\(^\\|\r\\)[ \t]*#[ \t]*") -(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef")) -(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\(n?def\\)?[ \t]+")) -(defconst hif-else-regexp (concat hif-cpp-prefix "else")) -(defconst hif-endif-regexp (concat hif-cpp-prefix "endif")) -(defconst hif-ifx-else-endif-regexp - (concat hif-ifx-regexp "\\|" hif-else-regexp "\\|" hif-endif-regexp)) - - -(defun hif-infix-to-prefix (token-list) - "Convert list of tokens in infix into prefix list" -; (message "hif-infix-to-prefix: %s" token-list) - (if (= 1 (length token-list)) - (` (hif-lookup (quote (, (car token-list))))) - (hif-parse-if-exp token-list)) - ) - -; pattern to match initial identifier, !, &&, ||, (, or ). -; Added ==, + and -: garyo@avs.com 8/9/94 -(defconst hif-token-regexp "^\\(&&\\|||\\|[!=]=\\|!\\|[()+-]\\|\\w+\\)") -(defconst hif-end-of-comment "\\*/") - - -(defun hif-tokenize (expr-string) - "Separate string into a list of tokens" - (let ((token-list nil) - (expr-start 0) - (expr-length (length expr-string)) - (current-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table hide-ifdef-syntax-table) - (while (< expr-start expr-length) -; (message "expr-start = %d" expr-start) (sit-for 1) - (cond - ((string-match "^[ \t]+" expr-string expr-start) - ;; skip whitespace - (setq expr-start (match-end 0)) - ;; stick newline in string so ^ matches on the next string-match - (aset expr-string (1- expr-start) ?\n)) - - ((string-match "^/\\*" expr-string expr-start) - (setq expr-start (match-end 0)) - (aset expr-string (1- expr-start) ?\n) - (or - (string-match hif-end-of-comment - expr-string expr-start) ; eat comment - (string-match "$" expr-string expr-start)) ; multi-line comment - (setq expr-start (match-end 0)) - (aset expr-string (1- expr-start) ?\n)) - - ((string-match "^//" expr-string expr-start) - (string-match "$" expr-string expr-start) - (setq expr-start (match-end 0))) - - ((string-match hif-token-regexp expr-string expr-start) - (let ((token (substring expr-string expr-start (match-end 0)))) - (setq expr-start (match-end 0)) - (aset expr-string (1- expr-start) ?\n) -; (message "token: %s" token) (sit-for 1) - (setq token-list - (cons - (cond - ((string-equal token "||") 'or) - ((string-equal token "&&") 'and) - ((string-equal token "==") 'equal) - ((string-equal token "!=") 'hif-notequal) - ((string-equal token "!") 'not) - ((string-equal token "defined") 'hif-defined) - ((string-equal token "(") 'lparen) - ((string-equal token ")") 'rparen) - ((string-equal token "+") 'hif-plus) - ((string-equal token "-") 'hif-minus) - (t (intern token))) - token-list)))) - (t (error "Bad #if expression: %s" expr-string))))) - (set-syntax-table current-syntax-table)) - (nreverse token-list))) - -;;;----------------------------------------------------------------- -;;; Translate C preprocessor #if expressions using recursive descent. -;;; This parser is limited to the operators &&, ||, !, and "defined". -;;; Added ==, !=, +, and -. Gary Oberbrunner, garyo@avs.com, 8/9/94 - -(defun hif-parse-if-exp (token-list) - "Parse the TOKEN-LIST. Return translated list in prefix form." - (hif-nexttoken) - (prog1 - (hif-expr) - (if token ; is there still a token? - (error "Error: unexpected token: %s" token)))) - -(defun hif-nexttoken () - "Pop the next token from token-list into the let variable \"token\"." - (setq token (car token-list)) - (setq token-list (cdr token-list)) - token) - -(defun hif-expr () - "Parse an expression as found in #if. - expr : term | expr '||' term." - (let ((result (hif-term))) - (while (eq token 'or) - (hif-nexttoken) - (setq result (list 'or result (hif-term)))) - result)) - -(defun hif-term () - "Parse a term : eq-expr | term '&&' eq-expr." - (let ((result (hif-eq-expr))) - (while (eq token 'and) - (hif-nexttoken) - (setq result (list 'and result (hif-eq-expr)))) - result)) - -(defun hif-eq-expr () - "Parse an eq-expr : math | eq-expr '=='|'!=' math." - (let ((result (hif-math)) - (eq-token nil)) - (while (or (eq token 'equal) (eq token 'hif-notequal)) - (setq eq-token token) - (hif-nexttoken) - (setq result (list eq-token result (hif-math)))) - result)) - -(defun hif-math () - "Parse an expression with + or - and simpler things. - math : factor | math '+|-' factor." - (let ((result (hif-factor)) - (math-op nil)) - (while (or (eq token 'hif-plus) (eq token 'hif-minus)) - (setq math-op token) - (hif-nexttoken) - (setq result (list math-op result (hif-factor)))) - result)) - -(defun hif-factor () - "Parse a factor: '!' factor | '(' expr ')' | 'defined(' id ')' | id." - (cond - ((eq token 'not) - (hif-nexttoken) - (list 'not (hif-factor))) - - ((eq token 'lparen) - (hif-nexttoken) - (let ((result (hif-expr))) - (if (not (eq token 'rparen)) - (error "Bad token in parenthesized expression: %s" token) - (hif-nexttoken) - result))) - - ((eq token 'hif-defined) - (hif-nexttoken) - (if (not (eq token 'lparen)) - (error "Error: expected \"(\" after \"defined\"")) - (hif-nexttoken) - (let ((ident token)) - (if (memq token '(or and not hif-defined lparen rparen)) - (error "Error: unexpected token: %s" token)) - (hif-nexttoken) - (if (not (eq token 'rparen)) - (error "Error: expected \")\" after identifier")) - (hif-nexttoken) - (` (hif-defined (quote (, ident)))) - )) - - (t ; identifier - (let ((ident token)) - (if (memq ident '(or and)) - (error "Error: missing identifier")) - (hif-nexttoken) - (` (hif-lookup (quote (, ident)))) - )) - )) - -(defun hif-mathify (val) - "Treat VAL as a number: if it's t or nil, use 1 or 0." - (cond ((eq val t) - 1) - ((null val) - 0) - (t val))) - -(defun hif-plus (a b) - "Like ordinary plus but treat t and nil as 1 and 0." - (+ (hif-mathify a) (hif-mathify b))) -(defun hif-minus (a b) - "Like ordinary minus but treat t and nil as 1 and 0." - (- (hif-mathify a) (hif-mathify b))) -(defun hif-notequal (a b) - "Like (not (equal A B)) but as one symbol." - (not (equal a b))) - -;;;----------- end of parser ----------------------- - - -(defun hif-canonicalize () - "When at beginning of #ifX, returns a Lisp expression for its condition." - (save-excursion - (let ((negate (looking-at hif-ifndef-regexp))) - (re-search-forward hif-ifx-regexp) - (let* ((expr-string - (buffer-substring (point) - (progn (skip-chars-forward "^\n\r") (point)))) - (expr (hif-infix-to-prefix (hif-tokenize expr-string)))) -; (message "hif-canonicalized: %s" expr) - (if negate - (list 'not expr) - expr))))) - - -(defun hif-find-any-ifX () - "Move to next #if..., or #ifndef, at point or after." -; (message "find ifX at %d" (point)) - (prog1 - (re-search-forward hif-ifx-regexp (point-max) t) - (beginning-of-line))) - - -(defun hif-find-next-relevant () - "Move to next #if..., #else, or #endif, after the current line." -; (message "hif-find-next-relevant at %d" (point)) - (end-of-line) - ; avoid infinite recursion by only going to beginning of line if match found - (if (re-search-forward hif-ifx-else-endif-regexp (point-max) t) - (beginning-of-line))) - -(defun hif-find-previous-relevant () - "Move to previous #if..., #else, or #endif, before the current line." -; (message "hif-find-previous-relevant at %d" (point)) - (beginning-of-line) - ; avoid infinite recursion by only going to beginning of line if match found - (if (re-search-backward hif-ifx-else-endif-regexp (point-min) t) - (beginning-of-line))) - - -(defun hif-looking-at-ifX () ;; Should eventually see #if - (looking-at hif-ifx-regexp)) -(defun hif-looking-at-endif () - (looking-at hif-endif-regexp)) -(defun hif-looking-at-else () - (looking-at hif-else-regexp)) - - - -(defun hif-ifdef-to-endif () - "If positioned at #ifX or #else form, skip to corresponding #endif." -; (message "hif-ifdef-to-endif at %d" (point)) (sit-for 1) - (hif-find-next-relevant) - (cond ((hif-looking-at-ifX) - (hif-ifdef-to-endif) ; find endif of nested if - (hif-ifdef-to-endif)) ; find outer endif or else - ((hif-looking-at-else) - (hif-ifdef-to-endif)) ; find endif following else - ((hif-looking-at-endif) - 'done) - (t - (error "Mismatched #ifdef #endif pair")))) - - -(defun hif-endif-to-ifdef () - "If positioned at #endif form, skip backward to corresponding #ifX." -; (message "hif-endif-to-ifdef at %d" (point)) - (let ((start (point))) - (hif-find-previous-relevant) - (if (= start (point)) - (error "Mismatched #ifdef #endif pair"))) - (cond ((hif-looking-at-endif) - (hif-endif-to-ifdef) ; find beginning of nested if - (hif-endif-to-ifdef)) ; find beginning of outer if or else - ((hif-looking-at-else) - (hif-endif-to-ifdef)) - ((hif-looking-at-ifX) - 'done) - (t))) ; never gets here - - -(defun forward-ifdef (&optional arg) - "Move point to beginning of line of the next ifdef-endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (backward-ifdef (- arg))) - (while (< 0 arg) - (setq arg (- arg)) - (let ((start (point))) - (if (not (hif-looking-at-ifX)) - (hif-find-next-relevant)) - (if (hif-looking-at-ifX) - (hif-ifdef-to-endif) - (goto-char start) - (error "No following #ifdef") - )))) - - -(defun backward-ifdef (&optional arg) - "Move point to beginning of the previous ifdef-endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (forward-ifdef (- arg))) - (while (< 0 arg) - (setq arg (1- arg)) - (beginning-of-line) - (let ((start (point))) - (if (not (hif-looking-at-endif)) - (hif-find-previous-relevant)) - (if (hif-looking-at-endif) - (hif-endif-to-ifdef) - (goto-char start) - (error "No previous #ifdef"))))) - - -(defun down-ifdef () - "Move point to beginning of nested ifdef or else-part." - (interactive) - (let ((start (point))) - (hif-find-next-relevant) - (if (or (hif-looking-at-ifX) (hif-looking-at-else)) - () - (goto-char start) - (error "No following #ifdef")))) - - -(defun up-ifdef () - "Move point to beginning of enclosing ifdef or else-part." - (interactive) - (beginning-of-line) - (let ((start (point))) - (if (not (hif-looking-at-endif)) - (hif-find-previous-relevant)) - (if (hif-looking-at-endif) - (hif-endif-to-ifdef)) - (if (= start (point)) - (error "No previous #ifdef")))) - -(defun next-ifdef (&optional arg) - "Move to the beginning of the next #ifX, #else, or #endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (previous-ifdef (- arg))) - (while (< 0 arg) - (setq arg (1- arg)) - (hif-find-next-relevant) - (if (eolp) - (progn - (beginning-of-line) - (error "No following #ifdefs, #elses, or #endifs"))))) - -(defun previous-ifdef (&optional arg) - "Move to the beginning of the previous #ifX, #else, or #endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (next-ifdef (- arg))) - (while (< 0 arg) - (setq arg (1- arg)) - (let ((start (point))) - (hif-find-previous-relevant) - (if (= start (point)) - (error "No previous #ifdefs, #elses, or #endifs") - )))) - - -;===%%SF%% parsing (End) === - - -;===%%SF%% hide-ifdef-hiding (Start) === - - -;;; A range is a structure with four components: -;;; ELSE-P True if there was an else clause for the ifdef. -;;; START The start of the range. (beginning of line) -;;; ELSE The else marker (beginning of line) -;;; Only valid if ELSE-P is true. -;;; END The end of the range. (beginning of line) - -(defun hif-make-range (else-p start end &optional else) - (list else-p start else end)) - -(defun hif-range-else-p (range) (elt range 0)) -(defun hif-range-start (range) (elt range 1)) -(defun hif-range-else (range) (elt range 2)) -(defun hif-range-end (range) (elt range 3)) - - - -;;; Find-Range -;;; The workhorse, it delimits the #if region. Reasonably simple: -;;; Skip until an #else or #endif is found, remembering positions. If -;;; an #else was found, skip some more, looking for the true #endif. - -(defun hif-find-range () - "Returns a Range structure describing the current #if region. -Point is left unchanged." -; (message "hif-find-range at %d" (point)) - (save-excursion - (beginning-of-line) - (let ((start (point)) - (else-p nil) - (else nil) - (end nil)) - ;; Part one. Look for either #endif or #else. - ;; This loop-and-a-half dedicated to E. Dijkstra. - (hif-find-next-relevant) - (while (hif-looking-at-ifX) ; Skip nested ifdef - (hif-ifdef-to-endif) - (hif-find-next-relevant)) - ;; Found either a #else or an #endif. - (cond ((hif-looking-at-else) - (setq else-p t) - (setq else (point))) - (t - (setq end (point)) ; (save-excursion (end-of-line) (point)) - )) - ;; If found #else, look for #endif. - (if else-p - (progn - (hif-find-next-relevant) - (while (hif-looking-at-ifX) ; Skip nested ifdef - (hif-ifdef-to-endif) - (hif-find-next-relevant)) - (if (hif-looking-at-else) - (error "Found two elses in a row? Broken!")) - (setq end (point)) ; (save-excursion (end-of-line) (point)) - )) - (hif-make-range else-p start end else)))) - - -;;; A bit slimy. -;;; NOTE: If there's an #ifdef at the beginning of the file, we can't -;;; hide it. There's no previous newline to replace. If we added -;;; one, we'd throw off all the counts. Feh. - -(defun hif-hide-line (point) - "Hide the line containing point. Does nothing if `hide-ifdef-lines' is nil." - (if hide-ifdef-lines - (save-excursion - (goto-char point) - (let ((modp (buffer-modified-p))) - (unwind-protect - (progn - (beginning-of-line) - (if (not (= (point) 1)) - (hide-ifdef-region (1- (point)) (point)))) - (set-buffer-modified-p modp)) - )) - )) - - -;;; Hif-Possibly-Hide -;;; There are four cases. The #ifX expression is "taken" if it -;;; the hide-ifdef-evaluator returns T. Presumably, this means the code -;;; inside the #ifdef would be included when the program was -;;; compiled. -;;; -;;; Case 1: #ifX taken, and there's an #else. -;;; The #else part must be hidden. The #if (then) part must be -;;; processed for nested #ifX's. -;;; Case 2: #ifX taken, and there's no #else. -;;; The #if part must be processed for nested #ifX's. -;;; Case 3: #ifX not taken, and there's an #else. -;;; The #if part must be hidden. The #else part must be processed -;;; for nested #ifs. -;;; Case 4: #ifX not taken, and there's no #else. -;;; The #ifX part must be hidden. -;;; -;;; Further processing is done by narrowing to the relevant region -;;; and just recursively calling hide-ifdef-guts. -;;; -;;; When hif-possibly-hide returns, point is at the end of the -;;; possibly-hidden range. - -(defun hif-recurse-on (start end) - "Call `hide-ifdef-guts' after narrowing to end of START line and END line." - (save-excursion - (save-restriction - (goto-char start) - (end-of-line) - (narrow-to-region (point) end) - (hide-ifdef-guts)))) - -(defun hif-possibly-hide () - "Called at #ifX expression, this hides those parts that should be hidden. -It uses the judgement of `hide-ifdef-evaluator'." -; (message "hif-possibly-hide") (sit-for 1) - (let ((test (hif-canonicalize)) - (range (hif-find-range))) -; (message "test = %s" test) (sit-for 1) - - (hif-hide-line (hif-range-end range)) - (if (funcall hide-ifdef-evaluator test) - (cond ((hif-range-else-p range) ; case 1 - (hif-hide-line (hif-range-else range)) - (hide-ifdef-region (hif-range-else range) - (1- (hif-range-end range))) - (hif-recurse-on (hif-range-start range) - (hif-range-else range))) - (t ; case 2 - (hif-recurse-on (hif-range-start range) - (hif-range-end range)))) - (cond ((hif-range-else-p range) ; case 3 - (hif-hide-line (hif-range-else range)) - (hide-ifdef-region (hif-range-start range) - (1- (hif-range-else range))) - (hif-recurse-on (hif-range-else range) - (hif-range-end range))) - (t ; case 4 - (hide-ifdef-region (point) - (1- (hif-range-end range)))) - )) - (hif-hide-line (hif-range-start range)) ; Always hide start. - (goto-char (hif-range-end range)) - (end-of-line) - )) - - - -(defun hide-ifdef-guts () - "Does most of the work of `hide-ifdefs'. -It does not do the work that's pointless to redo on a recursive entry." -; (message "hide-ifdef-guts") - (save-excursion - (goto-char (point-min)) - (while (hif-find-any-ifX) - (hif-possibly-hide)))) - -;===%%SF%% hide-ifdef-hiding (End) === - - -;===%%SF%% exports (Start) === - -;;;###autoload -(defvar hide-ifdef-initially nil - "*Non-nil means call `hide-ifdefs' when Hide-Ifdef mode is first activated.") - -;;;###autoload -(defvar hide-ifdef-read-only nil - "*Set to non-nil if you want buffer to be read-only while hiding text.") - -(defvar hif-outside-read-only nil - "Internal variable. Saves the value of `buffer-read-only' while hiding.") - -;;;###autoload -(defvar hide-ifdef-lines nil - "*Non-nil means hide the #ifX, #else, and #endif lines.") - -(defun hide-ifdef-toggle-read-only () - "Toggle hide-ifdef-read-only." - (interactive) - (setq hide-ifdef-read-only (not hide-ifdef-read-only)) - (message "Hide-Read-Only %s" - (if hide-ifdef-read-only "ON" "OFF")) - (if hide-ifdef-hiding - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))) - (force-mode-line-update)) - -(defun hide-ifdef-toggle-outside-read-only () - "Replacement for `toggle-read-only' within Hide-Ifdef mode." - (interactive) - (setq hif-outside-read-only (not hif-outside-read-only)) - (message "Read only %s" - (if hif-outside-read-only "ON" "OFF")) - (setq buffer-read-only - (or (and hide-ifdef-hiding hide-ifdef-read-only) - hif-outside-read-only) - ) - (force-mode-line-update)) - - -(defun hide-ifdef-define (var) - "Define a VAR so that #ifdef VAR would be included." - (interactive "SDefine what? ") - (hif-set-var var 1) - (if hide-ifdef-hiding (hide-ifdefs))) - -(defun hide-ifdef-undef (var) - "Undefine a VAR so that #ifdef VAR would not be included." - (interactive "SUndefine what? ") - (hif-set-var var nil) - (if hide-ifdef-hiding (hide-ifdefs))) - - -(defun hide-ifdefs (&optional nomsg) - "Hide the contents of some #ifdefs. -Assume that defined symbols have been added to `hide-ifdef-env'. -The text hidden is the text that would not be included by the C -preprocessor if it were given the file with those symbols defined. - -Turn off hiding by calling `show-ifdefs'." - - (interactive) - (message "Hiding...") - (setq hif-outside-read-only buffer-read-only) - (if (not hide-ifdef-mode) - (hide-ifdef-mode 1)) ; turn on hide-ifdef-mode - (if hide-ifdef-hiding - (show-ifdefs)) ; Otherwise, deep confusion. - (let ((inhibit-read-only t)) - (setq selective-display t) - (setq hide-ifdef-hiding t) - (hide-ifdef-guts)) - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only)) - (or nomsg - (message "Hiding done"))) - - -(defun show-ifdefs () - "Cancel the effects of `hide-ifdef': show the contents of all #ifdefs." - (interactive) - (setq buffer-read-only hif-outside-read-only) - (setq selective-display nil) ; defaults - (let ((inhibit-read-only t)) - (hif-show-all)) - (setq hide-ifdef-hiding nil)) - - -(defun hif-find-ifdef-block () - "Utility for hide and show `ifdef-block'. -Set top and bottom of ifdef block." - (let (max-bottom) - (save-excursion - (beginning-of-line) - (if (not (or (hif-looking-at-else) (hif-looking-at-ifX))) - (up-ifdef)) - (setq top (point)) - (hif-ifdef-to-endif) - (setq max-bottom (1- (point)))) - (save-excursion - (beginning-of-line) - (if (not (hif-looking-at-endif)) - (hif-find-next-relevant)) - (while (hif-looking-at-ifX) - (hif-ifdef-to-endif) - (hif-find-next-relevant)) - (setq bottom (min max-bottom (1- (point)))))) - ) - - -(defun hide-ifdef-block () - "Hide the ifdef block (true or false part) enclosing or before the cursor." - (interactive) - (if (not hide-ifdef-mode) - (hide-ifdef-mode 1)) - (setq selective-display t) - (let (top bottom (inhibit-read-only t)) - (hif-find-ifdef-block) ; set top and bottom - dynamic scoping - (hide-ifdef-region top bottom) - (if hide-ifdef-lines - (progn - (hif-hide-line top) - (hif-hide-line (1+ bottom)))) - (setq hide-ifdef-hiding t)) - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))) - - -(defun show-ifdef-block () - "Show the ifdef block (true or false part) enclosing or before the cursor." - (interactive) - (let ((inhibit-read-only t)) - (if hide-ifdef-lines - (save-excursion - (beginning-of-line) - (hif-show-ifdef-region (1- (point)) (progn (end-of-line) (point)))) - - (let (top bottom) - (hif-find-ifdef-block) - (hif-show-ifdef-region (1- top) bottom))))) - - -;;; definition alist support - -(defvar hide-ifdef-define-alist nil - "A global assoc list of pre-defined symbol lists") - -(defun hif-compress-define-list (env) - "Compress the define list ENV into a list of defined symbols only." - (let ((defs (mapcar '(lambda (arg) - (if (hif-lookup (car arg)) (car arg))) - env)) - (new-defs nil)) - (while defs - (if (car defs) - (setq new-defs (cons (car defs) new-defs))) - (setq defs (cdr defs))) - new-defs)) - -(defun hide-ifdef-set-define-alist (name) - "Set the association for NAME to `hide-ifdef-env'." - (interactive "SSet define list: ") - (setq hide-ifdef-define-alist - (cons (cons name (hif-compress-define-list hide-ifdef-env)) - hide-ifdef-define-alist))) - -(defun hide-ifdef-use-define-alist (name) - "Set `hide-ifdef-env' to the define list specified by NAME." - (interactive "SUse define list: ") - (let ((define-list (assoc name hide-ifdef-define-alist))) - (if define-list - (setq hide-ifdef-env - (mapcar '(lambda (arg) (cons arg t)) - (cdr define-list))) - (error "No define list for %s" name)) - (if hide-ifdef-hiding (hide-ifdefs)))) - -(provide 'hideif) - -;;; hideif.el ends here - diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el deleted file mode 100644 index c49c7ea4da3..00000000000 --- a/lisp/progmodes/hideshow.el +++ /dev/null @@ -1,492 +0,0 @@ -;;; hideshow.el --- minor mode cmds to selectively display blocks of code - -;; Copyright (C) 1994,1995,1996 Free Software Foundation - -;; Author: Thien-Thi Nguyen <ttn@netcom.com> -;; Version: 3.4 -;; Keywords: C C++ lisp tools editing -;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; LCD Archive Entry: -;; hideshow|Thien-Thi Nguyen|ttn@netcom.com| -;; minor mode commands to selectively display blocks of code| -;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z| - -;;; Commentary: - -;; This file provides `hs-minor-mode'. When active, six commands: -;; hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode -;; are available. They implement block hiding and showing. Blocks are -;; defined in mode-specific way. In c-mode or c++-mode, they are simply -;; curly braces, while in lisp-ish modes they are parens. Multi-line -;; comments (c-mode) can also be hidden. The command M-x hs-minor-mode -;; toggles the minor mode or sets it (similar to outline minor mode). -;; See documentation for each command for more info. -;; -;; The variable `hs-unbalance-handler-method' controls hideshow's behavior -;; in the case of "unbalanced parentheses". See doc for more info. - -;; Suggested usage: - -;; (load-library "hideshow") -;; (defun my-hs-setup () "enables hideshow and binds some commands" -;; (hs-minor-mode 1) -;; (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block) -;; (define-key hs-minor-mode-map "\C-cs" 'hs-show-block) -;; (define-key hs-minro-mode-map "\C-cH" 'hs-hide-all) -;; (define-key hs-minro-mode-map "\C-cS" 'hs-show-all) -;; (define-key hs-minor-mode-map "\C-cR" 'hs-show-region)) -;; (add-hook 'X-mode-hook 'my-hs-setup t) ; other modes similarly -;; -;; where X = {emacs-lisp,c,c++,perl,...}. See the doc for the variable -;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes. - -;; Etc: - -;; Bug reports and fixes welcome (comments, too). Thanks go to -;; Dean Andrews <adahome@ix.netcom.com> -;; Preston F. Crow <preston.f.crow@dartmouth.edu> -;; Gael Marziou <gael@gnlab030.grenoble.hp.com> -;; Keith Sheffield <sheff@edcsgw2.cr.usgs.gov> -;; Jan Djarv <jan.djarv@sa.erisoft.se> -;; Lars Lindberg <qhslali@aom.ericsson.se> -;; Alf-Ivar Holm <alfh@ifi.uio.no> -;; for valuable feedback, code and bug reports. - -;;; Code: - - -;;;---------------------------------------------------------------------------- -;;; user-configurable variables - -(defvar hs-unbalance-handler-method 'top-level - "*Symbol representing how \"unbalanced parentheses\" should be handled. -This error is usually signaled by `hs-show-block'. One of four values: -`top-level', `next-line', `signal' or `ignore'. Default is `top-level'. - -- `top-level' -- Show top-level block containing the currently troublesome - block. -- `next-line' -- Use the fact that, for an already hidden block, its end - will be on the next line. Attempt to show this block. -- `signal' -- Pass the error through, stopping execution. -- `ignore' -- Ignore the error, continuing execution. - -Values other than these four will be interpreted as `signal'.") - -(defvar hs-special-modes-alist '((c-mode "{" "}") - (c++-mode "{" "}")) - "*Alist of the form (MODE START-RE END-RE FORWARD-SEXP-FUNC). -If present, hideshow will use these values for the start and end regexps, -respectively. Since Algol-ish languages do not have single-character -block delimiters, the function `forward-sexp' which is used by hideshow -doesn't work. In this case, if a similar function is provided, you can -register it and have hideshow use it instead of `forward-sexp'. To add -more values, use - -\t(pushnew '(new-mode st-re end-re function-name) -\t hs-special-modes-alist :test 'equal) - -For example: - -\t(pushnew '(simula-mode \"begin\" \"end\" simula-next-statement) -\t hs-special-modes-alist :test 'equal) - -Note that the regexps should not contain leading or trailing whitespace.") - -(defvar hs-hide-hook nil - "*Hooks called at the end of `hs-hide-all' and `hs-hide-block'.") - -(defvar hs-show-hook nil - "*Hooks called at the end of commands to show text. -These commands include `hs-show-all', `hs-show-block' and `hs-show-region'.") - -(defvar hs-minor-mode-prefix "\C-c" - "*Prefix key to use for hideshow commands in hideshow minor mode.") - - -;;;---------------------------------------------------------------------------- -;;; internal variables - -(defvar hs-minor-mode nil - "Non-nil if using hideshow mode as a minor mode of some other mode. -Use the command `hs-minor-mode' to toggle this variable.") - -(defvar hs-minor-mode-map nil - "Mode map for hideshow minor mode.") - -(defvar hs-menu-bar nil - "Menu bar for hideshow minor mode (Xemacs only).") - -(defvar hs-c-start-regexp nil - "Regexp for beginning of comments. Buffer-local. -Differs from mode-specific comment regexps in that surrounding -whitespace is stripped.") - -(defvar hs-c-end-regexp nil - "Regexp for end of comments. Buffer-local. -See `hs-c-start-regexp'.") - -(defvar hs-block-start-regexp nil - "Regexp for beginning of block. Buffer-local.") - -(defvar hs-block-end-regexp nil - "Regexp for end of block. Buffer-local.") - -(defvar hs-forward-sexp-func 'forward-sexp - "Function used to do a forward-sexp. Should change for Algol-ish modes. -For single-character block delimiters -- ie, the syntax table regexp for the -character is either `(' or `)' -- `hs-forward-sexp-func' would just be -`forward-sexp'. For other modes such as simula, a more specialized function -is necessary.") - -(defvar hs-emacs-type 'fsf - "Used to support both Emacs and XEmacs.") - -(eval-when-compile - (if (string-match "xemacs\\|lucid" emacs-version) - (progn - (defvar current-menubar nil "") - (defun set-buffer-menubar (arg1)) - (defun add-menu (arg1 arg2 arg3))))) - - -;;;---------------------------------------------------------------------------- -;;; support funcs - -;; snarfed from outline.el, but added buffer-read-only -(defun hs-flag-region (from to flag) - "Hides or shows lines from FROM to TO, according to FLAG. -If FLAG is `?\\n' (the newline character) then show the text; -if FLAG is `?\\^M' \(control-M) then hide the text." - (let ((modp (buffer-modified-p)) - buffer-read-only) ; nothing is immune - (unwind-protect (progn - (subst-char-in-region - from to - (if (= flag ?\n) ?\C-m ?\n) - flag t)) - (set-buffer-modified-p modp)))) - -(defun hs-hide-block-at-point (&optional end) - "Hide block iff on block beginning, optional END means reposition at end." - (if (looking-at hs-block-start-regexp) - (let* ((p (point)) - (q (progn (funcall hs-forward-sexp-func 1) (point)))) - (forward-line -1) (end-of-line) - (if (and (< p (point)) (> (count-lines p q) 1)) - (hs-flag-region p (point) ?\C-m)) - (goto-char (if end q p))))) - -(defun hs-show-block-at-point (&optional end) - "Show block iff on block beginning. Optional END means reposition at end." - (if (looking-at hs-block-start-regexp) - (let* ((p (point)) - (q - (condition-case error ; probably unbalanced paren - (progn - (funcall hs-forward-sexp-func 1) - (point)) - (error - (cond - ((eq hs-unbalance-handler-method 'ignore) - ;; just ignore this block - (point)) - ((eq hs-unbalance-handler-method 'top-level) - ;; try to get out of rat's nest and expose the whole func - (if (/= (current-column) 0) (beginning-of-defun)) - (setq p (point)) - (re-search-forward (concat "^" hs-block-start-regexp) - (point-max) t 2) - (point)) - ((eq hs-unbalance-handler-method 'next-line) - ;; assumption is that user knows what s/he's doing - (beginning-of-line) (setq p (point)) - (end-of-line 2) (point)) - (t - ;; pass error through -- this applies to `signal', too - (signal (car error) (cdr error)))))))) - (hs-flag-region p q ?\n) - (goto-char (if end (1+ (point)) p))))) - -(defun hs-safety-is-job-n () - "Warn if `selective-display' or `selective-display-ellipses' is nil." - (let ((str "")) - (or selective-display - (setq str "selective-display nil ")) - (or selective-display-ellipses - (setq str (concat str "selective-display-ellipses nil"))) - (if (= (length str) 0) - nil - (message "warning: %s" str) - (sit-for 2)))) - -(defun hs-inside-comment-p () - "Returns non-nil if point is inside a comment, otherwise nil. -Actually, for multi-line-able comments, returns a list containing -the buffer position of the start and the end of the comment." - ;; is it single-line-only or multi-line-able? - (save-excursion - (let ((p (point)) - q) - (if (string= comment-end "") ; single line - (let (found) - (beginning-of-line) - (setq found (re-search-forward hs-c-start-regexp p t)) - (and found (not (search-forward "\"" p t)))) - (re-search-forward hs-c-end-regexp (point-max) 1) - (setq q (point)) - (forward-comment -1) - (re-search-forward hs-c-start-regexp (point-max) 1) - (if (< (- (point) (length comment-start)) p) - (list (match-beginning 0) q)))))) - -(defun hs-grok-mode-type () - "Setup variables for new buffers where applicable." - (if (and (boundp 'comment-start) - (boundp 'comment-end)) - (progn - (setq hs-c-start-regexp (regexp-quote comment-start)) - (if (string-match " +$" hs-c-start-regexp) - (setq hs-c-start-regexp - (substring hs-c-start-regexp 0 (1- (match-end 0))))) - (setq hs-c-end-regexp (if (string= "" comment-end) "\n" - (regexp-quote comment-end))) - (if (string-match "^ +" hs-c-end-regexp) - (setq hs-c-end-regexp - (substring hs-c-end-regexp (match-end 0)))) - (let ((lookup (assoc major-mode hs-special-modes-alist))) - (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(") - hs-block-end-regexp (or (nth 2 lookup) "\\s\)") - hs-forward-sexp-func (or (nth 3 lookup) 'forward-sexp)))))) - -(defun hs-find-block-beginning () - "Repositions point at block-start. Return point, or nil if top-level." - (let (done - (here (point)) - (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\(" - hs-block-end-regexp "\\)"))) - (while (and (not done) - (re-search-backward both-regexps (point-min) t)) - (if (match-beginning 1) ; start of start-regexp - (setq done (match-beginning 1)) - (goto-char (match-end 2)) ; end of end-regexp - (funcall hs-forward-sexp-func -1))) - (goto-char (or done here)) - done)) - -(defmacro hs-life-goes-on (&rest body) - "Executes optional BODY iff variable `hs-minor-mode' is non-nil." - (list 'if 'hs-minor-mode (cons 'progn body))) - - -;;;---------------------------------------------------------------------------- -;;; commands - -;;;###autoload -(defun hs-hide-all () - "Hides all top-level blocks, displaying only first and last lines. -It moves point to the beginning of the line, and it runs the normal hook -`hs-hide-hook'. See documentation for `run-hooks'." - (interactive) - (hs-life-goes-on - (message "hiding all blocks ...") - (save-excursion - (hs-flag-region (point-min) (point-max) ?\n) ; eliminate weirdness - (goto-char (point-min)) - (let ((count 0) - (top-level-re (concat "^" hs-block-start-regexp))) - (while (progn - (forward-comment (buffer-size)) - (re-search-forward top-level-re (point-max) t)) - (goto-char (match-beginning 0)) - (hs-hide-block-at-point t) - (message "hiding ... %d" (setq count (1+ count))))) - (hs-safety-is-job-n)) - (beginning-of-line) - (message "hiding all blocks ... done") - (run-hooks 'hs-hide-hook))) - -(defun hs-show-all () - "Shows all top-level blocks. -This does not change point; it runs the normal hook `hs-show-hook'. -See documentation for `run-hooks'." - (interactive) - (hs-life-goes-on - (message "showing all blocks ...") - (hs-flag-region (point-min) (point-max) ?\n) - (message "showing all blocks ... done") - (run-hooks 'hs-show-hook))) - -;;;###autoload -(defun hs-hide-block (&optional end) - "Selects a block and hides it. With prefix arg, reposition at end. -Block is defined as a sexp for lispish modes, mode-specific otherwise. -Comments are blocks, too. Upon completion, point is at repositioned and -the normal hook `hs-hide-hook' is run. See documentation for `run-hooks'." - (interactive "P") - (hs-life-goes-on - (let ((c-reg (hs-inside-comment-p))) - (if c-reg - (cond ((string= comment-end "") - (message "can't hide a single-line comment")) - ((< (count-lines (car c-reg) (nth 1 c-reg)) 2) - (message "not enough comment lines to hide")) - (t - (goto-char (nth 1 c-reg)) - (forward-line -1) - (hs-flag-region (car c-reg) (point) ?\C-m) - (goto-char (if end (nth 1 c-reg) (car c-reg))) - (hs-safety-is-job-n) - (run-hooks 'hs-hide-hook))) - (if (or (looking-at hs-block-start-regexp) - (hs-find-block-beginning)) - (progn - (hs-hide-block-at-point end) - (hs-safety-is-job-n) - (run-hooks 'hs-hide-hook))))))) - -(defun hs-show-block (&optional end) - "Selects a block and shows it. With prefix arg, reposition at end. -Upon completion, point is repositioned and the normal hook -`hs-show-hook' is run. See documentation for `hs-hide-block' and `run-hooks'." - (interactive "P") - (hs-life-goes-on - (let ((c-reg (hs-inside-comment-p))) - (if c-reg - (cond ((string= comment-end "") - (message "already looking at the entire comment")) - (t - (hs-flag-region (car c-reg) (nth 1 c-reg) ?\n) - (goto-char (if end (nth 1 c-reg) (car c-reg))))) - (if (or (looking-at hs-block-start-regexp) - (hs-find-block-beginning)) - (progn - (hs-show-block-at-point end) - (hs-safety-is-job-n) - (run-hooks 'hs-show-hook))))))) - -(defun hs-show-region (beg end) - "Shows all lines from BEG to END, without doing any block analysis. -Note:` hs-show-region' is intended for use when when `hs-show-block' signals -`unbalanced parentheses' and so is an emergency measure only. You may -become very confused if you use this command indiscriminately." - (interactive "r") - (hs-life-goes-on - (hs-flag-region beg end ?\n) - (hs-safety-is-job-n) - (run-hooks 'hs-show-hook))) - -;;;###autoload -(defun hs-minor-mode (&optional arg) - "Toggle hideshow minor mode. -With ARG, turn hideshow minor mode on if ARG is positive, off otherwise. -When hideshow minor mode is on, the menu bar is augmented with hideshow -commands and the hideshow commands are enabled. The variables -`selective-display' and `selective-display-ellipses' are set to t. -Last, the normal hook `hs-minor-mode-hook' is run; see the doc for `run-hooks'. - -Turning hideshow minor mode off reverts the menu bar and the -variables to default values and disables the hideshow commands." - (interactive "P") - (setq hs-minor-mode - (if (null arg) - (not hs-minor-mode) - (> (prefix-numeric-value arg) 0))) - (if hs-minor-mode - (progn - (if (eq hs-emacs-type 'lucid) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil (car hs-menu-bar) (cdr hs-menu-bar)))) - (setq selective-display t - selective-display-ellipses t) - (hs-grok-mode-type) - (run-hooks 'hs-minor-mode-hook)) - (if (eq hs-emacs-type 'lucid) - (set-buffer-menubar (delete hs-menu-bar current-menubar))) - (kill-local-variable 'selective-display) - (kill-local-variable 'selective-display-ellipses))) - - -;;;---------------------------------------------------------------------------- -;;; load-time setup routines - -;; which emacs being used? -(setq hs-emacs-type - (if (string-match "xemacs\\|lucid" emacs-version) - 'lucid - 'fsf)) - -;; keymaps and menus -(if (not hs-minor-mode-map) - (setq hs-minor-mode-map (make-sparse-keymap)) - (cond - ((eq hs-emacs-type 'lucid) - (setq hs-menu-bar ; build top down for lucid - '("hideshow" - ["Hide Block" hs-hide-block t] - ["Show Block" hs-show-block t] - ["Hide All" hs-hide-all t] - ["Show All" hs-show-all t] - ["Show Region" hs-show-region t]))) - (t ; build bottom up for others - (define-key hs-minor-mode-map [menu-bar hideshow] - (cons "hideshow" (make-sparse-keymap "hideshow"))) - (define-key hs-minor-mode-map [menu-bar hideshow hs-show-region] - '("Show Region" . hs-show-region)) - (define-key hs-minor-mode-map [menu-bar hideshow hs-show-all] - '("Show All" . hs-show-all)) - (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-all] - '("Hide All" . hs-hide-all)) - (define-key hs-minor-mode-map [menu-bar hideshow hs-show-block] - '("Show Block" . hs-show-block)) - (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-block] - '("Hide Block" . hs-hide-block))))) - -;; some housekeeping -(or (assq 'hs-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'hs-minor-mode hs-minor-mode-map) - minor-mode-map-alist))) -(or (assq 'hs-minor-mode minor-mode-alist) - (setq minor-mode-alist (append minor-mode-alist - (list '(hs-minor-mode " hs"))))) - -;; make some variables buffer-local -(make-variable-buffer-local 'hs-minor-mode) -(make-variable-buffer-local 'hs-c-start-regexp) -(make-variable-buffer-local 'hs-c-end-regexp) -(make-variable-buffer-local 'hs-block-start-regexp) -(make-variable-buffer-local 'hs-block-end-regexp) -(make-variable-buffer-local 'hs-forward-sexp-func) -(put 'hs-minor-mode 'permanent-local t) -(put 'hs-c-start-regexp 'permanent-local t) -(put 'hs-c-end-regexp 'permanent-local t) -(put 'hs-block-start-regexp 'permanent-local t) -(put 'hs-block-end-regexp 'permanent-local t) -(put 'hs-forward-sexp-func 'permanent-local t) - - -;;;---------------------------------------------------------------------------- -;;; that's it - -(provide 'hideshow) - -;;; hideshow.el ends here diff --git a/lisp/progmodes/icon.el b/lisp/progmodes/icon.el deleted file mode 100644 index 85e30a77ade..00000000000 --- a/lisp/progmodes/icon.el +++ /dev/null @@ -1,556 +0,0 @@ -;;; icon.el --- mode for editing Icon code - -;; Copyright (C) 1989 Free Software Foundation, Inc. - -;; Author: Chris Smith <csmith@convex.com> -;; Created: 15 Feb 89 -;; Keywords: languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; A major mode for editing the Icon programming language. - -;;; Code: - -(defvar icon-mode-abbrev-table nil - "Abbrev table in use in Icon-mode buffers.") -(define-abbrev-table 'icon-mode-abbrev-table ()) - -(defvar icon-mode-map () - "Keymap used in Icon mode.") -(if icon-mode-map - () - (setq icon-mode-map (make-sparse-keymap)) - (define-key icon-mode-map "{" 'electric-icon-brace) - (define-key icon-mode-map "}" 'electric-icon-brace) - (define-key icon-mode-map "\e\C-h" 'mark-icon-function) - (define-key icon-mode-map "\e\C-a" 'beginning-of-icon-defun) - (define-key icon-mode-map "\e\C-e" 'end-of-icon-defun) - (define-key icon-mode-map "\e\C-q" 'indent-icon-exp) - (define-key icon-mode-map "\177" 'backward-delete-char-untabify) - (define-key icon-mode-map "\t" 'icon-indent-command)) - -(defvar icon-mode-syntax-table nil - "Syntax table in use in Icon-mode buffers.") - -(if icon-mode-syntax-table - () - (setq icon-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" icon-mode-syntax-table) - (modify-syntax-entry ?# "<" icon-mode-syntax-table) - (modify-syntax-entry ?\n ">" icon-mode-syntax-table) - (modify-syntax-entry ?$ "." icon-mode-syntax-table) - (modify-syntax-entry ?/ "." icon-mode-syntax-table) - (modify-syntax-entry ?* "." icon-mode-syntax-table) - (modify-syntax-entry ?+ "." icon-mode-syntax-table) - (modify-syntax-entry ?- "." icon-mode-syntax-table) - (modify-syntax-entry ?= "." icon-mode-syntax-table) - (modify-syntax-entry ?% "." icon-mode-syntax-table) - (modify-syntax-entry ?< "." icon-mode-syntax-table) - (modify-syntax-entry ?> "." icon-mode-syntax-table) - (modify-syntax-entry ?& "." icon-mode-syntax-table) - (modify-syntax-entry ?| "." icon-mode-syntax-table) - (modify-syntax-entry ?\' "\"" icon-mode-syntax-table)) - -(defvar icon-indent-level 4 - "*Indentation of Icon statements with respect to containing block.") -(defvar icon-brace-imaginary-offset 0 - "*Imagined indentation of a Icon open brace that actually follows a statement.") -(defvar icon-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defvar icon-continued-statement-offset 4 - "*Extra indent for lines not starting new statements.") -(defvar icon-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to icon-continued-statement-offset.") - -(defvar icon-auto-newline nil - "*Non-nil means automatically newline before and after braces -inserted in Icon code.") - -(defvar icon-tab-always-indent t - "*Non-nil means TAB in Icon mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used.") - -;;;###autoload -(defun icon-mode () - "Major mode for editing Icon code. -Expression and list commands understand all Icon brackets. -Tab indents for Icon code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{icon-mode-map} -Variables controlling indentation style: - icon-tab-always-indent - Non-nil means TAB in Icon mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - icon-auto-newline - Non-nil means automatically newline before and after braces - inserted in Icon code. - icon-indent-level - Indentation of Icon statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - icon-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - icon-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to `icon-continued-statement-offset'. - icon-brace-offset - Extra indentation for line if it starts with an open brace. - icon-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - -Turning on Icon mode calls the value of the variable `icon-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map icon-mode-map) - (setq major-mode 'icon-mode) - (setq mode-name "Icon") - (setq local-abbrev-table icon-mode-abbrev-table) - (set-syntax-table icon-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'icon-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "# *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'icon-comment-indent) - (run-hooks 'icon-mode-hook)) - -;; This is used by indent-for-comment to decide how much to -;; indent a comment in Icon code based on its context. -(defun icon-comment-indent () - (if (looking-at "^#") - 0 - (save-excursion - (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) - comment-column)))) - -(defun electric-icon-brace (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos) - (if (and (not arg) - (eolp) - (or (save-excursion - (skip-chars-backward " \t") - (bolp)) - (if icon-auto-newline - (progn (icon-indent-line) (newline) t) - nil))) - (progn - (insert last-command-char) - (icon-indent-line) - (if icon-auto-newline - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (icon-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun icon-indent-command (&optional whole-exp) - (interactive "P") - "Indent current line as Icon code, or in some cases insert a tab character. -If `icon-tab-always-indent' is non-nil (the default), always indent current -line. Otherwise, indent the current line only if point is at the left margin -or in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, means indent rigidly all the -lines of the expression starting after point so that this line becomes -properly indented. The relative indentation among the lines of the -expression are preserved." - (if whole-exp - ;; If arg, always indent this line as Icon - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (icon-indent-line)) - beg end) - (save-excursion - (if icon-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not icon-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (icon-indent-line)))) - -(defun icon-indent-line () - "Indent current line as Icon code. -Return the amount the indentation changed by." - (let ((indent (calculate-icon-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - ((eq indent t) - (setq indent (calculate-icon-indent-within-comment))) - ((looking-at "[ \t]*#") - (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((and (looking-at "else\\b") - (not (looking-at "else\\s_"))) - (setq indent (save-excursion - (icon-backward-to-start-of-if) - (current-indentation)))) - ((or (= (following-char) ?}) - (looking-at "end\\b")) - (setq indent (- indent icon-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent icon-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun calculate-icon-indent (&optional parse-start) - "Return appropriate indentation for current line as Icon code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - state - containing-sexp - toplevel) - (if parse-start - (goto-char parse-start) - (setq toplevel (beginning-of-icon-defun))) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; return nil or t if should not change this line - (nth 4 state)) - ((and containing-sexp - (/= (char-after containing-sexp) ?{)) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - (if toplevel - ;; Outside any procedures. - (progn (icon-backward-to-noncomment (point-min)) - (if (icon-is-continuation-line) - icon-continued-statement-offset 0)) - ;; Statement level. - (if (null containing-sexp) - (progn (beginning-of-icon-defun) - (setq containing-sexp (point)))) - (goto-char indent-point) - ;; Is it a continuation or a new statement? - ;; Find previous non-comment character. - (icon-backward-to-noncomment containing-sexp) - ;; Now we get the answer. - (if (icon-is-continuation-line) - ;; This line is continuation of preceding line's statement; - ;; indent icon-continued-statement-offset more than the - ;; first line of the statement. - (progn - (icon-backward-to-start-of-continued-exp containing-sexp) - (+ icon-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (skip-chars-forward " \t") - (eq (following-char) ?{)) - icon-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like it. - (save-excursion - (if (looking-at "procedure\\s ") - (forward-sexp 3) - (forward-char 1)) - (while (progn (skip-chars-forward " \t\n") - (looking-at "#")) - ;; Skip over comments following openbrace. - (forward-line 1)) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (current-column))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If icon-indent-level is zero, - ;; use icon-brace-offset + icon-continued-statement-offset - ;; instead. - ;; For open-braces not the first thing in a line, - ;; add in icon-brace-imaginary-offset. - (+ (if (and (bolp) (zerop icon-indent-level)) - (+ icon-brace-offset - icon-continued-statement-offset) - icon-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the icon-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 icon-brace-imaginary-offset)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -;; List of words to check for as the last thing on a line. -;; If cdr is t, next line is a continuation of the same statement, -;; if cdr is nil, next line starts a new (possibly indented) statement. - -(defconst icon-resword-alist - '(("by" . t) ("case" . t) ("create") ("do") ("dynamic" . t) ("else") - ("every" . t) ("if" . t) ("global" . t) ("initial" . t) - ("link" . t) ("local" . t) ("of") ("record" . t) ("repeat" . t) - ("static" . t) ("then") ("to" . t) ("until" . t) ("while" . t))) - -(defun icon-is-continuation-line () - (let* ((ch (preceding-char)) - (ch-syntax (char-syntax ch))) - (if (eq ch-syntax ?w) - (assoc (buffer-substring - (progn (forward-word -1) (point)) - (progn (forward-word 1) (point))) - icon-resword-alist) - (not (memq ch '(0 ?\; ?\} ?\{ ?\) ?\] ?\" ?\' ?\n)))))) - -(defun icon-backward-to-noncomment (lim) - (let (opoint stop) - (while (not stop) - (skip-chars-backward " \t\n\f" lim) - (setq opoint (point)) - (beginning-of-line) - (if (and (nth 5 (parse-partial-sexp (point) opoint)) - (< lim (point))) - (search-backward "#") - (setq stop t))))) - -(defun icon-backward-to-start-of-continued-exp (lim) - (if (memq (preceding-char) '(?\) ?\])) - (forward-sexp -1)) - (beginning-of-line) - (skip-chars-forward " \t") - (cond - ((<= (point) lim) (goto-char (1+ lim))) - ((not (icon-is-continued-line)) 0) - ((and (eq (char-syntax (following-char)) ?w) - (cdr - (assoc (buffer-substring (point) - (save-excursion (forward-word 1) (point))) - icon-resword-alist))) 0) - (t (end-of-line 0) (icon-backward-to-start-of-continued-exp lim)))) - -(defun icon-is-continued-line () - (save-excursion - (end-of-line 0) - (icon-is-continuation-line))) - -(defun icon-backward-to-start-of-if (&optional limit) - "Move to the start of the last \"unbalanced\" if." - (or limit (setq limit (save-excursion (beginning-of-icon-defun) (point)))) - (let ((if-level 1) - (case-fold-search nil)) - (while (not (zerop if-level)) - (backward-sexp 1) - (cond ((looking-at "else\\b") - (setq if-level (1+ if-level))) - ((looking-at "if\\b") - (setq if-level (1- if-level))) - ((< (point) limit) - (setq if-level 0) - (goto-char limit)))))) - -(defun mark-icon-function () - "Put mark at end of Icon function, point at beginning." - (interactive) - (push-mark (point)) - (end-of-icon-defun) - (push-mark (point)) - (beginning-of-line 0) - (beginning-of-icon-defun)) - -(defun beginning-of-icon-defun () - "Go to the start of the enclosing procedure; return t if at top level." - (interactive) - (if (re-search-backward "^procedure\\s \\|^end[ \t\n]" (point-min) 'move) - (looking-at "e") - t)) - -(defun end-of-icon-defun () - (interactive) - (if (not (bobp)) (forward-char -1)) - (re-search-forward "\\(\\s \\|^\\)end\\(\\s \\|$\\)" (point-max) 'move) - (forward-word -1) - (forward-line 1)) - -(defun indent-icon-exp () - "Indent each line of the Icon grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - restart outer-loop-done inner-loop-done state ostate - this-indent last-sexp - at-else at-brace at-do - (opoint (point)) - (next-depth 0)) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq innerloop-done nil) - (while (and (not innerloop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (icon-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq innerloop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - (if (/= last-depth next-depth) - (setq last-sexp nil)) - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack (or (car (cdr state)) - (save-excursion (forward-sexp -1) - (point))))) - (forward-line 1) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - ;; Lines inside parens are handled specially. - (if (/= (char-after (car contain-stack)) ?{) - (setq this-indent (car indent-stack)) - ;; Line is at statement level. - ;; Is it a new statement? Is it an else? - ;; Find last non-comment character before this line - (save-excursion - (setq at-else (looking-at "else\\W")) - (setq at-brace (= (following-char) ?{)) - (icon-backward-to-noncomment opoint) - (if (icon-is-continuation-line) - ;; Preceding line did not end in comma or semi; - ;; indent this line icon-continued-statement-offset - ;; more than previous. - (progn - (icon-backward-to-start-of-continued-exp (car contain-stack)) - (setq this-indent - (+ icon-continued-statement-offset (current-column) - (if at-brace icon-continued-brace-offset 0)))) - ;; Preceding line ended in comma or semi; - ;; use the standard indent for this level. - (if at-else - (progn (icon-backward-to-start-of-if opoint) - (setq this-indent (current-indentation))) - (setq this-indent (car indent-stack)))))) - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let ((val (calculate-icon-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack - (setq this-indent val)))) - ;; Adjust line indentation according to its contents - (if (or (= (following-char) ?}) - (looking-at "end\\b")) - (setq this-indent (- this-indent icon-indent-level))) - (if (= (following-char) ?{) - (setq this-indent (+ this-indent icon-brace-offset))) - ;; Put chosen indentation into effect. - (or (= (current-column) this-indent) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to this-indent))) - ;; Indent any comment following the text. - (or (looking-at comment-start-skip) - (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t) - (progn (indent-for-comment) (beginning-of-line)))))))))) - -;;; icon.el ends here diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el deleted file mode 100644 index 870d3f944b7..00000000000 --- a/lisp/progmodes/inf-lisp.el +++ /dev/null @@ -1,642 +0,0 @@ -;;; inf-lisp.el --- an inferior-lisp mode - -;; Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Olin Shivers <shivers@cs.cmu.edu> -;; Keywords: processes, lisp - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 - -;; This file defines a a lisp-in-a-buffer package (inferior-lisp -;; mode) built on top of comint mode. This version is more -;; featureful, robust, and uniform than the Emacs 18 version. The -;; key bindings are also more compatible with the bindings of Hemlock -;; and Zwei (the Lisp Machine emacs). - -;; Since this mode is built on top of the general command-interpreter-in- -;; a-buffer mode (comint mode), it shares a common base functionality, -;; and a common set of bindings, with all modes derived from comint mode. -;; This makes these modes easier to use. - -;; For documentation on the functionality provided by comint mode, and -;; the hooks available for customising it, see the file comint.el. -;; For further information on inferior-lisp mode, see the comments below. - -;; Needs fixin: -;; The load-file/compile-file default mechanism could be smarter -- it -;; doesn't know about the relationship between filename extensions and -;; whether the file is source or executable. If you compile foo.lisp -;; with compile-file, then the next load-file should use foo.bin for -;; the default, not foo.lisp. This is tricky to do right, particularly -;; because the extension for executable files varies so much (.o, .bin, -;; .lbin, .mo, .vo, .ao, ...). -;; -;; It would be nice if inferior-lisp (and inferior scheme, T, ...) modes -;; had a verbose minor mode wherein sending or compiling defuns, etc. -;; would be reflected in the transcript with suitable comments, e.g. -;; ";;; redefining fact". Several ways to do this. Which is right? -;; -;; When sending text from a source file to a subprocess, the process-mark can -;; move off the window, so you can lose sight of the process interactions. -;; Maybe I should ensure the process mark is in the window when I send -;; text to the process? Switch selectable? - -;;; Code: - -(require 'comint) -(require 'lisp-mode) - - -;;;###autoload -(defvar inferior-lisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" - "*What not to save on inferior Lisp's input history. -Input matching this regexp is not saved on the input history in Inferior Lisp -mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword -\(as in :a, :c, etc.)") - -(defvar inferior-lisp-mode-map nil) -(cond ((not inferior-lisp-mode-map) - (setq inferior-lisp-mode-map - (copy-keymap comint-mode-map)) - (setq inferior-lisp-mode-map - (nconc inferior-lisp-mode-map shared-lisp-mode-map)) - (define-key inferior-lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) - (define-key inferior-lisp-mode-map "\C-c\C-l" 'lisp-load-file) - (define-key inferior-lisp-mode-map "\C-c\C-k" 'lisp-compile-file) - (define-key inferior-lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) - (define-key inferior-lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) - (define-key inferior-lisp-mode-map "\C-c\C-f" - 'lisp-show-function-documentation) - (define-key inferior-lisp-mode-map "\C-c\C-v" - 'lisp-show-variable-documentation))) - -;;; These commands augment Lisp mode, so you can process Lisp code in -;;; the source files. -(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention -(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention -(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) -(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) -(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) -(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) -(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) -(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file -(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) -(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) -(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) -(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) - - -;;; This function exists for backwards compatibility. -;;; Previous versions of this package bound commands to C-c <letter> -;;; bindings, which is not allowed by the gnumacs standard. - -;;; "This function binds many inferior-lisp commands to C-c <letter> bindings, -;;;where they are more accessible. C-c <letter> bindings are reserved for the -;;;user, so these bindings are non-standard. If you want them, you should -;;;have this function called by the inferior-lisp-load-hook: -;;; (setq inferior-lisp-load-hook '(inferior-lisp-install-letter-bindings)) -;;;You can modify this function to install just the bindings you want." -(defun inferior-lisp-install-letter-bindings () - (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) - (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go) - (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go) - (define-key lisp-mode-map "\C-cz" 'switch-to-lisp) - (define-key lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation) - - (define-key inferior-lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key inferior-lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key inferior-lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key inferior-lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key inferior-lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key inferior-lisp-mode-map "\C-cv" - 'lisp-show-variable-documentation)) - - -;;;###autoload -(defvar inferior-lisp-program "lisp" - "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.") - -;;;###autoload -(defvar inferior-lisp-load-command "(load \"%s\")\n" - "*Format-string for building a Lisp expression to load a file. -This format string should use `%s' to substitute a file name -and should result in a Lisp expression that will command the inferior Lisp -to load that file. The default works acceptably on most Lisps. -The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\n\" -produces cosmetically superior output for this application, -but it works only in Common Lisp.") - -;;;###autoload -(defvar inferior-lisp-prompt "^[^> \n]*>+:? *" - "Regexp to recognise prompts in the Inferior Lisp mode. -Defaults to \"^[^> \\n]*>+:? *\", which works pretty good for Lucid, kcl, -and franz. This variable is used to initialize `comint-prompt-regexp' in the -Inferior Lisp buffer. - -More precise choices: -Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" -franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" -kcl: \"^>+ *\" - -This is a fine thing to set in your .emacs file.") - -(defvar inferior-lisp-buffer nil "*The current inferior-lisp process buffer. - -MULTIPLE PROCESS SUPPORT -=========================================================================== -To run multiple Lisp processes, you start the first up -with \\[inferior-lisp]. It will be in a buffer named `*inferior-lisp*'. -Rename this buffer with \\[rename-buffer]. You may now start up a new -process with another \\[inferior-lisp]. It will be in a new buffer, -named `*inferior-lisp*'. You can switch between the different process -buffers with \\[switch-to-buffer]. - -Commands that send text from source buffers to Lisp processes -- -like `lisp-eval-defun' or `lisp-show-arglist' -- have to choose a process -to send to, when you have more than one Lisp process around. This -is determined by the global variable `inferior-lisp-buffer'. Suppose you -have three inferior Lisps running: - Buffer Process - foo inferior-lisp - bar inferior-lisp<2> - *inferior-lisp* inferior-lisp<3> -If you do a \\[lisp-eval-defun] command on some Lisp source code, -what process do you send it to? - -- If you're in a process buffer (foo, bar, or *inferior-lisp*), - you send it to that process. -- If you're in some other buffer (e.g., a source file), you - send it to the process attached to buffer `inferior-lisp-buffer'. -This process selection is performed by function `inferior-lisp-proc'. - -Whenever \\[inferior-lisp] fires up a new process, it resets -`inferior-lisp-buffer' to be the new process's buffer. If you only run -one process, this does the right thing. If you run multiple -processes, you can change `inferior-lisp-buffer' to another process -buffer with \\[set-variable].") - -;;;###autoload -(defvar inferior-lisp-mode-hook '() - "*Hook for customising Inferior Lisp mode.") - -(defun inferior-lisp-mode () - "Major mode for interacting with an inferior Lisp process. -Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an -Emacs buffer. Variable `inferior-lisp-program' controls which Lisp interpreter -is run. Variables `inferior-lisp-prompt', `inferior-lisp-filter-regexp' and -`inferior-lisp-load-command' can customize this mode for different Lisp -interpreters. - -For information on running multiple processes in multiple buffers, see -documentation for variable `inferior-lisp-buffer'. - -\\{inferior-lisp-mode-map} - -Customisation: Entry to this mode runs the hooks on `comint-mode-hook' and -`inferior-lisp-mode-hook' (in that order). - -You can send text to the inferior Lisp process from other buffers containing -Lisp source. - switch-to-lisp switches the current buffer to the Lisp process buffer. - lisp-eval-defun sends the current defun to the Lisp process. - lisp-compile-defun compiles the current defun. - lisp-eval-region sends the current region to the Lisp process. - lisp-compile-region compiles the current region. - - Prefixing the lisp-eval/compile-defun/region commands with - a \\[universal-argument] causes a switch to the Lisp process buffer after sending - the text. - -Commands: -Return after the end of the process' output sends the text from the - end of process to point. -Return before the end of the process' output copies the sexp ending at point - to the end of the process' output, and sends it. -Delete converts tabs to spaces as it moves back. -Tab indents for Lisp; with argument, shifts rest - of expression rigidly with the current line. -C-M-q does Tab on each line starting within following expression. -Paragraphs are separated only by blank lines. Semicolons start comments. -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - (interactive) - (comint-mode) - (setq comint-prompt-regexp inferior-lisp-prompt) - (setq major-mode 'inferior-lisp-mode) - (setq mode-name "Inferior Lisp") - (setq mode-line-process '(":%s")) - (lisp-mode-variables t) - (use-local-map inferior-lisp-mode-map) ;c-c c-k for "kompile" file - (setq comint-get-old-input (function lisp-get-old-input)) - (setq comint-input-filter (function lisp-input-filter)) - (setq comint-input-sentinel 'ignore) - (run-hooks 'inferior-lisp-mode-hook)) - -(defun lisp-get-old-input () - "Return a string containing the sexp ending at point." - (save-excursion - (let ((end (point))) - (backward-sexp) - (buffer-substring (point) end)))) - -(defun lisp-input-filter (str) - "t if STR does not match `inferior-lisp-filter-regexp'." - (not (string-match inferior-lisp-filter-regexp str))) - -;;;###autoload -(defun inferior-lisp (cmd) - "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'. -If there is a process already running in `*inferior-lisp*', just switch -to that buffer. -With argument, allows you to edit the command line (default is value -of `inferior-lisp-program'). Runs the hooks from -`inferior-lisp-mode-hook' (after the `comint-mode-hook' is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (interactive (list (if current-prefix-arg - (read-string "Run lisp: " inferior-lisp-program) - inferior-lisp-program))) - (if (not (comint-check-proc "*inferior-lisp*")) - (let ((cmdlist (inferior-lisp-args-to-list cmd))) - (set-buffer (apply (function make-comint) - "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) - (inferior-lisp-mode))) - (setq inferior-lisp-buffer "*inferior-lisp*") - (pop-to-buffer "*inferior-lisp*")) -;;;###autoload (add-hook 'same-window-buffer-names "*inferior-lisp*") - -;;;###autoload -(defalias 'run-lisp 'inferior-lisp) - -;;; Break a string up into a list of arguments. -;;; This will break if you have an argument with whitespace, as in -;;; string = "-ab +c -x 'you lose'". -(defun inferior-lisp-args-to-list (string) - (let ((where (string-match "[ \t]" string))) - (cond ((null where) (list string)) - ((not (= where 0)) - (cons (substring string 0 where) - (inferior-lisp-args-to-list (substring string (+ 1 where) - (length string))))) - (t (let ((pos (string-match "[^ \t]" string))) - (if (null pos) - nil - (inferior-lisp-args-to-list (substring string pos - (length string))))))))) - -(defun lisp-eval-region (start end &optional and-go) - "Send the current region to the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "r\nP") - (comint-send-region (inferior-lisp-proc) start end) - (comint-send-string (inferior-lisp-proc) "\n") - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-defun (&optional and-go) - "Send the current defun to the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((end (point))) - (beginning-of-defun) - (lisp-eval-region (point) end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-last-sexp (&optional and-go) - "Send the previous sexp to the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "P") - (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go)) - -;;; Common Lisp COMPILE sux. -(defun lisp-compile-region (start end &optional and-go) - "Compile the current region in the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "r\nP") - (comint-send-string - (inferior-lisp-proc) - (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" - (buffer-substring start end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-compile-defun (&optional and-go) - "Compile the current defun in the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((e (point))) - (beginning-of-defun) - (lisp-compile-region (point) e))) - (if and-go (switch-to-lisp t))) - -(defun switch-to-lisp (eob-p) - "Switch to the inferior Lisp process buffer. -With argument, positions cursor at end of buffer." - (interactive "P") - (if (get-buffer inferior-lisp-buffer) - (let ((pop-up-frames - ;; Be willing to use another frame - ;; that already has the window in it. - (or pop-up-frames - (get-buffer-window inferior-lisp-buffer t)))) - (pop-to-buffer inferior-lisp-buffer)) - (error "No current inferior Lisp buffer")) - (cond (eob-p - (push-mark) - (goto-char (point-max))))) - - -;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg, -;;; these commands are redundant. But they are kept around for the user -;;; to bind if he wishes, for backwards functionality, and because it's -;;; easier to type C-c e than C-u C-c C-e. - -(defun lisp-eval-region-and-go (start end) - "Send the current region to the inferior Lisp, and switch to its buffer." - (interactive "r") - (lisp-eval-region start end t)) - -(defun lisp-eval-defun-and-go () - "Send the current defun to the inferior Lisp, and switch to its buffer." - (interactive) - (lisp-eval-defun t)) - -(defun lisp-compile-region-and-go (start end) - "Compile the current region in the inferior Lisp, and switch to its buffer." - (interactive "r") - (lisp-compile-region start end t)) - -(defun lisp-compile-defun-and-go () - "Compile the current defun in the inferior Lisp, and switch to its buffer." - (interactive) - (lisp-compile-defun t)) - -;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. -;;; (defun lisp-compile-sexp (start end) -;;; "Compile the s-expression bounded by START and END in the inferior lisp. -;;; If the sexp isn't a DEFUN form, it is evaluated instead." -;;; (cond ((looking-at "(defun\\s +") -;;; (goto-char (match-end 0)) -;;; (let ((name-start (point))) -;;; (forward-sexp 1) -;;; (process-send-string "inferior-lisp" -;;; (format "(compile '%s #'(lambda " -;;; (buffer-substring name-start -;;; (point))))) -;;; (let ((body-start (point))) -;;; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. -;;; (process-send-region "inferior-lisp" -;;; (buffer-substring body-start (point)))) -;;; (process-send-string "inferior-lisp" ")\n")) -;;; (t (lisp-eval-region start end))))) -;;; -;;; (defun lisp-compile-region (start end) -;;; "Each s-expression in the current region is compiled (if a DEFUN) -;;; or evaluated (if not) in the inferior lisp." -;;; (interactive "r") -;;; (save-excursion -;;; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check -;;; (if (< (point) start) (error "region begins in middle of defun")) -;;; (goto-char start) -;;; (let ((s start)) -;;; (end-of-defun) -;;; (while (<= (point) end) ; Zip through -;;; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. -;;; (setq s (point)) -;;; (end-of-defun)) -;;; (if (< s end) (lisp-compile-sexp s end))))) -;;; -;;; End of HS-style code - - -(defvar lisp-prev-l/c-dir/file nil - "Record last directory and file used in loading or compiling. -This holds a cons cell of the form `(DIRECTORY . FILE)' -describing the last `lisp-load-file' or `lisp-compile-file' command.") - -(defvar lisp-source-modes '(lisp-mode) - "*Used to determine if a buffer contains Lisp source code. -If it's loaded into a buffer that is in one of these major modes, it's -considered a Lisp source file by `lisp-load-file' and `lisp-compile-file'. -Used by these commands to determine defaults.") - -(defun lisp-load-file (file-name) - "Load a Lisp file into the inferior Lisp process." - (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL because LOAD - ; doesn't need an exact name - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (inferior-lisp-proc) - (format inferior-lisp-load-command file-name)) - (switch-to-lisp t)) - - -(defun lisp-compile-file (file-name) - "Compile a Lisp file in the inferior Lisp process." - (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL = don't need - ; suffix .lisp - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (inferior-lisp-proc) (concat "(compile-file \"" - file-name - "\"\)\n")) - (switch-to-lisp t)) - - - -;;; Documentation functions: function doc, var doc, arglist, and -;;; describe symbol. -;;; =========================================================================== - -;;; Command strings -;;; =============== - -(defvar lisp-function-doc-command - "(let ((fn '%s)) - (format t \"Documentation for ~a:~&~a\" - fn (documentation fn 'function)) - (values))\n" - "Command to query inferior Lisp for a function's documentation.") - -(defvar lisp-var-doc-command - "(let ((v '%s)) - (format t \"Documentation for ~a:~&~a\" - v (documentation v 'variable)) - (values))\n" - "Command to query inferior Lisp for a variable's documentation.") - -(defvar lisp-arglist-command - "(let ((fn '%s)) - (format t \"Arglist for ~a: ~a\" fn (arglist fn)) - (values))\n" - "Command to query inferior Lisp for a function's arglist.") - -(defvar lisp-describe-sym-command - "(describe '%s)\n" - "Command to query inferior Lisp for a variable's documentation.") - - -;;; Ancillary functions -;;; =================== - -;;; Reads a string from the user. -(defun lisp-symprompt (prompt default) - (list (let* ((prompt (if default - (format "%s (default %s): " prompt default) - (concat prompt ": "))) - (ans (read-string prompt))) - (if (zerop (length ans)) default ans)))) - - -;;; Adapted from function-called-at-point in help.el. -(defun lisp-fn-called-at-pt () - "Returns the name of the function called in the current call. -The value is nil if it can't find one." - (condition-case nil - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) - (backward-up-list 1) - (forward-char 1) - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj)))) - (error nil))) - - -;;; Adapted from variable-at-point in help.el. -(defun lisp-var-at-pt () - (condition-case () - (save-excursion - (forward-sexp -1) - (skip-chars-forward "'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj))) - (error nil))) - - -;;; Documentation functions: fn and var doc, arglist, and symbol describe. -;;; ====================================================================== - -(defun lisp-show-function-documentation (fn) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable `lisp-function-doc-command'." - (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) - (comint-proc-query (inferior-lisp-proc) - (format lisp-function-doc-command fn))) - -(defun lisp-show-variable-documentation (var) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable `lisp-var-doc-command'." - (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) - (comint-proc-query (inferior-lisp-proc) (format lisp-var-doc-command var))) - -(defun lisp-show-arglist (fn) - "Send a query to the inferior Lisp for the arglist for function FN. -See variable `lisp-arglist-command'." - (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) - (comint-proc-query (inferior-lisp-proc) (format lisp-arglist-command fn))) - -(defun lisp-describe-sym (sym) - "Send a command to the inferior Lisp to describe symbol SYM. -See variable `lisp-describe-sym-command'." - (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) - (comint-proc-query (inferior-lisp-proc) - (format lisp-describe-sym-command sym))) - - -;; "Returns the current inferior Lisp process. -;; See variable `inferior-lisp-buffer'." -(defun inferior-lisp-proc () - (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) - (current-buffer) - inferior-lisp-buffer)))) - (or proc - (error "No Lisp subprocess; see variable `inferior-lisp-buffer'")))) - - -;;; Do the user's customisation... -;;;=============================== -(defvar inferior-lisp-load-hook nil - "This hook is run when the library `inf-lisp' is loaded. -This is a good place to put keybindings.") - -(run-hooks 'inferior-lisp-load-hook) - -;;; CHANGE LOG -;;; =========================================================================== -;;; 7/21/92 Jim Blandy -;;; - Changed all uses of the cmulisp name or prefix to inferior-lisp; -;;; this is now the official inferior lisp package. Use the global -;;; ChangeLog from now on. -;;; 5/24/90 Olin -;;; - Split cmulisp and cmushell modes into separate files. -;;; Not only is this a good idea, it's apparently the way it'll be rel 19. -;;; - Upgraded process sends to use comint-send-string instead of -;;; process-send-string. -;;; - Explicit references to process "cmulisp" have been replaced with -;;; (cmulisp-proc). This allows better handling of multiple process bufs. -;;; - Added process query and var/function/symbol documentation -;;; commands. Based on code written by Douglas Roberts. -;;; - Added lisp-eval-last-sexp, bound to C-x C-e. -;;; -;;; 9/20/90 Olin -;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix -;;; reported by Lennart Staflin. -;;; -;;; 3/12/90 Olin -;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp. -;;; Tale suggested this. -;;; - Reversed this decision 7/15/91. You need the visual feedback. -;;; -;;; 7/25/91 Olin -;;; Changed all keybindings of the form C-c <letter>. These are -;;; supposed to be reserved for the user to bind. This affected -;;; mainly the compile/eval-defun/region[-and-go] commands. -;;; This was painful, but necessary to adhere to the gnumacs standard. -;;; For some backwards compatibility, see the -;;; cmulisp-install-letter-bindings -;;; function. -;;; -;;; 8/2/91 Olin -;;; - The lisp-compile/eval-defun/region commands now take a prefix arg, -;;; which means switch-to-lisp after sending the text to the Lisp process. -;;; This obsoletes all the -and-go commands. The -and-go commands are -;;; kept around for historical reasons, and because the user can bind -;;; them to key sequences shorter than C-u C-c C-<letter>. -;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to -;;; edit the command line. - -(provide 'inf-lisp) - -;;; inf-lisp.el ends here diff --git a/lisp/progmodes/m4-mode.el b/lisp/progmodes/m4-mode.el deleted file mode 100644 index a9177ea91e0..00000000000 --- a/lisp/progmodes/m4-mode.el +++ /dev/null @@ -1,152 +0,0 @@ -;;; m4-mode.el --- m4 code editing commands for Emacs - -;;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Andrew Csillag <drew@staff.prodigy.com> -;; Maintainer: Andrew Csillag <drew@staff.prodigy.com> -;; Keywords: languages, faces - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; A smart editing mode for m4 macro definitions. It seems to have most of the -;; syntax right (sexp motion commands work, but function motion commands don't). -;; It also sets the font-lock syntax stuff for colorization - -;; To Do's: - -;; * want to make m4-m4-(buffer|region) look sorta like M-x compile look&feel ? -;; * sexp motion commands don't seem to work right - -;; to autoload m4 lisp code: -;; (autoload 'm4-mode "m4-mode" nil t) -;; -;; or can use (load "m4-mode") or (require 'm4-mode) to just load it -;; -;; to try to "auto-detect" m4 files: -;; (setq auto-mode-alist -;; (cons '(".*\\.m4$" . m4-mode) -;; auto-mode-alist)) - -;;; Thanks: -;;; to Akim Demaille and Terry Jones for the bug reports - -;;; Code: - -;;path to the m4 program -(defvar m4-program "/usr/local/bin/m4") - -;;thank god for make-regexp.el! -(defvar m4-font-lock-keywords - `( - ("^\\\#.*" . font-lock-comment-face) - ("\\\$\\\*" . font-lock-variable-name-face) - ("\\\$[0-9]" . font-lock-variable-name-face) - ("\\\$\\\#" . font-lock-variable-name-face) - ("\\\$\\\@" . font-lock-variable-name-face) - ("\\\$\\\*" . font-lock-variable-name-face) - ("\\b\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\b" . font-lock-keyword-face) - ("\\b\\(m4_\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(_undefine\\|exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|undivert\\)\\)\\b" . font-lock-keyword-face) - "default font-lock-keywords") -) - -;;this may still need some work -(defvar m4-mode-syntax-table nil - "syntax table used in m4 mode") -(setq m4-mode-syntax-table (make-syntax-table)) -(modify-syntax-entry ?` "('" m4-mode-syntax-table) -(modify-syntax-entry ?' ")`" m4-mode-syntax-table) -(modify-syntax-entry ?# "<\n" m4-mode-syntax-table) -(modify-syntax-entry ?\n ">#" m4-mode-syntax-table) -(modify-syntax-entry ?{ "_" m4-mode-syntax-table) -(modify-syntax-entry ?} "_" m4-mode-syntax-table) -(modify-syntax-entry ?* "w" m4-mode-syntax-table) -(modify-syntax-entry ?_ "w" m4-mode-syntax-table) -(modify-syntax-entry ?\" "w" m4-mode-syntax-table) - -(defvar m4-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-b" 'm4-m4-buffer) - (define-key map "\C-c\C-r" 'm4-m4-region) - (define-key map "\C-c\C-c" 'comment-region) - map)) - -(defun m4-m4-buffer () - "send contents of the current buffer to m4" - (interactive) - (start-process "m4process" "*m4 output*" m4-program "-e") - (process-send-region "m4process" (point-min) (point-max)) - (process-send-eof "m4process") - (switch-to-buffer "*m4 output*") -) - -(defun m4-m4-region () - "send contents of the current region to m4" - (interactive) - (start-process "m4process" "*m4 output*" m4-program "-e") - (process-send-region "m4process" (point) (mark)) - (process-send-eof "m4process") - (switch-to-buffer "*m4 output*") -) - -(defun m4-mode () - "A major-mode to edit m4 macro files -\\{m4-mode-map} -" - (interactive) - (kill-all-local-variables) - (use-local-map m4-mode-map) - - (make-local-variable 'comment-start) - (setq comment-start "#") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - - - (make-local-variable 'font-lock-defaults) - (setq major-mode 'm4-mode - mode-name "m4" - font-lock-defaults `(m4-font-lock-keywords nil) - ) - (set-syntax-table m4-mode-syntax-table) - (run-hooks 'm4-mode-hook)) - -(provide 'm4-mode) -;;stuff to play with for debugging -;(char-to-string (char-syntax ?`)) - -;;;how I generate the nasty looking regexps at the top -;;;(make-regexp '("builtin" "changecom" "changequote" "changeword" "debugfile" -;;; "debugmode" "decr" "define" "defn" "divert" "divnum" "dnl" -;;; "dumpdef" "errprint" "esyscmd" "eval" "file" "format" "gnu" -;;; "ifdef" "ifelse" "include" "incr" "index" "indir" "len" "line" -;;; "m4exit" "m4wrap" "maketemp" "patsubst" "popdef" "pushdef" "regexp" -;;; "shift" "sinclude" "substr" "syscmd" "sysval" "traceoff" "traceon" -;;; "translit" "undefine" "undivert" "unix")) -;;;(make-regexp '("m4_builtin" "m4_changecom" "m4_changequote" "m4_changeword" -;;; "m4_debugfile" "m4_debugmode" "m4_decr" "m4_define" "m4_defn" -;;; "m4_divert" "m4_divnum" "m4_dnl" "m4_dumpdef" "m4_errprint" -;;; "m4_esyscmd" "m4_eval" "m4_file" "m4_format" "m4_ifdef" "m4_ifelse" -;;; "m4_include" "m4_incr" "m4_index" "m4_indir" "m4_len" "m4_line" -;;; "m4_m4exit" "m4_m4wrap" "m4_maketemp" "m4_patsubst" "m4_popdef" -;;; "m4_pushdef" "m4_regexp" "m4_shift" "m4_sinclude" "m4_substr" -;;; "m4_syscmd" "m4_sysval" "m4_traceoff" "m4_traceon" "m4_translit" -;;; "m4_m4_undefine" "m4_undivert")) - -;;; m4.el ends here diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el deleted file mode 100644 index 25aaf3b8cf7..00000000000 --- a/lisp/progmodes/make-mode.el +++ /dev/null @@ -1,1396 +0,0 @@ -;;; make-mode.el --- makefile editing commands for Emacs - -;; Copyright (C) 1992, 1994 Free Software Foundation, Inc. - -;; Author: Thomas Neumann <tom@smart.bo.open.de> -;; Eric S. Raymond <esr@snark.thyrsus.com> -;; Adapted-By: ESR -;; Keywords: unix, tools - -;; RMS: -;; This needs work. -;; Also, the doc strings need fixing: the first line doesn't stand alone, -;; and other usage is not high quality. Symbol names don't have `...'. - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; A major mode for editing makefiles. The mode knows about Makefile -;; syntax and defines M-n and M-p to move to next and previous productions. -;; -;; The keys $, =, : and . are electric; they try to help you fill in a -;; macro reference, macro definition, ordinary target name, or special -;; target name, respectively. Such names are completed using a list of -;; targets and macro names parsed out of the makefile. This list is -;; automatically updated, if necessary, whenever you invoke one of -;; these commands. You can force it to be updated with C-c C-p. -;; -;; The command C-c C-f adds certain filenames in the current directory -;; as targets. You can filter out filenames by setting the variable -;; makefile-ignored-files-in-pickup-regex. -;; -;; The command C-c C-u grinds for a bit, then pops up a report buffer -;; showing which target names are up-to-date with respect to their -;; prerequisites, which targets are out-of-date, and which have no -;; prerequisites. -;; -;; The command C-c C-b pops up a browser window listing all target and -;; macro names. You can mark or unmark items wit C-c SPC, and insert -;; all marked items back in the Makefile with C-c TAB. -;; -;; The command C-c TAB in the makefile buffer inserts a GNU make builtin. -;; You will be prompted for the builtin's args. -;; -;; There are numerous other customization variables. - -;; -;; To Do: -;; -;; * makefile-backslash-region should be given better behavior. -;; * Consider binding C-c C-c to comment-region (like cc-mode). -;; * Eliminate electric stuff entirely. -;; * It might be nice to highlight targets differently depending on -;; whether they are up-to-date or not. Not sure how this would -;; interact with font-lock. -;; * Would be nice to edit the commands in ksh-mode and have -;; indentation and slashification done automatically. Hard. -;; * Consider removing browser mode. It seems useless. -;; * ":" should notice when a new target is made and add it to the -;; list (or at least set makefile-need-target-pickup). -;; * Make browser into a major mode. -;; * Clean up macro insertion stuff. It is a mess. -;; * Browser entry and exit is weird. Normalize. -;; * Browser needs to be rewritten. Right now it is kind of a crock. -;; Should at least: -;; * Act more like dired/buffer menu/whatever. -;; * Highlight as mouse traverses. -;; * B2 inserts. -;; * Update documentation above. -;; * Update texinfo manual. -;; * Update files.el. - - - -;;; Code: - -(provide 'makefile) - -;; Sadly we need this for a macro. -(eval-when-compile - (require 'imenu)) - -;;; ------------------------------------------------------------ -;;; Configurable stuff -;;; ------------------------------------------------------------ - -(defvar makefile-browser-buffer-name "*Macros and Targets*" - "Name of the macro- and target browser buffer.") - -(defvar makefile-target-colon ":" - "String to append to all target names inserted by `makefile-insert-target'. -\":\" or \"::\" are common values.") - -(defvar makefile-macro-assign " = " - "String to append to all macro names inserted by `makefile-insert-macro'. -The normal value should be \" = \", since this is what -standard make expects. However, newer makes such as dmake -allow a larger variety of different macro assignments, so you -might prefer to use \" += \" or \" := \" .") - -(defvar makefile-electric-keys nil - "If non-nil, install electric keybindings. -Default is nil.") - -(defvar makefile-use-curly-braces-for-macros-p nil - "Controls the style of generated macro references. -t (actually non-nil) means macro references should use curly braces, -like `${this}'. -nil means use parentheses, like `$(this)'.") - -(defvar makefile-tab-after-target-colon t - "If non-nil, insert a TAB after a target colon. -Otherwise, a space is inserted. -The default is t.") - -(defvar makefile-browser-leftmost-column 10 - "Number of blanks to the left of the browser selection mark.") - -(defvar makefile-browser-cursor-column 10 - "Column in which the cursor is positioned when it moves -up or down in the browser.") - -(defvar makefile-backslash-column 48 - "*Column in which `makefile-backslash-region' inserts backslashes.") - -(defvar makefile-browser-selected-mark "+ " - "String used to mark selected entries in the browser.") - -(defvar makefile-browser-unselected-mark " " - "String used to mark unselected entries in the browser.") - -(defvar makefile-browser-auto-advance-after-selection-p t - "If non-nil, cursor will move after item is selected in browser.") - -(defvar makefile-pickup-everything-picks-up-filenames-p nil - "If non-nil, `makefile-pickup-everything' picks up filenames as targets. -\(i.e. it calls `makefile-find-filenames-as-targets'). -Otherwise filenames are omitted.") - -(defvar makefile-cleanup-continuations-p t - "If non-nil, automatically clean up continuation lines when saving. -A line is cleaned up by removing all whitespace following a trailing -backslash. This is done silently. -IMPORTANT: Please note that enabling this option causes makefile-mode -to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \'it seems necessary\'.") - -(defvar makefile-browser-hook '()) - -;; -;; Special targets for DMake, Sun's make ... -;; -(defvar makefile-special-targets-list - '(("DEFAULT") ("DONE") ("ERROR") ("EXPORT") - ("FAILED") ("GROUPEPILOG") ("GROUPPROLOG") ("IGNORE") - ("IMPORT") ("INCLUDE") ("INCLUDEDIRS") ("INIT") - ("KEEP_STATE") ("MAKEFILES") ("MAKE_VERSION") ("NO_PARALLEL") - ("PARALLEL") ("PHONY") ("PRECIOUS") ("REMOVE") - ("SCCS_GET") ("SILENT") ("SOURCE") ("SUFFIXES") - ("WAIT") ("c.o") ("C.o") ("m.o") - ("el.elc") ("y.c") ("s.o")) - "List of special targets. -You will be offered to complete on one of those in the minibuffer whenever -you enter a \".\" at the beginning of a line in makefile-mode.") - -(defvar makefile-runtime-macros-list - '(("@") ("&") (">") ("<") ("*") ("^") ("+") ("?") ("%") ("$")) - "List of macros that are resolved by make at runtime. -If you insert a macro reference using makefile-insert-macro-ref, the name -of the macro is checked against this list. If it can be found its name will -not be enclosed in { } or ( ).") - -;; Note that the first big subexpression is used by font lock. Note -;; that if you change this regexp you must fix the imenu index -;; function defined at the end of the file. -(defconst makefile-dependency-regex - "^ *\\([^\n\t#:]+\\([ \t]+[^ \t\n#:]+\\)*\\)[ \t]*:\\([ \t]*$\\|\\([^=\n].*$\\)\\)" - "Regex used to find dependency lines in a makefile.") - -;; Note that the first subexpression is used by font lock. Note that -;; if you change this regexp you must fix the imenu index function -;; defined at the end of the file. -(defconst makefile-macroassign-regex - "^ *\\([^\n\t][^:#= \t\n]*\\)[ \t]*[*:+]?:?=" - "Regex used to find macro assignment lines in a makefile.") - -(defconst makefile-ignored-files-in-pickup-regex - "\\(^\\..*\\)\\|\\(.*~$\\)\\|\\(.*,v$\\)\\|\\(\\.[chy]\\)" - "Regex for filenames that will NOT be included in the target list.") - -(if (fboundp 'facemenu-unlisted-faces) - (add-to-list 'facemenu-unlisted-faces 'makefile-space-face)) -(defvar makefile-space-face 'makefile-space-face - "Face to use for highlighting leading spaces in Font-Lock mode.") - -(defconst makefile-font-lock-keywords - (list - ;; Do macro assignments. These get the "variable-name" face rather - ;; arbitrarily. - (list makefile-macroassign-regex 1 'font-lock-variable-name-face) - ;; - ;; Do dependencies. These get the function name face. - (list makefile-dependency-regex 1 'font-lock-function-name-face) - ;; - ;; Variable references even in targets/strings/comments: - '("\\$[({]\\([-a-zA-Z0-9_.]+\\)[}):]" 1 font-lock-reference-face prepend) - - ;; Highlight lines that contain just whitespace. - ;; They can cause trouble, especially if they start with a tab. - '("^[ \t]+$" . makefile-space-face) - - ;; Highlight shell comments that Make treats as commands, - ;; since these can fool people. - '("^\t+#" 0 makefile-space-face t) - - ;; Highlight spaces that precede tabs. - ;; They can make a tab fail to be effective. - '("^\\( +\\)\t" 1 makefile-space-face))) - -;;; ------------------------------------------------------------ -;;; The following configurable variables are used in the -;;; up-to-date overview . -;;; The standard configuration assumes that your `make' program -;;; can be run in question/query mode using the `-q' option, this -;;; means that the command -;;; -;;; make -q foo -;;; -;;; should return an exit status of zero if the target `foo' is -;;; up to date and a nonzero exit status otherwise. -;;; Many makes can do this although the docs/manpages do not mention -;;; it. Try it with your favourite one. GNU make, System V make, and -;;; Dennis Vadura's DMake have no problems. -;;; Set the variable `makefile-brave-make' to the name of the -;;; make utility that does this on your system. -;;; To understand what this is all about see the function definition -;;; of `makefile-query-by-make-minus-q' . -;;; ------------------------------------------------------------ - -(defvar makefile-brave-make "make" - "A make that can handle the `-q' option.") - -(defvar makefile-query-one-target-method 'makefile-query-by-make-minus-q - "Function to call to determine whether a make target is up to date. -The function must satisfy this calling convention: - -* As its first argument, it must accept the name of the target to - be checked, as a string. - -* As its second argument, it may accept the name of a makefile - as a string. Depending on what you're going to do you may - not need this. - -* It must return the integer value 0 (zero) if the given target - should be considered up-to-date in the context of the given - makefile, any nonzero integer value otherwise.") - -(defvar makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*" - "Name of the Up-to-date overview buffer.") - -;;; --- end of up-to-date-overview configuration ------------------ - -(defvar makefile-mode-map nil - "The keymap that is used in Makefile mode.") - -(if makefile-mode-map - () - (setq makefile-mode-map (make-sparse-keymap)) - ;; set up the keymap - (define-key makefile-mode-map "\C-c:" 'makefile-insert-target-ref) - (if makefile-electric-keys - (progn - (define-key makefile-mode-map "$" 'makefile-insert-macro-ref) - (define-key makefile-mode-map ":" 'makefile-electric-colon) - (define-key makefile-mode-map "=" 'makefile-electric-equal) - (define-key makefile-mode-map "." 'makefile-electric-dot))) - (define-key makefile-mode-map "\C-c\C-f" 'makefile-pickup-filenames-as-targets) - (define-key makefile-mode-map "\C-c\C-b" 'makefile-switch-to-browser) - (define-key makefile-mode-map "\C-c\C-p" 'makefile-pickup-everything) - (define-key makefile-mode-map "\C-c\C-u" 'makefile-create-up-to-date-overview) - (define-key makefile-mode-map "\C-c\C-i" 'makefile-insert-gmake-function) - (define-key makefile-mode-map "\C-c\C-\\" 'makefile-backslash-region) - (define-key makefile-mode-map "\M-p" 'makefile-previous-dependency) - (define-key makefile-mode-map "\M-n" 'makefile-next-dependency) - (define-key makefile-mode-map "\e\t" 'makefile-complete) - - ;; Make menus. - (define-key makefile-mode-map [menu-bar makefile-mode] - (cons "Makefile" (make-sparse-keymap "Makefile"))) - - (define-key makefile-mode-map [menu-bar makefile-mode browse] - '("Pop up Makefile Browser" . makefile-switch-to-browser)) - (define-key makefile-mode-map [menu-bar makefile-mode complete] - '("Complete Target or Macro" . makefile-complete)) - (define-key makefile-mode-map [menu-bar makefile-mode pickup] - '("Find Targets and Macros" . makefile-pickup-everything)) - - (define-key makefile-mode-map [menu-bar makefile-mode prev] - '("Move to Previous Dependency" . makefile-previous-dependency)) - (define-key makefile-mode-map [menu-bar makefile-mode next] - '("Move to Next Dependency" . makefile-next-dependency))) - -(defvar makefile-browser-map nil - "The keymap that is used in the macro- and target browser.") -(if makefile-browser-map - () - (setq makefile-browser-map (make-sparse-keymap)) - (define-key makefile-browser-map "n" 'makefile-browser-next-line) - (define-key makefile-browser-map "\C-n" 'makefile-browser-next-line) - (define-key makefile-browser-map "p" 'makefile-browser-previous-line) - (define-key makefile-browser-map "\C-p" 'makefile-browser-previous-line) - (define-key makefile-browser-map " " 'makefile-browser-toggle) - (define-key makefile-browser-map "i" 'makefile-browser-insert-selection) - (define-key makefile-browser-map "I" 'makefile-browser-insert-selection-and-quit) - (define-key makefile-browser-map "\C-c\C-m" 'makefile-browser-insert-continuation) - (define-key makefile-browser-map "q" 'makefile-browser-quit) - ;; disable horizontal movement - (define-key makefile-browser-map "\C-b" 'undefined) - (define-key makefile-browser-map "\C-f" 'undefined)) - - -(defvar makefile-mode-syntax-table nil) -(if makefile-mode-syntax-table - () - (setq makefile-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\( "() " makefile-mode-syntax-table) - (modify-syntax-entry ?\) ")( " makefile-mode-syntax-table) - (modify-syntax-entry ?\[ "(] " makefile-mode-syntax-table) - (modify-syntax-entry ?\] ")[ " makefile-mode-syntax-table) - (modify-syntax-entry ?\{ "(} " makefile-mode-syntax-table) - (modify-syntax-entry ?\} "){ " makefile-mode-syntax-table) - (modify-syntax-entry ?\' "\" " makefile-mode-syntax-table) - (modify-syntax-entry ?\` "\" " makefile-mode-syntax-table) - (modify-syntax-entry ?# "< " makefile-mode-syntax-table) - (modify-syntax-entry ?\n "> " makefile-mode-syntax-table)) - - -;;; ------------------------------------------------------------ -;;; Internal variables. -;;; You don't need to configure below this line. -;;; ------------------------------------------------------------ - -(defvar makefile-target-table nil - "Table of all target names known for this buffer.") - -(defvar makefile-macro-table nil - "Table of all macro names known for this buffer.") - -(defvar makefile-browser-client - "A buffer in Makefile mode that is currently using the browser.") - -(defvar makefile-browser-selection-vector nil) -(defvar makefile-has-prereqs nil) -(defvar makefile-need-target-pickup t) -(defvar makefile-need-macro-pickup t) - -(defvar makefile-mode-hook '()) - -;; Each element looks like '("GNU MAKE FUNCTION" "ARG" "ARG" ... ) -;; Each "ARG" is used as a prompt for a required argument. -(defconst makefile-gnumake-functions-alist - '( - ;; Text functions - ("subst" "From" "To" "In") - ("patsubst" "Pattern" "Replacement" "In") - ("strip" "Text") - ("findstring" "Find what" "In") - ("filter" "Pattern" "Text") - ("filter-out" "Pattern" "Text") - ("sort" "List") - ;; Filename functions - ("dir" "Names") - ("notdir" "Names") - ("suffix" "Names") - ("basename" "Names") - ("addprefix" "Prefix" "Names") - ("addsuffix" "Suffix" "Names") - ("join" "List 1" "List 2") - ("word" "Index" "Text") - ("words" "Text") - ("firstword" "Text") - ("wildcard" "Pattern") - ;; Misc functions - ("foreach" "Variable" "List" "Text") - ("origin" "Variable") - ("shell" "Command"))) - - -;;; ------------------------------------------------------------ -;;; The mode function itself. -;;; ------------------------------------------------------------ - -;;;###autoload -(defun makefile-mode () - "Major mode for editing Makefiles. -This function ends by invoking the function(s) `makefile-mode-hook'. - -\\{makefile-mode-map} - -In the browser, use the following keys: - -\\{makefile-browser-map} - -Makefile mode can be configured by modifying the following variables: - -makefile-browser-buffer-name: - Name of the macro- and target browser buffer. - -makefile-target-colon: - The string that gets appended to all target names - inserted by `makefile-insert-target'. - \":\" or \"::\" are quite common values. - -makefile-macro-assign: - The string that gets appended to all macro names - inserted by `makefile-insert-macro'. - The normal value should be \" = \", since this is what - standard make expects. However, newer makes such as dmake - allow a larger variety of different macro assignments, so you - might prefer to use \" += \" or \" := \" . - -makefile-tab-after-target-colon: - If you want a TAB (instead of a space) to be appended after the - target colon, then set this to a non-nil value. - -makefile-browser-leftmost-column: - Number of blanks to the left of the browser selection mark. - -makefile-browser-cursor-column: - Column in which the cursor is positioned when it moves - up or down in the browser. - -makefile-browser-selected-mark: - String used to mark selected entries in the browser. - -makefile-browser-unselected-mark: - String used to mark unselected entries in the browser. - -makefile-browser-auto-advance-after-selection-p: - If this variable is set to a non-nil value the cursor - will automagically advance to the next line after an item - has been selected in the browser. - -makefile-pickup-everything-picks-up-filenames-p: - If this variable is set to a non-nil value then - `makefile-pickup-everything' also picks up filenames as targets - (i.e. it calls `makefile-find-filenames-as-targets'), otherwise - filenames are omitted. - -makefile-cleanup-continuations-p: - If this variable is set to a non-nil value then makefile-mode - will assure that no line in the file ends with a backslash - (the continuation character) followed by any whitespace. - This is done by silently removing the trailing whitespace, leaving - the backslash itself intact. - IMPORTANT: Please note that enabling this option causes makefile-mode - to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\". - -makefile-browser-hook: - A function or list of functions to be called just before the - browser is entered. This is executed in the makefile buffer. - -makefile-special-targets-list: - List of special targets. You will be offered to complete - on one of those in the minibuffer whenever you enter a `.'. - at the beginning of a line in Makefile mode." - - (interactive) - (kill-all-local-variables) - (make-local-variable 'local-write-file-hooks) - (setq local-write-file-hooks - '(makefile-cleanup-continuations makefile-warn-suspicious-lines)) - (make-local-variable 'makefile-target-table) - (make-local-variable 'makefile-macro-table) - (make-local-variable 'makefile-has-prereqs) - (make-local-variable 'makefile-need-target-pickup) - (make-local-variable 'makefile-need-macro-pickup) - - ;; Font lock. - (if (fboundp 'make-face) - (makefile-define-space-face)) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(makefile-font-lock-keywords)) - - ;; Add-log. - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function 'makefile-add-log-defun) - - ;; Imenu. - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function 'makefile-menu-index-function) - - ;; Dabbrev. - (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) - (setq dabbrev-abbrev-skip-leading-regexp "\\$") - - ;; Comment stuff. - (make-local-variable 'comment-start) - (setq comment-start "#") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+[ \t]*") - - ;; become the current major mode - (setq major-mode 'makefile-mode) - (setq mode-name "Makefile") - - ;; Activate keymap and syntax table. - (use-local-map makefile-mode-map) - (set-syntax-table makefile-mode-syntax-table) - - ;; Real TABs are important in makefiles - (setq indent-tabs-mode t) - (run-hooks 'makefile-mode-hook)) - - - -;;; Motion code. - -(defun makefile-next-dependency () - "Move point to the beginning of the next dependency line." - (interactive) - (let ((here (point))) - (end-of-line) - (if (re-search-forward makefile-dependency-regex (point-max) t) - (progn (beginning-of-line) t) ; indicate success - (goto-char here) nil))) - -(defun makefile-previous-dependency () - "Move point to the beginning of the previous dependency line." - (interactive) - (let ((here (point))) - (beginning-of-line) - (if (re-search-backward makefile-dependency-regex (point-min) t) - (progn (beginning-of-line) t) ; indicate success - (goto-char here) nil))) - - - -;;; Electric keys. Blech. - -(defun makefile-electric-dot (arg) - "Prompt for the name of a special target to insert. -Only does electric insertion at beginning of line. -Anywhere else just self-inserts." - (interactive "p") - (if (bolp) - (makefile-insert-special-target) - (self-insert-command arg))) - -(defun makefile-insert-special-target () - "Prompt for and insert a special target name. -Uses `makefile-special-targets' list." - (interactive) - (makefile-pickup-targets) - (let ((special-target - (completing-read "Special target: " - makefile-special-targets-list nil nil nil))) - (if (zerop (length special-target)) - () - (insert "." special-target ":") - (makefile-forward-after-target-colon)))) - -(defun makefile-electric-equal (arg) - "Prompt for name of a macro to insert. -Only does prompting if point is at beginning of line. -Anywhere else just self-inserts." - (interactive "p") - (makefile-pickup-macros) - (if (bolp) - (call-interactively 'makefile-insert-macro) - (self-insert-command arg))) - -(defun makefile-insert-macro (macro-name) - "Prepare definition of a new macro." - (interactive "sMacro Name: ") - (makefile-pickup-macros) - (if (not (zerop (length macro-name))) - (progn - (beginning-of-line) - (insert macro-name makefile-macro-assign) - (setq makefile-need-macro-pickup t) - (makefile-remember-macro macro-name)))) - -(defun makefile-insert-macro-ref (macro-name) - "Complete on a list of known macros, then insert complete ref at point." - (interactive - (list - (progn - (makefile-pickup-macros) - (completing-read "Refer to macro: " makefile-macro-table nil nil nil)))) - (makefile-do-macro-insertion macro-name)) - -(defun makefile-insert-target (target-name) - "Prepare definition of a new target (dependency line)." - (interactive "sTarget: ") - (if (not (zerop (length target-name))) - (progn - (beginning-of-line) - (insert target-name makefile-target-colon) - (makefile-forward-after-target-colon) - (end-of-line) - (setq makefile-need-target-pickup t) - (makefile-remember-target target-name)))) - -(defun makefile-insert-target-ref (target-name) - "Complete on a list of known targets, then insert target-ref at point." - (interactive - (list - (progn - (makefile-pickup-targets) - (completing-read "Refer to target: " makefile-target-table nil nil nil)))) - (if (not (zerop (length target-name))) - (insert target-name " "))) - -(defun makefile-electric-colon (arg) - "Prompt for name of new target. -Prompting only happens at beginning of line. -Anywhere else just self-inserts." - (interactive "p") - (if (bolp) - (call-interactively 'makefile-insert-target) - (self-insert-command arg))) - - - -;;; ------------------------------------------------------------ -;;; Extracting targets and macros from an existing makefile -;;; ------------------------------------------------------------ - -(defun makefile-pickup-targets () - "Notice names of all target definitions in Makefile." - (interactive) - (if (not makefile-need-target-pickup) - nil - (setq makefile-need-target-pickup nil) - (setq makefile-target-table nil) - (setq makefile-has-prereqs nil) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward makefile-dependency-regex (point-max) t) - (makefile-add-this-line-targets))) - (message "Read targets OK."))) - -(defun makefile-add-this-line-targets () - (save-excursion - (beginning-of-line) - (let ((done-with-line nil) - (line-number (1+ (count-lines (point-min) (point))))) - (while (not done-with-line) - (skip-chars-forward " \t") - (if (not (setq done-with-line (or (eolp) - (char-equal (char-after (point)) ?:)))) - (progn - (let* ((start-of-target-name (point)) - (target-name - (progn - (skip-chars-forward "^ \t:#") - (buffer-substring start-of-target-name (point)))) - (has-prereqs - (not (looking-at ":[ \t]*$")))) - (if (makefile-remember-target target-name has-prereqs) - (message "Picked up target \"%s\" from line %d" - target-name line-number))))))))) - -(defun makefile-pickup-macros () - "Notice names of all macro definitions in Makefile." - (interactive) - (if (not makefile-need-macro-pickup) - nil - (setq makefile-need-macro-pickup nil) - (setq makefile-macro-table nil) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward makefile-macroassign-regex (point-max) t) - (makefile-add-this-line-macro) - (forward-line 1))) - (message "Read macros OK."))) - -(defun makefile-add-this-line-macro () - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (if (not (eolp)) - (let* ((start-of-macro-name (point)) - (line-number (1+ (count-lines (point-min) (point)))) - (macro-name (progn - (skip-chars-forward "^ \t:#=*") - (buffer-substring start-of-macro-name (point))))) - (if (makefile-remember-macro macro-name) - (message "Picked up macro \"%s\" from line %d" - macro-name line-number)))))) - -(defun makefile-pickup-everything (arg) - "Notice names of all macros and targets in Makefile. -Prefix arg means force pickups to be redone." - (interactive "P") - (if arg - (progn - (setq makefile-need-target-pickup t) - (setq makefile-need-macro-pickup t))) - (makefile-pickup-macros) - (makefile-pickup-targets) - (if makefile-pickup-everything-picks-up-filenames-p - (makefile-pickup-filenames-as-targets))) - -(defun makefile-pickup-filenames-as-targets () - "Scan the current directory for filenames to use as targets. -Checks each filename against `makefile-ignored-files-in-pickup-regex' -and adds all qualifying names to the list of known targets." - (interactive) - (let* ((dir (file-name-directory (buffer-file-name))) - (raw-filename-list (if dir - (file-name-all-completions "" dir) - (file-name-all-completions "" "")))) - (mapcar '(lambda (name) - (if (and (not (file-directory-p name)) - (not (string-match makefile-ignored-files-in-pickup-regex - name))) - (if (makefile-remember-target name) - (message "Picked up file \"%s\" as target" name)))) - raw-filename-list))) - - - -;;; Completion. - -(defun makefile-complete () - "Perform completion on Makefile construct preceding point. -Can complete variable and target names. -The context determines which are considered." - (interactive) - (let* ((beg (save-excursion - (skip-chars-backward "^$(){}:#= \t\n") - (point))) - (try (buffer-substring beg (point))) - (do-macros nil) - (paren nil)) - - (save-excursion - (goto-char beg) - (let ((pc (preceding-char))) - (cond - ;; Beginning of line means anything. - ((bolp) - ()) - - ;; Preceding "$" means macros only. - ((= pc ?$) - (setq do-macros t)) - - ;; Preceding "$(" or "${" means macros only. - ((and (or (= pc ?{) - (= pc ?\()) - (progn - (setq paren pc) - (backward-char) - (and (not (bolp)) - (= (preceding-char) ?$)))) - (setq do-macros t))))) - - ;; Try completion. - (let* ((table (append (if do-macros - '() - makefile-target-table) - makefile-macro-table)) - (completion (try-completion try table))) - (cond - ;; Exact match, so insert closing paren or colon. - ((eq completion t) - (insert (if do-macros - (if (eq paren ?{) - ?} - ?\)) - (if (save-excursion - (goto-char beg) - (bolp)) - ":" - " ")))) - - ;; No match. - ((null completion) - (message "Can't find completion for \"%s\"" try) - (ding)) - - ;; Partial completion. - ((not (string= try completion)) - ;; FIXME it would be nice to supply the closing paren if an - ;; exact, unambiguous match were found. That is not possible - ;; right now. Ditto closing ":" for targets. - (delete-region beg (point)) - - ;; DO-MACROS means doing macros only. If not that, then check - ;; to see if this completion is a macro. Special insertion - ;; must be done for macros. - (if (or do-macros - (assoc completion makefile-macro-table)) - (let ((makefile-use-curly-braces-for-macros-p - (or (eq paren ?{) - makefile-use-curly-braces-for-macros-p))) - (delete-backward-char 2) - (makefile-do-macro-insertion completion) - (delete-backward-char 1)) - - ;; Just insert targets. - (insert completion))) - - ;; Can't complete any more, so make completion list. FIXME - ;; this doesn't do the right thing when the completion is - ;; actually inserted. I don't think there is an easy way to do - ;; that. - (t - (message "Making completion list...") - (let ((list (all-completions try table))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...done")))))) - - - -;; Backslashification. Stolen from cc-mode.el. - -(defun makefile-backslashify-current-line (doit) - (end-of-line) - (if doit - (if (not (save-excursion - (forward-char -1) - (eq (char-after (point)) ?\\ ))) - (progn - (if (>= (current-column) makefile-backslash-column) - (insert " \\") - (while (<= (current-column) makefile-backslash-column) - (insert "\t") - (end-of-line)) - (delete-char -1) - (while (< (current-column) makefile-backslash-column) - (insert " ") - (end-of-line)) - (insert "\\")))) - (if (not (bolp)) - (progn - (forward-char -1) - (if (eq (char-after (point)) ?\\ ) - (let ((saved (save-excursion - (end-of-line) - (point)))) - (skip-chars-backward " \t") - (delete-region (point) saved))))))) - -(defun makefile-backslash-region (beg end arg) - "Insert backslashes at end of every line in region. -Useful for defining multi-line rules. -If called with a prefix argument, trailing backslashes are removed." - (interactive "r\nP") - (save-excursion - (let ((do-lastline-p (progn (goto-char end) (not (bolp))))) - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (not (save-excursion - (forward-line 1) - (eobp))) - (makefile-backslashify-current-line (null arg)) - (forward-line 1))) - (and do-lastline-p - (progn (goto-char end) - (makefile-backslashify-current-line (null arg))))))) - - - -;;; ------------------------------------------------------------ -;;; Browser mode. -;;; ------------------------------------------------------------ - -(defun makefile-browser-format-target-line (target selected) - (format - (concat (make-string makefile-browser-leftmost-column ?\ ) - (if selected - makefile-browser-selected-mark - makefile-browser-unselected-mark) - "%s%s") - target makefile-target-colon)) - -(defun makefile-browser-format-macro-line (macro selected) - (format - (concat (make-string makefile-browser-leftmost-column ?\ ) - (if selected - makefile-browser-selected-mark - makefile-browser-unselected-mark) - (makefile-format-macro-ref macro)))) - -(defun makefile-browser-fill (targets macros) - (let ((inhibit-read-only t)) - (goto-char (point-min)) - (erase-buffer) - (mapconcat - (function - (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n"))) - targets - "") - (mapconcat - (function - (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n"))) - macros - "") - (sort-lines nil (point-min) (point-max)) - (goto-char (1- (point-max))) - (delete-char 1) ; remove unnecessary newline at eob - (goto-char (point-min)) - (forward-char makefile-browser-cursor-column))) - -;;; -;;; Moving up and down in the browser -;;; - -(defun makefile-browser-next-line () - "Move the browser selection cursor to the next line." - (interactive) - (if (not (makefile-last-line-p)) - (progn - (forward-line 1) - (forward-char makefile-browser-cursor-column)))) - -(defun makefile-browser-previous-line () - "Move the browser selection cursor to the previous line." - (interactive) - (if (not (makefile-first-line-p)) - (progn - (forward-line -1) - (forward-char makefile-browser-cursor-column)))) - -;;; -;;; Quitting the browser (returns to client buffer) -;;; - -(defun makefile-browser-quit () - "Leave the browser and return to the makefile buffer." - (interactive) - (let ((my-client makefile-browser-client)) - (setq makefile-browser-client nil) ; we quitted, so NO client! - (set-buffer-modified-p nil) - (kill-buffer (current-buffer)) - (pop-to-buffer my-client))) - -;;; -;;; Toggle state of a browser item -;;; - -(defun makefile-browser-toggle () - "Toggle the selection state of the browser item at the cursor position." - (interactive) - (let ((this-line (count-lines (point-min) (point)))) - (setq this-line (max 1 this-line)) - (makefile-browser-toggle-state-for-line this-line) - (goto-line this-line) - (let ((inhibit-read-only t)) - (beginning-of-line) - (if (makefile-browser-on-macro-line-p) - (let ((macro-name (makefile-browser-this-line-macro-name))) - (delete-region (point) (progn (end-of-line) (point))) - (insert - (makefile-browser-format-macro-line - macro-name - (makefile-browser-get-state-for-line this-line)))) - (let ((target-name (makefile-browser-this-line-target-name))) - (delete-region (point) (progn (end-of-line) (point))) - (insert - (makefile-browser-format-target-line - target-name - (makefile-browser-get-state-for-line this-line)))))) - (beginning-of-line) - (forward-char makefile-browser-cursor-column) - (if makefile-browser-auto-advance-after-selection-p - (makefile-browser-next-line)))) - -;;; -;;; Making insertions into the client buffer -;;; - -(defun makefile-browser-insert-continuation () - "Insert a makefile continuation. -In the makefile buffer, go to (end-of-line), insert a \'\\\' -character, insert a new blank line, go to that line and indent by one TAB. -This is most useful in the process of creating continued lines when copying -large dependencies from the browser to the client buffer. -\(point) advances accordingly in the client buffer." - (interactive) - (save-excursion - (set-buffer makefile-browser-client) - (end-of-line) - (insert "\\\n\t"))) - -(defun makefile-browser-insert-selection () - "Insert all selected targets and/or macros in the makefile buffer. -Insertion takes place at point." - (interactive) - (save-excursion - (goto-line 1) - (let ((current-line 1)) - (while (not (eobp)) - (if (makefile-browser-get-state-for-line current-line) - (makefile-browser-send-this-line-item)) - (forward-line 1) - (setq current-line (1+ current-line)))))) - -(defun makefile-browser-insert-selection-and-quit () - (interactive) - (makefile-browser-insert-selection) - (makefile-browser-quit)) - -(defun makefile-browser-send-this-line-item () - (if (makefile-browser-on-macro-line-p) - (save-excursion - (let ((macro-name (makefile-browser-this-line-macro-name))) - (set-buffer makefile-browser-client) - (insert (makefile-format-macro-ref macro-name) " "))) - (save-excursion - (let ((target-name (makefile-browser-this-line-target-name))) - (set-buffer makefile-browser-client) - (insert target-name " "))))) - -(defun makefile-browser-start-interaction () - (use-local-map makefile-browser-map) - (setq buffer-read-only t)) - -(defun makefile-browse (targets macros) - (interactive) - (if (zerop (+ (length targets) (length macros))) - (progn - (beep) - (message "No macros or targets to browse! Consider running 'makefile-pickup-everything\'")) - (let ((browser-buffer (get-buffer-create makefile-browser-buffer-name))) - (pop-to-buffer browser-buffer) - (make-variable-buffer-local 'makefile-browser-selection-vector) - (makefile-browser-fill targets macros) - (shrink-window-if-larger-than-buffer) - (setq makefile-browser-selection-vector - (make-vector (+ (length targets) (length macros)) nil)) - (makefile-browser-start-interaction)))) - -(defun makefile-switch-to-browser () - (interactive) - (run-hooks 'makefile-browser-hook) - (setq makefile-browser-client (current-buffer)) - (makefile-pickup-targets) - (makefile-pickup-macros) - (makefile-browse makefile-target-table makefile-macro-table)) - - - -;;; ------------------------------------------------------------ -;;; Up-to-date overview buffer -;;; ------------------------------------------------------------ - -(defun makefile-create-up-to-date-overview () - "Create a buffer containing an overview of the state of all known targets. -Known targets are targets that are explicitly defined in that makefile; -in other words, all targets that appear on the left hand side of a -dependency in the makefile." - (interactive) - (if (y-or-n-p "Are you sure that the makefile being edited is consistent? ") - ;; - ;; The rest of this function operates on a temporary makefile, created by - ;; writing the current contents of the makefile buffer. - ;; - (let ((saved-target-table makefile-target-table) - (this-buffer (current-buffer)) - (makefile-up-to-date-buffer - (get-buffer-create makefile-up-to-date-buffer-name)) - (filename (makefile-save-temporary)) - ;; - ;; Forget the target table because it may contain picked-up filenames - ;; that are not really targets in the current makefile. - ;; We don't want to query these, so get a new target-table with just the - ;; targets that can be found in the makefile buffer. - ;; The 'old' target table will be restored later. - ;; - (real-targets (progn - (makefile-pickup-targets) - makefile-target-table)) - (prereqs makefile-has-prereqs) - ) - - (set-buffer makefile-up-to-date-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (makefile-query-targets filename real-targets prereqs) - (if (zerop (buffer-size)) ; if it did not get us anything - (progn - (kill-buffer (current-buffer)) - (message "No overview created!"))) - (set-buffer this-buffer) - (setq makefile-target-table saved-target-table) - (if (get-buffer makefile-up-to-date-buffer-name) - (progn - (pop-to-buffer (get-buffer makefile-up-to-date-buffer-name)) - (shrink-window-if-larger-than-buffer) - (sort-lines nil (point-min) (point-max)) - (setq buffer-read-only t)))))) - -(defun makefile-save-temporary () - "Create a temporary file from the current makefile buffer." - (let ((filename (makefile-generate-temporary-filename))) - (write-region (point-min) (point-max) filename nil 0) - filename)) ; return the filename - -(defun makefile-generate-temporary-filename () - "Create a filename suitable for use in `makefile-save-temporary'. -Be careful to allow brain-dead file systems (DOS, SYSV ...) to cope -with the generated name!" - (let ((my-name (user-login-name)) - (my-uid (int-to-string (user-uid)))) - (concat "mktmp" - (if (> (length my-name) 3) - (substring my-name 0 3) - my-name) - "." - (if (> (length my-uid) 3) - (substring my-uid 0 3) - my-uid)))) - -(defun makefile-query-targets (filename target-table prereq-list) - "Fill the up-to-date overview buffer. -Checks each target in TARGET-TABLE using `makefile-query-one-target-method' -and generates the overview, one line per target name." - (insert - (mapconcat - (function (lambda (item) - (let* ((target-name (car item)) - (no-prereqs (not (member target-name prereq-list))) - (needs-rebuild (or no-prereqs - (funcall - makefile-query-one-target-method - target-name - filename)))) - (format "\t%s%s" - target-name - (cond (no-prereqs " .. has no prerequisites") - (needs-rebuild " .. NEEDS REBUILD") - (t " .. is up to date")))) - )) - target-table "\n")) - (goto-char (point-min)) - (delete-file filename)) ; remove the tmpfile - -(defun makefile-query-by-make-minus-q (target &optional filename) - (not (zerop - (call-process makefile-brave-make nil nil nil - "-f" filename "-q" target)))) - - - -;;; ------------------------------------------------------------ -;;; Continuation cleanup -;;; ------------------------------------------------------------ - -(defun makefile-cleanup-continuations () - (if (eq major-mode 'makefile-mode) - (if (and makefile-cleanup-continuations-p - (not buffer-read-only)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "\\\\[ \t]+$" (point-max) t) - (replace-match "\\" t t)))))) - - -;;; ------------------------------------------------------------ -;;; Warn of suspicious lines -;;; ------------------------------------------------------------ - -(defun makefile-warn-suspicious-lines () - (let ((dont-save nil)) - (if (eq major-mode 'makefile-mode) - (let ((suspicious - (save-excursion - (goto-char (point-min)) - (re-search-forward - "\\(^[\t]+$\\)\\|\\(^[ ]+[\t]\\)" (point-max) t)))) - (if suspicious - (let ((line-nr (count-lines (point-min) suspicious))) - (setq dont-save - (not (y-or-n-p - (format "Suspicious line %d. Save anyway " - line-nr)))))))) - dont-save)) - - - -;;; ------------------------------------------------------------ -;;; GNU make function support -;;; ------------------------------------------------------------ - -(defun makefile-insert-gmake-function () - "Insert a GNU make function call. -Asks for the name of the function to use (with completion). -Then prompts for all required parameters." - (interactive) - (let* ((gm-function-name (completing-read - "Function: " - makefile-gnumake-functions-alist - nil t nil)) - (gm-function-prompts - (cdr (assoc gm-function-name makefile-gnumake-functions-alist)))) - (if (not (zerop (length gm-function-name))) - (insert (makefile-format-macro-ref - (concat gm-function-name " " - (makefile-prompt-for-gmake-funargs - gm-function-name gm-function-prompts))) - " ")))) - -(defun makefile-prompt-for-gmake-funargs (function-name prompt-list) - (mapconcat - (function (lambda (one-prompt) - (read-string (format "[%s] %s: " function-name one-prompt) - nil))) - prompt-list - ",")) - - - -;;; ------------------------------------------------------------ -;;; Utility functions -;;; ------------------------------------------------------------ - -(defun makefile-do-macro-insertion (macro-name) - "Insert a macro reference." - (if (not (zerop (length macro-name))) - (if (assoc macro-name makefile-runtime-macros-list) - (insert "$" macro-name) - (insert (makefile-format-macro-ref macro-name))))) - -(defun makefile-remember-target (target-name &optional has-prereqs) - "Remember a given target if it is not already remembered for this buffer." - (if (not (zerop (length target-name))) - (progn - (if (not (assoc target-name makefile-target-table)) - (setq makefile-target-table - (cons (list target-name) makefile-target-table))) - (if has-prereqs - (setq makefile-has-prereqs - (cons target-name makefile-has-prereqs)))))) - -(defun makefile-remember-macro (macro-name) - "Remember a given macro if it is not already remembered for this buffer." - (if (not (zerop (length macro-name))) - (if (not (assoc macro-name makefile-macro-table)) - (setq makefile-macro-table - (cons (list macro-name) makefile-macro-table))))) - -(defun makefile-forward-after-target-colon () - "Move point forward after inserting the terminating colon of a target. -This acts according to the value of `makefile-tab-after-target-colon'." - (if makefile-tab-after-target-colon - (insert "\t") - (insert " "))) - -(defun makefile-browser-on-macro-line-p () - "Determine if point is on a macro line in the browser." - (save-excursion - (beginning-of-line) - (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t))) - -(defun makefile-browser-this-line-target-name () - "Extract the target name from a line in the browser." - (save-excursion - (end-of-line) - (skip-chars-backward "^ \t") - (buffer-substring (point) (1- (makefile-end-of-line-point))))) - -(defun makefile-browser-this-line-macro-name () - "Extract the macro name from a line in the browser." - (save-excursion - (beginning-of-line) - (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t) - (let ((macro-start (point))) - (skip-chars-forward "^})") - (buffer-substring macro-start (point))))) - -(defun makefile-format-macro-ref (macro-name) - "Format a macro reference. -Uses `makefile-use-curly-braces-for-macros-p'." - (if (or (char-equal ?\( (string-to-char macro-name)) - (char-equal ?\{ (string-to-char macro-name))) - (format "$%s" macro-name) - (if makefile-use-curly-braces-for-macros-p - (format "${%s}" macro-name) - (format "$(%s)" macro-name)))) - -(defun makefile-browser-get-state-for-line (n) - (aref makefile-browser-selection-vector (1- n))) - -(defun makefile-browser-set-state-for-line (n to-state) - (aset makefile-browser-selection-vector (1- n) to-state)) - -(defun makefile-browser-toggle-state-for-line (n) - (makefile-browser-set-state-for-line n (not (makefile-browser-get-state-for-line n)))) - -(defun makefile-beginning-of-line-point () - (save-excursion - (beginning-of-line) - (point))) - -(defun makefile-end-of-line-point () - (save-excursion - (end-of-line) - (point))) - -(defun makefile-last-line-p () - (= (makefile-end-of-line-point) (point-max))) - -(defun makefile-first-line-p () - (= (makefile-beginning-of-line-point) (point-min))) - - - -;;; Support for other packages, like add-log and imenu. - -(defun makefile-add-log-defun () - "Return name of target or variable assignment that point is in. -If it isn't in one, return nil." - (save-excursion - (let (found) - (beginning-of-line) - ;; Scan back line by line, noticing when we come to a - ;; variable or rule definition, and giving up when we see - ;; a line that is not part of either of those. - (while (not found) - (cond - ((looking-at makefile-macroassign-regex) - (setq found (buffer-substring-no-properties (match-beginning 1) - (match-end 1)))) - ((looking-at makefile-dependency-regex) - (setq found (buffer-substring-no-properties (match-beginning 1) - (match-end 1)))) - ;; Don't keep looking across a blank line or comment. Give up. - ((looking-at "$\\|#") - (setq found 'bobp)) - ((bobp) - (setq found 'bobp))) - (or found - (forward-line -1))) - (if (stringp found) found)))) - -;; FIXME it might be nice to have them separated by macro vs target. -(defun makefile-menu-index-function () - ;; "Generate alist of indices for imenu." - (let (alist - stupid - (re (concat makefile-dependency-regex - "\\|" - makefile-macroassign-regex))) - (imenu-progress-message stupid 0) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (imenu-progress-message stupid) - (let ((n (if (match-beginning 1) 1 5))) - (setq alist (cons - (cons (buffer-substring (match-beginning n) - (match-end n)) - (match-beginning n)) - alist)))) - (imenu-progress-message stupid 100) - (nreverse alist))) - -(defun makefile-define-space-face () - (make-face 'makefile-space-face) - (or (not (eq window-system 'x)) - (face-differs-from-default-p 'makefile-space-face) - (let* ((params (frame-parameters)) - (light-bg (cdr (assq 'background-mode params))) - (bg-color (cond ((eq (cdr (assq 'display-type params)) 'mono) - (if light-bg "black" "white")) - ((eq (cdr (assq 'display-type params)) 'grayscale) - (if light-bg "black" "white")) - (light-bg ; Light color background. - "hotpink") - (t ; Dark color background. - "hotpink")))) - (set-face-background 'makefile-space-face bg-color)))) - -;;; make-mode.el ends here diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el deleted file mode 100644 index 12c6befae9d..00000000000 --- a/lisp/progmodes/modula2.el +++ /dev/null @@ -1,454 +0,0 @@ -;;; modula2.el --- Modula-2 editing support package - -;; Author: Michael Schmidt <michael@pbinfo.UUCP> -;; Tom Perrine <Perrin@LOGICON.ARPA> -;; Keywords: languages - -;; The authors distributed this without a copyright notice -;; back in 1988, so it is in the public domain. The original included -;; the following credit: - -;; Author Mick Jordan -;; amended Peter Robinson - -;;; Commentary: - -;; A major mode for editing Modula-2 code. It provides convenient abbrevs -;; for Modula-2 keywords, knows about the standard layout rules, and supports -;; a native compile command. - -;;; Code: - -;;; Added by Tom Perrine (TEP) -(defvar m2-mode-syntax-table nil - "Syntax table in use in Modula-2 buffers.") - -(defvar m2-compile-command "m2c" - "Command to compile Modula-2 programs") - -(defvar m2-link-command "m2l" - "Command to link Modula-2 programs") - -(defvar m2-link-name nil - "Name of the executable.") - - -(if m2-mode-syntax-table - () - (let ((table (make-syntax-table))) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?\( ". 1" table) - (modify-syntax-entry ?\) ". 4" table) - (modify-syntax-entry ?* ". 23" table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?\' "\"" table) - (setq m2-mode-syntax-table table))) - -;;; Added by TEP -(defvar m2-mode-map nil - "Keymap used in Modula-2 mode.") - -(if m2-mode-map () - (let ((map (make-sparse-keymap))) - (define-key map "\^i" 'm2-tab) - (define-key map "\C-cb" 'm2-begin) - (define-key map "\C-cc" 'm2-case) - (define-key map "\C-cd" 'm2-definition) - (define-key map "\C-ce" 'm2-else) - (define-key map "\C-cf" 'm2-for) - (define-key map "\C-ch" 'm2-header) - (define-key map "\C-ci" 'm2-if) - (define-key map "\C-cm" 'm2-module) - (define-key map "\C-cl" 'm2-loop) - (define-key map "\C-co" 'm2-or) - (define-key map "\C-cp" 'm2-procedure) - (define-key map "\C-c\C-w" 'm2-with) - (define-key map "\C-cr" 'm2-record) - (define-key map "\C-cs" 'm2-stdio) - (define-key map "\C-ct" 'm2-type) - (define-key map "\C-cu" 'm2-until) - (define-key map "\C-cv" 'm2-var) - (define-key map "\C-cw" 'm2-while) - (define-key map "\C-cx" 'm2-export) - (define-key map "\C-cy" 'm2-import) - (define-key map "\C-c{" 'm2-begin-comment) - (define-key map "\C-c}" 'm2-end-comment) - (define-key map "\C-j" 'm2-newline) - (define-key map "\C-c\C-z" 'suspend-emacs) - (define-key map "\C-c\C-v" 'm2-visit) - (define-key map "\C-c\C-t" 'm2-toggle) - (define-key map "\C-c\C-l" 'm2-link) - (define-key map "\C-c\C-c" 'm2-compile) - (setq m2-mode-map map))) - -(defvar m2-indent 5 "*This variable gives the indentation in Modula-2-Mode") - -;;;###autoload -(defun modula-2-mode () - "This is a mode intended to support program development in Modula-2. -All control constructs of Modula-2 can be reached by typing C-c -followed by the first character of the construct. -\\<m2-mode-map> - \\[m2-begin] begin \\[m2-case] case - \\[m2-definition] definition \\[m2-else] else - \\[m2-for] for \\[m2-header] header - \\[m2-if] if \\[m2-module] module - \\[m2-loop] loop \\[m2-or] or - \\[m2-procedure] procedure Control-c Control-w with - \\[m2-record] record \\[m2-stdio] stdio - \\[m2-type] type \\[m2-until] until - \\[m2-var] var \\[m2-while] while - \\[m2-export] export \\[m2-import] import - \\[m2-begin-comment] begin-comment \\[m2-end-comment] end-comment - \\[suspend-emacs] suspend Emacs \\[m2-toggle] toggle - \\[m2-compile] compile \\[m2-next-error] next-error - \\[m2-link] link - - `m2-indent' controls the number of spaces for each indentation. - `m2-compile-command' holds the command to compile a Modula-2 program. - `m2-link-command' holds the command to link a Modula-2 program." - (interactive) - (kill-all-local-variables) - (use-local-map m2-mode-map) - (setq major-mode 'modula-2-mode) - (setq mode-name "Modula-2") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'end-comment-column) - (setq end-comment-column 75) - (set-syntax-table m2-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) -; (make-local-variable 'indent-line-function) -; (setq indent-line-function 'c-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "(* ") - (make-local-variable 'comment-end) - (setq comment-end " *)") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "/\\*+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (run-hooks 'm2-mode-hook)) - -(defun m2-newline () - "Insert a newline and indent following line like previous line." - (interactive) - (let ((hpos (current-indentation))) - (newline) - (indent-to hpos))) - -(defun m2-tab () - "Indent to next tab stop." - (interactive) - (indent-to (* (1+ (/ (current-indentation) m2-indent)) m2-indent))) - -(defun m2-begin () - "Insert a BEGIN keyword and indent for the next line." - (interactive) - (insert "BEGIN") - (m2-newline) - (m2-tab)) - -(defun m2-case () - "Build skeleton CASE statement, prompting for the <expression>." - (interactive) - (let ((name (read-string "Case-Expression: "))) - (insert "CASE " name " OF") - (m2-newline) - (m2-newline) - (insert "END (* case " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-definition () - "Build skeleton DEFINITION MODULE, prompting for the <module name>." - (interactive) - (insert "DEFINITION MODULE ") - (let ((name (read-string "Name: "))) - (insert name ";\n\n\n\nEND " name ".\n")) - (previous-line 3)) - -(defun m2-else () - "Insert ELSE keyword and indent for next line." - (interactive) - (m2-newline) - (backward-delete-char-untabify m2-indent ()) - (insert "ELSE") - (m2-newline) - (m2-tab)) - -(defun m2-for () - "Build skeleton FOR loop statement, prompting for the loop parameters." - (interactive) - (insert "FOR ") - (let ((name (read-string "Loop Initialiser: ")) limit by) - (insert name " TO ") - (setq limit (read-string "Limit: ")) - (insert limit) - (setq by (read-string "Step: ")) - (if (not (string-equal by "")) - (insert " BY " by)) - (insert " DO") - (m2-newline) - (m2-newline) - (insert "END (* for " name " to " limit " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-header () - "Insert a comment block containing the module title, author, etc." - (interactive) - (insert "(*\n Title: \t") - (insert (read-string "Title: ")) - (insert "\n Created:\t") - (insert (current-time-string)) - (insert "\n Author: \t") - (insert (user-full-name)) - (insert (concat "\n\t\t<" (user-login-name) "@" (system-name) ">\n")) - (insert "*)\n\n")) - -(defun m2-if () - "Insert skeleton IF statement, prompting for <boolean-expression>." - (interactive) - (insert "IF ") - (let ((thecondition (read-string "<boolean-expression>: "))) - (insert thecondition " THEN") - (m2-newline) - (m2-newline) - (insert "END (* if " thecondition " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-loop () - "Build skeleton LOOP (with END)." - (interactive) - (insert "LOOP") - (m2-newline) - (m2-newline) - (insert "END (* loop *);") - (end-of-line 0) - (m2-tab)) - -(defun m2-module () - "Build skeleton IMPLEMENTATION MODULE, prompting for <module-name>." - (interactive) - (insert "IMPLEMENTATION MODULE ") - (let ((name (read-string "Name: "))) - (insert name ";\n\n\n\nEND " name ".\n") - (previous-line 3) - (m2-header) - (m2-type) - (newline) - (m2-var) - (newline) - (m2-begin) - (m2-begin-comment) - (insert " Module " name " Initialisation Code ")) - (m2-end-comment) - (newline) - (m2-tab)) - -(defun m2-or () - (interactive) - (m2-newline) - (backward-delete-char-untabify m2-indent) - (insert "|") - (m2-newline) - (m2-tab)) - -(defun m2-procedure () - (interactive) - (insert "PROCEDURE ") - (let ((name (read-string "Name: " )) - args) - (insert name " (") - (insert (read-string "Arguments: ") ")") - (setq args (read-string "Result Type: ")) - (if (not (string-equal args "")) - (insert " : " args)) - (insert ";") - (m2-newline) - (insert "BEGIN") - (m2-newline) - (m2-newline) - (insert "END ") - (insert name) - (insert ";") - (end-of-line 0) - (m2-tab))) - -(defun m2-with () - (interactive) - (insert "WITH ") - (let ((name (read-string "Record-Type: "))) - (insert name) - (insert " DO") - (m2-newline) - (m2-newline) - (insert "END (* with " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-record () - (interactive) - (insert "RECORD") - (m2-newline) - (m2-newline) - (insert "END (* record *);") - (end-of-line 0) - (m2-tab)) - -(defun m2-stdio () - (interactive) - (insert " -FROM TextIO IMPORT - WriteCHAR, ReadCHAR, WriteINTEGER, ReadINTEGER, - WriteCARDINAL, ReadCARDINAL, WriteBOOLEAN, ReadBOOLEAN, - WriteREAL, ReadREAL, WriteBITSET, ReadBITSET, - WriteBasedCARDINAL, ReadBasedCARDINAL, WriteChars, ReadChars, - WriteString, ReadString, WhiteSpace, EndOfLine; - -FROM SysStreams IMPORT sysIn, sysOut, sysErr; - -")) - -(defun m2-type () - (interactive) - (insert "TYPE") - (m2-newline) - (m2-tab)) - -(defun m2-until () - (interactive) - (insert "REPEAT") - (m2-newline) - (m2-newline) - (insert "UNTIL ") - (insert (read-string "<boolean-expression>: ") ";") - (end-of-line 0) - (m2-tab)) - -(defun m2-var () - (interactive) - (m2-newline) - (insert "VAR") - (m2-newline) - (m2-tab)) - -(defun m2-while () - (interactive) - (insert "WHILE ") - (let ((name (read-string "<boolean-expression>: "))) - (insert name " DO" ) - (m2-newline) - (m2-newline) - (insert "END (* while " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-export () - (interactive) - (insert "EXPORT QUALIFIED ")) - -(defun m2-import () - (interactive) - (insert "FROM ") - (insert (read-string "Module: ")) - (insert " IMPORT ")) - -(defun m2-begin-comment () - (interactive) - (if (not (bolp)) - (indent-to comment-column 0)) - (insert "(* ")) - -(defun m2-end-comment () - (interactive) - (if (not (bolp)) - (indent-to end-comment-column)) - (insert "*)")) - -(defun m2-compile () - (interactive) - (setq modulename (buffer-name)) - (compile (concat m2-compile-command " " modulename))) - -(defun m2-link () - (interactive) - (setq modulename (buffer-name)) - (if m2-link-name - (compile (concat m2-link-command " " m2-link-name)) - (compile (concat m2-link-command " " - (setq m2-link-name (read-string "Name of executable: " - modulename)))))) - -(defun m2-execute-monitor-command (command) - (let* ((shell shell-file-name) - (csh (equal (file-name-nondirectory shell) "csh"))) - (call-process shell nil t t "-cf" (concat "exec " command)))) - -(defun m2-visit () - (interactive) - (let ((deffile nil) - (modfile nil) - modulename) - (save-excursion - (setq modulename - (read-string "Module name: ")) - (switch-to-buffer "*Command Execution*") - (m2-execute-monitor-command (concat "m2whereis " modulename)) - (goto-char (point-min)) - (condition-case () - (progn (re-search-forward "\\(.*\\.def\\) *$") - (setq deffile (buffer-substring (match-beginning 1) - (match-end 1)))) - (search-failed ())) - (condition-case () - (progn (re-search-forward "\\(.*\\.mod\\) *$") - (setq modfile (buffer-substring (match-beginning 1) - (match-end 1)))) - (search-failed ())) - (if (not (or deffile modfile)) - (error "I can find neither definition nor implementation of %s" - modulename))) - (cond (deffile - (find-file deffile) - (if modfile - (save-excursion - (find-file modfile)))) - (modfile - (find-file modfile))))) - -(defun m2-toggle () - "Toggle between .mod and .def files for the module." - (interactive) - (cond ((string-equal (substring (buffer-name) -4) ".def") - (find-file-other-window - (concat (substring (buffer-name) 0 -4) ".mod"))) - ((string-equal (substring (buffer-name) -4) ".mod") - (find-file-other-window - (concat (substring (buffer-name) 0 -4) ".def"))) - ((string-equal (substring (buffer-name) -3) ".mi") - (find-file-other-window - (concat (substring (buffer-name) 0 -3) ".md"))) - ((string-equal (substring (buffer-name) -3) ".md") - (find-file-other-window - (concat (substring (buffer-name) 0 -3) ".mi"))))) - -;;; modula2.el ends here diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el deleted file mode 100644 index 1055e692689..00000000000 --- a/lisp/progmodes/pascal.el +++ /dev/null @@ -1,1560 +0,0 @@ -;;; pascal.el --- major mode for editing pascal source in Emacs - -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Espen Skoglund (espensk@stud.cs.uit.no) -;; Keywords: languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; USAGE -;; ===== - -;; Emacs should enter Pascal mode when you find a Pascal source file. -;; When you have entered Pascal mode, you may get more info by pressing -;; C-h m. You may also get online help describing various functions by: -;; C-h f <Name of function you want described> - -;; If you want to customize Pascal mode to fit you better, you may add -;; these lines (the values of the variables presented here are the defaults): -;; -;; ;; User customization for Pascal mode -;; (setq pascal-indent-level 3 -;; pascal-case-indent 2 -;; pascal-auto-newline nil -;; pascal-tab-always-indent t -;; pascal-auto-endcomments t -;; pascal-auto-lineup '(all) -;; pascal-toggle-completions nil -;; pascal-type-keywords '("array" "file" "packed" "char" -;; "integer" "real" "string" "record") -;; pascal-start-keywords '("begin" "end" "function" "procedure" -;; "repeat" "until" "while" "read" "readln" -;; "reset" "rewrite" "write" "writeln") -;; pascal-separator-keywords '("downto" "else" "mod" "div" "then")) - -;; KNOWN BUGS / BUGREPORTS -;; ======================= -;; As far as I know, there are no bugs in the current version of this -;; package. This may not be true however, since I never use this mode -;; myself and therefore would never notice them anyway. If you do -;; find any bugs, you may submit them to: espensk@stud.cs.uit.no -;; as well as to bug-gnu-emacs@prep.ai.mit.edu. - -;;; Code: - -(defvar pascal-mode-abbrev-table nil - "Abbrev table in use in Pascal-mode buffers.") -(define-abbrev-table 'pascal-mode-abbrev-table ()) - -(defvar pascal-mode-map () - "Keymap used in Pascal mode.") -(if pascal-mode-map - () - (setq pascal-mode-map (make-sparse-keymap)) - (define-key pascal-mode-map ";" 'electric-pascal-semi-or-dot) - (define-key pascal-mode-map "." 'electric-pascal-semi-or-dot) - (define-key pascal-mode-map ":" 'electric-pascal-colon) - (define-key pascal-mode-map "=" 'electric-pascal-equal) - (define-key pascal-mode-map "#" 'electric-pascal-hash) - (define-key pascal-mode-map "\r" 'electric-pascal-terminate-line) - (define-key pascal-mode-map "\t" 'electric-pascal-tab) - (define-key pascal-mode-map "\M-\t" 'pascal-complete-word) - (define-key pascal-mode-map "\M-?" 'pascal-show-completions) - (define-key pascal-mode-map "\177" 'backward-delete-char-untabify) - (define-key pascal-mode-map "\M-\C-h" 'pascal-mark-defun) - (define-key pascal-mode-map "\C-c\C-b" 'pascal-insert-block) - (define-key pascal-mode-map "\M-*" 'pascal-star-comment) - (define-key pascal-mode-map "\C-c\C-c" 'pascal-comment-area) - (define-key pascal-mode-map "\C-c\C-u" 'pascal-uncomment-area) - (define-key pascal-mode-map "\M-\C-a" 'pascal-beg-of-defun) - (define-key pascal-mode-map "\M-\C-e" 'pascal-end-of-defun) - (define-key pascal-mode-map "\C-c\C-d" 'pascal-goto-defun) - (define-key pascal-mode-map "\C-c\C-o" 'pascal-outline) -;;; A command to change the whole buffer won't be used terribly -;;; often, so no need for a key binding. -; (define-key pascal-mode-map "\C-cd" 'pascal-downcase-keywords) -; (define-key pascal-mode-map "\C-cu" 'pascal-upcase-keywords) -; (define-key pascal-mode-map "\C-cc" 'pascal-capitalize-keywords) - ) - -(defvar pascal-imenu-generic-expression - '("^[ \t]*\\(function\\|procedure\\)[ \t\n]+\\([a-zA-Z0-9_.:]+\\)" . (2)) - "Imenu expression for Pascal-mode. See `imenu-generic-expression'.") - -(defvar pascal-keywords - '("and" "array" "begin" "case" "const" "div" "do" "downto" "else" "end" - "file" "for" "function" "goto" "if" "in" "label" "mod" "nil" "not" "of" - "or" "packed" "procedure" "program" "record" "repeat" "set" "then" "to" - "type" "until" "var" "while" "with" - ;; The following are not standard in pascal, but widely used. - "get" "put" "input" "output" "read" "readln" "reset" "rewrite" "write" - "writeln")) - -;;; -;;; Regular expressions used to calculate indent, etc. -;;; -(defconst pascal-symbol-re "\\<[a-zA-Z_][a-zA-Z_0-9.]*\\>") -(defconst pascal-beg-block-re "\\<\\(begin\\|case\\|record\\|repeat\\)\\>") -(defconst pascal-end-block-re "\\<\\(end\\|until\\)\\>") -(defconst pascal-declaration-re "\\<\\(const\\|label\\|type\\|var\\)\\>") -(defconst pascal-defun-re "\\<\\(function\\|procedure\\|program\\)\\>") -(defconst pascal-sub-block-re "\\<\\(if\\|else\\|for\\|while\\|with\\)\\>") -(defconst pascal-noindent-re "\\<\\(begin\\|end\\|until\\|else\\)\\>") -(defconst pascal-nosemi-re "\\<\\(begin\\|repeat\\|then\\|do\\|else\\)\\>") -(defconst pascal-autoindent-lines-re - "\\<\\(label\\|var\\|type\\|const\\|until\\|end\\|begin\\|repeat\\|else\\)\\>") - -;;; Strings used to mark beginning and end of excluded text -(defconst pascal-exclude-str-start "{-----\\/----- EXCLUDED -----\\/-----") -(defconst pascal-exclude-str-end " -----/\\----- EXCLUDED -----/\\-----}") - -(defvar pascal-mode-syntax-table nil - "Syntax table in use in Pascal-mode buffers.") - -(if pascal-mode-syntax-table - () - (setq pascal-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "." pascal-mode-syntax-table) - (modify-syntax-entry ?( "()1" pascal-mode-syntax-table) - (modify-syntax-entry ?) ")(4" pascal-mode-syntax-table) - (modify-syntax-entry ?* ". 23" pascal-mode-syntax-table) - (modify-syntax-entry ?{ "<" pascal-mode-syntax-table) - (modify-syntax-entry ?} ">" pascal-mode-syntax-table) - (modify-syntax-entry ?+ "." pascal-mode-syntax-table) - (modify-syntax-entry ?- "." pascal-mode-syntax-table) - (modify-syntax-entry ?= "." pascal-mode-syntax-table) - (modify-syntax-entry ?% "." pascal-mode-syntax-table) - (modify-syntax-entry ?< "." pascal-mode-syntax-table) - (modify-syntax-entry ?> "." pascal-mode-syntax-table) - (modify-syntax-entry ?& "." pascal-mode-syntax-table) - (modify-syntax-entry ?| "." pascal-mode-syntax-table) - (modify-syntax-entry ?_ "w" pascal-mode-syntax-table) - (modify-syntax-entry ?\' "\"" pascal-mode-syntax-table)) - -(defvar pascal-font-lock-keywords - (list - '("^[ \t]*\\(function\\|pro\\(cedure\\|gram\\)\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) -; ("type" "const" "real" "integer" "char" "boolean" "var" -; "record" "array" "file") - (cons (concat "\\<\\(array\\|boolean\\|c\\(har\\|onst\\)\\|file\\|" - "integer\\|re\\(al\\|cord\\)\\|type\\|var\\)\\>") - 'font-lock-type-face) - '("\\<\\(label\\|external\\|forward\\)\\>" . font-lock-reference-face) - '("\\<\\([0-9]+\\)[ \t]*:" 1 font-lock-reference-face) -; ("of" "to" "for" "if" "then" "else" "case" "while" -; "do" "until" "and" "or" "not" "in" "with" "repeat" "begin" "end") - (concat "\\<\\(" - "and\\|begin\\|case\\|do\\|e\\(lse\\|nd\\)\\|for\\|i[fn]\\|" - "not\\|o[fr]\\|repeat\\|t\\(hen\\|o\\)\\|until\\|w\\(hile\\|ith\\)" - "\\)\\>") - '("\\<\\(goto\\)\\>[ \t]*\\([0-9]+\\)?" - (1 font-lock-keyword-face) (2 font-lock-reference-face nil t))) - "Additional expressions to highlight in Pascal mode.") - -(defvar pascal-indent-level 3 - "*Indentation of Pascal statements with respect to containing block.") - -(defvar pascal-case-indent 2 - "*Indentation for case statements.") - -(defvar pascal-auto-newline nil - "*Non-nil means automatically newline after semicolons and the punctuation -mark after an end.") - -(defvar pascal-tab-always-indent t - "*Non-nil means TAB in Pascal mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used.") - -(defvar pascal-auto-endcomments t - "*Non-nil means a comment { ... } is set after the ends which ends cases and -functions. The name of the function or case will be set between the braces.") - -(defvar pascal-auto-lineup '(all) - "*List of contexts where auto lineup of :'s or ='s should be done. -Elements can be of type: 'paramlist', 'declaration' or 'case', which will -do auto lineup in parameterlist, declarations or case-statements -respectively. The word 'all' will do all lineups. '(case paramlist) for -instance will do lineup in case-statements and parameterlist, while '(all) -will do all lineups.") - -(defvar pascal-toggle-completions nil - "*Non-nil means \\<pascal-mode-map>\\[pascal-complete-word] should try all possible completions one by one. -Repeated use of \\[pascal-complete-word] will show you all of them. -Normally, when there is more than one possible completion, -it displays a list of all possible completions.") - -(defvar pascal-type-keywords - '("array" "file" "packed" "char" "integer" "real" "string" "record") - "*Keywords for types used when completing a word in a declaration or parmlist. -\(eg. integer, real, char.) The types defined within the Pascal program -will be completed runtime, and should not be added to this list.") - -(defvar pascal-start-keywords - '("begin" "end" "function" "procedure" "repeat" "until" "while" - "read" "readln" "reset" "rewrite" "write" "writeln") - "*Keywords to complete when standing at the first word of a statement. -\(eg. begin, repeat, until, readln.) -The procedures and variables defined within the Pascal program -will be completed runtime and should not be added to this list.") - -(defvar pascal-separator-keywords - '("downto" "else" "mod" "div" "then") - "*Keywords to complete when NOT standing at the first word of a statement. -\(eg. downto, else, mod, then.) -Variables and function names defined within the -Pascal program are completed runtime and should not be added to this list.") - -;;; -;;; Macros -;;; - -(defsubst pascal-get-beg-of-line (&optional arg) - (save-excursion - (beginning-of-line arg) - (point))) - -(defsubst pascal-get-end-of-line (&optional arg) - (save-excursion - (end-of-line arg) - (point))) - -(defun pascal-declaration-end () - (let ((nest 1)) - (while (and (> nest 0) - (re-search-forward - "[:=]\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)" - (save-excursion (end-of-line 2) (point)) t)) - (cond ((match-beginning 1) (setq nest (1+ nest))) - ((match-beginning 2) (setq nest (1- nest))) - ((looking-at "[^(\n]+)") (setq nest 0)))))) - - -(defun pascal-declaration-beg () - (let ((nest 1)) - (while (and (> nest 0) - (re-search-backward "[:=]\\|\\<\\(type\\|var\\|label\\|const\\)\\>\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)" (pascal-get-beg-of-line 0) t)) - (cond ((match-beginning 1) (setq nest 0)) - ((match-beginning 2) (setq nest (1- nest))) - ((match-beginning 3) (setq nest (1+ nest))))) - (= nest 0))) - - -(defsubst pascal-within-string () - (save-excursion - (nth 3 (parse-partial-sexp (pascal-get-beg-of-line) (point))))) - - -;;;###autoload -(defun pascal-mode () - "Major mode for editing Pascal code. \\<pascal-mode-map> -TAB indents for Pascal code. Delete converts tabs to spaces as it moves back. - -\\[pascal-complete-word] completes the word around current point with respect \ -to position in code -\\[pascal-show-completions] shows all possible completions at this point. - -Other useful functions are: - -\\[pascal-mark-defun]\t- Mark function. -\\[pascal-insert-block]\t- insert begin ... end; -\\[pascal-star-comment]\t- insert (* ... *) -\\[pascal-comment-area]\t- Put marked area in a comment, fixing nested comments. -\\[pascal-uncomment-area]\t- Uncomment an area commented with \ -\\[pascal-comment-area]. -\\[pascal-beg-of-defun]\t- Move to beginning of current function. -\\[pascal-end-of-defun]\t- Move to end of current function. -\\[pascal-goto-defun]\t- Goto function prompted for in the minibuffer. -\\[pascal-outline]\t- Enter pascal-outline-mode (see also pascal-outline). - -Variables controlling indentation/edit style: - - pascal-indent-level (default 3) - Indentation of Pascal statements with respect to containing block. - pascal-case-indent (default 2) - Indentation for case statements. - pascal-auto-newline (default nil) - Non-nil means automatically newline after semicolons and the punctuation - mark after an end. - pascal-tab-always-indent (default t) - Non-nil means TAB in Pascal mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - pascal-auto-endcomments (default t) - Non-nil means a comment { ... } is set after the ends which ends cases and - functions. The name of the function or case will be set between the braces. - pascal-auto-lineup (default t) - List of contexts where auto lineup of :'s or ='s hould be done. - -See also the user variables pascal-type-keywords, pascal-start-keywords and -pascal-separator-keywords. - -Turning on Pascal mode calls the value of the variable pascal-mode-hook with -no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map pascal-mode-map) - (setq major-mode 'pascal-mode) - (setq mode-name "Pascal") - (setq local-abbrev-table pascal-mode-abbrev-table) - (set-syntax-table pascal-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'pascal-indent-line) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'pascal-indent-comment) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'case-fold-search) - (setq case-fold-search t) - (make-local-variable 'comment-start) - (setq comment-start "{") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+ *\\|{ *") - (make-local-variable 'comment-end) - (setq comment-end "}") - ;; Font lock support - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(pascal-font-lock-keywords nil t)) - ;; Imenu support - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression pascal-imenu-generic-expression) - (run-hooks 'pascal-mode-hook)) - - - -;;; -;;; Electric functions -;;; -(defun electric-pascal-terminate-line () - "Terminate line and indent next line." - (interactive) - ;; First, check if current line should be indented - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (if (looking-at pascal-autoindent-lines-re) - (pascal-indent-line))) - (delete-horizontal-space) ; Removes trailing whitespaces - (newline) - ;; Indent next line - (pascal-indent-line) - ;; Maybe we should set some endcomments - (if pascal-auto-endcomments - (pascal-set-auto-comments)) - ;; Check if we shall indent inside comment - (let ((setstar nil)) - (save-excursion - (forward-line -1) - (skip-chars-forward " \t") - (cond ((looking-at "\\*[ \t]+)") - ;; Delete region between `*' and `)' if there is only whitespaces. - (forward-char 1) - (delete-horizontal-space)) - ((and (looking-at "(\\*\\|\\*[^)]") - (not (save-excursion - (search-forward "*)" (pascal-get-end-of-line) t)))) - (setq setstar t)))) - ;; If last line was a star comment line then this one shall be too. - (if (null setstar) - (pascal-indent-line) - (insert "* ")))) - - -(defun electric-pascal-semi-or-dot () - "Insert `;' or `.' character and reindent the line." - (interactive) - (insert last-command-char) - (save-excursion - (beginning-of-line) - (pascal-indent-line)) - (if pascal-auto-newline - (electric-pascal-terminate-line))) - -(defun electric-pascal-colon () - "Insert `:' and do all indentions except line indent on this line." - (interactive) - (insert last-command-char) - ;; Do nothing if within string. - (if (pascal-within-string) - () - (save-excursion - (beginning-of-line) - (pascal-indent-line)) - (let ((pascal-tab-always-indent nil)) - (pascal-indent-command)))) - -(defun electric-pascal-equal () - "Insert `=', and do indention if within type declaration." - (interactive) - (insert last-command-char) - (if (eq (car (pascal-calculate-indent)) 'declaration) - (let ((pascal-tab-always-indent nil)) - (pascal-indent-command)))) - -(defun electric-pascal-hash () - "Insert `#', and indent to column 0 if this is a CPP directive." - (interactive) - (insert last-command-char) - (if (save-excursion (beginning-of-line) (looking-at "^[ \t]*#")) - (save-excursion (beginning-of-line) - (delete-horizontal-space)))) - -(defun electric-pascal-tab () - "Function called when TAB is pressed in Pascal mode." - (interactive) - ;; Do nothing if within a string or in a CPP directive. - (if (or (pascal-within-string) - (and (not (bolp)) - (save-excursion (beginning-of-line) (eq (following-char) ?#)))) - (insert "\t") - ;; If pascal-tab-always-indent, indent the beginning of the line. - (if pascal-tab-always-indent - (save-excursion - (beginning-of-line) - (pascal-indent-line)) - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - (pascal-indent-line) - (insert "\t"))) - (pascal-indent-command))) - - - -;;; -;;; Interactive functions -;;; -(defun pascal-insert-block () - "Insert Pascal begin ... end; block in the code with right indentation." - (interactive) - (pascal-indent-line) - (insert "begin") - (electric-pascal-terminate-line) - (save-excursion - (electric-pascal-terminate-line) - (insert "end;") - (beginning-of-line) - (pascal-indent-line))) - -(defun pascal-star-comment () - "Insert Pascal star comment at point." - (interactive) - (pascal-indent-line) - (insert "(*") - (electric-pascal-terminate-line) - (save-excursion - (electric-pascal-terminate-line) - (delete-horizontal-space) - (insert ")")) - (insert " ")) - -(defun pascal-mark-defun () - "Mark the current pascal function (or procedure). -This puts the mark at the end, and point at the beginning." - (interactive) - (push-mark (point)) - (pascal-end-of-defun) - (push-mark (point)) - (pascal-beg-of-defun) - (if (fboundp 'zmacs-activate-region) - (zmacs-activate-region))) - -(defun pascal-comment-area (start end) - "Put the region into a Pascal comment. -The comments that are in this area are \"deformed\": -`*)' becomes `!(*' and `}' becomes `!{'. -These deformed comments are returned to normal if you use -\\[pascal-uncomment-area] to undo the commenting. - -The commented area starts with `pascal-exclude-str-start', and ends with -`pascal-include-str-end'. But if you change these variables, -\\[pascal-uncomment-area] won't recognize the comments." - (interactive "r") - (save-excursion - ;; Insert start and endcomments - (goto-char end) - (if (and (save-excursion (skip-chars-forward " \t") (eolp)) - (not (save-excursion (skip-chars-backward " \t") (bolp)))) - (forward-line 1) - (beginning-of-line)) - (insert pascal-exclude-str-end) - (setq end (point)) - (newline) - (goto-char start) - (beginning-of-line) - (insert pascal-exclude-str-start) - (newline) - ;; Replace end-comments within commented area - (goto-char end) - (save-excursion - (while (re-search-backward "\\*)" start t) - (replace-match "!(*" t t))) - (save-excursion - (while (re-search-backward "}" start t) - (replace-match "!{" t t))))) - -(defun pascal-uncomment-area () - "Uncomment a commented area; change deformed comments back to normal. -This command does nothing if the pointer is not in a commented -area. See also `pascal-comment-area'." - (interactive) - (save-excursion - (let ((start (point)) - (end (point))) - ;; Find the boundaries of the comment - (save-excursion - (setq start (progn (search-backward pascal-exclude-str-start nil t) - (point))) - (setq end (progn (search-forward pascal-exclude-str-end nil t) - (point)))) - ;; Check if we're really inside a comment - (if (or (equal start (point)) (<= end (point))) - (message "Not standing within commented area.") - (progn - ;; Remove endcomment - (goto-char end) - (beginning-of-line) - (let ((pos (point))) - (end-of-line) - (delete-region pos (1+ (point)))) - ;; Change comments back to normal - (save-excursion - (while (re-search-backward "!{" start t) - (replace-match "}" t t))) - (save-excursion - (while (re-search-backward "!(\\*" start t) - (replace-match "*)" t t))) - ;; Remove startcomment - (goto-char start) - (beginning-of-line) - (let ((pos (point))) - (end-of-line) - (delete-region pos (1+ (point))))))))) - -(defun pascal-beg-of-defun () - "Move backward to the beginning of the current function or procedure." - (interactive) - (catch 'found - (if (not (looking-at (concat "\\s \\|\\s)\\|" pascal-defun-re))) - (forward-sexp 1)) - (let ((nest 0) (max -1) (func 0) - (reg (concat pascal-beg-block-re "\\|" - pascal-end-block-re "\\|" - pascal-defun-re))) - (while (re-search-backward reg nil 'move) - (cond ((let ((state (save-excursion - (parse-partial-sexp (point-min) (point))))) - (or (nth 3 state) (nth 4 state))) ; Inside string or comment - ()) - ((match-end 1) ; begin|case|record|repeat - (if (and (looking-at "\\<record\\>") (>= max 0)) - (setq func (1- func))) - (setq nest (1+ nest) - max (max nest max))) - ((match-end 2) ; end|until - (if (and (= nest max) (>= max 0)) - (setq func (1+ func))) - (setq nest (1- nest))) - ((match-end 3) ; function|procedure - (if (= 0 func) - (throw 'found t) - (setq func (1- func))))))) - nil)) - -(defun pascal-end-of-defun () - "Move forward to the end of the current function or procedure." - (interactive) - (if (looking-at "\\s ") - (forward-sexp 1)) - (if (not (looking-at pascal-defun-re)) - (pascal-beg-of-defun)) - (forward-char 1) - (let ((nest 0) (func 1) - (reg (concat pascal-beg-block-re "\\|" - pascal-end-block-re "\\|" - pascal-defun-re))) - (while (and (/= func 0) - (re-search-forward reg nil 'move)) - (cond ((let ((state (save-excursion - (parse-partial-sexp (point-min) (point))))) - (or (nth 3 state) (nth 4 state))) ; Inside string or comment - ()) - ((match-end 1) - (setq nest (1+ nest)) - (if (save-excursion - (goto-char (match-beginning 0)) - (looking-at "\\<record\\>")) - (setq func (1+ func)))) - ((match-end 2) - (setq nest (1- nest)) - (if (= nest 0) - (setq func (1- func)))) - ((match-end 3) - (setq func (1+ func)))))) - (forward-line 1)) - -(defun pascal-end-of-statement () - "Move forward to end of current statement." - (interactive) - (let ((parse-sexp-ignore-comments t) - (nest 0) pos - (regexp (concat "\\(" pascal-beg-block-re "\\)\\|\\(" - pascal-end-block-re "\\)"))) - (if (not (looking-at "[ \t\n]")) (forward-sexp -1)) - (or (looking-at pascal-beg-block-re) - ;; Skip to end of statement - (setq pos (catch 'found - (while t - (forward-sexp 1) - (cond ((looking-at "[ \t]*;") - (skip-chars-forward "^;") - (forward-char 1) - (throw 'found (point))) - ((save-excursion - (forward-sexp -1) - (looking-at pascal-beg-block-re)) - (goto-char (match-beginning 0)) - (throw 'found nil)) - ((eobp) - (throw 'found (point)))))))) - (if (not pos) - ;; Skip a whole block - (catch 'found - (while t - (re-search-forward regexp nil 'move) - (setq nest (if (match-end 1) - (1+ nest) - (1- nest))) - (cond ((eobp) - (throw 'found (point))) - ((= 0 nest) - (throw 'found (pascal-end-of-statement)))))) - pos))) - -(defun pascal-downcase-keywords () - "Downcase all Pascal keywords in the buffer." - (interactive) - (pascal-change-keywords 'downcase-word)) - -(defun pascal-upcase-keywords () - "Upcase all Pascal keywords in the buffer." - (interactive) - (pascal-change-keywords 'upcase-word)) - -(defun pascal-capitalize-keywords () - "Capitalize all Pascal keywords in the buffer." - (interactive) - (pascal-change-keywords 'capitalize-word)) - -;; Change the keywords according to argument. -(defun pascal-change-keywords (change-word) - (save-excursion - (let ((keyword-re (concat "\\<\\(" - (mapconcat 'identity pascal-keywords "\\|") - "\\)\\>"))) - (goto-char (point-min)) - (while (re-search-forward keyword-re nil t) - (funcall change-word -1))))) - - - -;;; -;;; Other functions -;;; -(defun pascal-set-auto-comments () - "Insert `{ case }' or `{ NAME }' on this line if appropriate. -Insert `{ case }' if there is an `end' on the line which -ends a case block. Insert `{ NAME }' if there is an `end' -on the line which ends a function or procedure named NAME." - (save-excursion - (forward-line -1) - (skip-chars-forward " \t") - (if (and (looking-at "\\<end;") - (not (save-excursion - (end-of-line) - (search-backward "{" (pascal-get-beg-of-line) t)))) - (let ((type (car (pascal-calculate-indent)))) - (if (eq type 'declaration) - () - (if (eq type 'case) - ;; This is a case block - (progn - (end-of-line) - (delete-horizontal-space) - (insert " { case }")) - (let ((nest 1)) - ;; Check if this is the end of a function - (save-excursion - (while (not (or (looking-at pascal-defun-re) (bobp))) - (backward-sexp 1) - (cond ((looking-at pascal-beg-block-re) - (setq nest (1- nest))) - ((looking-at pascal-end-block-re) - (setq nest (1+ nest))))) - (if (bobp) - (setq nest 1))) - (if (zerop nest) - (progn - (end-of-line) - (delete-horizontal-space) - (insert " { ") - (let (b e) - (save-excursion - (setq b (progn (pascal-beg-of-defun) - (skip-chars-forward "^ \t") - (skip-chars-forward " \t") - (point)) - e (progn (skip-chars-forward "a-zA-Z0-9_") - (point)))) - (insert-buffer-substring (current-buffer) b e)) - (insert " }")))))))))) - - - -;;; -;;; Indentation -;;; -(defconst pascal-indent-alist - '((block . (+ ind pascal-indent-level)) - (case . (+ ind pascal-case-indent)) - (caseblock . ind) (cpp . 0) - (declaration . (+ ind pascal-indent-level)) - (paramlist . (pascal-indent-paramlist t)) - (comment . (pascal-indent-comment t)) - (defun . ind) (contexp . ind) - (unknown . 0) (string . 0))) - -(defun pascal-indent-command () - "Indent for special part of code." - (let* ((indent-str (pascal-calculate-indent)) - (type (car indent-str)) - (ind (car (cdr indent-str)))) - (cond ((and (eq type 'paramlist) - (or (memq 'all pascal-auto-lineup) - (memq 'paramlist pascal-auto-lineup))) - (pascal-indent-paramlist) - (pascal-indent-paramlist)) - ((and (eq type 'declaration) - (or (memq 'all pascal-auto-lineup) - (memq 'declaration pascal-auto-lineup))) - (pascal-indent-declaration)) - ((and (eq type 'case) (not (looking-at "^[ \t]*$")) - (or (memq 'all pascal-auto-lineup) - (memq 'case pascal-auto-lineup))) - (pascal-indent-case))) - (if (looking-at "[ \t]+$") - (skip-chars-forward " \t")))) - -(defun pascal-indent-line () - "Indent current line as a Pascal statement." - (let* ((indent-str (pascal-calculate-indent)) - (type (car indent-str)) - (ind (car (cdr indent-str)))) - (if (looking-at "^[0-9a-zA-Z]+[ \t]*:[^=]") - (search-forward ":" nil t)) - (delete-horizontal-space) - ;; Some things should not be indented - (if (or (and (eq type 'declaration) (looking-at pascal-declaration-re)) - (eq type 'cpp) - (looking-at pascal-defun-re)) - () - ;; Other things should have no extra indent - (if (looking-at pascal-noindent-re) - (indent-to ind) - ;; But most lines are treated this way: - (indent-to (eval (cdr (assoc type pascal-indent-alist)))) - )))) - -(defun pascal-calculate-indent () - "Calculate the indent of the current Pascal line. -Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." - (save-excursion - (let* ((parse-sexp-ignore-comments t) - (oldpos (point)) - (state (save-excursion (parse-partial-sexp (point-min) (point)))) - (nest 0) (par 0) (complete (looking-at "[ \t]*end\\>")) - (elsed (looking-at "[ \t]*else\\>")) - (type (catch 'nesting - ;; Check if inside a string, comment or parenthesis - (cond ((nth 3 state) (throw 'nesting 'string)) - ((nth 4 state) (throw 'nesting 'comment)) - ((> (car state) 0) - (goto-char (scan-lists (point) -1 (car state))) - (setq par (1+ (current-column)))) - ((save-excursion (beginning-of-line) - (eq (following-char) ?#)) - (throw 'nesting 'cpp))) - ;; Loop until correct indent is found - (while t - (backward-sexp 1) - (cond (;--Escape from case statements - (and (looking-at "[A-Za-z0-9]+[ \t]*:[^=]") - (not complete) - (save-excursion (skip-chars-backward " \t") - (bolp)) - (= (save-excursion - (end-of-line) (backward-sexp) (point)) - (point)) - (> (save-excursion (goto-char oldpos) - (beginning-of-line) - (point)) - (point))) - (throw 'nesting 'caseblock)) - (;--Nest block outwards - (looking-at pascal-beg-block-re) - (if (= nest 0) - (cond ((looking-at "case\\>") - (throw 'nesting 'case)) - ((looking-at "record\\>") - (throw 'nesting 'declaration)) - (t (throw 'nesting 'block))) - (setq nest (1- nest)))) - (;--Nest block inwards - (looking-at pascal-end-block-re) - (if (and (looking-at "end\\s ") - elsed (not complete)) - (throw 'nesting 'block)) - (setq complete t - nest (1+ nest))) - (;--Defun (or parameter list) - (looking-at pascal-defun-re) - (if (= 0 par) - (throw 'nesting 'defun) - (setq par 0) - (let ((n 0)) - (while (re-search-forward - "\\(\\<record\\>\\)\\|\\<end\\>" - oldpos t) - (if (match-end 1) - (setq n (1+ n)) (setq n (1- n)))) - (if (> n 0) - (throw 'nesting 'declaration) - (throw 'nesting 'paramlist))))) - (;--Declaration part - (looking-at pascal-declaration-re) - (if (save-excursion - (goto-char oldpos) - (forward-line -1) - (looking-at "^[ \t]*$")) - (throw 'nesting 'unknown) - (throw 'nesting 'declaration))) - (;--If, else or while statement - (and (not complete) - (looking-at pascal-sub-block-re)) - (throw 'nesting 'block)) - (;--Found complete statement - (save-excursion (forward-sexp 1) - (= (following-char) ?\;)) - (setq complete t)) - (;--No known statements - (bobp) - (throw 'nesting 'unknown)) - ))))) - - ;; Return type of block and indent level. - (if (> par 0) ; Unclosed Parenthesis - (list 'contexp par) - (list type (pascal-indent-level)))))) - -(defun pascal-indent-level () - "Return the indent-level the current statement has. -Do not count labels, case-statements or records." - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*[0-9a-zA-Z]+[ \t]*:[^=]") - (search-forward ":" nil t) - (if (looking-at ".*=[ \t]*record\\>") - (search-forward "=" nil t))) - (skip-chars-forward " \t") - (current-column))) - -(defun pascal-indent-comment (&optional arg) - "Indent current line as comment. -If optional arg is non-nil, just return the -column number the line should be indented to." - (let* ((stcol (save-excursion - (re-search-backward "(\\*\\|{" nil t) - (1+ (current-column))))) - (if arg stcol - (delete-horizontal-space) - (indent-to stcol)))) - -(defun pascal-indent-case () - "Indent within case statements." - (let ((savepos (point-marker)) - (end (prog2 - (end-of-line) - (point-marker) - (re-search-backward "\\<case\\>" nil t))) - (beg (point)) oldpos - (ind 0)) - ;; Get right indent - (while (< (point) (marker-position end)) - (if (re-search-forward - "^[ \t]*[^ \t,:]+[ \t]*\\(,[ \t]*[^ \t,:]+[ \t]*\\)*:" - (marker-position end) 'move) - (forward-char -1)) - (if (< (point) (marker-position end)) - (progn - (delete-horizontal-space) - (if (> (current-column) ind) - (setq ind (current-column))) - (pascal-end-of-statement)))) - (goto-char beg) - (setq oldpos (marker-position end)) - ;; Indent all case statements - (while (< (point) (marker-position end)) - (if (re-search-forward - "^[ \t]*[^][ \t,\\.:]+[ \t]*\\(,[ \t]*[^ \t,:]+[ \t]*\\)*:" - (marker-position end) 'move) - (forward-char -1)) - (indent-to (1+ ind)) - (if (/= (following-char) ?:) - () - (forward-char 1) - (delete-horizontal-space) - (insert " ")) - (setq oldpos (point)) - (pascal-end-of-statement)) - (goto-char savepos))) - -(defun pascal-indent-paramlist (&optional arg) - "Indent current line in parameterlist. -If optional arg is non-nil, just return the -indent of the current line in parameterlist." - (save-excursion - (let* ((oldpos (point)) - (stpos (progn (goto-char (scan-lists (point) -1 1)) (point))) - (stcol (1+ (current-column))) - (edpos (progn (pascal-declaration-end) - (search-backward ")" (pascal-get-beg-of-line) t) - (point))) - (usevar (re-search-backward "\\<var\\>" stpos t))) - (if arg (progn - ;; If arg, just return indent - (goto-char oldpos) - (beginning-of-line) - (if (or (not usevar) (looking-at "[ \t]*var\\>")) - stcol (+ 4 stcol))) - (goto-char stpos) - (forward-char 1) - (delete-horizontal-space) - (if (and usevar (not (looking-at "var\\>"))) - (indent-to (+ 4 stcol))) - (pascal-indent-declaration nil stpos edpos))))) - -(defun pascal-indent-declaration (&optional arg start end) - "Indent current lines as declaration, lining up the `:'s or `='s." - (let ((pos (point-marker))) - (if (and (not (or arg start)) (not (pascal-declaration-beg))) - () - (let ((lineup (if (or (looking-at "\\<var\\>\\|\\<record\\>") arg start) - ":" "=")) - (stpos (if start start - (forward-word 2) (backward-word 1) (point))) - (edpos (set-marker (make-marker) - (if end end - (max (progn (pascal-declaration-end) - (point)) - pos)))) - ind) - - (goto-char stpos) - ;; Indent lines in record block - (if arg - (while (<= (point) (marker-position edpos)) - (beginning-of-line) - (delete-horizontal-space) - (if (looking-at "end\\>") - (indent-to arg) - (indent-to (+ arg pascal-indent-level))) - (forward-line 1))) - - ;; Do lineup - (setq ind (pascal-get-lineup-indent stpos edpos lineup)) - (goto-char stpos) - (while (and (<= (point) (marker-position edpos)) - (not (eobp))) - (if (search-forward lineup (pascal-get-end-of-line) 'move) - (forward-char -1)) - (delete-horizontal-space) - (indent-to ind) - (if (not (looking-at lineup)) - (forward-line 1) ; No more indent if there is no : or = - (forward-char 1) - (delete-horizontal-space) - (insert " ") - ;; Indent record block - (if (looking-at "record\\>") - (pascal-indent-declaration (current-column))) - (forward-line 1))))) - - ;; If arg - move point - (if arg (forward-line -1) - (goto-char (marker-position pos))))) - -; "Return the indent level that will line up several lines within the region -;from b to e nicely. The lineup string is str." -(defun pascal-get-lineup-indent (b e str) - (save-excursion - (let ((ind 0) - (reg (concat str "\\|\\(\\<record\\>\\)")) - nest) - (goto-char b) - ;; Get rightmost position - (while (< (point) e) - (setq nest 1) - (if (re-search-forward reg (min e (pascal-get-end-of-line 2)) 'move) - (progn - ;; Skip record blocks - (if (match-beginning 1) - (pascal-declaration-end) - (progn - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (if (> (current-column) ind) - (setq ind (current-column))) - (goto-char (match-end 0))))))) - ;; In case no lineup was found - (if (> ind 0) - (1+ ind) - ;; No lineup-string found - (goto-char b) - (end-of-line) - (skip-chars-backward " \t") - (1+ (current-column)))))) - - - -;;; -;;; Completion -;;; -(defvar pascal-str nil) -(defvar pascal-all nil) -(defvar pascal-pred nil) -(defvar pascal-buffer-to-use nil) -(defvar pascal-flag nil) - -(defun pascal-string-diff (str1 str2) - "Return index of first letter where STR1 and STR2 differs." - (catch 'done - (let ((diff 0)) - (while t - (if (or (> (1+ diff) (length str1)) - (> (1+ diff) (length str2))) - (throw 'done diff)) - (or (equal (aref str1 diff) (aref str2 diff)) - (throw 'done diff)) - (setq diff (1+ diff)))))) - -;; Calculate all possible completions for functions if argument is `function', -;; completions for procedures if argument is `procedure' or both functions and -;; procedures otherwise. - -(defun pascal-func-completion (type) - ;; Build regular expression for function/procedure names - (if (string= pascal-str "") - (setq pascal-str "[a-zA-Z_]")) - (let ((pascal-str (concat (cond - ((eq type 'procedure) "\\<\\(procedure\\)\\s +") - ((eq type 'function) "\\<\\(function\\)\\s +") - (t "\\<\\(function\\|procedure\\)\\s +")) - "\\<\\(" pascal-str "[a-zA-Z0-9_.]*\\)\\>")) - match) - - (if (not (looking-at "\\<\\(function\\|procedure\\)\\>")) - (re-search-backward "\\<\\(function\\|procedure\\)\\>" nil t)) - (forward-char 1) - - ;; Search through all reachable functions - (while (pascal-beg-of-defun) - (if (re-search-forward pascal-str (pascal-get-end-of-line) t) - (progn (setq match (buffer-substring (match-beginning 2) - (match-end 2))) - (if (or (null pascal-pred) - (funcall pascal-pred match)) - (setq pascal-all (cons match pascal-all))))) - (goto-char (match-beginning 0))))) - -(defun pascal-get-completion-decl () - ;; Macro for searching through current declaration (var, type or const) - ;; for matches of `str' and adding the occurrence tp `all' - (let ((end (save-excursion (pascal-declaration-end) - (point))) - match) - ;; Traverse lines - (while (< (point) end) - (if (re-search-forward "[:=]" (pascal-get-end-of-line) t) - ;; Traverse current line - (while (and (re-search-backward - (concat "\\((\\|\\<\\(var\\|type\\|const\\)\\>\\)\\|" - pascal-symbol-re) - (pascal-get-beg-of-line) t) - (not (match-end 1))) - (setq match (buffer-substring (match-beginning 0) (match-end 0))) - (if (string-match (concat "\\<" pascal-str) match) - (if (or (null pascal-pred) - (funcall pascal-pred match)) - (setq pascal-all (cons match pascal-all)))))) - (if (re-search-forward "\\<record\\>" (pascal-get-end-of-line) t) - (pascal-declaration-end) - (forward-line 1))))) - -(defun pascal-type-completion () - "Calculate all possible completions for types." - (let ((start (point)) - goon) - ;; Search for all reachable type declarations - (while (or (pascal-beg-of-defun) - (setq goon (not goon))) - (save-excursion - (if (and (< start (prog1 (save-excursion (pascal-end-of-defun) - (point)) - (forward-char 1))) - (re-search-forward - "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>" - start t) - (not (match-end 1))) - ;; Check current type declaration - (pascal-get-completion-decl)))))) - -(defun pascal-var-completion () - "Calculate all possible completions for variables (or constants)." - (let ((start (point)) - goon twice) - ;; Search for all reachable var declarations - (while (or (pascal-beg-of-defun) - (setq goon (not goon))) - (save-excursion - (if (> start (prog1 (save-excursion (pascal-end-of-defun) - (point)))) - () ; Declarations not reachable - (if (search-forward "(" (pascal-get-end-of-line) t) - ;; Check parameterlist - (pascal-get-completion-decl)) - (setq twice 2) - (while (>= (setq twice (1- twice)) 0) - (cond ((and (re-search-forward - (concat "\\<\\(var\\|const\\)\\>\\|" - "\\<\\(begin\\|function\\|procedure\\)\\>") - start t) - (not (match-end 2))) - ;; Check var/const declarations - (pascal-get-completion-decl)) - ((match-end 2) - (setq twice 0))))))))) - - -(defun pascal-keyword-completion (keyword-list) - "Give list of all possible completions of keywords in KEYWORD-LIST." - (mapcar '(lambda (s) - (if (string-match (concat "\\<" pascal-str) s) - (if (or (null pascal-pred) - (funcall pascal-pred s)) - (setq pascal-all (cons s pascal-all))))) - keyword-list)) - -;; Function passed to completing-read, try-completion or -;; all-completions to get completion on STR. If predicate is non-nil, -;; it must be a function to be called for every match to check if this -;; should really be a match. If flag is t, the function returns a list -;; of all possible completions. If it is nil it returns a string, the -;; longest possible completion, or t if STR is an exact match. If flag -;; is 'lambda, the function returns t if STR is an exact match, nil -;; otherwise. - -(defun pascal-completion (pascal-str pascal-pred pascal-flag) - (save-excursion - (let ((pascal-all nil)) - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use pascal-completions - (set-buffer pascal-buffer-to-use) - - ;; Determine what should be completed - (let ((state (car (pascal-calculate-indent)))) - (cond (;--Within a declaration or parameterlist - (or (eq state 'declaration) (eq state 'paramlist) - (and (eq state 'defun) - (save-excursion - (re-search-backward ")[ \t]*:" - (pascal-get-beg-of-line) t)))) - (if (or (eq state 'paramlist) (eq state 'defun)) - (pascal-beg-of-defun)) - (pascal-type-completion) - (pascal-keyword-completion pascal-type-keywords)) - (;--Starting a new statement - (and (not (eq state 'contexp)) - (save-excursion - (skip-chars-backward "a-zA-Z0-9_.") - (backward-sexp 1) - (or (looking-at pascal-nosemi-re) - (progn - (forward-sexp 1) - (looking-at "\\s *\\(;\\|:[^=]\\)"))))) - (save-excursion (pascal-var-completion)) - (pascal-func-completion 'procedure) - (pascal-keyword-completion pascal-start-keywords)) - (t;--Anywhere else - (save-excursion (pascal-var-completion)) - (pascal-func-completion 'function) - (pascal-keyword-completion pascal-separator-keywords)))) - - ;; Now we have built a list of all matches. Give response to caller - (pascal-completion-response)))) - -(defun pascal-completion-response () - (cond ((or (equal pascal-flag 'lambda) (null pascal-flag)) - ;; This was not called by all-completions - (if (null pascal-all) - ;; Return nil if there was no matching label - nil - ;; Get longest string common in the labels - (let* ((elm (cdr pascal-all)) - (match (car pascal-all)) - (min (length match)) - exact tmp) - (if (string= match pascal-str) - ;; Return t if first match was an exact match - (setq match t) - (while (not (null elm)) - ;; Find longest common string - (if (< (setq tmp (pascal-string-diff match (car elm))) min) - (progn - (setq min tmp) - (setq match (substring match 0 min)))) - ;; Terminate with match=t if this is an exact match - (if (string= (car elm) pascal-str) - (progn - (setq match t) - (setq elm nil)) - (setq elm (cdr elm))))) - ;; If this is a test just for exact match, return nil ot t - (if (and (equal pascal-flag 'lambda) (not (equal match 't))) - nil - match)))) - ;; If flag is t, this was called by all-completions. Return - ;; list of all possible completions - (pascal-flag - pascal-all))) - -(defvar pascal-last-word-numb 0) -(defvar pascal-last-word-shown nil) -(defvar pascal-last-completions nil) - -(defun pascal-complete-word () - "Complete word at current point. -\(See also `pascal-toggle-completions', `pascal-type-keywords', -`pascal-start-keywords' and `pascal-separator-keywords'.)" - (interactive) - (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) - (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) - (pascal-str (buffer-substring b e)) - ;; The following variable is used in pascal-completion - (pascal-buffer-to-use (current-buffer)) - (allcomp (if (and pascal-toggle-completions - (string= pascal-last-word-shown pascal-str)) - pascal-last-completions - (all-completions pascal-str 'pascal-completion))) - (match (if pascal-toggle-completions - "" (try-completion - pascal-str (mapcar '(lambda (elm) - (cons elm 0)) allcomp))))) - ;; Delete old string - (delete-region b e) - - ;; Toggle-completions inserts whole labels - (if pascal-toggle-completions - (progn - ;; Update entry number in list - (setq pascal-last-completions allcomp - pascal-last-word-numb - (if (>= pascal-last-word-numb (1- (length allcomp))) - 0 - (1+ pascal-last-word-numb))) - (setq pascal-last-word-shown (elt allcomp pascal-last-word-numb)) - ;; Display next match or same string if no match was found - (if (not (null allcomp)) - (insert "" pascal-last-word-shown) - (insert "" pascal-str) - (message "(No match)"))) - ;; The other form of completion does not necessarily do that. - - ;; Insert match if found, or the original string if no match - (if (or (null match) (equal match 't)) - (progn (insert "" pascal-str) - (message "(No match)")) - (insert "" match)) - ;; Give message about current status of completion - (cond ((equal match 't) - (if (not (null (cdr allcomp))) - (message "(Complete but not unique)") - (message "(Sole completion)"))) - ;; Display buffer if the current completion didn't help - ;; on completing the label. - ((and (not (null (cdr allcomp))) (= (length pascal-str) - (length match))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list allcomp)) - ;; Wait for a keypress. Then delete *Completion* window - (momentary-string-display "" (point)) - (delete-window (get-buffer-window (get-buffer "*Completions*"))) - ))))) - -(defun pascal-show-completions () - "Show all possible completions at current point." - (interactive) - (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) - (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) - (pascal-str (buffer-substring b e)) - ;; The following variable is used in pascal-completion - (pascal-buffer-to-use (current-buffer)) - (allcomp (if (and pascal-toggle-completions - (string= pascal-last-word-shown pascal-str)) - pascal-last-completions - (all-completions pascal-str 'pascal-completion)))) - ;; Show possible completions in a temporary buffer. - (with-output-to-temp-buffer "*Completions*" - (display-completion-list allcomp)) - ;; Wait for a keypress. Then delete *Completion* window - (momentary-string-display "" (point)) - (delete-window (get-buffer-window (get-buffer "*Completions*"))))) - - -(defun pascal-get-default-symbol () - "Return symbol around current point as a string." - (save-excursion - (buffer-substring (progn - (skip-chars-backward " \t") - (skip-chars-backward "a-zA-Z0-9_") - (point)) - (progn - (skip-chars-forward "a-zA-Z0-9_") - (point))))) - -(defun pascal-build-defun-re (str &optional arg) - "Return function/procedure starting with STR as regular expression. -With optional second arg non-nil, STR is the complete name of the instruction." - (if arg - (concat "^\\(function\\|procedure\\)[ \t]+\\(" str "\\)\\>") - (concat "^\\(function\\|procedure\\)[ \t]+\\(" str "[a-zA-Z0-9_]*\\)\\>"))) - -;; Function passed to completing-read, try-completion or -;; all-completions to get completion on any function name. If -;; predicate is non-nil, it must be a function to be called for every -;; match to check if this should really be a match. If flag is t, the -;; function returns a list of all possible completions. If it is nil -;; it returns a string, the longest possible completion, or t if STR -;; is an exact match. If flag is 'lambda, the function returns t if -;; STR is an exact match, nil otherwise. - -(defun pascal-comp-defun (pascal-str pascal-pred pascal-flag) - (save-excursion - (let ((pascal-all nil) - match) - - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use pascal-completions - (set-buffer pascal-buffer-to-use) - - (let ((pascal-str pascal-str)) - ;; Build regular expression for functions - (if (string= pascal-str "") - (setq pascal-str (pascal-build-defun-re "[a-zA-Z_]")) - (setq pascal-str (pascal-build-defun-re pascal-str))) - (goto-char (point-min)) - - ;; Build a list of all possible completions - (while (re-search-forward pascal-str nil t) - (setq match (buffer-substring (match-beginning 2) (match-end 2))) - (if (or (null pascal-pred) - (funcall pascal-pred match)) - (setq pascal-all (cons match pascal-all))))) - - ;; Now we have built a list of all matches. Give response to caller - (pascal-completion-response)))) - -(defun pascal-goto-defun () - "Move to specified Pascal function/procedure. -The default is a name found in the buffer around point." - (interactive) - (let* ((default (pascal-get-default-symbol)) - ;; The following variable is used in pascal-comp-function - (pascal-buffer-to-use (current-buffer)) - (default (if (pascal-comp-defun default nil 'lambda) - default "")) - (label (if (not (string= default "")) - ;; Do completion with default - (completing-read (concat "Label: (default " default ") ") - 'pascal-comp-defun nil t "") - ;; There is no default value. Complete without it - (completing-read "Label: " - 'pascal-comp-defun nil t "")))) - ;; If there was no response on prompt, use default value - (if (string= label "") - (setq label default)) - ;; Goto right place in buffer if label is not an empty string - (or (string= label "") - (progn - (goto-char (point-min)) - (re-search-forward (pascal-build-defun-re label t)) - (beginning-of-line))))) - - - -;;; -;;; Pascal-outline-mode -;;; -(defvar pascal-outline-map nil "Keymap used in Pascal Outline mode.") - -(if pascal-outline-map - nil - (if (boundp 'set-keymap-name) - (set-keymap-name pascal-outline-map 'pascal-outline-map)) - (if (not (boundp 'set-keymap-parent)) - (setq pascal-outline-map (copy-keymap pascal-mode-map)) - (setq pascal-outline-map (make-sparse-keymap)) - (set-keymap-parent pascal-outline-map pascal-mode-map)) - (define-key pascal-outline-map "\M-\C-a" 'pascal-outline-prev-defun) - (define-key pascal-outline-map "\M-\C-e" 'pascal-outline-next-defun) - (define-key pascal-outline-map "\C-c\C-d" 'pascal-outline-goto-defun) - (define-key pascal-outline-map "\C-c\C-s" 'pascal-show-all) - (define-key pascal-outline-map "\C-c\C-h" 'pascal-hide-other-defuns)) - -(defvar pascal-outline-mode nil "Non-nil while using Pascal Outline mode.") -(make-variable-buffer-local 'pascal-outline-mode) -(set-default 'pascal-outline-mode nil) -(if (not (assoc 'pascal-outline-mode minor-mode-alist)) - (setq minor-mode-alist (append minor-mode-alist - (list '(pascal-outline-mode " Outl"))))) - -(defun pascal-outline (&optional arg) - "Outline-line minor mode for Pascal mode. -When in Pascal Outline mode, portions -of the text being edited may be made invisible. \\<pascal-outline-map> - -Pascal Outline mode provides some additional commands. - -\\[pascal-outline-prev-defun]\ -\t- Move to previous function/procedure, hiding everything else. -\\[pascal-outline-next-defun]\ -\t- Move to next function/procedure, hiding everything else. -\\[pascal-outline-goto-defun]\ -\t- Goto function/procedure prompted for in minibuffer, -\t hide all other functions. -\\[pascal-show-all]\t- Show the whole buffer. -\\[pascal-hide-other-defuns]\ -\t- Hide everything but the current function (function under the cursor). -\\[pascal-outline]\t- Leave pascal-outline-mode." - (interactive "P") - (setq pascal-outline-mode - (if (null arg) (not pascal-outline-mode) t)) - (if (boundp 'redraw-mode-line) - (redraw-mode-line)) - (if pascal-outline-mode - (progn - (setq selective-display t) - (use-local-map pascal-outline-map)) - (progn - (setq selective-display nil) - (pascal-show-all) - (use-local-map pascal-mode-map)))) - -(defun pascal-outline-change (b e pascal-flag) - (let ((modp (buffer-modified-p))) - (unwind-protect - (subst-char-in-region b e (if (= pascal-flag ?\n) - ?\^M ?\n) pascal-flag) - (set-buffer-modified-p modp)))) - -(defun pascal-show-all () - "Show all of the text in the buffer." - (interactive) - (pascal-outline-change (point-min) (point-max) ?\n)) - -(defun pascal-hide-other-defuns () - "Show only the current defun." - (interactive) - (save-excursion - (let ((beg (progn (if (not (looking-at "\\(function\\|procedure\\)\\>")) - (pascal-beg-of-defun)) - (point))) - (end (progn (pascal-end-of-defun) - (backward-sexp 1) - (search-forward "\n\\|\^M" nil t) - (point))) - (opoint (point-min))) - (goto-char (point-min)) - - ;; Hide all functions before current function - (while (re-search-forward "^\\(function\\|procedure\\)\\>" beg 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) - ;; Functions may be nested - (if (> (progn (pascal-end-of-defun) (point)) beg) - (goto-char opoint))) - (if (> beg opoint) - (pascal-outline-change opoint (1- beg) ?\^M)) - - ;; Show current function - (pascal-outline-change beg end ?\n) - ;; Hide nested functions - (forward-char 1) - (while (re-search-forward "^\\(function\\|procedure\\)\\>" end 'move) - (setq opoint (point)) - (pascal-end-of-defun) - (pascal-outline-change opoint (point) ?\^M)) - - (goto-char end) - (setq opoint end) - - ;; Hide all function after current function - (while (re-search-forward "^\\(function\\|procedure\\)\\>" nil 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) - (pascal-end-of-defun)) - (pascal-outline-change opoint (point-max) ?\^M) - - ;; Hide main program - (if (< (progn (forward-line -1) (point)) end) - (progn - (goto-char beg) - (pascal-end-of-defun) - (backward-sexp 1) - (pascal-outline-change (point) (point-max) ?\^M)))))) - -(defun pascal-outline-next-defun () - "Move to next function/procedure, hiding all others." - (interactive) - (pascal-end-of-defun) - (pascal-hide-other-defuns)) - -(defun pascal-outline-prev-defun () - "Move to previous function/procedure, hiding all others." - (interactive) - (pascal-beg-of-defun) - (pascal-hide-other-defuns)) - -(defun pascal-outline-goto-defun () - "Move to specified function/procedure, hiding all others." - (interactive) - (pascal-goto-defun) - (pascal-hide-other-defuns)) - -;;; pascal.el ends here diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el deleted file mode 100644 index 67a439da655..00000000000 --- a/lisp/progmodes/perl-mode.el +++ /dev/null @@ -1,732 +0,0 @@ -;;; perl-mode.el --- Perl code editing commands for GNU Emacs - -;; Copyright (C) 1990, 1994 Free Software Foundation, Inc. - -;; Author: William F. Mann -;; Maintainer: FSF -;; Adapted-By: ESR -;; Keywords: languages - -;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the -;; Free Software Foundation, under terms of its General Public License. - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode") -;; to your .emacs file and change the first line of your perl script to: -;; #!/usr/bin/perl -- # -*-Perl-*- -;; With arguments to perl: -;; #!/usr/bin/perl -P- # -*-Perl-*- -;; To handle files included with do 'filename.pl';, add something like -;; (setq auto-mode-alist (append (list (cons "\\.pl\\'" 'perl-mode)) -;; auto-mode-alist)) -;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode. - -;; This code is based on the 18.53 version c-mode.el, with extensive -;; rewriting. Most of the features of c-mode survived intact. - -;; I added a new feature which adds functionality to TAB; it is controlled -;; by the variable perl-tab-to-comment. With it enabled, TAB does the -;; first thing it can from the following list: change the indentation; -;; move past leading white space; delete an empty comment; reindent a -;; comment; move to end of line; create an empty comment; tell you that -;; the line ends in a quoted string, or has a # which should be a \#. - -;; If your machine is slow, you may want to remove some of the bindings -;; to electric-perl-terminator. I changed the indenting defaults to be -;; what Larry Wall uses in perl/lib, but left in all the options. - -;; I also tuned a few things: comments and labels starting in column -;; zero are left there by indent-perl-exp; perl-beginning-of-function -;; goes back to the first open brace/paren in column zero, the open brace -;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp -;; (meta-^q) indents from the current line through the close of the next -;; brace/paren, so you don't need to start exactly at a brace or paren. - -;; It may be good style to put a set of redundant braces around your -;; main program. This will let you reindent it with meta-^q. - -;; Known problems (these are all caused by limitations in the Emacs Lisp -;; parsing routine (parse-partial-sexp), which was not designed for such -;; a rich language; writing a more suitable parser would be a big job): -;; 1) Regular expression delimiters do not act as quotes, so special -;; characters such as `'"#:;[](){} may need to be backslashed -;; in regular expressions and in both parts of s/// and tr///. -;; 2) The globbing syntax <pattern> is not recognized, so special -;; characters in the pattern string must be backslashed. -;; 3) The q, qq, and << quoting operators are not recognized; see below. -;; 4) \ (backslash) always quotes the next character, so '\' is -;; treated as the start of a string. Use "\\" as a work-around. -;; 5) To make variables such a $' and $#array work, perl-mode treats -;; $ just like backslash, so '$' is the same as problem 5. -;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an -;; unmatched }. See below. -;; 7) When ' (quote) is used as a package name separator, perl-mode -;; doesn't understand, and thinks it is seeing a quoted string. - -;; Here are some ugly tricks to bypass some of these problems: the perl -;; expression /`/ (that's a back-tick) usually evaluates harmlessly, -;; but will trick perl-mode into starting a quoted string, which -;; can be ended with another /`/. Assuming you have no embedded -;; back-ticks, this can used to help solve problem 3: -;; -;; /`/; $ugly = q?"'$?; /`/; -;; -;; To solve problem 6, add a /{/; before each use of ${var}: -;; /{/; while (<${glob_me}>) ... -;; -;; Problem 7 is even worse, but this 'fix' does work :-( -;; $DB'stop#' -;; [$DB'line#' -;; ] =~ s/;9$//; - -;;; Code: - -(defvar perl-mode-abbrev-table nil - "Abbrev table in use in perl-mode buffers.") -(define-abbrev-table 'perl-mode-abbrev-table ()) - -(defvar perl-mode-map () - "Keymap used in Perl mode.") -(if perl-mode-map - () - (setq perl-mode-map (make-sparse-keymap)) - (define-key perl-mode-map "{" 'electric-perl-terminator) - (define-key perl-mode-map "}" 'electric-perl-terminator) - (define-key perl-mode-map ";" 'electric-perl-terminator) - (define-key perl-mode-map ":" 'electric-perl-terminator) - (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function) - (define-key perl-mode-map "\e\C-e" 'perl-end-of-function) - (define-key perl-mode-map "\e\C-h" 'mark-perl-function) - (define-key perl-mode-map "\e\C-q" 'indent-perl-exp) - (define-key perl-mode-map "\177" 'backward-delete-char-untabify) - (define-key perl-mode-map "\t" 'perl-indent-command)) - -(autoload 'c-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar perl-mode-syntax-table nil - "Syntax table in use in perl-mode buffers.") - -(if perl-mode-syntax-table - () - (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table))) - (modify-syntax-entry ?\n ">" perl-mode-syntax-table) - (modify-syntax-entry ?# "<" perl-mode-syntax-table) - (modify-syntax-entry ?$ "/" perl-mode-syntax-table) - (modify-syntax-entry ?% "." perl-mode-syntax-table) - (modify-syntax-entry ?& "." perl-mode-syntax-table) - (modify-syntax-entry ?\' "\"" perl-mode-syntax-table) - (modify-syntax-entry ?* "." perl-mode-syntax-table) - (modify-syntax-entry ?+ "." perl-mode-syntax-table) - (modify-syntax-entry ?- "." perl-mode-syntax-table) - (modify-syntax-entry ?/ "." perl-mode-syntax-table) - (modify-syntax-entry ?< "." perl-mode-syntax-table) - (modify-syntax-entry ?= "." perl-mode-syntax-table) - (modify-syntax-entry ?> "." perl-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table) - (modify-syntax-entry ?` "\"" perl-mode-syntax-table) - (modify-syntax-entry ?| "." perl-mode-syntax-table) -) - -(defvar perl-imenu-generic-expression - '( - ;; Functions - (nil "^sub\\s-+\\([-A-Za-z0-9+_:]+\\)\\(\\s-\\|\n\\)*{" 1 ) - ;;Variables - ("Variables" "^\\([$@%][-A-Za-z0-9+_:]+\\)\\s-*=" 1 ) - ("Packages" "^package\\s-+\\([-A-Za-z0-9+_:]+\\);" 1 ) - ) - "Imenu generic expression for Perl mode. See `imenu-generic-expression'.") - -;; Regexps updated with help from Tom Tromey <tromey@cambric.colorado.edu> and -;; Jim Campbell <jec@murzim.ca.boeing.com>. - -(defconst perl-font-lock-keywords-1 - '(;; What is this for? - ;;("\\(--- .* ---\\|=== .* ===\\)" . font-lock-string-face) - ;; - ;; Fontify preprocessor statements as we do in `c-font-lock-keywords'. - ;; Ilya Zakharevich <ilya@math.ohio-state.edu> thinks this is a bad idea. - ("^#[ \t]*include[ \t]+\\(<[^>\"\n]+>\\)" 1 font-lock-string-face) - ("^#[ \t]*define[ \t]+\\(\\sw+\\)(" 1 font-lock-function-name-face) - ("^#[ \t]*if\\>" - ("\\<\\(defined\\)\\>[ \t]*(?\\(\\sw+\\)?" nil nil - (1 font-lock-reference-face) (2 font-lock-variable-name-face nil t))) - ("^#[ \t]*\\(\\sw+\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-reference-face) (2 font-lock-variable-name-face nil t)) - ;; - ;; Fontify function and package names in declarations. - ("\\<\\(package\\|sub\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ("\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-reference-face nil t))) - "Subdued level highlighting for Perl mode.") - -(defconst perl-font-lock-keywords-2 - (append perl-font-lock-keywords-1 - (list - ;; - ;; Fontify keywords, except those fontified otherwise. -; (make-regexp '("if" "until" "while" "elsif" "else" "unless" "do" "dump" -; "for" "foreach" "exit" "die" -; "BEGIN" "END" "return" "exec" "eval")) - (concat "\\<\\(" - "BEGIN\\|END\\|d\\(ie\\|o\\|ump\\)\\|" - "e\\(ls\\(e\\|if\\)\\|val\\|x\\(ec\\|it\\)\\)\\|" - "for\\(\\|each\\)\\|if\\|return\\|un\\(less\\|til\\)\\|while" - "\\)\\>") - ;; - ;; Fontify local and my keywords as types. - '("\\<\\(local\\|my\\)\\>" . font-lock-type-face) - ;; - ;; Fontify function, variable and file name references. - '("&\\(\\sw+\\)" 1 font-lock-function-name-face) - ;; Additionally underline non-scalar variables. Maybe this is a bad idea. - ;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face) - '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) - '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" - (2 (cons font-lock-variable-name-face '(underline)))) - '("<\\(\\sw+\\)>" 1 font-lock-reference-face) - ;; - ;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'. - '("\\<\\(continue\\|goto\\|last\\|next\\|redo\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-reference-face nil t)) - '("^[ \t]*\\(\\sw+\\)[ \t]*:[^:]" 1 font-lock-reference-face))) - "Gaudy level highlighting for Perl mode.") - -(defvar perl-font-lock-keywords perl-font-lock-keywords-1 - "Default expressions to highlight in Perl mode.") - - -(defvar perl-indent-level 4 - "*Indentation of Perl statements with respect to containing block.") -(defvar perl-continued-statement-offset 4 - "*Extra indent for lines not starting new statements.") -(defvar perl-continued-brace-offset -4 - "*Extra indent for substatements that start with open-braces. -This is in addition to `perl-continued-statement-offset'.") -(defvar perl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defvar perl-brace-imaginary-offset 0 - "*Imagined indentation of an open brace that actually follows a statement.") -(defvar perl-label-offset -2 - "*Offset of Perl label lines relative to usual indentation.") - -(defvar perl-tab-always-indent t - "*Non-nil means TAB in Perl mode always indents the current line. -Otherwise it inserts a tab character if you type it past the first -nonwhite character on the line.") - -;; I changed the default to nil for consistency with general Emacs -;; conventions -- rms. -(defvar perl-tab-to-comment nil - "*Non-nil means TAB moves to eol or makes a comment in some cases. -For lines which don't need indenting, TAB either indents an -existing comment, moves to end-of-line, or if at end-of-line already, -create a new comment.") - -(defvar perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:" - "*Lines starting with this regular expression are not auto-indented.") - -;;;###autoload -(defun perl-mode () - "Major mode for editing Perl code. -Expression and list commands understand all Perl brackets. -Tab indents for Perl code. -Comments are delimited with # ... \\n. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{perl-mode-map} -Variables controlling indentation style: - perl-tab-always-indent - Non-nil means TAB in Perl mode should always indent the current line, - regardless of where in the line point is when the TAB command is used. - perl-tab-to-comment - Non-nil means that for lines which don't need indenting, TAB will - either delete an empty comment, indent an existing comment, move - to end-of-line, or if at end-of-line already, create a new comment. - perl-nochange - Lines starting with this regular expression are not auto-indented. - perl-indent-level - Indentation of Perl statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - perl-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - perl-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to `perl-continued-statement-offset'. - perl-brace-offset - Extra indentation for line if it starts with an open brace. - perl-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - perl-label-offset - Extra indentation for line that is a label. - -Various indentation styles: K&R BSD BLK GNU LW - perl-indent-level 5 8 0 2 4 - perl-continued-statement-offset 5 8 4 2 4 - perl-continued-brace-offset 0 0 0 0 -4 - perl-brace-offset -5 -8 0 0 0 - perl-brace-imaginary-offset 0 0 4 0 0 - perl-label-offset -5 -8 -2 -2 -2 - -Turning on Perl mode runs the normal hook `perl-mode-hook'." - (interactive) - (kill-all-local-variables) - (use-local-map perl-mode-map) - (setq major-mode 'perl-mode) - (setq mode-name "Perl") - (setq local-abbrev-table perl-mode-abbrev-table) - (set-syntax-table perl-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'perl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'perl-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - ;; Tell font-lock.el how to handle Perl. - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((perl-font-lock-keywords - perl-font-lock-keywords-1 - perl-font-lock-keywords-2) - nil nil ((?\_ . "w")))) - ;; Tell imenu how to handle Perl. - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression perl-imenu-generic-expression) - (run-hooks 'perl-mode-hook)) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in Perl code -;; based on its context. -(defun perl-comment-indent () - (if (and (bolp) (not (eolp))) - 0 ;Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max (if (bolp) ;Else indent at comment column - 0 ; except leave at least one space if - (1+ (current-column))) ; not at beginning of line. - comment-column)))) - -(defun electric-perl-terminator (arg) - "Insert character and adjust indentation. -If at end-of-line, and not in a comment or a quote, correct the's indentation." - (interactive "P") - (let ((insertpos (point))) - (and (not arg) ; decide whether to indent - (eolp) - (save-excursion - (beginning-of-line) - (and (not ; eliminate comments quickly - (and comment-start-skip - (re-search-forward comment-start-skip insertpos t)) ) - (or (/= last-command-char ?:) - ;; Colon is special only after a label .... - (looking-at "\\s-*\\(\\w\\|\\s_\\)+$")) - (let ((pps (parse-partial-sexp - (perl-beginning-of-function) insertpos))) - (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))) - (progn ; must insert, indent, delete - (insert-char last-command-char 1) - (perl-indent-line) - (delete-char -1)))) - (self-insert-command (prefix-numeric-value arg))) - -;; not used anymore, but may be useful someday: -;;(defun perl-inside-parens-p () -;; (condition-case () -;; (save-excursion -;; (save-restriction -;; (narrow-to-region (point) -;; (perl-beginning-of-function)) -;; (goto-char (point-max)) -;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) -;; (error nil))) - -(defun perl-indent-command (&optional arg) - "Indent current line as Perl code, or optionally, insert a tab character. - -With an argument, indent the current line, regardless of other options. - -If `perl-tab-always-indent' is nil and point is not in the indentation -area at the beginning of the line, simply insert a tab. - -Otherwise, indent the current line. If point was within the indentation -area it is moved to the end of the indentation area. If the line was -already indented properly and point was not within the indentation area, -and if `perl-tab-to-comment' is non-nil (the default), then do the first -possible action from the following list: - - 1) delete an empty comment - 2) move forward to start of comment, indenting if necessary - 3) move forward to end of line - 4) create an empty comment - 5) move backward to start of comment, indenting if necessary." - (interactive "P") - (if arg ; If arg, just indent this line - (perl-indent-line "\f") - (if (and (not perl-tab-always-indent) - (> (current-column) (current-indentation))) - (insert-tab) - (let (bof lsexp delta (oldpnt (point))) - (beginning-of-line) - (setq lsexp (point)) - (setq bof (perl-beginning-of-function)) - (goto-char oldpnt) - (setq delta (perl-indent-line "\f\\|;?#" bof)) - (and perl-tab-to-comment - (= oldpnt (point)) ; done if point moved - (if (listp delta) ; if line starts in a quoted string - (setq lsexp (or (nth 2 delta) bof)) - (= delta 0)) ; done if indenting occurred - (let (eol state) - (end-of-line) - (setq eol (point)) - (if (= (char-after bof) ?=) - (if (= oldpnt eol) - (message "In a format statement")) - (setq state (parse-partial-sexp lsexp eol)) - (if (nth 3 state) - (if (= oldpnt eol) ; already at eol in a string - (message "In a string which starts with a %c." - (nth 3 state))) - (if (not (nth 4 state)) - (if (= oldpnt eol) ; no comment, create one? - (indent-for-comment)) - (beginning-of-line) - (if (and comment-start-skip - (re-search-forward comment-start-skip eol 'move)) - (if (eolp) - (progn ; kill existing comment - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (kill-region (point) eol)) - (if (or (< oldpnt (point)) (= oldpnt eol)) - (indent-for-comment) ; indent existing comment - (end-of-line))) - (if (/= oldpnt eol) - (end-of-line) - (message "Use backslash to quote # characters.") - (ding t)))))))))))) - -(defun perl-indent-line (&optional nochange parse-start) - "Indent current line as Perl code. -Return the amount the indentation -changed by, or (parse-state) if line starts in a quoted string." - (let ((case-fold-search nil) - (pos (- (point-max) (point))) - (bof (or parse-start (save-excursion (perl-beginning-of-function)))) - beg indent shift-amt) - (beginning-of-line) - (setq beg (point)) - (setq shift-amt - (cond ((= (char-after bof) ?=) 0) - ((listp (setq indent (calculate-perl-indent bof))) indent) - ((looking-at (or nochange perl-nochange)) 0) - (t - (skip-chars-forward " \t\f") - (cond ((looking-at "\\(\\w\\|\\s_\\)+:") - (setq indent (max 1 (+ indent perl-label-offset)))) - ((= (following-char) ?}) - (setq indent (- indent perl-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent perl-brace-offset)))) - (- indent (current-column))))) - (skip-chars-forward " \t\f") - (if (and (numberp shift-amt) (/= 0 shift-amt)) - (progn (delete-region beg (point)) - (indent-to indent))) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - shift-amt)) - -(defun calculate-perl-indent (&optional parse-start) - "Return appropriate indentation for current line as Perl code. -In usual case returns an integer: the column to indent to. -Returns (parse-state) if line starts inside a string." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - (colon-line-end 0) - state containing-sexp) - (if parse-start ;used to avoid searching - (goto-char parse-start) - (perl-beginning-of-function)) - (while (< (point) indent-point) ;repeat until right sexp - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) -; state = (depth_in_parens innermost_containing_list last_complete_sexp -; string_terminator_or_nil inside_commentp following_quotep -; minimum_paren-depth_this_scan) -; Parsing stops if depth in parentheses becomes equal to third arg. - (setq containing-sexp (nth 1 state))) - (cond ((nth 3 state) state) ; In a quoted string? - ((null containing-sexp) ; Line is at top level. - (skip-chars-forward " \t\f") - (if (= (following-char) ?{) - 0 ; move to beginning of line if it starts a function body - ;; indent a little if this is a continuation line - (perl-backward-to-noncomment) - (if (or (bobp) - (memq (preceding-char) '(?\; ?\}))) - 0 perl-continued-statement-offset))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (perl-backward-to-noncomment) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)))) - (if (eq (preceding-char) ?\,) - (perl-backward-to-start-of-continued-exp containing-sexp) - (beginning-of-line)) - (perl-backward-to-noncomment)) - ;; Now we get the answer. - (if (not (memq (preceding-char) '(?\; ?\} ?\{))) - ;; This line is continuation of preceding line's statement; - ;; indent perl-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (perl-backward-to-start-of-continued-exp containing-sexp) - (+ perl-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (looking-at "[ \t]*{")) - perl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position at last unclosed open. - (goto-char containing-sexp) - (or - ;; If open paren is in col 0, close brace is special - (and (bolp) - (save-excursion (goto-char indent-point) - (looking-at "[ \t]*}")) - perl-indent-level) - ;; Is line first statement after an open-brace? - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - ;; Skip over comments and labels following openbrace. - (while (progn - (skip-chars-forward " \t\f\n") - (cond ((looking-at ";?#") - (forward-line 1) t) - ((looking-at "\\(\\w\\|\\s_\\)+:") - (save-excursion - (end-of-line) - (setq colon-line-end (point))) - (search-forward ":"))))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) - (- (current-indentation) perl-label-offset) - (current-column)))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open paren in column zero, don't let statement - ;; start there too. If perl-indent-level is zero, - ;; use perl-brace-offset + perl-continued-statement-offset - ;; For open-braces not the first thing in a line, - ;; add in perl-brace-imaginary-offset. - (+ (if (and (bolp) (zerop perl-indent-level)) - (+ perl-brace-offset perl-continued-statement-offset) - perl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the perl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 perl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -(defun perl-backward-to-noncomment () - "Move point backward to after the first non-white-space, skipping comments." - (interactive) - (let (opoint stop) - (while (not stop) - (setq opoint (point)) - (beginning-of-line) - (if (and comment-start-skip - (re-search-forward comment-start-skip opoint 'move 1)) - (progn (goto-char (match-end 1)) - (skip-chars-forward ";"))) - (skip-chars-backward " \t\f") - (setq stop (or (bobp) - (not (bolp)) - (forward-char -1)))))) - -(defun perl-backward-to-start-of-continued-exp (lim) - (if (= (preceding-char) ?\)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t\f")) - -;; note: this may be slower than the c-mode version, but I can understand it. -(defun indent-perl-exp () - "Indent each line of the Perl grouping following point." - (interactive) - (let* ((case-fold-search nil) - (oldpnt (point-marker)) - (bof-mark (save-excursion - (end-of-line 2) - (perl-beginning-of-function) - (point-marker))) - eol last-mark lsexp-mark delta) - (if (= (char-after (marker-position bof-mark)) ?=) - (message "Can't indent a format statement") - (message "Indenting Perl expression...") - (save-excursion (end-of-line) (setq eol (point))) - (save-excursion ; locate matching close paren - (while (and (not (eobp)) (<= (point) eol)) - (parse-partial-sexp (point) (point-max) 0)) - (setq last-mark (point-marker))) - (setq lsexp-mark bof-mark) - (beginning-of-line) - (while (< (point) (marker-position last-mark)) - (setq delta (perl-indent-line nil (marker-position bof-mark))) - (if (numberp delta) ; unquoted start-of-line? - (progn - (if (eolp) - (delete-horizontal-space)) - (setq lsexp-mark (point-marker)))) - (end-of-line) - (setq eol (point)) - (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol)) - (progn ; line ends in a comment - (beginning-of-line) - (if (or (not (looking-at "\\s-*;?#")) - (listp delta) - (and (/= 0 delta) - (= (- (current-indentation) delta) comment-column))) - (if (and comment-start-skip - (re-search-forward comment-start-skip eol t)) - (indent-for-comment))))) ; indent existing comment - (forward-line 1)) - (goto-char (marker-position oldpnt)) - (message "Indenting Perl expression...done")))) - -(defun perl-beginning-of-function (&optional arg) - "Move backward to next beginning-of-function, or as far as possible. -With argument, repeat that many times; negative args move forward. -Returns new value of point in all cases." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) (forward-char 1)) - (and (/= arg 0) - (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\." - nil 'move arg) - (goto-char (1- (match-end 0)))) - (point)) - -;; note: this routine is adapted directly from emacs lisp.el, end-of-defun; -;; no bugs have been removed :-) -(defun perl-end-of-function (&optional arg) - "Move forward to next end-of-function. -The end of a function is found by moving forward from the beginning of one. -With argument, repeat that many times; negative args move backward." - (interactive "p") - (or arg (setq arg 1)) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point)) npos) - (while (progn - (if (and first - (progn - (forward-char 1) - (perl-beginning-of-function 1) - (not (bobp)))) - nil - (or (bobp) (forward-char -1)) - (perl-beginning-of-function -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (perl-beginning-of-function 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (progn (perl-beginning-of-function 2) (not (bobp))) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg))))) - -(defun mark-perl-function () - "Put mark at end of Perl function, point at beginning." - (interactive) - (push-mark (point)) - (perl-end-of-function) - (push-mark (point)) - (perl-beginning-of-function) - (backward-paragraph)) - -(provide 'perl-mode) - -;;; perl-mode.el ends here diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el deleted file mode 100644 index 05a3c7ed5ac..00000000000 --- a/lisp/progmodes/prolog.el +++ /dev/null @@ -1,273 +0,0 @@ -;;; prolog.el --- major mode for editing and running Prolog under Emacs - -;; Copyright (C) 1986, 1987 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Keywords: languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package provides a major mode for editing Prolog. It knows -;; about Prolog syntax and comments, and can send regions to an inferior -;; Prolog interpreter process. - -;;; Code: - -(defvar prolog-mode-syntax-table nil) -(defvar prolog-mode-abbrev-table nil) -(defvar prolog-mode-map nil) - -(defvar prolog-program-name "prolog" - "*Program name for invoking an inferior Prolog with `run-prolog'.") - -(defvar prolog-consult-string "reconsult(user).\n" - "*(Re)Consult mode (for C-Prolog and Quintus Prolog). ") - -(defvar prolog-compile-string "compile(user).\n" - "*Compile mode (for Quintus Prolog).") - -(defvar prolog-eof-string "end_of_file.\n" - "*String that represents end of file for prolog. -nil means send actual operating system end of file.") - -(defvar prolog-indent-width 4) - -(if prolog-mode-syntax-table - () - (let ((table (make-syntax-table))) - (modify-syntax-entry ?_ "w" table) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?/ "." table) - (modify-syntax-entry ?* "." table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "<" table) - (modify-syntax-entry ?\n ">" table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?\' "\"" table) - (setq prolog-mode-syntax-table table))) - -(define-abbrev-table 'prolog-mode-abbrev-table ()) - -(defun prolog-mode-variables () - (set-syntax-table prolog-mode-syntax-table) - (setq local-abbrev-table prolog-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "%%\\|$\\|" page-delimiter)) ;'%%..' - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'prolog-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "%") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "%+ *") - (make-local-variable 'comment-column) - (setq comment-column 48) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'prolog-comment-indent)) - -(defun prolog-mode-commands (map) - (define-key map "\t" 'prolog-indent-line) - (define-key map "\e\C-x" 'prolog-consult-region)) - -(if prolog-mode-map - nil - (setq prolog-mode-map (make-sparse-keymap)) - (prolog-mode-commands prolog-mode-map)) - -;;;###autoload -(defun prolog-mode () - "Major mode for editing Prolog code for Prologs. -Blank lines and `%%...' separate paragraphs. `%'s start comments. -Commands: -\\{prolog-mode-map} -Entry to this mode calls the value of `prolog-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map prolog-mode-map) - (setq major-mode 'prolog-mode) - (setq mode-name "Prolog") - (prolog-mode-variables) - (run-hooks 'prolog-mode-hook)) - -(defun prolog-indent-line (&optional whole-exp) - "Indent current line as Prolog code. -With argument, indent any additional lines of the same clause -rigidly along with this one (not yet)." - (interactive "p") - (let ((indent (prolog-indent-level)) - (pos (- (point-max) (point))) beg) - (beginning-of-line) - (setq beg (point)) - (skip-chars-forward " \t") - (if (zerop (- indent (current-column))) - nil - (delete-region beg (point)) - (indent-to indent)) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - )) - -(defun prolog-indent-level () - "Compute prolog indentation level." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (cond - ((looking-at "%%%") 0) ;Large comment starts - ((looking-at "%[^%]") comment-column) ;Small comment starts - ((bobp) 0) ;Beginning of buffer - (t - (let ((empty t) ind more less) - (if (looking-at ")") - (setq less t) ;Find close - (setq less nil)) - ;; See previous indentation - (while empty - (forward-line -1) - (beginning-of-line) - (if (bobp) - (setq empty nil) - (skip-chars-forward " \t") - (if (not (or (looking-at "%[^%]") (looking-at "\n"))) - (setq empty nil)))) - (if (bobp) - (setq ind 0) ;Beginning of buffer - (setq ind (current-column))) ;Beginning of clause - ;; See its beginning - (if (looking-at "%%[^%]") - ind - ;; Real prolog code - (if (looking-at "(") - (setq more t) ;Find open - (setq more nil)) - ;; See its tail - (end-of-prolog-clause) - (or (bobp) (forward-char -1)) - (cond ((looking-at "[,(;>]") - (if (and more (looking-at "[^,]")) - (+ ind prolog-indent-width) ;More indentation - (max tab-width ind))) ;Same indentation - ((looking-at "-") tab-width) ;TAB - ((or less (looking-at "[^.]")) - (max (- ind prolog-indent-width) 0)) ;Less indentation - (t 0)) ;No indentation - ))) - ))) - -(defun end-of-prolog-clause () - "Go to end of clause in this line." - (beginning-of-line 1) - (let* ((eolpos (save-excursion (end-of-line) (point)))) - (if (re-search-forward comment-start-skip eolpos 'move) - (goto-char (match-beginning 0))) - (skip-chars-backward " \t"))) - -(defun prolog-comment-indent () - "Compute prolog comment indentation." - (cond ((looking-at "%%%") 0) - ((looking-at "%%") (prolog-indent-level)) - (t - (save-excursion - (skip-chars-backward " \t") - ;; Insert one space at least, except at left margin. - (max (+ (current-column) (if (bolp) 0 1)) - comment-column))) - )) - - -;;; -;;; Inferior prolog mode -;;; -(defvar inferior-prolog-mode-map nil) - -(defun inferior-prolog-mode () - "Major mode for interacting with an inferior Prolog process. - -The following commands are available: -\\{inferior-prolog-mode-map} - -Entry to this mode calls the value of `prolog-mode-hook' with no arguments, -if that value is non-nil. Likewise with the value of `comint-mode-hook'. -`prolog-mode-hook' is called after `comint-mode-hook'. - -You can send text to the inferior Prolog from other buffers -using the commands `send-region', `send-string' and \\[prolog-consult-region]. - -Commands: -Tab indents for Prolog; with argument, shifts rest - of expression rigidly with the current line. -Paragraphs are separated only by blank lines and '%%'. -'%'s start comments. - -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. -\\[comint-kill-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing. -\\[comint-interrupt-subjob] interrupts the shell or its current subjob if any. -\\[comint-stop-subjob] stops. \\[comint-quit-subjob] sends quit signal." - (interactive) - (require 'comint) - (comint-mode) - (setq major-mode 'inferior-prolog-mode - mode-name "Inferior Prolog" - comint-prompt-regexp "^| [ ?][- ] *") - (prolog-mode-variables) - (if inferior-prolog-mode-map nil - (setq inferior-prolog-mode-map (copy-keymap comint-mode-map)) - (prolog-mode-commands inferior-prolog-mode-map)) - (use-local-map inferior-prolog-mode-map) - (run-hooks 'prolog-mode-hook)) - -;;;###autoload -(defun run-prolog () - "Run an inferior Prolog process, input and output via buffer *prolog*." - (interactive) - (require 'comint) - (switch-to-buffer (make-comint "prolog" prolog-program-name)) - (inferior-prolog-mode)) - -(defun prolog-consult-region (compile beg end) - "Send the region to the Prolog process made by \"M-x run-prolog\". -If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." - (interactive "P\nr") - (save-excursion - (if compile - (send-string "prolog" prolog-compile-string) - (send-string "prolog" prolog-consult-string)) - (send-region "prolog" beg end) - (send-string "prolog" "\n") ;May be unnecessary - (if prolog-eof-string - (send-string "prolog" prolog-eof-string) - (process-send-eof "prolog")))) ;Send eof to prolog process. - -(defun prolog-consult-region-and-go (compile beg end) - "Send the region to the inferior Prolog, and switch to *prolog* buffer. -If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." - (interactive "P\nr") - (prolog-consult-region compile beg end) - (switch-to-buffer "*prolog*")) - -;;; prolog.el ends here diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el deleted file mode 100644 index a4393df8ee7..00000000000 --- a/lisp/progmodes/scheme.el +++ /dev/null @@ -1,515 +0,0 @@ -;;; scheme.el --- Scheme mode, and its idiosyncratic commands. - -;; Copyright (C) 1986, 1987, 1988 Free Software Foundation, Inc. - -;; Author: Bill Rozas <jinz@prep.ai.mit.edu> -;; Keywords: languages, lisp - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Adapted from Lisp mode by Bill Rozas, jinx@prep. -;; Initially a query replace of Lisp mode, except for the indentation -;; of special forms. Probably the code should be merged at some point -;; so that there is sharing between both libraries. - -;;; Code: - -(defvar scheme-mode-syntax-table nil "") -(if (not scheme-mode-syntax-table) - (let ((i 0)) - (setq scheme-mode-syntax-table (make-syntax-table)) - (set-syntax-table scheme-mode-syntax-table) - - ;; Default is atom-constituent. - (while (< i 256) - (modify-syntax-entry i "_ ") - (setq i (1+ i))) - - ;; Word components. - (setq i ?0) - (while (<= i ?9) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - (setq i ?A) - (while (<= i ?Z) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - (setq i ?a) - (while (<= i ?z) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - - ;; Whitespace - (modify-syntax-entry ?\t " ") - (modify-syntax-entry ?\n "> ") - (modify-syntax-entry ?\f " ") - (modify-syntax-entry ?\r " ") - (modify-syntax-entry ? " ") - - ;; These characters are delimiters but otherwise undefined. - ;; Brackets and braces balance for editing convenience. - (modify-syntax-entry ?[ "(] ") - (modify-syntax-entry ?] ")[ ") - (modify-syntax-entry ?{ "(} ") - (modify-syntax-entry ?} "){ ") - (modify-syntax-entry ?\| " 23") - - ;; Other atom delimiters - (modify-syntax-entry ?\( "() ") - (modify-syntax-entry ?\) ")( ") - (modify-syntax-entry ?\; "< ") - (modify-syntax-entry ?\" "\" ") - (modify-syntax-entry ?' " p") - (modify-syntax-entry ?` " p") - - ;; Special characters - (modify-syntax-entry ?, "_ p") - (modify-syntax-entry ?@ "_ p") - (modify-syntax-entry ?# "_ p14") - (modify-syntax-entry ?\\ "\\ "))) - -(defvar scheme-mode-abbrev-table nil "") -(define-abbrev-table 'scheme-mode-abbrev-table ()) - -(defun scheme-mode-variables () - (set-syntax-table scheme-mode-syntax-table) - (setq local-abbrev-table scheme-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'scheme-indent-line) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'comment-start) - (setq comment-start ";") - (make-local-variable 'comment-start-skip) - ;; Look within the line for a ; following an even number of backslashes - ;; after either a non-backslash or the line beginning. - (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'scheme-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (setq mode-line-process '("" scheme-mode-line-process))) - -(defvar scheme-mode-line-process "") - -(defun scheme-mode-commands (map) - (define-key map "\t" 'scheme-indent-line) - (define-key map "\177" 'backward-delete-char-untabify) - (define-key map "\e\C-q" 'scheme-indent-sexp)) - -(defvar scheme-mode-map nil) -(if (not scheme-mode-map) - (progn - (setq scheme-mode-map (make-sparse-keymap)) - (scheme-mode-commands scheme-mode-map))) - -;;;###autoload -(defun scheme-mode () - "Major mode for editing Scheme code. -Editing commands are similar to those of lisp-mode. - -In addition, if an inferior Scheme process is running, some additional -commands will be defined, for evaluating expressions and controlling -the interpreter, and the state of the process will be displayed in the -modeline of all Scheme buffers. The names of commands that interact -with the Scheme process start with \"xscheme-\". For more information -see the documentation for xscheme-interaction-mode. - -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{scheme-mode-map} -Entry to this mode calls the value of scheme-mode-hook -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (scheme-mode-initialize) - (scheme-mode-variables) - (run-hooks 'scheme-mode-hook)) - -(defun scheme-mode-initialize () - (use-local-map scheme-mode-map) - (setq major-mode 'scheme-mode) - (setq mode-name "Scheme")) - -(defvar scheme-mit-dialect t - "If non-nil, scheme mode is specialized for MIT Scheme. -Set this to nil if you normally use another dialect.") - -(defun scheme-comment-indent (&optional pos) - (save-excursion - (if pos (goto-char pos)) - (cond ((looking-at ";;;") (current-column)) - ((looking-at ";;") - (let ((tem (calculate-scheme-indent))) - (if (listp tem) (car tem) tem))) - (t - (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) - comment-column))))) - -(defvar scheme-indent-offset nil "") -(defvar scheme-indent-function 'scheme-indent-function "") - -(defun scheme-indent-line (&optional whole-exp) - "Indent current line as Scheme code. -With argument, indent any additional lines of the same expression -rigidly along with this one." - (interactive "P") - (let ((indent (calculate-scheme-indent)) shift-amt beg end - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (skip-chars-forward " \t") - (if (looking-at "[ \t]*;;;") - ;; Don't alter indentation of a ;;; comment line. - nil - (if (listp indent) (setq indent (car indent))) - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - nil - (delete-region beg (point)) - (indent-to indent)) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - ;; If desired, shift remaining lines of expression the same amount. - (and whole-exp (not (zerop shift-amt)) - (save-excursion - (goto-char beg) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point)) - (> end beg)) - (indent-code-rigidly beg end shift-amt))))) - -(defun calculate-scheme-indent (&optional parse-start) - "Return appropriate indentation for current line as scheme code. -In usual case returns an integer: the column to indent to. -Can instead return a list, whose car is the column to indent to. -This means that following lines at the same level of indentation -should not necessarily be indented the same way. -The second element of the list is the buffer position -of the start of the containing expression." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) state paren-depth desired-indent (retry t) - last-sexp containing-sexp first-sexp-list-p) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - ;; Find outermost containing sexp - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; Find innermost containing sexp - (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) - (setq retry nil) - (setq last-sexp (nth 2 state)) - (setq containing-sexp (car (cdr state))) - ;; Position following last unclosed open. - (goto-char (1+ containing-sexp)) - ;; Is there a complete sexp since then? - (if (and last-sexp (> last-sexp (point))) - ;; Yes, but is there a containing sexp after that? - (let ((peek (parse-partial-sexp last-sexp indent-point 0))) - (if (setq retry (car (cdr peek))) (setq state peek)))) - (if (not retry) - ;; Innermost containing sexp found - (progn - (goto-char (1+ containing-sexp)) - (if (not last-sexp) - ;; indent-point immediately follows open paren. - ;; Don't call hook. - (setq desired-indent (current-column)) - ;; Move to first sexp after containing open paren - (parse-partial-sexp (point) last-sexp 0 t) - (setq first-sexp-list-p (looking-at "\\s(")) - (cond - ((> (save-excursion (forward-line 1) (point)) - last-sexp) - ;; Last sexp is on same line as containing sexp. - ;; It's almost certainly a function call. - (parse-partial-sexp (point) last-sexp 0 t) - (if (/= (point) last-sexp) - ;; Indent beneath first argument or, if only one sexp - ;; on line, indent beneath that. - (progn (forward-sexp 1) - (parse-partial-sexp (point) last-sexp 0 t))) - (backward-prefix-chars)) - (t - ;; Indent beneath first sexp on same line as last-sexp. - ;; Again, it's almost certainly a function call. - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (backward-prefix-chars))))))) - ;; If looking at a list, don't call hook. - (if first-sexp-list-p - (setq desired-indent (current-column))) - ;; Point is at the point to indent under unless we are inside a string. - ;; Call indentation hook except when overridden by scheme-indent-offset - ;; or if the desired indentation has already been computed. - (cond ((car (nthcdr 3 state)) - ;; Inside a string, don't change indentation. - (goto-char indent-point) - (skip-chars-forward " \t") - (setq desired-indent (current-column))) - ((and (integerp scheme-indent-offset) containing-sexp) - ;; Indent by constant offset - (goto-char containing-sexp) - (setq desired-indent (+ scheme-indent-offset (current-column)))) - ((not (or desired-indent - (and (boundp 'scheme-indent-function) - scheme-indent-function - (not retry) - (setq desired-indent - (funcall scheme-indent-function - indent-point state))))) - ;; Use default indentation if not computed yet - (setq desired-indent (current-column)))) - desired-indent))) - -(defun scheme-indent-function (indent-point state) - (let ((normal-indent (current-column))) - (save-excursion - (goto-char (1+ (car (cdr state)))) - (re-search-forward "\\sw\\|\\s_") - (if (/= (point) (car (cdr state))) - (let ((function (buffer-substring (progn (forward-char -1) (point)) - (progn (forward-sexp 1) (point)))) - method) - ;; Who cares about this, really? - ;(if (not (string-match "\\\\\\||" function))) - (setq function (downcase function)) - (setq method (get (intern-soft function) 'scheme-indent-function)) - (cond ((integerp method) - (scheme-indent-specform method state indent-point)) - (method - (funcall method state indent-point)) - ((and (> (length function) 3) - (string-equal (substring function 0 3) "def")) - (scheme-indent-defform state indent-point)))))))) - -(defvar scheme-body-indent 2 "") - -(defun scheme-indent-specform (count state indent-point) - (let ((containing-form-start (car (cdr state))) (i count) - body-indent containing-form-column) - ;; Move to the start of containing form, calculate indentation - ;; to use for non-distinguished forms (> count), and move past the - ;; function symbol. scheme-indent-function guarantees that there is at - ;; least one word or symbol character following open paren of containing - ;; form. - (goto-char containing-form-start) - (setq containing-form-column (current-column)) - (setq body-indent (+ scheme-body-indent containing-form-column)) - (forward-char 1) - (forward-sexp 1) - ;; Now find the start of the last form. - (parse-partial-sexp (point) indent-point 1 t) - (while (and (< (point) indent-point) - (condition-case nil - (progn - (setq count (1- count)) - (forward-sexp 1) - (parse-partial-sexp (point) indent-point 1 t)) - (error nil)))) - ;; Point is sitting on first character of last (or count) sexp. - (cond ((> count 0) - ;; A distinguished form. Use double scheme-body-indent. - (list (+ containing-form-column (* 2 scheme-body-indent)) - containing-form-start)) - ;; A non-distinguished form. Use body-indent if there are no - ;; distinguished forms and this is the first undistinguished - ;; form, or if this is the first undistinguished form and - ;; the preceding distinguished form has indentation at least - ;; as great as body-indent. - ((and (= count 0) - (or (= i 0) - (<= body-indent normal-indent))) - body-indent) - (t - normal-indent)))) - -(defun scheme-indent-defform (state indent-point) - (goto-char (car (cdr state))) - (forward-line 1) - (if (> (point) (car (cdr (cdr state)))) - (progn - (goto-char (car (cdr state))) - (+ scheme-body-indent (current-column))))) - -;;; Let is different in Scheme - -(defun would-be-symbol (string) - (not (string-equal (substring string 0 1) "("))) - -(defun next-sexp-as-string () - ;; Assumes that protected by a save-excursion - (forward-sexp 1) - (let ((the-end (point))) - (backward-sexp 1) - (buffer-substring (point) the-end))) - -;; This is correct but too slow. -;; The one below works almost always. -;;(defun scheme-let-indent (state indent-point) -;; (if (would-be-symbol (next-sexp-as-string)) -;; (scheme-indent-specform 2 state indent-point) -;; (scheme-indent-specform 1 state indent-point))) - -(defun scheme-let-indent (state indent-point) - (skip-chars-forward " \t") - (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]") - (scheme-indent-specform 2 state indent-point) - (scheme-indent-specform 1 state indent-point))) - -;; (put 'begin 'scheme-indent-function 0), say, causes begin to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - -(put 'begin 'scheme-indent-function 0) -(put 'case 'scheme-indent-function 1) -(put 'delay 'scheme-indent-function 0) -(put 'do 'scheme-indent-function 2) -(put 'lambda 'scheme-indent-function 1) -(put 'let 'scheme-indent-function 'scheme-let-indent) -(put 'let* 'scheme-indent-function 1) -(put 'letrec 'scheme-indent-function 1) -(put 'sequence 'scheme-indent-function 0) - -(put 'call-with-input-file 'scheme-indent-function 1) -(put 'with-input-from-file 'scheme-indent-function 1) -(put 'with-input-from-port 'scheme-indent-function 1) -(put 'call-with-output-file 'scheme-indent-function 1) -(put 'with-output-to-file 'scheme-indent-function 1) -(put 'with-output-to-port 'scheme-indent-function 1) - -;;;; MIT Scheme specific indentation. - -(if scheme-mit-dialect - (progn - (put 'fluid-let 'scheme-indent-function 1) - (put 'in-package 'scheme-indent-function 1) - (put 'let-syntax 'scheme-indent-function 1) - (put 'local-declare 'scheme-indent-function 1) - (put 'macro 'scheme-indent-function 1) - (put 'make-environment 'scheme-indent-function 0) - (put 'named-lambda 'scheme-indent-function 1) - (put 'using-syntax 'scheme-indent-function 1) - - (put 'with-input-from-string 'scheme-indent-function 1) - (put 'with-output-to-string 'scheme-indent-function 0) - (put 'with-values 'scheme-indent-function 1) - - (put 'syntax-table-define 'scheme-indent-function 2) - (put 'list-transform-positive 'scheme-indent-function 1) - (put 'list-transform-negative 'scheme-indent-function 1) - (put 'list-search-positive 'scheme-indent-function 1) - (put 'list-search-negative 'scheme-indent-function 1) - - (put 'access-components 'scheme-indent-function 1) - (put 'assignment-components 'scheme-indent-function 1) - (put 'combination-components 'scheme-indent-function 1) - (put 'comment-components 'scheme-indent-function 1) - (put 'conditional-components 'scheme-indent-function 1) - (put 'disjunction-components 'scheme-indent-function 1) - (put 'declaration-components 'scheme-indent-function 1) - (put 'definition-components 'scheme-indent-function 1) - (put 'delay-components 'scheme-indent-function 1) - (put 'in-package-components 'scheme-indent-function 1) - (put 'lambda-components 'scheme-indent-function 1) - (put 'lambda-components* 'scheme-indent-function 1) - (put 'lambda-components** 'scheme-indent-function 1) - (put 'open-block-components 'scheme-indent-function 1) - (put 'pathname-components 'scheme-indent-function 1) - (put 'procedure-components 'scheme-indent-function 1) - (put 'sequence-components 'scheme-indent-function 1) - (put 'unassigned\?-components 'scheme-indent-function 1) - (put 'unbound\?-components 'scheme-indent-function 1) - (put 'variable-components 'scheme-indent-function 1))) - -(defun scheme-indent-sexp () - "Indent each line of the list starting just after point." - (interactive) - (let ((indent-stack (list nil)) (next-depth 0) bol - outer-loop-done inner-loop-done state this-indent) - (save-excursion (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (not outer-loop-done) - (setq last-depth next-depth - innerloop-done nil) - (while (and (not innerloop-done) - (not (setq outer-loop-done (eobp)))) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (car (nthcdr 4 state)) - (progn (indent-for-comment) - (end-of-line) - (setcar (nthcdr 4 state) nil))) - (if (car (nthcdr 3 state)) - (progn - (forward-line 1) - (setcar (nthcdr 5 state) nil)) - (setq innerloop-done t))) - (if (setq outer-loop-done (<= next-depth 0)) - nil - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - last-depth (1+ last-depth))) - (forward-line 1) - (setq bol (point)) - (skip-chars-forward " \t") - (if (or (eobp) (looking-at "[;\n]")) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - (setq this-indent (car indent-stack)) - (let ((val (calculate-scheme-indent - (if (car indent-stack) (- (car indent-stack)))))) - (if (integerp val) - (setcar indent-stack - (setq this-indent val)) - (if (cdr val) - (setcar indent-stack (- (car (cdr val))))) - (setq this-indent (car val))))) - (if (/= (current-column) this-indent) - (progn (delete-region bol (point)) - (indent-to this-indent))))))))) - -(provide 'scheme) - -;;; scheme.el ends here diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el deleted file mode 100644 index 6ba2856938f..00000000000 --- a/lisp/progmodes/sh-script.el +++ /dev/null @@ -1,1388 +0,0 @@ -;;; sh-script.el --- shell-script editing commands for Emacs - -;; Copyright (C) 1993, 1994, 1995, 1996 by Free Software Foundation, Inc. - -;; Author: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 -;; Version: 2.0e -;; Maintainer: FSF -;; Keywords: languages, unix - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Major mode for editing shell scripts. Bourne, C and rc shells as well -;; as various derivatives are supported and easily derived from. Structured -;; statements can be inserted with one command or abbrev. Completion is -;; available for filenames, variables known from the script, the shell and -;; the environment as well as commands. - -;;; Known Bugs: - -;; - In Bourne the keyword `in' is not anchored to case, for, select ... -;; - Variables in `"' strings aren't fontified because there's no way of -;; syntactically distinguishing those from `'' strings. - -;;; Code: - -;; page 1: variables and settings -;; page 2: mode-command and utility functions -;; page 3: statement syntax-commands for various shells -;; page 4: various other commands - -(require 'executable) - -(defvar sh-ancestor-alist - '((ash . sh) - (bash . jsh) - (dtksh . ksh) - (es . rc) - (itcsh . tcsh) - (jcsh . csh) - (jsh . sh) - (ksh . ksh88) - (ksh88 . jsh) - (oash . sh) - (pdksh . ksh88) - (posix . sh) - (tcsh . csh) - (wksh . ksh88) - (wsh . sh) - (zsh . ksh88)) - "*Alist showing the direct ancestor of various shells. -This is the basis for `sh-feature'. See also `sh-alias-alist'. -By default we have the following three hierarchies: - -csh C Shell - jcsh C Shell with Job Control - tcsh Toronto C Shell - itcsh ? Toronto C Shell -rc Plan 9 Shell - es Extensible Shell -sh Bourne Shell - ash ? Shell - jsh Bourne Shell with Job Control - bash GNU Bourne Again Shell - ksh88 Korn Shell '88 - ksh Korn Shell '93 - dtksh CDE Desktop Korn Shell - pdksh Public Domain Korn Shell - wksh Window Korn Shell - zsh Z Shell - oash SCO OA (curses) Shell - posix IEEE 1003.2 Shell Standard - wsh ? Shell") - - -(defvar sh-alias-alist - (nconc (if (eq system-type 'gnu/linux) - '((csh . tcsh) - (ksh . pdksh))) - ;; for the time being - '((ksh . ksh88) - (sh5 . sh))) - "*Alist for transforming shell names to what they really are. -Use this where the name of the executable doesn't correspond to the type of -shell it really is.") - - -(defvar sh-shell-file - (or - ;; On MSDOS and Windows, collapse $SHELL to lower-case and remove - ;; the executable extension, so comparisons with the list of - ;; known shells work. - (and (memq system-type '(ms-dos windows-nt)) - (file-name-sans-extension (downcase (getenv "SHELL")))) - (getenv "SHELL") - "/bin/sh") - "*The executable file name for the shell being programmed.") - - -(defvar sh-shell-arg - ;; bash does not need any options when run in a shell script, - '((bash) - (csh . "-f") - (pdksh) - ;; Bill_Mann@praxisint.com says -p with ksh can do harm. - (ksh88) - ;; -p means don't initialize functions from the environment. - (rc . "-p") - ;; Someone proposed -motif, but we don't want to encourage - ;; use of a non-free widget set. - (wksh) - ;; -f means don't run .zshrc. - (zsh . "-f")) - "*Single argument string for the magic number. See `sh-feature'.") - -(defvar sh-shell-variables nil - "Alist of shell variable names that should be included in completion. -These are used for completion in addition to all the variables named -in `process-environment'. Each element looks like (VAR . VAR), where -the car and cdr are the same symbol.") - -(defvar sh-shell-variables-initialized nil - "Non-nil if `sh-shell-variables' is initialized.") - -(defun sh-canonicalize-shell (shell) - "Convert a shell name SHELL to the one we should handle it as." - (or (symbolp shell) - (setq shell (intern shell))) - (or (cdr (assq shell sh-alias-alist)) - shell)) - -(defvar sh-shell (sh-canonicalize-shell (file-name-nondirectory sh-shell-file)) - "The shell being programmed. This is set by \\[sh-set-shell].") - -;;; I turned off this feature because it doesn't permit typing commands -;;; in the usual way without help. -;;;(defvar sh-abbrevs -;;; '((csh eval sh-abbrevs shell -;;; "switch" 'sh-case -;;; "getopts" 'sh-while-getopts) - -;;; (es eval sh-abbrevs shell -;;; "function" 'sh-function) - -;;; (ksh88 eval sh-abbrevs sh -;;; "select" 'sh-select) - -;;; (rc eval sh-abbrevs shell -;;; "case" 'sh-case -;;; "function" 'sh-function) - -;;; (sh eval sh-abbrevs shell -;;; "case" 'sh-case -;;; "function" 'sh-function -;;; "until" 'sh-until -;;; "getopts" 'sh-while-getopts) - -;;; ;; The next entry is only used for defining the others -;;; (shell "for" sh-for -;;; "loop" sh-indexed-loop -;;; "if" sh-if -;;; "tmpfile" sh-tmp-file -;;; "while" sh-while) - -;;; (zsh eval sh-abbrevs ksh88 -;;; "repeat" 'sh-repeat)) -;;; "Abbrev-table used in Shell-Script mode. See `sh-feature'. -;;;Due to the internal workings of abbrev tables, the shell name symbol is -;;;actually defined as the table for the like of \\[edit-abbrevs].") - - - -(defvar sh-mode-syntax-table - '((sh eval sh-mode-syntax-table () - ?\# "<" - ?\^l ">#" - ?\n ">#" - ?\" "\"\"" - ?\' "\"'" - ?\` "\"`" - ?$ "\\" ; `escape' so $# doesn't start a comment - ?! "_" - ?% "_" - ?: "_" - ?. "_" - ?^ "_" - ?~ "_") - (csh eval identity sh) - (rc eval identity sh)) - "Syntax-table used in Shell-Script mode. See `sh-feature'.") - - - -(defvar sh-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Insert"))) - (define-key map "\C-c(" 'sh-function) - (define-key map "\C-c\C-w" 'sh-while) - (define-key map "\C-c\C-u" 'sh-until) - (define-key map "\C-c\C-t" 'sh-tmp-file) - (define-key map "\C-c\C-s" 'sh-select) - (define-key map "\C-c\C-r" 'sh-repeat) - (define-key map "\C-c\C-o" 'sh-while-getopts) - (define-key map "\C-c\C-l" 'sh-indexed-loop) - (define-key map "\C-c\C-i" 'sh-if) - (define-key map "\C-c\C-f" 'sh-for) - (define-key map "\C-c\C-c" 'sh-case) - - (define-key map "=" 'sh-assignment) - (define-key map "\C-c+" 'sh-add) - (define-key map "\C-\M-x" 'sh-execute-region) - (define-key map "\C-c\C-x" 'executable-interpret) - (define-key map "<" 'sh-maybe-here-document) - (define-key map "(" 'skeleton-pair-insert-maybe) - (define-key map "{" 'skeleton-pair-insert-maybe) - (define-key map "[" 'skeleton-pair-insert-maybe) - (define-key map "'" 'skeleton-pair-insert-maybe) - (define-key map "`" 'skeleton-pair-insert-maybe) - (define-key map "\"" 'skeleton-pair-insert-maybe) - - (define-key map "\t" 'sh-indent-line) - (substitute-key-definition 'complete-tag 'comint-dynamic-complete - map (current-global-map)) - (substitute-key-definition 'newline-and-indent 'sh-newline-and-indent - map (current-global-map)) - (substitute-key-definition 'delete-backward-char - 'backward-delete-char-untabify - map (current-global-map)) - (define-key map "\C-c:" 'sh-set-shell) - (substitute-key-definition 'beginning-of-defun - 'sh-beginning-of-compound-command - map (current-global-map)) - (substitute-key-definition 'backward-sentence 'sh-beginning-of-command - map (current-global-map)) - (substitute-key-definition 'forward-sentence 'sh-end-of-command - map (current-global-map)) - (define-key map [menu-bar insert] (cons "Insert" menu-map)) - (define-key menu-map [sh-while] '("While Loop" . sh-while)) - (define-key menu-map [sh-until] '("Until Loop" . sh-until)) - (define-key menu-map [sh-tmp-file] '("Temporary File" . sh-tmp-file)) - (define-key menu-map [sh-select] '("Select Statement" . sh-select)) - (define-key menu-map [sh-repeat] '("Repeat Loop" . sh-repeat)) - (define-key menu-map [sh-while-getopts] - '("Options Loop" . sh-while-getopts)) - (define-key menu-map [sh-indexed-loop] - '("Indexed Loop" . sh-indexed-loop)) - (define-key menu-map [sh-if] '("If Statement" . sh-if)) - (define-key menu-map [sh-for] '("For Loop" . sh-for)) - (define-key menu-map [sh-case] '("Case Statement" . sh-case)) - map) - "Keymap used in Shell-Script mode.") - - - -(defvar sh-dynamic-complete-functions - '(shell-dynamic-complete-environment-variable - shell-dynamic-complete-command - comint-dynamic-complete-filename) - "*Functions for doing TAB dynamic completion.") - - -(defvar sh-require-final-newline - '((csh . t) - (pdksh . t) - (rc eval . require-final-newline) - (sh eval . require-final-newline)) - "*Value of `require-final-newline' in Shell-Script mode buffers. -See `sh-feature'.") - - -(defvar sh-assignment-regexp - '((csh . "\\<\\([a-zA-Z0-9_]+\\)\\(\\[.+\\]\\)?[ \t]*[-+*/%^]?=") - ;; actually spaces are only supported in let/(( ... )) - (ksh88 . "\\<\\([a-zA-Z0-9_]+\\)\\(\\[.+\\]\\)?[ \t]*\\([-+*/%&|~^]\\|<<\\|>>\\)?=") - (rc . "\\<\\([a-zA-Z0-9_*]+\\)[ \t]*=") - (sh . "\\<\\([a-zA-Z0-9_]+\\)=")) - "*Regexp for the variable name and what may follow in an assignment. -First grouping matches the variable name. This is upto and including the `=' -sign. See `sh-feature'.") - - -(defvar sh-indentation 4 - "The width for further indentation in Shell-Script mode.") - - -(defvar sh-remember-variable-min 3 - "*Don't remember variables less than this length for completing reads.") - - -(defvar sh-header-marker nil - "When non-`nil' is the end of header for prepending by \\[sh-execute-region]. -That command is also used for setting this variable.") - - -(defvar sh-beginning-of-command - "\\([;({`|&]\\|\\`\\|[^\\]\n\\)[ \t]*\\([/~a-zA-Z0-9:]\\)" - "*Regexp to determine the beginning of a shell command. -The actual command starts at the beginning of the second \\(grouping\\).") - - -(defvar sh-end-of-command - "\\([/~a-zA-Z0-9:]\\)[ \t]*\\([;#)}`|&]\\|$\\)" - "*Regexp to determine the end of a shell command. -The actual command ends at the end of the first \\(grouping\\).") - - - -(defvar sh-here-document-word "EOF" - "Word to delimit here documents.") - -(defvar sh-test - '((sh "[ ]" . 3) - (ksh88 "[[ ]]" . 4)) - "Initial input in Bourne if, while and until skeletons. See `sh-feature'.") - - -(defvar sh-builtins - '((bash eval sh-append posix - "alias" "bg" "bind" "builtin" "declare" "dirs" "enable" "fc" "fg" - "help" "history" "jobs" "kill" "let" "local" "popd" "pushd" "source" - "suspend" "typeset" "unalias") - - ;; The next entry is only used for defining the others - (bourne eval sh-append shell - "eval" "export" "getopts" "newgrp" "pwd" "read" "readonly" - "times" "ulimit") - - (csh eval sh-append shell - "alias" "chdir" "glob" "history" "limit" "nice" "nohup" "rehash" - "setenv" "source" "time" "unalias" "unhash") - - (dtksh eval identity wksh) - - (es "access" "apids" "cd" "echo" "eval" "false" "let" "limit" "local" - "newpgrp" "result" "time" "umask" "var" "vars" "wait" "whatis") - - (jsh eval sh-append sh - "bg" "fg" "jobs" "kill" "stop" "suspend") - - (jcsh eval sh-append csh - "bg" "fg" "jobs" "kill" "notify" "stop" "suspend") - - (ksh88 eval sh-append bourne - "alias" "bg" "false" "fc" "fg" "jobs" "kill" "let" "print" "time" - "typeset" "unalias" "whence") - - (oash eval sh-append sh - "checkwin" "dateline" "error" "form" "menu" "newwin" "oadeinit" - "oaed" "oahelp" "oainit" "pp" "ppfile" "scan" "scrollok" "wattr" - "wclear" "werase" "win" "wmclose" "wmmessage" "wmopen" "wmove" - "wmtitle" "wrefresh") - - (pdksh eval sh-append ksh88 - "bind") - - (posix eval sh-append sh - "command") - - (rc "builtin" "cd" "echo" "eval" "limit" "newpgrp" "shift" "umask" "wait" - "whatis") - - (sh eval sh-append bourne - "hash" "test" "type") - - ;; The next entry is only used for defining the others - (shell "cd" "echo" "eval" "set" "shift" "umask" "unset" "wait") - - (wksh eval sh-append ksh88 - "Xt[A-Z][A-Za-z]*") - - (zsh eval sh-append ksh88 - "autoload" "bindkey" "builtin" "chdir" "compctl" "declare" "dirs" - "disable" "disown" "echotc" "enable" "functions" "getln" "hash" - "history" "integer" "limit" "local" "log" "popd" "pushd" "r" - "readonly" "rehash" "sched" "setopt" "source" "suspend" "true" - "ttyctl" "type" "unfunction" "unhash" "unlimit" "unsetopt" "vared" - "which")) - "*List of all shell builtins for completing read and fontification. -Note that on some systems not all builtins are available or some are -implemented as aliases. See `sh-feature'.") - - - -(defvar sh-leading-keywords - '((csh "else") - - (es "true" "unwind-protect" "whatis") - - (rc "else") - - (sh "do" "elif" "else" "if" "then" "trap" "type" "until" "while")) - "*List of keywords that may be immediately followed by a builtin or keyword. -Given some confusion between keywords and builtins depending on shell and -system, the distinction here has been based on whether they influence the -flow of control or syntax. See `sh-feature'.") - - -(defvar sh-other-keywords - '((bash eval sh-append bourne - "bye" "logout") - - ;; The next entry is only used for defining the others - (bourne eval sh-append sh - "function") - - (csh eval sh-append shell - "breaksw" "default" "end" "endif" "endsw" "foreach" "goto" - "if" "logout" "onintr" "repeat" "switch" "then" "while") - - (es "break" "catch" "exec" "exit" "fn" "for" "forever" "fork" "if" - "return" "throw" "while") - - (ksh88 eval sh-append bourne - "select") - - (rc "break" "case" "exec" "exit" "fn" "for" "if" "in" "return" "switch" - "while") - - (sh eval sh-append shell - "done" "esac" "fi" "for" "in" "return") - - ;; The next entry is only used for defining the others - (shell "break" "case" "continue" "exec" "exit") - - (zsh eval sh-append bash - "select")) - "*List of keywords not in `sh-leading-keywords'. -See `sh-feature'.") - - - -(defvar sh-variables - '((bash eval sh-append sh - "allow_null_glob_expansion" "auto_resume" "BASH" "BASH_VERSION" - "cdable_vars" "ENV" "EUID" "FCEDIT" "FIGNORE" "glob_dot_filenames" - "histchars" "HISTFILE" "HISTFILESIZE" "history_control" "HISTSIZE" - "hostname_completion_file" "HOSTTYPE" "IGNOREEOF" "ignoreeof" - "LINENO" "MAIL_WARNING" "noclobber" "nolinks" "notify" - "no_exit_on_failed_exec" "NO_PROMPT_VARS" "OLDPWD" "OPTERR" "PPID" - "PROMPT_COMMAND" "PS4" "pushd_silent" "PWD" "RANDOM" "REPLY" - "SECONDS" "SHLVL" "TMOUT" "UID") - - (csh eval sh-append shell - "argv" "cdpath" "child" "echo" "histchars" "history" "home" - "ignoreeof" "mail" "noclobber" "noglob" "nonomatch" "path" "prompt" - "shell" "status" "time" "verbose") - - (es eval sh-append shell - "apid" "cdpath" "CDPATH" "history" "home" "ifs" "noexport" "path" - "pid" "prompt" "signals") - - (jcsh eval sh-append csh - "notify") - - (ksh88 eval sh-append sh - "ENV" "ERRNO" "FCEDIT" "FPATH" "HISTFILE" "HISTSIZE" "LINENO" - "OLDPWD" "PPID" "PS3" "PS4" "PWD" "RANDOM" "REPLY" "SECONDS" - "TMOUT") - - (oash eval sh-append sh - "FIELD" "FIELD_MAX" "LAST_KEY" "OALIB" "PP_ITEM" "PP_NUM") - - (rc eval sh-append shell - "apid" "apids" "cdpath" "CDPATH" "history" "home" "ifs" "path" "pid" - "prompt" "status") - - (sh eval sh-append shell - "CDPATH" "IFS" "OPTARG" "OPTIND" "PS1" "PS2") - - ;; The next entry is only used for defining the others - (shell "COLUMNS" "EDITOR" "HOME" "HUSHLOGIN" "LANG" "LC_COLLATE" - "LC_CTYPE" "LC_MESSAGES" "LC_MONETARY" "LC_NUMERIC" "LC_TIME" - "LINES" "LOGNAME" "MAIL" "MAILCHECK" "MAILPATH" "PAGER" "PATH" - "SHELL" "TERM" "TERMCAP" "TERMINFO" "VISUAL") - - (tcsh eval sh-append csh - "addsuffix" "ampm" "autocorrect" "autoexpand" "autolist" - "autologout" "chase_symlinks" "correct" "dextract" "edit" "el" - "fignore" "gid" "histlit" "HOST" "HOSTTYPE" "HPATH" - "ignore_symlinks" "listjobs" "listlinks" "listmax" "matchbeep" - "nobeep" "NOREBIND" "oid" "printexitvalue" "prompt2" "prompt3" - "pushdsilent" "pushdtohome" "recexact" "recognize_only_executables" - "rmstar" "savehist" "SHLVL" "showdots" "sl" "SYSTYPE" "tcsh" "term" - "tperiod" "tty" "uid" "version" "visiblebell" "watch" "who" - "wordchars") - - (zsh eval sh-append ksh88 - "BAUD" "bindcmds" "cdpath" "DIRSTACKSIZE" "fignore" "FIGNORE" "fpath" - "HISTCHARS" "hostcmds" "hosts" "HOSTS" "LISTMAX" "LITHISTSIZE" - "LOGCHECK" "mailpath" "manpath" "NULLCMD" "optcmds" "path" "POSTEDIT" - "prompt" "PROMPT" "PROMPT2" "PROMPT3" "PROMPT4" "psvar" "PSVAR" - "READNULLCMD" "REPORTTIME" "RPROMPT" "RPS1" "SAVEHIST" "SPROMPT" - "STTY" "TIMEFMT" "TMOUT" "TMPPREFIX" "varcmds" "watch" "WATCH" - "WATCHFMT" "WORDCHARS" "ZDOTDIR")) - "List of all shell variables available for completing read. -See `sh-feature'.") - - - -(defvar sh-font-lock-keywords - '((csh eval sh-append shell - '("\\${?[#?]?\\([A-Za-z_][A-Za-z0-9_]*\\|0\\)" 1 - font-lock-variable-name-face)) - - (es eval sh-append executable-font-lock-keywords - '("\\$#?\\([A-Za-z_][A-Za-z0-9_]*\\|[0-9]+\\)" 1 - font-lock-variable-name-face)) - - (rc eval identity es) - - (sh eval sh-append shell - '("\\$\\({#?\\)?\\([A-Za-z_][A-Za-z0-9_]*\\|[-#?@!]\\)" 2 - font-lock-variable-name-face)) - - ;; The next entry is only used for defining the others - (shell eval sh-append executable-font-lock-keywords - '("\\\\[^A-Za-z0-9]" 0 font-lock-string-face) - '("\\${?\\([A-Za-z_][A-Za-z0-9_]*\\|[0-9]+\\|[$*_]\\)" 1 - font-lock-variable-name-face))) - "*Rules for highlighting shell scripts. See `sh-feature'.") - -(defvar sh-font-lock-keywords-1 - '((sh "[ \t]in\\>")) - "*Additional rules for highlighting shell scripts. See `sh-feature'.") - -(defvar sh-font-lock-keywords-2 () - "*Yet more rules for highlighting shell scripts. See `sh-feature'.") - - -;; mode-command and utility functions - -;;;###autoload -(put 'sh-mode 'mode-class 'special) - -;;;###autoload -(defun sh-mode () - "Major mode for editing shell scripts. -This mode works for many shells, since they all have roughly the same syntax, -as far as commands, arguments, variables, pipes, comments etc. are concerned. -Unless the file's magic number indicates the shell, your usual shell is -assumed. Since filenames rarely give a clue, they are not further analyzed. - -This mode adapts to the variations between shells (see `sh-set-shell') by -means of an inheritance based feature lookup (see `sh-feature'). This -mechanism applies to all variables (including skeletons) that pertain to -shell-specific features. - -The default style of this mode is that of Rosenblatt's Korn shell book. -The syntax of the statements varies with the shell being used. The -following commands are available, based on the current shell's syntax: - -\\[sh-case] case statement -\\[sh-for] for loop -\\[sh-function] function definition -\\[sh-if] if statement -\\[sh-indexed-loop] indexed loop from 1 to n -\\[sh-while-getopts] while getopts loop -\\[sh-repeat] repeat loop -\\[sh-select] select loop -\\[sh-until] until loop -\\[sh-while] while loop - -\\[backward-delete-char-untabify] Delete backward one position, even if it was a tab. -\\[sh-newline-and-indent] Delete unquoted space and indent new line same as this one. -\\[sh-end-of-command] Go to end of successive commands. -\\[sh-beginning-of-command] Go to beginning of successive commands. -\\[sh-set-shell] Set this buffer's shell, and maybe its magic number. -\\[sh-execute-region] Have optional header and region be executed in a subshell. - -\\[sh-maybe-here-document] Without prefix, following an unquoted < inserts here document. -{, (, [, ', \", ` - Unless quoted with \\, insert the pairs {}, (), [], or '', \"\", ``. - -If you generally program a shell different from your login shell you can -set `sh-shell-file' accordingly. If your shell's file name doesn't correctly -indicate what shell it is use `sh-alias-alist' to translate. - -If your shell gives error messages with line numbers, you can use \\[executable-interpret] -with your script for an edit-interpret-debug cycle." - (interactive) - (kill-all-local-variables) - (use-local-map sh-mode-map) - (make-local-variable 'indent-line-function) - (make-local-variable 'indent-region-function) - (make-local-variable 'skeleton-end-hook) - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (make-local-variable 'comment-start) - (make-local-variable 'comment-start-skip) - (make-local-variable 'require-final-newline) - (make-local-variable 'sh-header-marker) - (make-local-variable 'sh-shell-file) - (make-local-variable 'sh-shell) - (make-local-variable 'skeleton-pair-alist) - (make-local-variable 'skeleton-pair-filter) - (make-local-variable 'comint-dynamic-complete-functions) - (make-local-variable 'comint-prompt-regexp) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'skeleton-filter) - (make-local-variable 'skeleton-newline-indent-rigidly) - (make-local-variable 'sh-shell-variables) - (make-local-variable 'sh-shell-variables-initialized) - (setq major-mode 'sh-mode - mode-name "Shell-script" - indent-line-function 'sh-indent-line - ;; not very clever, but enables wrapping skeletons around regions - indent-region-function (lambda (b e) - (save-excursion - (goto-char b) - (skip-syntax-backward "-") - (setq b (point)) - (goto-char e) - (skip-syntax-backward "-") - (indent-rigidly b (point) sh-indentation))) - skeleton-end-hook (lambda () - (or (eolp) (newline) (indent-relative))) - paragraph-start (concat page-delimiter "\\|$") - paragraph-separate paragraph-start - comment-start "# " - comint-dynamic-complete-functions sh-dynamic-complete-functions - ;; we can't look if previous line ended with `\' - comint-prompt-regexp "^[ \t]*" - font-lock-defaults - `((sh-font-lock-keywords - sh-font-lock-keywords-1 - sh-font-lock-keywords-2) - nil nil - ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w"))) - skeleton-pair-alist '((?` _ ?`)) - skeleton-pair-filter 'sh-quoted-p - skeleton-further-elements '((< '(- (min sh-indentation - (current-column))))) - skeleton-filter 'sh-feature - skeleton-newline-indent-rigidly t) - ;; Parse or insert magic number for exec, and set all variables depending - ;; on the shell thus determined. - (let ((interpreter - (save-excursion - (goto-char (point-min)) - (if (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^ \t\n]+\\)") - (buffer-substring (match-beginning 2) - (match-end 2)))))) - (if interpreter - (sh-set-shell interpreter nil nil))) - (run-hooks 'sh-mode-hook)) -;;;###autoload -(defalias 'shell-script-mode 'sh-mode) - - -(defun sh-font-lock-keywords (&optional keywords) - "Function to get simple fontification based on `sh-font-lock-keywords'. -This adds rules for comments and assignments." - (sh-feature sh-font-lock-keywords - (lambda (list) - `((,(sh-feature sh-assignment-regexp) - 1 font-lock-variable-name-face) - ,@keywords - ,@list)))) - -(defun sh-font-lock-keywords-1 (&optional builtins) - "Function to get better fontification including keywords." - (let ((keywords (concat "\\([;(){}`|&]\\|^\\)[ \t]*\\(\\(\\(" - (mapconcat 'identity - (sh-feature sh-leading-keywords) - "\\|") - "\\)[ \t]+\\)?\\(" - (mapconcat 'identity - (append (sh-feature sh-leading-keywords) - (sh-feature sh-other-keywords)) - "\\|") - "\\)"))) - (sh-font-lock-keywords - `(,@(if builtins - `((,(concat keywords "[ \t]+\\)?\\(" - (mapconcat 'identity (sh-feature sh-builtins) "\\|") - "\\)\\>") - (2 font-lock-keyword-face nil t) - (6 font-lock-builtin-face)) - ,@(sh-feature sh-font-lock-keywords-2))) - (,(concat keywords "\\)\\>") - 2 font-lock-keyword-face) - ,@(sh-feature sh-font-lock-keywords-1))))) - -(defun sh-font-lock-keywords-2 () - "Function to get better fontification including keywords and builtins." - (sh-font-lock-keywords-1 t)) - - -(defun sh-set-shell (shell &optional no-query-flag insert-flag) - "Set this buffer's shell to SHELL (a string). -Makes this script executable via `executable-set-magic', and sets up the -proper starting #!-line, if INSERT-FLAG is non-nil. -Calls the value of `sh-set-shell-hook' if set." - (interactive (list (completing-read "Name or path of shell: " - interpreter-mode-alist - (lambda (x) (eq (cdr x) 'sh-mode))) - (eq executable-query 'function) - t)) - (setq sh-shell (intern (file-name-nondirectory shell)) - sh-shell (or (cdr (assq sh-shell sh-alias-alist)) - sh-shell)) - (if insert-flag - (setq sh-shell-file - (executable-set-magic shell (sh-feature sh-shell-arg) - no-query-flag insert-flag))) - (setq require-final-newline (sh-feature sh-require-final-newline) -;;; local-abbrev-table (sh-feature sh-abbrevs) - font-lock-keywords nil ; force resetting - font-lock-syntax-table nil - comment-start-skip "#+[\t ]*" - mode-line-process (format "[%s]" sh-shell) - sh-shell-variables nil - sh-shell-variables-initialized nil - shell (sh-feature sh-variables)) - (set-syntax-table (sh-feature sh-mode-syntax-table)) - (while shell - (sh-remember-variable (car shell)) - (setq shell (cdr shell))) - (and (boundp 'font-lock-mode) - font-lock-mode - (font-lock-mode (font-lock-mode 0))) - (run-hooks 'sh-set-shell-hook)) - - - -(defun sh-feature (list &optional function) - "Index ALIST by the current shell. -If ALIST isn't a list where every element is a cons, it is returned as is. -Else indexing follows an inheritance logic which works in two ways: - - - Fall back on successive ancestors (see `sh-ancestor-alist') as long as - the alist contains no value for the current shell. - - - If the value thus looked up is a list starting with `eval' its `cdr' is - first evaluated. If that is also a list and the first argument is a - symbol in ALIST it is not evaluated, but rather recursively looked up in - ALIST to allow the function called to define the value for one shell to be - derived from another shell. While calling the function, is the car of the - alist element is the current shell. - The value thus determined is physically replaced into the alist. - -Optional FUNCTION is applied to the determined value and the result is cached -in ALIST." - (or (if (consp list) - (let ((l list)) - (while (and l (consp (car l))) - (setq l (cdr l))) - (if l list))) - (if function - (cdr (assoc (setq function (cons sh-shell function)) list))) - (let ((sh-shell sh-shell) - elt val) - (while (and sh-shell - (not (setq elt (assq sh-shell list)))) - (setq sh-shell (cdr (assq sh-shell sh-ancestor-alist)))) - (if (and (consp (setq val (cdr elt))) - (eq (car val) 'eval)) - (setcdr elt - (setq val - (eval (if (consp (setq val (cdr val))) - (let ((sh-shell (car (cdr val))) - function) - (if (assq sh-shell list) - (setcar (cdr val) - (list 'quote - (sh-feature list)))) - val) - val))))) - (if function - (nconc list - (list (cons function - (setq sh-shell (car function) - val (funcall (cdr function) val)))))) - val))) - - - -;;; I commented this out because nobody calls it -- rms. -;;;(defun sh-abbrevs (ancestor &rest list) -;;; "Iff it isn't, define the current shell as abbrev table and fill that. -;;;Abbrev table will inherit all abbrevs from ANCESTOR, which is either an abbrev -;;;table or a list of (NAME1 EXPANSION1 ...). In addition it will define abbrevs -;;;according to the remaining arguments NAMEi EXPANSIONi ... -;;;EXPANSION may be either a string or a skeleton command." -;;; (or (if (boundp sh-shell) -;;; (symbol-value sh-shell)) -;;; (progn -;;; (if (listp ancestor) -;;; (nconc list ancestor)) -;;; (define-abbrev-table sh-shell ()) -;;; (if (vectorp ancestor) -;;; (mapatoms (lambda (atom) -;;; (or (eq atom 0) -;;; (define-abbrev (symbol-value sh-shell) -;;; (symbol-name atom) -;;; (symbol-value atom) -;;; (symbol-function atom)))) -;;; ancestor)) -;;; (while list -;;; (define-abbrev (symbol-value sh-shell) -;;; (car list) -;;; (if (stringp (car (cdr list))) -;;; (car (cdr list)) -;;; "") -;;; (if (symbolp (car (cdr list))) -;;; (car (cdr list)))) -;;; (setq list (cdr (cdr list))))) -;;; (symbol-value sh-shell))) - - -(defun sh-mode-syntax-table (table &rest list) - "Copy TABLE and set syntax for successive CHARs according to strings S." - (setq table (copy-syntax-table table)) - (while list - (modify-syntax-entry (car list) (car (cdr list)) table) - (setq list (cdr (cdr list)))) - table) - - -(defun sh-append (ancestor &rest list) - "Return list composed of first argument (a list) physically appended to rest." - (nconc list ancestor)) - - -(defun sh-modify (skeleton &rest list) - "Modify a copy of SKELETON by replacing I1 with REPL1, I2 with REPL2 ..." - (setq skeleton (copy-sequence skeleton)) - (while list - (setcar (or (nthcdr (car list) skeleton) - (error "Index %d out of bounds" (car list))) - (car (cdr list))) - (setq list (nthcdr 2 list))) - skeleton) - - -(defun sh-indent-line () - "Indent as far as preceding non-empty line, then by steps of `sh-indentation'. -Lines containing only comments are considered empty." - (interactive) - (let ((previous (save-excursion - (while (and (not (bobp)) - (progn - (forward-line -1) - (back-to-indentation) - (or (eolp) - (eq (following-char) ?#))))) - (current-column))) - current) - (save-excursion - (indent-to (if (eq this-command 'newline-and-indent) - previous - (if (< (current-column) - (setq current (progn (back-to-indentation) - (current-column)))) - (if (eolp) previous 0) - (delete-region (point) - (progn (beginning-of-line) (point))) - (if (eolp) - (max previous (* (1+ (/ current sh-indentation)) - sh-indentation)) - (* (1+ (/ current sh-indentation)) sh-indentation)))))) - (if (< (current-column) (current-indentation)) - (skip-chars-forward " \t")))) - - -(defun sh-execute-region (start end &optional flag) - "Pass optional header and region to a subshell for noninteractive execution. -The working directory is that of the buffer, and only environment variables -are already set which is why you can mark a header within the script. - -With a positive prefix ARG, instead of sending region, define header from -beginning of buffer to point. With a negative prefix ARG, instead of sending -region, clear header." - (interactive "r\nP") - (if flag - (setq sh-header-marker (if (> (prefix-numeric-value flag) 0) - (point-marker))) - (if sh-header-marker - (save-excursion - (let (buffer-undo-list) - (goto-char sh-header-marker) - (append-to-buffer (current-buffer) start end) - (shell-command-on-region (point-min) - (setq end (+ sh-header-marker - (- end start))) - sh-shell-file) - (delete-region sh-header-marker end))) - (shell-command-on-region start end (concat sh-shell-file " -"))))) - - -(defun sh-remember-variable (var) - "Make VARIABLE available for future completing reads in this buffer." - (or (< (length var) sh-remember-variable-min) - (getenv var) - (assoc var sh-shell-variables) - (setq sh-shell-variables (cons (cons var var) sh-shell-variables))) - var) - - - -(defun sh-quoted-p () - "Is point preceded by an odd number of backslashes?" - (eq -1 (% (save-excursion (skip-chars-backward "\\\\")) 2))) - -;; statement syntax-commands for various shells - -;; You are welcome to add the syntax or even completely new statements as -;; appropriate for your favorite shell. - -(define-skeleton sh-case - "Insert a case/switch statement. See `sh-feature'." - (csh "expression: " - "switch( " str " )" \n - > "case " (read-string "pattern: ") ?: \n - > _ \n - "breaksw" \n - ( "other pattern, %s: " - < "case " str ?: \n - > _ \n - "breaksw" \n) - < "default:" \n - > _ \n - resume: - < < "endsw") - (es) - (rc "expression: " - "switch( " str " ) {" \n - > "case " (read-string "pattern: ") \n - > _ \n - ( "other pattern, %s: " - < "case " str \n - > _ \n) - < "case *" \n - > _ \n - resume: - < < ?}) - (sh "expression: " - "case " str " in" \n - > (read-string "pattern: ") ?\) \n - > _ \n - ";;" \n - ( "other pattern, %s: " - < str ?\) \n - > _ \n - ";;" \n) - < "*)" \n - > _ \n - resume: - < < "esac")) -(put 'sh-case 'menu-enable '(sh-feature sh-case)) - - - -(define-skeleton sh-for - "Insert a for loop. See `sh-feature'." - (csh eval sh-modify sh - 1 "foreach " - 3 " ( " - 5 " )" - 15 "end") - (es eval sh-modify rc - 3 " = ") - (rc eval sh-modify sh - 1 "for( " - 5 " ) {" - 15 ?}) - (sh "Index variable: " - "for " str " in " _ "; do" \n - > _ | ?$ & (sh-remember-variable str) \n - < "done")) - - - -(define-skeleton sh-indexed-loop - "Insert an indexed loop from 1 to n. See `sh-feature'." - (bash eval identity posix) - (csh "Index variable: " - "@ " str " = 1" \n - "while( $" str " <= " (read-string "upper limit: ") " )" \n - > _ ?$ str \n - "@ " str "++" \n - < "end") - (es eval sh-modify rc - 3 " =") - (ksh88 "Index variable: " - "integer " str "=0" \n - "while (( ( " str " += 1 ) <= " - (read-string "upper limit: ") - " )); do" \n - > _ ?$ (sh-remember-variable str) \n - < "done") - (posix "Index variable: " - str "=1" \n - "while [ $" str " -le " - (read-string "upper limit: ") - " ]; do" \n - > _ ?$ str \n - str ?= (sh-add (sh-remember-variable str) 1) \n - < "done") - (rc "Index variable: " - "for( " str " in" " `{awk 'BEGIN { for( i=1; i<=" - (read-string "upper limit: ") - "; i++ ) print i }'}) {" \n - > _ ?$ (sh-remember-variable str) \n - < ?}) - (sh "Index variable: " - "for " str " in `awk 'BEGIN { for( i=1; i<=" - (read-string "upper limit: ") - "; i++ ) print i }'`; do" \n - > _ ?$ (sh-remember-variable str) \n - < "done")) - - -(defun sh-shell-initialize-variables () - "Scan the buffer for variable assignments. -Add these variables to `sh-shell-variables'." - (message "Scanning buffer `%s' for variable assignments..." (buffer-name)) - (save-excursion - (goto-char (point-min)) - (setq sh-shell-variables-initialized t) - (while (search-forward "=" nil t) - (sh-assignment 0))) - (message "Scanning buffer `%s' for variable assignments...done" - (buffer-name))) - -(defvar sh-add-buffer) - -(defun sh-add-completer (string predicate code) - "Do completion using `sh-shell-variables', but initialize it first. -This function is designed for use as the \"completion table\", -so it takes three arguments: - STRING, the current buffer contents; - PREDICATE, the predicate for filtering possible matches; - CODE, which says what kind of things to do. -CODE can be nil, t or `lambda'. -nil means to return the best completion of STRING, or nil if there is none. -t means to return a list of all possible completions of STRING. -`lambda' means to return t if STRING is a valid completion as it stands." - (let ((sh-shell-variables - (save-excursion - (set-buffer sh-add-buffer) - (or sh-shell-variables-initialized - (sh-shell-initialize-variables)) - (nconc (mapcar (lambda (var) - (let ((name - (substring var 0 (string-match "=" var)))) - (cons name name))) - process-environment) - sh-shell-variables)))) - (cond ((null code) - (try-completion string sh-shell-variables predicate)) - ((eq code t) - (all-completions string sh-shell-variables predicate)) - ((eq code 'lambda) - (assoc string sh-shell-variables))))) - -(defun sh-add (var delta) - "Insert an addition of VAR and prefix DELTA for Bourne (type) shell." - (interactive - (let ((sh-add-buffer (current-buffer))) - (list (completing-read "Variable: " 'sh-add-completer) - (prefix-numeric-value current-prefix-arg)))) - (insert (sh-feature '((bash . "$[ ") - (ksh88 . "$(( ") - (posix . "$(( ") - (rc . "`{expr $") - (sh . "`expr $") - (zsh . "$[ "))) - (sh-remember-variable var) - (if (< delta 0) " - " " + ") - (number-to-string (abs delta)) - (sh-feature '((bash . " ]") - (ksh88 . " ))") - (posix . " ))") - (rc . "}") - (sh . "`") - (zsh . " ]"))))) - - - -(define-skeleton sh-function - "Insert a function definition. See `sh-feature'." - (bash eval sh-modify ksh88 - 3 "() {") - (ksh88 "name: " - "function " str " {" \n - > _ \n - < "}") - (rc eval sh-modify ksh88 - 1 "fn ") - (sh () - "() {" \n - > _ \n - < "}")) - - - -(define-skeleton sh-if - "Insert an if statement. See `sh-feature'." - (csh "condition: " - "if( " str " ) then" \n - > _ \n - ( "other condition, %s: " - < "else if( " str " ) then" \n - > _ \n) - < "else" \n - > _ \n - resume: - < "endif") - (es "condition: " - "if { " str " } {" \n - > _ \n - ( "other condition, %s: " - < "} { " str " } {" \n - > _ \n) - < "} {" \n - > _ \n - resume: - < ?}) - (rc eval sh-modify csh - 3 " ) {" - 8 '( "other condition, %s: " - < "} else if( " str " ) {" \n - > _ \n) - 10 "} else {" - 17 ?}) - (sh "condition: " - '(setq input (sh-feature sh-test)) - "if " str "; then" \n - > _ \n - ( "other condition, %s: " - < "elif " str "; then" \n - > _ \n) - < "else" \n - > _ \n - resume: - < "fi")) - - - -(define-skeleton sh-repeat - "Insert a repeat loop definition. See `sh-feature'." - (es nil - "forever {" \n - > _ \n - < ?}) - (zsh "factor: " - "repeat " str "; do"\n - > _ \n - < "done")) -(put 'sh-repeat 'menu-enable '(sh-feature sh-repeat)) - - - -(define-skeleton sh-select - "Insert a select statement. See `sh-feature'." - (ksh88 "Index variable: " - "select " str " in " _ "; do" \n - > ?$ str \n - < "done")) -(put 'sh-select 'menu-enable '(sh-feature sh-select)) - - - -(define-skeleton sh-tmp-file - "Insert code to setup temporary file handling. See `sh-feature'." - (bash eval identity ksh88) - (csh (file-name-nondirectory (buffer-file-name)) - "set tmp = /tmp/" str ".$$" \n - "onintr exit" \n _ - (and (goto-char (point-max)) - (not (bolp)) - ?\n) - "exit:\n" - "rm $tmp* >&/dev/null" >) - (es (file-name-nondirectory (buffer-file-name)) - "local( signals = $signals sighup sigint; tmp = /tmp/" str ".$pid ) {" \n - > "catch @ e {" \n - > "rm $tmp^* >[2]/dev/null" \n - "throw $e" \n - < "} {" \n - > _ \n - < ?} \n - < ?}) - (ksh88 eval sh-modify sh - 6 "EXIT") - (rc (file-name-nondirectory (buffer-file-name)) - "tmp = /tmp/" str ".$pid" \n - "fn sigexit { rm $tmp^* >[2]/dev/null }") - (sh (file-name-nondirectory (buffer-file-name)) - "TMP=/tmp/" str ".$$" \n - "trap \"rm $TMP* 2>/dev/null\" " ?0)) - - - -(define-skeleton sh-until - "Insert an until loop. See `sh-feature'." - (sh "condition: " - '(setq input (sh-feature sh-test)) - "until " str "; do" \n - > _ \n - < "done")) -(put 'sh-until 'menu-enable '(sh-feature sh-until)) - - - -(define-skeleton sh-while - "Insert a while loop. See `sh-feature'." - (csh eval sh-modify sh - 2 "while( " - 4 " )" - 10 "end") - (es eval sh-modify rc - 2 "while { " - 4 " } {") - (rc eval sh-modify csh - 4 " ) {" - 10 ?}) - (sh "condition: " - '(setq input (sh-feature sh-test)) - "while " str "; do" \n - > _ \n - < "done")) - - - -(define-skeleton sh-while-getopts - "Insert a while getopts loop. See `sh-feature'. -Prompts for an options string which consists of letters for each recognized -option followed by a colon `:' if the option accepts an argument." - (bash eval sh-modify sh - 18 "${0##*/}") - (csh nil - "while( 1 )" \n - > "switch( \"$1\" )" \n - '(setq input '("- x" . 2)) - > > - ( "option, %s: " - < "case " '(eval str) - '(if (string-match " +" str) - (setq v1 (substring str (match-end 0)) - str (substring str 0 (match-beginning 0))) - (setq v1 nil)) - str ?: \n - > "set " v1 & " = $2" | -4 & _ \n - (if v1 "shift") & \n - "breaksw" \n) - < "case --:" \n - > "shift" \n - < "default:" \n - > "break" \n - resume: - < < "endsw" \n - "shift" \n - < "end") - (ksh88 eval sh-modify sh - 16 "print" - 18 "${0##*/}" - 36 "OPTIND-1") - (posix eval sh-modify sh - 18 "$(basename $0)") - (sh "optstring: " - "while getopts :" str " OPT; do" \n - > "case $OPT in" \n - > > - '(setq v1 (append (vconcat str) nil)) - ( (prog1 (if v1 (char-to-string (car v1))) - (if (eq (nth 1 v1) ?:) - (setq v1 (nthcdr 2 v1) - v2 "\"$OPTARG\"") - (setq v1 (cdr v1) - v2 nil))) - < str "|+" str ?\) \n - > _ v2 \n - ";;" \n) - < "*)" \n - > "echo" " \"usage: " "`basename $0`" - " [+-" '(setq v1 (point)) str - '(save-excursion - (while (search-backward ":" v1 t) - (replace-match " ARG] [+-" t t))) - (if (eq (preceding-char) ?-) -5) - "] [--] ARGS...\"" \n - "exit 2" \n - < < "esac" \n - < "done" \n - "shift " (sh-add "OPTIND" -1))) -(put 'sh-while-getopts 'menu-enable '(sh-feature sh-while-getopts)) - - - -(defun sh-assignment (arg) - "Remember preceding identifier for future completion and do self-insert." - (interactive "p") - (self-insert-command arg) - (if (<= arg 1) - (sh-remember-variable - (save-excursion - (if (re-search-forward (sh-feature sh-assignment-regexp) - (prog1 (point) - (beginning-of-line 1)) - t) - (match-string 1)))))) - - - -(defun sh-maybe-here-document (arg) - "Inserts self. Without prefix, following unquoted `<' inserts here document. -The document is bounded by `sh-here-document-word'." - (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) - (or arg - (not (eq (char-after (- (point) 2)) last-command-char)) - (save-excursion - (backward-char 2) - (sh-quoted-p)) - (progn - (insert sh-here-document-word) - (or (eolp) (looking-at "[ \t]") (insert ? )) - (end-of-line 1) - (while - (sh-quoted-p) - (end-of-line 2)) - (newline) - (save-excursion (insert ?\n sh-here-document-word))))) - - -;; various other commands - -(autoload 'comint-dynamic-complete "comint" - "Dynamically perform completion at point." t) - -(autoload 'shell-dynamic-complete-command "shell" - "Dynamically complete the command at point." t) - -(autoload 'comint-dynamic-complete-filename "comint" - "Dynamically complete the filename at point." t) - -(autoload 'shell-dynamic-complete-environment-variable "shell" - "Dynamically complete the environment variable at point." t) - - - -(defun sh-newline-and-indent () - "Strip unquoted whitespace, insert newline, and indent like current line." - (interactive "*") - (indent-to (prog1 (current-indentation) - (delete-region (point) - (progn - (or (zerop (skip-chars-backward " \t")) - (if (sh-quoted-p) - (forward-char))) - (point))) - (newline)))) - - - -(defun sh-beginning-of-command () - "Move point to successive beginnings of commands." - (interactive) - (if (re-search-backward sh-beginning-of-command nil t) - (goto-char (match-beginning 2)))) - - -(defun sh-end-of-command () - "Move point to successive ends of commands." - (interactive) - (if (re-search-forward sh-end-of-command nil t) - (goto-char (match-end 1)))) - -(provide 'sh-script) -;; sh-script.el ends here diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el deleted file mode 100644 index c4de80bfd61..00000000000 --- a/lisp/progmodes/simula.el +++ /dev/null @@ -1,1773 +0,0 @@ -;;; simula.el --- SIMULA 87 code editing commands for Emacs - -;; Copyright (C) 1992, 1994, 1996 Free Software Foundation, Inc. - -;; Author: Hans Henrik Eriksen <hhe@ifi.uio.no> -;; Maintainer: simula-mode@ifi.uio.no -;; Adapted-By: ESR -;; Keywords: languages - -;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; A major mode for editing the Simula language. It knows about Simula -;; syntax and standard indentation commands. It also provides convenient -;; abbrevs for Simula keywords. -;; -;; Hans Henrik Eriksen (the author) may be reached at: -;; Institutt for informatikk, -;; Universitetet i Oslo - -;;; Code: - - -(defconst simula-tab-always-indent-default nil - "Non-nil means TAB in SIMULA mode should always reindent the current line. -Otherwise TAB indents only when point is within -the run of whitespace at the beginning of the line.") - -(defvar simula-tab-always-indent simula-tab-always-indent-default - "*Non-nil means TAB in SIMULA mode should always reindent the current line. -Otherwise TAB indents only when point is within -the run of whitespace at the beginning of the line.") - -(defconst simula-indent-level-default 3 - "Indentation of SIMULA statements with respect to containing block.") - -(defvar simula-indent-level simula-indent-level-default - "*Indentation of SIMULA statements with respect to containing block.") - -(defconst simula-substatement-offset-default 3 - "Extra indentation after DO, THEN, ELSE, WHEN and OTHERWISE.") - -(defvar simula-substatement-offset simula-substatement-offset-default - "*Extra indentation after DO, THEN, ELSE, WHEN and OTHERWISE.") - -(defconst simula-continued-statement-offset-default 3 - "Extra indentation for lines not starting a statement or substatement. -If value is a list, each line in a multipleline continued statement -will have the car of the list extra indentation with respect to -the previous line of the statement.") - -(defvar simula-continued-statement-offset simula-continued-statement-offset-default - "*Extra indentation for lines not starting a statement or substatement. -If value is a list, each line in a multipleline continued statement -will have the car of the list extra indentation with respect to -the previous line of the statement.") - -(defconst simula-label-offset-default -4711 - "Offset of SIMULA label lines relative to usual indentation.") - -(defvar simula-label-offset simula-label-offset-default - "*Offset of SIMULA label lines relative to usual indentation.") - -(defconst simula-if-indent-default '(0 . 0) - "Extra indentation of THEN and ELSE with respect to the starting IF. -Value is a cons cell, the car is extra THEN indentation and the cdr -extra ELSE indentation. IF after ELSE is indented as the starting IF.") - -(defvar simula-if-indent simula-if-indent-default - "*Extra indentation of THEN and ELSE with respect to the starting IF. -Value is a cons cell, the car is extra THEN indentation and the cdr -extra ELSE indentation. IF after ELSE is indented as the starting IF.") - -(defconst simula-inspect-indent-default '(0 . 0) - "Extra indentation of WHEN and OTHERWISE with respect to the INSPECT. -Value is a cons cell, the car is extra WHEN indentation -and the cdr extra OTHERWISE indentation.") - -(defvar simula-inspect-indent simula-inspect-indent-default - "*Extra indentation of WHEN and OTHERWISE with respect to the INSPECT. -Value is a cons cell, the car is extra WHEN indentation -and the cdr extra OTHERWISE indentation.") - -(defconst simula-electric-indent-default nil - "Non-nil means `simula-indent-line' function may reindent previous line.") - -(defvar simula-electric-indent simula-electric-indent-default - "*Non-nil means `simula-indent-line' function may reindent previous line.") - -(defconst simula-abbrev-keyword-default 'upcase - "Specify how to convert case for SIMULA keywords. -Value is one of the symbols `upcase', `downcase', `capitalize', -(as in) `abbrev-table' or nil if they should not be changed.") - -(defvar simula-abbrev-keyword simula-abbrev-keyword-default - "*Specify how to convert case for SIMULA keywords. -Value is one of the symbols `upcase', `downcase', `capitalize', -(as in) `abbrev-table' or nil if they should not be changed.") - -(defconst simula-abbrev-stdproc-default 'abbrev-table - "Specify how to convert case for standard SIMULA procedure and class names. -Value is one of the symbols `upcase', `downcase', `capitalize', -(as in) `abbrev-table', or nil if they should not be changed.") - -(defvar simula-abbrev-stdproc simula-abbrev-stdproc-default - "*Specify how to convert case for standard SIMULA procedure and class names. -Value is one of the symbols `upcase', `downcase', `capitalize', -(as in) `abbrev-table', or nil if they should not be changed.") - -(defvar simula-abbrev-file nil - "*File with extra abbrev definitions for use in SIMULA mode. -These are used together with the standard abbrev definitions for SIMULA. -Please note that the standard definitions are required -for SIMULA mode to function correctly.") - -(defvar simula-mode-syntax-table nil - "Syntax table in SIMULA mode buffers.") - -;; Regexps written with help from Alf-Ivar Holm <alfh@ifi.uio.no>. -(defconst simula-font-lock-keywords-1 - (list - ;; - ;; Comments and strings. - '(simula-match-string-or-comment 0 - (if (match-beginning 1) font-lock-string-face font-lock-comment-face)) - ;; - ;; Compiler directives. - '("^%\\([^ \t\n].*\\)" 1 font-lock-reference-face) - ;; - ;; Class and procedure names. - '("\\<\\(class\\|procedure\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ) - "Subdued level highlighting for Simula mode.") - -(defconst simula-font-lock-keywords-2 - (append simula-font-lock-keywords-1 - (list - ;; - ;; Constants as references. - '("\\<\\(false\\|none\\|notext\\|true\\)\\>" . font-lock-reference-face) - ;; - ;; Keywords. - (concat "\\<\\(" -; (make-regexp -; '("activate" "after" "and" "at" "before" "begin" "delay" "do" -; "else" "end" "eq" "eqv" "external" "for" "ge" "go" "goto" "gt" -; "hidden" "if" "imp" "in" "inner" "inspect" "is" "label" "le" -; "lt" "ne" "new" "not" "or" "otherwise" "prior" "protected" -; "qua" "reactivate" "step" "switch" "then" "this" "to" "until" -; "virtual" "when" "while")) - "a\\(ctivate\\|fter\\|nd\\|t\\)\\|be\\(fore\\|gin\\)\\|" - "d\\(elay\\|o\\)\\|e\\(lse\\|nd\\|qv?\\|xternal\\)\\|for\\|" - "g\\([eot]\\|oto\\)\\|hidden\\|i\\([fns]\\|mp\\|n\\(ner\\|" - "spect\\)\\)\\|l\\([et]\\|abel\\)\\|n\\(ew?\\|ot\\)\\|" - "o\\(r\\|therwise\\)\\|pr\\(ior\\|otected\\)\\|qua\\|" - "reactivate\\|s\\(tep\\|witch\\)\\|t\\(h\\(en\\|is\\)\\|o\\)\\|" - "until\\|virtual\\|wh\\(en\\|ile\\)" - "\\)\\>") - ;; - ;; Types. - (cons (concat "\\<\\(array\\|boolean\\|character\\|integer\\|" - "long\\|name\\|real\\|short\\|text\\|value\\|ref\\)\\>") - 'font-lock-type-face) - )) - "Medium level highlighting for Simula mode.") - -(defconst simula-font-lock-keywords-3 - (append simula-font-lock-keywords-2 - (list - ;; - ;; Super-class names and super-slow. - '("\\<\\(\\sw+\\)[ \t]+class\\>" 1 font-lock-function-name-face) - ;; - ;; Types and their declarations. - (list (concat "\\<\\(array\\|boolean\\|character\\|integer\\|" - "long\\|name\\|real\\|short\\|text\\|value\\)\\>" - "\\([ \t]+\\sw+\\>\\)*") - '(font-lock-match-c-style-declaration-item-and-skip-to-next - ;; Start with point after all type specifiers. - (goto-char (or (match-beginning 2) (match-end 1))) - ;; Finish with point after first type specifier. - (goto-char (match-end 1)) - ;; Fontify as a variable name. - (1 font-lock-variable-name-face))) - ;; - ;; Object references and their declarations. - '("\\<\\(ref\\)\\>[ \t]*\\((\\(\\sw+\\))\\)?" - (3 font-lock-function-name-face nil t) - (font-lock-match-c-style-declaration-item-and-skip-to-next nil nil - (1 font-lock-variable-name-face))) - )) - "Gaudy level highlighting for Simula mode.") - -(defvar simula-font-lock-keywords simula-font-lock-keywords-1 - "Default expressions to highlight in Simula mode.") - -; The following function is taken from cc-mode.el, -; it determines the flavor of the Emacs running -(defconst simula-emacs-features - (let ((major (and (boundp 'emacs-major-version) - emacs-major-version)) - (minor (and (boundp 'emacs-minor-version) - emacs-minor-version)) - flavor comments) - ;; figure out version numbers if not already discovered - (and (or (not major) (not minor)) - (string-match "\\([0-9]+\\).\\([0-9]+\\)" emacs-version) - (setq major (string-to-int (substring emacs-version - (match-beginning 1) - (match-end 1))) - minor (string-to-int (substring emacs-version - (match-beginning 2) - (match-end 2))))) - (if (not (and major minor)) - (error "Cannot figure out the major and minor version numbers.")) - ;; calculate the major version - (cond - ((= major 18) (setq major 'v18)) ;Emacs 18 - ((= major 4) (setq major 'v18)) ;Epoch 4 - ((= major 19) (setq major 'v19 ;Emacs 19 - flavor (if (string-match "Lucid" emacs-version) - 'Lucid 'FSF))) - ;; I don't know - (t (error "Cannot recognize major version number: %s" major))) - (list major flavor comments)) - "A list of features extant in the Emacs you are using. -There are many flavors of Emacs out there, each with different -features supporting those needed by simula-mode. Here's the current -supported list, along with the values for this variable: - - Emacs 19: (v19 FSF 1-bit) - Vanilla Emacs 18/Epoch 4: (v18 no-dual-comments) - Emacs 18/Epoch 4 (patch2): (v18 8-bit) - Lucid Emacs 19: (v19 Lucid 8-bit).") - -(defvar simula-mode-menu - '(["Report Bug" simula-submit-bug-report t] - ["Indent Line" simula-indent-line t] - ["Backward Statement" simula-previous-statement t] - ["Forward Statement" simula-next-statement t] - ["Backward Up Level" simula-backward-up-level t] - ["Forward Down Statement" simula-forward-down-level t] - ) - "Lucid Emacs menu for SIMULA mode.") - -(if simula-mode-syntax-table - () - (setq simula-mode-syntax-table (copy-syntax-table (standard-syntax-table))) - (modify-syntax-entry ?! "<" simula-mode-syntax-table) - (modify-syntax-entry ?$ "." simula-mode-syntax-table) - (modify-syntax-entry ?% "." simula-mode-syntax-table) - (modify-syntax-entry ?' "\"" simula-mode-syntax-table) - (modify-syntax-entry ?\( "()" simula-mode-syntax-table) - (modify-syntax-entry ?\) ")(" simula-mode-syntax-table) - (modify-syntax-entry ?\; ">" simula-mode-syntax-table) - (modify-syntax-entry ?\[ "." simula-mode-syntax-table) - (modify-syntax-entry ?\\ "." simula-mode-syntax-table) - (modify-syntax-entry ?\] "." simula-mode-syntax-table) - (modify-syntax-entry ?_ "_" simula-mode-syntax-table) - (modify-syntax-entry ?\| "." simula-mode-syntax-table) - (modify-syntax-entry ?\{ "." simula-mode-syntax-table) - (modify-syntax-entry ?\} "." simula-mode-syntax-table)) - -(defvar simula-mode-map () - "Keymap used in SIMULA mode.") - -(if simula-mode-map - () - (setq simula-mode-map (make-sparse-keymap)) - (define-key simula-mode-map "\C-c\C-u" 'simula-backward-up-level) - (define-key simula-mode-map "\C-c\C-p" 'simula-previous-statement) - (define-key simula-mode-map "\C-c\C-d" 'simula-forward-down-level) - (define-key simula-mode-map "\C-c\C-n" 'simula-next-statement) - ;(define-key simula-mode-map "\C-c\C-g" 'simula-goto-definition) - ;(define-key simula-mode-map "\C-c\C-h" 'simula-standard-help) - (define-key simula-mode-map "\177" 'backward-delete-char-untabify) - (define-key simula-mode-map ":" 'simula-electric-label) - (define-key simula-mode-map "\e\C-q" 'simula-indent-exp) - (define-key simula-mode-map "\t" 'simula-indent-command) - ;; Emacs 19 defines menus in the mode map - (if (memq 'FSF simula-emacs-features) - (progn - (define-key simula-mode-map [menu-bar] (make-sparse-keymap)) - - (define-key simula-mode-map [menu-bar simula] - (cons "SIMULA" (make-sparse-keymap "SIMULA"))) - (define-key simula-mode-map [menu-bar simula bug-report] - '("Submit Bug Report" . simula-submit-bug-report)) - (define-key simula-mode-map [menu-bar simula separator-indent] - '("--")) - (define-key simula-mode-map [menu-bar simula indent-exp] - '("Indent Expression" . simula-indent-exp)) - (define-key simula-mode-map [menu-bar simula indent-line] - '("Indent Line" . simula-indent-command)) - (define-key simula-mode-map [menu-bar simula separator-navigate] - '("--")) - (define-key simula-mode-map [menu-bar simula backward-stmt] - '("Previous Statement" . simula-previous-statement)) - (define-key simula-mode-map [menu-bar simula forward-stmt] - '("Next Statement" . simula-next-statement)) - (define-key simula-mode-map [menu-bar simula backward-up] - '("Backward Up Level" . simula-backward-up-level)) - (define-key simula-mode-map [menu-bar simula forward-down] - '("Forward Down Statement" . simula-forward-down-level)) - - (put 'simula-next-statement 'menu-enable '(not (eobp))) - (put 'simula-previous-statement 'menu-enable '(not (bobp))) - (put 'simula-forward-down-level 'menu-enable '(not (eobp))) - (put 'simula-backward-up-level 'menu-enable '(not (bobp))) - (put 'simula-indent-command 'menu-enable '(not buffer-read-only)) - (put 'simula-indent-exp 'menu-enable '(not buffer-read-only)))) - - ;; RMS: mouse-3 should not select this menu. mouse-3's global - ;; definition is useful in SIMULA mode and we should not interfere - ;; with that. The menu is mainly for beginners, and for them, - ;; the menubar requires less memory than a special click. - ;; in Lucid Emacs, we want the menu to popup when the 3rd button is - ;; hit. In 19.10 and beyond this is done automatically if we put - ;; the menu on mode-popup-menu variable, see c-common-init [cc-mode.el] - (if (memq 'Lucid simula-emacs-features) - (if (not (boundp 'mode-popup-menu)) - (define-key simula-mode-map 'button3 'simula-popup-menu)))) - -;; menus for Lucid -(defun simula-popup-menu (e) - "Pops up the SIMULA menu." - (interactive "@e") - (popup-menu (cons (concat mode-name " Mode Commands") simula-mode-menu)) - (simula-keep-region-active)) - -;; active regions, and auto-newline/hungry delete key -(defun simula-keep-region-active () - ;; do whatever is necessary to keep the region active in - ;; Lucid. ignore byte-compiler warnings you might see - (and (boundp 'zmacs-region-stays) - (setq zmacs-region-stays t))) - -(defvar simula-mode-abbrev-table nil - "Abbrev table in SIMULA mode buffers") - - -;;;###autoload -(defun simula-mode () - "Major mode for editing SIMULA code. -\\{simula-mode-map} -Variables controlling indentation style: - simula-tab-always-indent - Non-nil means TAB in SIMULA mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - simula-indent-level - Indentation of SIMULA statements with respect to containing block. - simula-substatement-offset - Extra indentation after DO, THEN, ELSE, WHEN and OTHERWISE. - simula-continued-statement-offset 3 - Extra indentation for lines not starting a statement or substatement, - e.g. a nested FOR-loop. If value is a list, each line in a multiple- - line continued statement will have the car of the list extra indentation - with respect to the previous line of the statement. - simula-label-offset -4711 - Offset of SIMULA label lines relative to usual indentation. - simula-if-indent '(0 . 0) - Extra indentation of THEN and ELSE with respect to the starting IF. - Value is a cons cell, the car is extra THEN indentation and the cdr - extra ELSE indentation. IF after ELSE is indented as the starting IF. - simula-inspect-indent '(0 . 0) - Extra indentation of WHEN and OTHERWISE with respect to the - corresponding INSPECT. Value is a cons cell, the car is - extra WHEN indentation and the cdr extra OTHERWISE indentation. - simula-electric-indent nil - If this variable is non-nil, `simula-indent-line' - will check the previous line to see if it has to be reindented. - simula-abbrev-keyword 'upcase - Determine how SIMULA keywords will be expanded. Value is one of - the symbols `upcase', `downcase', `capitalize', (as in) `abbrev-table', - or nil if they should not be changed. - simula-abbrev-stdproc 'abbrev-table - Determine how standard SIMULA procedure and class names will be - expanded. Value is one of the symbols `upcase', `downcase', `capitalize', - (as in) `abbrev-table', or nil if they should not be changed. - -Turning on SIMULA mode calls the value of the variable simula-mode-hook -with no arguments, if that value is non-nil - -Warning: simula-mode-hook should not read in an abbrev file without calling -the function simula-install-standard-abbrevs afterwards, preferably not -at all." - (interactive) - (kill-all-local-variables) - (use-local-map simula-mode-map) - (setq major-mode 'simula-mode) - (setq mode-name "SIMULA") - (make-local-variable 'comment-column) - (setq comment-column 40) -; (make-local-variable 'end-comment-column) -; (setq end-comment-column 75) - (set-syntax-table simula-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start "[ \t]*$\\|\\f") - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'simula-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "! ") - (make-local-variable 'comment-end) - (setq comment-end " ;") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "!+ *") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'comment-multi-line) - (setq comment-multi-line t) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '((simula-font-lock-keywords simula-font-lock-keywords-1 - simula-font-lock-keywords-2 simula-font-lock-keywords-3) - t t ((?_ . "w")))) - (if simula-mode-abbrev-table - () - (if simula-abbrev-file - (read-abbrev-file simula-abbrev-file) - (define-abbrev-table 'simula-mode-abbrev-table ())) - (let (abbrevs-changed) - (simula-install-standard-abbrevs))) - (setq local-abbrev-table simula-mode-abbrev-table) - (abbrev-mode 1) - (run-hooks 'simula-mode-hook)) - - -(defun simula-indent-exp () - "Indent SIMULA expression following point." - (interactive) - (let ((here (point)) - (simula-electric-indent nil) - end) - (simula-skip-comment-forward) - (if (eobp) - (goto-char here) - (unwind-protect - (progn - (simula-next-statement 1) - (setq end (point-marker)) - (simula-previous-statement 1) - (beginning-of-line) - (while (< (point) end) - (if (not (looking-at "[ \t]*$")) - (simula-indent-line)) - (forward-line 1))) - (and end (set-marker end nil)))))) - - -(defun simula-indent-line () - "Indent this line as SIMULA code. -If `simula-electric-indent' is non-nil, indent previous line if necessary." - (let ((origin (- (point-max) (point))) - (indent (simula-calculate-indent)) - (case-fold-search t)) - (unwind-protect - (if simula-electric-indent - (progn - ;; - ;; manually expand abbrev on last line, if any - ;; - (end-of-line 0) - (expand-abbrev) - ;; now maybe we should reindent that line - (beginning-of-line) - (skip-chars-forward " \t\f") - (if (and - (looking-at - "\\(end\\|if\\|then\\|else\\|when\\|otherwise\\)\\>") - (not (simula-context))) - ;; yes - reindent - (let ((post-indent (simula-calculate-indent))) - (if (eq (current-indentation) post-indent) - () - (delete-horizontal-space) - (indent-to post-indent)))))) - (goto-char (- (point-max) origin)) - (if (eq (current-indentation) indent) - (back-to-indentation) - (delete-horizontal-space) - (indent-to indent))))) - - -(defun simula-indent-command (&optional whole-exp) - "Indent current line as SIMULA code, or insert TAB character. -If `simula-tab-always-indent' is non-nil, always indent current line. -Otherwise, indent only if point is before any non-whitespace -character on the line. - -A numeric argument, regardless of its value, means indent rigidly -all the lines of the SIMULA statement after point so that this line -becomes properly indented. -The relative indentation among the lines of the statement are preserved." - (interactive "P") - (let ((case-fold-search t)) - (if (or whole-exp simula-tab-always-indent - (save-excursion - (skip-chars-backward " \t\f") - (bolp))) - ;; reindent current line - (let ((indent (save-excursion - (beginning-of-line) - (simula-calculate-indent))) - (current (current-indentation)) - (origin (- (point-max) (point))) - (bol (save-excursion - (skip-chars-backward " \t\f") - (bolp))) - beg end) - (unwind-protect - (if (eq current indent) - (if (save-excursion - (skip-chars-backward " \t\f") - (bolp)) - (back-to-indentation)) - (beginning-of-line) - (delete-horizontal-space) - (indent-to indent)) - (if (not bol) - (goto-char (- (point-max) origin)))) - (setq origin (point)) - (if whole-exp - (save-excursion - (beginning-of-line 2) - (setq beg (point)) - (goto-char origin) - (simula-next-statement 1) - (setq end (point)) - (if (and (> end beg) (not (eq indent current))) - (indent-code-rigidly beg end (- indent current) "%"))))) - (insert-tab)))) - - -(defun simula-context () - "Returns value according to syntactic SIMULA context of point. - 0 point inside COMMENT comment - 1 point on SIMULA-compiler directive line - 2 point inside END comment - 3 point inside string - 4 point inside character constant - nil otherwise." - ;; first, find out if this is a compiler directive line - (if (save-excursion - (beginning-of-line) - (eq (following-char) ?%)) - ;; YES - return 1 - 1 - (save-excursion - ;; The current line is NOT a compiler directive line. - ;; Now, the strategy is to search backward to find a semicolon - ;; that is NOT inside a string. The point after semicolon MUST be - ;; outside a comment, since semicolons are comment-ending and - ;; comments are non-recursive. We take advantage of the fact - ;; that strings MUST end on the same line as they started, so - ;; that we can easily decide whether we are inside a string or not. - (let (return-value (origin (point))) - (skip-chars-backward "^;" (point-min)) - ;; found semicolon or beginning of buffer - (let (loopvalue (saved-point origin)) - (while (and (not (bobp)) - (if (progn - (beginning-of-line) - ;; compiler directive line? If so, cont searching.. - (eq (following-char) ?%)) - t - (while (< (point) saved-point) - (skip-chars-forward "^;\"'") - (forward-char 1) - (cond - ((eq (preceding-char) ?\;) - (setq saved-point (point))) - ((eq (preceding-char) ?\") - (skip-chars-forward "^\";") - (if (eq (following-char) ?\;) - (setq saved-point (point) loopvalue t) - (forward-char 1))) - (t - (if (eq (following-char) ?') - (forward-char 1)) - (skip-chars-forward "^';") - (if (eq (following-char) ?\;) - (setq saved-point (point) loopvalue t) - (forward-char 1))))) - loopvalue)) - (backward-char 1) - (skip-chars-backward "^;") - (setq saved-point (point) loopvalue nil))) - ;; Now we are CERTAIN that we are outside comments and strings. - ;; The job now is to search forward again towards the origin - ;; skipping directives, comments and strings correctly, - ;; so that we know what context we are in when we find the origin. - (while (and - (< (point) origin) - (re-search-forward - "\\<end\\>\\|!\\|\"\\|'\\|^%\\|\\<comment\\>" origin 'move)) - (cond - ((memq (preceding-char) '(?d ?D)) - (setq return-value 2) - (while (and (re-search-forward - ";\\|\\<end\\>\\|\\<else\\>\\|\\<otherwise\\>\\|\\<when\\>\\|^%" - origin 'move) - ;; found another END? - (or (memq (preceding-char) '(?d ?D)) - ;; if directive, skip line - (and (eq (preceding-char) ?%) - (beginning-of-line 2)) - ;; found other keyword, out of END comment - (setq return-value nil)))) - (if (and (eq (char-syntax (preceding-char)) ?w) - (eq (char-syntax (following-char)) ?w)) - (save-excursion - (backward-word 1) - (if (looking-at "end\\>\\|else\\>\\|otherwise\\>\\|when\\>") - (setq return-value nil))))) - ((memq (preceding-char) '(?! ?t ?T)) - ; skip comment - (setq return-value 0) - (skip-chars-forward "^%;" origin) - (while (and return-value (< (point) origin)) - (if (eq (following-char) ?\;) - (setq return-value nil) - (if (bolp) - (beginning-of-line 2) ; skip directive inside comment - (forward-char 1)) ; or single '%' - (skip-chars-forward "^%;" origin)))) - ((eq (preceding-char) ?\") - (if (not (search-forward "\"" origin 'move)) - (setq return-value 3))) - ((eq (preceding-char) ?\') - (if (or (eq (point) origin) (eobp)) - (setq return-value 4) - (forward-char 1) - (if (not (search-forward "'" origin 'move)) - (setq return-value 4)))) - ;; compiler directive line - skip - (t (beginning-of-line 2)))) - return-value) - ))) - - -(defun simula-electric-label () - "If this is a label that starts the line, reindent the line." - (interactive) - (expand-abbrev) - (insert ?:) - (let ((origin (- (point-max) (point))) - (case-fold-search t) - ;; don't mix a label with an assignment operator := :- - ;; therefore take a peek at next typed character... - (next-char (read-event))) - (unwind-protect - (setq unread-command-events (append unread-command-events - (list next-char))) - ;; Problem: find out if character just read is a command char - ;; that would insert something after ':' making it a label. - ;; At least \n, \r (and maybe \t) falls into this category. - ;; This is a real crock, it depends on traditional keymap - ;; bindings, that is, printing characters doing self-insert, - ;; and no other command sequence inserting '-' or '='. - ;; simula-electric-label can be easily fooled... - (if (and (not (memq next-char '(?= ?-))) - (or (memq next-char '(?\n ?\r)) - (and (eq next-char ?\t) - simula-tab-always-indent) - (not (memq (following-char) '(?= ?-)))) - (not (simula-context)) - ;; label? - (progn - (backward-char 1) - (skip-chars-backward " \t\f") - (skip-chars-backward "a-zA-Z0-9_") - (if (looking-at "virtual\\>") - nil - (skip-chars-backward " \t\f") - (bolp)))) - (let ((amount (simula-calculate-indent))) - (delete-horizontal-space) - (indent-to amount))) - (goto-char (- (point-max) origin))))) - - -(defun simula-backward-up-level (count) - "Move backward up COUNT block levels. -If COUNT is negative, move forward up block level instead." - (interactive "p") - (let ((origin (point)) - (case-fold-search t)) - (condition-case () - (if (> count 0) - (while (> count 0) - (re-search-backward "\\<begin\\>\\|\\<end\\>") - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?b ?B)) - (1- count) - (1+ count))))) - (while (< count 0) - (re-search-forward "\\<begin\\>\\|\\<end\\>") - (backward-word 1) - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?e ?E)) - (1+ count) - (1- count)))) - (backward-word -1))) - ;; If block level not found, jump back to origin and signal an error - (error (progn - (goto-char origin) - (error "No higher block level"))) - (quit (progn - (goto-char origin) - (signal 'quit nil)))))) - - -(defun simula-forward-down-level (count) - "Move forward down COUNT block levels. -If COUNT is negative, move backward down block level instead." - (interactive "p") - ;; When we search for a deeper block level, we must never - ;; get out of the block where we started -> count >= start-count - (let ((start-count count) - (origin (point)) - (case-fold-search t)) - (condition-case () - (if (< count 0) - (while (< count 0) - (re-search-backward "\\<begin\\>\\|\\<end\\>") - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?e ?E)) - (1+ count) - (1- count)))) - (if (< count start-count) (signal 'error nil))) - (while (> count 0) - (re-search-forward "\\<begin\\>\\|\\<end\\>") - (backward-word 1) - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?b ?B)) - (1- count) - (1+ count)))) - (backward-word -1) - ;; deeper level has to be found within starting block - (if (> count start-count) (signal 'error nil)))) - ;; If block level not found, jump back to origin and signal an error - (error (progn - (goto-char origin) - (error "No containing block level"))) - (quit (progn - (goto-char origin) - (signal 'quit nil)))))) - - -(defun simula-previous-statement (count) - "Move backward COUNT statements. -If COUNT is negative, move forward instead." - (interactive "p") - (if (< count 0) - (simula-next-statement (- count)) - (let (status - (case-fold-search t) - (origin (point))) - (condition-case () - ;; - (progn - (simula-skip-comment-backward) - (if (memq (preceding-char) '(?n ?N)) - (progn - (backward-word 1) - (if (not (looking-at "\\<begin\\>")) - (backward-word -1))) - (if (eq (preceding-char) ?\;) - (backward-char 1)) - ) - (while (and (natnump (setq count (1- count))) - (setq status (simula-search-backward - ";\\|\\<begin\\>" nil 'move)))) - (if status - (progn - (if (eq (following-char) ?\;) - (forward-char 1) - (backward-word -1)))) - (simula-skip-comment-forward)) - (error (progn (goto-char origin) - (error "Incomplete statement (too many ENDs)"))) - (quit (progn (goto-char origin) (signal 'quit nil))))))) - - -(defun simula-next-statement (count) - "Move forward COUNT statements. -If COUNT is negative, move backward instead." - (interactive "p") - (if (< count 0) - (simula-previous-statement (- count)) - (let (status - (case-fold-search t) - (origin (point))) - (condition-case () - (progn - (simula-skip-comment-forward) - (if (looking-at "\\<end\\>") (forward-word 1)) - (while (and (natnump (setq count (1- count))) - (setq status (simula-search-forward - ";\\|\\<end\\>" (point-max) 'move)))) - (if (and status (/= (preceding-char) ?\;)) - (progn - (backward-word 1) - (simula-skip-comment-backward)))) - (error (progn (goto-char origin) - (error "Incomplete statement (too few ENDs)"))) - (quit (progn (goto-char origin) (signal 'quit nil))))))) - - -(defun simula-skip-comment-backward (&optional stop-at-end) - "Search towards bob to find first char that is outside a comment." - (interactive) - (catch 'simula-out - (let (context) - (while t - (skip-chars-backward " \t\n\f") - (if (eq (preceding-char) ?\;) - (save-excursion - (backward-char 1) - (setq context (simula-context)) - (if (and stop-at-end (eq context 2)) - (setq context nil))) - (setq context (simula-context))) - (cond - ((memq context '(nil 3 4)) - ;; check to see if we found a label - (if (and (eq (preceding-char) ?:) - (not (memq (following-char) '(?- ?=))) - (save-excursion - (skip-chars-backward ": \t\fa-zA-Z0-9_") - (not (looking-at "virtual\\>")))) - (skip-chars-backward ": \t\fa-zA-Z0-9_") - (throw 'simula-out nil))) - ((eq context 0) - ;; since we are inside a comment, it must start somewhere! - (while (and (re-search-backward "!\\|\\<comment\\>") - (memq (simula-context) '(0 1))))) - ((eq context 1) - (beginning-of-line) - (if (bobp) - (throw 'simula-out nil) - (backward-char))) - ((eq context 2) - ;; an END-comment must belong to an END - (re-search-backward "\\<end\\>") - (forward-word 1) - (throw 'simula-out nil)) - ;; should be impossible to get here.. - ))))) - - -(defun simula-skip-comment-forward () - "Search towards eob to find first char that is outside a comment." - ;; this function assumes we start with point .outside a comment - (interactive) - (catch 'simula-out - (while t - (skip-chars-forward " \t\n\f") - ;; BUG: the following (0 2) branches don't take into account intermixing - ;; directive lines - (cond - ((looking-at "!\\|\\<comment\\>") - (search-forward ";" nil 'move)) - ((and (bolp) (eq (following-char) ?%)) - (beginning-of-line 2)) - ((and (looking-at "[a-z0-9_]*[ \t\f]*:[^-=]") - (not (looking-at "virtual\\>"))) - (skip-chars-forward "a-zA-Z0-9_ \t\f:")) - (t - (throw 'simula-out t)))))) - - -(defun simula-forward-up-level () - (let ((continue-loop t) - (origin (point)) - (case-fold-search t) - return-value - temp) - (while continue-loop - (if (re-search-backward "\\<begin\\>\\|\\<end\\>" (point-min) 'move) - (setq temp (simula-context) - return-value (and (memq (preceding-char) '(?d ?D)) - (memq temp '(nil 2))) - continue-loop (and (not return-value) - (simula-forward-up-level))) - (setq continue-loop nil))) - (if return-value - t - (goto-char origin) - nil))) - - -(defun simula-calculate-indent () - (save-excursion - (let ((where (simula-context)) - (origin (point)) - (indent 0) - continued - start-line - temp - found-end - prev-cont) - (cond - ((eq where 0) - ;; - ;; Comment. - ;; If comment started on previous non-blank line, indent to the - ;; column where the comment started, else indent as that line. - ;; - (skip-chars-backward " \t\n\f") - (while (and (not (bolp)) (eq (simula-context) 0)) - (re-search-backward "^\\|!\\|\\<comment\\>")) - (skip-chars-forward " \t\n\f") - (prog1 - (current-column) - (goto-char origin))) - ((eq where 1) - ;; - ;; Directive. Always 0. - ;; - 0) - ;; - ;; Detect missing string delimiters - ;; - ((eq where 3) - (error "Inside string")) - ((eq where 4) - (error "Inside character constant")) - ;; - ;; check to see if inside ()'s - ;; - ((setq temp (simula-inside-parens)) - temp) - ;; - ;; Calculate non-comment indentation - (t - ;; first, find out if this line starts with something that needs - ;; special indentation (END/IF/THEN/ELSE/WHEN/OTHERWISE or label) - ;; - (skip-chars-forward " \t\f") - (cond - ;; - ;; END - ;; - ((looking-at "end\\>") - (setq indent (- simula-indent-level) - found-end t)) - ;; - ;; IF/THEN/ELSE - ;; - ((looking-at "if\\>\\|then\\>\\|else\\>") - ;; search for the *starting* IF - (cond - ((memq (following-char) '(?T ?t)) - (setq indent (car simula-if-indent))) - ((memq (following-char) '(?E ?e)) - (setq indent (cdr simula-if-indent))) - (t - (forward-word 1) - (setq indent 0))) - (simula-find-if)) - ;; - ;; WHEN/OTHERWISE - ;; - ((looking-at "when\\>\\|otherwise\\>") - ;; search for corresponding INSPECT - (if (memq (following-char) '(?W ?w)) - (setq indent (car simula-inspect-indent)) - (setq indent (cdr simula-inspect-indent))) - (simula-find-inspect)) - ;; - ;; label: - ;; - ((and (not (looking-at "virtual\\>")) - (looking-at "[a-z0-9_]*[ \t\f]*:[^-=]")) - (setq indent simula-label-offset))) - ;; find line with non-comment text - (simula-skip-comment-backward 'dont-skip-end) - (if (and found-end - (not (eq (preceding-char) ?\;)) - (if (memq (preceding-char) '(?N ?n)) - (save-excursion - (backward-word 1) - (not (looking-at "begin\\>"))) - t)) - (progn - (simula-previous-statement 1) - (simula-skip-comment-backward))) - (setq start-line - (save-excursion (beginning-of-line) (point)) - ;; - perhaps this is a continued statement - continued - (save-excursion - (and (not (bobp)) - ;; (not found-end) - (if (eq (char-syntax (preceding-char)) ?w) - (progn - (backward-word 1) - (not (looking-at - "begin\\|then\\|else\\|when\\|otherwise\\|do" - ))) - (not (memq (preceding-char) '(?: ?\;))))))) - ;; - ;; MAIN calculation loop - count BEGIN/DO etc. - ;; - (while (not (bolp)) - (if (re-search-backward - ";\\|\\<\\(begin\\|end\\|if\\|else\\|then\\|when\\|otherwise\\|do\\)\\>" - start-line 'move) - (if (simula-context) - ();; found something in a comment/string - ignore - (setq temp (following-char)) - (cond - ((eq temp ?\;) - (simula-previous-statement 1)) - ((looking-at "begin\\>") - (setq indent (+ indent simula-indent-level))) - ((looking-at "end\\>") - (forward-word 1) - (simula-previous-statement 1)) - ((looking-at "do\\>") - (setq indent (+ indent simula-substatement-offset)) - (simula-find-do-match)) - ((looking-at "\\(if\\|then\\|else\\)\\>") - (if (memq temp '(?I ?i)) - (forward-word 1) - (setq indent (+ indent - simula-substatement-offset - (if (memq temp '(?T ?t)) - (car simula-if-indent) - (cdr simula-if-indent))))) - (simula-find-if)) - ((looking-at "\\<when\\>\\|\\<otherwise\\>") - (setq indent (+ indent - simula-substatement-offset - (if (memq temp '(?W ?w)) - (car simula-if-indent) - (cdr simula-if-indent)))) - (simula-find-inspect))) - ;; found the start of a [sub]statement - ;; add indentation for continued statement - (if continued - (setq indent - (+ indent - (if (listp simula-continued-statement-offset) - (car simula-continued-statement-offset) - simula-continued-statement-offset)))) - (setq start-line - (save-excursion (beginning-of-line) (point)) - continued nil)) - ;; search failed .. point is at beginning of line - ;; determine if we should continue searching - ;; (at or before comment or label) - ;; temp = t means finished - (setq temp - (and (not (simula-context)) - (save-excursion - (skip-chars-forward " \t\f") - (or (looking-at "virtual") - (not - (looking-at - "!\\|comment\\>\\|[a-z0-9_]*[ \t\f]*:[^-=]"))))) - prev-cont continued) - ;; if we are finished, find current line's indentation - (if temp - (setq indent (+ indent (current-indentation)))) - ;; find next line with non-comment SIMULA text - ;; maybe indent extra if statement continues - (simula-skip-comment-backward) - (setq continued - (and (not (bobp)) - (if (eq (char-syntax (preceding-char)) ?w) - (save-excursion - (backward-word 1) - (not (looking-at - "begin\\|then\\|else\\|when\\|otherwise\\|do"))) - (not (memq (preceding-char) '(?: ?\;)))))) - ;; if we the state of the continued-variable - ;; changed, add indentation for continued statement - (if (or (and prev-cont (not continued)) - (and continued - (listp simula-continued-statement-offset))) - (setq indent - (+ indent - (if (listp simula-continued-statement-offset) - (car simula-continued-statement-offset) - simula-continued-statement-offset)))) - ;; while ends if point is at beginning of line at loop test - (if (not temp) - (setq start-line (save-excursion (beginning-of-line) (point))) - (beginning-of-line)))) - ;; - ;; return indentation - ;; - indent))))) - - -(defun simula-find-if () - "Find starting IF of a IF-THEN[-ELSE[-IF-THEN...]] statement." - (catch 'simula-out - (while t - (if (and (simula-search-backward "\\<if\\>\\|;\\|\\<begin\\>"nil t) - (memq (following-char) '(?I ?i))) - (save-excursion - ;; - ;; find out if this IF was really the start of the IF statement - ;; - (simula-skip-comment-backward) - (if (and (eq (char-syntax (preceding-char)) ?w) - (progn - (backward-word 1) - (looking-at "else\\>"))) - () - (throw 'simula-out t))) - (if (not (looking-at "\\<if\\>")) - (error "Missing IF or misplaced BEGIN or ';' (can't find IF)") - ;; - ;; we were at the starting IF in the first place.. - ;; - (throw 'simula-out t)))))) - - -(defun simula-find-inspect () - "Find INSPECT matching WHEN or OTHERWISE." - (catch 'simula-out - (let ((level 0)) - ;; - ;; INSPECTs can be nested, have to find the corresponding one - ;; - (while t - (if (and (simula-search-backward "\\<inspect\\>\\|\\<otherwise\\>\\|;" - nil t) - (/= (following-char) ?\;)) - (if (memq (following-char) '(?O ?o)) - (setq level (1+ level)) - (if (zerop level) - (throw 'simula-out t) - (setq level (1- level)))) - (error "Missing INSPECT or misplaced ';' (can't find INSPECT)")))))) - - -(defun simula-find-do-match () - "Find keyword matching DO: FOR, WHILE, INSPECT or WHEN" - (while (and (re-search-backward - "\\<\\(do\\|for\\|while\\|inspect\\|when\\|end\\|begin\\)\\>\\|;" - nil 'move) - (simula-context))) - (if (and (looking-at "\\<\\(for\\|while\\|inspect\\|when\\)\\>") - (not (simula-context))) - () ;; found match - (error "No matching FOR, WHILE or INSPECT for DO, or misplaced ';'"))) - - -(defun simula-inside-parens () - "Return position after `(' on line if inside parentheses, nil otherwise." - (save-excursion - (let ((parlevel 0)) - (catch 'simula-out - (while t - (if (re-search-backward "(\\|)\\|;" nil t) - (if (eq (simula-context) nil) - ;; found something - check it out - (cond - ((eq (following-char) ?\;) - (if (zerop parlevel) - (throw 'simula-out nil) - (error "Parenthesis mismatch or misplaced ';'"))) - ((eq (following-char) ?\() - (if (zerop parlevel) - (throw 'simula-out (1+ (current-column))) - (setq parlevel (1- parlevel)))) - (t (setq parlevel (1+ parlevel)))) - );; nothing - inside comment or string - ;; search failed - (throw 'simula-out nil))))))) - - -(defun simula-goto-definition () - "Goto point of definition of variable, procedure or class." - (interactive)) - - -(defun simula-expand-stdproc () - (if (or (not simula-abbrev-stdproc) (simula-context)) - (unexpand-abbrev) - (cond - ((eq simula-abbrev-stdproc 'upcase) (upcase-word -1)) - ((eq simula-abbrev-stdproc 'downcase) (downcase-word -1)) - ((eq simula-abbrev-stdproc 'capitalize) (capitalize-word -1)) - ((eq simula-abbrev-stdproc 'abbrev-table) - ;; If not in lowercase, expansions are always capitalized. - ;; We then want to replace with the exact expansion. - (if (equal (symbol-name last-abbrev) last-abbrev-text) - () - (downcase-word -1) - (expand-abbrev)))))) - - -(defun simula-expand-keyword () - (if (or (not simula-abbrev-keyword) (simula-context)) - (unexpand-abbrev) - (cond - ((eq simula-abbrev-keyword 'upcase) (upcase-word -1)) - ((eq simula-abbrev-keyword 'downcase) (downcase-word -1)) - ((eq simula-abbrev-keyword 'capitalize) (capitalize-word -1)) - ((eq simula-abbrev-stdproc 'abbrev-table) - (if (equal (symbol-name last-abbrev) last-abbrev-text) - () - (downcase-word -1) - (expand-abbrev)))))) - - -(defun simula-electric-keyword () - "Expand SIMULA keyword. If it starts the line, reindent." - ;; redisplay - (let ((show-char (eq this-command 'self-insert-command))) - ;; If the abbrev expansion results in reindentation, the user may have - ;; to wait some time before the character he typed is displayed - ;; (the char causing the expansion is inserted AFTER the hook function - ;; is called). This is annoying in case of normal characters. - ;; However, if the user pressed a key bound to newline, it is better - ;; to have the line inserted after the begin-end match. - (if show-char - (progn - (insert-char last-command-char 1) - (sit-for 0) - (backward-char 1))) - (if (let ((where (simula-context)) - (case-fold-search t)) - (if where - (if (and (eq where 2) (eq (char-syntax (preceding-char)) ?w)) - (save-excursion - (backward-word 1) - (not (looking-at "end\\>")))))) - (unexpand-abbrev) - (cond - ((not simula-abbrev-keyword) (unexpand-abbrev)) - ((eq simula-abbrev-keyword 'upcase) (upcase-word -1)) - ((eq simula-abbrev-keyword 'downcase) (downcase-word -1)) - ((eq simula-abbrev-keyword 'capitalize) (capitalize-word -1))) - (let ((pos (- (point-max) (point))) - (case-fold-search t) - null) - (condition-case null - (progn - ;; check if the expanded word is on the beginning of the line. - (if (and (eq (char-syntax (preceding-char)) ?w) - (progn - (backward-word 1) - (if (looking-at "end\\>") - (save-excursion - (simula-backward-up-level 1) - (if (pos-visible-in-window-p) - (sit-for 1) - (message "Matches %s" - (buffer-substring - (point) - (+ (point) (window-width))))))) - (skip-chars-backward " \t\f") - (bolp))) - (let ((indent (simula-calculate-indent))) - (if (eq indent (current-indentation)) - () - (delete-horizontal-space) - (indent-to indent))) - (skip-chars-forward " \t\f")) - ;; check for END - blow whistles and ring bells - - (goto-char (- (point-max) pos)) - (if show-char - (delete-char 1))) - (quit (goto-char (- (point-max) pos)))))))) - - -(defun simula-search-backward (regexp &optional bound noerror) - "Search backward from point for regular expression REGEXP, ignoring matches -found inside SIMULA comments, string literals, and BEGIN..END blocks. -Set point to the end of the occurrence found, and return point. -An optional second argument BOUND bounds the search, it is a buffer position. -The match found must not extend after that position. Optional third argument -NOERROR, if t, means if fail just return nil (no error). -If not nil and not t, move to limit of search and return nil." - (let (begin end context (comb-regexp (concat regexp "\\|\\<end\\>")) - match (start-point (point))) - (catch 'simula-backward - (while (re-search-backward comb-regexp bound 1) - ;; We have a match, check SIMULA context at match-beginning - ;; to see if we are outside comments etc. - ;; Set MATCH to t if we found a true match, - ;; set MATCH to 'BLOCK if we found a BEGIN..END block, - ;; else set MATCH to nil. - (save-match-data - (setq context (simula-context)) - (cond - ((eq context nil) - (setq match (if (looking-at regexp) t 'BLOCK))) -;;; A comment-ending semicolon is part of the comment, and shouldn't match. -;;; ((eq context 0) -;;; (setq match (if (eq (following-char) ?\;) t nil))) - ((eq context 2) - (setq match (if (and (looking-at regexp) - (looking-at ";\\|\\<end\\>\\|\\<else\\>\\|\\<otherwise\\>\\|\\<when\\>")) - t - (if (looking-at "\\<end\\>") 'BLOCK nil)))) - (t (setq match nil)))) - ;; Exit if true match - (if (eq match t) (throw 'simula-backward (point))) - (if (eq match 'BLOCK) - ;; We found the END of a block - (let ((level 0)) - (while (natnump level) - (if (re-search-backward "\\<begin\\>\\|\\<end\\>" bound 1) - (let ((context (simula-context))) - ;; We found a BEGIN -> decrease level count - (cond ((and (eq context nil) - (memq (following-char) '(?b ?B))) - (setq level (1- level))) - ;; END -> increase level count - ((and (memq context '(nil 2)) - (memq (following-char) '(?e ?E))) - (setq level (1+ level))))) - ;; Block search failed. Action depends on noerror. - (if (or (not noerror) (eq noerror t)) - (goto-char start-point)) - (if (not noerror) - (signal 'search-failed (list regexp))) - (throw 'simula-backward nil)))))) - ;; Search failed. Action depends on noerror. - (if (or (not noerror) (eq noerror t)) - (goto-char start-point)) - (if noerror - nil - (signal 'search-failed (list regexp)))))) - - -(defun simula-search-forward (regexp &optional bound noerror) - "Search forward from point for regular expression REGEXP, ignoring matches -found inside SIMULA comments, string literals, and BEGIN..END blocks. -Set point to the end of the occurrence found, and return point. -An optional second argument BOUND bounds the search, it is a buffer position. -The match found must not extend after that position. Optional third argument -NOERROR, if t, means if fail just return nil (no error). -If not nil and not t, move to limit of search and return nil." - (let (begin end context (comb-regexp (concat regexp "\\|\\<begin\\>")) - match (start-point (point))) - (catch 'simula-forward - (while (re-search-forward comb-regexp bound 1) - ;; We have a match, check SIMULA context at match-beginning - ;; to see if we are outside comments. - ;; Set MATCH to t if we found a true match, - ;; set MATCH to 'BLOCK if we found a BEGIN..END block, - ;; else set MATCH to nil. - (save-match-data - (save-excursion - (goto-char (match-beginning 0)) - (setq context (simula-context)) - (cond - ((not context) - (setq match (if (looking-at regexp) t 'BLOCK))) -;;; A comment-ending semicolon is part of the comment, and shouldn't match. -;;; ((eq context 0) -;;; (setq match (if (eq (following-char) ?\;) t nil))) - ((eq context 2) - (setq match (if (and (looking-at regexp) - (looking-at ";\\|\\<end\\>\\|\\<else\\>\\|\\<otherwise\\>\\|\\<when\\>")) t nil))) - (t (setq match nil))))) - ;; Exit if true match - (if (eq match t) (throw 'simula-forward (point))) - (if (eq match 'BLOCK) - ;; We found the BEGINning of a block - (let ((level 0)) - (while (natnump level) - (if (re-search-forward "\\<begin\\>\\|\\<end\\>" bound 1) - (let ((context (simula-context))) - ;; We found a BEGIN -> increase level count - (cond ((eq context nil) (setq level (1+ level))) - ;; END -> decrease level count - ((and (eq context 2) - ;; Don't match BEGIN inside END comment - (memq (preceding-char) '(?d ?D))) - (setq level (1- level))))) - ;; Block search failed. Action depends on noerror. - (if (or (not noerror) (eq noerror t)) - (goto-char start-point)) - (if (not noerror) - (signal 'search-failed (list regexp))) - (throw 'simula-forward nil)))))) - ;; Search failed. Action depends on noerror. - (if (or (not noerror) (eq noerror t)) - (goto-char start-point)) - (if noerror - nil - (signal 'search-failed (list regexp)))))) - - -(defun simula-install-standard-abbrevs () - "Define Simula keywords, procedures and classes in local abbrev table." - ;; procedure and class names are as of the SIMULA 87 standard. - (interactive) - (mapcar (function (lambda (args) - (apply 'define-abbrev simula-mode-abbrev-table args))) - '(("abs" "Abs" simula-expand-stdproc) - ("accum" "Accum" simula-expand-stdproc) - ("activate" "ACTIVATE" simula-expand-keyword) - ("addepsilon" "AddEpsilon" simula-expand-stdproc) - ("after" "AFTER" simula-expand-keyword) - ("and" "AND" simula-expand-keyword) - ("arccos" "ArcCos" simula-expand-stdproc) - ("arcsin" "ArcSin" simula-expand-stdproc) - ("arctan" "ArcTan" simula-expand-stdproc) - ("arctan2" "ArcTan2" simula-expand-stdproc) - ("array" "ARRAY" simula-expand-keyword) - ("at" "AT" simula-expand-keyword) - ("before" "BEFORE" simula-expand-keyword) - ("begin" "BEGIN" simula-expand-keyword) - ("blanks" "Blanks" simula-expand-stdproc) - ("boolean" "BOOLEAN" simula-expand-keyword) - ("breakoutimage" "BreakOutImage" simula-expand-stdproc) - ("bytefile" "ByteFile" simula-expand-stdproc) - ("call" "Call" simula-expand-stdproc) - ("cancel" "Cancel" simula-expand-stdproc) - ("cardinal" "Cardinal" simula-expand-stdproc) - ("char" "Char" simula-expand-stdproc) - ("character" "CHARACTER" simula-expand-keyword) - ("checkpoint" "CheckPoint" simula-expand-stdproc) - ("class" "CLASS" simula-expand-keyword) - ("clear" "Clear" simula-expand-stdproc) - ("clocktime" "ClockTime" simula-expand-stdproc) - ("close" "Close" simula-expand-stdproc) - ("comment" "COMMENT" simula-expand-keyword) - ("constant" "Constant" simula-expand-stdproc) - ("copy" "Copy" simula-expand-stdproc) - ("cos" "Cos" simula-expand-stdproc) - ("cosh" "CosH" simula-expand-stdproc) - ("cotan" "CoTan" simula-expand-stdproc) - ("cputime" "CpuTime" simula-expand-stdproc) - ("current" "Current" simula-expand-stdproc) - ("datetime" "DateTime" simula-expand-stdproc) - ("decimalmark" "DecimalMark" simula-expand-stdproc) - ("delay" "DELAY" simula-expand-keyword) - ("deleteimage" "DeleteImage" simula-expand-stdproc) - ("detach" "Detach" simula-expand-stdproc) - ("digit" "Digit" simula-expand-stdproc) - ("directbytefile" "DirectByteFile" simula-expand-stdproc) - ("directfile" "DirectFile" simula-expand-stdproc) - ("discrete" "Discrete" simula-expand-stdproc) - ("do" "DO" simula-expand-keyword) - ("downcase" "Downcase" simula-expand-stdproc) - ("draw" "Draw" simula-expand-stdproc) - ("eject" "Eject" simula-expand-stdproc) - ("else" "ELSE" simula-electric-keyword) - ("empty" "Empty" simula-expand-stdproc) - ("end" "END" simula-electric-keyword) - ("endfile" "Endfile" simula-expand-stdproc) - ("entier" "Entier" simula-expand-stdproc) - ("eq" "EQ" simula-expand-keyword) - ("eqv" "EQV" simula-expand-keyword) - ("erlang" "Erlang" simula-expand-stdproc) - ("error" "Error" simula-expand-stdproc) - ("evtime" "EvTime" simula-expand-stdproc) - ("exp" "Exp" simula-expand-stdproc) - ("external" "EXTERNAL" simula-expand-keyword) - ("false" "FALSE" simula-expand-keyword) - ("field" "Field" simula-expand-stdproc) - ("file" "File" simula-expand-stdproc) - ("first" "First" simula-expand-stdproc) - ("follow" "Follow" simula-expand-stdproc) - ("for" "FOR" simula-expand-keyword) - ("ge" "GE" simula-expand-keyword) - ("getchar" "GetChar" simula-expand-stdproc) - ("getfrac" "GetFrac" simula-expand-stdproc) - ("getint" "GetInt" simula-expand-stdproc) - ("getreal" "GetReal" simula-expand-stdproc) - ("go" "GO" simula-expand-keyword) - ("goto" "GOTO" simula-expand-keyword) - ("gt" "GT" simula-expand-keyword) - ("head" "Head" simula-expand-stdproc) - ("hidden" "HIDDEN" simula-expand-keyword) - ("histd" "HistD" simula-expand-stdproc) - ("histo" "Histo" simula-expand-stdproc) - ("hold" "Hold" simula-expand-stdproc) - ("idle" "Idle" simula-expand-stdproc) - ("if" "IF" simula-expand-keyword) - ("image" "Image" simula-expand-stdproc) - ("imagefile" "ImageFile" simula-expand-stdproc) - ("imp" "IMP" simula-expand-keyword) - ("in" "IN" simula-expand-keyword) - ("inbyte" "InByte" simula-expand-stdproc) - ("inbytefile" "InByteFile" simula-expand-stdproc) - ("inchar" "InChar" simula-expand-stdproc) - ("infile" "InFile" simula-expand-stdproc) - ("infrac" "InFrac" simula-expand-stdproc) - ("inimage" "InImage" simula-expand-stdproc) - ("inint" "InInt" simula-expand-stdproc) - ("inner" "INNER" simula-expand-keyword) - ("inreal" "InReal" simula-expand-stdproc) - ("inrecord" "InRecord" simula-expand-stdproc) - ("inspect" "INSPECT" simula-expand-keyword) - ("integer" "INTEGER" simula-expand-keyword) - ("intext" "InText" simula-expand-stdproc) - ("into" "Into" simula-expand-stdproc) - ("is" "IS" simula-expand-keyword) - ("isochar" "ISOChar" simula-expand-stdproc) - ("isopen" "IsOpen" simula-expand-stdproc) - ("isorank" "ISORank" simula-expand-stdproc) - ("label" "LABEL" simula-expand-keyword) - ("last" "Last" simula-expand-stdproc) - ("lastitem" "LastItem" simula-expand-stdproc) - ("lastloc" "LastLoc" simula-expand-stdproc) - ("le" "LE" simula-expand-keyword) - ("length" "Length" simula-expand-stdproc) - ("letter" "Letter" simula-expand-stdproc) - ("line" "Line" simula-expand-stdproc) - ("linear" "Linear" simula-expand-stdproc) - ("linesperpage" "LinesPerPage" simula-expand-stdproc) - ("link" "Link" simula-expand-stdproc) - ("linkage" "Linkage" simula-expand-stdproc) - ("ln" "Ln" simula-expand-stdproc) - ("locate" "Locate" simula-expand-stdproc) - ("location" "Location" simula-expand-stdproc) - ("lock" "Lock" simula-expand-stdproc) - ("locked" "Locked" simula-expand-stdproc) - ("log10" "Log10" simula-expand-stdproc) - ("long" "LONG" simula-expand-keyword) - ("lowcase" "LowCase" simula-expand-stdproc) - ("lowerbound" "LowerBound" simula-expand-stdproc) - ("lowten" "LowTen" simula-expand-stdproc) - ("lt" "LT" simula-expand-keyword) - ("main" "Main" simula-expand-stdproc) - ("max" "Max" simula-expand-stdproc) - ("maxint" "MaxInt" simula-expand-stdproc) - ("maxlongreal" "MaxLongReal" simula-expand-stdproc) - ("maxloc" "MaxLoc" simula-expand-stdproc) - ("maxrank" "MaxRank" simula-expand-stdproc) - ("maxreal" "MaxReal" simula-expand-stdproc) - ("min" "Min" simula-expand-stdproc) - ("minint" "MinInt" simula-expand-stdproc) - ("minlongreal" "MinLongReal" simula-expand-stdproc) - ("minrank" "MinRank" simula-expand-stdproc) - ("minreal" "MinReal" simula-expand-stdproc) - ("mod" "Mod" simula-expand-stdproc) - ("more" "More" simula-expand-stdproc) - ("name" "NAME" simula-expand-keyword) - ("ne" "NE" simula-expand-keyword) - ("negexp" "NegExp" simula-expand-stdproc) - ("new" "NEW" simula-expand-keyword) - ("nextev" "NextEv" simula-expand-stdproc) - ("none" "NONE" simula-expand-keyword) - ("normal" "Normal" simula-expand-stdproc) - ("not" "NOT" simula-expand-keyword) - ("notext" "NOTEXT" simula-expand-keyword) - ("open" "Open" simula-expand-stdproc) - ("or" "OR" simula-expand-keyword) - ("otherwise" "OTHERWISE" simula-electric-keyword) - ("out" "Out" simula-expand-stdproc) - ("outbyte" "OutByte" simula-expand-stdproc) - ("outbytefile" "OutByteFile" simula-expand-stdproc) - ("outchar" "OutChar" simula-expand-stdproc) - ("outfile" "OutFile" simula-expand-stdproc) - ("outfix" "OutFix" simula-expand-stdproc) - ("outfrac" "OutFrac" simula-expand-stdproc) - ("outimage" "OutImage" simula-expand-stdproc) - ("outint" "OutInt" simula-expand-stdproc) - ("outreal" "OutReal" simula-expand-stdproc) - ("outrecord" "OutRecord" simula-expand-stdproc) - ("outtext" "OutText" simula-expand-stdproc) - ("page" "Page" simula-expand-stdproc) - ("passivate" "Passivate" simula-expand-stdproc) - ("poisson" "Poisson" simula-expand-stdproc) - ("pos" "Pos" simula-expand-stdproc) - ("precede" "Precede" simula-expand-stdproc) - ("pred" "Pred" simula-expand-stdproc) - ("prev" "Prev" simula-expand-stdproc) - ("printfile" "PrintFile" simula-expand-stdproc) - ("prior" "PRIOR" simula-expand-keyword) - ("procedure" "PROCEDURE" simula-expand-keyword) - ("process" "Process" simula-expand-stdproc) - ("protected" "PROTECTED" simula-expand-keyword) - ("putchar" "PutChar" simula-expand-stdproc) - ("putfix" "PutFix" simula-expand-stdproc) - ("putfrac" "PutFrac" simula-expand-stdproc) - ("putint" "PutInt" simula-expand-stdproc) - ("putreal" "PutReal" simula-expand-stdproc) - ("qua" "QUA" simula-expand-keyword) - ("randint" "RandInt" simula-expand-stdproc) - ("rank" "Rank" simula-expand-stdproc) - ("reactivate" "REACTIVATE" simula-expand-keyword) - ("real" "REAL" simula-expand-keyword) - ("ref" "REF" simula-expand-keyword) - ("resume" "Resume" simula-expand-stdproc) - ("setaccess" "SetAccess" simula-expand-stdproc) - ("setpos" "SetPos" simula-expand-stdproc) - ("short" "SHORT" simula-expand-keyword) - ("sign" "Sign" simula-expand-stdproc) - ("simset" "SimSet" simula-expand-stdproc) - ("simulaid" "SimulaId" simula-expand-stdproc) - ("simulation" "Simulation" simula-expand-stdproc) - ("sin" "Sin" simula-expand-stdproc) - ("sinh" "SinH" simula-expand-stdproc) - ("sourceline" "SourceLine" simula-expand-stdproc) - ("spacing" "Spacing" simula-expand-stdproc) - ("sqrt" "Sqrt" simula-expand-stdproc) - ("start" "Start" simula-expand-stdproc) - ("step" "STEP" simula-expand-keyword) - ("strip" "Strip" simula-expand-stdproc) - ("sub" "Sub" simula-expand-stdproc) - ("subepsilon" "SubEpsilon" simula-expand-stdproc) - ("suc" "Suc" simula-expand-stdproc) - ("switch" "SWITCH" simula-expand-keyword) - ("sysin" "SysIn" simula-expand-stdproc) - ("sysout" "SysOut" simula-expand-stdproc) - ("tan" "Tan" simula-expand-stdproc) - ("tanh" "TanH" simula-expand-stdproc) - ("terminate_program" "Terminate_Program" simula-expand-stdproc) - ("terminated" "Terminated" simula-expand-stdproc) - ("text" "TEXT" simula-expand-keyword) - ("then" "THEN" simula-electric-keyword) - ("this" "THIS" simula-expand-keyword) - ("time" "Time" simula-expand-stdproc) - ("to" "TO" simula-expand-keyword) - ("true" "TRUE" simula-expand-keyword) - ("uniform" "Uniform" simula-expand-stdproc) - ("unlock" "Unlock" simula-expand-stdproc) - ("until" "UNTIL" simula-expand-keyword) - ("upcase" "Upcase" simula-expand-stdproc) - ("upperbound" "UpperBound" simula-expand-stdproc) - ("value" "VALUE" simula-expand-keyword) - ("virtual" "VIRTUAL" simula-expand-keyword) - ("wait" "Wait" simula-expand-stdproc) - ("when" "WHEN" simula-electric-keyword) - ("while" "WHILE" simula-expand-keyword)))) - -;;; Font Lock mode support. -(eval-when-compile - (require 'cl)) - -;; SIMULA comments and strings are a mess. If we rely on the syntax table, -;; then %-comments may be shown incorrectly (and prematurely) ended by a -;; semicolon, !-comments by a newline and '-strings may screw up the rest of -;; the buffer. And of course we can't do comment- or end-comments using the -;; syntax table. We can do everything except end-comments in one fast regexp, -;; but we aught to do end-comments too, so we need a function. simon@gnu. -(defun simula-match-string-or-comment (limit) - ;; Return t if there is a string or comment before LIMIT. - ;; Matches buffer text so that if (match-string 1) is non-nil, it is the - ;; string. Otherwise, (match-string 0) is non-nil, and is the comment. - (when (re-search-forward - (eval-when-compile - (concat "\\(\"[^\"\n]*\"\\|'\\(.\\|![0-9]+!\\)'\\)\\|" - "\\(\\<end[ \t\n]+\\)\\|" - "^%[ \t].*\\|\\(!\\|\\<comment\\>\\)[^;]*;?")) - limit t) - (when (match-beginning 3) - ;; We've matched an end-comment. Yuck. Find the extent of it. - (store-match-data - (list (point) - (if (re-search-forward "\\<\\(end\\|else\\|when\\|otherwise\\)\\>\\|;" - limit 'move) - (match-beginning 0) - (point))))) - t)) - -;;; Hilit mode support. -(if (and (fboundp 'hilit-set-mode-patterns) - (boundp 'hilit-patterns-alist) - (not (assoc 'simula-mode hilit-patterns-alist))) - (hilit-set-mode-patterns - 'simula-mode - '( - ("^%\\([ \t\f].*\\)?$" nil comment) - ("^%include\\>" nil include) - ("\"[^\"\n]*\"\\|'.'\\|'![0-9]+!'" nil string) - ("\\<\\(ACTIVATE\\|AFTER\\|AND\\|ARRAY\\|AT\\|BEFORE\\|BEGIN\\|BOOLEAN\\|CHARACTER\\|CLASS\\|DELAY\\|DO\\|ELSE\\|END\\|EQ\\|EQV\\|EXTERNAL\\|FALSE\\|FOR\\|GE\\|GO\\|GOTO\\|GT\\|HIDDEN\\|IF\\|IMP\\|IN\\|INNER\\|INSPECT\\|INTEGER\\|IS\\|LABEL\\|LE\\|LONG\\|LT\\|NAME\\|NE\\|NEW\\|NONE\\|NOT\\|NOTEXT\\|OR\\|OTHERWISE\\|PRIOR\\|PROCEDURE\\|PROTECTED\\|QUA\\|REACTIVATE\\|REAL\\|REF\\|SHORT\\|STEP\\|SWITCH\\|TEXT\\|THEN\\|THIS\\|TO\\|TRUE\\|UNTIL\\|VALUE\\|VIRTUAL\\|WHEN\\|WHILE\\)\\>" nil keyword) - ("!\\|\\<COMMENT\\>" ";" comment)) - nil 'case-insensitive)) - -;; None of this seems to be used by anything, including hilit19.el. simon@gnu. -;(setq simula-find-comment-point -1 -; simula-find-comment-context nil) -; -;;; function used by hilit19 -;(defun simula-find-next-comment-region (param) -; "Return region (start end) cons of comment after point, or NIL" -; (let (start end) -; ;; This function is called repeatedly, check if point is -; ;; where we left it in the last call -; (if (not (eq simula-find-comment-point (point))) -; (setq simula-find-comment-point (point) -; simula-find-comment-context (simula-context))) -; ;; loop as long as we haven't found the end of a comment -; (if (memq simula-find-comment-context '(0 1 2)) -; (setq start (point)) -; (if (re-search-forward "\\<end\\>\\|!\\|\"\\|'\\|^%\\|\\<comment\\>" -; nil 'move) -; (let ((previous-char (preceding-char))) -; (cond -; ((memq previous-char '(?d ?D)) -; (setq start (point) -; simula-find-comment-context 2)) -; ((memq previous-char '(?t ?T ?\!)) -; (setq start (point) -; simula-find-comment-context 0)) -; ((eq previous-char ?%) -; (setq start (point) -; simula-find-comment-context 0)))))) -; ;; BUG: the following (0 2) branches don't take into account intermixing -; ;; directive lines -; (cond -; ((eq simula-find-comment-context 0) -; (search-forward ";" nil 'move)) -; ((eq simula-find-comment-context 1) -; (beginning-of-line 2)) -; ((eq simula-find-comment-context 2) -; (re-search-forward ";\\|\\<end\\>\\|\\<else\\>\\|\\<otherwise\\>\\|\\<when\\>\\" (point-max) 'move))) -; (if start -; (setq end (point))) -; ;; save point for later calls to this function -; (setq simula-find-comment-point (if end (point) -1)) -; (and end (cons start end)))) - -;; defuns for submitting bug reports - -(defconst simula-mode-help-address "simula-mode@ifi.uio.no" - "Address accepting submission of simula-mode bug reports.") - -(defun simula-submit-bug-report () - "Submit via mail a bug report on simula-mode." - (interactive) - (and - (y-or-n-p "Do you want to submit a report on simula-mode? ") - (reporter-submit-bug-report - simula-mode-help-address - (concat "simula-mode from Emacs " emacs-version) - (list - ;; report only the vars that affect indentation - 'simula-emacs-features - 'simula-indent-level - 'simula-substatement-offset - 'simula-continued-statement-offset - 'simula-label-offset - 'simula-if-indent - 'simula-inspect-indent - 'simula-electric-indent - 'simula-abbrev-keyword - 'simula-abbrev-stdproc - 'simula-abbrev-file - 'simula-tab-always-indent - )))) - -(provide 'simula-mode) - -;;; simula.el ends here diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el deleted file mode 100644 index ef8e27b68df..00000000000 --- a/lisp/progmodes/tcl.el +++ /dev/null @@ -1,2227 +0,0 @@ -;; tcl.el --- Tcl code editing commands for Emacs - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Maintainer: Tom Tromey <tromey@busco.lanl.gov> -;; Author: Tom Tromey <tromey@busco.lanl.gov> -;; Chris Lindblad <cjl@lcs.mit.edu> -;; Keywords: languages tcl modes -;; Version: $Revision: 1.50 $ - -;; 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 1, 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. - -;; HOW TO INSTALL: -;; Put the following forms in your .emacs to enable autoloading of Tcl -;; mode, and auto-recognition of ".tcl" files. -;; -;; (autoload 'tcl-mode "tcl" "Tcl mode." t) -;; (autoload 'inferior-tcl "tcl" "Run inferior Tcl process." t) -;; (setq auto-mode-alist (append '(("\\.tcl$" . tcl-mode)) auto-mode-alist)) -;; -;; If you plan to use the interface to the TclX help files, you must -;; set the variable tcl-help-directory-list to point to the topmost -;; directories containing the TclX help files. Eg: -;; -;; (setq tcl-help-directory-list '("/usr/local/lib/tclx/help")) -;; -;; Also you will want to add the following to your .emacs: -;; -;; (autoload 'tcl-help-on-word "tcl" "Help on Tcl commands" t) -;; -;; FYI a *very* useful thing to do is nroff all the Tk man pages and -;; put them in a subdir of the help system. -;; - -;;; Commentary: - -;; LCD Archive Entry: -;; tcl|Tom Tromey|tromey@busco.lanl.gov| -;; Major mode for editing Tcl| -;; $Date: 1996/03/23 05:14:50 $|$Revision: 1.50 $|~/modes/tcl.el.Z| - -;; CUSTOMIZATION NOTES: -;; * tcl-proc-list can be used to customize a list of things that -;; "define" other things. Eg in my project I put "defvar" in this -;; list. -;; * tcl-typeword-list is similar, but uses font-lock-type-face. -;; * tcl-keyword-list is a list of keywords. I've generally used this -;; for flow-control words. Eg I add "unwind_protect" to this list. -;; * tcl-type-alist can be used to minimally customize indentation -;; according to context. - -;; Change log: -;; $Log: tcl.el,v $ -;; Revision 1.50 1996/03/23 05:14:50 tromey -;; (tcl-using-emacs-19): Work with XEmacs 20.0. From Ben Wing. -;; -;; Revision 1.49 1995/12/07 18:27:47 tromey -;; (add-log-tcl-defun): Don't use tcl-beginning-of-defun; just go to end -;; of line before searching. -;; -;; Revision 1.48 1995/12/07 18:18:21 tromey -;; (add-log-tcl-defun): Now uses tcl-beginning-of-defun. -;; -;; Revision 1.47 1995/08/22 17:49:45 tromey -;; (tcl-hilit): New function from "Chris Alfeld" <calfeld@math.utah.edu> -;; (tcl-mode): Call it -;; -;; Revision 1.46 1995/08/07 16:02:01 tromey -;; (tcl-do-auto-fill): Only fill past fill-column; for 19.29. -;; (tcl-auto-fill-mode): Use force-mode-line-update. -;; -;; Revision 1.45 1995/07/23 23:51:25 tromey -;; (tcl-word-no-props): New function. -;; (tcl-figure-type): Use it. -;; (tcl-current-word): Ditto. -;; -;; Revision 1.44 1995/07/23 20:26:47 tromey -;; Doc fixes. -;; -;; Revision 1.43 1995/07/17 19:59:49 tromey -;; (inferior-tcl-mode): Use modeline-process if it exists. -;; -;; Revision 1.42 1995/07/17 19:55:25 tromey -;; XEmacs currently must use tcl-internal-end-of-defun -;; -;; Revision 1.41 1995/07/14 21:54:56 tromey -;; Changes to make menus work in XEmacs. -;; From Mike Scheidler <c23mts@kocrsv01.delcoelect.com> -;; -;; Revision 1.40 1995/07/11 03:13:15 tromey -;; (tcl-mode): Customize for new dabbrev. -;; -;; Revision 1.39 1995/07/09 21:58:03 tromey -;; (tcl-do-fill-paragraph): New function. -;; (tcl-mode): Set up for paragraph filling. -;; -;; Revision 1.38 1995/07/09 21:30:32 tromey -;; (tcl-mode): Fixes to 19.29 paragraph variables. -;; -;; Revision 1.37 1995/07/09 18:52:16 tromey -;; (tcl-do-auto-fill): Set fill-prefix. -;; -;; Revision 1.36 1995/07/09 01:07:57 tromey -;; (tcl-imenu-create-index-function): Work with imenu from Emacs 19.29 -;; -;; Revision 1.35 1995/06/27 20:12:00 tromey -;; (tcl-type-alist): More itcl changes. -;; -;; Revision 1.34 1995/06/27 20:06:05 tromey -;; More changes for itcl. -;; Bug fixes for Emacs 19.29. -;; -;; Revision 1.33 1995/06/27 20:01:29 tromey -;; (tcl-set-proc-regexp): Allow leading spaces. -;; (tcl-proc-list): Changes for itcl. -;; (tcl-typeword-list): Ditto. -;; (tcl-keyword-list): Ditto. -;; -;; Revision 1.32 1995/05/11 22:12:49 tromey -;; (tcl-type-alist): Include entry for "proc". -;; -;; Revision 1.31 1995/05/10 23:38:12 tromey -;; (tcl-add-fsf-menu): Use make-lucid-menu-keymap, not -;; "make-xemacs-menu-keymap". -;; -;; Revision 1.30 1995/05/10 18:22:21 tromey -;; Bug fix in menu code for XEmacs. -;; -;; Revision 1.29 1995/05/09 21:36:53 tromey -;; Changed "Lucid Emacs" to "XEmacs". -;; Tcl's popup menu now added to existing one, courtesy -;; dfarmer@evolving.com (Doug Farmer) -;; -;; Revision 1.28 1995/04/08 19:52:50 tromey -;; (tcl-outline-level): New function -;; (tcl-mode): Added outline-handling stuff. -;; From Jesper Pedersen <blackie@imada.ou.dk> -;; -;; Revision 1.27 1994/10/11 02:01:27 tromey -;; (tcl-mode): imenu-create-index-function made buffer local. -;; -;; Revision 1.26 1994/09/01 18:06:24 tromey -;; Added filename completion in inferior tcl mode -;; -;; Revision 1.25 1994/08/22 15:56:24 tromey -;; tcl-load-file default to current buffer. -;; -;; Revision 1.24 1994/08/21 20:33:05 tromey -;; Fixed bug in tcl-guess-application. -;; -;; Revision 1.23 1994/08/21 03:54:45 tromey -;; Keybindings don't overshadown comint bindings. -;; -;; Revision 1.22 1994/07/26 00:46:07 tromey -;; Emacs 18 changes from Carl Witty. -;; -;; Revision 1.21 1994/07/14 22:49:21 tromey -;; Added ";;;###autoload" comments where appropriate. -;; -; Revision 1.20 1994/06/05 16:57:22 tromey -; tcl-current-word does the right thing in inferior-tcl-mode. -; -; Revision 1.19 1994/06/03 21:09:19 tromey -; Another menu fix. -; -; Revision 1.18 1994/06/03 20:39:14 tromey -; Fixed menu bug. -; -; Revision 1.17 1994/06/03 00:47:15 tromey -; Fixed bug in bug-reporting code. -; -; Revision 1.16 1994/05/26 05:06:14 tromey -; Menu items now sensitive as appropriate. -; -; Revision 1.15 1994/05/22 20:38:11 tromey -; Added bug-report keybindings and menu entries. -; -; Revision 1.14 1994/05/22 20:18:28 tromey -; Even more compile stuff. -; -; Revision 1.13 1994/05/22 20:17:15 tromey -; Moved emacs version checking code to very beginning. -; -; Revision 1.12 1994/05/22 20:14:59 tromey -; Compile fixes. -; -; Revision 1.11 1994/05/22 20:12:44 tromey -; Fixed mark-defun for 19.23. -; More menu fixes. -; -; Revision 1.10 1994/05/22 20:02:03 tromey -; Fixed bug with M-;. -; Wrote bug-reporting code. -; -; Revision 1.9 1994/05/22 05:26:51 tromey -; Fixes for imenu. -; -; Revision 1.8 1994/05/22 03:38:07 tromey -; Fixed menu support. -; -; Revision 1.7 1994/05/03 01:23:42 tromey -; *** empty log message *** -; -; Revision 1.6 1994/04/23 16:23:36 tromey -; Wrote tcl-indent-for-comment -; -;; -;; 18-Mar-1994 Tom Tromey Fourth beta release. -;; Added {un,}comment-region to menu. Idea from -;; Mike Scheidler <c23mts@kocrsv01.delcoelect.com> -;; 17-Mar-1994 Tom Tromey -;; Fixed tcl-restart-with-file. Bug fix attempt in -;; tcl-internal-end-of-defun. -;; 16-Mar-1994 Tom Tromey Third beta release -;; Added support code for menu (from Tcl mode written by -;; schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid)). -;; 12-Mar-1994 Tom Tromey -;; Better documentation for inferior-tcl-buffer. Wrote -;; tcl-restart-with-file. Wrote Lucid Emacs menu (but no -;; code to install it). -;; 12-Mar-1994 Tom Tromey -;; Wrote tcl-guess-application. Another stab at making -;; tcl-omit-ws-regexp work. -;; 10-Mar-1994 Tom Tromey Second beta release -;; Last Modified: Thu Mar 10 01:24:25 1994 (Tom Tromey) -;; Wrote perl-mode style line indentation command. -;; Wrote more documentation. Added tcl-continued-indent-level. -;; Integrated help code. -;; 8-Mar-1994 Tom Tromey -;; Last Modified: Tue Mar 8 11:58:44 1994 (Tom Tromey) -;; Bug fixes. -;; 6-Mar-1994 Tom Tromey -;; Last Modified: Sun Mar 6 18:55:41 1994 (Tom Tromey) -;; Updated auto-newline support. -;; 6-Mar-1994 Tom Tromey Beta release -;; Last Modified: Sat Mar 5 17:24:32 1994 (Tom Tromey) -;; Wrote tcl-hashify-buffer. Other minor bug fixes. -;; 5-Mar-1994 Tom Tromey -;; Last Modified: Sat Mar 5 16:11:20 1994 (Tom Tromey) -;; Wrote electric-hash code. -;; 3-Mar-1994 Tom Tromey -;; Last Modified: Thu Mar 3 02:53:40 1994 (Tom Tromey) -;; Added code to handle auto-fill in comments. -;; Added imenu support code. -;; Cleaned up code. -;; Better font-lock support. -;; 28-Feb-1994 Tom Tromey -;; Last Modified: Mon Feb 28 14:08:05 1994 (Tom Tromey) -;; Made tcl-figure-type more easily configurable. -;; 28-Feb-1994 Tom Tromey -;; Last Modified: Mon Feb 28 01:02:58 1994 (Tom Tromey) -;; Wrote inferior-tcl mode. -;; 16-Feb-1994 Tom Tromey -;; Last Modified: Wed Feb 16 17:05:19 1994 (Tom Tromey) -;; Added support for font-lock-mode. -;; 29-Oct-1993 Tom Tromey -;; Last Modified: Sun Oct 24 17:39:14 1993 (Tom Tromey) -;; Patches from Guido Bosch to make things work with Lucid Emacs. -;; 22-Oct-1993 Tom Tromey -;; Last Modified: Fri Oct 22 15:26:46 1993 (Tom Tromey) -;; Made many characters have "_" syntax class; suggested by Guido -;; Bosch <Guido.Bosch@loria.fr>. Note that this includes the "$" -;; character, which might be a change you'd notice. -;; 21-Oct-1993 Tom Tromey -;; Last Modified: Thu Oct 21 20:28:40 1993 (Tom Tromey) -;; More fixes for tcl-omit-ws-regexp. -;; 20-Oct-1993 Tom Tromey -;; Started keeping history. Fixed tcl-{beginning,end}-of-defun. -;; Added some code to make things work with Emacs 18. - -;; THANKS TO: -;; Guido Bosch <Guido.Bosch@loria.fr> -;; pgs1002@esc.cam.ac.uk (Dr P.G. Sjoerdsma) -;; Mike Scheidler <c23mts@kocrsv01.delcoelect.com> -;; Matt Newman <men@charney.colorado.edu> -;; rwhitby@research.canon.oz.au (Rod Whitby) -;; h9118101@hkuxa.hku.hk (Yip Chi Lap [Beta]) -;; Pertti Tapio Kasanen <ptk@delta.hut.fi> -;; schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid) -;; warsaw@nlm.nih.gov (Barry A. Warsaw) -;; Carl Witty <cwitty@ai.mit.edu> -;; T. V. Raman <raman@crl.dec.com> -;; Jesper Pedersen <blackie@imada.ou.dk> -;; dfarmer@evolving.com (Doug Farmer) -;; "Chris Alfeld" <calfeld@math.utah.edu> -;; Ben Wing <wing@666.com> - -;; KNOWN BUGS: -;; * indent-region should skip blank lines. (It does in v19, so I'm -;; not motivated to fix it here). -;; * In Tcl "#" is not always a comment character. This can confuse -;; tcl.el in certain circumstances. For now the only workaround is -;; to enclose offending hash characters in quotes or precede it with -;; a backslash. Note that using braces won't work -- quotes change -;; the syntax class of characters between them, while braces do not. -;; The electric-# mode helps alleviate this problem somewhat. -;; * indent-tcl-exp is untested. -;; * Doesn't work under Emacs 18 yet. -;; * There's been a report that font-lock does strange things under -;; Lucid Emacs 19.6. For instance in "proc foobar", the space -;; before "foobar" is highlighted. - -;; TODO: -;; * make add-log-tcl-defun smarter. should notice if we are in the -;; middle of a defun, or between defuns. should notice if point is -;; on first line of defun (or maybe even in comments before defun). -;; * Allow continuation lines to be indented under the first argument -;; of the preceeding line, like this: -;; [list something \ -;; something-else] -;; * There is a request that indentation work like this: -;; button .fred -label Fred \ -;; -command {puts fred} -;; * Should have tcl-complete-symbol that queries the inferior process. -;; * Should have describe-symbol that works by sending the magic -;; command to a tclX process. -;; * Need C-x C-e binding (tcl-eval-last-exp). -;; * Write indent-region function that is faster than indenting each -;; line individually. -;; * tcl-figure-type should stop at "beginning of line" (only ws -;; before point, and no "\" on previous line). (see tcl-real-command-p). -;; * overrides some comint keybindings; fix. -;; * Trailing \ will eat blank lines. Should deal with this. -;; (this would help catch some potential bugs). -;; * Inferior should display in half the screen, not the whole screen. -;; * Indentation should deal with "switch". -;; * Consider writing code to find help files automatically (for -;; common cases). -;; * `#' shouldn't insert `\#' when point is in string. - - - -;;; Code: - -;; I sure wish Emacs had a package that made it easy to extract this -;; sort of information. Strange definition works with XEmacs 20.0. -(defconst tcl-using-emacs-19 (not (string-match "18\\." emacs-version)) - "Nil unless using Emacs 19 (XEmacs or FSF).") - -;; FIXME this will break on Emacs 19.100. -(defconst tcl-using-emacs-19-23 - (string-match "19\\.\\(2[3-9]\\|[3-9][0-9]\\)" emacs-version) - "Nil unless using Emacs 19-23 or later.") - -(defconst tcl-using-xemacs-19 (string-match "XEmacs" emacs-version) - "Nil unless using XEmacs).") - -(require 'comint) - -;; When compiling under GNU Emacs, load imenu during compilation. If -;; you have 19.22 or earlier, comment this out, or get imenu. -(and (fboundp 'eval-when-compile) - (eval-when-compile - (if (and (string-match "19\\." emacs-version) - (not (string-match "XEmacs" emacs-version))) - (require 'imenu)) - ())) - -(defconst tcl-version "$Revision: 1.50 $") -(defconst tcl-maintainer "Tom Tromey <tromey@drip.colorado.edu>") - -;; -;; User variables. -;; - -(defvar tcl-indent-level 4 - "*Indentation of Tcl statements with respect to containing block.") - -(defvar tcl-continued-indent-level 4 - "*Indentation of continuation line relative to first line of command.") - -(defvar tcl-auto-newline nil - "*Non-nil means automatically newline before and after braces -inserted in Tcl code.") - -(defvar tcl-tab-always-indent t - "*Control effect of TAB key. -If t (the default), always indent current line. -If nil and point is not in the indentation area at the beginning of -the line, a TAB is inserted. -Other values cause the first possible action from the following list -to take place: - - 1. Move from beginning of line to correct indentation. - 2. Delete an empty comment. - 3. Move forward to start of comment, indenting if necessary. - 4. Move forward to end of line, indenting if necessary. - 5. Create an empty comment. - 6. Move backward to start of comment, indenting if necessary.") - -(defvar tcl-use-hairy-comment-detector t - "*If not `nil', the the more complicated, but slower, comment -detecting function is used. This variable is only used in GNU Emacs -19 (the fast function is always used elsewhere).") - -(defvar tcl-electric-hash-style 'smart - "*Style of electric hash insertion to use. -Possible values are 'backslash, meaning that `\\' quoting should be -done; 'quote, meaning that `\"' quoting should be done; 'smart, -meaning that the choice between 'backslash and 'quote should be -made depending on the number of hashes inserted; or nil, meaning that -no quoting should be done. Any other value for this variable is -taken to mean 'smart. The default is 'smart.") - -(defvar tcl-help-directory-list nil - "*List of topmost directories containing TclX help files") - -(defvar tcl-use-smart-word-finder t - "*If not nil, use a better way of finding the current word when -looking up help on a Tcl command.") - -(defvar tcl-application "wish" - "*Name of Tcl application to run in inferior Tcl mode.") - -(defvar tcl-command-switches nil - "*Switches to supply to `tcl-application'.") - -(defvar tcl-prompt-regexp "^\\(% \\|\\)" - "*If not nil, a regexp that will match the prompt in the inferior process. -If nil, the prompt is the name of the application with \">\" appended. - -The default is \"^\\(% \\|\\)\", which will match the default primary -and secondary prompts for tclsh and wish.") - -(defvar inferior-tcl-source-command "source %s\n" - "*Format-string for building a Tcl command to load a file. -This format string should use `%s' to substitute a file name -and should result in a Tcl expression that will command the -inferior Tcl to load that file. The filename will be appropriately -quoted for Tcl.") - -;; -;; Keymaps, abbrevs, syntax tables. -;; - -(defvar tcl-mode-abbrev-table nil - "Abbrev table in use in Tcl-mode buffers.") -(if tcl-mode-abbrev-table - () - (define-abbrev-table 'tcl-mode-abbrev-table ())) - -(defvar tcl-mode-map () - "Keymap used in Tcl mode.") - -(defvar tcl-mode-syntax-table nil - "Syntax table in use in Tcl-mode buffers.") -(if tcl-mode-syntax-table - () - (setq tcl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?% "_" tcl-mode-syntax-table) - (modify-syntax-entry ?@ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?& "_" tcl-mode-syntax-table) - (modify-syntax-entry ?* "_" tcl-mode-syntax-table) - (modify-syntax-entry ?+ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?- "_" tcl-mode-syntax-table) - (modify-syntax-entry ?. "_" tcl-mode-syntax-table) - (modify-syntax-entry ?: "_" tcl-mode-syntax-table) - (modify-syntax-entry ?! "_" tcl-mode-syntax-table) - (modify-syntax-entry ?$ "_" tcl-mode-syntax-table) ; FIXME use "'"? - (modify-syntax-entry ?/ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?~ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?< "_" tcl-mode-syntax-table) - (modify-syntax-entry ?= "_" tcl-mode-syntax-table) - (modify-syntax-entry ?> "_" tcl-mode-syntax-table) - (modify-syntax-entry ?| "_" tcl-mode-syntax-table) - (modify-syntax-entry ?\( "()" tcl-mode-syntax-table) - (modify-syntax-entry ?\) ")(" tcl-mode-syntax-table) - (modify-syntax-entry ?\; "." tcl-mode-syntax-table) - (modify-syntax-entry ?\n "> " tcl-mode-syntax-table) - (modify-syntax-entry ?\f "> " tcl-mode-syntax-table) - (modify-syntax-entry ?# "< " tcl-mode-syntax-table)) - -(defvar inferior-tcl-mode-map nil - "Keymap used in Inferior Tcl mode.") - -;; XEmacs menu. -(defvar tcl-xemacs-menu - '(["Beginning of function" tcl-beginning-of-defun t] - ["End of function" tcl-end-of-defun t] - ["Mark function" tcl-mark-defun t] - ["Indent region" indent-region (tcl-mark)] - ["Comment region" comment-region (tcl-mark)] - ["Uncomment region" tcl-uncomment-region (tcl-mark)] - "----" - ["Show Tcl process buffer" inferior-tcl t] - ["Send function to Tcl process" tcl-eval-defun - (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] - ["Send region to Tcl process" tcl-eval-region - (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] - ["Send file to Tcl process" tcl-load-file - (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] - ["Restart Tcl process with file" tcl-restart-with-file t] - "----" - ["Tcl help" tcl-help-on-word tcl-help-directory-list] - ["Send bug report" tcl-submit-bug-report t]) - "XEmacs menu for Tcl mode.") - -;; GNU Emacs does menus via keymaps. Do it in a function in case we -;; later decide to add it to inferior Tcl mode as well. -(defun tcl-add-fsf-menu (map) - (define-key map [menu-bar] (make-sparse-keymap)) - ;; This fails in Emacs 19.22 and earlier. - (require 'lmenu) - (let ((menu (make-lucid-menu-keymap "Tcl" tcl-xemacs-menu))) - (define-key map [menu-bar tcl] (cons "Tcl" menu)) - ;; The following is intended to compute the key sequence - ;; information for the menu. It doesn't work. - (x-popup-menu nil menu))) - -(defun tcl-fill-mode-map () - (define-key tcl-mode-map "{" 'tcl-electric-char) - (define-key tcl-mode-map "}" 'tcl-electric-brace) - (define-key tcl-mode-map "[" 'tcl-electric-char) - (define-key tcl-mode-map "]" 'tcl-electric-char) - (define-key tcl-mode-map ";" 'tcl-electric-char) - (define-key tcl-mode-map "#" 'tcl-electric-hash) - ;; FIXME. - (define-key tcl-mode-map "\e\C-a" 'tcl-beginning-of-defun) - ;; FIXME. - (define-key tcl-mode-map "\e\C-e" 'tcl-end-of-defun) - ;; FIXME. - (define-key tcl-mode-map "\e\C-h" 'tcl-mark-defun) - (define-key tcl-mode-map "\e\C-q" 'indent-tcl-exp) - (define-key tcl-mode-map "\177" 'backward-delete-char-untabify) - (define-key tcl-mode-map "\t" 'tcl-indent-command) - (define-key tcl-mode-map "\M-;" 'tcl-indent-for-comment) - (define-key tcl-mode-map "\M-\C-x" 'tcl-eval-defun) - (define-key tcl-mode-map "\C-c\C-b" 'tcl-submit-bug-report) - (and (fboundp 'comment-region) - (define-key tcl-mode-map "\C-c\C-c" 'comment-region)) - (define-key tcl-mode-map "\C-c\C-i" 'tcl-help-on-word) - (define-key tcl-mode-map "\C-c\C-v" 'tcl-eval-defun) - (define-key tcl-mode-map "\C-c\C-f" 'tcl-load-file) - (define-key tcl-mode-map "\C-c\C-t" 'inferior-tcl) - (define-key tcl-mode-map "\C-c\C-x" 'tcl-eval-region) - (define-key tcl-mode-map "\C-c\C-s" 'switch-to-tcl) - - ;; Make menus. - (if (and tcl-using-emacs-19 (not tcl-using-xemacs-19)) - (progn - (tcl-add-fsf-menu tcl-mode-map)))) - -(defun tcl-fill-inferior-map () - (define-key inferior-tcl-mode-map "\t" 'comint-dynamic-complete) - (define-key inferior-tcl-mode-map "\M-?" - 'comint-dynamic-list-filename-completions) - (define-key inferior-tcl-mode-map "\e\C-a" 'tcl-beginning-of-defun) - (define-key inferior-tcl-mode-map "\e\C-e" 'tcl-end-of-defun) - (define-key inferior-tcl-mode-map "\177" 'backward-delete-char-untabify) - (define-key inferior-tcl-mode-map "\M-\C-x" 'tcl-eval-defun) - (define-key inferior-tcl-mode-map "\C-c\C-b" 'tcl-submit-bug-report) - (define-key inferior-tcl-mode-map "\C-c\C-i" 'tcl-help-on-word) - (define-key inferior-tcl-mode-map "\C-c\C-v" 'tcl-eval-defun) - (define-key inferior-tcl-mode-map "\C-c\C-f" 'tcl-load-file) - (define-key inferior-tcl-mode-map "\C-c\C-t" 'inferior-tcl) - (define-key inferior-tcl-mode-map "\C-c\C-x" 'tcl-eval-region) - (define-key inferior-tcl-mode-map "\C-c\C-s" 'switch-to-tcl)) - -(if tcl-mode-map - () - (setq tcl-mode-map (make-sparse-keymap)) - (tcl-fill-mode-map)) - -(if inferior-tcl-mode-map - () - ;; FIXME Use keymap inheritance here? FIXME we override comint - ;; keybindings here. Maybe someone has a better set? - (setq inferior-tcl-mode-map (copy-keymap comint-mode-map)) - (tcl-fill-inferior-map)) - - -(defvar inferior-tcl-buffer nil - "*The current inferior-tcl process buffer. - -MULTIPLE PROCESS SUPPORT -=========================================================================== -To run multiple Tcl processes, you start the first up with -\\[inferior-tcl]. It will be in a buffer named `*inferior-tcl*'. -Rename this buffer with \\[rename-buffer]. You may now start up a new -process with another \\[inferior-tcl]. It will be in a new buffer, -named `*inferior-tcl*'. You can switch between the different process -buffers with \\[switch-to-buffer]. - -Commands that send text from source buffers to Tcl processes -- like -`tcl-eval-defun' or `tcl-load-file' -- have to choose a process to -send to, when you have more than one Tcl process around. This is -determined by the global variable `inferior-tcl-buffer'. Suppose you -have three inferior Lisps running: - Buffer Process - foo inferior-tcl - bar inferior-tcl<2> - *inferior-tcl* inferior-tcl<3> -If you do a \\[tcl-eval-defun] command on some Lisp source code, what -process do you send it to? - -- If you're in a process buffer (foo, bar, or *inferior-tcl*), - you send it to that process. -- If you're in some other buffer (e.g., a source file), you - send it to the process attached to buffer `inferior-tcl-buffer'. -This process selection is performed by function `inferior-tcl-proc'. - -Whenever \\[inferior-tcl] fires up a new process, it resets -`inferior-tcl-buffer' to be the new process's buffer. If you only run -one process, this does the right thing. If you run multiple -processes, you can change `inferior-tcl-buffer' to another process -buffer with \\[set-variable].") - -;; -;; Hooks and other customization. -;; - -(defvar tcl-mode-hook nil - "Hook run on entry to Tcl mode. - -Several functions exist which are useful to run from your -`tcl-mode-hook' (see each function's documentation for more -information): - - tcl-guess-application - Guesses a default setting for `tcl-application' based on any - \"#!\" line at the top of the file. - tcl-hashify-buffer - Quotes all \"#\" characters that don't correspond to actual - Tcl comments. (Useful when editing code not originally created - with this mode). - tcl-auto-fill-mode - Auto-filling of Tcl comments. - -Emacs 19 users can add functions to the hook with `add-hook': - - (add-hook 'tcl-mode-hook 'tcl-guess-application) - -Emacs 18 users must use `setq': - - (setq tcl-mode-hook (cons 'tcl-guess-application tcl-mode-hook))") - - -(defvar inferior-tcl-mode-hook nil - "Hook for customizing Inferior Tcl mode.") - -(defvar tcl-proc-list - '("proc" "method" "itcl_class") - "List of commands whose first argument defines something. -This exists because some people (eg, me) use \"defvar\" et al. -Call `tcl-set-proc-regexp' and `tcl-set-font-lock-keywords' -after changing this list.") - -(defvar tcl-proc-regexp nil - "Regexp to use when matching proc headers.") - -(defvar tcl-typeword-list - '("global" "upvar" "inherit" "public" "protected" "common") - "List of Tcl keywords denoting \"type\". Used only for highlighting. -Call `tcl-set-font-lock-keywords' after changing this list.") - -;; Generally I've picked control operators to be keywords. -(defvar tcl-keyword-list - '("if" "then" "else" "elseif" "for" "foreach" "break" "continue" "while" - "eval" "case" "in" "switch" "default" "exit" "error" "proc" "return" - "uplevel" "constructor" "destructor" "itcl_class" "loop" "for_array_keys" - "for_recursive_glob" "for_file") - "List of Tcl keywords. Used only for highlighting. -Default list includes some TclX keywords. -Call `tcl-set-font-lock-keywords' after changing this list.") - -(defvar tcl-font-lock-keywords nil - "Keywords to highlight for Tcl. See variable `font-lock-keywords'. -This variable is generally set from `tcl-proc-regexp', -`tcl-typeword-list', and `tcl-keyword-list' by the function -`tcl-set-font-lock-keywords'.") - -;; FIXME need some way to recognize variables because array refs look -;; like 2 sexps. -(defvar tcl-type-alist - '( - ("proc" nil tcl-expr tcl-commands) - ("method" nil tcl-expr tcl-commands) - ("destructor" tcl-commands) - ("constructor" tcl-commands) - ("expr" tcl-expr) - ("catch" tcl-commands) - ("if" tcl-expr "then" tcl-commands) - ("elseif" tcl-expr "then" tcl-commands) - ("elseif" tcl-expr tcl-commands) - ("if" tcl-expr tcl-commands) - ("while" tcl-expr tcl-commands) - ("for" tcl-commands tcl-expr tcl-commands tcl-commands) - ("foreach" nil nil tcl-commands) - ("for_file" nil nil tcl-commands) - ("for_array_keys" nil nil tcl-commands) - ("for_recursive_glob" nil nil nil tcl-commands) - ;; Loop handling is not perfect, because the third argument can be - ;; either a command or an expr, and there is no real way to look - ;; forward. - ("loop" nil tcl-expr tcl-expr tcl-commands) - ("loop" nil tcl-expr tcl-commands) - ) - "Alist that controls indentation. -\(Actually, this really only controls what happens on continuation lines). -Each entry looks like `(KEYWORD TYPE ...)'. -Each type entry describes a sexp after the keyword, and can be one of: -* nil, meaning that this sexp has no particular type. -* tcl-expr, meaning that this sexp is an arithmetic expression. -* tcl-commands, meaning that this sexp holds Tcl commands. -* a string, which must exactly match the string at the corresponding - position for a match to be made. - -For example, the entry for the \"loop\" command is: - - (\"loop\" nil tcl-expr tcl-commands) - -This means that the \"loop\" command has three arguments. The first -argument is ignored (for indentation purposes). The second argument -is a Tcl expression, and the last argument is Tcl commands.") - -(defvar tcl-explain-indentation nil - "If not `nil', debugging message will be printed during indentation.") - - - -;; -;; Work around differences between various versions of Emacs. -;; - -;; We use this because Lemacs 19.9 has what we need. -(defconst tcl-pps-has-arg-6 - (or tcl-using-emacs-19 - (and tcl-using-xemacs-19 - (condition-case nil - (progn - (parse-partial-sexp (point) (point) nil nil nil t) - t) - (error nil)))) - "t if using an emacs which supports sixth (\"commentstop\") argument -to parse-partial-sexp.") - -;; Its pretty bogus to have to do this, but there is no easier way to -;; say "match not syntax-1 and not syntax-2". Too bad you can't put -;; \s in [...]. This sickness is used in Emacs 19 to match a defun -;; starter. (It is used for this in v18 as well). -;;(defconst tcl-omit-ws-regexp -;; (concat "^\\(\\s" -;; (mapconcat 'char-to-string "w_.()\"\\$'/" "\\|\\s") -;; "\\)\\S(*") -;; "Regular expression that matches everything except space, comment -;;starter, and comment ender syntax codes.") - -;; FIXME? Instead of using the hairy regexp above, we just use a -;; simple one. -;;(defconst tcl-omit-ws-regexp "^[^] \t\n#}]\\S(*" -;; "Regular expression used in locating function definitions.") - -;; Here's another stab. I think this one actually works. Now the -;; problem seems to be that there is a bug in Emacs 19.22 where -;; end-of-defun doesn't really use the brace matching the one that -;; trails defun-prompt-regexp. -(defconst tcl-omit-ws-regexp "^[^ \t\n#}][^\n}]+}*[ \t]+") - -(defun tcl-internal-beginning-of-defun (&optional arg) - "Move backward to next beginning-of-defun. -With argument, do this that many times. -Returns t unless search stops due to end of buffer." - (interactive "p") - (if (or (null arg) (= arg 0)) - (setq arg 1)) - (let (success) - (while (progn - (setq arg (1- arg)) - (and (>= arg 0) - (setq success - (re-search-backward tcl-omit-ws-regexp nil 'move 1)))) - (while (and (looking-at "[]#}]") - (setq success - (re-search-backward tcl-omit-ws-regexp nil 'move 1))))) - (beginning-of-line) - (not (null success)))) - -(defun tcl-internal-end-of-defun (&optional arg) - "Move forward to next end of defun. -An end of a defun is found by moving forward from the beginning of one." - (interactive "p") - (if (or (null arg) (= arg 0)) (setq arg 1)) - (let ((start (point))) - ;; Was forward-char. I think this works a little better. - (forward-line) - (tcl-beginning-of-defun) - (while (> arg 0) - (while (and (re-search-forward tcl-omit-ws-regexp nil 'move 1) - (progn (beginning-of-line) t) - (looking-at "[]#}]") - (progn (forward-line) t))) - (let ((next-line (save-excursion - (forward-line) - (point)))) - (while (< (point) next-line) - (forward-sexp))) - (forward-line) - (if (> (point) start) (setq arg (1- arg)))))) - -;; In Emacs 19, we can use begining-of-defun as long as we set up a -;; certain regexp. In Emacs 18, we need our own function. -(fset 'tcl-beginning-of-defun - (if tcl-using-emacs-19 - 'beginning-of-defun - 'tcl-internal-beginning-of-defun)) - -;; Ditto end-of-defun. -(fset 'tcl-end-of-defun - (if (and tcl-using-emacs-19 (not tcl-using-xemacs-19)) - 'end-of-defun - 'tcl-internal-end-of-defun)) - -;; Internal mark-defun that is used for losing Emacsen. -(defun tcl-internal-mark-defun () - "Put mark at end of Tcl function, point at beginning." - (interactive) - (push-mark (point)) - (tcl-end-of-defun) - (if tcl-using-emacs-19 - (push-mark (point) nil t) - (push-mark (point))) - (tcl-beginning-of-defun) - (backward-paragraph)) - -;; In GNU Emacs 19-23 and later, mark-defun works as advertised. I -;; don't know about XEmacs, so for now it and Emacs 18 just lose. -(fset 'tcl-mark-defun - (if tcl-using-emacs-19-23 - 'mark-defun - 'tcl-internal-mark-defun)) - -;; In GNU Emacs 19, mark takes an additional "force" argument. I -;; don't know about XEmacs, so I'm just assuming it is the same. -;; Emacs 18 doesn't have this argument. -(defun tcl-mark () - "Return mark, or nil if none." - (if tcl-using-emacs-19 - (mark t) - (mark))) - - - -;; -;; Some helper functions. -;; - -(defun tcl-set-proc-regexp () - "Set `tcl-proc-regexp' from variable `tcl-proc-list'." - (setq tcl-proc-regexp (concat "^\\s-*\\(" - (mapconcat 'identity tcl-proc-list "\\|") - "\\)[ \t]+"))) - -(defun tcl-set-font-lock-keywords () - "Set `tcl-font-lock-keywords'. -Uses variables `tcl-proc-regexp' and `tcl-keyword-list'." - (setq tcl-font-lock-keywords - (list - ;; Names of functions (and other "defining things"). - (list (concat tcl-proc-regexp "\\([^ \t\n]+\\)") - 2 'font-lock-function-name-face) - - ;; Names of type-defining things. - (list (concat "\\(\\s-\\|^\\)\\(" - ;; FIXME Use 'regexp-quote? - (mapconcat 'identity tcl-typeword-list "\\|") - "\\)\\(\\s-\\|$\\)") - 2 'font-lock-type-face) - - ;; Keywords. Only recognized if surrounded by whitespace. - ;; FIXME consider using "not word or symbol", not - ;; "whitespace". - (cons (concat "\\(\\s-\\|^\\)\\(" - ;; FIXME Use regexp-quote? - (mapconcat 'identity tcl-keyword-list "\\|") - "\\)\\(\\s-\\|$\\)") - 2) - ))) - -(if tcl-proc-regexp - () - (tcl-set-proc-regexp)) - -(if tcl-font-lock-keywords - () - (tcl-set-font-lock-keywords)) - - - -;; -;; The mode itself. -;; - -;;;###autoload -(defun tcl-mode () - "Major mode for editing Tcl code. -Expression and list commands understand all Tcl brackets. -Tab indents for Tcl code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Variables controlling indentation style: - tcl-indent-level - Indentation of Tcl statements within surrounding block. - tcl-continued-indent-level - Indentation of continuation line relative to first line of command. - -Variables controlling user interaction with mode (see variable -documentation for details): - tcl-tab-always-indent - Controls action of TAB key. - tcl-auto-newline - Non-nil means automatically newline before and after braces, brackets, - and semicolons inserted in Tcl code. - tcl-electric-hash-style - Controls action of `#' key. - tcl-use-hairy-comment-detector - If t, use more complicated, but slower, comment detector. - This variable is only used in GNU Emacs 19. - tcl-use-smart-word-finder - If not nil, use a smarter, Tcl-specific way to find the current - word when looking up help on a Tcl command. - -Turning on Tcl mode calls the value of the variable `tcl-mode-hook' -with no args, if that value is non-nil. Read the documentation for -`tcl-mode-hook' to see what kinds of interesting hook functions -already exist. - -Commands: -\\{tcl-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map tcl-mode-map) - (setq major-mode 'tcl-mode) - (setq mode-name "Tcl") - (setq local-abbrev-table tcl-mode-abbrev-table) - (set-syntax-table tcl-mode-syntax-table) - - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (if (and tcl-using-emacs-19-23 - (>= emacs-minor-version 29)) - (progn - ;; In Emacs 19.29, you aren't supposed to start these with a - ;; ^. - (setq paragraph-start "$\\| ") - (setq paragraph-separate paragraph-start)) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (setq paragraph-separate paragraph-start)) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'tcl-do-fill-paragraph) - - (make-local-variable 'indent-line-function) - (setq indent-line-function 'tcl-indent-line) - ;; Tcl doesn't require a final newline. - ;; (make-local-variable 'require-final-newline) - ;; (setq require-final-newline t) - - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-end) - (setq comment-end "") - - (make-local-variable 'outline-regexp) - (setq outline-regexp "[^\n\^M]") - (make-local-variable 'outline-level) - (setq outline-level 'tcl-outline-level) - - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords tcl-font-lock-keywords) - - ;; The following only really makes sense under GNU Emacs 19. - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function 'tcl-imenu-create-index-function) - (make-local-variable 'parse-sexp-ignore-comments) - - ;; Settings for new dabbrev code. - (make-local-variable 'dabbrev-case-fold-search) - (setq dabbrev-case-fold-search nil) - (make-local-variable 'dabbrev-case-replace) - (setq dabbrev-case-replace nil) - (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) - (setq dabbrev-abbrev-skip-leading-regexp "[$!]") - (make-local-variable 'dabbrev-abbrev-char-regexp) - (setq dabbrev-abbrev-char-regexp "\\sw\\|\\s_") - - (if tcl-using-emacs-19 - (progn - ;; This can only be set to t in Emacs 19 and XEmacs. - ;; Emacs 18 and Epoch lose. - (setq parse-sexp-ignore-comments t) - ;; XEmacs has defun-prompt-regexp, but I don't believe - ;; that it works for end-of-defun -- only for - ;; beginning-of-defun. - (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp tcl-omit-ws-regexp) - ;; The following doesn't work in Lucid Emacs 19.6, but maybe - ;; it will appear in later versions. - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function 'add-log-tcl-defun)) - (setq parse-sexp-ignore-comments nil)) - - ;; Put Tcl menu into menubar for XEmacs. This happens - ;; automatically for GNU Emacs. - (if (and tcl-using-xemacs-19 - current-menubar - (not (assoc "Tcl" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil "Tcl" tcl-xemacs-menu))) - ;; Append Tcl menu to popup menu for XEmacs. - (if (and tcl-using-xemacs-19 (boundp 'mode-popup-menu)) - (setq mode-popup-menu - (cons (concat mode-name " Mode Commands") tcl-xemacs-menu))) - - ;; If hilit19 is loaded, add our stuff. - (if (featurep 'hilit19) - (tcl-hilit)) - - (run-hooks 'tcl-mode-hook)) - - - -;; This is used for braces, brackets, and semi (except for closing -;; braces, which are handled specially). -(defun tcl-electric-char (arg) - "Insert character and correct line's indentation." - (interactive "p") - ;; Indent line first; this looks better if parens blink. - (tcl-indent-line) - (self-insert-command arg) - (if (and tcl-auto-newline (= last-command-char ?\;)) - (progn - (newline) - (tcl-indent-line)))) - -;; This is used for closing braces. If tcl-auto-newline is set, can -;; insert a newline both before and after the brace, depending on -;; context. FIXME should this be configurable? Does anyone use this? -(defun tcl-electric-brace (arg) - "Insert character and correct line's indentation." - (interactive "p") - ;; If auto-newlining and there is stuff on the same line, insert a - ;; newline first. - (if tcl-auto-newline - (progn - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - () - (tcl-indent-line) - (newline)) - ;; In auto-newline case, must insert a newline after each - ;; brace. So an explicit loop is needed. - (while (> arg 0) - (insert last-command-char) - (tcl-indent-line) - (newline) - (setq arg (1- arg)))) - (self-insert-command arg)) - (tcl-indent-line)) - - - -(defun tcl-indent-command (&optional arg) - "Indent current line as Tcl code, or in some cases insert a tab character. -If tcl-tab-always-indent is t (the default), always indent current line. -If tcl-tab-always-indent is nil and point is not in the indentation -area at the beginning of the line, a TAB is inserted. -Other values of tcl-tab-always-indent cause the first possible action -from the following list to take place: - - 1. Move from beginning of line to correct indentation. - 2. Delete an empty comment. - 3. Move forward to start of comment, indenting if necessary. - 4. Move forward to end of line, indenting if necessary. - 5. Create an empty comment. - 6. Move backward to start of comment, indenting if necessary." - (interactive "p") - (cond - ((not tcl-tab-always-indent) - ;; Indent if in indentation area, otherwise insert TAB. - (if (<= (current-column) (current-indentation)) - (tcl-indent-line) - (insert-tab arg))) - ((eq tcl-tab-always-indent t) - ;; Always indent. - (tcl-indent-line)) - (t - ;; "Perl-mode" style TAB command. - (let* ((ipoint (point)) - (eolpoint (progn - (end-of-line) - (point))) - (comment-p (tcl-in-comment))) - (cond - ((= ipoint (save-excursion - (beginning-of-line) - (point))) - (beginning-of-line) - (tcl-indent-line) - ;; If indenting didn't leave us in column 0, go to the - ;; indentation. Otherwise leave point at end of line. This - ;; is a hack. - (if (= (point) (save-excursion - (beginning-of-line) - (point))) - (end-of-line) - (back-to-indentation))) - ((and comment-p (looking-at "[ \t]*$")) - ;; Empty comment, so delete it. We also delete any ";" - ;; characters at the end of the line. I think this is - ;; friendlier, but I don't know how other people will feel. - (backward-char) - (skip-chars-backward " \t;") - (delete-region (point) eolpoint)) - ((and comment-p (< ipoint (point))) - ;; Before comment, so skip to it. - (tcl-indent-line) - (indent-for-comment)) - ((/= ipoint eolpoint) - ;; Go to end of line (since we're not there yet). - (goto-char eolpoint) - (tcl-indent-line)) - ((not comment-p) - (tcl-indent-line) - (tcl-indent-for-comment)) - (t - ;; Go to start of comment. We don't leave point where it is - ;; because we want to skip comment-start-skip. - (tcl-indent-line) - (indent-for-comment))))))) - -(defun tcl-indent-line () - "Indent current line as Tcl code. -Return the amount the indentation changed by." - (let ((indent (calculate-tcl-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((= (following-char) ?}) - (setq indent (- indent tcl-indent-level))) - ((= (following-char) ?\]) - (setq indent (- indent 1)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun tcl-figure-type () - "Determine type of sexp at point. -This is either 'tcl-expr, 'tcl-commands, or nil. Puts point at start -of sexp that indicates types. - -See documentation for variable `tcl-type-alist' for more information." - (let ((count 0) - result - word-stack) - (while (and (< count 5) - (not result)) - (condition-case nil - (progn - ;; FIXME should use "tcl-backward-sexp", which would skip - ;; over entire variables, etc. - (backward-sexp) - (if (looking-at "[a-zA-Z_]+") - (let ((list tcl-type-alist) - entry) - (setq word-stack (cons (tcl-word-no-props) word-stack)) - (while (and list (not result)) - (setq entry (car list)) - (setq list (cdr list)) - (let ((index 0)) - (while (and entry (<= index count)) - ;; Abort loop if string does not match word on - ;; stack. - (and (stringp (car entry)) - (not (string= (car entry) - (nth index word-stack))) - (setq entry nil)) - (setq entry (cdr entry)) - (setq index (1+ index))) - (and (> index count) - (not (stringp (car entry))) - (setq result (car entry))) - ))) - (setq word-stack (cons nil word-stack)))) - (error nil)) - (setq count (1+ count))) - (and tcl-explain-indentation - (message "Indentation type %s" result)) - result)) - -(defun calculate-tcl-indent (&optional parse-start) - "Return appropriate indentation for current line as Tcl code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let* ((indent-point (point)) - (case-fold-search nil) - (continued-line - (save-excursion - (if (bobp) - nil - (backward-char) - (= ?\\ (preceding-char))))) - (continued-indent-value (if continued-line - tcl-continued-indent-level - 0)) - state - containing-sexp - found-next-line) - (if parse-start - (goto-char parse-start) - (tcl-beginning-of-defun)) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; Inside comment or string. Return nil or t if should - ;; not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. - continued-indent-value) - (t - ;; Set expr-p if we are looking at the expression part of - ;; an "if", "expr", etc statement. Set commands-p if we - ;; are looking at the body part of an if, while, etc - ;; statement. FIXME Should check for "for" loops here. - (goto-char containing-sexp) - (let* ((sexpr-type (tcl-figure-type)) - (expr-p (eq sexpr-type 'tcl-expr)) - (commands-p (eq sexpr-type 'tcl-commands)) - (expr-start (point))) - ;; Find the first statement in the block and indent - ;; like it. The first statement in the block might be - ;; on the same line, so what we do is skip all - ;; "virtually blank" lines, looking for a non-blank - ;; one. A line is virtually blank if it only contains - ;; a comment and whitespace. FIXME continued comments - ;; aren't supported. They are a wart on Tcl anyway. - ;; We do it this funky way because we want to know if - ;; we've found a statement on some line _after_ the - ;; line holding the sexp opener. - (goto-char containing-sexp) - (forward-char) - (if (and (< (point) indent-point) - (looking-at "[ \t]*\\(#.*\\)?$")) - (progn - (forward-line) - (while (and (< (point) indent-point) - (looking-at "[ \t]*\\(#.*\\)?$")) - (setq found-next-line t) - (forward-line)))) - (if (or continued-line - (/= (char-after containing-sexp) ?{) - expr-p) - (progn - ;; Line is continuation line, or the sexp opener - ;; is not a curly brace, or we are are looking at - ;; an `expr' expression (which must be split - ;; specially). So indentation is column of first - ;; good spot after sexp opener (with some added - ;; in the continued-line case). If there is no - ;; nonempty line before the indentation point, we - ;; use the column of the character after the sexp - ;; opener. - (if (>= (point) indent-point) - (progn - (goto-char containing-sexp) - (forward-char)) - (skip-chars-forward " \t")) - (+ (current-column) continued-indent-value)) - ;; After a curly brace, and not a continuation line. - ;; So take indentation from first good line after - ;; start of block, unless that line is on the same - ;; line as the opening brace. In this case use the - ;; indentation of the opening brace's line, plus - ;; another indent step. If we are in the body part - ;; of an "if" or "while" then the indentation is - ;; taken from the line holding the start of the - ;; statement. - (if (and (< (point) indent-point) - found-next-line) - (current-indentation) - (if commands-p - (goto-char expr-start) - (goto-char containing-sexp)) - (+ (current-indentation) tcl-indent-level))))))))) - - - -(defun indent-tcl-exp () - "Indent each line of the Tcl grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - outer-loop-done inner-loop-done state ostate - this-indent last-sexp continued-line - (next-depth 0) - last-depth) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq inner-loop-done nil) - (while (and (not inner-loop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (tcl-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq inner-loop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - ;; If this line had ..))) (((.. in it, pop out of the levels - ;; that ended anywhere in this line, even if the final depth - ;; doesn't indicate that they ended. - (while (> last-depth (nth 6 state)) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (if (/= last-depth next-depth) - (setq last-sexp nil)) - ;; Add levels for any parens that were started in this line. - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack - (or (car (cdr state)) - (save-excursion - (forward-sexp -1) - (point))))) - (forward-line 1) - (setq continued-line - (save-excursion - (backward-char) - (= (preceding-char) ?\\))) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - (setq this-indent (car indent-stack)) - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let ((val (calculate-tcl-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack - (setq this-indent val)) - (setq continued-line nil))) - (cond ((not (numberp this-indent))) - ((= (following-char) ?}) - (setq this-indent (- this-indent tcl-indent-level))) - ((= (following-char) ?\]) - (setq this-indent (- this-indent 1)))) - ;; Put chosen indentation into effect. - (or (null this-indent) - (= (current-column) - (if continued-line - (+ this-indent tcl-indent-level) - this-indent)) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to - (if continued-line - (+ this-indent tcl-indent-level) - this-indent))))))))) - ) - - - -;; -;; Interfaces to other packages. -;; - -(defun tcl-imenu-create-index-function () - "Generate alist of indices for imenu." - (let ((re (concat tcl-proc-regexp "\\([^ \t\n{]+\\)")) - alist prev-pos) - (goto-char (point-min)) - (imenu-progress-message prev-pos 0) - (save-match-data - (while (re-search-forward re nil t) - (imenu-progress-message prev-pos) - ;; Position on start of proc name, not beginning of line. - (setq alist (cons - (cons (buffer-substring (match-beginning 2) (match-end 2)) - (match-beginning 2)) - alist)))) - (imenu-progress-message prev-pos 100) - (nreverse alist))) - -;; FIXME Definition of function is very ad-hoc. Should use -;; tcl-beginning-of-defun. Also has incestuous knowledge about the -;; format of tcl-proc-regexp. -(defun add-log-tcl-defun () - "Return name of Tcl function point is in, or nil." - (save-excursion - (end-of-line) - (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t) - (buffer-substring (match-beginning 2) - (match-end 2))))) - -(defun tcl-outline-level () - (save-excursion - (skip-chars-forward " \t") - (current-column))) - - - -;; -;; Helper functions for inferior Tcl mode. -;; - -;; This exists to let us delete the prompt when commands are sent -;; directly to the inferior Tcl. See gud.el for an explanation of how -;; it all works (I took it from there). This stuff doesn't really -;; work as well as I'd like it to. But I don't believe there is -;; anything useful that can be done. -(defvar inferior-tcl-delete-prompt-marker nil) - -(defun tcl-filter (proc string) - (let ((inhibit-quit t)) - (save-excursion - (set-buffer (process-buffer proc)) - (goto-char (process-mark proc)) - ;; Delete prompt if requested. - (if (marker-buffer inferior-tcl-delete-prompt-marker) - (progn - (delete-region (point) inferior-tcl-delete-prompt-marker) - (set-marker inferior-tcl-delete-prompt-marker nil))))) - (if tcl-using-emacs-19 - (comint-output-filter proc string) - (funcall comint-output-filter string))) - -(defun tcl-send-string (proc string) - (save-excursion - (set-buffer (process-buffer proc)) - (goto-char (process-mark proc)) - (beginning-of-line) - (if (looking-at comint-prompt-regexp) - (set-marker inferior-tcl-delete-prompt-marker (point)))) - (comint-send-string proc string)) - -(defun tcl-send-region (proc start end) - (save-excursion - (set-buffer (process-buffer proc)) - (goto-char (process-mark proc)) - (beginning-of-line) - (if (looking-at comint-prompt-regexp) - (set-marker inferior-tcl-delete-prompt-marker (point)))) - (comint-send-region proc start end)) - -(defun switch-to-tcl (eob-p) - "Switch to inferior Tcl process buffer. -With argument, positions cursor at end of buffer." - (interactive "P") - (if (get-buffer inferior-tcl-buffer) - (pop-to-buffer inferior-tcl-buffer) - (error "No current inferior Tcl buffer")) - (cond (eob-p - (push-mark) - (goto-char (point-max))))) - -(defun inferior-tcl-proc () - "Return current inferior Tcl process. -See variable `inferior-tcl-buffer'." - (let ((proc (get-buffer-process (if (eq major-mode 'inferior-tcl-mode) - (current-buffer) - inferior-tcl-buffer)))) - (or proc - (error "No Tcl process; see variable `inferior-tcl-buffer'")))) - -(defun tcl-eval-region (start end &optional and-go) - "Send the current region to the inferior Tcl process. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive "r\nP") - (let ((proc (inferior-tcl-proc))) - (tcl-send-region proc start end) - (tcl-send-string proc "\n") - (if and-go (switch-to-tcl t)))) - -(defun tcl-eval-defun (&optional and-go) - "Send the current defun to the inferior Tcl process. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive "P") - (save-excursion - (tcl-end-of-defun) - (let ((end (point))) - (tcl-beginning-of-defun) - (tcl-eval-region (point) end))) - (if and-go (switch-to-tcl t))) - - - -;; -;; Inferior Tcl mode itself. -;; - -(defun inferior-tcl-mode () - "Major mode for interacting with Tcl interpreter. - -A Tcl process can be started with M-x inferior-tcl. - -Entry to this mode runs the hooks comint-mode-hook and -inferior-tcl-mode-hook, in that order. - -You can send text to the inferior Tcl process from other buffers -containing Tcl source. - -Variables controlling Inferior Tcl mode: - tcl-application - Name of program to run. - tcl-command-switches - Command line arguments to `tcl-application'. - tcl-prompt-regexp - Matches prompt. - inferior-tcl-source-command - Command to use to read Tcl file in running application. - inferior-tcl-buffer - The current inferior Tcl process buffer. See variable - documentation for details on multiple-process support. - -The following commands are available: -\\{inferior-tcl-mode-map}" - (interactive) - (comint-mode) - (setq comint-prompt-regexp (or tcl-prompt-regexp - (concat "^" - (regexp-quote tcl-application) - ">"))) - (setq major-mode 'inferior-tcl-mode) - (setq mode-name "Inferior Tcl") - (if (boundp 'modeline-process) - (setq modeline-process '(": %s")) ; For XEmacs. - (setq mode-line-process '(": %s"))) - (use-local-map inferior-tcl-mode-map) - (setq local-abbrev-table tcl-mode-abbrev-table) - (set-syntax-table tcl-mode-syntax-table) - (if tcl-using-emacs-19 - (progn - (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp tcl-omit-ws-regexp))) - (make-local-variable 'inferior-tcl-delete-prompt-marker) - (setq inferior-tcl-delete-prompt-marker (make-marker)) - (set-process-filter (get-buffer-process (current-buffer)) 'tcl-filter) - (run-hooks 'inferior-tcl-mode-hook)) - -;;;###autoload -(defun inferior-tcl (cmd) - "Run inferior Tcl process. -Prefix arg means enter program name interactively. -See documentation for function `inferior-tcl-mode' for more information." - (interactive - (list (if current-prefix-arg - (read-string "Run Tcl: " tcl-application) - tcl-application))) - (if (not (comint-check-proc "*inferior-tcl*")) - (progn - (set-buffer (apply (function make-comint) "inferior-tcl" cmd nil - tcl-command-switches)) - (inferior-tcl-mode))) - (make-local-variable 'tcl-application) - (setq tcl-application cmd) - (setq inferior-tcl-buffer "*inferior-tcl*") - (switch-to-buffer "*inferior-tcl*")) - -(and (fboundp 'defalias) - (defalias 'run-tcl 'inferior-tcl)) - - - -;; -;; Auto-fill support. -;; - -(defun tcl-real-command-p () - "Return nil if point is not at the beginning of a command. -A command is the first word on an otherwise empty line, or the -first word following a semicolon, opening brace, or opening bracket." - (save-excursion - (skip-chars-backward " \t") - (cond - ((bobp) t) - ((bolp) - (backward-char) - ;; Note -- continued comments are not supported here. I - ;; consider those to be a wart on the language. - (not (eq ?\\ (preceding-char)))) - (t - (memq (preceding-char) '(?\; ?{ ?\[)))))) - -;; FIXME doesn't actually return t. See last case. -(defun tcl-real-comment-p () - "Return t if point is just after the `#' beginning a real comment. -Does not check to see if previous char is actually `#'. -A real comment is either at the beginning of the buffer, -preceeded only by whitespace on the line, or has a preceeding -semicolon, opening brace, or opening bracket on the same line." - (save-excursion - (backward-char) - (tcl-real-command-p))) - -(defun tcl-hairy-scan-for-comment (state end always-stop) - "Determine if point is in a comment. -Returns a list of the form `(FLAG . STATE)'. STATE can be used -as input to future invocations. FLAG is nil if not in comment, -t otherwise. If in comment, leaves point at beginning of comment. -Only works in Emacs 19. See also `tcl-simple-scan-for-comment', a -simpler version that is often right, and works in Emacs 18." - (let ((bol (save-excursion - (goto-char end) - (beginning-of-line) - (point))) - real-comment - last-cstart) - (while (and (not last-cstart) (< (point) end)) - (setq real-comment nil) ;In case we've looped around and it is - ;set. - (setq state (parse-partial-sexp (point) end nil nil state t)) - (if (nth 4 state) - (progn - ;; If ALWAYS-STOP is set, stop even if we don't have a - ;; real comment, or if the comment isn't on the same line - ;; as the end. - (if always-stop (setq last-cstart (point))) - ;; If we have a real comment, then set the comment - ;; starting point if we are on the same line as the ending - ;; location. - (setq real-comment (tcl-real-comment-p)) - (if real-comment - (progn - (and (> (point) bol) (setq last-cstart (point))) - ;; NOTE Emacs 19 has a misfeature whereby calling - ;; parse-partial-sexp with COMMENTSTOP set and with - ;; an initial list that says point is in a comment - ;; will cause an immediate return. So we must skip - ;; over the comment ourselves. - (beginning-of-line 2))) - ;; Frob the state to make it look like we aren't in a - ;; comment. - (setcar (nthcdr 4 state) nil)))) - (and last-cstart - (goto-char last-cstart)) - (cons real-comment state))) - -(defun tcl-hairy-in-comment () - "Return t if point is in a comment, and leave point at beginning -of comment." - (let ((save (point))) - (tcl-beginning-of-defun) - (car (tcl-hairy-scan-for-comment nil save nil)))) - -(defun tcl-simple-in-comment () - "Return t if point is in comment, and leave point at beginning -of comment. This is faster that `tcl-hairy-in-comment', but is -correct less often." - (let ((save (point)) - comment) - (beginning-of-line) - (while (and (< (point) save) (not comment)) - (search-forward "#" save 'move) - (setq comment (tcl-real-comment-p))) - comment)) - -(defun tcl-in-comment () - "Return t if point is in comment, and leave point at beginning -of comment." - (if (and tcl-pps-has-arg-6 - tcl-use-hairy-comment-detector) - (tcl-hairy-in-comment) - (tcl-simple-in-comment))) - -(defun tcl-do-fill-paragraph (ignore) - "fill-paragraph function for Tcl mode. Only fills in a comment." - (let (in-comment col where) - (save-excursion - (end-of-line) - (setq in-comment (tcl-in-comment)) - (if in-comment - (progn - (setq where (1+ (point))) - (setq col (1- (current-column)))))) - (and in-comment - (save-excursion - (back-to-indentation) - (= col (current-column))) - ;; In a comment. Set the fill prefix, and find the paragraph - ;; boundaries by searching for lines that look like - ;; comment-only lines. - (let ((fill-prefix (buffer-substring (progn - (beginning-of-line) - (point)) - where)) - p-start p-end) - ;; Search backwards. - (save-excursion - (while (looking-at "^[ \t]*#") - (forward-line -1)) - (forward-line) - (setq p-start (point))) - - ;; Search forwards. - (save-excursion - (while (looking-at "^[ \t]*#") - (forward-line)) - (setq p-end (point))) - - ;; Narrow and do the fill. - (save-restriction - (narrow-to-region p-start p-end) - (fill-paragraph ignore))))) - t) - -(defun tcl-do-auto-fill () - "Auto-fill function for Tcl mode. Only auto-fills in a comment." - (if (> (current-column) fill-column) - (let ((fill-prefix "# ") - in-comment col) - (save-excursion - (setq in-comment (tcl-in-comment)) - (if in-comment - (setq col (1- (current-column))))) - (if in-comment - (progn - (do-auto-fill) - (save-excursion - (back-to-indentation) - (delete-region (point) (save-excursion - (beginning-of-line) - (point))) - (indent-to-column col))))))) - - - -;; -;; Help-related code. -;; - -(defvar tcl-help-saved-dirs nil - "Saved help directories. -If `tcl-help-directory-list' changes, this allows `tcl-help-on-word' -to update the alist.") - -(defvar tcl-help-alist nil - "Alist with command names as keys and filenames as values.") - -(defun tcl-help-snarf-commands (dirlist) - "Build alist of commands and filenames." - (while dirlist - (let ((files (directory-files (car dirlist) t))) - (while files - (if (and (file-directory-p (car files)) - (not - (let ((fpart (file-name-nondirectory (car files)))) - (or (equal fpart ".") - (equal fpart ".."))))) - (let ((matches (directory-files (car files) t))) - (while matches - (or (file-directory-p (car matches)) - (setq tcl-help-alist - (cons - (cons (file-name-nondirectory (car matches)) - (car matches)) - tcl-help-alist))) - (setq matches (cdr matches))))) - (setq files (cdr files)))) - (setq dirlist (cdr dirlist)))) - -(defun tcl-reread-help-files () - "Set up to re-read files, and then do it." - (interactive) - (message "Building Tcl help file index...") - (setq tcl-help-saved-dirs tcl-help-directory-list) - (setq tcl-help-alist nil) - (tcl-help-snarf-commands tcl-help-directory-list) - (message "Building Tcl help file index...done")) - -(defun tcl-word-no-props () - "Like current-word, but strips properties." - (let ((word (current-word))) - (and (fboundp 'set-text-properties) - (set-text-properties 0 (length word) nil word)) - word)) - -(defun tcl-current-word (flag) - "Return current command word, or nil. -If FLAG is nil, just uses `current-word'. -Otherwise scans backward for most likely Tcl command word." - (if (and flag - (memq major-mode '(tcl-mode inferior-tcl-mode))) - (condition-case nil - (save-excursion - ;; Look backward for first word actually in alist. - (if (bobp) - () - (while (and (not (bobp)) - (not (tcl-real-command-p))) - (backward-sexp))) - (if (assoc (tcl-word-no-props) tcl-help-alist) - (tcl-word-no-props))) - (error nil)) - (tcl-word-no-props))) - -;;;###autoload -(defun tcl-help-on-word (command &optional arg) - "Get help on Tcl command. Default is word at point. -Prefix argument means invert sense of `tcl-use-smart-word-finder'." - (interactive - (list - (progn - (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) - (tcl-reread-help-files)) - (let ((word (tcl-current-word - (if current-prefix-arg - (not tcl-use-smart-word-finder) - tcl-use-smart-word-finder)))) - (completing-read - (if (or (null word) (string= word "")) - "Help on Tcl command: " - (format "Help on Tcl command (default %s): " word)) - tcl-help-alist nil t))) - current-prefix-arg)) - (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) - (tcl-reread-help-files)) - (if (string= command "") - (setq command (tcl-current-word - (if arg - (not tcl-use-smart-word-finder) - tcl-use-smart-word-finder)))) - (let* ((help (get-buffer-create "*Tcl help*")) - (cell (assoc command tcl-help-alist)) - (file (and cell (cdr cell)))) - (set-buffer help) - (delete-region (point-min) (point-max)) - (if file - (progn - (insert "*** " command "\n\n") - (insert-file-contents file)) - (if (string= command "") - (insert "Magical Pig!") - (insert "Tcl command " command " not in help\n"))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (display-buffer help))) - - - -;; -;; Other interactive stuff. -;; - -(defvar tcl-previous-dir/file nil - "Record last directory and file used in loading. -This holds a cons cell of the form `(DIRECTORY . FILE)' -describing the last `tcl-load-file' command.") - -(defun tcl-load-file (file &optional and-go) - "Load a Tcl file into the inferior Tcl process. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive - (list - ;; car because comint-get-source returns a list holding the - ;; filename. - (car (comint-get-source "Load Tcl file: " - (or (and - (eq major-mode 'tcl-mode) - (buffer-file-name)) - tcl-previous-dir/file) - '(tcl-mode) t)) - current-prefix-arg)) - (comint-check-source file) - (setq tcl-previous-dir/file (cons (file-name-directory file) - (file-name-nondirectory file))) - (tcl-send-string (inferior-tcl-proc) - (format inferior-tcl-source-command (tcl-quote file))) - (if and-go (switch-to-tcl t))) - -(defun tcl-restart-with-file (file &optional and-go) - "Restart inferior Tcl with file. -If an inferior Tcl process exists, it is killed first. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive - (list - (car (comint-get-source "Restart with Tcl file: " - (or (and - (eq major-mode 'tcl-mode) - (buffer-file-name)) - tcl-previous-dir/file) - '(tcl-mode) t)) - current-prefix-arg)) - (let* ((buf (if (eq major-mode 'inferior-tcl-mode) - (current-buffer) - inferior-tcl-buffer)) - (proc (and buf (get-process buf)))) - (cond - ((not (and buf (get-buffer buf))) - ;; I think this will be ok. - (inferior-tcl tcl-application) - (tcl-load-file file and-go)) - ((or - (not (comint-check-proc buf)) - (yes-or-no-p - "A Tcl process is running, are you sure you want to reset it? ")) - (save-excursion - (comint-check-source file) - (setq tcl-previous-dir/file (cons (file-name-directory file) - (file-name-nondirectory file))) - (comint-exec (get-buffer-create buf) - (if proc - (process-name proc) - "inferior-tcl") - tcl-application file tcl-command-switches) - (if and-go (switch-to-tcl t))))))) - -;; FIXME I imagine you can do this under Emacs 18. I just don't know -;; how. -(defun tcl-auto-fill-mode (&optional arg) - "Like `auto-fill-mode', but controls filling of Tcl comments." - (interactive "P") - (and (not tcl-using-emacs-19) - (error "You must use Emacs 19 to get this feature.")) - ;; Following code taken from "auto-fill-mode" (simple.el). - (prog1 - (setq auto-fill-function - (if (if (null arg) - (not auto-fill-function) - (> (prefix-numeric-value arg) 0)) - 'tcl-do-auto-fill - nil)) - (force-mode-line-update))) - -;; hilit19 support from "Chris Alfeld" <calfeld@math.utah.edu> -(defun tcl-hilit () - (hilit-set-mode-patterns - '(tcl-mode) - '( - ("\\(^ *\\|\; *\\)#.*$" nil comment) - ("[^\\]\\(\\$[A-Za-z0-9\\-\\_./\\(\\)]+\\)" 1 label) - ("[^_]\\<\\(append\\|array\\|auto_execok\\|auto_load\\|auto_mkindex\\|auto_reset\\|break\\|case\\|catch\\|cd\\|close\\|concat\\|continue\\|eof\\|error\\|eval\\|exec\\|exit\\|expr\\|file\\|flush\\|for\\|foreach\\|format\\|gets\\|glob\\|global\\|history\\|if\\|incr\\|info\\|join\\|lappend\\|lindex\\|linsert\\|list\\|llength\\|lrange\\|lreplace\\|lsearch\\|lsort\\|open\\|pid\\|proc\\|puts\\|pwd\\|read\\|regexp\\|regsub\\|rename\\|return\\|scan\\|seek\\|set\\|source\\|split\\|string\\|switch\\|tell\\|time\\|trace\\|unknown\\|unset\\|uplevel\\|upvar\\|while\\)\\>[^_]" 1 keyword) ; tcl keywords - ("[^_]\\<\\(after\\|bell\\|bind\\|bindtags\\|clipboard\\|destroy\\|fileevent\\|focus\\|grab\\|image\\|lower\\|option\\|pack\\|place\\|raise\\|scale\\|selection\\|send\\|subst\\|tk\\|tk_popup\\|tkwait\\|update\\|winfo\\|wm\\)\\>[^_]" 1 define) ; tk keywords - ("[^_]\\<\\(button\\|canvas\\|checkbutton\\|entry\\|frame\\|label\\|listbox\\|menu\\|menubutton\\|message\\|radiobutton\\|scrollbar\\|text\\|toplevel\\)\\>[^_]" 1 decl) ; tk widgets - ("[^_]\\<\\(tix\\((ButtonBox\\|Baloon\\|Control\\|DirList\\|ExFileSelectBox\\|ExFileSelectDialog\\|FileEntry\\|HList\\|LabelEntry\\|LabelFrame\\|NoteBook\\|OptionMenu\\|PanedWindow\\|PopupMenu\\|ScrolledHList\\|ScrolledText\\|ScrolledWindow\\|Select\\|StdButtonBox\\)\\)\\>[^_]" 1 defun) ; tix widgets - ("[{}\\\"\\(\\)]" nil include) ; misc punctuation - ))) - -(defun tcl-electric-hash (&optional count) - "Insert a `#' and quote if it does not start a real comment. -Prefix arg is number of `#'s to insert. -See variable `tcl-electric-hash-style' for description of quoting -styles." - (interactive "p") - (or count (setq count 1)) - (if (> count 0) - (let ((type - (if (eq tcl-electric-hash-style 'smart) - (if (> count 3) ; FIXME what is "smart"? - 'quote - 'backslash) - tcl-electric-hash-style)) - comment) - (if type - (progn - (save-excursion - (insert "#") - (setq comment (tcl-in-comment))) - (delete-char 1) - (and tcl-explain-indentation (message "comment: %s" comment)) - (cond - ((eq type 'quote) - (if (not comment) - (insert "\""))) - ((eq type 'backslash) - ;; The following will set count to 0, so the - ;; insert-char can still be run. - (if (not comment) - (while (> count 0) - (insert "\\#") - (setq count (1- count))))) - (t nil)))) - (insert-char ?# count)))) - -(defun tcl-hashify-buffer () - "Quote all `#'s in current buffer that aren't Tcl comments." - (interactive) - (save-excursion - (goto-char (point-min)) - (if (and tcl-pps-has-arg-6 tcl-use-hairy-comment-detector) - (let (state - result) - (while (< (point) (point-max)) - (setq result (tcl-hairy-scan-for-comment state (point-max) t)) - (if (car result) - (beginning-of-line 2) - (backward-char) - (if (eq ?# (following-char)) - (insert "\\")) - (forward-char)) - (setq state (cdr result)))) - (while (and (< (point) (point-max)) - (search-forward "#" nil 'move)) - (if (tcl-real-comment-p) - (beginning-of-line 2) - ;; There's really no good way for the simple converter to - ;; work. So we just quote # if it isn't already quoted. - ;; Bogus, but it works. - (backward-char) - (if (not (eq ?\\ (preceding-char))) - (insert "\\")) - (forward-char)))))) - -(defun tcl-indent-for-comment () - "Indent this line's comment to comment column, or insert an empty comment. -Is smart about syntax of Tcl comments. -Parts of this were taken from indent-for-comment (simple.el)." - (interactive "*") - (end-of-line) - (or (tcl-in-comment) - (progn - ;; Not in a comment, so we have to insert one. Create an - ;; empty comment (since there isn't one on this line). If - ;; line is not blank, make sure we insert a ";" first. - (skip-chars-backward " \t") - (let ((eolpoint (point))) - (beginning-of-line) - (if (/= (point) eolpoint) - (progn - (goto-char eolpoint) - (insert - (if (tcl-real-command-p) "" ";") - "# ") - (backward-char)))))) - ;; Point is just after the "#" starting a comment. Move it as - ;; appropriate. - (let* ((indent (if comment-indent-hook - (funcall comment-indent-hook) - (funcall comment-indent-function))) - (begpos (progn - (backward-char) - (point)))) - (if (/= begpos indent) - (progn - (skip-chars-backward " \t" (save-excursion - (beginning-of-line) - (point))) - (delete-region (point) begpos) - (indent-to indent))) - (looking-at comment-start-skip) ; Always true. - (goto-char (match-end 0)) - ;; I don't like the effect of the next two. - ;;(skip-chars-backward " \t" (match-beginning 0)) - ;;(skip-chars-backward "^ \t" (match-beginning 0)) - )) - -;; The following was inspired by the Tcl editing mode written by -;; Gregor Schmid <schmid@fb3-s7.math.TU-Berlin.DE>. His version also -;; attempts to snarf the command line options from the command line, -;; but I didn't think that would really be that helpful (doesn't seem -;; like it owould be right enough. His version also looks for the -;; "#!/bin/csh ... exec" hack, but that seemed even less useful. -;; FIXME should make sure that the application mentioned actually -;; exists. -(defun tcl-guess-application () - "Attempt to guess Tcl application by looking at first line. -The first line is assumed to look like \"#!.../program ...\"." - (save-excursion - (goto-char (point-min)) - (if (looking-at "#![^ \t]*/\\([^ \t\n/]+\\)\\([ \t]\\|$\\)") - (progn - (make-local-variable 'tcl-application) - (setq tcl-application (buffer-substring (match-beginning 1) - (match-end 1))))))) - -;; This only exists to put on the menubar. I couldn't figure out any -;; other way to do it. FIXME should take "number of #-marks" -;; argument. -(defun tcl-uncomment-region (beg end) - "Uncomment region." - (interactive "r") - (comment-region beg end -1)) - - - -;; -;; XEmacs menu support. -;; Taken from schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid), -;; who wrote a different Tcl mode. -;; We also have support for menus in FSF. We do this by -;; loading the XEmacs menu emulation code. -;; - -(defun tcl-popup-menu (e) - (interactive "@e") - (and tcl-using-emacs-19 - (not tcl-using-xemacs-19) - (if tcl-using-emacs-19-23 - (require 'lmenu) - ;; CAVEATS: - ;; * lmenu.el provides 'menubar, which is bogus. - ;; * lmenu.el causes menubars to be turned on everywhere. - ;; Doubly bogus! - ;; Both of these problems are fixed in Emacs 19.23. People - ;; using an Emacs before that just suffer. - (require 'menubar "lmenu"))) ;; This is annoying - ;; IMHO popup-menu should be autoloaded in FSF Emacs. Oh well. - (popup-menu tcl-xemacs-menu)) - - - -;; -;; Quoting and unquoting functions. -;; - -;; This quoting is sufficient to protect eg a filename from any sort -;; of expansion or splitting. Tcl quoting sure sucks. -(defun tcl-quote (string) - "Quote STRING according to Tcl rules." - (mapconcat (function (lambda (char) - (if (memq char '(?[ ?] ?{ ?} ?\\ ?\" ?$ ? ?\;)) - (concat "\\" (char-to-string char)) - (char-to-string char)))) - string "")) - - - -;; -;; Bug reporting. -;; - -(and (fboundp 'eval-when-compile) - (eval-when-compile - (require 'reporter))) - -(defun tcl-submit-bug-report () - "Submit via mail a bug report on Tcl mode." - (interactive) - (require 'reporter) - (and - (y-or-n-p "Do you really want to submit a bug report on Tcl mode? ") - (reporter-submit-bug-report - tcl-maintainer - (concat "Tcl mode " tcl-version) - '(tcl-indent-level - tcl-continued-indent-level - tcl-auto-newline - tcl-tab-always-indent - tcl-use-hairy-comment-detector - tcl-electric-hash-style - tcl-help-directory-list - tcl-use-smart-word-finder - tcl-application - tcl-command-switches - tcl-prompt-regexp - inferior-tcl-source-command - tcl-using-emacs-19 - tcl-using-emacs-19-23 - tcl-using-xemacs-19 - tcl-proc-list - tcl-proc-regexp - tcl-typeword-list - tcl-keyword-list - tcl-font-lock-keywords - tcl-pps-has-arg-6)))) - - - -(provide 'tcl) - -;;; tcl.el ends here |