Mercurial > hg > xemacs-beta

comparison lisp/symbols.el @ 217:d44af0c54775 r20-4b7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b7
author cvs
date Mon, 13 Aug 2007 10:08:34 +0200
parents
children 74fd4e045ea6
comparison
equal deleted inserted replaced
216:43306a74e31c 217:d44af0c54775
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
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF.
26
27 ;;; Commentary:
28
29 ;; Not yet dumped into XEmacs.
30
31 ;; The idea behind magic variables is that you can specify arbitrary
32 ;; behavior to happen when setting or retrieving a variable's value. The
33 ;; purpose of this is to make it possible to cleanly provide support for
34 ;; obsolete variables (e.g. unread-command-event, which is obsolete for
35 ;; unread-command-events) and variable compatibility
36 ;; (e.g. suggest-key-bindings, the FSF equivalent of
37 ;; teach-extended-commands-p and teach-extended-commands-timeout).
38
39 ;; There are a large number of functions pertaining to a variable's
40 ;; value:
41
42 ;; boundp
43 ;; globally-boundp
44 ;; makunbound
45 ;; symbol-value
46 ;; set / setq
47 ;; default-boundp
48 ;; default-value
49 ;; set-default / setq-default
50 ;; make-variable-buffer-local
51 ;; make-local-variable
52 ;; kill-local-variable
53 ;; kill-console-local-variable
54 ;; symbol-value-in-buffer
55 ;; symbol-value-in-console
56 ;; local-variable-p / local-variable-if-set-p
57
58 ;; Plus some "meta-functions":
59
60 ;; defvaralias
61 ;; variable-alias
62 ;; indirect-variable
63
64 ;; I wanted an implementation that:
65
66 ;; -- would work with all the above functions, but (a) didn't require
67 ;; a separate handler for every function, and (b) would work OK
68 ;; even if more functions are added (e.g. `set-symbol-value-in-buffer'
69 ;; or `makunbound-default') or if more arguments are added to a
70 ;; function.
71 ;; -- avoided consing if at all possible.
72 ;; -- didn't slow down operations on non-magic variables (therefore,
73 ;; storing the magic information using `put' is ruled out).
74 ;;
75
76 ;;; Code:
77
78 ;; perhaps this should check whether the functions are bound, so that
79 ;; some handlers can be unspecified. That requires that all functions
80 ;; are defined before `define-magic-variable-handlers' is called,
81 ;; though.
82
83 ;; perhaps there should be something that combines
84 ;; `define-magic-variable-handlers' with `defvaralias'.
85
86 (defun define-magic-variable-handlers (variable handler-class harg)
87 "Set the magic variable handles for VARIABLE to those in HANDLER-CLASS.
88 HANDLER-CLASS should be a symbol. The handlers are constructed by adding
89 the handler type to HANDLER-CLASS. HARG is passed as the HARG value for
90 each of the handlers."
91 (mapcar
92 #'(lambda (htype)
93 (set-magic-variable-handler variable htype
94 (intern (concat (symbol-value handler-class)
95 "-"
96 (symbol-value htype)))
97 harg))
98 '(get-value set-value other-predicate other-action)))
99
100 ;; unread-command-event
101
102 (defun mvh-first-of-list-get-value (sym fun args harg)
103 (car (apply fun harg args)))
104
105 (defun mvh-first-of-list-set-value (sym value setfun getfun args harg)
106 (apply setfun harg (cons value (apply getfun harg args)) args))
107
108 (defun mvh-first-of-list-other-predicate (sym fun args harg)
109 (apply fun harg args))
110
111 (defun mvh-first-of-list-other-action (sym fun args harg)
112 (apply fun harg args))
113
114 (define-magic-variable-handlers 'unread-command-event
115 'mvh-first-of-list
116 'unread-command-events)
117
118 ;; last-command-char, last-input-char, unread-command-char
119
120 (defun mvh-char-to-event-get-value (sym fun args harg)
121 (event-to-character (apply fun harg args)))
122
123 (defun mvh-char-to-event-set-value (sym value setfun getfun args harg)
124 (let ((event (apply getfun harg args)))
125 (if (event-live-p event)
126 nil
127 (setq event (allocate-event))
128 (apply setfun harg event args))
129 (character-to-event value event)))
130
131 (defun mvh-char-to-event-other-predicate (sym fun args harg)
132 (apply fun harg args))
133
134 (defun mvh-char-to-event-other-action (sym fun args harg)
135 (apply fun harg args))
136
137 (define-magic-variable-handlers 'last-command-char
138 'mvh-char-to-event
139 'last-command-event)
140
141 (define-magic-variable-handlers 'last-input-char
142 'mvh-char-to-event
143 'last-input-event)
144
145 (define-magic-variable-handlers 'unread-command-char
146 'mvh-char-to-event
147 'unread-command-event)
148
149 ;; suggest-key-bindings
150
151 (set-magic-variable-handler
152 'suggest-key-bindings 'get-value
153 #'(lambda (sym fun args harg)
154 (and (apply fun 'teach-extended-commands-p args)
155 (apply fun 'teach-extended-commands-timeout args))))
156
157 (set-magic-variable-handler
158 'suggest-key-bindings 'set-value
159 #'(lambda (sym value setfun getfun args harg)
160 (apply setfun 'teach-extended-commands-p (not (null value)) args)
161 (if value
162 (apply 'teach-extended-commands-timeout
163 (if (numberp value) value 2) args))))
164
165 (set-magic-variable-handler
166 'suggest-key-bindings 'other-action
167 #'(lambda (sym fun args harg)
168 (apply fun 'teach-extended-commands-p args)
169 (apply fun 'teach-extended-commands-timeout args)))
170
171 (set-magic-variable-handler
172 'suggest-key-bindings 'other-predicate
173 #'(lambda (sym fun args harg)
174 (and (apply fun 'teach-extended-commands-p args)
175 (apply fun 'teach-extended-commands-timeout args))))
176
177 ;;; symbols.el ends here