|
22
|
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
|
