Mercurial > hg > xemacs-beta

comparison lisp/prim/symbols.el @ 0:376386a54a3c r19-14

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