;;; reduce-mode -- REDUCE code editing mode for GNU Emacs ;; Author: Francis J. Wright ;; Keywords: REDUCE, languages ;; $Id: reduce-mode.el,v 1.36 2001-08-13 20:43:30+01 fjw Exp $ (defconst reduce-mode-version "1.1 beta, Time-stamp: <03 September 2001>" "Version information for REDUCE Mode.") ;; This version REQUIRES GNU Emacs 21.1+ ;; The latest version of REDUCE Mode is available from the URL ;; http://centaur.maths.qmw.ac.uk/Emacs/REDUCE/ ;; Copyright (c) 1994--2001 Francis J. Wright ;; This file is not part of GNU Emacs. ;; This 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. ;; It 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. ;; Contributions by Rainer Schoepf flagged ; RS ;; Schoepf@goofy.zdv.Uni-Mainz.DE ;;; Commentary: ;;;; ****************** ;;;; USE OF REDUCE MODE ;;;; ****************** ;; REDUCE mode is part of the REDUCE IDE, which is normally best ;; installed by running the installer program `reduce-ide-install.el'. ;; All related files should be available in the same directory or ;; archive as this file. ;; Full documentation covering the installation and use of REDUCE mode ;; is provided by a texinfo source file called `reduce-ide.texinfo'. ;; From this are (or can be) derived the info file `reduce-ide.info', ;; the HTML file `reduce-ide.html' and the TeX DVI file ;; `reduce-ide.dvi'. The info file can be browsed using the ;; independent info browsing program called `info', or installed into ;; the Emacs info browser, and the DVI file can be printed using a ;; normal TeX DVI driver. ;; All commands also self-document, as usual in Emacs. ;; Brief manual installation instructions follow. ;; Put the following in your `.emacs' file (a) to install REDUCE mode, ;; [assuming that the compiled file reduce-mode.elc is in your load-path]: ;; (autoload 'reduce-mode "reduce-mode" "Major mode for REDUCE code editing" t) ;; and (b) to run it automatically on files with extension ".red": ;; (add-to-list 'auto-mode-alist '("\\.red\\'" . reduce-mode)) ;; To turn on only REDUCE font-lock mode by default include ;; (add-hook 'reduce-mode-hook 'turn-on-font-lock) ;; or to turn on all supported font-lock modes by default include ;; (global-font-lock-mode 1) ;; Developed under MS-DOS/Windows, initially under DEmacs and most ;; recently under NTEmacs. ;; To do: ;; BUGS ;; ==== ;; ! should not be an escape IN STRINGS (motion by sexp, font-lock) ;; reduce-backward-statement does too much searching! ;; Enhancements ;; ============ ;; highlight comment statements ;; more flexible intelligent indentation, rationalize the code ;; make skipping comment statements configurable (?) ;; add RLisp88 support (?) ;; more structure templates (?) -- while, repeat ;; faster font-lock (function rather than just regexps)? ;;; Code: ;; (message "Loading reduce-mode") ; TEMPORARY! (eval-when-compile ; keep compiler happy! (require 'font-lock) (require 'timer) (require 'paren)) ;; Customizable user options: (defgroup reduce nil "Support for editing and running REDUCE code." :tag "REDUCE" :group 'languages) (defgroup reduce-interface nil "Interface options for editing and running REDUCE code." :tag "REDUCE Interface" :group 'reduce) (defgroup reduce-format-display nil "Format and display options for editing and running REDUCE code." :tag "REDUCE Format & Display" :group 'reduce) (defcustom reduce-mode-load-hook nil "*List of functions to be called when REDUCE mode is loaded. E.g. `require-reduce-run' to automatically load `reduce-run'. It can be used to customize global features of REDUCE mode such as its key map, i.e. it is a good place to put keybindings." :type 'hook :options '(require-reduce-run) :group 'reduce) (defcustom reduce-mode-hook nil "*List of functions to be called when REDUCE mode is entered. It can be used to customize buffer-local features of REDUCE mode. E.g. use `turn-on-font-lock' to turn on font-lock mode locally." :type 'hook :options '(turn-on-font-lock) :group 'reduce) ;; Interface: (defcustom reduce-imenu-generic-expression ; EXPERIMENTAL! '((nil "^\\([^%\n]+\\(ic\\|ro\\) \\)?\\s *procedure \\(\\w\\(\\w\\|\\s_\\|!.\\)*\\)" 3) ("Operators" "^\\([^%\n]+ic \\)?\\s *operator \\(\\w\\(\\w\\|\\s_\\|!.\\)*\\)" 2)) "*Imenu support for procedure definitions and operator declarations. An alist with elements of the form (MENU-TITLE REGEXP INDEX) -- see the documentation for `imenu-generic-expression'." :type '(repeat (list (choice (const nil) string) regexp integer)) :group 'reduce-interface) (defcustom reduce-imenu nil "*If non-nil REDUCE mode automatically calls `imenu-add-to-menubar' to add a Contents menu to the menubar. Default is nil." :type 'boolean :group 'reduce-interface) (defcustom reduce-imenu-title "Procs/Ops" "*The title to use if REDUCE mode adds a proc/op menu to the menubar. Default is \"Procs/Ops\"." :type 'string :group 'reduce-interface) (defcustom reduce-max-up-tries 2 "*Repeats of reduce-forward/backward-statement to move up block or group" :type 'integer :group 'reduce-interface) (defcustom reduce-completion-alist '(("algebraic ") ("algebraic procedure ") ("ap" . "algebraic procedure ") ("begin" . reduce-insert-block) ("clearrules ") ("collect ") ("comment ") ("endmodule") ("factorize(") ("first ") ("for all ") ("for each ") ("freeof ") ("gensym()") ("ift" . reduce-expand-if-then) ("if...then" . reduce-expand-if-then) ("ife" . reduce-expand-if-then-else) ("if...then...else" . reduce-expand-if-then-else) ("impart ") ("infinity") ("integer ") ("length ") ("linear ") ("load_package ") ("member ") ("module ") ("operator ") ("order ") ("procedure ") ("product ") ("quotient(") ("remainder(") ("repart ") ("repeat ") ("repeat until ") ("resultant(") ("return ") ("reverse ") ("scalar ") ("second ") ("smember(") ("such that ") ("st" . "such that ") ("symbolic ") ("symbolic operator ") ("sop" . "symbolic operator ") ("symbolic procedure ") ("sp" . "symbolic procedure ") ("third ") ("until ") ("where ") ("while ") ("while do ") ("write ") ("<<" . reduce-insert-group) ) "Alist of REDUCE symbols to be completed by `reduce-complete-symbol'. Optional `cdr' is a replacement string or nullary function (for structures)." :type '(repeat (cons string (choice (const nil) string function))) :group 'reduce-interface) ;; Formatting: (defcustom reduce-indentation 3 "*Depth of successive indentations in REDUCE code." :type 'integer :group 'reduce-format-display) (defcustom reduce-comment-region "%% " "*String inserted by \\[reduce-comment-region] at start of each line in region." :type 'string :group 'reduce-format-display) (defcustom reduce-auto-indent-mode t "*If non-nil then conditionally re-indent the current line after `reduce-auto-indent-delay' seconds of Emacs idle time if the text just typed matches `reduce-auto-indent-regex'." :set (lambda (symbol value) (reduce-auto-indent-mode (or value 0))) :initialize 'custom-initialize-default :type 'boolean :group 'reduce-format-display) (defcustom reduce-auto-indent-delay 0.125 "*Time in seconds to delay before maybe re-indenting current line." :type 'number :group 'reduce-format-display) (defcustom reduce-auto-indent-regexp "\\(else\\|end\\|>>\\)\\=" "*Auto indent current line if text just typed matches this regexp. It should end with \\=\\=. The default value is \"\\(else\\|end\\|>>\\)\\=\\=\"." :type 'regexp :group 'reduce-format-display) ;; Display: (defcustom reduce-show-delim-mode ;; Set a sensible default: (and window-system (featurep 'paren) show-paren-mode) "*If non-nil then highlight matching group and block delimiters. Otherwise blink the opengroup matching an inserted closegroup." :set (lambda (symbol value) (reduce-show-delim-mode (or value 0))) :initialize 'custom-initialize-default :type 'boolean :group 'reduce-format-display) (defface reduce-show-delim-match-face '((((class color)) (:background "turquoise")) (t (:background "gray"))) "Face used for a matching REDUCE delimiter. Default is the same as for Show Paren mode." :group 'reduce-format-display) (defface reduce-show-delim-mismatch-face '((((class color)) (:foreground "white" :background "purple")) (t (:reverse-video t))) "Face used for a mismatching REDUCE delimiter. Default is the same as for Show Paren mode." :group 'reduce-format-display) (defcustom reduce-show-proc-mode nil "*If non-nil then display current procedure name in mode line after `reduce-show-proc-delay' seconds of Emacs idle time." :set (lambda (symbol value) (reduce-show-proc-mode (or value 0))) :initialize 'custom-initialize-default :type 'boolean :group 'reduce-format-display) (defcustom reduce-show-proc-delay 0.125 "*Time in seconds to delay before showing the current procedure name." :type 'number :group 'reduce-format-display) ;; Internal variables: (defvar reduce-imenu-done nil "Buffer-local: set to true if `reduce-imenu' has been called.") (make-variable-buffer-local 'reduce-imenu-done) (defvar reduce-mode-map nil "Keymap for REDUCE mode.") (defvar reduce-mode-syntax-table nil "Syntax table for REDUCE mode.") (defconst reduce-font-lock-keywords '( reduce-font-lock-keywords-0 ; Default = nil reduce-font-lock-keywords-1 ; Algebraic reduce-font-lock-keywords-2 ; Symbolic reduce-font-lock-keywords-3 ; Full = t ) "A list of symbols corresponding to increasing fontification. Each is assigned a `font-lock-keywords' value for REDUCE mode.") (defconst reduce-font-lock-syntactic-keywords ;; ((MATCHER SUBEXP SYNTAX OVERRIDE LAXMATCH) ... ) ;; where SYNTAX = (SYNTAX-CODE . MATCHING-CHAR) ;; If this proves unreliable, try ;; '(("\".*\\(!\\)\"" 1 (1 . nil))) ;; i.e. only mark ! at end of a string as punctuation. ;; But this may be slow! '(("[^'\(]\\(!\\)\"" 1 (1 . nil))) "Mark ! followed by \" as having punctuation syntax (syntax-code 1) unless preceded by ' or (, for correct syntax highlighing of strings.") ;;;; ***************** ;;;; REDUCE major mode ;;;; ***************** ;;; Automatically pre-define reduce mode to autoload if available ;;; when building Emacs (unlikely ever to be done!): ;;;###autoload (defun reduce-mode () "Major mode for editing REDUCE source code -- part of REDUCE IDE. Author: F.J.Wright@Maths.QMW.ac.uk Version: see `reduce-mode-version' Comments, suggestions, bug reports, etc. are welcome. Full texinfo documentation is provided in the file `reduce-ide.texinfo'. Commands are aware of REDUCE syntax, and syntax-directed commands ignore comments, strings and character case. Standard indentation and comment commands are supported. Modelled primarily on Lisp mode; comment commands follow Lisp conventions. `<< ... >>' and `begin ... end' are treated as bracketed or ``symbolic'' expressions for motion, delimiter matching, etc. The command `reduce-indent-line' (`\\[reduce-indent-line]') indents in a fixed style (mine!). If re-run immediately after itself or `reindent-then-newline-and-indent' \(`\\[reindent-then-newline-and-indent]') or `newline-and-indent' (`\\[newline-and-indent]') it indents further. The indentation increment is the value of the variable `reduce-indentation'. Structure template commands are provided to insert and indent if-then (`\\[reduce-insert-if-then]'), block (`\\[reduce-insert-block]') and group (`\\[reduce-insert-group]') constructs, the latter optionally on a single line. The command `reduce-complete-symbol' (`\\[reduce-complete-symbol]') performs REDUCE keyword/phrase/structure completion. Text highlighting is supported by turning on `font-lock-mode', and the style of highlighting may be controlled by setting `font-lock-maximum-decoration' to one of: 1, nil : basic keyword highlighting -- the default; 2 : algebraic-mode highlighting; 3 : symbolic-mode highlighting; 4, t : full highlighting -- of almost everything! Highlighting may also be controlled using the REDUCE menu. Delete converts tabs to spaces as it moves back. Blank lines separate paragraphs. Percent signs start comments. REDUCE mode defines the following local key bindings: \\{reduce-mode-map} Entry to this mode calls the value of `reduce-mode-hook' if non-nil." (interactive) (kill-all-local-variables) (use-local-map reduce-mode-map) (setq major-mode 'reduce-mode) (setq mode-name "REDUCE") (reduce-mode-variables) ;; Set up font-lock mode: (set (make-local-variable 'font-lock-defaults) ;; reduce-font-lock-keywords evaluates to a list of symbols! (list reduce-font-lock-keywords ; KEYWORDS nil ; KEYWORDS-ONLY t ; CASE-FOLD nil ; SYNTAX-ALIST nil ; SYNTAX-BEGIN (cons ; (VARIABLE . VALUE) ... 'font-lock-syntactic-keywords reduce-font-lock-syntactic-keywords) )) ;; Make all parsing respect the syntax property set by the above ;; font-lock option (which is essential to parse "...!"): (set (make-local-variable 'parse-sexp-lookup-properties) t) ;; Optionally turn on REDUCE minor modes: (if reduce-show-delim-mode (reduce-show-delim-mode t)) (if reduce-auto-indent-mode (reduce-auto-indent-mode t)) ;; For reduce-show-proc-mode: (set (make-local-variable 'which-func-mode) nil) (set (make-local-variable 'which-func-format) 'reduce-show-proc-string) (if reduce-show-proc-mode (reduce-show-proc-mode t)) ;; Experimental support for outline minor mode (cf. lisp-mode.el) ;; `outline-regexp' must match `heading' from beginning of line; ;; length of match determines level: (set (make-local-variable 'outline-regexp) "[^ \t\n]") ;; Imenu support: (set (make-local-variable 'imenu-generic-expression) ;; `make-local-variable' in case imenu not yet loaded! reduce-imenu-generic-expression) (set (make-local-variable 'imenu-space-replacement) " ") ;; Necessary to avoid re-installing the same imenu: (setq reduce-imenu-done nil) (if reduce-imenu (reduce-imenu)) ;; ChangeLog support: (set (make-local-variable 'add-log-current-defun-function) 'reduce-current-proc) (run-hooks 'reduce-mode-hook)) (fset 'R (symbol-function 'reduce-mode)) ; a synonym (defun reduce-mode-variables () "Define REDUCE mode local variables." (set-syntax-table reduce-mode-syntax-table) (set (make-local-variable 'paragraph-start) (concat "^$\\|" page-delimiter)) (set (make-local-variable 'paragraph-separate) ;; paragraph-start) (concat paragraph-start "\\|^%")) ; RS ;; so that comments at beginning of a line do not disturb reformatting. (set (make-local-variable 'paragraph-ignore-fill-prefix) t) (set (make-local-variable 'indent-line-function) 'reduce-indent-line) (set (make-local-variable 'comment-start) "% ") (set (make-local-variable 'comment-start-skip) "\\(^\\|[^!]\\)%+ *") ; "%+ *" but not !% (set (make-local-variable 'comment-column) 40) (set (make-local-variable 'comment-indent-function) 'reduce-comment-indent) ;; (setq fill-prefix "% ") ; buffer local (set (make-local-variable 'parse-sexp-ignore-comments) t) ; RS ) (defun reduce-imenu (&optional redraw) "Add a \"Contents\" menu to the menubar." (interactive) (if reduce-imenu-done ;; This is PRIMARILY to avoid a bug in imenu-add-to-menubar that ;; causes it to corrupt the menu bar if it is run more than once ;; in the same buffer. () (setq reduce-imenu-done t) (imenu-add-to-menubar reduce-imenu-title) (if redraw (force-mode-line-update)))) ;;;; ********************** ;;;; Keyboard and menu maps ;;;; ********************** (if reduce-mode-map () (let ((map (make-sparse-keymap))) ;; (define-key map ">" 'reduce-self-insert-and-blink-matching-group-open) ;; (define-key map "\t" 'reduce-indent-line) (define-key map "\n" 'reindent-then-newline-and-indent) (define-key map "\C-c\t" 'reduce-unindent-line) ; default (define-key map [(shift tab)] 'reduce-unindent-line) ; backtab (define-key map "\177" 'backward-delete-char-untabify) ; DEL (define-key map "\C-c\C-n" 'reduce-forward-statement) (define-key map "\C-c\C-p" 'reduce-backward-statement) (define-key map "\C-c\C-d" 'reduce-down-block-or-group) (define-key map "\C-c\C-u" 'reduce-up-block-or-group) (define-key map "\C-c\C-k" 'reduce-kill-statement) (define-key map "\e\C-f" 'reduce-forward-sexp) (define-key map "\e\C-b" 'reduce-backward-sexp) (define-key map "\e\C-e" 'reduce-forward-procedure) (define-key map "\e\C-a" 'reduce-backward-procedure) (define-key map "\e\C-h" 'reduce-mark-procedure) (define-key map "\C-xnd" 'reduce-narrow-to-procedure) (define-key map "\C-ck" 'reduce-kill-procedure) ;; (define-key map "\e;" 'reduce-indent-comment) ; via global map (define-key map "\e\C-\\" 'reduce-indent-region) (define-key map "\e\C-q" 'reduce-indent-procedure) (define-key map "\C-c;" 'reduce-comment-region) (define-key map "\C-c:" 'reduce-comment-procedure) (define-key map "\eq" 'reduce-fill-comment) (define-key map "\C-ci" 'reduce-insert-if-then) (define-key map "\C-cb" 'reduce-insert-block) (define-key map "\C-c<" 'reduce-insert-group) (define-key map "\e\C-l" 'reduce-reposition-window) (define-key map "\e\t" 'reduce-complete-symbol) (setq reduce-mode-map map))) ;; REDUCE-mode menu bar and pop-up menu (easy-menu-define ; (symbol maps doc menu) reduce-mode-menu reduce-mode-map "REDUCE Mode Menu" `("REDUCE" ["Indent Line" indent-for-tab-command :active t :help "Re-indent the current line"] ["Unindent Line" reduce-unindent-line :active t :help "Unindent the current line by one indentation step"] ["Kill Statement" reduce-kill-statement :active t :help "Kill to the end of the current statement"] ["Fill Comment" reduce-fill-comment :active t :help "Fill the current comment"] ["(Un)Comment Region" reduce-comment-region :active mark-active :help "Toggle the commenting of the current region"] ;; "-- PROCEDURES --" ; not good in ntemacs "--" ["Forward Procedure" reduce-forward-procedure :active t :help "Move forward to the nearest end of a procedure"] ["Backward Procedure" reduce-backward-procedure :active t :help "Move backward to the nearest start of a procedure"] ["Indent Procedure" reduce-indent-procedure :active t :help "Re-indent the current procedure"] ["Mark Procedure" reduce-mark-procedure :active t :help "Mark the current procedure"] ["Reposition Window" reduce-reposition-window :active t :help "Scroll to show the current procedure optimally"] ["Narrow To Procedure" reduce-narrow-to-procedure :active t :help "Narrow the buffer to the current procedure"] ["(Un)Comment Proc" reduce-comment-procedure :active t :help "Toggle the commenting of the current procedure"] ["Kill Procedure" reduce-kill-procedure :active t :help "Kill the current procedure"] "--" ("Show / Find / Tag" ["Show Current Proc" reduce-show-proc-mode :style toggle :selected reduce-show-proc-mode :active t :help "Toggle display of the current procedure name"] ["Make Proc/Op Menu" (reduce-imenu t) :active (not reduce-imenu-done) :help "Show an imenu of procedures and operators"] "--" ["Find Tag..." find-tag :active t :help "Find a procedure definition using a tag file"] ["Find Next Tag" (find-tag nil t) :active t :help "Find the next procedure definition (using a tag file)"] ["New TAGS Table..." visit-tags-table :active t :help "Select a new tag file"] "--" ["Tag Directory..." reduce-tagify-dir :active t :help "Tag all REDUCE files in this directory"] ["Tag Subdirs..." reduce-tagify-subdirs :active t :help "Tag all REDUCE files in sub-directories of `..'"] ) ;; "-- TEMPLATES --" ; not good in ntemacs "--" ["Insert If-Then" reduce-insert-if-then :active t :help "Insert an `if-then' template"] ["Insert Block" reduce-insert-block :active t :help "Insert a `block' template"] ["Insert Group" reduce-insert-group :active t :help "Insert a `group' template"] "--" ["Indent Region" reduce-indent-region :active mark-active :help "Re-indent the current region"] ["Indent Buffer" (reduce-indent-region (point-min) (point-max)) :keys "C-u M-C-\\" :active t :help "Re-indent the current buffer"] "--" ["Command Mini Help" (apropos-command "reduce") :active t :help "Show a REDUCE Mode command summary"] ["Customize..." (customize-group 'reduce) :active t :help "Customize REDUCE Mode"] ["Show Version" reduce-mode-version :active t :help "Show the REDUCE Mode version"] ["Outline" outline-minor-mode :style toggle :selected outline-minor-mode :active t :help "Toggle outline minor mode"] ["Update ChangeLog" add-change-log-entry-other-window :active t :help "Add change log entry other window"] )) (defun reduce-mode-version () "Echo version information for REDUCE Major Mode." (interactive) (message "REDUCE Major Mode %s" reduce-mode-version)) ;;;; ************ ;;;; Syntax table ;;;; ************ (if reduce-mode-syntax-table () (let ((table (make-syntax-table))) (modify-syntax-entry ?_ "_" table) ;; (modify-syntax-entry ?! "\\" table) (modify-syntax-entry ?! "/" table) ; single character quote (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 ?< "." 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) (modify-syntax-entry ?\" "\"" table) (modify-syntax-entry ?$ "." table) ; RS (setq reduce-mode-syntax-table table)) ) ;;;; ******************** ;;;; Indentation commands ;;;; ******************** (defun reduce-indent-line (&optional arg) "Indent current line as REDUCE code. Indents to fixed style determined by current and previous non-blank line. Subsequent consecutive calls indent additionally by `reduce-indentation'. With argument, indent any additional lines of the same statement rigidly together with this one." (interactive "*P") ; error if buffer read-only (let ((start-marker (point-marker)) (indentation (progn (back-to-indentation) (current-column))) new-indent) (if (and (memq this-command '(reduce-indent-line indent-for-tab-command)) (memq last-command (list 'reduce-indent-line 'indent-for-tab-command 'newline-and-indent 'reindent-then-newline-and-indent))) (indent-to 0 reduce-indentation) (if (< (setq new-indent (reduce-calculate-indent)) indentation) (delete-horizontal-space)) (indent-to new-indent)) (if arg (save-excursion (setq indentation (- (current-column) indentation)) (indent-rigidly (point) (progn (reduce-forward-statement 1) (point)) indentation) )) (if (< (point) start-marker) (goto-char start-marker)) (set-marker start-marker nil) )) (defun reduce-calculate-indent () "Return appropriate indentation for current line as REDUCE code." (let ((case-fold-search t)) (or (reduce-calculate-indent-proc) (reduce-calculate-indent-this) (reduce-calculate-indent-prev)))) (defconst procedure-regexp "\\>') return the indentation of the beginning of the construct; otherwise return nil." (save-excursion (back-to-indentation) (cond ;; *** Opening tokens *** : ((looking-at "[({ \t]*\\(\\\\|<<\\)") ;; Find previous non-blank line: (let ((closed (looking-at ".*\\(\\\\|>>\\)"))) (skip-syntax-backward " >") ; whitespace, endcomment (if (looking-at "[;$]") (reduce-backward-statement 1) (back-to-indentation)) (if (or (looking-at-procedure) (and (or closed ; single-line construct (looking-at "\\w+[ \t]*:=")) ; assignment (not (looking-at ".*[;$]")))) ; not completed (+ (current-column) reduce-indentation) (current-column)) )) ((looking-at "\\w+[ \t]*:[^=]") ; label ;; Indent to beginning of enclosing block: (reduce-backward-block) (current-column)) ;; *** Intermediate tokens *** : ((looking-at "\\\\|\\") (reduce-find-matching-if) (current-indentation)) ;; *** Closing tokens *** : ((looking-at "\\") (reduce-backward-block) (current-indentation)) ((looking-at ">>") (reduce-backward-group) (current-indentation)) ) )) (defun reduce-find-matching-if () "Find the `if' matching a `then' or `else'." ;; Must skip groups, blocks and brackets. ;; Detects a missing `if' as early as possible as an unrecoverable error. (let ((pattern "\\<\\(if\\|else\\|end\\|begin\\)\\>\\|>>\\|\\s)\\|<<\\|\\s(\\|[^!][;$]")) (or (and (reduce-re-search-backward pattern) (cond ((looking-at "if")) ; found it -- return t ((looking-at "else") ; nested conditional (reduce-find-matching-if) (reduce-find-matching-if)) ((= (following-char) ?>) ; end of group (reduce-backward-group) (reduce-find-matching-if)) ((looking-at "end") ; end of block (reduce-backward-block) (reduce-find-matching-if)) ((= (char-syntax (following-char)) ?\) ) (forward-char) (backward-list) ; skip balanced brackets (reduce-find-matching-if)))) ;; begin, <<, opening bracket, `;', `$' or beginning of buffer (error "`if' matching `then' or `else' not found")) )) (defun reduce-calculate-indent-prev () "Return indentation based on previous non-blank line." ;; Should comments be ignored, esp. if they begin the line? ;; e.g. they may indicate a commented-out region! (save-excursion (beginning-of-line) (if (bobp) 0 ; no previous line ;; Find previous line that is neither blank nor a comment ;; beginning in the first column (which may represent ;; commented-out code): (while (and (= (forward-line -1) 0) (looking-at "%\\|[ \t\f]*$")) ) (if (and (bobp) (looking-at "[ \t\f]*$")) 0 ; no previous non-blank line (back-to-indentation) ;; Point is now at first text in the previous non-blank line. (let ((previous-indentation (current-column)) extra-indentation) ;; Skip any label: (when (looking-at "\\(\\w+[ \t]*:\\)[^=]") ; label (goto-char (match-end 1)) (skip-chars-forward "[ \t]") (if (eolp) ; label alone on line (setq extra-indentation reduce-indentation) (setq previous-indentation (current-column)))) ;; Point is now at start of statement text in the previous ;; non-blank line. (or extra-indentation (setq extra-indentation (cond ;; *** Tokens at beginning of the line *** : ((looking-at "%") 0) ; % comment (HANDLE THIS FIRST!) ; ((looking-at "\\w+[ \t]*:[^=]") ; label ; (if (looking-at ".*\\") ; what else? ; (* 2 reduce-indentation) ; reduce-indentation)) ;; *** Tokens anywhere in the line *** : ((or (looking-at-procedure) (and (looking-at ".*\\") (not (looking-at ".*\\"))) (and (looking-at ".*<<") (not (looking-at ".*>>")))) (if (looking-at ".*,[ \t]*[%\n]") ; line ends with , (* 2 reduce-indentation) reduce-indentation)) ;; *** Tokens at the end of the (logical) line *** : ((looking-at ".*\\<\\(if\\|for\\|do\\|collect\\|join\\|sum\\product\\)\\>[ \t]*[%\n]") reduce-indentation) ;; Otherwise, extra indentation undefined ))) (cond ;; If extra indentation determined then use it ... (extra-indentation (+ previous-indentation extra-indentation)) ;; If beginning new statement or comma-separated element ;; then indent to previous statement or element ;; unless it is a first argument ... ((reduce-calculate-indent-prev1)) ; This produces very odd results if the group is preceded by indented code: ; ((and (looking-at ".*<<") (not (looking-at ".*>>"))) ; (reduce-backward-statement 1) ; (back-to-indentation) ; (+ (current-column) reduce-indentation)) ;; If continuing `if' then indent relative to the `if' ... ; ((looking-at ".*\\(\\\\|\\\\)[ \t]*[%\n]") ; (if (looking-at ".*\\") ; () ; (goto-char (match-beginning 1)) ; (reduce-find-matching-if)) ; (+ (current-indentation) reduce-indentation)) ;; ... but the `if' must be embedded ... ((looking-at ".+\\.*\\(\\\\|\\\\)[ \t]*[%\n]") (goto-char (match-beginning 1)) (reduce-find-matching-if) (+ (current-indentation) reduce-indentation)) ;; Otherwise continuing previous line, so ... (t (+ previous-indentation reduce-indentation)) )))))) (defun reduce-calculate-indent-prev1 () ;; If beginning new statement or comma-separated element ;; or sub-expression ending with `+', `-', `or' or `and' ;; then indent to previous statement or element ;; unless it is a first argument ... (if (looking-at ".*\\(\\([,+-]\\|\\\\|>>\\)[\;$][ \t]*[%\n]"))))) (end-of-line) (reduce-backward-statement 1) (if second_arg (setq second_arg (save-excursion (reduce-re-search-backward "[^ \t\f\n]") (not (looking-at "\\(,\\|\\s(\\)[ \t]*[%\n]")) ))) (back-to-indentation) (if (or second_arg (and open (looking-at ;; ... procedure / begin, << / label ".*\\\ \\|\\\\|<<\ \\|\\w+[ \t]*:[^=]")) ; ??? (looking-at "\\w+[ \t]*:[^=]")) ; label (+ (current-column) reduce-indentation) (current-column))))) (defun reduce-unindent-line (arg) "Unindent current line as REDUCE code. (back-tab) Delete `reduce-indentation' spaces from beginning of line. With argument, unindent any additional lines of the same statement rigidly along with this one." (interactive "*P") ; error if buffer read-only (let ((start-marker (point-marker)) (indentation (progn (back-to-indentation) (current-column)))) (if (bolp) () (backward-delete-char-untabify reduce-indentation) (if arg (save-excursion (setq indentation (- (current-column) indentation)) (indent-rigidly (point) (progn (reduce-forward-statement 1) (point)) indentation) )) (if (< (point) start-marker) (goto-char start-marker)) (set-marker start-marker nil) ))) (defun reduce-comment-indent () ;; Called only by indent-for-comment and ;; (hence) indent-new-comment-line. (if (looking-at "%%%") (current-column) (if (looking-at "%%") (reduce-calculate-indent) (skip-chars-backward " \t") ;; (bolp) needed by indent-new-comment-line: (max (if (bolp) 0 (1+ (current-column))) comment-column) ))) (defun reduce-indent-procedure (arg) "Indent the procedure (and trailing white space) ending after point. With arg, indent the following arg procedures including this one." (interactive "*p") ; error if buffer read-only (if (reduce-mark-procedure arg) ;; Leaves mark at end of procedure, point at start. (reduce-indent-region (point) (mark)) )) (defun reduce-indent-region (beg-region end-region) "Indent the region. With prefix arg, indent the whole buffer." ;; (interactive "*r") ; error if buffer read-only (interactive (if current-prefix-arg (list (point-min) (point-max)) (list (region-beginning) (region-end)))) ;; Indent lines between beg-region and end-region ;; and return point to where it started. ;; This version is not very efficient. (message "Indenting ...") (let ((end-region-mark (make-marker)) (save-point (point-marker))) ;; Must use markers so that they move with the text. (set-marker end-region-mark end-region) (goto-char beg-region) (while (< (point) end-region-mark) (reduce-indent-line) ;; Strip trailing white space from lines (end-of-line) (delete-horizontal-space) (forward-line)) (goto-char save-point) (set-marker end-region-mark nil) (set-marker save-point nil)) (message "Indenting ... done")) ;;;; ****************************************************** ;;;; Support for automatic re-indentation of specific lines ;;;; ****************************************************** (defvar reduce-auto-indent-idle-timer nil) (defun reduce-auto-indent-mode (&optional arg) "Toggle REDUCE Auto Indent mode. With prefix ARG, turn mode on if and only if ARG is positive. Returns the new status of REDUCE Auto Indent mode (non-nil means on). When REDUCE Auto Indent mode is enabled, after `reduce-auto-indent-delay' seconds of Emacs idle time re-indent the current line if the text just typed matches `reduce-auto-indent-regexp'." (interactive "P") (let ((on-p (if arg (> (prefix-numeric-value arg) 0) (not reduce-auto-indent-mode)))) (if reduce-auto-indent-idle-timer (cancel-timer reduce-auto-indent-idle-timer)) (if on-p (setq reduce-auto-indent-idle-timer (run-with-idle-timer reduce-auto-indent-delay t 'reduce-auto-indent-function))) (setq reduce-auto-indent-mode on-p) (reduce-auto-indent-function))) (defun reduce-auto-indent-function () "Re-indent current line if a match with `reduce-auto-indent-regexp' has just be typed." (and (eq major-mode 'reduce-mode) (eq last-command 'self-insert-command) (save-excursion (save-match-data (if (re-search-backward reduce-auto-indent-regexp nil t) (reduce-indent-line)) )))) ;;;; ****************************** ;;;; Operations based on procedures ;;;; ****************************** (defun reduce-backward-procedure (arg) "Move backward to next start of procedure. With arg, do it arg times." (interactive "p") (let ((case-fold-search t) (count arg)) (while (and (> count 0) (reduce-re-search-backward procedure-regexp)) (setq count (1- count))) (if (= count arg) () ;; (reduce-backward-statement 1) ; overkill? Instead ... ;; Find preceding "%", ";", "$", "(" or beginning of buffer: (while (progn (skip-chars-backward "^%;$(") (and (not (bobp)) (not (backward-char 1)) (= (preceding-char) ?!)))) ;; If in %-comment then skip to its end: (if (reduce-back-to-percent-comment-start) (end-of-line)) ;; Find actual start of procedure statement: (if (reduce-re-search-forward "[a-zA-Z]") (backward-char 1)) ))) (defun reduce-forward-procedure (arg) "Move forward to next end of procedure. With arg, do it arg times." (interactive "p") (let ((case-fold-search t) (start (point)) count) ;; Move to end of procedure starting before point: (if (reduce-re-search-backward procedure-regexp) (reduce-forward-statement 2)) ;; Now move forward by arg or arg-1 procedures ;; or stay put if at least one move not possible (if (<= (point) start) () (setq arg (1- arg)) (setq start (point))) (setq count arg) (while (and (> count 0) (reduce-re-search-forward procedure-regexp)) (setq count (1- count))) (if (< count arg) (reduce-forward-statement 2) (goto-char start)) ) ;; Skip white space and any following eol: (skip-chars-forward " \t") (if (= (following-char) ?\n) (forward-char)) ) (defun reduce-mark-procedure (arg) "Put mark after next end of procedure, point at start of that procedure. Procedure ends AFTER any trailing white space. Returns t is successful, nil otherwise. With arg, mark the following arg procedures including this one." ;; Could be more efficient by hacking reduce-forward-procedure! (interactive "p") (let ((start (point)) transient-mark-mode) ;; Region must stay active, even if transient-mark-mode is on. (reduce-forward-procedure arg) (if (= (point) start) nil (skip-chars-forward " \t\n") ; skip trailing white space (push-mark start t) ; save original position QUIETLY (push-mark) ; mark end of procedure (reduce-backward-procedure arg) t) )) (defun reduce-kill-procedure () "Kill the procedure (and trailing white space) ending after point." (interactive "*") ; error if buffer read-only (if (reduce-mark-procedure 1) (kill-region (region-beginning) (region-end)))) (defun reduce-narrow-to-procedure (arg) ;; Based on `narrow-to-defun' in `lisp.el'. "Make text outside current procedure invisible. The procedure visible is the one that contains point or follows point. With arg, narrow to the following arg procedures including this one." (interactive "p") (save-excursion (widen) (reduce-forward-procedure arg) (let ((end (point))) (reduce-backward-procedure arg) (narrow-to-region (point) end)))) ;;;; ****************************** ;;;; Operations based on statements ;;;; ****************************** (defvar reduce-up-tries 1 "Repeat count of reduce-forward/backward-statement at end of block or group") (defvar start nil "Free variable, used in reduce-up-block-or-group-maybe, bound in reduce-forward/backward-statement") (defun reduce-up-block-or-group-maybe (found) "Move over `<<', `begin', `>>' or `end' (including end-of-file marker) after reduce-max-up-tries repeated interactive attempts." (if (and found (= (point) start) (eq this-command last-command)) (if (< reduce-up-tries reduce-max-up-tries) (setq reduce-up-tries (1+ reduce-up-tries)) (setq reduce-up-tries 1) (goto-char found) (if (eq this-command 'reduce-forward-statement) ;; End of file marker needs special treatment: (progn (reduce-re-search-forward "[;$]" 'move) (if (reduce-re-search-forward "[^ \t\f\n]") (goto-char found))) )) (setq reduce-up-tries 1))) (defvar pattern nil "Free variable -- used fairly widely") (defvar found nil "Free variable -- used fairly widely") (defun reduce-forward-statement (arg) "Move forward to end of statement. With arg, do it arg times. If looking at the end of a block or group, or the end-of-file marker, move over it after `reduce-max-up-tries' consecutive interactive tries." (interactive "p") (let ((case-fold-search t) (pattern "[;$]\\|>>\\|\\\\|<<\\|\\\\|\\s(\\|\\s)") (start (point)) found) ;; Skip an immediate closing bracket: (if (looking-at "[ \t\n]*\\s)") (goto-char (match-end 0))) (while (and (> arg 0) (reduce-forward-statement1)) (setq arg (1- arg))) ;; Never move backwards: (if (< (point) start) (goto-char start)) ;; Move over >> or end on repeated interactive attempt: (reduce-up-block-or-group-maybe found) )) (defun reduce-forward-statement1 () ;; Move forward to next statement end and return t if successful (if (looking-at "[;$]") ;; (forward-char 1) (not (forward-char 1)) (if (reduce-re-search-forward pattern) (cond ((= (preceding-char) ?>) (setq found (point)) (backward-char 2) (skip-chars-backward " \t\n") t) ((memq (preceding-char) '(?d ?D)) (setq found (point)) (backward-char 3) (skip-chars-backward " \t\n") t) ((= (preceding-char) ?<) (reduce-forward-group) (reduce-forward-statement1)) ((memq (preceding-char) '(?n ?N)) (reduce-forward-block) (reduce-forward-statement1)) ((= (char-syntax (preceding-char)) ?\( ) (backward-char) (forward-list) ; skip balanced brackets (reduce-forward-statement1)) ((= (char-syntax (preceding-char)) ?\) ) (if (save-excursion ; quoted list does not (backward-list) ; contain REDUCE statements (skip-chars-backward " \t\n") (= (preceding-char) ?')) (reduce-forward-statement1) (backward-char) (skip-chars-backward " \t\n") t)) (t t)) ))) (defvar not-eof nil "Free variable, bound in reduce-backward-statement, used in reduce-backward-statement1. True if point not after end-of-file marker.") (defun reduce-backward-statement (arg) "Move backward to start of statement. With arg, do it arg times. If looking at the beginning of a block or group move over it after `reduce-max-up-tries' consecutive interactive tries. The end-of-file marker is treated as a statement. Returns the count of statements left to move." ;; Return count used by reduce-calculate-indent-proc. (interactive "p") (let ((case-fold-search t) (pattern "[;$]\\|<<\\|\\\\|>>\\|\\\\|\\s)\\|\\s(") (start (point)) (found t) ;; Check whether after end of file marker, ``end''. ;; Assume it starts at the beginning of the line. (not-eof (save-excursion (or (reduce-re-search-forward "[^ \t\f\n]") (not (progn (reduce-re-search-backward "[^ \t\f\n]") (beginning-of-line) (looking-at "\\"))) )))) (if (and (reduce-re-search-backward "[^ \t\f\n]") (not (or (memq (following-char) '(?\; ?$)) ;; Skip an immediate opening bracket: (= (char-syntax (following-char)) ?\( )))) (forward-char 1)) (while (and (> arg 0) found) (setq found (reduce-backward-statement1)) (setq arg (1- arg))) (if found (cond ((= (following-char) ?<) (setq found (point)) (forward-char 2)) ((memq (following-char) '(?b ?B)) (setq found (point)) (forward-char 5)) (t (forward-char 1)) )) ;; Move to actual start of statement: (reduce-re-search-forward "[^ \t\f\n]") (backward-char 1) ;; Never move forwards: (if (> (point) start) (goto-char start)) ;; Move over << or begin on repeated interactive attempt: (reduce-up-block-or-group-maybe found) arg )) (defun reduce-backward-statement1 () ;; Move backward to next statement beginning. ;; Returns t if successful, nil if reaches beginning of buffer. (if (reduce-re-search-backward pattern 'move) (cond ((= (following-char) ?>) ; end of group (reduce-backward-group) (reduce-backward-statement1)) ((memq (following-char) '(?e ?E)) ; end of block (or file) (if not-eof (progn (reduce-backward-block) (setq not-eof nil))) (reduce-backward-statement1)) ((= (char-syntax (following-char)) ?\) ) (forward-char) (backward-list) ; skip balanced brackets (reduce-backward-statement1)) ((= (char-syntax (following-char)) ?\( ) (forward-char) (skip-chars-forward " \t\n") (backward-char) t) (t t)) )) (defun reduce-kill-statement (&optional arg) "Kill the rest of the current statement; if no nonblanks kill thru newline. With prefix argument, kill that many statements from point. Negative arguments kill complete statements backwards, cf. `kill-line'." ;; Based on kill-line in simple.el (interactive "*P") ; error if buffer read-only (kill-region (point) (progn (if (and (null arg) (looking-at "[ \t]*$")) (forward-line 1) (setq arg (prefix-numeric-value arg)) (if (> arg 0) (progn (reduce-forward-statement arg) (skip-chars-forward " \t")) ; 2 Oct 1994 (reduce-backward-statement (- 1 arg)))) (point)))) ;;;; ************************ ;;;; Moving by block or group ;;;; ************************ (defun reduce-up-block-or-group (arg) "Move backward up one level of block or group to beginning of nearest unpaired `begin' or `<<'. A universal argument means move forward to end of nearest unpaired `end' or `>>'. With a numeric argument, do it that many times, where a negative argument means move forward instead of backward." (interactive "P") (let ((case-fold-search t)) (setq arg (reduce-prefix-numeric-value arg)) (while (and (not (= arg 0)) (reduce-up-block-or-group1 arg)) (setq arg (if (> arg 0) (1- arg) (1+ arg))) ))) (defun reduce-up-block-or-group1 (arg) (let ((start (point))) (if (or (and (> arg 0) (reduce-backward-block-or-group)) (and (< arg 0) (reduce-forward-block-or-group))) t (goto-char start) nil))) (defun reduce-backward-block-or-group () "Move backward to beginning of block or group containing point." (if (reduce-re-search-backward "\\\\|<<\\|\\\\|>>") (cond ((= (following-char) ?>) (reduce-backward-group) (reduce-backward-block-or-group)) ((memq (following-char) '(?e ?E)) (reduce-backward-block) (reduce-backward-block-or-group)) (t t) ))) (defun reduce-forward-block-or-group () "Move forward to end of block or group containing point." (if (reduce-re-search-forward "\\\\|>>\\|\\\\|<<") (cond ((= (preceding-char) ?<) (reduce-forward-group) (reduce-forward-block-or-group)) ((memq (preceding-char) '(?n ?N)) (reduce-forward-block) (reduce-forward-block-or-group)) (t t) ))) (defun reduce-down-block-or-group (arg) "Move forward down one level of block or group to end of nearest unpaired `begin' or `<<'. A universal argument means move backward to beginning of nearest unpaired `end' or `>>'. With a numeric argument, do it that many times, where a negative argument means move backward instead of forward." (interactive "P") (let ((case-fold-search t)) (setq arg (reduce-prefix-numeric-value arg)) (while (and (not (= arg 0)) (reduce-down-block-or-group1 arg)) (setq arg (if (> arg 0) (1- arg) (1+ arg))) ))) (defun reduce-down-block-or-group1 (arg) (let ((start (point))) (if (if (> arg 0) (and (reduce-re-search-forward "<<\\|\\\\|>>\\|\\") (memq (preceding-char) '(?< ?n ?N))) (and (reduce-re-search-backward ">>\\|\\\\|<<\\|\\") (memq (following-char) '(?> ?e ?E))) ) t (goto-char start) nil) )) (defun reduce-prefix-numeric-value (arg) "Interpret universal -> -1, otherwise apply prefix-numeric-value." (if (and arg (listp arg)) -1 (prefix-numeric-value arg))) (defun reduce-forward-block () "Move forward to end of block containing point and return t, or move as far as possible and return nil." (let (return) (while (and (setq return (reduce-re-search-forward "\\\\|\\" 'move)) (memq (preceding-char) '(?n ?N))) (reduce-forward-block)) return)) (defun reduce-backward-block () "Move backward to start of block containing point and return t, or move as far as possible and return nil." (let (return) (while (and (setq return (reduce-re-search-backward "\\\\|\\" 'move)) (memq (following-char) '(?e ?E))) (reduce-backward-block)) return)) (defun reduce-forward-group () "Move forward to end of group containing point and return t, or move as far as possible and return nil." (let (return) (while (and (setq return (reduce-re-search-forward ">>\\|<<" 'move)) (= (preceding-char) ?<)) (reduce-forward-group)) return)) (defun reduce-backward-group () "Move backward to start of group containing point and return t, or move as far as possible and return nil." (let (return) (while (and (setq return (reduce-re-search-backward "<<\\|>>" 'move)) (= (following-char) ?>)) (reduce-backward-group)) return)) ;;;; ***************************************************************** ;;;; Searching for syntactic elements ignoring comments, strings, etc. ;;;; ***************************************************************** (defvar move nil "Free variable, bound in reduce-re-search-forward/backward, used in reduce-re-search-forward/backward2. True if search should move regardless.") (defun reduce-re-search-forward (REGEXP &optional MOVE) "Regexp syntactic search forward, skipping REDUCE comments, strings, escaped tokens, and quoted tokens other than `('. Return t if match found, nil otherwise. If no match and optional arg MOVE is non-nil then move to end." (let ((start (point)) (pattern (concat REGEXP "\\|%\\|\\")) (move (if MOVE 'move t))) (if (reduce-re-search-forward1) t (if (not MOVE) (goto-char start)) nil) )) (defun reduce-re-search-forward1 () ;; Skip strings (if (reduce-re-search-forward2) (if (reduce-in-string) ; try again! (reduce-re-search-forward1) t) nil)) (defun reduce-re-search-forward2 () ;; Skip escaped, quoted or commented text (if (re-search-forward pattern nil move) (let ((match-data (match-data)) before) (if (> (match-beginning 0) 0) (setq before (char-after (1- (match-beginning 0))))) (cond ((and before (or (= before ?!) ; skip escaped text (and (= before ?') ; skip quoted text except '(...) (not (= (char-after (match-beginning 0)) ?\( ))))) (reduce-re-search-forward2)) ; search again ((= (preceding-char) ?%) ; skip % comment (forward-line 1) (reduce-re-search-forward2)) ; search again ((string-match "^comment$" ;; otherwise might fortuitously match only ;; the beginning of the string "comment" (buffer-substring (match-beginning 0) (match-end 0)) ) (re-search-forward "[^!][;$]" nil move) ; 'move ??? (reduce-re-search-forward2)) ; search again (t (store-match-data match-data) t)) ))) (defvar REGEXP nil "Free variable, bound in reduce-re-search-backward, used in reduce-re-search-backward2. Search regexp.") (defun reduce-re-search-backward (REGEXP &optional MOVE) "Regexp syntactic search backward, skipping REDUCE comments and strings. Return t if match found, nil otherwise. If no match and optional arg MOVE is non-nil then move to end." (let ((start (point)) (move (if MOVE 'move t))) (if (reduce-re-search-backward1) t (if (not MOVE) (goto-char start)) nil) )) (defun reduce-re-search-backward1 () ;; Skip strings (if (reduce-re-search-backward2) (if (reduce-in-string) ; try again! (reduce-re-search-backward1) t) nil)) (defun reduce-re-search-backward2 () ;; Skip escaped, quoted or commented text (if (re-search-backward REGEXP nil move) (let ((match-data (match-data))) (if (or (= (preceding-char) ?!) ; escaped (and (= (preceding-char) ?') ; quoted (maybe) (not (= (char-after (- (point) 2)) ?!))) (reduce-back-to-comment-start)) ; in comment (reduce-re-search-backward2) ; search again ;; Restore finally accepted match data: (store-match-data match-data) t) ))) (defun reduce-back-to-comment-start () "If point is in a comment then move to its start and return t, otherwise do not move and return nil." (or ;; Check whether in % comment: (reduce-back-to-percent-comment-start) ;; Check whether in comment statement: (let ((start (point)) found (pattern "[^!][;$]\\|\\")) (reduce-back-to-comment-statement-start) (cond (found ; in comment statement -- (reduce-back-to-comment-statement-start) ; find its true beginning (goto-char found) t) (t (goto-char start) nil)) ; not in comment statement ))) (defun reduce-back-to-comment-statement-start () "Move backwards to the nearest `comment' keyword or separator; if it is `comment' then save its start position in `found'." (while (and (re-search-backward pattern nil 'move) (reduce-back-to-percent-comment-start))) (if (looking-at "comment") (setq found (point))) ) (defun reduce-back-to-percent-comment-start () "If point is in a percent comment then move to its start and return t, otherwise do not move and return nil." ;;; (re-search-backward ;;; "^%\\|[^!]%" (save-excursion (beginning-of-line) (point)) t) ;; Note that a % may appear at the end of, or alone on, a line! (let ((start (point))) (beginning-of-line) (prog1 (re-search-forward "^%\\|[^!]%" (1+ start) 'move) (backward-char) ))) (defun reduce-in-string () "Returns t if point is within a string, assuming no multi-line strings." (let ((start (point)) (in-string nil)) (beginning-of-line) (while (< (point) start) (if (= (following-char) ?\") (if in-string ;; Cannot include a \" within a string (setq in-string nil) ; found end of string (if (not(= (preceding-char) ?!)) (setq in-string t)) ; found beginning of string )) (forward-char 1)) in-string)) ;;;; **************** ;;;; Comment commands ;;;; **************** (defun reduce-comment-region (beg-region end-region arg) "Comment/uncomment every line in the region. With interactive arg, comment if non-negative, uncomment if null or negative (cf. minor modes). Puts `reduce-comment-region' at the beginning of every line in the region. First two args specify the region boundaries, third arg is interactive." ;; Taken almost directly from fortran.el ;; by Michael D. Prange (prange@erl.mit.edu). (interactive "*r\nP") ; error if buffer read-only (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 (if arg (< (reduce-prefix-numeric-value arg) 0) (looking-at "%")) ; FJW ;; Uncomment the region: (let ((com "%+ ?")) (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))))) ;; Comment the region: (progn (insert reduce-comment-region) (while (and (= (forward-line 1) 0) (< (point) end-region-mark)) (insert reduce-comment-region))) ) (goto-char save-point) (set-marker end-region-mark nil) (set-marker save-point nil))) (defun reduce-comment-procedure (arg) "Comment/uncomment every line of the procedure ending after point. With interactive arg, if non-negative comment out procedure, if null or negative uncomment all consecutive commented-out lines containing or following point (cf. minor modes)." (interactive "*P") ; error if buffer read-only (save-excursion (beginning-of-line) (if (if arg (< (reduce-prefix-numeric-value arg) 0) (looking-at "%")) (let (start) ; uncomment lines (if (looking-at "%") ; necessary ??? (if (re-search-backward "^[^%]" nil t) (forward-line 1)) (re-search-forward "^%" nil t)) (setq start (point)) (re-search-forward "^[^%]" nil t) (reduce-comment-region start (point) -1)) ; UNCOMMENT (if (reduce-mark-procedure 1) ; comment out procedure (progn ; first back up to real (exchange-point-and-mark) ; end of procedure (skip-chars-backward " \t\n") (reduce-comment-region (region-beginning) (region-end) nil)))) )) (defun reduce-fill-comment (justify) "Fill successive %-comment lines around or immediately following point. Prefix arg means justify as well." ;; Should perhaps add support for comment statements as well. (interactive "*P") (save-excursion (let (first) (beginning-of-line) ;; If point is before a comment line then move to its start: ;; (Otherwise find start later by moving backwards.) (while (and (looking-at "[ \t]*$") (= (forward-line) 0) (setq first (point)) )) ;; If point is in a comment then find its prefix and fill it: (if (looking-at "[ \t]*%") (let (fill-prefix last) ;; Code modified from `set-fill-prefix' in fill.el (setq fill-prefix (buffer-substring (point) (progn (skip-chars-forward " \t%") (point)))) (if (equal fill-prefix "") (setq fill-prefix nil)) ;; Find the last line of the comment: (while (and (= (forward-line) 0) (looking-at "[ \t]*%")) ) (setq last (point)) ;; Move to the first line of the comment: (if first (goto-char first) (while (and (= (forward-line -1) 0) (looking-at "[ \t]*%")) ) ;; Might have reached bob, so ... (if (not (looking-at "[ \t]*%")) (forward-line))) ;; Fill region as one paragraph: break lines to fit fill-column. (fill-region-as-paragraph (point) last justify) ))))) ;;;; *************************** ;;;; Structure template commands ;;;; *************************** (defun reduce-insert-if-then (&optional else) "Insert `if ... then' and position point inside. With argument include a correctly indented `else' on a second line." (interactive "*P") ; error if buffer read-only (insert "if ") (let ((finish (point))) (insert " then ") (if else (progn (newline) (insert "else ") (reduce-indent-line) )) (goto-char finish) )) (defun reduce-insert-block (&optional nosplit) "Insert and indent `begin ... end' block and position point inside. With argument put `begin' and `end' on the same line (see reduce-insert-block-or-group)." (interactive "*P") ; error if buffer read-only (reduce-insert-block-or-group "begin" "end" t nosplit)) (defun reduce-insert-group (&optional nosplit) "Insert and indent `<< >>' group and position point inside. With argument put `<<' and `>>' on the same line (see reduce-insert-block-or-group)." (interactive "*P") ; error if buffer read-only (reduce-insert-block-or-group "<<" ">>" nil nosplit)) (defun reduce-insert-block-or-group (open close block nosplit) "Insert and indent `open ... close' structure and position point inside. If the mark is transient and active then enclose the region; otherwise if point is not at the end of the line then enclose the rest of the line. Leave the mark at the insertion point in the body of a block. If `nosplit' is true then put `open' and `close' on the same line." (let ((region-beginning (and transient-mark-mode mark-active (region-beginning))) (region-end (and transient-mark-mode mark-active (copy-marker (region-end)))) finish-marker) (if region-beginning (goto-char region-beginning)) (insert open) (if block (progn (insert " scalar ") (setq finish-marker (point-marker)) (insert ";"))) (if (looking-at "[ \t]*$") () (if nosplit (insert " ") (newline-and-indent))) (if region-end (progn ; better to indent rigidly? (reduce-indent-region (point) region-end) (goto-char region-end) (if (bolp) (backward-char)) (set-marker region-end nil) ) (if (looking-at "[ \t]*$") () ;; (reduce-forward-statement 1) (end-of-line) (setq region-end t)) ) (if region-end () (reduce-indent-line) (if nosplit (insert " ") (newline-and-indent)) ) (if block (push-mark) (setq finish-marker (point-marker))) (if nosplit (insert " ") (newline)) (insert close) (if (looking-at "[ \t]*else") (just-one-space) (insert ";") (if (looking-at "[ \t]*$") () (insert " ")) ) (reduce-indent-line) ; necessary AFTER inserting close (goto-char finish-marker) (set-marker finish-marker nil) )) ;; If an expansion function interprets an argument then it means that ;; the expansion should be kept on one line. The following are ;; provided solely to ignore any argument: (defun reduce-expand-if-then (&optional arg) "Insert `if ... then' and position point inside." (reduce-insert-if-then)) (defun reduce-expand-if-then-else (&optional arg) "Insert `if ... then ... else' and position point after `if'." (reduce-insert-if-then 'else)) ;;;; ********************************** ;;;; Balanced structure (sexp) commands ;;;; ********************************** (defun reduce-forward-sexp (&optional arg) "Move forward across one balanced expression. With argument, do it that many times." (interactive "p") (let ((case-fold-search t)) (skip-chars-forward " \t\n;$") (cond ((= (char-syntax (following-char)) ?\( ) (forward-sexp)) ((looking-at "<<") (forward-char 2) (reduce-forward-group)) ((looking-at "begin") (forward-char 5) (reduce-forward-block)) ((looking-at ">>") (forward-char 2)) (t (forward-sexp)) )) (if (and arg (> arg 1)) (reduce-forward-sexp (1- arg))) ) (defun reduce-backward-sexp (&optional arg) "Move backward across one balanced expression. With argument, do it that many times." (interactive "p") (skip-chars-backward " \t\n;$") (if (= (char-syntax (preceding-char)) ?\) ) (backward-sexp) (let ((case-fold-search t) (start (point))) (skip-chars-backward ">>end<<") (cond ((looking-at ">>") (reduce-backward-group)) ((looking-at "end") (reduce-backward-block)) ((looking-at "<<")) (t (goto-char start) (backward-sexp)) ) )) (if (and arg (> arg 1)) (reduce-backward-sexp (1- arg))) ) ;;;; ************************************* ;;;; Support for matching group delimiters ;;;; ************************************* (defun reduce-self-insert-and-blink-matching-group-open () "Insert character and then blink matching group opening construct." ;; Based on blink-matching-open in simple.el ;; but cannot use syntax table for composite tokens like << ... >> (interactive "*") ; error if buffer read-only ;; (insert last-command-char) (insert ?>) (and (= (char-after (- (point) 2)) ?>) blink-matching-paren (save-excursion (save-restriction (if blink-matching-paren-distance (narrow-to-region (max (point-min) (- (point) blink-matching-paren-distance)) (point))) (backward-char 2) (reduce-backward-group) ) (if (looking-at "<<") (blink-point) (message "Matching << not found")) ;; [within blink-matching-paren-distance] ) )) (defun blink-point () "Blink the position of point." ;; Based closely on blink-matching-open in simple.el (if (pos-visible-in-window-p) (sit-for 1) (let ((blinkpos (point))) (message "Matches %s" (if (save-excursion (skip-chars-backward " \t") (not (bolp))) (buffer-substring (progn (beginning-of-line) (point)) (+ blinkpos 2)) (buffer-substring blinkpos (progn (forward-char 1) (skip-chars-forward "\n \t") (end-of-line) (point))))) ))) ;;; Display highlighting on whatever group or block delimiter matches ;;; the one before or after point. ;;; Based closely on paren.el --- highlight matching paren --- by RMS ;;; NOTE: Cannot use simple syntactic matching even for group, because ;;; it cannot distinguish a single < from <<, etc. ;;; Add matching of delim AROUND point later??? ;; Overlay used to highlight the matching delim: (defvar reduce-show-delim-overlay nil) ;; Overlay used to highlight the closedelim right before point: (defvar reduce-show-delim-overlay-1 nil) (defvar reduce-show-delim-idle-timer nil) (defun reduce-show-delim-mode (&optional arg) "Toggle REDUCE Show Delim mode. With prefix ARG, turn REDUCE Show Delim mode on if and only if ARG is positive. Returns the new status of REDUCE Show Delim mode (non-nil means on). When REDUCE Show Delim mode is enabled, any matching delimiter is highlighted after `show-paren-delay' seconds of Emacs idle time." (interactive "P") (if window-system (let ((on-p (if arg (> (prefix-numeric-value arg) 0) (not reduce-show-delim-mode)))) (and reduce-show-delim-idle-timer (cancel-timer reduce-show-delim-idle-timer)) (cond (on-p (require 'paren) ; for show-paren-delay (setq reduce-show-delim-idle-timer (run-with-idle-timer show-paren-delay t 'reduce-show-delim-function)) (define-key reduce-mode-map ">" nil)) ; undefined (t (and reduce-show-delim-overlay (overlay-buffer reduce-show-delim-overlay) (delete-overlay reduce-show-delim-overlay)) (and reduce-show-delim-overlay-1 (overlay-buffer reduce-show-delim-overlay-1) (delete-overlay reduce-show-delim-overlay-1)) ;; Blink matching group delimiter (define-key reduce-mode-map ">" 'reduce-self-insert-and-blink-matching-group-open))) (setq reduce-show-delim-mode on-p)))) (defun reduce-show-delim-function () "In REDUCE mode (only), perform matching delimiter highlighting. \(Highlights group and block delimiters only.)" ;; Do nothing if no window system to display results with. ;; Do nothing if executing keyboard macro. ;; Do nothing if input is pending. (when (and window-system (eq major-mode 'reduce-mode)) (let (pos dir mismatch face (case-fold-search t)) (cond ((and (eq (following-char) ?<) ;; (or (eq (preceding-char) ?<) (eq (char-after (1+ (point))) ?<) );) (setq dir 2)) ((and (eq (preceding-char) ?>) ;; (or (eq (following-char) ?>) (eq (char-after (- (point) 2)) ?>) );) (setq dir -2)) ((save-match-data (looking-at "\\")) (setq dir 3)) ((and (memq (preceding-char) '(?d ?D)) (memq (char-after (- (point) 2)) '(?n ?N)) (memq (char-after (- (point) 3)) '(?e ?E)) (/= (char-syntax (following-char)) ?w) (/= (char-syntax (char-after (- (point) 4))) ?w) ) (setq dir -3)) ) ;; ;; Find the other end of the sexp. (when dir (save-excursion (save-restriction ;; Determine the range within which to look for a match. (when blink-matching-paren-distance (narrow-to-region (max (point-min) (- (point) blink-matching-paren-distance)) (min (point-max) (+ (point) blink-matching-paren-distance)))) ;; Scan across one group or block within that range. ;; Errors or nil mean there is a mismatch. (condition-case () (progn (forward-char dir) (if (cond ((= dir 2) (reduce-forward-group)) ((= dir -2) (reduce-backward-group)) ((= dir 3) (reduce-forward-block)) ((= dir -3) (reduce-backward-block))) (setq pos (point)) (setq pos t mismatch t))) (error (setq pos t mismatch t))) ))) ;; ;; Highlight the other end of the sexp, or unhighlight if none. (if (not pos) (progn ;; If not at a delim that has a match, ;; turn off any previous delim highlighting. (and reduce-show-delim-overlay (overlay-buffer reduce-show-delim-overlay) (delete-overlay reduce-show-delim-overlay)) (and reduce-show-delim-overlay-1 (overlay-buffer reduce-show-delim-overlay-1) (delete-overlay reduce-show-delim-overlay-1))) ;; ;; Use the correct face. (if mismatch (progn (if show-paren-ring-bell-on-mismatch (beep)) (setq face 'reduce-show-delim-mismatch-face)) (setq face 'reduce-show-delim-match-face)) ;; ;; If matching backwards, highlight the closedelim ;; before point as well as its matching open. ;; If matching forward, and the opendelim is unbalanced, ;; highlight the delim at point to indicate misbalance. ;; Otherwise, turn off any such highlighting. (if (and (> dir 0) (integerp pos)) (when (and reduce-show-delim-overlay-1 (overlay-buffer reduce-show-delim-overlay-1)) (delete-overlay reduce-show-delim-overlay-1)) (if (= dir 3) (setq dir 5)) ; for mismatched `begin' (let ((from (if (> dir 0) (point) (forward-point dir))) (to (if (> dir 0) (forward-point dir) (point)))) (if reduce-show-delim-overlay-1 (move-overlay reduce-show-delim-overlay-1 from to (current-buffer)) (setq reduce-show-delim-overlay-1 (make-overlay from to))) ;; Always set the overlay face, since it varies. (overlay-put reduce-show-delim-overlay-1 'face face))) ;; ;; Turn on highlighting for the matching delim, if found. ;; If it's an unmatched delim, turn off any such highlighting. (unless (integerp pos) (delete-overlay reduce-show-delim-overlay)) (if (= dir -3) (setq dir -5)) ; for matched `begin' (let ((to (if (or (eq show-paren-style 'expression) (and (eq show-paren-style 'mixed) (not (pos-visible-in-window-p pos)))) (point) pos)) (from (if (or (eq show-paren-style 'expression) (and (eq show-paren-style 'mixed) (not (pos-visible-in-window-p pos)))) pos (save-excursion (goto-char pos) (forward-point (- dir)))))) (if reduce-show-delim-overlay (move-overlay reduce-show-delim-overlay from to (current-buffer)) (setq reduce-show-delim-overlay (make-overlay from to)))) ;; ;; Always set the overlay face, since it varies. (overlay-put reduce-show-delim-overlay 'face face))))) ;;;; ***************************** ;;;; Support for reposition-window ;;;; ***************************** ;; The next two functions should probably be built into ;; reduce-forward/backward-procedure: (defun reduce-beginning-of-defun (&optional arg) (if (null arg) (setq arg 1)) (if (> arg 0) (reduce-backward-procedure arg) (reduce-forward-procedure (- 1 arg)) (reduce-backward-procedure 1))) (defun reduce-end-of-defun (&optional arg) (if (null arg) (setq arg 1)) (if (> arg 0) (reduce-forward-procedure arg) (reduce-backward-procedure (- 1 arg)) (reduce-forward-procedure 1))) (defun reduce-reposition-window () "See reposition-window for details." (interactive) (let ((beginning-of-defun (symbol-function 'beginning-of-defun)) (end-of-defun (symbol-function 'end-of-defun))) (fset 'beginning-of-defun 'reduce-beginning-of-defun) (fset 'end-of-defun 'reduce-end-of-defun) (condition-case nil (reposition-window) (error (message "Error trapped in reposition-window"))) (fset 'beginning-of-defun beginning-of-defun) (fset 'end-of-defun end-of-defun) )) ;;;; ****************************************************** ;;;; Support for REDUCE keyword/phrase/structure completion ;;;; ****************************************************** (defun reduce-complete-symbol (arg) "Perform completion on REDUCE symbol preceding point or region if mark is transient and active. Compare that symbol against the elements of `reduce-completion-alist'. If a perfect match (only) has a cdr then delete the match and insert the cdr if it is a string or call it if it is a (nullary) function, passing on any prefix argument (in raw form)." ;; Based on lisp-complete-symbol in lisp.el (interactive "*P") ; error if buffer read-only (let* ((end (progn (cond ((and transient-mark-mode mark-active) (if (= (point) (region-beginning)) () (exchange-point-and-mark) (skip-syntax-backward " ")))) (point))) (beg (unwind-protect (save-excursion (reduce-backward-sexp) ;; (while (= (char-syntax (following-char)) ?\') ;; (forward-char 1)) (skip-syntax-forward "\'") (point)) )) (pattern (buffer-substring-no-properties beg end)) (completion (try-completion pattern reduce-completion-alist))) (cond ((eq completion t) ; perfect match (let ((fn (cdr (assoc pattern reduce-completion-alist)))) (if fn (cond ((stringp fn) (delete-region beg end) (insert fn)) ((fboundp fn) (delete-region beg end) (funcall fn arg)) (t (error "Completion for \"%s\" not a string or function." pattern))) ))) ((null completion) (message "Can't find completion for \"%s\"" pattern) (ding)) ((not (string= pattern completion)) (delete-region beg end) (insert completion) (if (fboundp (cdr (assoc completion reduce-completion-alist))) (setq deactivate-mark nil))) ; for beg -> begin -> ... (t (message "Making completion list...") (let ((list (all-completions pattern reduce-completion-alist))) (with-output-to-temp-buffer "*Completions*" (display-completion-list list))) (message "Making completion list...%s" "done"))))) ;;;; **************************************************** ;;;; Support font-lock-mode for highlighting keywords and ;;;; "object" names (based on code by Rainer Schoepf). ;;;; **************************************************** ;; Fontification is performed syntactically (e.g. comments) and THEN ;; by keyword. ;; *** Make these temp variables let bindings later ??? *** (defconst reduce-identifier-regexp "\\([a-z]\\|!.\\)\\(\\w\\|\\s_\\|!.\\)*" ;; NB: digits have word syntax "Regular expression matching a REDUCE identifier.") (defconst reduce-keyword-regexp (mapconcat 'identity ; keywords '("begin" "return" "end\\(module\\)?" "if" "then" "else" "while" "do" "repeat" "until" "collect" "join" "conc" "sum" "product" "for\\(\\s *\\(all\\|each\\)\\)?" "step" "in" "on" "off" "comment" "write" "let" ; "where" "when" ??? ;; Lisp keywords used frequently in REDUCE: "lambda" "function" ;; "put" "flag" "remprop" "remflag" ) "\\|") "Regular expression matching a REDUCE keyword.") (defconst reduce-infix-regexp "where\\|when\\|or\\|and\\|member\\|memq\\|neq\\|eq" ) ;(defvar reduce-reserved-variable-regexp ; "e\\|i\\|infinity\\|nil\\|pi\\|t") (defconst font-lock-default-face 'font-lock-default-face "A copy of the default face for use by REDUCE Font Lock mode.") (copy-face 'default 'font-lock-default-face) (defconst reduce-font-lock-keywords-0 (list ;; Main keywords: (list (concat ;; Ignore quoted keywords and composite identifiers: "\\(^[^!_']?\\|[^!][^!_']\\)" "\\<\\(\\(" reduce-keyword-regexp "\\)" ;; Handle consecutive keywords: "\\(\\s +\\(" reduce-keyword-regexp "\\)\\)*" "\\)\\>" ;; Ignore composite identifiers: "[^!_]" ) '(2 font-lock-keyword-face)) ;; Group delimiters and references: '("<<\\|>>\\|\\<\\(module\\|go\\(\\s *to\\)?\\)\\>" . font-lock-keyword-face) ;; Procedure declarations: (list (concat "\\(^\\|ic\\|macro\\|expr\\)\\s *\\<\\(procedure\\)\\s +" "\\(" reduce-identifier-regexp "\\)" "\\s *(?") '(2 font-lock-keyword-face) ;; '(2 font-lock-function-name-face t) ; highlights within comments '(3 font-lock-function-name-face) ) ;; Type declarations: ; '("[^!][^_]\\<\\(algebraic\\|symbolic\\|operator\\|scalar\\|integer\\|real\\)\\>[^!_]" '("\\(?:^\\|[^_]\\)\\<\\(algebraic\\|symbolic\\|operator\\|scalar\\|integer\\|real\\)\\>[^!_]" (1 font-lock-type-face)) ) "Default minimal REDUCE fontification rules" ) (defconst reduce-font-lock-keywords-basic (list ;; Main keywords: (list (concat ;; Ignore quoted keywords and composite identifiers: "\\(^[^!_']?\\|[^!][^!_']\\)" "\\<\\(\\(" reduce-keyword-regexp "\\)" ;; Handle consecutive keywords: "\\(\\s +\\(" reduce-keyword-regexp "\\)\\)*" "\\)\\>" ;; Ignore composite identifiers: "[^!_]" ) '(2 font-lock-keyword-face)) ;; Group delimiters: OK '("<<\\|>>" . font-lock-keyword-face) ;; Procedure declarations: (list (concat "\\<\\(procedure\\)\\s +" "\\(" reduce-identifier-regexp "\\)" "\\s *(?") '(1 font-lock-keyword-face) ;; This will probably cause highlighting within comments, see above: '(2 font-lock-function-name-face t) ;; Anchored matches (single line only!): (list (concat "\\s *" "\\(" reduce-identifier-regexp "\\)" "\\s *\\([\);$].*\\|\\s.\\)" ; Stop after `)', `;' or `$' ) nil nil '(1 font-lock-variable-name-face)) ) ;; Type declarations: (list "\\<\\(operator\\|scalar\\|integer\\|real\\)\\s " '(1 font-lock-type-face) ;; Anchored matches (single line only!): (list (concat "\\s *" "\\(" reduce-identifier-regexp "\\)" "\\s *\\s." ) nil nil '(1 font-lock-variable-name-face)) ) ;; References -- goto and labels: (list (concat "\\<\\(go\\(\\s *to\\)?\\)\\s +" "\\(" reduce-identifier-regexp "\\)") '(1 font-lock-keyword-face) '(3 font-lock-constant-face)) ; was font-lock-reference-face (cons (concat "^\\s *\\(" reduce-identifier-regexp "\\)\\s *:[^=]") '(1 font-lock-constant-face)) ; was font-lock-reference-face ) "Basic REDUCE fontification sub-rules" ) (defconst reduce-font-lock-keywords-algebraic (list ;; More type declarations: (list "\\<\\(array\\|matrix\\)\\s " '(1 font-lock-type-face) ;; Anchored matches (single line only!): (list (concat "\\s *" "\\(" reduce-identifier-regexp "\\)" "\\s *\\(([^\)]*)\\s *\\)?\\s." ) nil nil '(1 font-lock-variable-name-face)) )) "More algebraic-mode REDUCE fontification sub-rules" ) (defconst reduce-font-lock-keywords-symbolic (list ;; References -- module: (list (concat "\\<\\(module\\)\\s +" "\\(" reduce-identifier-regexp "\\)") '(1 font-lock-keyword-face) '(2 font-lock-constant-face)) ; was font-lock-reference-face ;; Type declarations: '("\\<\\(fluid\\|global\\)\\>\\s *'(\\(.*\\))" (1 font-lock-type-face) (2 font-lock-variable-name-face)) (cons (concat ;; Ignore quoted keywords and composite identifiers: "\\(^[^!_']?\\|[^!][^!_']\\)" "\\<\\(newtok\\|precedence\\|switch\\|share\\|" "algebraic\\|symbolic\\|f?expr\\|s?macro\\)\\>" ;; Ignore composite identifiers: "[^!_]" ) '(2 font-lock-type-face)) ) "More symbolic-mode REDUCE fontification sub-rules" ) (defconst reduce-font-lock-keywords-full (list ;; Gaudier fontification ;; ===================== ;; More type declarations: (list "\\<\\(array\\|matrix\\)\\s " '(1 font-lock-type-face) ;; Anchored matches (single line only!): (list (concat "\\s *" "\\(" reduce-identifier-regexp "\\)" "\\s *\\(([^\)]*)\\s *\\)?\\s." ) nil nil '(1 font-lock-variable-name-face)) ) ;; Set *ALL* quoted identifiers in the default face: (cons (concat "'\\(" ;; All (multi-line) quoted lists (nested to 2 levels): "(\\([^)]*([^)]*[^!])\\)*[^)]*[^!])" "\\|" reduce-identifier-regexp ; includes keywords! "\\)") '(0 font-lock-default-face keep)) ; not already highlighted ;; Highlight variable invocations: ;; ( var), var PUNCTUATION, var EOL, var KEYWORD, var INFIX ) (list (concat "\\(" reduce-identifier-regexp "\\)" "\\s *\\(" "\\s\)\\|\\s.\\|$\\|" "\\s \\<\\(" reduce-keyword-regexp "\\|\\(" reduce-infix-regexp "\\)\\)\\>" "\\)") '(1 font-lock-variable-name-face) '(4 font-lock-default-face)) ;;; Should force ALL infix ops into right font! ;; Highlight function calls: ;; ( fn(), fn{}, fn"", fn'data, fn var, fn ! ) (cons (concat "\\(\\(" reduce-identifier-regexp "\\)" ;; Handle unparenthesized compositions: "\\(\\s +\\(" reduce-identifier-regexp "\\)\\)*\\)" "\\s *\\(\\s\(\\|[\"']\\|\\s \\(\\w\\|!\\)\\)" ) ;; Must keep already fontified keywords in order to ;; highlight functions immediately following keywords ;; and avoid mis-highlighting variables: '(1 font-lock-function-name-face keep)) ) "Full maximal REDUCE fontification sub-rules" ) (defconst reduce-font-lock-keywords-1 (append reduce-font-lock-keywords-basic reduce-font-lock-keywords-algebraic) "Standard algebraic-mode REDUCE fontification rules" ) (defconst reduce-font-lock-keywords-2 (append reduce-font-lock-keywords-basic reduce-font-lock-keywords-symbolic) "Standard symbolic-mode REDUCE fontification rules" ) (defconst reduce-font-lock-keywords-3 (append reduce-font-lock-keywords-basic reduce-font-lock-keywords-algebraic reduce-font-lock-keywords-symbolic reduce-font-lock-keywords-full) "Full REDUCE fontification rules" ) ;; Provide a REDUCE font-lock menu, based on font-lock-menu.el by ;; Simon Marshall . (defvar reduce-font-lock-level (if (and (boundp 'font-lock-maximum-decoration) ;; boundp in case font-lock not loaded font-lock-maximum-decoration) (let ((max (length reduce-font-lock-keywords))) (if (numberp font-lock-maximum-decoration) (cond ((< font-lock-maximum-decoration 1) 1) ((> font-lock-maximum-decoration max) max) (t font-lock-maximum-decoration)) max)) ; t = maximum 1)) ; nil = minimum (defconst reduce-font-lock-submenu '("Syntax Highlighting" ["In Current Buffer" font-lock-mode :style toggle :selected font-lock-mode :active t] ["Highlight Buffer" font-lock-fontify-buffer t] ; ["Toggle `!' Syntax" reduce-font-lock-toggle-escape t] ["Maximum (4)" (reduce-font-lock-change 4) :style radio :selected (eq reduce-font-lock-level 4) :active t] ["Symbolic (3)" (reduce-font-lock-change 3) :style radio :selected (eq reduce-font-lock-level 3) :active t] ["Algebraic (2)" (reduce-font-lock-change 2) :style radio :selected (eq reduce-font-lock-level 2) :active t] ["Minimum (1)" (reduce-font-lock-change 1) :style radio :selected (eq reduce-font-lock-level 1) :active t])) (easy-menu-define ; (symbol maps doc menu) reduce-fontification-submenu nil "REDUCE Fontification Submenu" reduce-font-lock-submenu ) (define-key-after (lookup-key reduce-mode-map [menu-bar REDUCE]) [Fontification] (cons "Syntax Highlighting" reduce-fontification-submenu) t) ; was 'Make\ Proc\ Menu (defconst reduce-font-lock-level-names '("minimum" "algebraic" "symbolic" "maximum")) (defun reduce-font-lock-change (level) "Turn on REDUCE Font Lock mode using specified keywords." (interactive) (require 'font-lock) (let ((name (nth (1- level) reduce-font-lock-level-names)) (keywords (eval (nth (1- level) (car font-lock-defaults))))) ;; `font-lock-defaults' is used in order to support both ;; reduce-mode and reduce-run with the same code! (setq keywords (font-lock-compile-keywords keywords)) ; Emacs 20 only! (if (and font-lock-mode (equal font-lock-keywords keywords)) (message "REDUCE Font Lock decoration unchanged (level %d : %s)." level name) (font-lock-mode 0) (font-lock-set-defaults) (setq font-lock-keywords keywords) (font-lock-mode 1) (setq reduce-font-lock-level level) (message "REDUCE Font Lock decoration set to level %d : %s." level name)))) (defun reduce-font-lock-toggle-escape (&optional arg) "Toggle `!' escape syntax for REDUCE Font Lock mode (only) and re-fontify. With arg, clear `!' escape syntax if arg >= 0 and set it if arg < 0. For example, \(add-hook 'reduce-mode-hook (function (lambda () (reduce-font-lock-toggle-escape 1)))) will turn off the default font-lock escape syntax for `!'." (interactive "P") (require 'font-lock) (let ((reset font-lock-syntax-table)) (font-lock-mode 0) (font-lock-set-defaults) ; resets font-lock-syntax-table (if arg (setq reset (< (prefix-numeric-value arg) 0))) (if reset ;; `!' syntax has been reset to `escape', so do nothing: () ;; (setq font-lock-syntax-table nil) ; default ;; Set `!' syntax to punctuation: (setq font-lock-syntax-table (copy-syntax-table reduce-mode-syntax-table)) (modify-syntax-entry ?! "." font-lock-syntax-table)) ; punctuation (font-lock-mode 1) ;; Display message so it is not overwritten by font-lock messages: (message (if font-lock-syntax-table "REDUCE Font Lock syntax (only) for `!' set to `punctuation'." "REDUCE Font Lock syntax table reset.")))) ;;;; ********************************************************** ;;;; Support for displaying current procedure name in mode line ;;;; ********************************************************** (defvar reduce-show-proc-idle-timer nil) (defvar reduce-show-proc-string nil) (defvar which-func-mode) (defun reduce-show-proc-mode (&optional arg) "Toggle REDUCE Show Proc mode. With prefix ARG, turn REDUCE Show Proc mode on if and only if ARG is positive. Returns the new status of REDUCE Show Proc mode (non-nil means on). When REDUCE Show Proc mode is enabled, display current procedure name in mode line after `reduce-show-proc-delay' seconds of Emacs idle time." (interactive "P") (let ((on-p (if arg (> (prefix-numeric-value arg) 0) (not reduce-show-proc-mode)))) (if reduce-show-proc-idle-timer (cancel-timer reduce-show-proc-idle-timer)) (if on-p (setq reduce-show-proc-idle-timer (run-with-idle-timer reduce-show-proc-delay t 'reduce-show-proc-function))) (setq reduce-show-proc-mode on-p which-func-mode on-p) (reduce-show-proc-function))) (defconst reduce-show-proc-regexp (car reduce-imenu-generic-expression)) (defun reduce-current-proc () "Return name of procedure definition point is in, or nil." ;; Used by reduce-show-proc-mode and ChangeLog support (let ((start (point)) procname) (end-of-line) (save-match-data (when (re-search-backward (nth 1 reduce-show-proc-regexp) nil t) (setq procname (match-string (nth 2 reduce-show-proc-regexp))) (reduce-forward-procedure 1) (if (<= (point) start) ; not in procedure (setq procname nil)))) (goto-char start) procname)) (defun reduce-show-proc-function () "Display current procedure name in mode line." (when (eq major-mode 'reduce-mode) (setq reduce-show-proc-string (concat "[" (or (reduce-current-proc) "") "]")) (force-mode-line-update))) ;;;; ***************************************** ;;;; Support for tagging procedure definitions ;;;; ***************************************** (defun reduce-tagify-dir (dir) "Generate a REDUCE TAGS file for (all `.red' files in) a directory, by default the current directory." (interactive ;; In NT Emacs 21.0.104.1 GUI file selector does not work for ;; directories... (let (use-dialog-box) (list (read-file-name "Tag files in dir: " ; PROMPT (expand-file-name ".") ; DIRECTORY (default cwd) ;; ... used instead of nil to get forward slashes under ;; MS-DOS/Windows for compatibility with ;; `reduce-tagify-subdirs' "." ; DEFAULT t ; EXISTING )))) (reduce-tagify dir "*.red")) (defun reduce-tagify-subdirs (dir) "Generate a REDUCE TAGS file for all subdirectories of a directory, by default the parent of the current directory." (interactive ;; In NT Emacs 21.0.104.1 GUI file selector does not work for ;; directories... (let (use-dialog-box) (list (read-file-name "Tag subdirs of dir: " ; PROMPT (expand-file-name "..") ; DIRECTORY ".." ; DEFAULT t ; EXISTING )))) (reduce-tagify dir "*/*.red")) ; (start-process ; creates an asynchronous process ; "*rtags*" ; NAME for process ; "*rtags-out*" ; BUFFER-OR-NAME for stdout ; "sh" ; PROGRAM in `exec-path' to run ; "-c" ; ARGS ... ; "etags --lang=none '--regex=/[^%]*procedure[ \t]+\([^ \t()]+\)/\1/' $dir.red" ; ) (defun reduce-tagify (dir files) "Generate a REDUCE TAGS file in directory DIR as cwd for specified FILES \(a UNIX shell regexp)." ;; Assumes a UNIX shell called `sh' in `exec-path'! ;; (Could avoid use of `sh' by constructing file list in lisp.) (unless (file-directory-p dir) (error "Not a directory: %s" dir)) (setq dir (file-name-as-directory (expand-file-name dir))) (message "Tagging files `%s%s'" dir files) (let ((shell-file-name "sh") ; necessary for MS Windows etc. (default-directory dir)) (set-process-sentinel (start-process-shell-command ; creates an asynchronous shell process "*rtags*" ; NAME for process "*rtags-log*" ; BUFFER-OR-NAME for stdout "etags" ; PROGRAM in `exec-path' to run "--lang=none" ; ARGS ... "'--regex=/[^%\n]*procedure[ \t]+\\([^ \t()]+\\)/\\1/'" files) 'reduce-tagify-sentinel))) (defun reduce-tagify-sentinel (process event) "Sentinel to show (primarily) when the tagification is finished." (message "REDUCE tagify process %s has %s." process (substring event 0 -1))) ; remove trailing \n ;;;; ********************************************************************** ;;; Load Hook (defun require-reduce-run () "Require the library `reduce-run'. Useful on `reduce-mode-load-hook'." (require 'reduce-run)) (provide 'reduce-mode) (run-hooks 'reduce-mode-load-hook) ;;; reduce-mode.el ends here