Mercurial > hg > xemacs-beta
annotate lisp/easy-mmode.el @ 4810:6ee5e50a8772
Add a compiler macro for #'map, where CL-TYPE is constant and understood.
2010-01-07 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (map):
Add a compiler macro for this function, for cases where CL-TYPE is
constant and understood.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 07 Jan 2010 21:50:39 +0000 |
| parents | e29fcfd8df5f |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 2548 | 1 ;;; easy-mmode.el --- easy definition for major and minor modes |
| 2 | |
| 3 ;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc. | |
| 4 | |
| 5 ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> | |
| 6 ;; Maintainer: Stefan Monnier <monnier@gnu.org> | |
| 7 | |
| 8 ;; Keywords: extensions lisp | |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify | |
| 13 ;; it under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, | |
| 18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 20 ;; GNU General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 23 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 27 ;;; Synched up with: GNU Emacs 21.3. | |
| 28 | |
| 29 ;;; Commentary: | |
| 30 | |
| 31 ;; Minor modes are useful and common. This package makes defining a | |
| 32 ;; minor mode easy, by focusing on the writing of the minor mode | |
| 33 ;; functionalities themselves. Moreover, this package enforces a | |
| 34 ;; conventional naming of user interface primitives, making things | |
| 35 ;; natural for the minor-mode end-users. | |
| 36 | |
| 37 ;; For each mode, easy-mmode defines the following: | |
| 38 ;; <mode> : The minor mode predicate. A buffer-local variable. | |
| 39 ;; <mode>-map : The keymap possibly associated to <mode>. | |
| 40 ;; <mode>-hook,<mode>-on-hook,<mode>-off-hook and <mode>-mode: | |
| 41 ;; see `define-minor-mode' documentation | |
| 42 ;; | |
| 43 ;; eval | |
| 44 ;; (pp (macroexpand '(define-minor-mode <your-mode> <doc>))) | |
| 45 ;; to check the result before using it. | |
| 46 | |
| 47 ;; The order in which minor modes are installed is important. Keymap | |
| 48 ;; lookup proceeds down minor-mode-map-alist, and the order there | |
| 49 ;; tends to be the reverse of the order in which the modes were | |
| 50 ;; installed. Perhaps there should be a feature to let you specify | |
| 51 ;; orderings. | |
| 52 | |
| 53 ;; Additionally to `define-minor-mode', the package provides convenient | |
| 54 ;; ways to define keymaps, and other helper functions for major and minor | |
| 55 ;; modes. | |
| 56 | |
| 57 ;;; Code: | |
| 58 | |
| 59 (eval-when-compile (require 'cl)) | |
| 60 | |
| 61 ;;; This file uses two functions that did not exist in some versions of | |
| 62 ;;; XEmacs: propertize and replace-regexp-in-string. We provide these | |
| 63 ;;; functions here for such XEmacsen. | |
| 64 ;;; | |
| 65 ;;; FIXME: These function definitions should go into the future or | |
| 66 ;;; forward-compat package, once that package exists. | |
| 67 | |
| 68 ;; XEmacs <= 21.4 does not have propertize, but XEmacs >= 21.5 dumps it (it is | |
| 69 ;; defined in subr.el). Therefore, it is either defined regardless of what | |
| 70 ;; has been loaded already, or it won't be defined regardless of what is | |
| 71 ;; loaded. | |
| 72 (if (not (fboundp 'propertize)) | |
| 73 (defun propertize (string &rest properties) | |
| 74 "Return a copy of STRING with text properties added. | |
| 75 First argument is the string to copy. | |
| 76 Remaining arguments form a sequence of PROPERTY VALUE pairs for text | |
| 77 properties to add to the result." | |
| 78 (let ((str (copy-sequence string))) | |
| 79 (add-text-properties 0 (length str) | |
| 80 properties | |
| 81 str) | |
| 82 str))) | |
| 83 | |
| 84 ;; XEmacs <= 21.4 does not have replace-regexp-in-string, but XEmacs >= 21.5 | |
| 85 ;; dumps it (it is defined in subr.el). Therefore, it is either defined | |
| 86 ;; regardless of what has been loaded already, or it won't be defined | |
| 87 ;; regardless of what is loaded. | |
| 88 (if (not (fboundp 'replace-regexp-in-string)) | |
| 89 (defun replace-regexp-in-string (regexp rep string &optional | |
| 90 fixedcase literal subexp start) | |
| 91 "Replace all matches for REGEXP with REP in STRING. | |
| 92 | |
| 93 Return a new string containing the replacements. | |
| 94 | |
| 95 Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the | |
| 96 arguments with the same names of function `replace-match'. If START | |
| 97 is non-nil, start replacements at that index in STRING. | |
| 98 | |
| 99 REP is either a string used as the NEWTEXT arg of `replace-match' or a | |
| 100 function. If it is a function it is applied to each match to generate | |
| 101 the replacement passed to `replace-match'; the match-data at this | |
| 102 point are such that match 0 is the function's argument. | |
| 103 | |
| 104 To replace only the first match (if any), make REGEXP match up to \\' | |
| 105 and replace a sub-expression, e.g. | |
| 106 (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1) | |
| 107 => \" bar foo\" | |
| 108 " | |
| 109 (let ((l (length string)) | |
| 110 (start (or start 0)) | |
| 111 matches str mb me) | |
| 112 (save-match-data | |
| 113 (while (and (< start l) (string-match regexp string start)) | |
| 114 (setq mb (match-beginning 0) | |
| 115 me (match-end 0)) | |
| 116 ;; If we matched the empty string, make sure we advance by one char | |
| 117 (when (= me mb) (setq me (min l (1+ mb)))) | |
| 118 ;; Generate a replacement for the matched substring. | |
| 119 ;; Operate only on the substring to minimize string consing. | |
| 120 ;; Set up match data for the substring for replacement; | |
| 121 ;; presumably this is likely to be faster than munging the | |
| 122 ;; match data directly in Lisp. | |
| 123 (string-match regexp (setq str (substring string mb me))) | |
| 124 (setq matches | |
| 125 (cons (replace-match (if (stringp rep) | |
| 126 rep | |
| 127 (funcall rep (match-string 0 str))) | |
| 128 fixedcase literal str subexp) | |
| 129 (cons (substring string start mb) ; unmatched prefix | |
| 130 matches))) | |
| 131 (setq start me)) | |
| 132 ;; Reconstruct a string from the pieces. | |
| 133 (setq matches (cons (substring string start l) matches)) ; leftover | |
| 134 (apply #'concat (nreverse matches)))))) | |
| 135 | |
| 136 | |
| 137 (defun easy-mmode-pretty-mode-name (mode &optional lighter) | |
| 138 "Turn the symbol MODE into a string intended for the user. | |
| 139 If provided LIGHTER will be used to help choose capitalization." | |
| 140 (let* ((case-fold-search t) | |
| 141 (name (concat (replace-regexp-in-string | |
| 142 "-Minor" " minor" | |
| 143 (capitalize (replace-regexp-in-string | |
| 144 "-mode\\'" "" (symbol-name mode)))) | |
| 145 " mode"))) | |
| 146 (if (not (stringp lighter)) name | |
| 147 (setq lighter | |
| 148 (replace-regexp-in-string "\\`\\s-+\\|\\-s+\\'" "" lighter)) | |
| 149 (replace-regexp-in-string lighter lighter name t t)))) | |
| 150 | |
| 151 ;; XEmacs change: add -on-hook, -off-hook, and macro parameter documentation. | |
| 152 ;;;###no-autoload | |
| 153 (defalias 'easy-mmode-define-minor-mode 'define-minor-mode) | |
| 154 ;;;###no-autoload | |
| 155 (defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body) | |
| 156 "Define a new minor mode MODE. | |
| 157 This function defines the associated control variable MODE, keymap MODE-map, | |
| 158 toggle command MODE, and hook MODE-hook. | |
| 159 | |
| 160 DOC is the documentation for the mode toggle command. | |
| 161 Optional INIT-VALUE is the initial value of the mode's variable. | |
| 162 Optional LIGHTER is displayed in the modeline when the mode is on. | |
| 163 Optional KEYMAP is the default (defvar) keymap bound to the mode keymap. | |
| 164 If it is a list, it is passed to `easy-mmode-define-keymap' | |
| 165 in order to build a valid keymap. It's generally better to use | |
| 166 a separate MODE-map variable than to use this argument. | |
| 167 The above three arguments can be skipped if keyword arguments are | |
| 168 used (see below). | |
| 169 | |
| 170 BODY contains code that will be executed each time the mode is (de)activated. | |
| 171 It will be executed after any toggling but before running the hooks. | |
| 172 Before the actual body code, you can write | |
| 173 keyword arguments (alternating keywords and values). | |
| 174 These following keyword arguments are supported: | |
| 175 :group GROUP Custom group name to use in all generated `defcustom' forms. | |
| 176 :global GLOBAL If non-nil specifies that the minor mode is not meant to be | |
| 177 buffer-local, so don't make the variable MODE buffer-local. | |
| 178 By default, the mode is buffer-local. | |
| 179 :init-value VAL Same as the INIT-VALUE argument. | |
| 180 :lighter SPEC Same as the LIGHTER argument. | |
| 181 :require SYM Same as in `defcustom'. | |
| 182 | |
| 183 For backwards compatibility, these hooks are run each time the mode is | |
| 184 \(de)activated. When the mode is toggled, MODE-hook is always run before the | |
| 185 other hook. | |
| 186 MODE-hook: run if the mode is toggled. | |
| 187 MODE-on-hook: run if the mode is activated. | |
| 188 MODE-off-hook: run if the mode is deactivated. | |
| 189 | |
| 190 \(defmacro easy-mmode-define-minor-mode | |
| 191 (MODE DOC &optional INIT-VALUE LIGHTER KEYMAP &rest BODY)...\) | |
| 192 | |
| 193 For example, you could write | |
| 194 (define-minor-mode foo-mode \"If enabled, foo on you!\" | |
| 195 nil \"Foo \" foo-keymap | |
| 196 :require 'foo :global t :group 'inconvenience | |
| 197 ...BODY CODE...)" | |
| 198 | |
| 199 ;; Allow skipping the first three args. | |
| 200 (cond | |
| 201 ((keywordp init-value) | |
| 202 (setq body (list* init-value lighter keymap body) | |
| 203 init-value nil lighter nil keymap nil)) | |
| 204 ((keywordp lighter) | |
| 205 (setq body (list* lighter keymap body) lighter nil keymap nil)) | |
| 206 ((keywordp keymap) (push keymap body) (setq keymap nil))) | |
| 207 | |
| 208 (let* ((mode-name (symbol-name mode)) | |
| 209 (pretty-name (easy-mmode-pretty-mode-name mode lighter)) | |
| 210 (globalp nil) | |
| 211 (group nil) | |
| 212 (extra-args nil) | |
| 213 (require t) | |
| 214 (keymap-sym (if (and keymap (symbolp keymap)) keymap | |
| 215 (intern (concat mode-name "-map")))) | |
| 216 (hook (intern (concat mode-name "-hook"))) | |
| 217 (hook-on (intern (concat mode-name "-on-hook"))) | |
| 218 (hook-off (intern (concat mode-name "-off-hook")))) | |
| 219 | |
| 220 ;; Check keys. | |
| 221 (while (keywordp (car body)) | |
| 222 (case (pop body) | |
| 223 (:init-value (setq init-value (pop body))) | |
| 224 (:lighter (setq lighter (pop body))) | |
| 225 (:global (setq globalp (pop body))) | |
| 226 (:extra-args (setq extra-args (pop body))) | |
| 227 (:group (setq group (nconc group (list :group (pop body))))) | |
| 228 (:require (setq require (pop body))) | |
| 229 (t (pop body)))) | |
| 230 | |
| 231 (unless group | |
| 232 ;; We might as well provide a best-guess default group. | |
| 233 (setq group | |
| 234 `(:group ',(or (custom-current-group) | |
| 235 (intern (replace-regexp-in-string | |
| 236 "-mode\\'" "" mode-name)))))) | |
| 237 ;; Add default properties to LIGHTER. | |
| 238 ;; #### FSF comments this out in 21.3. | |
| 239 ; (unless (or (not (stringp lighter)) | |
| 240 ; (get-text-property 0 'local-map lighter) | |
| 241 ; (get-text-property 0 'keymap lighter)) | |
| 242 ; (setq lighter | |
| 243 ; (propertize lighter | |
| 244 ; 'local-map modeline-minor-mode-map ; XEmacs change | |
| 245 ; 'help-echo "mouse-3: minor mode menu"))) | |
| 246 | |
| 247 `(progn | |
| 248 ;; Define the variable to enable or disable the mode. | |
| 249 ,(if (not globalp) | |
| 250 `(progn | |
| 251 (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. | |
| 252 Use the command `%s' to change this variable." pretty-name mode)) | |
| 253 (make-variable-buffer-local ',mode)) | |
| 254 | |
| 255 (let ((curfile (or (and (boundp 'byte-compile-current-file) | |
| 256 byte-compile-current-file) | |
| 257 load-file-name))) | |
| 258 `(defcustom ,mode ,init-value | |
| 259 ,(format "Non-nil if %s is enabled. | |
| 260 See the command `%s' for a description of this minor-mode. | |
| 261 Setting this variable directly does not take effect; | |
| 262 use either \\[customize] or the function `%s'." | |
| 263 pretty-name mode mode) | |
| 264 :set (lambda (symbol value) (funcall symbol (or value 0))) | |
| 265 :initialize 'custom-initialize-default | |
| 266 ,@group | |
| 267 :type 'boolean | |
| 268 ,@(cond | |
| 269 ((not (and curfile require)) nil) | |
| 270 ((not (eq require t)) `(:require ,require)) | |
| 271 (t `(:require | |
| 272 ',(intern (file-name-nondirectory | |
| 273 (file-name-sans-extension curfile))))))))) | |
| 274 | |
| 275 ;; The actual function. | |
| 276 (defun ,mode (&optional arg ,@extra-args) | |
| 277 ,(or doc | |
| 278 (format (concat "Toggle %s on or off. | |
| 279 Interactively, with no prefix argument, toggle the mode. | |
| 280 With universal prefix ARG turn mode on. | |
| 281 With zero or negative ARG turn mode off. | |
| 282 \\{%s}") pretty-name keymap-sym)) | |
| 283 ;; Use `toggle' rather than (if ,mode 0 1) so that using | |
| 284 ;; repeat-command still does the toggling correctly. | |
| 285 (interactive (list (or current-prefix-arg 'toggle))) | |
| 286 ;; XEmacs addition: save the old mode | |
| 287 (let ((old-mode ,mode)) | |
| 288 (setq ,mode | |
| 289 (cond | |
| 290 ((eq arg 'toggle) (not ,mode)) | |
| 291 (arg (or (listp arg);; XEmacs addition: C-u alone | |
| 292 (> (prefix-numeric-value arg) 0))) | |
| 293 (t | |
| 294 (if (null ,mode) t | |
| 295 (message | |
| 296 "Toggling %s off; better pass an explicit argument." | |
| 297 ',mode) | |
| 298 nil)))) | |
| 299 ,@body | |
| 300 ;; The on/off hooks are here for backward compatibility only. | |
| 301 ;; The on/off hooks are here for backward compatibility only. | |
| 302 ;; XEmacs change: check mode before running hooks | |
| 303 (and ,hook | |
| 304 (not (equal old-mode ,mode)) | |
| 305 (run-hooks ',hook)) | |
| 306 (and ,hook-on | |
| 307 ,mode | |
| 308 (run-hooks ',hook-on)) | |
| 309 (and ,hook-off | |
| 310 (not ,mode) | |
| 311 (run-hooks ',hook-off))) | |
| 312 (if (interactive-p) | |
| 313 (progn | |
| 314 ,(if globalp `(customize-mark-as-set ',mode)) | |
| 315 (message ,(format "%s %%sabled" pretty-name) | |
| 316 (if ,mode "en" "dis")))) | |
| 317 (force-mode-line-update) | |
| 318 ;; Return the new setting. | |
| 319 ,mode) | |
| 320 | |
| 321 ;; Autoloading an easy-mmode-define-minor-mode autoloads | |
| 322 ;; everything up-to-here. | |
| 323 ;; | |
| 324 ;; XEmacs change: XEmacs does not support :autoload-end. On the other | |
| 325 ;; hand, I don't see why we need to support it. An autoload cookie | |
| 326 ;; just before a (define-minor-mode foo) form will generate an autoload | |
| 327 ;; form for the file with name foo. But that's exactly right, since | |
| 328 ;; the defun created just above here has the name foo. There are no | |
| 329 ;; other top-level forms created above here by the macro, so we're done. | |
| 330 ;; | |
| 331 ;;:autoload-end | |
| 332 | |
| 333 ;; The toggle's hook. | |
| 334 (defcustom ,hook nil | |
| 335 ,(format "Hook run at the end of function `%s'." mode-name) | |
| 336 ,@group | |
| 337 :type 'hook) | |
| 338 | |
| 339 ;; XEmacs addition: declare the on and off hooks also | |
| 340 (defcustom ,hook-on nil | |
| 341 ,(format "Hook to run when entering %s." mode-name) | |
| 342 :group ,(cadr group) | |
| 343 :type 'hook) | |
| 344 | |
| 345 (defcustom ,hook-off nil | |
| 346 ,(format "Hook to run when exiting %s." mode-name) | |
| 347 :group ,(cadr group) | |
| 348 :type 'hook) | |
| 349 | |
| 350 ;; Define the minor-mode keymap. | |
| 351 ,(unless (symbolp keymap) ;nil is also a symbol. | |
| 352 `(defvar ,keymap-sym | |
| 353 (let ((m ,keymap)) | |
| 354 (cond ((keymapp m) m) | |
| 355 ((listp m) (easy-mmode-define-keymap m)) | |
| 356 (t (error "Invalid keymap %S" ,keymap)))) | |
| 357 ,(format "Keymap for `%s'." mode-name))) | |
| 358 | |
| 359 (add-minor-mode ',mode ',lighter | |
| 360 ,(if keymap keymap-sym | |
| 361 `(if (boundp ',keymap-sym) | |
| 362 (symbol-value ',keymap-sym))) | |
| 363 ;; XEmacs change: supply the AFTER and TOGGLE-FUN args | |
| 364 t ',mode) | |
| 365 | |
| 366 ;; If the mode is global, call the function according to the default. | |
| 367 ,(if globalp | |
| 368 `(if (and load-file-name (not (equal ,init-value ,mode)) | |
| 369 ;; XEmacs addition: | |
| 370 (not purify-flag)) | |
| 371 (eval-after-load load-file-name '(,mode (if ,mode 1 -1)))))))) | |
| 372 | |
| 373 ;;; | |
| 374 ;;; make global minor mode | |
| 375 ;;; | |
| 376 | |
| 377 ;;;###no-autoload | |
| 378 (defmacro easy-mmode-define-global-mode (global-mode mode turn-on | |
| 379 &rest keys) | |
| 380 "Make GLOBAL-MODE out of the buffer-local minor MODE. | |
| 381 TURN-ON is a function that will be called with no args in every buffer | |
| 382 and that should try to turn MODE on if applicable for that buffer. | |
| 383 KEYS is a list of CL-style keyword arguments: | |
| 384 :group to specify the custom group." | |
| 385 (let* ((global-mode-name (symbol-name global-mode)) | |
| 386 (pretty-name (easy-mmode-pretty-mode-name mode)) | |
| 387 (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) | |
| 388 (group nil) | |
| 389 (extra-args nil) | |
| 390 (buffers (intern (concat global-mode-name "-buffers"))) | |
| 391 (cmmh (intern (concat global-mode-name "-cmmh")))) | |
| 392 | |
| 393 ;; Check keys. | |
| 394 (while (keywordp (car keys)) | |
| 395 (case (pop keys) | |
| 396 (:extra-args (setq extra-args (pop keys))) | |
| 397 (:group (setq group (nconc group (list :group (pop keys))))) | |
| 398 (t (setq keys (cdr keys))))) | |
| 399 | |
| 400 (unless group | |
| 401 ;; We might as well provide a best-guess default group. | |
| 402 (setq group | |
| 403 `(:group ',(or (custom-current-group) | |
| 404 (intern (replace-regexp-in-string | |
| 405 "-mode\\'" "" (symbol-name mode))))))) | |
| 406 | |
| 407 `(progn | |
| 408 ;; The actual global minor-mode | |
| 409 (define-minor-mode ,global-mode | |
| 410 ,(format "Toggle %s in every buffer. | |
| 411 With prefix ARG, turn %s on if and only if ARG is positive. | |
| 412 %s is actually not turned on in every buffer but only in those | |
| 413 in which `%s' turns it on." | |
| 414 pretty-name pretty-global-name pretty-name turn-on) | |
| 415 :global t :extra-args ,extra-args ,@group | |
| 416 | |
| 417 ;; Setup hook to handle future mode changes and new buffers. | |
| 418 (if ,global-mode | |
| 419 ;; XEmacs: find-file-hooks not find-file-hook | |
| 420 (progn | |
| 421 (add-hook 'find-file-hooks ',buffers) | |
| 422 (add-hook 'change-major-mode-hook ',cmmh)) | |
| 423 (remove-hook 'find-file-hooks ',buffers) | |
| 424 (remove-hook 'change-major-mode-hook ',cmmh)) | |
| 425 | |
| 426 ;; Go through existing buffers. | |
| 427 (dolist (buf (buffer-list)) | |
| 428 (with-current-buffer buf | |
| 429 (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) | |
| 430 | |
| 431 ;; TODO: XEmacs does not support :autoload-end | |
| 432 ;; Autoloading easy-mmode-define-global-mode | |
| 433 ;; autoloads everything up-to-here. | |
| 434 :autoload-end | |
| 435 | |
| 436 ;; List of buffers left to process. | |
| 437 (defvar ,buffers nil) | |
| 438 | |
| 439 ;; The function that calls TURN-ON in each buffer. | |
| 440 (defun ,buffers () | |
| 441 (remove-hook 'post-command-hook ',buffers) | |
| 442 (while ,buffers | |
| 443 (let ((buf (pop ,buffers))) | |
| 444 (when (buffer-live-p buf) | |
| 445 (with-current-buffer buf (,turn-on)))))) | |
| 446 (put ',buffers 'definition-name ',global-mode) | |
| 447 | |
| 448 ;; The function that catches kill-all-local-variables. | |
| 449 (defun ,cmmh () | |
| 450 (add-to-list ',buffers (current-buffer)) | |
| 451 (add-hook 'post-command-hook ',buffers)) | |
| 452 (put ',cmmh 'definition-name ',global-mode)))) | |
| 453 | |
| 454 ;;; | |
| 455 ;;; easy-mmode-defmap | |
| 456 ;;; | |
| 457 | |
| 458 (if (fboundp 'set-keymap-parents) | |
| 459 (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents) | |
| 460 (defun easy-mmode-set-keymap-parents (m parents) | |
| 461 (set-keymap-parent | |
| 462 m | |
| 463 (cond | |
| 464 ((not (consp parents)) parents) | |
| 465 ((not (cdr parents)) (car parents)) | |
| 466 (t (let ((m (copy-keymap (pop parents)))) | |
| 467 (easy-mmode-set-keymap-parents m parents) | |
| 468 m)))))) | |
| 469 | |
| 470 ;;;###no-autoload | |
| 471 (defun easy-mmode-define-keymap (bs &optional name m args) | |
| 472 "Return a keymap built from bindings BS. | |
| 473 BS must be a list of (KEY . BINDING) where | |
| 474 KEY and BINDINGS are suitable for `define-key'. | |
| 475 Optional NAME is passed to `make-sparse-keymap'. | |
| 476 Optional map M can be used to modify an existing map. | |
| 477 ARGS is a list of additional keyword arguments." | |
| 478 (let (inherit dense ;suppress | |
| 479 ) | |
| 480 (while args | |
| 481 (let ((key (pop args)) | |
| 482 (val (pop args))) | |
| 483 (case key | |
| 484 (:name (setq name val)) | |
| 485 (:dense (setq dense val)) | |
| 486 (:inherit (setq inherit val)) | |
| 487 (:group) | |
| 488 ;;((eq key :suppress) (setq suppress val)) | |
| 489 (t (message "Unknown argument %s in defmap" key))))) | |
| 490 (unless (keymapp m) | |
| 491 (setq bs (append m bs)) | |
| 492 (setq m (if dense (make-keymap name) (make-sparse-keymap name)))) | |
| 493 (dolist (b bs) | |
| 494 (let ((keys (car b)) | |
| 495 (binding (cdr b))) | |
| 496 (dolist (key (if (consp keys) keys (list keys))) | |
| 497 (cond | |
| 498 ((symbolp key) | |
| 499 (substitute-key-definition key binding m global-map)) | |
| 500 ((null binding) | |
| 501 (unless (keymapp (lookup-key m key)) (define-key m key binding))) | |
| 502 ((let ((o (lookup-key m key))) | |
| 503 (or (null o) (numberp o) (eq o 'undefined))) | |
| 504 (define-key m key binding)))))) | |
| 505 (cond | |
| 506 ((keymapp inherit) (set-keymap-parent m inherit)) | |
| 507 ((consp inherit) (easy-mmode-set-keymap-parents m inherit))) | |
| 508 m)) | |
| 509 | |
| 510 ;;;###no-autoload | |
| 511 (defmacro easy-mmode-defmap (m bs doc &rest args) | |
| 512 `(defconst ,m | |
| 513 (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) | |
| 514 ,doc)) | |
| 515 | |
| 516 | |
| 517 ;;; | |
| 518 ;;; easy-mmode-defsyntax | |
| 519 ;;; | |
| 520 | |
| 521 (defun easy-mmode-define-syntax (css args) | |
| 522 (let ((st (make-syntax-table (plist-get args :copy))) | |
| 523 (parent (plist-get args :inherit))) | |
| 524 (dolist (cs css) | |
| 525 (let ((char (car cs)) | |
| 526 (syntax (cdr cs))) | |
| 527 (if (sequencep char) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2548
diff
changeset
|
528 (mapc (lambda (c) (modify-syntax-entry c syntax st)) char) |
| 2548 | 529 (modify-syntax-entry char syntax st)))) |
| 530 ;; XEmacs change: we do not have set-char-table-parent | |
| 531 (if parent (derived-mode-merge-syntax-tables | |
| 532 (if (symbolp parent) (symbol-value parent) parent) st)) | |
| 533 st)) | |
| 534 | |
| 535 ;;;###no-autoload | |
| 536 (defmacro easy-mmode-defsyntax (st css doc &rest args) | |
| 537 "Define variable ST as a syntax-table. | |
| 538 CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." | |
| 539 `(progn | |
| 540 (autoload 'easy-mmode-define-syntax "easy-mmode") | |
| 541 (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) | |
| 542 | |
| 543 | |
| 544 | |
| 545 ;;; | |
| 546 ;;; easy-mmode-define-navigation | |
| 547 ;;; | |
| 548 | |
| 549 ;; XEmacs change: autoload | |
| 550 ;;;###no-autoload | |
| 551 (defmacro easy-mmode-define-navigation (base re &optional name endfun) | |
| 552 "Define BASE-next and BASE-prev to navigate in the buffer. | |
| 553 RE determines the places the commands should move point to. | |
| 554 NAME should describe the entities matched by RE. It is used to build | |
| 555 the docstrings of the two functions. | |
| 556 BASE-next also tries to make sure that the whole entry is visible by | |
| 557 searching for its end (by calling ENDFUN if provided or by looking for | |
| 558 the next entry) and recentering if necessary. | |
| 559 ENDFUN should return the end position (with or without moving point)." | |
| 560 (let* ((base-name (symbol-name base)) | |
| 561 (prev-sym (intern (concat base-name "-prev"))) | |
| 562 (next-sym (intern (concat base-name "-next")))) | |
| 563 (unless name (setq name (symbol-name base-name))) | |
| 564 `(progn | |
| 565 (add-to-list 'debug-ignored-errors | |
| 566 ,(concat "^No \\(previous\\|next\\) " (regexp-quote name))) | |
| 567 (defun ,next-sym (&optional count) | |
| 568 ,(format "Go to the next COUNT'th %s." name) | |
| 569 (interactive) | |
| 570 (unless count (setq count 1)) | |
| 571 (if (< count 0) (,prev-sym (- count)) | |
| 572 (if (looking-at ,re) (incf count)) | |
| 573 (if (not (re-search-forward ,re nil t count)) | |
| 574 (if (looking-at ,re) | |
| 575 (goto-char (or ,(if endfun `(,endfun)) (point-max))) | |
| 576 (error ,(format "No next %s" name))) | |
| 577 (goto-char (match-beginning 0)) | |
| 578 (when (and (eq (current-buffer) (window-buffer (selected-window))) | |
| 579 (interactive-p)) | |
| 580 (let ((endpt (or (save-excursion | |
| 581 ,(if endfun `(,endfun) | |
| 582 `(re-search-forward ,re nil t 2))) | |
| 583 (point-max)))) | |
| 584 ;; XEmacs change: versions < 21.5.16 have a | |
| 585 ;; pos-visible-in-window-p that takes only 2 parameters | |
| 586 (unless | |
| 587 (if (eq (function-max-args #'pos-visible-in-window-p) 2) | |
| 588 (pos-visible-in-window-p endpt nil) | |
| 589 (pos-visible-in-window-p endpt nil t)) | |
| 590 (recenter '(0)))))))) | |
| 591 (defun ,prev-sym (&optional count) | |
| 592 ,(format "Go to the previous COUNT'th %s" (or name base-name)) | |
| 593 (interactive) | |
| 594 (unless count (setq count 1)) | |
| 595 (if (< count 0) (,next-sym (- count)) | |
| 596 (unless (re-search-backward ,re nil t count) | |
| 597 (error ,(format "No previous %s" name)))))))) | |
| 598 | |
| 599 (provide 'easy-mmode) | |
| 600 | |
| 601 ;;; easy-mmode.el ends here |