Mercurial > hg > xemacs-beta
annotate lisp/symbols.el @ 5901:a485caa1131d
Oops, regenerate and push configure.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Tue, 05 May 2015 13:12:14 +0900 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 217 | 1 ;;; symbols.el --- functions for working with symbols and symbol values |
| 2 | |
| 3 ;; Copyright (C) 1996 Ben Wing. | |
| 4 | |
| 5 ;; Maintainer: XEmacs Development Team | |
| 6 ;; Keywords: internal | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
10 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
11 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
12 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
13 ;; option) any later version. |
| 217 | 14 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
18 ;; for more details. |
| 217 | 19 |
| 20 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 217 | 22 |
| 23 ;;; Synched up with: Not in FSF. | |
| 24 | |
| 25 ;;; Commentary: | |
| 26 | |
| 27 ;; Not yet dumped into XEmacs. | |
| 28 | |
| 29 ;; The idea behind magic variables is that you can specify arbitrary | |
| 30 ;; behavior to happen when setting or retrieving a variable's value. The | |
| 31 ;; purpose of this is to make it possible to cleanly provide support for | |
| 32 ;; obsolete variables (e.g. unread-command-event, which is obsolete for | |
| 33 ;; unread-command-events) and variable compatibility | |
| 34 ;; (e.g. suggest-key-bindings, the FSF equivalent of | |
| 35 ;; teach-extended-commands-p and teach-extended-commands-timeout). | |
| 36 | |
| 37 ;; There are a large number of functions pertaining to a variable's | |
| 38 ;; value: | |
| 39 | |
| 40 ;; boundp | |
| 41 ;; globally-boundp | |
| 42 ;; makunbound | |
| 43 ;; symbol-value | |
| 44 ;; set / setq | |
| 45 ;; default-boundp | |
| 46 ;; default-value | |
| 47 ;; set-default / setq-default | |
| 48 ;; make-variable-buffer-local | |
| 49 ;; make-local-variable | |
| 50 ;; kill-local-variable | |
| 51 ;; kill-console-local-variable | |
| 52 ;; symbol-value-in-buffer | |
| 53 ;; symbol-value-in-console | |
| 54 ;; local-variable-p / local-variable-if-set-p | |
| 55 | |
| 56 ;; Plus some "meta-functions": | |
| 57 | |
| 58 ;; defvaralias | |
| 59 ;; variable-alias | |
| 60 ;; indirect-variable | |
| 61 | |
| 62 ;; I wanted an implementation that: | |
| 63 | |
| 64 ;; -- would work with all the above functions, but (a) didn't require | |
| 65 ;; a separate handler for every function, and (b) would work OK | |
| 66 ;; even if more functions are added (e.g. `set-symbol-value-in-buffer' | |
| 67 ;; or `makunbound-default') or if more arguments are added to a | |
| 68 ;; function. | |
| 69 ;; -- avoided consing if at all possible. | |
| 70 ;; -- didn't slow down operations on non-magic variables (therefore, | |
| 71 ;; storing the magic information using `put' is ruled out). | |
| 72 ;; | |
| 73 | |
| 74 ;;; Code: | |
| 75 | |
| 76 ;; perhaps this should check whether the functions are bound, so that | |
| 77 ;; some handlers can be unspecified. That requires that all functions | |
| 78 ;; are defined before `define-magic-variable-handlers' is called, | |
| 79 ;; though. | |
| 80 | |
| 81 ;; perhaps there should be something that combines | |
| 82 ;; `define-magic-variable-handlers' with `defvaralias'. | |
| 83 | |
| 502 | 84 (globally-declare-fboundp |
| 85 '(set-magic-variable-handler)) | |
| 86 | |
| 217 | 87 (defun define-magic-variable-handlers (variable handler-class harg) |
| 88 "Set the magic variable handles for VARIABLE to those in HANDLER-CLASS. | |
| 89 HANDLER-CLASS should be a symbol. The handlers are constructed by adding | |
| 90 the handler type to HANDLER-CLASS. HARG is passed as the HARG value for | |
| 91 each of the handlers." | |
| 92 (mapcar | |
| 93 #'(lambda (htype) | |
| 94 (set-magic-variable-handler variable htype | |
| 95 (intern (concat (symbol-value handler-class) | |
| 96 "-" | |
| 97 (symbol-value htype))) | |
| 98 harg)) | |
| 99 '(get-value set-value other-predicate other-action))) | |
| 100 | |
| 101 ;; unread-command-event | |
| 102 | |
| 103 (defun mvh-first-of-list-get-value (sym fun args harg) | |
| 104 (car (apply fun harg args))) | |
| 105 | |
| 106 (defun mvh-first-of-list-set-value (sym value setfun getfun args harg) | |
| 107 (apply setfun harg (cons value (apply getfun harg args)) args)) | |
| 108 | |
| 109 (defun mvh-first-of-list-other-predicate (sym fun args harg) | |
| 110 (apply fun harg args)) | |
| 111 | |
| 112 (defun mvh-first-of-list-other-action (sym fun args harg) | |
| 113 (apply fun harg args)) | |
| 114 | |
| 115 (define-magic-variable-handlers 'unread-command-event | |
| 116 'mvh-first-of-list | |
| 117 'unread-command-events) | |
| 118 | |
| 119 ;; last-command-char, last-input-char, unread-command-char | |
| 120 | |
| 121 (defun mvh-char-to-event-get-value (sym fun args harg) | |
| 122 (event-to-character (apply fun harg args))) | |
| 123 | |
| 124 (defun mvh-char-to-event-set-value (sym value setfun getfun args harg) | |
| 125 (let ((event (apply getfun harg args))) | |
| 126 (if (event-live-p event) | |
| 127 nil | |
| 398 | 128 (setq event (make-event)) |
| 217 | 129 (apply setfun harg event args)) |
| 130 (character-to-event value event))) | |
| 131 | |
| 132 (defun mvh-char-to-event-other-predicate (sym fun args harg) | |
| 133 (apply fun harg args)) | |
| 134 | |
| 135 (defun mvh-char-to-event-other-action (sym fun args harg) | |
| 136 (apply fun harg args)) | |
| 137 | |
| 138 (define-magic-variable-handlers 'last-command-char | |
| 139 'mvh-char-to-event | |
| 140 'last-command-event) | |
| 141 | |
| 142 (define-magic-variable-handlers 'last-input-char | |
| 143 'mvh-char-to-event | |
| 144 'last-input-event) | |
| 145 | |
| 146 (define-magic-variable-handlers 'unread-command-char | |
| 147 'mvh-char-to-event | |
| 148 'unread-command-event) | |
| 149 | |
| 150 ;; suggest-key-bindings | |
| 151 | |
| 152 (set-magic-variable-handler | |
| 153 'suggest-key-bindings 'get-value | |
| 154 #'(lambda (sym fun args harg) | |
| 155 (and (apply fun 'teach-extended-commands-p args) | |
| 156 (apply fun 'teach-extended-commands-timeout args)))) | |
| 157 | |
| 158 (set-magic-variable-handler | |
| 159 'suggest-key-bindings 'set-value | |
| 160 #'(lambda (sym value setfun getfun args harg) | |
| 161 (apply setfun 'teach-extended-commands-p (not (null value)) args) | |
| 162 (if value | |
| 163 (apply 'teach-extended-commands-timeout | |
| 164 (if (numberp value) value 2) args)))) | |
| 165 | |
| 166 (set-magic-variable-handler | |
| 167 'suggest-key-bindings 'other-action | |
| 168 #'(lambda (sym fun args harg) | |
| 169 (apply fun 'teach-extended-commands-p args) | |
| 170 (apply fun 'teach-extended-commands-timeout args))) | |
| 171 | |
| 172 (set-magic-variable-handler | |
| 173 'suggest-key-bindings 'other-predicate | |
| 174 #'(lambda (sym fun args harg) | |
| 175 (and (apply fun 'teach-extended-commands-p args) | |
| 176 (apply fun 'teach-extended-commands-timeout args)))) | |
| 177 | |
| 178 ;;; symbols.el ends here |