1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560 |
- ;;; reduce-mode.el --- Major mode to edit REDUCE computer-algebra code
- ;; Copyright (C) 1998-2001, 2012, 2017-2019 Francis J. Wright
- ;; Author: Francis J. Wright <https://sourceforge.net/u/fjwright>
- ;; Created: late 1992
- ;; Version: $Id$
- ;; Keywords: languages
- ;; Homepage: https://reduce-algebra.sourceforge.io/reduce-ide
- ;; Package-Version: 1.55
- ;; This file is not part of GNU Emacs.
- ;; This program is free software: you can redistribute it and/or
- ;; modify it under the terms of the GNU General Public License as
- ;; published by the Free Software Foundation, either version 3 of
- ;; the License, or (at your option) any later version.
- ;; This program is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;; GNU General Public License for more details.
- ;; You should have received a copy of the GNU General Public License
- ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
- ;; Contributions by Rainer Schoepf flagged ; RS
- ;; Schoepf@goofy.zdv.Uni-Mainz.DE
- ;; Contributions by Thomas Sturm flagged ; TS
- ;; sturm@redlog.eu
- ;;; Commentary:
- ;; REDUCE Mode is a major mode for editing source code for the REDUCE
- ;; computer algebra system, which is Open Source and available from
- ;; <https://sourceforge.net/projects/reduce-algebra>.
- ;; The latest version of REDUCE Mode is available from
- ;; <https://sourceforge.net/p/reduce-algebra/code/HEAD/tree/trunk/generic/emacs>.
- ;; 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 PDF file `reduce-ide.pdf'.
- ;; The info file can be browsed using the independent info browsing
- ;; program called `info', or installed into the Emacs info browser.
- ;;; Usage:
- ;; To install in GNU Emacs 24+, download this file to any convenient
- ;; directory and run the Emacs command `package-install-file' on it.
- ;; Brief manual installation instructions follow.
- ;; Byte-compile this file, put it somewhere in your `load-path', and
- ;; put the following in your `.emacs' file:
- ;; (autoload 'reduce-mode "reduce-mode" "Major mode for REDUCE code editing" t)
- ;; To run REDUCE Mode automatically on files with extension ".red" or
- ;; ".tst" put the following (after `autoload') in your `.emacs' file:
- ;;;###autoload
- (add-to-list 'auto-mode-alist '("\\.\\(red\\|tst\\)\\'" . reduce-mode))
- ;; To make REDUCE Mode customization always available put the
- ;; following (after `autoload') in your `.emacs' file:
- ;;;###autoload
- (defgroup reduce nil
- "Support for editing and running REDUCE code."
- :tag "REDUCE" :group 'languages :load "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)
- ;;; To do:
- ;; BUGS
- ;; ====
- ;; ! should not be an escape IN STRINGS (motion by sexp, font-lock)
- ;; reduce-backward-statement does too much searching!
- ;; Enhancements
- ;; ============
- ;; 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:
- (defconst reduce-mode-version
- ;; Extract version from `package-version' in file header:
- (eval-when-compile
- (require 'lisp-mnt)
- (save-excursion (lm-header "package-version")))
- "Version information for REDUCE Mode.")
- ;; (message "Loading reduce-mode") ; TEMPORARY!
- (eval-when-compile ; keep compiler happy!
- (require 'timer))
- ;; 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.
- E.g. `turn-on-font-lock' to turn on font-lock mode locally.
- It can be used to customize buffer-local features of REDUCE mode."
- :type 'hook
- :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'.
- This adds 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-indent-line-conservative nil ; TS
- "*If non-nil, `reduce-indent-line' will not successively indent."
- :type 'boolean
- :group 'reduce-format-display)
- (defcustom reduce-comment-region-string "%% "
- "*String inserted by \\[reduce-comment-region] at start of each line."
- :version "1.21" ; Name was reduce-comment-region up to version 1555!
- :type 'string
- :group 'reduce-format-display)
- (defcustom reduce-auto-indent-mode t
- "*If non-nil then conditionally re-indent the current line.
- This will happen after `reduce-auto-indent-delay' seconds of 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-on show-paren-mode
- "If non-nil then turn on `reduce-show-delim-mode' initially.
- Since `reduce-show-delim-mode' is a buffer-local minor mode, it
- can also be turned on and off in each buffer independently.
- Defaults to the value of `show-paren-mode'."
- :package-version '(reduce-mode . "1.54")
- :type 'boolean
- :group 'reduce-format-display)
- (defcustom reduce-show-proc-mode nil
- "*If non-nil then display current procedure name in mode line.
- Update 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)
- ;; External variables:
- ;; Due to improvements of byte compilation around 2003 the compiler
- ;; would complain about `make-local-var' on these later on. I left
- ;; unchanged another (too late) declaration for `which-func-mode' below,
- ;; which appears not to disturb. TS
- (defvar which-func-mode)
- (defvar which-func-format)
- (defvar imenu-space-replacement)
- ;; Internal variables:
- (defvar reduce-imenu-done nil
- "Buffer-local: set to true if `reduce-imenu-add-to-menubar' 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!):
- (declare-function reduce-show-delim-mode "reduce-delim" ())
- ;;;###autoload
- (defun reduce-mode ()
- "Major mode for editing REDUCE source code -- part of REDUCE IDE.
- Author: Francis Wright <http://sourceforge.net/users/fjwright>
- 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 via the command `font-lock-mode', and
- the style of highlighting may be controlled by setting
- `font-lock-maximum-decoration' to one of:
- 0, nil : basic keyword highlighting -- the default;
- 1 : algebraic-mode highlighting;
- 2 : symbolic-mode highlighting;
- 3, 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 - variables automatically buffer-local:
- (setq 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
- (cons ; (VARIABLE . VALUE) ...
- 'font-lock-syntactic-keywords ; obsolete since 24.1! Use
- ; syntax-propertize-function
- ; instead!
- reduce-font-lock-syntactic-keywords)
- ))
- (reduce-font-lock-level) ; for font-lock menu
- (setq font-lock-multiline t) ; for comment statements
- ;; Additional support for comment statements:
- (add-to-list 'font-lock-extend-region-functions
- #'reduce-font-lock-extend-region-for-comment-statement)
- ;; 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:
- (when reduce-show-delim-mode-on
- (require 'reduce-delim)
- (reduce-show-delim-mode))
- (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))
- ;; This seems to be obsolete in Emacs 26!
- ;; 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-add-to-menubar))
- ;; ChangeLog support:
- (set (make-local-variable 'add-log-current-defun-function)
- 'reduce-current-proc)
- (run-hooks 'reduce-mode-hook))
- (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-add-to-menubar (&optional redraw)
- "Add \"Contents\" menu to menubar; if REDRAW force update."
- (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-add-to-menubar t) :active (not reduce-imenu-done)
- :help "Show an imenu of procedures and operators"]
- "--"
- ["Find Tag..." xref-find-definitions :active t
- :help "Find a 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 REDUCE files in this directory"]
- ["Tag Dir & Subdirs..." reduce-tagify-dir-recursively :active t
- :help "Tag all REDUCE files under this directory"]
- )
- ;; "-- 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-show-version :active t
- :help "Show the REDUCE Mode version"]
- ;; This seems to be obsolete in Emacs 26!
- ;; ["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-show-version ()
- "Echo version information for REDUCE Major Mode."
- (interactive)
- (message "REDUCE Major Mode version: %s" reduce-mode-version))
- ;;;; ************
- ;;;; Syntax table
- ;;;; ************
- (if reduce-mode-syntax-table ()
- (let ((table (make-syntax-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; if ARG indent whole statement rigidly.
- Indents to fixed style determined by current and previous non-blank line.
- Subsequent consecutive calls indent additionally by `reduce-indentation'
- unless `reduce-indent-line-conservative' is non-nil. 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))
- (not reduce-indent-line-conservative)) ; TS
- (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 "\\(?:^\\|\\s-+\\|[;$]\\)procedure\\s-+[![:alpha:]]"
- "Regexp for use in a SEARCH to find a procedure header.")
- (defsubst looking-at-procedure ()
- "Return t if text after point matches the start of a procedure."
- (looking-at ".*\\<procedure\\s-+[![:alpha:]]"))
- (defun reduce-calculate-indent-proc ()
- ;; "Handle comment lines, or if immediately following a procedure body
- ;; then return 0, otherwise return nil."
- "Return 0 if immediately following procedure body, else return nil."
- (save-excursion
- (beginning-of-line)
- (cond
- ;; ((looking-at "[ \t]*%")
- ;; (back-to-indentation) (reduce-comment-indent))
- ;; ((and (re-search-backward "[;$][ \t\n]*\n" nil t) ; ))
- ((progn
- ;; Find previous line that is neither blank nor a comment:
- (while (and (= (forward-line -1) 0)
- (looking-at "[ \t\f]*[%\n]")) )
- ;; Does it end with a separator?
- (and (looking-at ".*[;$][ \t]*[%\n]")
- ;; Is it the end of a procedure?
- (progn (end-of-line)
- (= (reduce-backward-statement 2) 0))
- (looking-at-procedure)))
- 0)
- )))
- (defun reduce-calculate-indent-this ()
- "Handle current line BEGINNING with a special token.
- For an opening token (`begin' or `<<') normally return the indentation of
- the previous non-blank line; for an intermediate token (`then' or `else')
- return the indentation of the beginning of the statement; for a
- closing token (`end' or `>>') return the indentation of the beginning
- of the construct; otherwise return nil."
- (save-excursion
- (back-to-indentation)
- (cond
- ;; *** Opening tokens *** :
- ((looking-at "[({ \t]*\\(\\<begin\\>\\|<<\\)")
- ;; Find previous non-blank line:
- (let ((closed (looking-at ".*\\(\\<end\\>\\|>>\\)")))
- (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 "\\<then\\>\\|\\<else\\>")
- (reduce-find-matching-if) (current-indentation))
- ;; *** Closing tokens *** :
- ((looking-at "\\<end\\>")
- (reduce-backward-block) (current-indentation))
- ((looking-at ">>")
- (reduce-backward-group) (current-indentation))
- ;; ((looking-at "#\\<endif\\>")
- ;; (reduce-backward-group) 0)
- ((looking-at "#\\(\\<define\\>\\|\\<if\\>\\|\\<\\elif\\>\\|\\<\\else\\>\\|\\<endif\\>\\)")
- 0))))
- (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 ".*\\<if\\>") ; what else?
- ; (* 2 reduce-indentation)
- ; reduce-indentation))
- ;; *** Tokens anywhere in the line *** :
- ((or (looking-at-procedure)
- (and (looking-at ".*\\<begin\\>")
- (not (looking-at ".*\\<end\\>")))
- (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
- ((looking-at "#\\<endif\\>")
- (current-indentation))
- ((looking-at "#\\(\\<define\\>\\|\\<if\\>\\|\\<\\elif\\>\\|\\<\\else\\>\\)")
- (current-indentation))
- ;; 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 ".*\\(\\<then\\>\\|\\<else\\>\\)[ \t]*[%\n]")
- ; (if (looking-at ".*\\<if\\>")
- ; ()
- ; (goto-char (match-beginning 1))
- ; (reduce-find-matching-if))
- ; (+ (current-indentation) reduce-indentation))
- ;; ... but the `if' must be embedded ...
- ((looking-at ".+\\<if\\>.*\\(\\<then\\>\\|\\<else\\>\\)[ \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 ()
- "Sub-function of `reduce-calculate-indent-prev'.
- 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 ".*\\(\\([,+-]\\|\\<or\\|\\<and\\)\\|[\;$]\\)[ \t]*[%\n]")
- (let* ((second_arg (match-string 2))
- (open (or second_arg
- (not (looking-at
- ".*\\(\\<end\\>\\|>>\\)[\;$][ \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
- ".*\\<procedure\\>\
- \\|\\<begin\\>\\|<<\
- \\|\\w+[ \t]*:[^=]")) ; ???
- (looking-at "\\w+[ \t]*:[^=]")) ; label
- (+ (current-column) reduce-indentation)
- (current-column)))))
- (defun reduce-unindent-line (arg)
- "Unindent current line; if ARG indent whole statement rigidly.
- 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 ()
- "Value of `comment-indent-function'."
- ;; 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 this and following ARG procedures.
- 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
- (save-excursion
- (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)
- "Interactively indent region; otherwise BEG-REGION to END-REGION.
- Interactively 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 match with `reduce-auto-indent-regexp' just 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
- (unless (<= (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)
- "Mark this and following ARG procedures.
- Put mark after next end of procedure, point at start of that procedure.
- Procedure ends AFTER any trailing white space.
- Return t is successful, nil otherwise."
- ;; 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'.
- "Narrow to this and following ARG procedures.
- Make text outside current procedure invisible.
- The procedure visible is the one that contains point or follows point."
- (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.")
- (defun reduce-up-block-or-group-maybe (found start)
- "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 reduce-forward-statement-found nil
- "Free variable bound in `reduce-forward-statement'")
- ;; Consider replacing with lexical binding.
- (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 "[;$]\\|>>\\|\\<end\\>\\|<<\\|\\<begin\\>\\|\\s(\\|\\s)")
- (start (point))
- reduce-forward-statement-found)
- ;; Skip an immediate closing bracket:
- (if (looking-at "[ \t\n]*\\s)") (goto-char (match-end 0)))
- (while (and (> arg 0) (reduce-forward-statement1 pattern))
- (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 reduce-forward-statement-found start)))
- (defun reduce-forward-statement1 (pattern)
- "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 reduce-forward-statement-found (point))
- (backward-char 2) (skip-chars-backward " \t\n") t)
- ((memq (preceding-char) '(?d ?D))
- (setq reduce-forward-statement-found (point))
- (backward-char 3) (skip-chars-backward " \t\n") t)
- ((= (preceding-char) ?<)
- (reduce-forward-group) (reduce-forward-statement1 pattern))
- ((memq (preceding-char) '(?n ?N))
- (reduce-forward-block) (reduce-forward-statement1 pattern))
- ((= (char-syntax (preceding-char)) ?\( )
- (backward-char) (forward-list) ; skip balanced brackets
- (reduce-forward-statement1 pattern))
- ((= (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 pattern)
- (backward-char) (skip-chars-backward " \t\n") t))
- (t t))
- )))
- (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 "[;$]\\|<<\\|\\<begin\\>\\|>>\\|\\<end\\>\\|\\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 "\\<end\\>")))
- ))))
- (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 pattern not-eof))
- (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 start)
- arg
- ))
- (defun reduce-backward-statement1 (pattern not-eof)
- "Move backward to next statement beginning.
- Return 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 pattern not-eof))
- ((memq (following-char) '(?e ?E)) ; end of block (or file)
- (if not-eof
- (progn (reduce-backward-block) (setq not-eof nil)))
- (reduce-backward-statement1 pattern not-eof))
- ((= (char-syntax (following-char)) ?\) )
- (forward-char) (backward-list) ; skip balanced brackets
- (reduce-backward-statement1 pattern not-eof))
- ((= (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 or ARG statements from point.
- 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 backwards up one level of block or group; if ARG move forwards.
- Move to beginning of nearest unpaired `begin' or `<<'.
- A universal argument means move forwards
- 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)
- "Sub-function of `reduce-up-block-or-group'."
- (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 "\\<begin\\>\\|<<\\|\\<end\\>\\|>>")
- (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 "\\<end\\>\\|>>\\|\\<begin\\>\\|<<")
- (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; if ARG move backwards.
- Move 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)
- "Sub-function of `reduce-down-block-or-group'."
- (let ((start (point)))
- (if
- (if (> arg 0)
- (and
- (reduce-re-search-forward "<<\\|\\<begin\\>\\|>>\\|\\<end\\>")
- (memq (preceding-char) '(?< ?n ?N)))
- (and
- (reduce-re-search-backward ">>\\|\\<end\\>\\|<<\\|\\<begin\\>")
- (memq (following-char) '(?> ?e ?E)))
- )
- t
- (goto-char start) nil)
- ))
- (defun reduce-prefix-numeric-value (arg)
- "Interpret universal ARG as -1, otherwise apply `prefix-numeric-value'."
- (if (and arg (listp arg)) -1 (prefix-numeric-value arg)))
- (defun reduce-forward-block ()
- "Move forwards to end of block containing point.
- Return t if successful; otherwise move as far as possible and return nil."
- (let (return)
- (while (and (setq return (reduce-re-search-forward
- "[^'\(]\\<end\\>\\|\\([^'\(]\\<begin\\>\\)" 'move))
- (match-beginning 1))
- (reduce-forward-block))
- return))
- ;; ***** Should reduce-backward-block also skip white space,which it
- ;; ***** seems to do? This is a problem for reduce-show-delim-mode.
- (defun reduce-backward-block ()
- "Move backwards to start of block containing point.
- Return t if successful; otherwise move as far as possible and return nil."
- (let (return)
- (while (and (setq return (reduce-re-search-backward
- "[^'\(]\\<begin\\>\\|\\([^'\(]\\<end\\>\\)" 'move))
- (match-beginning 1))
- (reduce-backward-block))
- return))
- (defun reduce-forward-group ()
- "Move forwards to end of group containing point.
- Return t if successful; otherwise 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 backwards to start of group containing point.
- Return t if successful; otherwise 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.
- ;;;; *****************************************************************
- (defun reduce-re-search-forward (regexp &optional MOVE)
- "Syntactic search forwards for REGEXP; if no match and MOVE then move to end.
- Skip comments, strings, escaped tokens, and quoted tokens other than `('.
- Return t if match found, nil otherwise."
- (let ((start (point))
- (pattern (concat regexp "\\|%\\|\\<comment\\>"))
- (move (if MOVE 'move t)))
- (if (reduce-re-search-forward1 pattern move)
- t
- (if (not MOVE) (goto-char start))
- nil)
- ))
- (defun reduce-re-search-forward1 (pattern move)
- "Skip strings."
- (if (reduce-re-search-forward2 pattern move)
- (if (reduce-in-string) ; try again!
- (reduce-re-search-forward1 pattern move)
- t)
- nil))
- (defun reduce-re-search-forward2 (pattern move)
- "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 pattern move)) ; search again
- ((= (preceding-char) ?%) ; skip % comment
- (forward-line 1)
- (reduce-re-search-forward2 pattern move)) ; 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 pattern move)) ; search again
- (t (store-match-data match-data) t))
- )))
- (defun reduce-re-search-backward (regexp &optional MOVE)
- "Syntactic search backwards for REGEXP else if MOVE then move to start.
- Skip REDUCE comments and strings. Return t if match found, nil otherwise."
- (let ((start (point))
- (move (if MOVE 'move t)))
- (if (reduce-re-search-backward1 regexp move)
- t
- (if (not MOVE) (goto-char start))
- nil)
- ))
- (defun reduce-re-search-backward1 (regexp move)
- "Sub-function of `reduce-re-search-backward'.
- Skip strings backwards."
- (if (reduce-re-search-backward2 regexp move)
- (if (reduce-in-string) ; try again!
- (reduce-re-search-backward1 regexp move)
- t)
- nil))
- (defun reduce-re-search-backward2 (regexp move)
- "Skip escaped, quoted or commented text backwards."
- (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 regexp move) ; 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)) posn
- (pattern "[^!][;$]\\|\\<comment\\>"))
- (cond
- ((setq posn (reduce-back-to-comment-statement-start pattern))
- ;; in comment statement -- go to its true beginning
- (goto-char posn) t)
- (t (goto-char start) nil)) ; not in comment statement
- )))
- (defun reduce-back-to-comment-statement-start (pattern)
- "Move backwards to the nearest `comment' keyword or separator.
- If it is `comment' then return its start position; otherwise return nil."
- (while (and (re-search-backward pattern nil 'move)
- (reduce-back-to-percent-comment-start)))
- (if (looking-at "comment") (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 ()
- "Return 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 region, from BEG-REGION to END-REGION.
- With interactive ARG, comment if non-negative, uncomment if null
- or negative (cf. minor modes).
- Put `reduce-comment-region-string' 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-string)
- (while (and (= (forward-line 1) 0)
- (< (point) end-region-mark))
- (insert reduce-comment-region-string)))
- )
- (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 this procedure.
- This procedure is the one that ends 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 %-comment or comment statement paragraph at or after point.
- If JUSTIFY is non-nil (interactively, with prefix argument), justify as well."
- (interactive "*P")
- (save-excursion
- (let (first)
- ;; If in empty line then move to start of next non-empty line:
- (beginning-of-line)
- (while (and (looking-at "[ \t]*$")
- (= (forward-line) 0)
- (setq first (point))))
- ;; Is point within a comment statement?
- (if (or (and (looking-at "[ \t]*comment")
- (setq first (point)))
- ;; (See `reduce-font-lock-extend-region-for-comment-statement'.)
- (save-excursion
- (and (re-search-backward "\\(comment\\)\\|\\(;\\)" nil t)
- (match-beginning 1)
- (setq first (point)))))
- ;; Yes -- use normal text-mode fill, but only within the
- ;; comment statement, which might be within code:
- (save-restriction
- (narrow-to-region first (save-excursion (search-forward ";")))
- (fill-paragraph justify))
- ;;No...
- ;; 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'; if ELSE then include `else'.
- Position point after `if'.
- 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; if NOSPLIT then on same line.
- 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; if NOSPLIT then on same line.
- 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, ignoring ARG."
- (reduce-insert-if-then))
- (defun reduce-expand-if-then-else (&optional arg)
- "Insert `if ... then ... else' and position point after `if', ignoring ARG."
- (reduce-insert-if-then 'else))
- ;;;; **********************************
- ;;;; Balanced structure (sexp) commands
- ;;;; **********************************
- (defun reduce-forward-sexp (&optional arg)
- "Move forward across one, or ARG, balanced expression(s).
- 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, or ARG, balanced expression(s).
- 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)))))
- )))
- ;;;; *****************************
- ;;;; 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.
- Do this only 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).
- ;;;; ****************************************************
- ;; Note that Font Lock Mode is documented in the ELisp manual under
- ;; Major and Minor Modes. Fontification is performed syntactically
- ;; (e.g. comments) and THEN by keyword.
- (defconst reduce-identifier-regexp
- "\\(?:[a-z]\\|!.\\)\
- \\(?:\\w\\|\\s_\\|!.\\)*"
- ;; NB: digits have word syntax
- "Regular expression matching a REDUCE identifier.")
- (defconst reduce-infix-regexp
- "where\\|when\\|or\\|and\\|member\\|memq\\|neq\\|eq")
- (defconst reduce-keyword-regexp
- (mapconcat 'identity
- (list
- "begin" "return" "module" "end\\(?:module\\)?"
- "if" "then" "else"
- "while" "do" "repeat" "until"
- "collect" "join" "conc" "sum" "product"
- "for\\(?:\\s-*\\(?:all\\|each\\)\\)?" "step"
- "in" "on" "off" "write"
- "let" "clearrules"
- "clear" "pause"
- "assert_install" "assert_install_all"
- "assert_uninstall" "assert_uninstall_all"
- "assert"
- ;; Lisp keywords used frequently in REDUCE:
- "lambda" "function"
- ;; "put" "flag" "remprop" "remflag"
- reduce-infix-regexp)
- "\\|")
- "Regular expression matching a REDUCE keyword.")
- ;(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)
- ;; Assertion and preprocessor rules based on code by Thomas Sturm.
- ;; A good test file for all assertion rules is "redlog/cl/clqe.red".
- ;; A constant with a name of the form `font-lock-rule' becomes an
- ;; element of the list assigned by `reduce-mode' to
- ;; `font-lock-keywords', which directly controls search-based
- ;; fontification, whereas a constant with a name of the form
- ;; `font-lock-rules' (plural) below becomes appended to or spliced
- ;; into the list assigned to `font-lock-keywords'.
- (defconst reduce-font-lock-asserted-type-rule
- `("procedure"
- ;; anchored-highlighter to handle the rest of the statement:
- ,(concat "[^!]:\\s-*\\(" reduce-identifier-regexp "\\)") nil nil
- (1 font-lock-type-face t))
- "A rule specifying how to highlight types of procedure
- arguments and return values.")
- (defconst reduce-font-lock-assert-declare/struct-rules
- `((,(concat
- "\\(declare\\)\\s-+"
- "\\(" reduce-identifier-regexp "\\)\\s-*:")
- (1 font-lock-keyword-face)
- (2 font-lock-function-name-face)
- ;; anchored-highlighter to handle the rest of the statement:
- (,reduce-identifier-regexp nil nil (0 font-lock-type-face)))
- (,(concat
- "\\(struct\\)\\s-+"
- "\\(" reduce-identifier-regexp "\\)"
- ;; optionally followed by...
- "\\(?:\\s-+\\(\\(?:checked\\|asserted\\)\\s-+by\\)\\s-+"
- "\\(" reduce-identifier-regexp "\\)\\)?")
- (1 font-lock-keyword-face)
- (2 font-lock-type-face)
- (3 font-lock-keyword-face t)
- (4 font-lock-function-name-face)))
- "Rules specifying how to highlight `declare' and `struct'
- statements, as used in `redlog'.")
- (defconst reduce-font-lock-preprocessor-rules
- `((,(concat
- "\\(#define\\)\\s-+"
- "\\(" reduce-identifier-regexp "\\)\\s-+"
- "\\(" reduce-identifier-regexp "\\)")
- (1 font-lock-preprocessor-face)
- (2 font-lock-variable-name-face)
- (3 font-lock-variable-name-face))
- ("\\(#if\\)\\s-+\\(.*\\)"
- (1 font-lock-preprocessor-face)
- (2 font-lock-default-face))
- ("\\(#elif\\)\\s-+\\(.*\\)"
- (1 font-lock-preprocessor-face)
- (2 font-lock-default-face))
- ("\\(#else\\)"
- (1 font-lock-preprocessor-face))
- ("\\(#endif\\)"
- (1 font-lock-preprocessor-face)))
- "Rules specifying how to highlight preprocessor #-directives.")
- (defconst reduce-font-lock-keywords-0
- `("reduce-font-lock-keywords-0" ; TEMPORARY label for debugging
- (reduce-font-lock-match-comment-statement
- . (1 font-lock-comment-face t))
- ;; Main keywords:
- (,(concat
- ;; Ignore !keyword, _keyword, 'keyword, #keyword:
- "\\(?:^\\|[^!_'#]\\)"
- "\\<\\(" reduce-keyword-regexp "\\)\\>"
- ;; Ignore composite identifiers:
- "[^!_#]")
- (1 font-lock-keyword-face)
- ;; Handle consecutive keywords:
- (,(concat "\\<\\(" reduce-keyword-regexp "\\)\\>[^!_#]")
- nil nil (1 font-lock-keyword-face)))
- ;; Group delimiters and references:
- "<<\\|>>\\|\\<\\go\\(?:\\s-*to\\)?\\>"
- ;; ????? Handle goto label and label : specially?
- ;; Procedure declarations:
- (,(concat "\\<\\(procedure\\)\\s-+"
- "\\(" reduce-identifier-regexp "\\)")
- (1 font-lock-keyword-face)
- (2 font-lock-function-name-face))
-
- ;; Type declarations:
- ("\\(?:^\\|[^_]\\)\\<\\(algebraic\\|symbolic\\|lisp\\|operator\\|scalar\\|integer\\|real\\|linear\\)\\>[^!_]"
- (1 font-lock-type-face))
- ,reduce-font-lock-asserted-type-rule
- ,@reduce-font-lock-assert-declare/struct-rules
- ,@reduce-font-lock-preprocessor-rules)
- "Default minimal REDUCE fontification rules.")
- (defconst reduce-font-lock-keywords-basic
- (list
- '(reduce-font-lock-match-comment-statement
- . (1 font-lock-comment-face t))
- ;; 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)
- '(2 font-lock-function-name-face) ; no highlighting in comments; TS
- ;; 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
- (append (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))
- )
- reduce-font-lock-asserted-type-rule)
- reduce-font-lock-preprocessor-rules)
- "More algebraic-mode REDUCE fontification sub-rules.")
- (defconst reduce-font-lock-keywords-symbolic
- (append (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\\|asserted\\|inline\\)\\>"
- ;; Ignore composite identifiers:
- "[^!_]"
- )
- '(2 font-lock-type-face))
- reduce-font-lock-asserted-type-rule)
- reduce-font-lock-assert-declare/struct-rules
- reduce-font-lock-preprocessor-rules)
- "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 nil t))
- ;;; 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
- `("reduce-font-lock-keywords-1" ; TEMPORARY label for debugging
- ,@reduce-font-lock-keywords-basic
- ,@reduce-font-lock-keywords-algebraic)
- "Standard algebraic-mode REDUCE fontification rules.")
- (defconst reduce-font-lock-keywords-2
- `("reduce-font-lock-keywords-2" ; TEMPORARY label for debugging
- ,@reduce-font-lock-keywords-basic
- ,@reduce-font-lock-keywords-symbolic)
- "Standard symbolic-mode REDUCE fontification rules.")
- (defconst reduce-font-lock-keywords-3
- `("reduce-font-lock-keywords-3" ; TEMPORARY label for debugging
- ,@reduce-font-lock-keywords-basic
- ,@reduce-font-lock-keywords-algebraic
- ,@reduce-font-lock-keywords-symbolic
- ,@reduce-font-lock-keywords-full)
- "Full REDUCE fontification rules.")
- ;; Support functions for comment statements. Being normally
- ;; multi-line, they require the support of the function
- ;; `reduce-font-lock-extend-region-for-comment-statement'.
- (defun reduce-font-lock-match-comment-statement (limit)
- "Search for a comment statement between point and LIMIT.
- If successful, return non-nil and set the match data to describe
- the match; otherwise return nil."
- ;; Fontification will call this function repeatedly with the same
- ;; limit, and with point where the previous invocation left it,
- ;; until it fails. On failure, there is no need to reset point in
- ;; any particular way.
- (when
- (search-forward-regexp "\\(\\<comment\\>[^;$]*\\)[;$]" limit t)
- ;; If successful, check that "comment" is preceded by beginning of
- ;; buffer or a terminator, possibly with white space and/or %
- ;; comments in between:
- (save-excursion
- (goto-char (match-beginning 0))
- (save-match-data
- (looking-back "\\(?:\\`\\|[;$]\\)\
- \\(?:\\s-*\\(?:%.*\\)?\n\\)*\\s-*" nil)))))
- (defvar font-lock-beg)
- (defvar font-lock-end)
- (defun reduce-font-lock-extend-region-for-comment-statement ()
- "Extend font-lock region if necessary to include all of any
- comment statements that it intersects, and if so return non-nil.
- This function is prepended to `font-lock-extend-region-functions'."
- (let (new-beg new-end)
- (goto-char font-lock-beg)
- ;; Is font-lock-beg within a comment?
- (save-excursion
- (if (and (re-search-backward "\\(comment\\)\\|\\([;$]\\)" nil t)
- (match-beginning 1))
- (setq new-beg (point))))
- (when (or new-beg
- ;; Or does a comment start in the font-lock region?
- (search-forward "comment" font-lock-end t))
- ;; If either of the above then...
- (search-forward-regexp "[;$]" nil 1) ; if un-terminated move to EOB
- ;; Do multiple comments start in the font-lock region?
- (while (and (< (point) font-lock-end)
- (search-forward "comment" font-lock-end t))
- (search-forward-regexp "[;$]" nil 1)) ; if un-terminated move to EOB
- (if (> (point) font-lock-end)
- (setq new-end (point))))
- ;; Temporary message for testing:
- ;; (message "reduce-font-lock-extend-region-for-comment-statement: %s --> %s, %s --> %s"
- ;; font-lock-beg new-beg font-lock-end new-end)
- ;; Return non-nil if font-lock region adjusted:
- (or (if new-beg (setq font-lock-beg new-beg))
- (if new-end (setq font-lock-end new-end)))))
- ;; Provide a REDUCE font-lock menu, based originally on
- ;; font-lock-menu.el by Simon Marshall <simon@gnu.ai.mit.edu>.
- (defconst reduce-font-lock-level-max
- (1- (length reduce-font-lock-keywords))
- "Maximum REDUCE font-lock level.")
- (defvar reduce-font-lock-level)
- (defun reduce-font-lock-level ()
- "Establish the buffer-local variable `reduce-font-lock-level'.
- It is used only to control the font-lock menu and is set for each
- new buffer from the value of `font-lock-maximum-decoration',
- which must be done in `reduce-mode'."
- (set (make-local-variable 'reduce-font-lock-level)
- ;; The value of `font-lock-maximum-decoration' may be an alist,
- ;; non-negative integer, t (meaning max) or nil (meaning 0).
- (let (level)
- (if (consp font-lock-maximum-decoration) ; alist
- (if (setq level (or (assoc 'reduce-mode font-lock-maximum-decoration)
- (assoc t font-lock-maximum-decoration)))
- (setq level (cdr level)))
- (setq level font-lock-maximum-decoration)) ; not alist
- ;; level = integer, t or nil
- (cond ((numberp level)
- (cond ((< level 0) 0)
- ((> level reduce-font-lock-level-max)
- reduce-font-lock-level-max)
- (t level)))
- ((eq level t) reduce-font-lock-level-max) ; t means max
- (t 0))))) ; nil means 0
- (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 (3)" (reduce-font-lock-change 3)
- :style radio :selected (eq reduce-font-lock-level 3) :active t]
- ["Symbolic (2)" (reduce-font-lock-change 2)
- :style radio :selected (eq reduce-font-lock-level 2) :active t]
- ["Algebraic (1)" (reduce-font-lock-change 1)
- :style radio :selected (eq reduce-font-lock-level 1) :active t]
- ["Minimum (0)" (reduce-font-lock-change 0)
- :style radio :selected (eq reduce-font-lock-level 0) :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)
- "Re-fontify at the specified LEVEL."
- ;; Do messages need to be saved in the messages buffer?
- ;; If interactive then needs to be more robust.
- ;; (interactive)
- (let ((name (nth level reduce-font-lock-level-names)))
- (if (eq reduce-font-lock-level level)
- (message "REDUCE Font Lock decoration unchanged (level %d : %s)."
- level name)
- (let ((font-lock-maximum-decoration level))
- (font-lock-refresh-defaults))
- (setq reduce-font-lock-level level)
- (message "REDUCE Font Lock decoration set to level %d : %s."
- level name))))
- ;; (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
- ;;;; *****************************************
- (defcustom reduce-etags-directory invocation-directory
- "Directory containing the etags program, or nil if it is in path.
- If non-nil the string must end with /."
- :package-version '(reduce-mode . "1.54")
- :type '(choice (directory :tag "Etags program directory")
- (const :tag "Etags is in exec path" nil))
- :group 'reduce-interface)
- (defun reduce-tagify-dir (dir)
- "Generate a REDUCE TAGS file for `*.red' files in directory DIR.
- TAGS goes in DIR, which by default is the current directory."
- (interactive
- (list (read-directory-name
- "Tag files in dir: " ; PROMPT
- nil ; DIR (default cwd)
- nil ; DEFAULT-DIRNAME
- t))) ; MUSTMATCH
- (setq dir (directory-file-name (expand-file-name dir)))
- (reduce--tagify
- dir (directory-files dir nil "\\.red\\'")
- (message "Tagging files `%s/*.red'..." dir)))
- (defun reduce--tagify (dir files msg)
- "Generate a REDUCE TAGS file in directory DIR for specified FILES.
- FILES must be a list of filenames, which can be relative to DIR.
- MSG is the message displayed when the tagging process started."
- (let* ((default-directory dir)
- (value
- (apply
- #'call-process ; creates a synchronous process
- (concat reduce-etags-directory "etags") ; program
- nil ; infile
- "*rtags-log*" ; destination
- nil ; display
- "--lang=none" ; args ...
- "--regex=/[^%]*procedure[ \\t]+\\([^ \\t\(;$]+\\)/\\1/i"
- files))) ; LIST of filenames
- (if (eq value 0)
- (message "%sdone" msg)
- (message "etags failed with status: %s" value))))
- (defun reduce-tagify-dir-recursively (dir)
- "Generate a REDUCE TAGS file for all `*.red' files under directory DIR.
- TAGS goes in DIR, which by default is the current directory."
- (interactive
- (list (read-directory-name
- "Tag all files under dir: " ; PROMPT
- nil ; DIR (default cwd)
- nil ; DEFAULT-DIRNAME
- t))) ; MUSTMATCH
- (setq dir (directory-file-name (expand-file-name dir)))
- (let ((reduce--tagify-root dir))
- ;; reduce--tagify-root required by `reduce--directory-files-recursively'.
- (reduce--tagify
- dir (reduce--directory-files-recursively dir)
- (message "Tagging all files `%s/...*.red'..." dir))))
- (defvar reduce--tagify-root)
- (defun reduce--directory-files-recursively (dir)
- "Return a list of all `*.red' files under DIR.
- This function works recursively. Files are returned in \"depth first\"
- order, and files from each directory are sorted in alphabetical order.
- Each file name appears in the returned list relative to directory
- `reduce--tagify-root', assumed to be bound locally in the caller."
- ;; Modelled on `directory-files-recursively'.
- (let (result
- files
- ;; When DIR is "/", remote file names like "/method:" could
- ;; also be offered. We shall suppress them.
- (tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir)))))
- (dolist (file (sort (file-name-all-completions "" dir) 'string<))
- (unless (member file '("./" "../"))
- (if (directory-name-p file)
- (let* ((leaf (substring file 0 -1))
- (full-file (expand-file-name leaf dir)))
- (setq result
- (nconc result (reduce--directory-files-recursively
- full-file))))
- (when (string-match "\\.red\\'" file)
- (push (file-relative-name
- (expand-file-name file dir)
- reduce--tagify-root)
- files)))))
- (nconc result (nreverse files))))
- ;;;; **********************************************************************
- ;;; 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
|