Mercurial > hg > xemacs-beta

comparison lisp/efs/efs-defun.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 8fc7fe29b841
children 8b8b7f3559a2 8619ce7e4c50
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;; -*-Emacs-Lisp-*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; File: efs-defun.el
5 ;; Release: $efs release: 1.15 $
6 ;; Version: $Revision: 1.1 $
7 ;; RCS:
8 ;; Description: efs-defun allows for OS-dependent coding of functions
9 ;; Author: Sandy Rutherford <sandy@ibm550.sissa.it>
10 ;; Created: Thu Oct 22 17:58:14 1992
11 ;; Modified: Sun Nov 27 12:18:35 1994 by sandy on gandalf
12 ;; Language: Emacs-Lisp
13 ;;
14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15
16 ;;; This file is part of efs. See efs.el for copyright
17 ;;; (it's copylefted) and warrranty (there isn't one) information.
18
19 ;;; efs-defun allows object-oriented emacs lisp definitions.
20 ;;; In efs, this feature is used to support multiple host types.
21 ;;;
22 ;;; The first arg after the function name is a key which determines
23 ;;; which version of the function is being defined. Normally, when the function
24 ;;; is called this key is given as the first argument to the function.
25 ;;;
26 ;;; For example:
27 ;;;
28 ;;; (efs-defun foobar vms (x y)
29 ;;; (message "hello vms world")
30 ;;; (+ x y))
31 ;;; => foobar
32 ;;;
33 ;;; (foobar 'vms 1 2)
34 ;;; => 3
35
36 ;;; The key nil plays a special role:
37 ;;;
38 ;;; First, it defines a default action. If there is no function
39 ;;; definition associated with a given OS-key, then the function
40 ;;; definition associated with nil is used. If further there is no
41 ;;; function definition associated with nil, then an error is
42 ;;; signaled.
43 ;;;
44 ;;; Second, the documentation string for the function is the one given
45 ;;; with the nil definition. You can supply doc-strings with other
46 ;;; definitions of the function, but they are not accessible with
47 ;;; 'describe-function. In fact, when the function is either loaded or
48 ;;; byte-compiled, they are just thrown away.
49
50 ;;; There is another way to define the default action of an efs-function.
51 ;;; This is with the use flag. If you give as the key (&use foobar),
52 ;;; then when the function is called the variable foobar will be used to
53 ;;; determine which OS version of the function to use. As well as
54 ;;; allowing you to define the doc string, if the use flag is used,
55 ;;; then you can specify an interactive specification with the function.
56 ;;; Although a function is only interactive, if the default definition
57 ;;; has an interactive spec, it is still necessary to give interactive
58 ;;; specs for the other definitions of the function as well. It is possible
59 ;;; for these interactive specs to differ.
60 ;;;
61 ;;; For example:
62 ;;;
63 ;;; (efs-defun fizzle (&use foobar)
64 ;;; "Fizzle's doc string."
65 ;;; (interactive)
66 ;;; (message "fizz wizz"))
67 ;;;
68 ;;; (efs-defun fizzle vms
69 ;;; (interactive)
70 ;;; (message "VMS is fizzled."))
71 ;;;
72 ;;; (setq foobar 'unix)
73 ;;; => unix
74 ;;;
75 ;;; (fizzle)
76 ;;; => "fizz wizz"
77 ;;;
78 ;;; (setq foobar 'vms)
79 ;;; => vms
80 ;;;
81 ;;; (fizzle)
82 ;;; => "VMS is fizzled."
83 ;;;
84 ;;; M-x f i z z l e <return>
85 ;;; => "VMS is fizzled."
86 ;;;
87 ;;; Actually, when you use the &use spec, whatever follows it is simply
88 ;;; evaluated at call time.
89
90 ;;; Note that when the function is defined, the key is implicitly
91 ;;; quoted, whereas when the function is called, the key is
92 ;;; evaluated. If this seems strange, think about how efs-defuns
93 ;;; are used in practice.
94
95 ;;; There are no restrictions on the order in which the different OS-type
96 ;;; definitions are done.
97
98 ;;; There are no restrictions on the keys that can be used, nor on the
99 ;;; symbols that can be used as arguments to an efs-defun. We go
100 ;;; to some lengths to avoid potential conflicts. In particular, when
101 ;;; the OS-keys are looked up in the symbol's property list, we
102 ;;; actually look for a symbol with the same name in the special
103 ;;; obarray, efs-key-obarray. This avoids possible conflicts with
104 ;;; other entries in the property list, that are usually accessed with
105 ;;; symbols in the standard obarray.
106
107 ;;; The V19 byte-compiler will byte-compile efs-defun's.
108 ;;; The standard emacs V18 compiler will not, however they will still
109 ;;; work, just not at byte-compiled speed.
110
111 ;;; efs-autoload works much like the standard autoload, except it
112 ;;; defines the efs function cell for a given host type as an autoload.
113 ;;; The from-kbd arg only makes sense if the default action of the autoload
114 ;;; has been defined with a &use.
115
116 ;;; To do:
117 ;;;
118 ;;; 1. Set an edebug-form-hook for efs-defun
119
120 ;;; Known Bugs:
121 ;;;
122 ;;; 1. efs-autoload will correctly NOT overload an existing function
123 ;;; definition with an autoload definition. However, it will also
124 ;;; not overload a previous autoload with a new one. It should. An
125 ;;; overload can be forced for the KEY def of function FUN by doing
126 ;;; (put 'FUN (intern "KEY" efs-key-obarray) nil) first.
127 ;;;
128
129 ;;; Provisions and requirements
130
131 (provide 'efs-defun)
132 (require 'backquote)
133
134 ;;; Variables
135
136 (defconst efs-defun-version
137 (concat (substring "$efs release: 1.15 $" 14 -2)
138 "/"
139 (substring "$Revision: 1.1 $" 11 -2)))
140
141 (defconst efs-key-obarray (make-vector 7 0))
142
143 ;; Unfortunately, we need to track this in bytecomp.el.
144 ;; It's not much to keep track of, although.
145 (defconst efs-defun-bytecomp-buffer "*Compile-Log*")
146
147 (defvar efs-key nil
148 "Inside an efs function, this is set to the key that was used to
149 call the function. You can test this inside the default definition, to
150 determine which key was actually used.")
151 (defvar efs-args nil
152 "Inside an efs function, this is set to a list of the calling args
153 of the function.")
154
155 ;;; Utility Functions
156
157 ;;; These functions are called when the macros efs-defun and efs-autoload
158 ;;; are expanded. Their purpose is to help in producing the expanded code.
159
160 (defun efs-defun-arg-count (list)
161 ;; Takes a list of arguments, and returns a list of three
162 ;; integers giving the number of normal args, the number
163 ;; of &optional args, and the number of &rest args (this should
164 ;; only be 0 or 1, but we don't check this).
165 (let ((o-leng (length (memq '&optional list)))
166 (r-leng (length (memq '&rest list)))
167 (leng (length list)))
168 (list (- leng (max o-leng r-leng))
169 (max 0 (- o-leng r-leng 1))
170 (max 0 (1- r-leng)))))
171
172 ;; For each efs-function the property efs-function-arg-structure
173 ;; is either a list of three integers to indicate the number of normal,
174 ;; optional, and rest args, or it can be the symbol 'autoload to indicate
175 ;; that all definitions of the function are autoloads, and we have no
176 ;; idea of its arg structure.
177
178 (defun efs-defun-arg-check (fun key list)
179 ;; Checks that the LIST of args is consistent for the KEY def
180 ;; of function FUN.
181 (let ((prop (get fun 'efs-function-arg-structure))
182 count)
183 (if (eq list 'autoload)
184 (or prop (put fun 'efs-function-arg-structure 'autoload))
185 (setq count (efs-defun-arg-count list))
186 (if (and prop (not (eq prop 'autoload)) (not (equal prop count)))
187 (let ((warning
188 (format
189 "args. for the %s def. of %s don't agree with previous defs."
190 key fun)))
191 (message (concat "Warning: " warning))
192 ;; We are compiling, I suppose...
193 (if (get-buffer efs-defun-bytecomp-buffer)
194 (save-excursion
195 (set-buffer efs-defun-bytecomp-buffer)
196 (goto-char (point-max))
197 (insert "efs warning:\n " warning "\n")))))
198 (put fun 'efs-function-arg-structure count))))
199
200 (defun efs-def-generic (fun use doc-string interactive-p)
201 ;; Generates a generic function def using USE.
202 ;; If use is nil, the first arg of the function
203 ;; is the key.
204 (let ((def-args '(&rest efs-args))
205 result)
206 (or use
207 (setq def-args (cons 'efs-key def-args)))
208 (setq result
209 (` (or (get (quote (, fun))
210 (, (if use
211 (list 'intern
212 (list 'symbol-name use)
213 'efs-key-obarray)
214 '(intern
215 (symbol-name efs-key)
216 efs-key-obarray))))
217 (get (quote (, fun))
218 (intern "nil" efs-key-obarray)))))
219 ;; Make the gen fun interactive, if nec.
220 (setq result
221 (if interactive-p
222 (` ((interactive)
223 (if (interactive-p)
224 (let ((prefix-arg current-prefix-arg))
225 (call-interactively
226 (, result)))
227 (, (cons 'apply (list result 'efs-args))))))
228 (list (cons 'apply (list result 'efs-args)))))
229 (if doc-string (setq result (cons doc-string result)))
230 (cons 'defun (cons fun (cons def-args result)))))
231
232 (defun efs-def-autoload (fun key file from-kbd)
233 ;; Returns the autoload lambda for FUN and FILE.
234 ;; I really should have some notion of efs-autoload
235 ;; objects, and not just plain lambda's.
236 (let ((result
237 (if from-kbd
238 (`
239 (lambda (&rest args)
240 (interactive)
241 (let ((qkey (intern (symbol-name (quote (, key)))
242 efs-key-obarray))
243 (tmp1 (intern "tmp1" efs-key-obarray))
244 (tmp2 (intern "tmp2" efs-key-obarray)))
245 ;; Need to store the a-f-function, to see if it has been
246 ;; re-defined by the load. This is avoid to an infinite loop.
247 (set tmp1 (get (quote (, fun)) qkey))
248 ;; Need to store the prefix arg in case it's interactive.
249 ;; These values are stored in variables interned in the
250 ;; efs-key-obarray, because who knows what loading a
251 ;; file might do.
252 (set tmp2 current-prefix-arg)
253 (load (, file))
254 ;; check for re-def
255 (if (equal (symbol-value tmp1)
256 (get (quote (, fun)) qkey))
257 (error "%s definition of %s is not defined by loading %s"
258 qkey (quote (, fun)) (, file)))
259 ;; call function
260 (if (interactive-p)
261 (let ((prefix-arg (symbol-value tmp2)))
262 (call-interactively
263 (get (quote (, fun)) qkey)))
264 (apply (get (quote (, fun)) qkey) args)))))
265 (` (lambda (&rest args)
266 (let ((qkey (intern (symbol-name (quote (, key)))
267 efs-key-obarray))
268 (tmp1 (intern "tmp1" efs-key-obarray)))
269 ;; Need to store the a-f-function, to see if it has been
270 ;; re-defined by the load. This is avoid to an infinite loop.
271 (set tmp1 (get (quote (, fun)) qkey))
272 (load (, file))
273 ;; check for re-def
274 (if (equal (symbol-value tmp1)
275 (get (quote (, fun)) qkey))
276 (error "%s definition of %s is not defined by loading %s"
277 qkey (quote (, fun)) (, file)))
278 ;; call function
279 (apply (get (quote (, fun)) qkey) args)))))))
280 (list 'put (list 'quote fun)
281 (list 'intern
282 (list 'symbol-name (list 'quote key))
283 'efs-key-obarray)
284 (list 'function result))))
285
286 ;;; User level macros -- efs-defun and efs-autoload.
287
288 (defmacro efs-defun (funame key args &rest body)
289 (let* ((use (and (eq (car-safe key) '&use)
290 (nth 1 key)))
291 (key (and (null use) key))
292 result doc-string interactive-p)
293 ;; check args
294 (efs-defun-arg-check funame key args)
295 ;; extract doc-string
296 (if (stringp (car body))
297 (setq doc-string (car body)
298 body (cdr body)))
299 ;; If the default fun is interactive, and it's a use construct,
300 ;; then we allow the gen fun to be interactive.
301 (if use
302 (setq interactive-p (eq (car-safe (car-safe body)) 'interactive)))
303 (setq result
304 (` ((put (quote (, funame))
305 (intern (symbol-name (quote (, key)))
306 efs-key-obarray)
307 (function
308 (, (cons 'lambda
309 (cons args body)))))
310 (quote (, funame)))))
311 ;; if the key is null, make a generic def
312 (if (null key)
313 (setq result
314 (cons (efs-def-generic
315 funame use doc-string interactive-p)
316 result)))
317 ;; return
318 (cons 'progn result)))
319
320 ;;; For lisp-mode
321
322 (put 'efs-defun 'lisp-indent-hook 'defun)
323
324 ;; efs-autoload
325 ;; Allows efs function cells to be defined as autoloads.
326 ;; If efs-autoload inserted autoload objects in the property list,
327 ;; and the funcall mechanism in efs-defun checked for such
328 ;; auto-load objects, we could reduce the size of the code
329 ;; resulting from expanding efs-autoload. However, the expansion
330 ;; of efs-defun would be larger. What is the best thing to do?
331
332 (defmacro efs-autoload (fun key file &optional docstring from-kbd)
333 (let* ((use (and (eq (car-safe key) '&use)
334 (nth 1 key)))
335 (key (and (null use) key)))
336 (efs-defun-arg-check (eval fun) key 'autoload)
337 ;; has the function been previously defined?
338 (`
339 (if (null (get (, fun)
340 (intern (symbol-name (quote (, key)))
341 efs-key-obarray)))
342 (,
343 (if (null key)
344 (list 'progn
345 ;; need to eval fun, since autoload wants an explicit
346 ;; quote built into the fun arg.
347 (efs-def-generic
348 (eval fun) use docstring from-kbd )
349 (efs-def-autoload (eval fun) key file from-kbd)
350 (list 'quote
351 (list
352 'efs-autoload
353 key file docstring from-kbd)))
354 (list 'progn
355 (efs-def-autoload (eval fun) key file from-kbd)
356 (list 'quote
357 (list
358 'efs-autoload
359 key file docstring from-kbd)))))))))
360
361 (defun efs-fset (sym key fun)
362 ;; Like fset but sets KEY's definition of SYM.
363 (put sym (intern (symbol-name key) efs-key-obarray) fun))
364
365 (defun efs-fboundp (key fun)
366 ;; Like fboundp, but checks for KEY's def.
367 (null (null (get fun (intern (symbol-name key) efs-key-obarray)))))
368
369 ;; If we are going to use autoload objects, the following two functions
370 ;; will be useful.
371 ;;
372 ;; (defun efs-defun-do-autoload (fun file key interactive-p args)
373 ;; ;; Loads FILE and runs the KEY def of FUN.
374 ;; (let (fun file key interactive-p args)
375 ;; (load file))
376 ;; (let ((new-def (get fun key)))
377 ;; (if (eq (car-safe new-def) 'autoload)
378 ;; (error "%s definition of %s is not defined by loading %s"
379 ;; key fun file)
380 ;; (if interactive-p
381 ;; (let ((prefix-arg current-predix-arg))
382 ;; (call-interactively fun))
383 ;; (apply new-def args)))))
384 ;;
385 ;; (defun efs-defun-autoload (fun key file doc-string from-kbd)
386 ;; ;; Sets the KEY def of FUN to an autoload object.
387 ;; (let* ((key (intern (symbol-name key) efs-key-obarray))
388 ;; (def (get fun key)))
389 ;; (if (or (null def)
390 ;; (eq (car-safe def) 'autoload))
391 ;; (put fun key (list 'autoload file doc-string from-kbd)))))
392
393 ;;; end of efs-defun.el