aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorChong Yidong2009-08-30 02:02:15 +0000
committerChong Yidong2009-08-30 02:02:15 +0000
commitac6cb46aa6ee9a428ea5b24720cd403ef3c1ad66 (patch)
tree133afc12331d8b45d0dba62d56aef7ec24be1365
parent441983a5604168b3a0f21bd5a5e50b8121bdffea (diff)
downloademacs-ac6cb46aa6ee9a428ea5b24720cd403ef3c1ad66.tar.gz
emacs-ac6cb46aa6ee9a428ea5b24720cd403ef3c1ad66.zip
emacs-lisp/eieio-base.el, emacs-lisp/eieio-comp.el,
emacs-lisp/eieio-custom.el, emacs-lisp/eieio-datadebug.el, emacs-lisp/eieio-doc.el, emacs-lisp/eieio-opt.el, emacs-lisp/eieio-speedbar.el, emacs-lisp/eieio.el: Move from eieio/directory.
Diffstat
-rw-r--r--lisp/emacs-lisp/eieio-base.el328
-rw-r--r--lisp/emacs-lisp/eieio-comp.el170
-rw-r--r--lisp/emacs-lisp/eieio-custom.el471
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el151
-rw-r--r--lisp/emacs-lisp/eieio-doc.el368
-rw-r--r--lisp/emacs-lisp/eieio-opt.el699
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el424
-rw-r--r--lisp/emacs-lisp/eieio.el2803
8 files changed, 5414 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
new file mode 100644
index 00000000000..6bd09a778c3
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -0,0 +1,328 @@
1;;; eieio-base.el --- Base classes for EIEIO.
2
3;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: OO, lisp
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26;;
27;; Base classes for EIEIO. These classes perform some basic tasks
28;; but are generally useless on their own. To use any of these classes,
29;; inherit from one or more of them.
30
31;;; Code:
32
33(require 'eieio)
34
35;;; eieio-instance-inheritor
36;;
37;; Enable instance inheritance via the `clone' method.
38;; Works by using the `slot-unbound' method which usually throws an
39;; error if a slot is unbound.
40(defclass eieio-instance-inheritor ()
41 ((parent-instance :initarg :parent-instance
42 :type eieio-instance-inheritor-child
43 :documentation
44 "The parent of this instance.
45If a slot of this class is reference, and is unbound, then the parent
46is checked for a value.")
47 )
48 "This special class can enable instance inheritance.
49Use `clone' to make a new object that does instance inheritance from
50a parent instance. When a slot in the child is referenced, and has
51not been set, use values from the parent."
52 :abstract t)
53
54(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn)
55 "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
56SLOT-NAME, is the offending slot. FN is the function signalling the error."
57 (if (slot-boundp object 'parent-instance)
58 ;; It may not look like it, but this line recurses back into this
59 ;; method if the parent instance's slot is unbound.
60 (eieio-oref (oref object parent-instance) slot-name)
61 ;; Throw the regular signal.
62 (call-next-method)))
63
64(defmethod clone ((obj eieio-instance-inheritor) &rest params)
65 "Clone OBJ, initializing `:parent' to OBJ.
66All slots are unbound, except those initialized with PARAMS."
67 (let ((nobj (make-vector (length obj) eieio-unbound))
68 (nm (aref obj object-name))
69 (passname (and params (stringp (car params))))
70 (num 1))
71 (aset nobj 0 'object)
72 (aset nobj object-class (aref obj object-class))
73 ;; The following was copied from the default clone.
74 (if (not passname)
75 (save-match-data
76 (if (string-match "-\\([0-9]+\\)" nm)
77 (setq num (1+ (string-to-number (match-string 1 nm)))
78 nm (substring nm 0 (match-beginning 0))))
79 (aset nobj object-name (concat nm "-" (int-to-string num))))
80 (aset nobj object-name (car params)))
81 ;; Now initialize from params.
82 (if params (shared-initialize nobj (if passname (cdr params) params)))
83 (oset nobj parent-instance obj)
84 nobj))
85
86(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
87 slot)
88 "Non-nil if the instance inheritor OBJECT's SLOT is bound.
89See `slot-boundp' for for details on binding slots.
90The instance inheritor uses unbound slots as a way cascading cloned
91slot values, so testing for a slot being bound requires extra steps
92for this kind of object."
93 (if (slot-boundp object slot)
94 ;; If it is regularly bound, return t.
95 t
96 (if (slot-boundp object 'parent-instance)
97 (eieio-instance-inheritor-slot-boundp (oref object parent-instance)
98 slot)
99 nil)))
100
101
102;;; eieio-instance-tracker
103;;
104;; Track all created instances of this class.
105;; The class must initialize the `tracking-symbol' slot, and that
106;; symbol is then used to contain these objects.
107(defclass eieio-instance-tracker ()
108 ((tracking-symbol :type symbol
109 :allocation :class
110 :documentation
111 "The symbol used to maintain a list of our instances.
112The instance list is treated as a variable, with new instances added to it.")
113 )
114 "This special class enables instance tracking.
115Inheritors from this class must overload `tracking-symbol' which is
116a variable symbol used to store a list of all instances."
117 :abstract t)
118
119(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
120 &rest slots)
121 "Make sure THIS is in our master list of this class.
122Optional argument SLOTS are the initialization arguments."
123 ;; Theoretically, this is never called twice for a given instance.
124 (let ((sym (oref this tracking-symbol)))
125 (if (not (memq this (symbol-value sym)))
126 (set sym (append (symbol-value sym) (list this))))))
127
128(defmethod delete-instance ((this eieio-instance-tracker))
129 "Remove THIS from the master list of this class."
130 (set (oref this tracking-symbol)
131 (delq this (symbol-value (oref this tracking-symbol)))))
132
133;; In retrospect, this is a silly function.
134(defun eieio-instance-tracker-find (key slot list-symbol)
135 "Find KEY as an element of SLOT in the objects in LIST-SYMBOL.
136Returns the first match."
137 (object-assoc key slot (symbol-value list-symbol)))
138
139;;; eieio-singleton
140;;
141;; The singleton Design Pattern specifies that there is but one object
142;; of a given class ever created. The EIEIO singleton base class defines
143;; a CLASS allocated slot which contains the instance used. All calls to
144;; `make-instance' will either create a new instance and store it in this
145;; slot, or it will just return what is there.
146(defclass eieio-singleton ()
147 ((singleton :type eieio-singleton
148 :allocation :class
149 :documentation
150 "The only instance of this class that will be instantiated.
151Multiple calls to `make-instance' will return this object."))
152 "This special class causes subclasses to be singletons.
153A singleton is a class which will only ever have one instace."
154 :abstract t)
155
156(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots)
157 "Constructor for singleton CLASS.
158NAME and SLOTS initialize the new object.
159This constructor guarantees that no matter how many you request,
160only one object ever exists."
161 ;; NOTE TO SELF: In next version, make `slot-boundp' support classes
162 ;; with class allocated slots or default values.
163 (let ((old (oref-default class singleton)))
164 (if (eq old eieio-unbound)
165 (oset-default class singleton (call-next-method))
166 old)))
167
168
169;;; eieio-persistent
170;;
171;; For objects which must save themselves to disk. Provides an
172;; `object-write' method to save an object to disk, and a
173;; `eieio-persistent-read' function to call to read an object
174;; from disk.
175;;
176;; Also provide the method `eieio-persistent-path-relative' to
177;; calculate path names relative to a given instance. This will
178;; make the saved object location independent by converting all file
179;; references to be relative to the directory the object is saved to.
180;; You must call `eieio-peristent-path-relative' on each file name
181;; saved in your object.
182(defclass eieio-persistent ()
183 ((file :initarg :file
184 :type string
185 :documentation
186 "The save file for this persistent object.
187This must be a string, and must be specified when the new object is
188instantiated.")
189 (extension :type string
190 :allocation :class
191 :initform ".eieio"
192 :documentation
193 "Extension of files saved by this object.
194Enables auto-choosing nice file names based on name.")
195 (file-header-line :type string
196 :allocation :class
197 :initform ";; EIEIO PERSISTENT OBJECT"
198 :documentation
199 "Header line for the save file.
200This is used with the `object-write' method.")
201 (do-backups :type boolean
202 :allocation :class
203 :initform t
204 :documentation
205 "Saving this object should make backup files.
206Setting to nil will mean no backups are made."))
207 "This special class enables persistence through save files
208Use the `object-save' method to write this object to disk. The save
209format is Emacs Lisp code which calls the constructor for the saved
210object. For this reason, only slots which do not have an `:initarg'
211specified will not be saved."
212 :abstract t)
213
214(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
215 &optional name)
216 "Perpare to save THIS. Use in an `interactive' statement.
217Query user for file name with PROMPT if THIS does not yet specify
218a file. Optional argument NAME specifies a default file name."
219 (unless (slot-boundp this 'file)
220 (oset this file
221 (read-file-name prompt nil
222 (if name
223 (concat name (oref this extension))
224 ))))
225 (oref this file))
226
227(defun eieio-persistent-read (filename)
228 "Read a persistent object from FILENAME, and return it."
229 (let ((ret nil)
230 (buffstr nil))
231 (unwind-protect
232 (progn
233 (save-excursion
234 (set-buffer (get-buffer-create " *tmp eieio read*"))
235 (insert-file-contents filename nil nil nil t)
236 (goto-char (point-min))
237 (setq buffstr (buffer-string)))
238 ;; Do the read in the buffer the read was initialized from
239 ;; so that any initialize-instance calls that depend on
240 ;; the current buffer will work.
241 (setq ret (read buffstr))
242 (if (not (child-of-class-p (car ret) 'eieio-persistent))
243 (error "Corrupt object on disk"))
244 (setq ret (eval ret))
245 (oset ret file filename))
246 (kill-buffer " *tmp eieio read*"))
247 ret))
248
249(defmethod object-write ((this eieio-persistent) &optional comment)
250 "Write persistent object THIS out to the current stream.
251Optional argument COMMENT is a header line comment."
252 (call-next-method this (or comment (oref this file-header-line))))
253
254(defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
255 "For object THIS, make absolute file name FILE relative."
256 (file-relative-name (expand-file-name file)
257 (file-name-directory (oref this file))))
258
259(defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
260 "Save persistent object THIS to disk.
261Optional argument FILE overrides the file name specified in the object
262instance."
263 (save-excursion
264 (let ((b (set-buffer (get-buffer-create " *tmp object write*")))
265 (default-directory (file-name-directory (oref this file)))
266 (cfn (oref this file)))
267 (unwind-protect
268 (save-excursion
269 (erase-buffer)
270 (let ((standard-output (current-buffer)))
271 (oset this file
272 (if file
273 (eieio-persistent-path-relative this file)
274 (file-name-nondirectory cfn)))
275 (object-write this (oref this file-header-line)))
276 (let ((backup-inhibited (not (oref this do-backups))))
277 ;; Old way - write file. Leaves message behind.
278 ;;(write-file cfn nil)
279
280 ;; New way - Avoid the vast quantities of error checking
281 ;; just so I can get at the special flags that disable
282 ;; displaying random messages.
283 (write-region (point-min) (point-max)
284 cfn nil 1)
285 ))
286 ;; Restore :file, and kill the tmp buffer
287 (oset this file cfn)
288 (setq buffer-file-name nil)
289 (kill-buffer b)))))
290
291;; Notes on the persistent object:
292;; It should also set up some hooks to help it keep itself up to date.
293
294
295;;; Named object
296;;
297;; Named objects use the objects `name' as a slot, and that slot
298;; is accessed with the `object-name' symbol.
299
300(defclass eieio-named ()
301 ()
302 "Object with a name.
303Name storage already occurs in an object. This object provides get/set
304access to it."
305 :abstract t)
306
307(defmethod slot-missing ((obj eieio-named)
308 slot-name operation &optional new-value)
309 "Called when a on-existant slot is accessed.
310For variable `eieio-named', provide an imaginary `object-name' slot.
311Argument OBJ is the Named object.
312Argument SLOT-NAME is the slot that was attempted to be accessed.
313OPERATION is the type of access, such as `oref' or `oset'.
314NEW-VALUE is the value that was being set into SLOT if OPERATION were
315a set type."
316 (if (or (eq slot-name 'object-name)
317 (eq slot-name :object-name))
318 (cond ((eq operation 'oset)
319 (if (not (stringp new-value))
320 (signal 'invalid-slot-type
321 (list obj slot-name 'string new-value)))
322 (object-set-name-string obj new-value))
323 (t (object-name-string obj)))
324 (call-next-method)))
325
326(provide 'eieio-base)
327
328;;; eieio-base.el ends here
diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el
new file mode 100644
index 00000000000..8c75aee313a
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-comp.el
@@ -0,0 +1,170 @@
1;;; eieio-comp.el -- eieio routines to help with byte compilation
2
3;;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005, 2008,
4;;; 2009 Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: oop, lisp, tools
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26
27;; Byte compiler functions for defmethod. This will affect the new GNU
28;; byte compiler for Emacs 19 and better. This function will be called by
29;; the byte compiler whenever a `defmethod' is encountered in a file.
30;; It will output a function call to `eieio-defmethod' with the byte
31;; compiled function as a parameter.
32
33;;; Code:
34
35(eval-and-compile
36 (if (featurep 'xemacs)
37 (progn
38 ;; XEmacs compatibility settings.
39 (if (not (fboundp 'byte-compile-compiled-obj-to-list))
40 (defun byte-compile-compiled-obj-to-list (moose) nil))
41 (if (not (boundp 'byte-compile-outbuffer))
42 (defvar byte-compile-outbuffer nil))
43 (defmacro eieio-byte-compile-princ-code (code outbuffer)
44 `(progn (if (atom ,code)
45 (princ "#[" ,outbuffer)
46 (princ "'(" ,outbuffer))
47 (let ((codelist (if (byte-code-function-p ,code)
48 (byte-compile-compiled-obj-to-list ,code)
49 (append ,code nil))))
50 (while codelist
51 (eieio-prin1 (car codelist) ,outbuffer)
52 (princ " " ,outbuffer)
53 (setq codelist (cdr codelist))))
54 (if (atom ,code)
55 (princ "]" ,outbuffer)
56 (princ ")" ,outbuffer))))
57 (defun eieio-prin1 (code outbuffer)
58 (cond ((byte-code-function-p code)
59 (let ((codelist (byte-compile-compiled-obj-to-list code)))
60 (princ "#[" outbuffer)
61 (while codelist
62 (eieio-prin1 (car codelist) outbuffer)
63 (princ " " outbuffer)
64 (setq codelist (cdr codelist)))
65 (princ "]" outbuffer)))
66 ((vectorp code)
67 (let ((i 0) (ln (length code)))
68 (princ "[" outbuffer)
69 (while (< i ln)
70 (eieio-prin1 (aref code i) outbuffer)
71 (princ " " outbuffer)
72 (setq i (1+ i)))
73 (princ "]" outbuffer)))
74 (t (prin1 code outbuffer)))))
75 ;; Emacs:
76 (defmacro eieio-byte-compile-princ-code (code outbuffer)
77 (list 'prin1 code outbuffer))
78 ;; Dynamically bound in byte-compile-from-buffer.
79 (defvar bytecomp-outbuffer)
80 (defvar bytecomp-filename)))
81
82(declare-function eieio-defgeneric-form "eieio" (method doc-string))
83
84(defun byte-compile-defmethod-param-convert (paramlist)
85 "Convert method params into the params used by the defmethod thingy.
86Argument PARAMLIST is the paramter list to convert."
87 (let ((argfix nil))
88 (while paramlist
89 (setq argfix (cons (if (listp (car paramlist))
90 (car (car paramlist))
91 (car paramlist))
92 argfix))
93 (setq paramlist (cdr paramlist)))
94 (nreverse argfix)))
95
96;; This teaches the byte compiler how to do this sort of thing.
97(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
98
99(defun byte-compile-file-form-defmethod (form)
100 "Mumble about the method we are compiling.
101This function is mostly ripped from `byte-compile-file-form-defun', but
102it's been modified to handle the special syntax of the defmethod
103command. There should probably be one for defgeneric as well, but
104that is called but rarely. Argument FORM is the body of the method."
105 (setq form (cdr form))
106 (let* ((meth (car form))
107 (key (progn (setq form (cdr form))
108 (cond ((or (eq ':BEFORE (car form))
109 (eq ':before (car form)))
110 (setq form (cdr form))
111 ":before ")
112 ((or (eq ':AFTER (car form))
113 (eq ':after (car form)))
114 (setq form (cdr form))
115 ":after ")
116 ((or (eq ':PRIMARY (car form))
117 (eq ':primary (car form)))
118 (setq form (cdr form))
119 ":primary ")
120 ((or (eq ':STATIC (car form))
121 (eq ':static (car form)))
122 (setq form (cdr form))
123 ":static ")
124 (t ""))))
125 (params (car form))
126 (lamparams (byte-compile-defmethod-param-convert params))
127 (arg1 (car params))
128 (class (if (listp arg1) (nth 1 arg1) nil))
129 (my-outbuffer (if (featurep 'xemacs)
130 byte-compile-outbuffer
131 bytecomp-outbuffer)))
132 (let ((name (format "%s::%s" (or class "#<generic>") meth)))
133 (if byte-compile-verbose
134 ;; bytecomp-filename is from byte-compile-from-buffer.
135 (message "Compiling %s... (%s)" (or bytecomp-filename "") name))
136 (setq byte-compile-current-form name)) ; for warnings
137 ;; Flush any pending output
138 (byte-compile-flush-pending)
139 ;; Byte compile the body. For the byte compiled forms, add the
140 ;; rest arguments, which will get ignored by the engine which will
141 ;; add them later (I hope)
142 (let* ((new-one (byte-compile-lambda
143 (append (list 'lambda lamparams)
144 (cdr form))))
145 (code (byte-compile-byte-code-maker new-one)))
146 (princ "\n(eieio-defmethod '" my-outbuffer)
147 (princ meth my-outbuffer)
148 (princ " '(" my-outbuffer)
149 (princ key my-outbuffer)
150 (prin1 params my-outbuffer)
151 (princ " " my-outbuffer)
152 (eieio-byte-compile-princ-code code my-outbuffer)
153 (princ "))" my-outbuffer))
154 ;; Now add this function to the list of known functions.
155 ;; Don't bother with a doc string. Not relevant here.
156 (add-to-list 'byte-compile-function-environment
157 (cons meth
158 (eieio-defgeneric-form meth "")))
159
160 ;; Remove it from the undefined list if it is there.
161 (let ((elt (assq meth byte-compile-unresolved-functions)))
162 (if elt (setq byte-compile-unresolved-functions
163 (delq elt byte-compile-unresolved-functions))))
164
165 ;; nil prevents cruft from appearing in the output buffer.
166 nil))
167
168(provide 'eieio-comp)
169
170;;; eieio-comp.el ends here
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
new file mode 100644
index 00000000000..71ebf79d554
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -0,0 +1,471 @@
1;;; eieio-custom.el -- eieio object customization
2
3;;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: OO, lisp
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26;;
27;; This contains support customization of eieio objects. Enabling
28;; your object to be customizable requires use of the slot attirbute
29;; `:custom'.
30
31(require 'eieio)
32(require 'widget)
33(require 'wid-edit)
34(require 'custom)
35
36;;; Compatibility
37;;
38(eval-and-compile
39 (if (featurep 'xemacs)
40 (defalias 'eieio-overlay-lists (lambda () (list (extent-list))))
41 (defalias 'eieio-overlay-lists 'overlay-lists)
42 )
43 )
44;;; Code:
45(defclass eieio-widget-test-class nil
46 ((a-string :initarg :a-string
47 :initform "The moose is loose"
48 :custom string
49 :label "Amorphous String"
50 :group (default foo)
51 :documentation "A string for testing custom.
52This is the next line of documentation.")
53 (listostuff :initarg :listostuff
54 :initform ("1" "2" "3")
55 :type list
56 :custom (repeat (string :tag "Stuff"))
57 :label "List of Strings"
58 :group foo
59 :documentation "A list of stuff.")
60 (uninitialized :initarg :uninitialized
61 :type string
62 :custom string
63 :documentation "This slot is not initialized.
64Used to make sure that custom doesn't barf when it encounters one
65of these.")
66 (a-number :initarg :a-number
67 :initform 2
68 :custom integer
69 :documentation "A number of thingies."))
70 "A class for testing the widget on.")
71
72(defcustom eieio-widget-test (eieio-widget-test-class "Foo")
73 "Test variable for editing an object."
74 :type 'object
75 :group 'eieio)
76
77(defface eieio-custom-slot-tag-face '((((class color)
78 (background dark))
79 (:foreground "light blue"))
80 (((class color)
81 (background light))
82 (:foreground "blue"))
83 (t (:italic t)))
84 "Face used for unpushable variable tags."
85 :group 'custom-faces)
86
87(defvar eieio-wo nil
88 "Buffer local variable in object customize buffers for the current widget.")
89(defvar eieio-co nil
90 "Buffer local variable in object customize buffers for the current obj.")
91(defvar eieio-cog nil
92 "Buffer local variable in object customize buffers for the current group.")
93
94 (defvar eieio-custom-ignore-eieio-co nil
95 "When true, all customizable slots of the current object are updated.
96Updates occur regardless of the current customization group.")
97
98(define-widget 'object-slot 'group
99 "Abstractly modify a single slot in an object."
100 :tag "Slot"
101 :format "%t %v%h\n"
102 :convert-widget 'widget-types-convert-widget
103 :value-create 'eieio-slot-value-create
104 :value-get 'eieio-slot-value-get
105 :value-delete 'widget-children-value-delete
106 :validate 'widget-children-validate
107 :match 'eieio-object-match ;; same
108 )
109
110(defun eieio-slot-value-create (widget)
111 "Create the value of WIDGET."
112 (let ((chil nil)
113 )
114; (setq chil (cons (widget-create-child-and-convert
115; widget 'visibility
116; :help-echo "Hide the value of this option."
117; :action 'eieio-custom-toggle-parent
118; t)
119; chil))
120 (setq chil (cons
121 (widget-create-child-and-convert
122 widget (widget-get widget :childtype)
123 :tag ""
124 :value (widget-get widget :value))
125 chil))
126 (widget-put widget :children chil)))
127
128(defun eieio-slot-value-get (widget)
129 "Get the value of WIDGET."
130 (widget-value (car (widget-get widget :children))))
131
132(defun eieio-custom-toggle-hide (widget)
133 "Toggle visibility of WIDGET."
134 (let ((vc (car (widget-get widget :children))))
135 (cond ((eq (widget-get vc :eieio-custom-state) 'hidden)
136 (widget-put vc :eieio-custom-state 'visible)
137 (widget-put vc :value-face (widget-get vc :orig-face)))
138 (t
139 (widget-put vc :eieio-custom-state 'hidden)
140 (widget-put vc :orig-face (widget-get vc :value-face))
141 (widget-put vc :value-face 'invisible)
142 ))
143 (widget-value-set vc (widget-value vc))))
144
145(defun eieio-custom-toggle-parent (widget &rest ignore)
146 "Toggle visibility of parent of WIDGET.
147Optional argument IGNORE is an extraneous parameter."
148 (eieio-custom-toggle-hide (widget-get widget :parent)))
149
150(define-widget 'object-edit 'group
151 "Abstractly modify a CLOS object."
152 :tag "Object"
153 :format "%v"
154 :convert-widget 'widget-types-convert-widget
155 :value-create 'eieio-object-value-create
156 :value-get 'eieio-object-value-get
157 :value-delete 'widget-children-value-delete
158 :validate 'widget-children-validate
159 :match 'eieio-object-match
160 :clone-object-children nil
161 )
162
163(defun eieio-object-match (widget value)
164 "Match info for WIDGET against VALUE."
165 ;; Write me
166 t)
167
168(defun eieio-filter-slot-type (widget slottype)
169 "Filter WIDGETs SLOTTYPE."
170 (if (widget-get widget :clone-object-children)
171 slottype
172 (cond ((eq slottype 'object)
173 'object-edit)
174 ((and (listp slottype)
175 (eq (car slottype) 'object))
176 (cons 'object-edit (cdr slottype)))
177 ((equal slottype '(repeat object))
178 '(repeat object-edit))
179 ((and (listp slottype)
180 (equal (car slottype) 'repeat)
181 (listp (car (cdr slottype)))
182 (equal (car (car (cdr slottype))) 'object))
183 (list 'repeat
184 (cons 'object-edit
185 (cdr (car (cdr slottype))))))
186 (t slottype))))
187
188(defun eieio-object-value-create (widget)
189 "Create the value of WIDGET."
190 (if (not (widget-get widget :value))
191 (widget-put widget
192 :value (cond ((widget-get widget :objecttype)
193 (funcall (class-constructor
194 (widget-get widget :objecttype))
195 "Custom-new"))
196 ((widget-get widget :objectcreatefcn)
197 (funcall (widget-get widget :objectcreatefcn)))
198 (t (error "No create method specified")))))
199 (let* ((chil nil)
200 (obj (widget-get widget :value))
201 (master-group (widget-get widget :eieio-group))
202 (cv (class-v (object-class-fast obj)))
203 (slots (aref cv class-public-a))
204 (flabel (aref cv class-public-custom-label))
205 (fgroup (aref cv class-public-custom-group))
206 (fdoc (aref cv class-public-doc))
207 (fcust (aref cv class-public-custom)))
208 ;; First line describes the object, but may not editable.
209 (if (widget-get widget :eieio-show-name)
210 (setq chil (cons (widget-create-child-and-convert
211 widget 'string :tag "Object "
212 :sample-face 'bold
213 (object-name-string obj))
214 chil)))
215 ;; Display information about the group being shown
216 (when master-group
217 (let ((groups (class-option (object-class-fast obj) :custom-groups)))
218 (widget-insert "Groups:")
219 (while groups
220 (widget-insert " ")
221 (if (eq (car groups) master-group)
222 (widget-insert "*" (capitalize (symbol-name master-group)) "*")
223 (widget-create 'push-button
224 :thing (cons obj (car groups))
225 :notify (lambda (widget &rest stuff)
226 (eieio-customize-object
227 (car (widget-get widget :thing))
228 (cdr (widget-get widget :thing))))
229 (capitalize (symbol-name (car groups)))))
230 (setq groups (cdr groups)))
231 (widget-insert "\n\n")))
232 ;; Loop over all the slots, creating child widgets.
233 (while slots
234 ;; Output this slot if it has a customize flag associated with it.
235 (when (and (car fcust)
236 (or (not master-group) (member master-group (car fgroup)))
237 (slot-boundp obj (car slots)))
238 ;; In this case, this slot has a custom type. Create it's
239 ;; children widgets.
240 (let ((type (eieio-filter-slot-type widget (car fcust)))
241 (stuff nil))
242 ;; This next bit is an evil hack to get some EDE functions
243 ;; working the way I like.
244 (if (and (listp type)
245 (setq stuff (member :slotofchoices type)))
246 (let ((choices (eieio-oref obj (car (cdr stuff))))
247 (newtype nil))
248 (while (not (eq (car type) :slotofchoices))
249 (setq newtype (cons (car type) newtype)
250 type (cdr type)))
251 (while choices
252 (setq newtype (cons (list 'const (car choices))
253 newtype)
254 choices (cdr choices)))
255 (setq type (nreverse newtype))))
256 (setq chil (cons (widget-create-child-and-convert
257 widget 'object-slot
258 :childtype type
259 :sample-face 'eieio-custom-slot-tag-face
260 :tag
261 (concat
262 (make-string
263 (or (widget-get widget :indent) 0)
264 ? )
265 (if (car flabel)
266 (car flabel)
267 (let ((s (symbol-name
268 (or
269 (class-slot-initarg
270 (object-class-fast obj)
271 (car slots))
272 (car slots)))))
273 (capitalize
274 (if (string-match "^:" s)
275 (substring s (match-end 0))
276 s)))))
277 :value (slot-value obj (car slots))
278 :doc (if (car fdoc) (car fdoc)
279 "Slot not Documented.")
280 :eieio-custom-visibility 'visible
281 )
282 chil))
283 )
284 )
285 (setq slots (cdr slots)
286 fdoc (cdr fdoc)
287 fcust (cdr fcust)
288 flabel (cdr flabel)
289 fgroup (cdr fgroup)))
290 (widget-put widget :children (nreverse chil))
291 ))
292
293(defun eieio-object-value-get (widget)
294 "Get the value of WIDGET."
295 (let* ((obj (widget-get widget :value))
296 (master-group eieio-cog)
297 (cv (class-v (object-class-fast obj)))
298 (fgroup (aref cv class-public-custom-group))
299 (wids (widget-get widget :children))
300 (name (if (widget-get widget :eieio-show-name)
301 (car (widget-apply (car wids) :value-inline))
302 nil))
303 (chil (if (widget-get widget :eieio-show-name)
304 (nthcdr 1 wids) wids))
305 (cv (class-v (object-class-fast obj)))
306 (slots (aref cv class-public-a))
307 (fcust (aref cv class-public-custom)))
308 ;; If there are any prefix widgets, clear them.
309 ;; -- None yet
310 ;; Create a batch of initargs for each slot.
311 (while (and slots chil)
312 (if (and (car fcust)
313 (or eieio-custom-ignore-eieio-co
314 (not master-group) (member master-group (car fgroup)))
315 (slot-boundp obj (car slots)))
316 (progn
317 ;; Only customized slots have widgets
318 (let ((eieio-custom-ignore-eieio-co t))
319 (eieio-oset obj (car slots)
320 (car (widget-apply (car chil) :value-inline))))
321 (setq chil (cdr chil))))
322 (setq slots (cdr slots)
323 fgroup (cdr fgroup)
324 fcust (cdr fcust)))
325 ;; Set any name updates on it.
326 (if name (aset obj object-name name))
327 ;; This is the same object we had before.
328 obj))
329
330(defmethod eieio-done-customizing ((obj eieio-default-superclass))
331 "When a applying change to a widget, call this method.
332This method is called by the default widget-edit commands. User made
333commands should also call this method when applying changes.
334Argument OBJ is the object that has been customized."
335 nil)
336
337(defun customize-object (obj &optional group)
338 "Customize OBJ in a custom buffer.
339Optional argument GROUP is the sub-group of slots to display."
340 (eieio-customize-object obj group))
341
342(defmethod eieio-customize-object ((obj eieio-default-superclass)
343 &optional group)
344 "Customize OBJ in a specialized custom buffer.
345To override call the `eieio-custom-widget-insert' to just insert the
346object widget.
347Optional argument GROUP specifies a subgroup of slots to edit as a symbol.
348These groups are specified with the `:group' slot flag."
349 ;; Insert check for multiple edits here.
350 (let* ((g (or group 'default)))
351 (switch-to-buffer (get-buffer-create
352 (concat "*CUSTOMIZE "
353 (object-name obj) " "
354 (symbol-name g) "*")))
355 (toggle-read-only -1)
356 (kill-all-local-variables)
357 (erase-buffer)
358 (let ((all (eieio-overlay-lists)))
359 ;; Delete all the overlays.
360 (mapc 'delete-overlay (car all))
361 (mapc 'delete-overlay (cdr all)))
362 ;; Add an apply reset option at the top of the buffer.
363 (eieio-custom-object-apply-reset obj)
364 (widget-insert "\n\n")
365 (widget-insert "Edit object " (object-name obj) "\n\n")
366 ;; Create the widget editing the object.
367 (make-local-variable 'eieio-wo)
368 (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
369 ;;Now generate the apply buttons
370 (widget-insert "\n")
371 (eieio-custom-object-apply-reset obj)
372 ;; Now initialize the buffer
373 (use-local-map widget-keymap)
374 (widget-setup)
375 ;;(widget-minor-mode)
376 (goto-char (point-min))
377 (widget-forward 3)
378 (make-local-variable 'eieio-co)
379 (setq eieio-co obj)
380 (make-local-variable 'eieio-cog)
381 (setq eieio-cog group)))
382
383(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass))
384 "Insert an Apply and Reset button into the object editor.
385Argument OBJ os the object being customized."
386 (widget-create 'push-button
387 :notify (lambda (&rest ignore)
388 (widget-apply eieio-wo :value-get)
389 (eieio-done-customizing eieio-co)
390 (bury-buffer))
391 "Accept")
392 (widget-insert " ")
393 (widget-create 'push-button
394 :notify (lambda (&rest ignore)
395 ;; I think the act of getting it sets
396 ;; it's value through the get function.
397 (message "Applying Changes...")
398 (widget-apply eieio-wo :value-get)
399 (eieio-done-customizing eieio-co)
400 (message "Applying Changes...Done."))
401 "Apply")
402 (widget-insert " ")
403 (widget-create 'push-button
404 :notify (lambda (&rest ignore)
405 (message "Resetting.")
406 (eieio-customize-object eieio-co eieio-cog))
407 "Reset")
408 (widget-insert " ")
409 (widget-create 'push-button
410 :notify (lambda (&rest ignore)
411 (bury-buffer))
412 "Cancel"))
413
414(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
415 &rest flags)
416 "Insert the widget used for editing object OBJ in the current buffer.
417Arguments FLAGS are widget compatible flags.
418Must return the created widget."
419 (apply 'widget-create 'object-edit :value obj flags))
420
421(define-widget 'object 'object-edit
422 "Instance of a CLOS class."
423 :format "%{%t%}:\n%v"
424 :value-to-internal 'eieio-object-value-to-abstract
425 :value-to-external 'eieio-object-abstract-to-value
426 :clone-object-children t
427 )
428
429(defun eieio-object-value-to-abstract (widget value)
430 "For WIDGET, convert VALUE to an abstract /safe/ representation."
431 (if (eieio-object-p value) value
432 (if (null value) value
433 nil)))
434
435(defun eieio-object-abstract-to-value (widget value)
436 "For WIDGET, convert VALUE from an abstract /safe/ representation."
437 value)
438
439
440;;; customization group functions
441;;
442;; These functions provide the ability to create dynamic menus to
443;; customize specific sections of an object. They do not hook directly
444;; into a filter, but can be used to create easymenu vectors.
445(defmethod eieio-customize-object-group ((obj eieio-default-superclass))
446 "Create a list of vectors for customizing sections of OBJ."
447 (mapcar (lambda (group)
448 (vector (concat "Group " (symbol-name group))
449 (list 'customize-object obj (list 'quote group))
450 t))
451 (class-option (object-class-fast obj) :custom-groups)))
452
453(defvar eieio-read-custom-group-history nil
454 "History for the custom group reader.")
455
456(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
457 "Do a completing read on the name of a customization group in OBJ.
458Return the symbol for the group, or nil"
459 (let ((g (class-option (object-class-fast obj) :custom-groups)))
460 (if (= (length g) 1)
461 (car g)
462 ;; Make the association list
463 (setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g))
464 (cdr (assoc
465 (completing-read (concat (oref obj name) " Custom Group: ")
466 g nil t nil 'eieio-read-custom-group-history)
467 g)))))
468
469(provide 'eieio-custom)
470
471;;; eieio-custom.el ends here
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
new file mode 100644
index 00000000000..f9ec56da7c1
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -0,0 +1,151 @@
1;;; eieio-datadebug.el --- EIEIO extensions to the data debugger.
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Keywords: OO, lisp
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; Extensions to data-debug for EIEIO objects.
26;;
27
28(require 'eieio)
29(require 'data-debug)
30
31;;; Code:
32
33(defun data-debug-insert-object-slots (object prefix)
34 "Insert all the slots of OBJECT.
35PREFIX specifies what to insert at the start of each line."
36 (let ((attrprefix (concat (make-string (length prefix) ? ) "] "))
37 )
38 (data-debug/eieio-insert-slots object attrprefix)
39 )
40 )
41
42(defun data-debug-insert-object-slots-from-point (point)
43 "Insert the object slots found at the object button at POINT."
44 (let ((object (get-text-property point 'ddebug))
45 (indent (get-text-property point 'ddebug-indent))
46 start
47 )
48 (end-of-line)
49 (setq start (point))
50 (forward-char 1)
51 (data-debug-insert-object-slots object
52 (concat (make-string indent ? )
53 "~ "))
54 (goto-char start)
55 ))
56
57(defun data-debug-insert-object-button (object prefix prebuttontext)
58 "Insert a button representing OBJECT.
59PREFIX is the text that preceeds the button.
60PREBUTTONTEXT is some text between PREFIX and the object button."
61 (let ((start (point))
62 (end nil)
63 (str (object-print object))
64 (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
65 (object-name-string object)
66 (object-class object)
67 (class-parents (object-class object))
68 (length (object-slots object))
69 ))
70 )
71 (insert prefix prebuttontext str)
72 (setq end (point))
73 (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face)
74 (put-text-property start end 'ddebug object)
75 (put-text-property start end 'ddebug-indent(length prefix))
76 (put-text-property start end 'ddebug-prefix prefix)
77 (put-text-property start end 'help-echo tip)
78 (put-text-property start end 'ddebug-function
79 'data-debug-insert-object-slots-from-point)
80 (insert "\n")
81 )
82 )
83
84;;; METHODS
85;;
86;; Each object should have an opportunity to show stuff about itself.
87
88(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
89 prefix)
90 "Insert the slots of OBJ into the current DDEBUG buffer."
91 (data-debug-insert-thing (object-name-string obj)
92 prefix
93 "Name: ")
94 (let* ((cl (object-class obj))
95 (cv (class-v cl)))
96 (data-debug-insert-thing (class-constructor cl)
97 prefix
98 "Class: ")
99 ;; Loop over all the public slots
100 (let ((publa (aref cv class-public-a))
101 (publd (aref cv class-public-d))
102 )
103 (while publa
104 (if (slot-boundp obj (car publa))
105 (let ((i (class-slot-initarg cl (car publa)))
106 (v (eieio-oref obj (car publa))))
107 (data-debug-insert-thing
108 v prefix (concat
109 (if i (symbol-name i)
110 (symbol-name (car publa)))
111 " ")))
112 ;; Unbound case
113 (let ((i (class-slot-initarg cl (car publa))))
114 (data-debug-insert-custom
115 "#unbound" prefix
116 (concat (if i (symbol-name i)
117 (symbol-name (car publa)))
118 " ")
119 'font-lock-keyword-face))
120 )
121 (setq publa (cdr publa) publd (cdr publd)))
122 )))
123
124;;; DEBUG METHODS
125;;
126;; A generic function to run DDEBUG on an object and popup a new buffer.
127;;
128(defmethod data-debug-show ((obj eieio-default-superclass))
129 "Run ddebug against any EIEIO object OBJ"
130 (data-debug-new-buffer (format "*%s DDEBUG*" (object-name obj)))
131 (data-debug-insert-object-slots obj "]"))
132
133;;; DEBUG FUNCTIONS
134;;
135(defun eieio-debug-methodinvoke (method class)
136 "Show the method invocation order for METHOD with CLASS object."
137 (interactive "aMethod: \nXClass Expression: ")
138 (let* ((eieio-pre-method-execution-hooks
139 (lambda (l) (throw 'moose l) ))
140 (data
141 (catch 'moose (eieio-generic-call
142 method (list class))))
143 (buf (data-debug-new-buffer "*Method Invocation*"))
144 (data2 (mapcar (lambda (sym)
145 (symbol-function (car sym)))
146 data)))
147 (data-debug-insert-thing data2 ">" "")))
148
149(provide 'eieio-datadebug)
150
151;;; eieio-datadebug.el ends here
diff --git a/lisp/emacs-lisp/eieio-doc.el b/lisp/emacs-lisp/eieio-doc.el
new file mode 100644
index 00000000000..35de848c51c
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-doc.el
@@ -0,0 +1,368 @@
1;;; eieio-doc.el --- create texinfo documentation for an eieio class
2
3;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2004, 2005
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: OO, lisp, docs
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26;;
27;; Outputs into the current buffer documentation in texinfo format
28
29(require 'eieio-opt)
30
31;; for a class, all it's children, and all it's slots.
32
33;;; Code:
34(defvar eieiodoc-currently-in-node nil
35 "String representing the node we go BACK to.")
36
37(defvar eieiodoc-current-section-level nil
38 "String represending what type of section header to use.")
39
40(defvar eieiodoc-prev-class nil
41 "Non-nil when while `eieiodoc-recurse' is running.
42Can be referenced from the recursed function.")
43
44(defvar eieiodoc-next-class nil
45 "Non-nil when `eieiodoc-recurse' is running.
46Can be referenced from the recursed function.")
47
48(defun eieiodoc-class-nuke (root-class indexstring &optional skiplist)
49 "Call `eieiodoc-class' after nuking everything from POINT on.
50ROOT-CLASS, INDEXSTRING, and SKIPLIST are the same as `eieiodoc-class'."
51 (delete-region (point) (point-max))
52 (sit-for 0)
53 (eieiodoc-class root-class indexstring skiplist))
54
55(defvar eieiodoc--class-indexstring)
56(defvar eieiodoc--class-root)
57
58(defun eieiodoc-class (root-class indexstring &optional skiplist)
59 "Create documentation starting with ROOT-CLASS.
60The first job is to create an indented menu of all the classes
61starting with `root-class' and including all it's children. Once this
62is done, @nodes are created for all the subclasses. Each node is then
63documented with a description of the class, a brief inheritance tree
64\(with xrefs) and a list of all slots in a big table. Where each slot
65is inherited from is also documented. In addition, each class is
66documented in the index referenced by INDEXSTRING, a two letter code
67described in the texinfo manual.
68
69The optional third argument SKIPLIST is a list of object not to put
70into any menus, nodes or lists."
71 (interactive
72 (list (intern-soft
73 (completing-read "Class: " (eieio-build-class-alist) nil t))
74 (read-string "Index name (2 chars): ")))
75 (if (looking-at "[ \t\n]+@end ignore")
76 (goto-char (match-end 0)))
77 (save-excursion
78 (setq eieiodoc-currently-in-node
79 (if (re-search-backward "@node \\([^,]+\\)" nil t)
80 (buffer-substring (match-beginning 1) (match-end 1))
81 "Top")
82 eieiodoc-current-section-level
83 (if (re-search-forward "@\\(chapter\\|\\(sub\\)*section\\)"
84 (+ (point) 500) t)
85 (progn
86 (goto-char (match-beginning 0))
87 (cond ((looking-at "@chapter") "section")
88 ((looking-at "@section") "subsection")
89 ((looking-at "@\\(sub\\)+section") "subsubsection")
90 (t "subsubsection")))
91 "subsubsection")))
92 (save-excursion
93 (eieiodoc-main-menu root-class skiplist)
94 (insert "\n")
95 (let ((eieiodoc--class-indexstring indexstring)
96 (eieiodoc--class-root root-class))
97 (eieiodoc-recurse root-class 'eieiodoc-one-node nil skiplist))))
98
99(defun eieiodoc-main-menu (class skiplist)
100 "Create a menu of all classes under CLASS indented the correct amount.
101SKIPLIST is a list of objects to skip"
102 (end-of-line)
103 (insert "\n@menu\n")
104 (eieiodoc-recurse class (lambda (class level)
105 (insert "* " (make-string level ? )
106 (symbol-name class) " ::\n"))
107 nil skiplist)
108 (insert "@end menu\n"))
109
110(defun eieiodoc-one-node (class level)
111 "Create a node for CLASS, and for all subclasses of CLASS in order.
112This function should only be called by `eieiodoc-class'
113Argument LEVEL is the current level of recursion we have hit."
114 (message "Building node for %s" class)
115 (insert "\n@node " (symbol-name class) ", "
116 (if eieiodoc-next-class (symbol-name eieiodoc-next-class) " ") ", "
117 (if eieiodoc-prev-class (symbol-name eieiodoc-prev-class) " ") ", "
118 eieiodoc-currently-in-node "\n"
119 "@comment node-name, next, previous, up\n"
120 "@" eieiodoc-current-section-level " " (symbol-name class) "\n"
121 "@" eieiodoc--class-indexstring
122 "index " (symbol-name class) "\n\n")
123 ;; Now lets create a nifty little inheritance tree
124 (let ((cl class)
125 (revlist nil)
126 (depth 0))
127 (while cl
128 (setq revlist (cons cl revlist)
129 cl (class-parent cl)))
130 (insert "@table @asis\n@item Inheritance Tree:\n")
131 (while revlist
132 (insert "@table @code\n@item "
133 (if (and (child-of-class-p (car revlist) eieiodoc--class-root)
134 (not (eq class (car revlist))))
135 (concat "@w{@xref{" (symbol-name (car revlist)) "}.}")
136 (symbol-name (car revlist)))
137 "\n")
138 (setq revlist (cdr revlist)
139 depth (1+ depth)))
140 (let ((clist (reverse (aref (class-v class) class-children))))
141 (if (not clist)
142 (insert "No children")
143 (insert "@table @asis\n@item Children:\n")
144 (while clist
145 (insert "@w{@xref{" (symbol-name (car clist)) "}")
146 (if (cdr clist) (insert ",") (insert "."))
147 (insert "} ")
148 (setq clist (cdr clist)))
149 (insert "\n@end table\n")
150 ))
151 (while (> depth 0)
152 (insert "\n@end table\n")
153 (setq depth (1- depth)))
154 (insert "@end table\n\n "))
155 ;; Now lets build some documentation by extracting information from
156 ;; the class description vector
157 (let* ((cv (class-v class))
158 (docs (aref cv class-public-doc))
159 (names (aref cv class-public-a))
160 (deflt (aref cv class-public-d))
161 (prot (aref cv class-protection))
162 (typev (aref cv class-public-type))
163 (i 0)
164 (set-one nil)
165 (anchor nil)
166 )
167 ;; doc of the class itself
168 (insert (eieiodoc-texify-docstring (documentation class) class)
169 "\n\n@table @asis\n")
170 (if names
171 (progn
172 (setq anchor (point))
173 (insert "@item Slots:\n\n@table @code\n")
174 (while names
175 (if (eieiodoc-one-attribute class (car names) (car docs)
176 (car prot) (car deflt) (aref typev i))
177 (setq set-one t))
178 (setq names (cdr names)
179 docs (cdr docs)
180 prot (cdr prot)
181 deflt (cdr deflt)
182 i (1+ i)))
183 (insert "@end table\n\n")
184 (if (not set-one) (delete-region (point) anchor))
185 ))
186 (insert "@end table\n")
187 ;; Finally, document all the methods associated with this class.
188 (let ((methods (eieio-all-generic-functions class))
189 (doc nil))
190 (if (not methods) nil
191 (if (string= eieiodoc-current-section-level "subsubsection")
192 (insert "@" eieiodoc-current-section-level)
193 (insert "@sub" eieiodoc-current-section-level))
194 (insert " Specialized Methods\n\n")
195 (while methods
196 (setq doc (eieio-method-documentation (car methods) class))
197 (insert "@deffn Method " (symbol-name (car methods)))
198 (if (not doc)
199 (insert "\n Undocumented")
200 (if (car doc)
201 (progn
202 (insert " :BEFORE ")
203 (eieiodoc-output-deffn-args (car (car doc)))
204 (insert "\n")
205 (eieiodoc-insert-and-massage-docstring-with-args
206 (cdr (car doc)) (car (car doc)) class)))
207 (setq doc (cdr doc))
208 (if (car doc)
209 (progn
210 (insert " :PRIMARY ")
211 (eieiodoc-output-deffn-args (car (car doc)))
212 (insert "\n")
213 (eieiodoc-insert-and-massage-docstring-with-args
214 (cdr (car doc)) (car (car doc)) class)))
215 (setq doc (cdr doc))
216 (if (car doc)
217 (progn
218 (insert " :AFTER ")
219 (eieiodoc-output-deffn-args (car (car doc)))
220 (insert "\n")
221 (eieiodoc-insert-and-massage-docstring-with-args
222 (cdr (car doc)) (car (car doc)) class)))
223 (insert "\n@end deffn\n\n"))
224 (setq methods (cdr methods)))))
225 ))
226
227(defun eieiodoc-insert-and-massage-docstring-with-args (doc arglst class)
228 "Update DOC with texinfo strings using ARGLST with @var.
229Argument CLASS is the class passed to `eieiodoc-texify-docstring'."
230 (let ((start (point))
231 (end nil)
232 (case-fold-search nil))
233 ;; Insert the text
234 (insert (eieiodoc-texify-docstring doc class))
235 (setq end (point))
236 (save-restriction
237 (narrow-to-region start end)
238 (save-excursion
239 ;; Now find arguments
240 (while arglst
241 (goto-char (point-min))
242 (while (re-search-forward (upcase (symbol-name (car arglst))) nil t)
243 (replace-match "@var{\\&}" t))
244 (setq arglst (cdr arglst)))))))
245
246(defun eieiodoc-output-deffn-args (arglst)
247 "Output ARGLST for a deffn."
248 (while arglst
249 (insert (symbol-name (car arglst)) " ")
250 (setq arglst (cdr arglst))))
251
252(defun eieiodoc-one-attribute (class attribute doc priv deflt type)
253 "Create documentation of CLASS for a single ATTRIBUTE.
254Assume this attribute is inside a table, so it is initiated with the
255@item indicator. If this attribute is not inserted (because it is
256contained in the parent) then return nil, else return t.
257DOC is the documentation to use, PRIV is non-nil if it is a private slot,
258and DEFLT is the default value. TYPE is the symbol describing what type
259validation is done on that slot."
260 (let ((pv (eieiodoc-parent-diff class attribute))
261 (ia (eieio-attribute-to-initarg class attribute))
262 (set-me nil))
263 (if (or (eq pv t) (not ia))
264 nil ;; same in parent or no init arg
265 (setq set-me t)
266 (insert "@item " (if priv "Private: " "")
267 (symbol-name ia))
268 (if (and type (not (eq type t)))
269 (insert "\nType: @code{" (format "%S" type) "}"))
270 (if (not (eq deflt eieio-unbound))
271 (insert " @*\nDefault Value: @code{"(format "%S" deflt) "}"))
272 (insert "\n\n")
273 (if (eq pv 'default)
274 ;; default differs only, xref the parent
275 ;; This should be upgraded to actually search for the last
276 ;; differing default (or the original.)
277 (insert "@xref{" (symbol-name (class-parent class)) "}.\n")
278 (insert (if doc (eieiodoc-texify-docstring doc class) "Not Documented")
279 "\n@refill\n\n")))
280 set-me))
281;;;
282;; Utilities
283;;
284(defun eieiodoc-recurse (rclass func &optional level skiplist)
285 "Recurse down all children of RCLASS, calling FUNC on each one.
286LEVEL indicates the current depth below the first call we are. The
287function FUNC will be called with RCLASS and LEVEL. This will then
288recursivly call itself once for each child class of RCLASS. The
289optional fourth argument SKIPLIST is a list of objects to ignore while
290recursing."
291
292 (if (not level) (setq level 0))
293
294 ;; we reverse the children so they appear in the same order as it
295 ;; does in the code that creates them.
296 (let* ((children (reverse (aref (class-v rclass) class-children)))
297 (ocnc eieiodoc-next-class)
298 (eieiodoc-next-class (or (car children) ocnc))
299 (eieiodoc-prev-class eieiodoc-prev-class))
300
301 (if (not (member rclass skiplist))
302 (progn
303 (apply func (list rclass level))
304
305 (setq eieiodoc-prev-class rclass)))
306
307 (while children
308 (setq eieiodoc-next-class (or (car (cdr children)) ocnc))
309 (setq eieiodoc-prev-class (eieiodoc-recurse (car children) func (1+ level)))
310 (setq children (cdr children)))
311 ;; return the previous class so that the prev/next node gets it right
312 eieiodoc-prev-class))
313
314(defun eieiodoc-parent-diff (class slot)
315 "Return nil if the parent of CLASS does not have slot SLOT.
316Return t if it does, and return 'default if the default has changed."
317 (let ((df nil) (err t)
318 (scoped-class (class-parent class))
319 (eieio-skip-typecheck))
320 (condition-case nil
321 (setq df (eieio-oref-default (class-parent class) slot)
322 err nil)
323 (invalid-slot-name (setq df nil))
324 (error (setq df nil)))
325 (if err
326 nil
327 (if (equal df (eieio-oref-default class slot))
328 t
329 'default))))
330
331(defun eieiodoc-texify-docstring (string class)
332 "Take STRING, (a normal doc string), and convert it into a texinfo string.
333For instances where CLASS is the class being referenced, do not Xref
334that class.
335
336 `function' => @dfn{function}
337 `variable' => @code{variable}
338 `class' => @code{class} @xref{class}
339 `unknown' => @code{unknonwn}
340 'quoteme => @code{quoteme}
341 non-nil => non-@code{nil}
342 t => @code{t}
343 :tag => @code{:tag}
344 [ stuff ] => @code{[ stuff ]}
345 Key => @kbd{Key}"
346 (while (string-match "`\\([-a-zA-Z0-9]+\\)'" string)
347 (let* ((vs (substring string (match-beginning 1) (match-end 1)))
348 (v (intern-soft vs)))
349 (setq string
350 (concat
351 (replace-match (concat
352 (if (and (not (class-p v))(fboundp v))
353 "@dfn{" "@code{")
354 vs "}"
355 (if (and (class-p v) (not (eq v class)))
356 (concat " @xref{" vs "}.")))
357 nil t string)))))
358 (while (string-match "\\( \\|^\\|-\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([ ,]\\|$\\)" string)
359 (setq string (replace-match "@code{\\2}" t nil string 2)))
360 (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string)
361 (setq string (replace-match "@code{\\2}" t nil string 2)))
362 (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|$\\)" string)
363 (setq string (replace-match "@kbd{\\2}" t nil string 2)))
364 string)
365
366(provide 'eieio-doc)
367
368;;; eieio-doc.el ends here
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
new file mode 100644
index 00000000000..db39909c998
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -0,0 +1,699 @@
1;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
2
3;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005,
4;;; 2008, 2009 Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: OO, lisp
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26;;
27;; This contains support functions to eieio. These functions contain
28;; some small class browser and class printing functions.
29;;
30
31(require 'eieio)
32
33;;; Code:
34(defun eieio-browse (&optional root-class)
35 "Create an object browser window to show all objects.
36If optional ROOT-CLASS, then start with that, otherwise start with
37variable `eieio-default-superclass'."
38 (interactive (if current-prefix-arg
39 (list (read (completing-read "Class: "
40 (eieio-build-class-alist)
41 nil t)))
42 nil))
43 (if (not root-class) (setq root-class 'eieio-default-superclass))
44 (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class)))
45 (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
46 (save-excursion
47 (set-buffer (get-buffer "*EIEIO OBJECT BROWSE*"))
48 (erase-buffer)
49 (goto-char 0)
50 (eieio-browse-tree root-class "" "")
51 ))
52
53(defun eieio-browse-tree (this-root prefix ch-prefix)
54 "Recursively, draws the children of the given class on the screen.
55Argument THIS-ROOT is the local root of the tree.
56Argument PREFIX is the character prefix to use.
57Argument CH-PREFIX is another character prefix to display."
58 (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root)))
59 (let ((myname (symbol-name this-root))
60 (chl (aref (class-v this-root) class-children))
61 (fprefix (concat ch-prefix " +--"))
62 (mprefix (concat ch-prefix " | "))
63 (lprefix (concat ch-prefix " ")))
64 (insert prefix myname "\n")
65 (while (cdr chl)
66 (eieio-browse-tree (car chl) fprefix mprefix)
67 (setq chl (cdr chl)))
68 (if chl
69 (eieio-browse-tree (car chl) fprefix lprefix))
70 ))
71
72;;; CLASS COMPLETION / DOCUMENTATION
73;;;###autoload
74(defalias 'describe-class 'eieio-describe-class)
75;;;###autoload
76(defun eieio-describe-class (class &optional headerfcn)
77 "Describe a CLASS defined by a string or symbol.
78If CLASS is actually an object, then also display current values of that obect.
79Optional HEADERFCN should be called to insert a few bits of info first."
80 (interactive (list (eieio-read-class "Class: ")))
81 (with-output-to-temp-buffer (help-buffer) ;"*Help*"
82 (help-setup-xref (list #'eieio-describe-class class headerfcn)
83 (interactive-p))
84
85 (when headerfcn (funcall headerfcn))
86
87 (if (class-option class :abstract)
88 (princ "Abstract "))
89 (princ "Class ")
90 (prin1 class)
91 (terpri)
92 ;; Inheritence tree information
93 (let ((pl (class-parents class)))
94 (when pl
95 (princ " Inherits from ")
96 (while pl
97 (princ "`") (prin1 (car pl)) (princ "'")
98 (setq pl (cdr pl))
99 (if pl (princ ", ")))
100 (terpri)))
101 (let ((ch (class-children class)))
102 (when ch
103 (princ " Children ")
104 (while ch
105 (princ "`") (prin1 (car ch)) (princ "'")
106 (setq ch (cdr ch))
107 (if ch (princ ", ")))
108 (terpri)))
109 (terpri)
110 ;; System documentation
111 (let ((doc (documentation-property class 'variable-documentation)))
112 (when doc
113 (princ "Documentation:")
114 (terpri)
115 (princ doc)
116 (terpri)
117 (terpri)))
118 ;; Describe all the slots in this class
119 (eieio-describe-class-slots class)
120 ;; Describe all the methods specific to this class.
121 (let ((methods (eieio-all-generic-functions class))
122 (doc nil))
123 (if (not methods) nil
124 (princ "Specialized Methods:")
125 (terpri)
126 (terpri)
127 (while methods
128 (setq doc (eieio-method-documentation (car methods) class))
129 (princ "`")
130 (prin1 (car methods))
131 (princ "'")
132 (if (not doc)
133 (princ " Undocumented")
134 (if (car doc)
135 (progn
136 (princ " :STATIC ")
137 (prin1 (car (car doc)))
138 (terpri)
139 (princ (cdr (car doc)))))
140 (setq doc (cdr doc))
141 (if (car doc)
142 (progn
143 (princ " :BEFORE ")
144 (prin1 (car (car doc)))
145 (terpri)
146 (princ (cdr (car doc)))))
147 (setq doc (cdr doc))
148 (if (car doc)
149 (progn
150 (princ " :PRIMARY ")
151 (prin1 (car (car doc)))
152 (terpri)
153 (princ (cdr (car doc)))))
154 (setq doc (cdr doc))
155 (if (car doc)
156 (progn
157 (princ " :AFTER ")
158 (prin1 (car (car doc)))
159 (terpri)
160 (princ (cdr (car doc)))))
161 (terpri)
162 (terpri))
163 (setq methods (cdr methods))))))
164 (save-excursion
165 (set-buffer (help-buffer))
166 (buffer-string)))
167
168(defun eieio-describe-class-slots (class)
169 "Describe the slots in CLASS.
170Outputs to the standard output."
171 (let* ((cv (class-v class))
172 (docs (aref cv class-public-doc))
173 (names (aref cv class-public-a))
174 (deflt (aref cv class-public-d))
175 (types (aref cv class-public-type))
176 (publp (aref cv class-public-printer))
177 (i 0)
178 (prot (aref cv class-protection))
179 )
180 (princ "Instance Allocated Slots:")
181 (terpri)
182 (terpri)
183 (while names
184 (if (car prot) (princ "Private "))
185 (princ "Slot: ")
186 (prin1 (car names))
187 (when (not (eq (aref types i) t))
188 (princ " type = ")
189 (prin1 (aref types i)))
190 (unless (eq (car deflt) eieio-unbound)
191 (princ " default = ")
192 (prin1 (car deflt)))
193 (when (car publp)
194 (princ " printer = ")
195 (prin1 (car publp)))
196 (when (car docs)
197 (terpri)
198 (princ " ")
199 (princ (car docs))
200 (terpri))
201 (terpri)
202 (setq names (cdr names)
203 docs (cdr docs)
204 deflt (cdr deflt)
205 publp (cdr publp)
206 prot (cdr prot)
207 i (1+ i)))
208 (setq docs (aref cv class-class-allocation-doc)
209 names (aref cv class-class-allocation-a)
210 types (aref cv class-class-allocation-type)
211 i 0
212 prot (aref cv class-class-allocation-protection))
213 (when names
214 (terpri)
215 (princ "Class Allocated Slots:"))
216 (terpri)
217 (terpri)
218 (while names
219 (when (car prot)
220 (princ "Private "))
221 (princ "Slot: ")
222 (prin1 (car names))
223 (unless (eq (aref types i) t)
224 (princ " type = ")
225 (prin1 (aref types i)))
226 (condition-case nil
227 (let ((value (eieio-oref class (car names))))
228 (princ " value = ")
229 (prin1 value))
230 (error nil))
231 (when (car docs)
232 (terpri)
233 (princ " ")
234 (princ (car docs))
235 (terpri))
236 (terpri)
237 (setq names (cdr names)
238 docs (cdr docs)
239 prot (cdr prot)
240 i (1+ i)))))
241
242(defun eieio-describe-constructor (fcn)
243 "Describe the constructor function FCN.
244Uses `eieio-describe-class' to describe the class being constructed."
245 (interactive
246 ;; Use eieio-read-class since all constructors have the same name as
247 ;; the class they create.
248 (list (eieio-read-class "Class: ")))
249 (eieio-describe-class
250 fcn (lambda ()
251 ;; Describe the constructor part.
252 (princ "Object Constructor Function: ")
253 (prin1 fcn)
254 (terpri)
255 (princ "Creates an object of class ")
256 (prin1 fcn)
257 (princ ".")
258 (terpri)
259 (terpri)
260 ))
261 )
262
263(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
264 "Return an alist of all currently active classes for completion purposes.
265Optional argument CLASS is the class to start with.
266If INSTANTIABLE-ONLY is non nil, only allow names of classes which
267are not abstract, otherwise allow all classes.
268Optional argument BUILDLIST is more list to attach and is used internally."
269 (let* ((cc (or class eieio-default-superclass))
270 (sublst (aref (class-v cc) class-children)))
271 (if (or (not instantiable-only) (not (class-abstract-p cc)))
272 (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))
273 (while sublst
274 (setq buildlist (eieio-build-class-alist
275 (car sublst) instantiable-only buildlist))
276 (setq sublst (cdr sublst)))
277 buildlist))
278
279(defvar eieio-read-class nil
280 "History of the function `eieio-read-class' prompt.")
281
282(defun eieio-read-class (prompt &optional histvar instantiable-only)
283 "Return a class chosen by the user using PROMPT.
284Optional argument HISTVAR is a variable to use as history.
285If INSTANTIABLE-ONLY is non nil, only allow names of classes which
286are not abstract."
287 (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only)
288 nil t nil
289 (or histvar 'eieio-read-class))))
290
291(defun eieio-read-subclass (prompt class &optional histvar instantiable-only)
292 "Return a class chosen by the user using PROMPT.
293CLASS is the base class, and completion occurs across all subclasses.
294Optional argument HISTVAR is a variable to use as history.
295If INSTANTIABLE-ONLY is non nil, only allow names of classes which
296are not abstract."
297 (intern (completing-read prompt
298 (eieio-build-class-alist class instantiable-only)
299 nil t nil
300 (or histvar 'eieio-read-class))))
301
302;;; METHOD COMPLETION / DOC
303;;
304;;;###autoload
305(defalias 'describe-method 'eieio-describe-generic)
306;;;###autoload
307(defalias 'describe-generic 'eieio-describe-generic)
308;;;###autoload
309(defalias 'eieio-describe-method 'eieio-describe-generic)
310;;;###autoload
311(defun eieio-describe-generic (generic)
312 "Describe the generic function GENERIC.
313Also extracts information about all methods specific to this generic."
314 (interactive (list (eieio-read-generic "Generic Method: ")))
315 (if (not (generic-p generic))
316 (signal 'wrong-type-argument '(generic-p generic)))
317 (with-output-to-temp-buffer (help-buffer) ; "*Help*"
318 (help-setup-xref (list #'eieio-describe-generic generic) (interactive-p))
319
320 (prin1 generic)
321 (princ " is a generic function")
322 (when (generic-primary-only-p generic)
323 (princ " with only ")
324 (when (generic-primary-only-one-p generic)
325 (princ "one "))
326 (princ "primary method")
327 (when (not (generic-primary-only-one-p generic))
328 (princ "s"))
329 )
330 (princ ".")
331 (terpri)
332 (terpri)
333 (let ((d (documentation generic)))
334 (if (not d)
335 (princ "The generic is not documented.\n")
336 (princ "Documentation:")
337 (terpri)
338 (princ d)
339 (terpri)
340 (terpri)))
341 (princ "Implementations:")
342 (terpri)
343 (terpri)
344 (let ((i 3)
345 (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
346 ;; Loop over fanciful generics
347 (while (< i 6)
348 (let ((gm (aref (get generic 'eieio-method-tree) i)))
349 (when gm
350 (princ "Generic ")
351 (princ (aref prefix (- i 3)))
352 (terpri)
353 (princ (or (nth 2 gm) "Undocumented"))
354 (terpri)
355 (terpri)))
356 (setq i (1+ i)))
357 (setq i 0)
358 ;; Loop over defined class-specific methods
359 (while (< i 3)
360 (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))))
361 (while gm
362 (princ "`")
363 (prin1 (car (car gm)))
364 (princ "'")
365 ;; prefix type
366 (princ " ")
367 (princ (aref prefix i))
368 (princ " ")
369 ;; argument list
370 (let* ((func (cdr (car gm)))
371 (arglst (eieio-lambda-arglist func)))
372 (prin1 arglst))
373 (terpri)
374 ;; 3 because of cdr
375 (princ (or (documentation (cdr (car gm)))
376 "Undocumented"))
377 (setq gm (cdr gm))
378 (terpri)
379 (terpri)))
380 (setq i (1+ i)))))
381 (save-excursion
382 (set-buffer (help-buffer))
383 (buffer-string)))
384
385(defun eieio-lambda-arglist (func)
386 "Return the argument list of FUNC, a function body."
387 (if (symbolp func) (setq func (symbol-function func)))
388 (if (byte-code-function-p func)
389 (eieio-compiled-function-arglist func)
390 (car (cdr func))))
391
392(defun eieio-all-generic-functions (&optional class)
393 "Return a list of all generic functions.
394Optional CLASS argument returns only those functions that contain methods for CLASS."
395 (let ((l nil) tree (cn (if class (symbol-name class) nil)))
396 (mapatoms
397 (lambda (symbol)
398 (setq tree (get symbol 'eieio-method-obarray))
399 (if tree
400 (progn
401 ;; A symbol might be interned for that class in one of
402 ;; these three slots in the method-obarray.
403 (if (or (not class)
404 (fboundp (intern-soft cn (aref tree 0)))
405 (fboundp (intern-soft cn (aref tree 1)))
406 (fboundp (intern-soft cn (aref tree 2))))
407 (setq l (cons symbol l)))))))
408 l))
409
410(defun eieio-method-documentation (generic class)
411 "Return a list of the specific documentation of GENERIC for CLASS.
412If there is not an explicit method for CLASS in GENERIC, or if that
413function has no documentation, then return nil."
414 (let ((tree (get generic 'eieio-method-obarray))
415 (cn (symbol-name class))
416 before primary after)
417 (if (not tree)
418 nil
419 ;; A symbol might be interned for that class in one of
420 ;; these three slots in the method-obarray.
421 (setq before (intern-soft cn (aref tree 0))
422 primary (intern-soft cn (aref tree 1))
423 after (intern-soft cn (aref tree 2)))
424 (if (not (or (fboundp before)
425 (fboundp primary)
426 (fboundp after)))
427 nil
428 (list (if (fboundp before)
429 (cons (eieio-lambda-arglist before)
430 (documentation before))
431 nil)
432 (if (fboundp primary)
433 (cons (eieio-lambda-arglist primary)
434 (documentation primary))
435 nil)
436 (if (fboundp after)
437 (cons (eieio-lambda-arglist after)
438 (documentation after))
439 nil))))))
440
441(defvar eieio-read-generic nil
442 "History of the `eieio-read-generic' prompt.")
443
444(defun eieio-read-generic-p (fn)
445 "Function used in function `eieio-read-generic'.
446This is because `generic-p' is a macro.
447Argument FN is the function to test."
448 (generic-p fn))
449
450(defun eieio-read-generic (prompt &optional historyvar)
451 "Read a generic function from the minibuffer with PROMPT.
452Optional argument HISTORYVAR is the variable to use as history."
453 (intern (completing-read prompt obarray 'eieio-read-generic-p
454 t nil (or historyvar 'eieio-read-generic))))
455
456;;; METHOD STATS
457;;
458;; Dump out statistics about all the active methods in a session.
459(defun eieio-display-method-list ()
460 "Display a list of all the methods and what features are used."
461 (interactive)
462 (let* ((meth1 (eieio-all-generic-functions))
463 (meth (sort meth1 (lambda (a b)
464 (string< (symbol-name a)
465 (symbol-name b)))))
466 (buff (get-buffer-create "*EIEIO Method List*"))
467 (methidx 0)
468 (standard-output buff)
469 (slots '(method-static
470 method-before
471 method-primary
472 method-after
473 method-generic-before
474 method-generic-primary
475 method-generic-after))
476 (slotn '("static"
477 "before"
478 "primary"
479 "after"
480 "G bef"
481 "G prim"
482 "G aft"))
483 (idxarray (make-vector (length slots) 0))
484 (primaryonly 0)
485 (oneprimary 0)
486 )
487 (switch-to-buffer-other-window buff)
488 (erase-buffer)
489 (dolist (S slotn)
490 (princ S)
491 (princ "\t")
492 )
493 (princ "Method Name")
494 (terpri)
495 (princ "--------------------------------------------------------------------")
496 (terpri)
497 (dolist (M meth)
498 (let ((mtree (get M 'eieio-method-tree))
499 (P nil) (numP)
500 (!P nil))
501 (dolist (S slots)
502 (let ((num (length (aref mtree (symbol-value S)))))
503 (aset idxarray (symbol-value S)
504 (+ num (aref idxarray (symbol-value S))))
505 (prin1 num)
506 (princ "\t")
507 (when (< 0 num)
508 (if (eq S 'method-primary)
509 (setq P t numP num)
510 (setq !P t)))
511 ))
512 ;; Is this a primary-only impl method?
513 (when (and P (not !P))
514 (setq primaryonly (1+ primaryonly))
515 (when (= numP 1)
516 (setq oneprimary (1+ oneprimary))
517 (princ "*"))
518 (princ "* ")
519 )
520 (prin1 M)
521 (terpri)
522 (setq methidx (1+ methidx))
523 )
524 )
525 (princ "--------------------------------------------------------------------")
526 (terpri)
527 (dolist (S slots)
528 (prin1 (aref idxarray (symbol-value S)))
529 (princ "\t")
530 )
531 (prin1 methidx)
532 (princ " Total symbols")
533 (terpri)
534 (dolist (S slotn)
535 (princ S)
536 (princ "\t")
537 )
538 (terpri)
539 (terpri)
540 (princ "Methods Primary Only: ")
541 (prin1 primaryonly)
542 (princ "\t")
543 (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100)))
544 (princ "% of total methods")
545 (terpri)
546 (princ "Only One Primary Impl: ")
547 (prin1 oneprimary)
548 (princ "\t")
549 (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100)))
550 (princ "% of total primary methods")
551 (terpri)
552 ))
553
554;;; HELP AUGMENTATION
555;;
556(defun eieio-help-mode-augmentation-maybee (&rest unused)
557 "For buffers thrown into help mode, augment for eieio.
558Arguments UNUSED are not used."
559 ;; Scan created buttons so far if we are in help mode.
560 (when (eq major-mode 'help-mode)
561 (save-excursion
562 (goto-char (point-min))
563 (let ((pos t) (inhibit-read-only t))
564 (while pos
565 (if (get-text-property (point) 'help-xref) ; move off reference
566 (goto-char
567 (or (next-single-property-change (point) 'help-xref)
568 (point))))
569 (setq pos (next-single-property-change (point) 'help-xref))
570 (when pos
571 (goto-char pos)
572 (let* ((help-data (get-text-property (point) 'help-xref))
573 ;(method (car help-data))
574 (args (cdr help-data)))
575 (when (symbolp (car args))
576 (cond ((class-p (car args))
577 (setcar help-data 'eieio-describe-class))
578 ((generic-p (car args))
579 (setcar help-data 'eieio-describe-generic))
580 (t nil))
581 ))))
582 ;; start back at the beginning, and highlight some sections
583 (goto-char (point-min))
584 (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t)
585 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
586 (goto-char (point-min))
587 (if (re-search-forward "^Specialized Methods:$" nil t)
588 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
589 (goto-char (point-min))
590 (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t)
591 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
592 (goto-char (point-min))
593 (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t)
594 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
595 (goto-char (point-min))
596 (while (re-search-forward "^\\(Private \\)?Slot:" nil t)
597 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
598 ))))
599
600;;; SPEEDBAR SUPPORT
601;;
602(eval-when-compile
603 (condition-case nil
604 (require 'speedbar)
605 (error (message "Error loading speedbar... ignored."))))
606
607(defvar eieio-class-speedbar-key-map nil
608 "Keymap used when working with a project in speedbar.")
609
610(defun eieio-class-speedbar-make-map ()
611 "Make a keymap for eieio under speedbar."
612 (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap))
613
614 ;; General viewing stuff
615 (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line)
616 (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line)
617 (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line)
618 )
619
620(if eieio-class-speedbar-key-map
621 nil
622 (if (not (featurep 'speedbar))
623 (add-hook 'speedbar-load-hook (lambda ()
624 (eieio-class-speedbar-make-map)
625 (speedbar-add-expansion-list
626 '("EIEIO"
627 eieio-class-speedbar-menu
628 eieio-class-speedbar-key-map
629 eieio-class-speedbar))))
630 (eieio-class-speedbar-make-map)
631 (speedbar-add-expansion-list '("EIEIO"
632 eieio-class-speedbar-menu
633 eieio-class-speedbar-key-map
634 eieio-class-speedbar))))
635
636(defvar eieio-class-speedbar-menu
637 ()
638 "Menu part in easymenu format used in speedbar while in `eieio' mode.")
639
640(defun eieio-class-speedbar (dir-or-object depth)
641 "Create buttons in speedbar that represents the current project.
642DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current
643expansion depth."
644 (when (eq (point-min) (point-max))
645 ;; This function is only called once, to start the whole deal.
646 ;; Ceate, and expand the default object.
647 (eieio-class-button eieio-default-superclass 0)
648 (forward-line -1)
649 (speedbar-expand-line)))
650
651(defun eieio-class-button (class depth)
652 "Draw a speedbar button at the current point for CLASS at DEPTH."
653 (if (not (class-p class))
654 (signal 'wrong-type-argument (list 'class-p class)))
655 (let ((subclasses (aref (class-v class) class-children)))
656 (if subclasses
657 (speedbar-make-tag-line 'angle ?+
658 'eieio-sb-expand
659 class
660 (symbol-name class)
661 'eieio-describe-class-sb
662 class
663 'speedbar-directory-face
664 depth)
665 (speedbar-make-tag-line 'angle ? nil nil
666 (symbol-name class)
667 'eieio-describe-class-sb
668 class
669 'speedbar-directory-face
670 depth))))
671
672(defun eieio-sb-expand (text class indent)
673 "For button TEXT, expand CLASS at the current location.
674Argument INDENT is the depth of indentation."
675 (cond ((string-match "+" text) ;we have to expand this file
676 (speedbar-change-expand-button-char ?-)
677 (speedbar-with-writable
678 (save-excursion
679 (end-of-line) (forward-char 1)
680 (let ((subclasses (aref (class-v class) class-children)))
681 (while subclasses
682 (eieio-class-button (car subclasses) (1+ indent))
683 (setq subclasses (cdr subclasses)))))))
684 ((string-match "-" text) ;we have to contract this node
685 (speedbar-change-expand-button-char ?+)
686 (speedbar-delete-subblock indent))
687 (t (error "Ooops... not sure what to do")))
688 (speedbar-center-buffer-smartly))
689
690(defun eieio-describe-class-sb (text token indent)
691 "Describe the class TEXT in TOKEN.
692INDENT is the current indentation level."
693 (speedbar-with-attached-buffer
694 (eieio-describe-class token))
695 (speedbar-maybee-jump-to-attached-frame))
696
697(provide 'eieio-opt)
698
699;;; eieio-opt.el ends here
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
new file mode 100644
index 00000000000..c6738f898ec
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -0,0 +1,424 @@
1;;; eieio-speedbar.el -- Classes for managing speedbar displays.
2
3;;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008 Free
4;;; Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: OO, tools
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26;;
27;; This provides some classes that can be used as a parent which
28;; will automatically provide SPEEDBAR support for any list of objects
29;; of that type.
30;;
31;; This file requires speedbar version 0.10 or later.
32
33;;; Creating a new speedbar mode based on a pre-existing object hierarchy
34;;
35;; To create a new speedbar mode based on lists of objects is easier
36;; than creating a whole new speedbar mode from scratch.
37;;
38;; 1) Objects that will have lists of items that can be expanded
39;; should also inherit from the classes:
40;; * `eieio-speedbar' - specify your own button behavior
41;; * `eieio-speedbar-directory-button' - objects that behave like directories
42;; * `eieio-speedbar-file-button' - objects that behave like files
43;;
44;; 2) Objects that have lists of children should implement the method
45;; `eieio-speedbar-object-children' which returns a list of more
46;; objects, or a list of strings.
47;;
48;; 3) Objects that return a list of strings should also implement these
49;; methods:
50;; * `eieio-speedbar-child-make-tag-lines' - make tag lines for a child.
51;; * `eieio-speedbar-child-description' - describe non-object children
52;;
53;; 4) Objects which have expanded information should implement the method
54;; `eieio-speedbar-description' to produce more information.
55;;
56;; 5) Objects that are associated with a directory should implement
57;; the method `eieio-speedbar-derive-line-path' which returns a
58;; path.
59;;
60;; 6) Objects that have a specialized behavior when clicked should
61;; define the method `eieio-speedbar-handle-click'.
62;;
63;; To initialize a new eieio based speedbar display, do the following.
64;;
65;; 1) Create a keymap variable `foo-speedbar-key-map'.
66;; This keymap variable should be initialized in a function.
67;; If you have no special needs, use `eieio-speedbar-key-map'
68;;
69;; 2) Create a variable containing an easymenu definition compatible
70;; with speedbar. if you have no special needs, use
71;; `eieio-speedbar-menu'.
72;;
73;; 3) Create a function which returns the top-level list of children
74;; objects to be displayed in speedbar.
75;;
76;; 4) Call `eieio-speedbar-create' as specified in it's documentation
77;; string. This will automatically handle cases when speedbar is
78;; not already loaded, and specifying all overload functions.
79;;
80;; 5) Create an initliazer function which looks like this:
81;;
82;; (defun my-speedbar-mode-initilaize ()
83;; "documentation"
84;; (interactive)
85;; (speedbar-frame-mode 1)
86;; (speedbar-change-initial-expansion-list mymodename)
87;; (speedbar-get-focus))
88;;
89;; where `mymodename' is the same value as passed to `eieio-speedbar-create'
90;; as the MODENAME parameter.
91
92;; @todo - Can we make this ECB friendly?
93
94;;; Code:
95(require 'eieio)
96(require 'eieio-custom)
97(require 'speedbar)
98
99;;; Support a way of adding generic object based modes into speedbar.
100;;
101(defun eieio-speedbar-make-map ()
102 "Make the generic object based speedbar keymap."
103 (let ((map (speedbar-make-specialized-keymap)))
104
105 ;; General viewing things
106 (define-key map "\C-m" 'speedbar-edit-line)
107 (define-key map "+" 'speedbar-expand-line)
108 (define-key map "=" 'speedbar-expand-line)
109 (define-key map "-" 'speedbar-contract-line)
110
111 ;; Some object based things
112 (define-key map "C" 'eieio-speedbar-customize-line)
113 map))
114
115(defvar eieio-speedbar-key-map (eieio-speedbar-make-map)
116 "A Generic object based speedbar display keymap.")
117
118(defvar eieio-speedbar-menu
119 '([ "Edit Object/Field" speedbar-edit-line t]
120 [ "Expand Object" speedbar-expand-line
121 (save-excursion (beginning-of-line)
122 (looking-at "[0-9]+: *.\\+. "))]
123 [ "Contract Object" speedbar-contract-line
124 (save-excursion (beginning-of-line)
125 (looking-at "[0-9]+: *.-. "))]
126 "---"
127 [ "Customize Object" eieio-speedbar-customize-line
128 (eieio-object-p (speedbar-line-token)) ]
129 )
130 "Menu part in easymenu format used in speedbar while browsing objects.")
131
132;; Note to self: Fix this silly thing!
133(defalias 'eieio-speedbar-customize-line 'speedbar-edit-line)
134
135(defun eieio-speedbar-create (map-fn map-var menu-var modename fetcher)
136 "Create a speedbar mode for displaying an object hierarchy.
137MAP-FN is the keymap generator function used for extra keys.
138MAP-VAR is the keymap variable used.
139MENU-VAR is the symbol containting an easymenu compatible menu part to use.
140MODENAME is a s tring used to identify this browser mode.
141FETCHER is a generic function used to fetch the base object list used when
142creating the speedbar display."
143 (if (not (featurep 'speedbar))
144 (add-hook 'speedbar-load-hook
145 (list 'lambda nil
146 (list 'eieio-speedbar-create-engine
147 map-fn map-var menu-var modename fetcher)))
148 (eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher)))
149
150(defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher)
151 "Create a speedbar mode for displaying an object hierarchy.
152Called from `eieio-speedbar-create', or the speedbar load-hook.
153MAP-FN, MAP-VAR, MENU-VAR, MODENAME, and FETCHER are the same as
154`eieio-speedbar-create'."
155 ;; make sure the keymap exists
156 (funcall map-fn)
157 ;; Add to the expansion list.
158 (speedbar-add-expansion-list
159 (list modename
160 menu-var
161 map-var
162 (list 'lambda '(dir depth)
163 (list 'eieio-speedbar-buttons 'dir 'depth
164 (list 'quote fetcher)))))
165 ;; Set the special functions.
166 (speedbar-add-mode-functions-list
167 (list modename
168 '(speedbar-item-info . eieio-speedbar-item-info)
169 '(speedbar-line-directory . eieio-speedbar-line-path))))
170
171(defun eieio-speedbar-buttons (dir-or-object depth fetcher)
172 "Create buttons for the speedbar display.
173Start in directory DIR-OR-OBJECT. If it is an object, just display that
174objects subelements.
175Argument DEPTH specifies how far down we have already been displayed.
176If it is a directory, use FETCHER to fetch all objects associated with
177that path."
178 (let ((objlst (cond ((eieio-object-p dir-or-object)
179 (list dir-or-object))
180 ((stringp dir-or-object)
181 (funcall fetcher dir-or-object))
182 (t dir-or-object))))
183 (if (not objlst)
184 (speedbar-make-tag-line nil nil nil nil "Empty display" nil nil nil
185 depth)
186 ;; Dump all objects into speedbar
187 (while objlst
188 (eieio-speedbar-make-tag-line (car objlst) depth)
189 (setq objlst (cdr objlst))))))
190
191
192;;; DEFAULT SUPERCLASS baseline methods
193;;
194;; First, define methods onto the superclass so all classes
195;; will have some minor support.
196
197(defmethod eieio-speedbar-description ((object eieio-default-superclass))
198 "Return a string describing OBJECT."
199 (object-name-string object))
200
201(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass))
202 "Return the path which OBJECT has something to do with."
203 nil)
204
205(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass))
206 "Return a string to use as a speedbar button for OBJECT."
207 (object-name-string object))
208
209(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass)
210 depth)
211 "Insert a tag line into speedbar at point for OBJECT.
212By default, all objects appear as simple TAGS with no need to inherit from
213the special `eieio-speedbar' classes. Child classes should redefine this
214method to create more accurate tag lines.
215Argument DEPTH is the depth at which the tag line is inserted."
216 (speedbar-make-tag-line nil nil nil nil
217 (eieio-speedbar-object-buttonname object)
218 'eieio-speedbar-object-click
219 object
220 'speedbar-tag-face
221 depth))
222
223(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass))
224 "Handle a click action on OBJECT in speedbar.
225Any object can be represented as a tag in SPEEDBAR without special
226attributes. These default objects will be pulled up in a custom
227object edit buffer doing an in-place edit.
228
229If your object represents some other item, override this method
230and take the apropriate action."
231 (require 'eieio-custom)
232 (speedbar-with-attached-buffer
233 (eieio-customize-object object))
234 (speedbar-maybee-jump-to-attached-frame))
235
236
237;;; Class definitions
238;;
239;; Now define a special speedbar class with some
240;; variables with :allocation class which can be attached into
241;; object hierarchies.
242;;
243;; These more complex types are for objects which wish to display
244;; lists of children buttons.
245
246(defclass eieio-speedbar nil
247 ((buttontype :initform nil
248 :type symbol
249 :documentation
250 "The type of expansion button used for objects of this class.
251Possible values are those symbols supported by the `exp-button-type' argument
252to `speedbar-make-tag-line'."
253 :allocation :class)
254 (buttonface :initform speedbar-tag-face
255 :type (or symbol face)
256 :documentation
257 "The face used on the textual part of the button for this class.
258See `speedbar-make-tag-line' for details."
259 :allocation :class)
260 (expanded :initform nil
261 :type boolean
262 :documentation
263 "State of an object being expanded in speedbar.")
264 )
265 "Class which provides basic speedbar support for child classes.
266Add one of thie child classes to this class to the parent list of a class."
267 :method-invocation-order :depth-first
268 :abstract t)
269
270(defclass eieio-speedbar-directory-button (eieio-speedbar)
271 ((buttontype :initform angle)
272 (buttonface :initform speedbar-directory-face))
273 "Class providing support for objects which behave like a directory."
274 :method-invocation-order :depth-first
275 :abstract t)
276
277(defclass eieio-speedbar-file-button (eieio-speedbar)
278 ((buttontype :initform bracket)
279 (buttonface :initform speedbar-file-face))
280 "Class providing support for objects which behave like a directory."
281 :method-invocation-order :depth-first
282 :abstract t)
283
284
285;;; Methods to eieio-speedbar-* which do not need to be overriden
286;;
287(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar)
288 depth)
289 "Insert a tag line into speedbar at point for OBJECT.
290All objects a child of symbol `eieio-speedbar' can be created from this
291method. Override this if you need non-traditional tag lines.
292Argument DEPTH is the depth at which the tag line is inserted."
293 (let ((children (eieio-speedbar-object-children object))
294 (exp (oref object expanded)))
295 (if (not children)
296 (if (eq (oref object buttontype) 'expandtag)
297 (speedbar-make-tag-line 'statictag
298 ? nil nil
299 (eieio-speedbar-object-buttonname object)
300 'eieio-speedbar-object-click
301 object
302 (oref object buttonface)
303 depth)
304 (speedbar-make-tag-line (oref object buttontype)
305 ? nil nil
306 (eieio-speedbar-object-buttonname object)
307 'eieio-speedbar-object-click
308 object
309 (oref object buttonface)
310 depth))
311 (speedbar-make-tag-line (oref object buttontype)
312 (if exp ?- ?+)
313 'eieio-speedbar-object-expand
314 object
315 (eieio-speedbar-object-buttonname object)
316 'eieio-speedbar-object-click
317 object
318 (oref object buttonface)
319 depth)
320 (if exp
321 (eieio-speedbar-expand object (1+ depth))))))
322
323(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth)
324 "Base method for creating tag lines for non-object children."
325 (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
326 (object-name object)))
327
328(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
329 "Expand OBJECT at indentation DEPTH.
330Inserts a list of new tag lines representing expanded elements withing
331OBJECT."
332 (let ((children (eieio-speedbar-object-children object)))
333 (cond ((eieio-object-p (car children))
334 (mapcar (lambda (car)
335 (eieio-speedbar-make-tag-line car depth))
336 children))
337 (children (eieio-speedbar-child-make-tag-lines object depth)))))
338
339
340;;; Speedbar specific function callbacks.
341;;
342(defun eieio-speedbar-object-click (text token indent)
343 "Handle a user click on TEXT representing object TOKEN.
344The object is at indentation level INDENT."
345 (eieio-speedbar-handle-click token))
346
347(defun eieio-speedbar-object-expand (text token indent)
348 "Expand object represented by TEXT. TOKEN is the object.
349INDENT is the current indentation level."
350 (cond ((string-match "+" text) ;we have to expand this file
351 (speedbar-change-expand-button-char ?-)
352 (oset token expanded t)
353 (speedbar-with-writable
354 (save-excursion
355 (end-of-line) (forward-char 1)
356 (eieio-speedbar-expand token (1+ indent)))))
357 ((string-match "-" text) ;we have to contract this node
358 (speedbar-change-expand-button-char ?+)
359 (oset token expanded nil)
360 (speedbar-delete-subblock indent))
361 (t (error "Ooops... not sure what to do")))
362 (speedbar-center-buffer-smartly))
363
364(defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
365 "Return a description for a child of OBJ which is not an object."
366 (error "You must implement `eieio-speedbar-child-description' for %s"
367 (object-name obj)))
368
369(defun eieio-speedbar-item-info ()
370 "Display info for the current line when in EDE display mode."
371 ;; Switch across the types of the tokens.
372 (let ((tok (speedbar-line-token)))
373 (cond ((eieio-object-p tok)
374 (message (eieio-speedbar-description tok)))
375 (t
376 (let ((no (eieio-speedbar-find-nearest-object)))
377 (if no
378 (eieio-speedbar-child-description no)))))))
379
380(defun eieio-speedbar-find-nearest-object (&optional depth)
381 "Search backwards to the first line associated with an object.
382Optional argument DEPTH is the current depth of the search."
383 (save-excursion
384 (if (not depth)
385 (progn
386 (beginning-of-line)
387 (when (looking-at "^\\([0-9]+\\):")
388 (setq depth (string-to-number (match-string 1))))))
389 (when depth
390 (while (and (not (eieio-object-p (speedbar-line-token)))
391 (> depth 0))
392 (setq depth (1- depth))
393 (re-search-backward (format "^%d:" depth) nil t))
394 (speedbar-line-token))))
395
396(defun eieio-speedbar-line-path (&optional depth)
397 "If applicable, return the path to the file the cursor is on.
398Optional DEPTH is the depth we start at."
399 (save-match-data
400 (if (not depth)
401 (progn
402 (beginning-of-line)
403 (looking-at "^\\([0-9]+\\):")
404 (setq depth (string-to-number (match-string 1)))))
405 ;; This whole function is presently bogus. Make it better later.
406 (let ((tok (eieio-speedbar-find-nearest-object depth)))
407 (if (eieio-object-p tok)
408 (eieio-speedbar-derive-line-path tok)
409 default-directory))))
410
411
412;;; Methods to the eieio-speedbar-* classes which need to be overriden.
413;;
414(defmethod eieio-speedbar-object-children ((object eieio-speedbar))
415 "Return a list of children to be displayed in SPEEDBAR.
416If the return value is a list of OBJECTs, then those objects are
417queried for details. If the return list is made of strings,
418then this object will be queried for the details needed
419to create a speedbar button."
420 nil)
421
422(provide 'eieio-speedbar)
423
424;;; eieio-speedbar.el ends here
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
new file mode 100644
index 00000000000..09a1710dc67
--- /dev/null
+++ b/lisp/emacs-lisp/eieio.el
@@ -0,0 +1,2803 @@
1;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects
2;;; or maybe Eric's Implementation of Emacs Intrepreted Objects
3
4;;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003,
5;;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
6
7;; Author: Eric M. Ludlam <zappo@gnu.org>
8;; Version: 0.2
9;; Keywords: OO, lisp
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27;;
28;; EIEIO is a series of Lisp routines which implements a subset of
29;; CLOS, the Common Lisp Object System. In addition, EIEIO also adds
30;; a few new features which help it integrate more strongly with the
31;; Emacs running environment.
32;;
33;; See eieio.texi for complete documentation on using this package.
34
35;; There is funny stuff going on with typep and deftype. This
36;; is the only way I seem to be able to make this stuff load properly.
37
38;; @TODO - fix :initform to be a form, not a quoted value
39;; @TODO - For API calls like `object-p', replace with something
40;; that does not conflict with "object", meaning a lisp object.
41;; @TODO - Prefix non-clos functions with `eieio-'.
42
43;;; Code:
44
45(defvar eieio-version "1.2"
46 "Current version of EIEIO.")
47
48(require 'cl)
49
50(defun eieio-version ()
51 "Display the current version of EIEIO."
52 (interactive)
53 (message eieio-version))
54
55(eval-and-compile
56;; Abount the above. EIEIO must process it's own code when it compiles
57;; itself, thus, by eval-and-compiling outselves, we solve the problem.
58
59;; Compatibility
60(if (fboundp 'compiled-function-arglist)
61
62 ;; XEmacs can only access a compiled functions arglist like this:
63 (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist)
64
65 ;; Emacs doesn't have this function, but since FUNC is a vector, we can just
66 ;; grab the appropriate element.
67 (defun eieio-compiled-function-arglist (func)
68 "Return the argument list for the compiled function FUNC."
69 (aref func 0))
70
71 )
72
73
74;;;
75;; Variable declarations.
76;;
77
78(defvar eieio-hook nil
79 "*This hook is executed, then cleared each time `defclass' is called.")
80
81(defvar eieio-error-unsupported-class-tags nil
82 "*Non nil to throw an error if an encountered tag us unsupported.
83This may prevent classes from CLOS applications from being used with EIEIO
84since EIEIO does not support all CLOS tags.")
85
86(defvar eieio-skip-typecheck nil
87 "*If non-nil, skip all slot typechecking.
88Set this to t permanently if a program is functioning well to get a
89small speed increase. This variable is also used internally to handle
90default setting for optimization purposes.")
91
92(defvar eieio-optimize-primary-methods-flag t
93 "Non-nil means to optimize the method dispatch on primary methods.")
94
95;; State Variables
96(defvar this nil
97 "Inside a method, this variable is the object in question.
98DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots.
99
100Note: Embedded methods are no longer supported. The variable THIS is
101still set for CLOS methods for the sake of routines like
102`call-next-method'")
103
104(defvar scoped-class nil
105 "This is set to a class when a method is running.
106This is so we know we are allowed to check private parts or how to
107execute a `call-next-method'. DO NOT SET THIS YOURSELF!")
108
109(defvar eieio-initializing-object nil
110 "Set to non-nil while initializing an object.")
111
112(defconst eieio-unbound (make-symbol "unbound")
113 "Uninterned symbol representing an unbound slot in an object.")
114
115;; This is a bootstrap for eieio-default-superclass so it has a value
116;; while it is being built itself.
117(defvar eieio-default-superclass nil)
118
119(defconst class-symbol 1 "Class's symbol (self-referencing.).")
120(defconst class-parent 2 "Class parent slot.")
121(defconst class-children 3 "Class children class slot.")
122(defconst class-symbol-obarray 4 "Obarray permitting fast access to variable position indexes.")
123;; @todo
124;; the word "public" here is leftovers from the very first version.
125;; Get rid of it!
126(defconst class-public-a 5 "Class attribute index.")
127(defconst class-public-d 6 "Class attribute defaults index.")
128(defconst class-public-doc 7 "Class documentation strings for attributes.")
129(defconst class-public-type 8 "Class type for a slot.")
130(defconst class-public-custom 9 "Class custom type for a slot.")
131(defconst class-public-custom-label 10 "Class custom group for a slot.")
132(defconst class-public-custom-group 11 "Class custom group for a slot.")
133(defconst class-public-printer 12 "Printer for a slot.")
134(defconst class-protection 13 "Class protection for a slot.")
135(defconst class-initarg-tuples 14 "Class initarg tuples list.")
136(defconst class-class-allocation-a 15 "Class allocated attributes.")
137(defconst class-class-allocation-doc 16 "Class allocated documentation.")
138(defconst class-class-allocation-type 17 "Class allocated value type.")
139(defconst class-class-allocation-custom 18 "Class allocated custom descriptor.")
140(defconst class-class-allocation-custom-label 19 "Class allocated custom descriptor.")
141(defconst class-class-allocation-custom-group 20 "Class allocated custom group.")
142(defconst class-class-allocation-printer 21 "Class allocated printer for a slot.")
143(defconst class-class-allocation-protection 22 "Class allocated protection list.")
144(defconst class-class-allocation-values 23 "Class allocated value vector.")
145(defconst class-default-object-cache 24
146 "Cache index of what a newly created object would look like.
147This will speed up instantiation time as only a `copy-sequence' will
148be needed, instead of looping over all the values and setting them
149from the default.")
150(defconst class-options 25
151 "Storage location of tagged class options.
152Stored outright without modifications or stripping.")
153
154(defconst class-num-slots 26
155 "Number of slots in the class definition object.")
156
157(defconst object-class 1 "Index in an object vector where the class is stored.")
158(defconst object-name 2 "Index in an object where the name is stored.")
159
160(defconst method-static 0 "Index into :static tag on a method.")
161(defconst method-before 1 "Index into :before tag on a method.")
162(defconst method-primary 2 "Index into :primary tag on a method.")
163(defconst method-after 3 "Index into :after tag on a method.")
164(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.")
165(defconst method-generic-before 4 "Index into generic :before tag on a method.")
166(defconst method-generic-primary 5 "Index into generic :primary tag on a method.")
167(defconst method-generic-after 6 "Index into generic :after tag on a method.")
168(defconst method-num-slots 7 "Number of indexes into a method's vector.")
169
170;; How to specialty compile stuff.
171(autoload 'byte-compile-file-form-defmethod "eieio-comp"
172 "This function is used to byte compile methods in a nice way.")
173(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
174
175(eval-when-compile (require 'eieio-comp))
176
177
178;;; Important macros used in eieio.
179;;
180(defmacro class-v (class)
181 "Internal: Return the class vector from the CLASS symbol."
182 ;; No check: If eieio gets this far, it's probably been checked already.
183 `(get ,class 'eieio-class-definition))
184
185(defmacro class-p (class)
186 "Return t if CLASS is a valid class vector.
187CLASS is a symbol."
188 ;; this new method is faster since it doesn't waste time checking lots of
189 ;; things.
190 `(condition-case nil
191 (eq (aref (class-v ,class) 0) 'defclass)
192 (error nil)))
193
194;;;###autoload
195(defmacro eieio-object-p (obj)
196 "Return non-nil if OBJ is an EIEIO object."
197 `(condition-case nil
198 (let ((tobj ,obj))
199 (and (eq (aref tobj 0) 'object)
200 (class-p (aref tobj object-class))))
201 (error nil)))
202(defalias 'object-p 'eieio-object-p)
203
204(defmacro class-constructor (class)
205 "Return the symbol representing the constructor of CLASS."
206 `(aref (class-v ,class) class-symbol))
207
208(defmacro generic-p (method)
209 "Return t if symbol METHOD is a generic function.
210Only methods have the symbol `eieio-method-obarray' as a property (which
211contains a list of all bindings to that method type.)"
212 `(and (fboundp ,method) (get ,method 'eieio-method-obarray)))
213
214(defun generic-primary-only-p (method)
215 "Return t if symbol METHOD is a generic function with only primary methods.
216Only methods have the symbol `eieio-method-obarray' as a property (which
217contains a list of all bindings to that method type.)
218Methods with only primary implementations are executed in an optimized way."
219 (and (generic-p method)
220 (let ((M (get method 'eieio-method-tree)))
221 (and (< 0 (length (aref M method-primary)))
222 (not (aref M method-static))
223 (not (aref M method-before))
224 (not (aref M method-after))
225 (not (aref M method-generic-before))
226 (not (aref M method-generic-primary))
227 (not (aref M method-generic-after))))
228 ))
229
230(defun generic-primary-only-one-p (method)
231 "Return t if symbol METHOD is a generic function with only primary methods.
232Only methods have the symbol `eieio-method-obarray' as a property (which
233contains a list of all bindings to that method type.)
234Methods with only primary implementations are executed in an optimized way."
235 (and (generic-p method)
236 (let ((M (get method 'eieio-method-tree)))
237 (and (= 1 (length (aref M method-primary)))
238 (not (aref M method-static))
239 (not (aref M method-before))
240 (not (aref M method-after))
241 (not (aref M method-generic-before))
242 (not (aref M method-generic-primary))
243 (not (aref M method-generic-after))))
244 ))
245
246(defmacro class-option-assoc (list option)
247 "Return from LIST the found OPTION. Nil if it doesn't exist."
248 `(car-safe (cdr (memq ,option ,list))))
249
250(defmacro class-option (class option)
251 "Return the value stored for CLASS' OPTION.
252Return nil if that option doesn't exist."
253 `(class-option-assoc (aref (class-v ,class) class-options) ',option))
254
255(defmacro class-abstract-p (class)
256 "Return non-nil if CLASS is abstract.
257Abstract classes cannot be instantiated."
258 `(class-option ,class :abstract))
259
260(defmacro class-method-invocation-order (class)
261 "Return the invocation order of CLASS.
262Abstract classes cannot be instantiated."
263 `(or (class-option ,class :method-invocation-order)
264 :breadth-first))
265
266
267;;; Defining a new class
268;;
269(defmacro defclass (name superclass slots &rest options-and-doc)
270 "Define NAME as a new class derived from SUPERCLASS with SLOTS.
271OPTIONS-AND-DOC is used as the class' options and base documentation.
272SUPERCLASS is a list of superclasses to inherit from, with SLOTS
273being the slots residing in that class definition. NOTE: Currently
274only one slot may exist in SUPERCLASS as multiple inheritance is not
275yet supported. Supported tags are:
276
277 :initform - initializing form
278 :initarg - tag used during initialization
279 :accessor - tag used to create a function to access this slot
280 :allocation - specify where the value is stored.
281 defaults to `:instance', but could also be `:class'
282 :writer - a function symbol which will `write' an object's slot
283 :reader - a function symbol which will `read' an object
284 :type - the type of data allowed in this slot (see `typep')
285 :documentation
286 - A string documenting use of this slot.
287
288The following are extensions on CLOS:
289 :protection - Specify protection for this slot.
290 Defaults to `:public'. Also use `:protected', or `:private'
291 :custom - When customizing an object, the custom :type. Public only.
292 :label - A text string label used for a slot when customizing.
293 :group - Name of a customization group this slot belongs in.
294 :printer - A function to call to print the value of a slot.
295 See `eieio-override-prin1' as an example.
296
297A class can also have optional options. These options happen in place
298of documentation, (including a :documentation tag) in addition to
299documentation, or not at all. Supported options are:
300
301 :documentation - The doc-string used for this class.
302
303Options added to EIEIO:
304
305 :allow-nil-initform - Non-nil to skip typechecking of initforms if nil.
306 :custom-groups - List of custom group names. Organizes slots into
307 reasonable groups for customizations.
308 :abstract - Non-nil to prevent instances of this class.
309 If a string, use as an error string if someone does
310 try to make an instance.
311 :method-invocation-order
312 - Control the method invokation order if there is
313 multiple inheritance. Valid values are:
314 :breadth-first - The default.
315 :depth-first
316
317Options in CLOS not supported in EIEIO:
318
319 :metaclass - Class to use in place of `standard-class'
320 :default-initargs - Initargs to use when initializing new objects of
321 this class.
322
323Due to the way class options are set up, you can add any tags in you
324wish, and reference them using the function `class-option'."
325 ;; We must `eval-and-compile' this so that when we byte compile
326 ;; an eieio program, there is no need to load it ahead of time.
327 ;; It also provides lots of nice debugging errors at compile time.
328 `(eval-and-compile
329 (eieio-defclass ',name ',superclass ',slots ',options-and-doc)))
330
331(defvar eieio-defclass-autoload-map (make-vector 7 nil)
332 "Symbol map of superclasses we find in autoloads.")
333
334(defun eieio-defclass-autoload (cname superclasses filename doc)
335 "Create autoload symbols for the EIEIO class CNAME.
336SUPERCLASSES are the superclasses that CNAME inherites from.
337DOC is the docstring for CNAME.
338This function creates a mock-class for CNAME and adds it into
339SUPERCLASSES as children.
340It creates an autoload function for CNAME's constructor."
341 ;; Assume we've already debugged inputs.
342
343 (let* ((oldc (when (class-p cname) (class-v cname)))
344 (newc (make-vector class-num-slots nil))
345 )
346 (if oldc
347 nil ;; Do nothing if we already have this class.
348
349 ;; Create the class in NEWC, but don't fill anything else in.
350 (aset newc 0 'defclass)
351 (aset newc class-symbol cname)
352
353 (let ((clear-parent nil))
354 ;; No parents?
355 (when (not superclasses)
356 (setq superclasses '(eieio-default-superclass)
357 clear-parent t)
358 )
359
360 ;; Hook our new class into the existing structures so we can
361 ;; autoload it later.
362 (dolist (SC superclasses)
363
364
365 ;; TODO - If we create an autoload that is in the map, that
366 ;; map needs to be cleared!
367
368
369 ;; Does our parent exist?
370 (if (not (class-p SC))
371
372 ;; Create a symbol for this parent, and then store this
373 ;; parent on that symbol.
374 (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map)))
375 (if (not (boundp sym))
376 (set sym (list cname))
377 (add-to-list sym cname))
378 )
379
380 ;; We have a parent, save the child in there.
381 (when (not (member cname (aref (class-v SC) class-children)))
382 (aset (class-v SC) class-children
383 (cons cname (aref (class-v SC) class-children)))))
384
385 ;; save parent in child
386 (aset newc class-parent (cons SC (aref newc class-parent)))
387 )
388
389 ;; turn this into a useable self-pointing symbol
390 (set cname cname)
391
392 ;; Store the new class vector definition into the symbol. We need to
393 ;; do this first so that we can call defmethod for the accessor.
394 ;; The vector will be updated by the following while loop and will not
395 ;; need to be stored a second time.
396 (put cname 'eieio-class-definition newc)
397
398 ;; Clear the parent
399 (if clear-parent (aset newc class-parent nil))
400
401 ;; Create an autoload on top of our constructor function.
402 (autoload cname filename doc nil nil)
403 (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil)
404 (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil)
405
406 ))))
407
408(defsubst eieio-class-un-autoload (cname)
409 "If class CNAME is in an autoload state, load it's file."
410 (when (eq (car-safe (symbol-function cname)) 'autoload)
411 (load-library (car (cdr (symbol-function cname))))))
412
413(defun eieio-defclass (cname superclasses slots options-and-doc)
414 "See `defclass' for more information.
415Define CNAME as a new subclass of SUPERCLASSES, with SLOTS being the
416slots residing in that class definition, and with options or documentation
417OPTIONS-AND-DOC as the toplevel documentation for this class."
418 ;; Run our eieio-hook each time, and clear it when we are done.
419 ;; This way people can add hooks safely if they want to modify eieio
420 ;; or add definitions when eieio is loaded or something like that.
421 (run-hooks 'eieio-hook)
422 (setq eieio-hook nil)
423
424 (if (not (symbolp cname)) (signal 'wrong-type-argument '(symbolp cname)))
425 (if (not (listp superclasses)) (signal 'wrong-type-argument '(listp superclasses)))
426
427 (let* ((pname (if superclasses superclasses nil))
428 (newc (make-vector class-num-slots nil))
429 (oldc (when (class-p cname) (class-v cname)))
430 (groups nil) ;; list of groups id'd from slots
431 (options nil)
432 (clearparent nil))
433
434 (aset newc 0 'defclass)
435 (aset newc class-symbol cname)
436
437 ;; If this class already existed, and we are updating it's structure,
438 ;; make sure we keep the old child list. This can cause bugs, but
439 ;; if no new slots are created, it also saves time, and prevents
440 ;; method table breakage, particularly when the users is only
441 ;; byte compiling an EIEIO file.
442 (if oldc
443 (aset newc class-children (aref oldc class-children))
444 ;; If the old class did not exist, but did exist in the autoload map, then adopt those children.
445 ;; This is like the above, but deals with autoloads nicely.
446 (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map)))
447 (when sym
448 (condition-case nil
449 (aset newc class-children (symbol-value sym))
450 (error nil))
451 (unintern (symbol-name cname) eieio-defclass-autoload-map)
452 ))
453 )
454
455 (cond ((and (stringp (car options-and-doc))
456 (/= 1 (% (length options-and-doc) 2)))
457 (error "Too many arguments to `defclass'"))
458 ((and (symbolp (car options-and-doc))
459 (/= 0 (% (length options-and-doc) 2)))
460 (error "Too many arguments to `defclass'"))
461 )
462
463 (setq options
464 (if (stringp (car options-and-doc))
465 (cons :documentation options-and-doc)
466 options-and-doc))
467
468 (if pname
469 (progn
470 (while pname
471 (if (and (car pname) (symbolp (car pname)))
472 (if (not (class-p (car pname)))
473 ;; bad class
474 (error "Given parent class %s is not a class" (car pname))
475 ;; good parent class...
476 ;; save new child in parent
477 (when (not (member cname (aref (class-v (car pname)) class-children)))
478 (aset (class-v (car pname)) class-children
479 (cons cname (aref (class-v (car pname)) class-children))))
480 ;; Get custom groups, and store them into our local copy.
481 (mapc (lambda (g) (add-to-list 'groups g))
482 (class-option (car pname) :custom-groups))
483 ;; save parent in child
484 (aset newc class-parent (cons (car pname) (aref newc class-parent))))
485 (error "Invalid parent class %s" pname))
486 (setq pname (cdr pname)))
487 ;; Reverse the list of our parents so that they are prioritized in
488 ;; the same order as specified in the code.
489 (aset newc class-parent (nreverse (aref newc class-parent))) )
490 ;; If there is nothing to loop over, then inherit from the
491 ;; default superclass.
492 (unless (eq cname 'eieio-default-superclass)
493 ;; adopt the default parent here, but clear it later...
494 (setq clearparent t)
495 ;; save new child in parent
496 (if (not (member cname (aref (class-v 'eieio-default-superclass) class-children)))
497 (aset (class-v 'eieio-default-superclass) class-children
498 (cons cname (aref (class-v 'eieio-default-superclass) class-children))))
499 ;; save parent in child
500 (aset newc class-parent (list eieio-default-superclass))))
501
502 ;; turn this into a useable self-pointing symbol
503 (set cname cname)
504
505 ;; These two tests must be created right away so we can have self-
506 ;; referencing classes. ei, a class whose slot can contain only
507 ;; pointers to itself.
508
509 ;; Create the test function
510 (let ((csym (intern (concat (symbol-name cname) "-p"))))
511 (fset csym
512 (list 'lambda (list 'obj)
513 (format "Test OBJ to see if it an object of type %s" cname)
514 (list 'and '(eieio-object-p obj)
515 (list 'same-class-p 'obj cname)))))
516
517 ;; Make sure the method invocation order is a valid value.
518 (let ((io (class-option-assoc options :method-invocation-order)))
519 (when (and io (not (member io '(:depth-first :breadth-first))))
520 (error "Method invocation order %s is not allowed" io)
521 ))
522
523 ;; Create a handy child test too
524 (let ((csym (intern (concat (symbol-name cname) "-child-p"))))
525 (fset csym
526 `(lambda (obj)
527 ,(format
528 "Test OBJ to see if it an object is a child of type %s"
529 cname)
530 (and (eieio-object-p obj)
531 (object-of-class-p obj ,cname))))
532
533 ;; When using typep, (typep OBJ 'myclass) returns t for objects which
534 ;; are subclasses of myclass. For our predicates, however, it is
535 ;; important for EIEIO to be backwards compatible, where
536 ;; myobject-p, and myobject-child-p are different.
537 ;; "cl" uses this technique to specify symbols with specific typep
538 ;; test, so we can let typep have the CLOS documented behavior
539 ;; while keeping our above predicate clean.
540 (eval `(deftype ,cname ()
541 '(satisfies
542 ,(intern (concat (symbol-name cname) "-child-p")))))
543
544 )
545
546 ;; before adding new slots, lets add all the methods and classes
547 ;; in from the parent class
548 (eieio-copy-parents-into-subclass newc superclasses)
549
550 ;; Store the new class vector definition into the symbol. We need to
551 ;; do this first so that we can call defmethod for the accessor.
552 ;; The vector will be updated by the following while loop and will not
553 ;; need to be stored a second time.
554 (put cname 'eieio-class-definition newc)
555
556 ;; Query each slot in the declaration list and mangle into the
557 ;; class structure I have defined.
558 (while slots
559 (let* ((slot1 (car slots))
560 (name (car slot1))
561 (slot (cdr slot1))
562 (acces (plist-get slot ':accessor))
563 (init (or (plist-get slot ':initform)
564 (if (member ':initform slot) nil
565 eieio-unbound)))
566 (initarg (plist-get slot ':initarg))
567 (docstr (plist-get slot ':documentation))
568 (prot (plist-get slot ':protection))
569 (reader (plist-get slot ':reader))
570 (writer (plist-get slot ':writer))
571 (alloc (plist-get slot ':allocation))
572 (type (plist-get slot ':type))
573 (custom (plist-get slot ':custom))
574 (label (plist-get slot ':label))
575 (customg (plist-get slot ':group))
576 (printer (plist-get slot ':printer))
577
578 (skip-nil (class-option-assoc options :allow-nil-initform))
579 )
580
581 (if eieio-error-unsupported-class-tags
582 (let ((tmp slot))
583 (while tmp
584 (if (not (member (car tmp) '(:accessor
585 :initform
586 :initarg
587 :documentation
588 :protection
589 :reader
590 :writer
591 :allocation
592 :type
593 :custom
594 :label
595 :group
596 :printer
597 :allow-nil-initform
598 :custom-groups)))
599 (signal 'invalid-slot-type (list (car tmp))))
600 (setq tmp (cdr (cdr tmp))))))
601
602 ;; Clean up the meaning of protection.
603 (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil))
604 ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected))
605 ((or (eq prot 'private) (eq prot :private)) (setq prot 'private))
606 ((eq prot nil) nil)
607 (t (signal 'invalid-slot-type (list ':protection prot))))
608
609 ;; Make sure the :allocation parameter has a valid value.
610 (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance)))
611 (signal 'invalid-slot-type (list ':allocation alloc)))
612
613 ;; The default type specifier is supposed to be t, meaning anything.
614 (if (not type) (setq type t))
615
616 ;; Label is nil, or a string
617 (if (not (or (null label) (stringp label)))
618 (signal 'invalid-slot-type (list ':label label)))
619
620 ;; Is there an initarg, but allocation of class?
621 (if (and initarg (eq alloc :class))
622 (message "Class allocated slots do not need :initarg"))
623
624 ;; intern the symbol so we can use it blankly
625 (if initarg (set initarg initarg))
626
627 ;; The customgroup should be a list of symbols
628 (cond ((null customg)
629 (setq customg '(default)))
630 ((not (listp customg))
631 (setq customg (list customg))))
632 ;; The customgroup better be a symbol, or list of symbols.
633 (mapc (lambda (cg)
634 (if (not (symbolp cg))
635 (signal 'invalid-slot-type (list ':group cg))))
636 customg)
637
638 ;; First up, add this slot into our new class.
639 (eieio-add-new-slot newc name init docstr type custom label customg printer
640 prot initarg alloc 'defaultoverride skip-nil)
641
642 ;; We need to id the group, and store them in a group list attribute.
643 (mapc (lambda (cg) (add-to-list 'groups cg)) customg)
644
645 ;; anyone can have an accessor function. This creates a function
646 ;; of the specified name, and also performs a `defsetf' if applicable
647 ;; so that users can `setf' the space returned by this function
648 (if acces
649 (progn
650 (eieio-defmethod acces
651 (list (if (eq alloc :class) :static :primary)
652 (list (list 'this cname))
653 (format
654 "Retrieves the slot `%s' from an object of class `%s'"
655 name cname)
656 (list 'if (list 'slot-boundp 'this (list 'quote name))
657 (list 'eieio-oref 'this (list 'quote name))
658 ;; Else - Some error? nil?
659 nil
660 )))
661 ;; Thanks Pascal Bourguignon <pjb@informatimago.com>
662 ;; For this complex macro.
663 (eval (macroexpand
664 (list 'defsetf acces '(widget) '(store)
665 (list 'list ''eieio-oset 'widget
666 (list 'quote (list 'quote name)) 'store))))
667 ;;`(defsetf ,acces (widget) (store) (eieio-oset widget ',cname store))
668 )
669 )
670 ;; If a writer is defined, then create a generic method of that
671 ;; name whose purpose is to set the value of the slot.
672 (if writer
673 (progn
674 (eieio-defmethod writer
675 (list (list (list 'this cname) 'value)
676 (format "Set the slot `%s' of an object of class `%s'"
677 name cname)
678 `(setf (slot-value this ',name) value)))
679 ))
680 ;; If a reader is defined, then create a generic method
681 ;; of that name whose purpose is to access this slot value.
682 (if reader
683 (progn
684 (eieio-defmethod reader
685 (list (list (list 'this cname))
686 (format "Access the slot `%s' from object of class `%s'"
687 name cname)
688 `(slot-value this ',name)))))
689 )
690 (setq slots (cdr slots)))
691
692 ;; Now that everything has been loaded up, all our lists are backwards! Fix that up now.
693 (aset newc class-public-a (nreverse (aref newc class-public-a)))
694 (aset newc class-public-d (nreverse (aref newc class-public-d)))
695 (aset newc class-public-doc (nreverse (aref newc class-public-doc)))
696 (aset newc class-public-type
697 (apply 'vector (nreverse (aref newc class-public-type))))
698 (aset newc class-public-custom (nreverse (aref newc class-public-custom)))
699 (aset newc class-public-custom-label (nreverse (aref newc class-public-custom-label)))
700 (aset newc class-public-custom-group (nreverse (aref newc class-public-custom-group)))
701 (aset newc class-public-printer (nreverse (aref newc class-public-printer)))
702 (aset newc class-protection (nreverse (aref newc class-protection)))
703 (aset newc class-initarg-tuples (nreverse (aref newc class-initarg-tuples)))
704
705 ;; The storage for class-class-allocation-type needs to be turned into
706 ;; a vector now.
707 (aset newc class-class-allocation-type
708 (apply 'vector (aref newc class-class-allocation-type)))
709
710 ;; Also, take class allocated values, and vectorize them for speed.
711 (aset newc class-class-allocation-values
712 (apply 'vector (aref newc class-class-allocation-values)))
713
714 ;; Attach slot symbols into an obarray, and store the index of
715 ;; this slot as the variable slot in this new symbol. We need to
716 ;; know about primes, because obarrays are best set in vectors of
717 ;; prime number length, and we also need to make our vector small
718 ;; to save space, and also optimal for the number of items we have.
719 (let* ((cnt 0)
720 (pubsyms (aref newc class-public-a))
721 (prots (aref newc class-protection))
722 (l (length pubsyms))
723 (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47
724 53 59 61 67 71 73 79 83 89 97 101 )))
725 (while (and primes (< (car primes) l))
726 (setq primes (cdr primes)))
727 (car primes)))
728 (oa (make-vector vl 0))
729 (newsym))
730 (while pubsyms
731 (setq newsym (intern (symbol-name (car pubsyms)) oa))
732 (set newsym cnt)
733 (setq cnt (1+ cnt))
734 (if (car prots) (put newsym 'protection (car prots)))
735 (setq pubsyms (cdr pubsyms)
736 prots (cdr prots)))
737 (aset newc class-symbol-obarray oa)
738 )
739
740 ;; Create the constructor function
741 (if (class-option-assoc options :abstract)
742 ;; Abstract classes cannot be instantiated. Say so.
743 (let ((abs (class-option-assoc options :abstract)))
744 (if (not (stringp abs))
745 (setq abs (format "Class %s is abstract" cname)))
746 (fset cname
747 `(lambda (&rest stuff)
748 ,(format "You cannot create a new object of type %s" cname)
749 (error ,abs))))
750
751 ;; Non-abstract classes need a constructor.
752 (fset cname
753 `(lambda (newname &rest slots)
754 ,(format "Create a new object with name NAME of class type %s" cname)
755 (apply 'constructor ,cname newname slots)))
756 )
757
758 ;; Set up a specialized doc string.
759 ;; Use stored value since it is calculated in a non-trivial way
760 (put cname 'variable-documentation
761 (class-option-assoc options :documentation))
762
763 ;; We have a list of custom groups. Store them into the options.
764 (let ((g (class-option-assoc options :custom-groups)))
765 (mapc (lambda (cg) (add-to-list 'g cg)) groups)
766 (if (memq :custom-groups options)
767 (setcar (cdr (memq :custom-groups options)) g)
768 (setq options (cons :custom-groups (cons g options)))))
769
770 ;; Set up the options we have collected.
771 (aset newc class-options options)
772
773 ;; if this is a superclass, clear out parent (which was set to the
774 ;; default superclass eieio-default-superclass)
775 (if clearparent (aset newc class-parent nil))
776
777 ;; Create the cached default object.
778 (let ((cache (make-vector (+ (length (aref newc class-public-a))
779 3) nil)))
780 (aset cache 0 'object)
781 (aset cache object-class cname)
782 (aset cache object-name 'default-cache-object)
783 (let ((eieio-skip-typecheck t))
784 ;; All type-checking has been done to our satisfaction
785 ;; before this call. Don't waste our time in this call..
786 (eieio-set-defaults cache t))
787 (aset newc class-default-object-cache cache))
788
789 ;; Return our new class object
790 ;; newc
791 cname
792 ))
793
794(defun eieio-perform-slot-validation-for-default (slot spec value skipnil)
795 "For SLOT, signal if SPEC does not match VALUE.
796If SKIPNIL is non-nil, then if VALUE is nil, return t."
797 (let ((val (eieio-default-eval-maybe value)))
798 (if (and (not eieio-skip-typecheck)
799 (not (and skipnil (null val)))
800 (not (eieio-perform-slot-validation spec val)))
801 (signal 'invalid-slot-type (list slot spec val)))))
802
803(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc
804 &optional defaultoverride skipnil)
805 "Add into NEWC attribute A.
806If A already exists in NEWC, then do nothing. If it doesn't exist,
807then also add in D (defualt), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg.
808Argument ALLOC specifies if the slot is allocated per instance, or per class.
809If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC,
810we must override it's value for a default.
811Optional argument SKIPNIL indicates if type checking should be skipped
812if default value is nil."
813 ;; Make sure we duplicate those items that are sequences.
814 (condition-case nil
815 (if (sequencep d) (setq d (copy-sequence d)))
816 ;; This copy can fail on a cons cell with a non-cons in the cdr. Lets skip it if it doesn't work.
817 (error nil))
818 (if (sequencep type) (setq type (copy-sequence type)))
819 (if (sequencep cust) (setq cust (copy-sequence cust)))
820 (if (sequencep custg) (setq custg (copy-sequence custg)))
821
822 ;; To prevent override information w/out specification of storage,
823 ;; we need to do this little hack.
824 (if (member a (aref newc class-class-allocation-a)) (setq alloc ':class))
825
826 (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance)))
827 ;; In this case, we modify the INSTANCE version of a given slot.
828
829 (progn
830
831 ;; Only add this element if it is so-far unique
832 (if (not (member a (aref newc class-public-a)))
833 (progn
834 (eieio-perform-slot-validation-for-default a type d skipnil)
835 (aset newc class-public-a (cons a (aref newc class-public-a)))
836 (aset newc class-public-d (cons d (aref newc class-public-d)))
837 (aset newc class-public-doc (cons doc (aref newc class-public-doc)))
838 (aset newc class-public-type (cons type (aref newc class-public-type)))
839 (aset newc class-public-custom (cons cust (aref newc class-public-custom)))
840 (aset newc class-public-custom-label (cons label (aref newc class-public-custom-label)))
841 (aset newc class-public-custom-group (cons custg (aref newc class-public-custom-group)))
842 (aset newc class-public-printer (cons print (aref newc class-public-printer)))
843 (aset newc class-protection (cons prot (aref newc class-protection)))
844 (aset newc class-initarg-tuples (cons (cons init a) (aref newc class-initarg-tuples)))
845 )
846 ;; When defaultoverride is true, we are usually adding new local
847 ;; attributes which must override the default value of any slot
848 ;; passed in by one of the parent classes.
849 (when defaultoverride
850 ;; There is a match, and we must override the old value.
851 (let* ((ca (aref newc class-public-a))
852 (np (member a ca))
853 (num (- (length ca) (length np)))
854 (dp (if np (nthcdr num (aref newc class-public-d))
855 nil))
856 (tp (if np (nth num (aref newc class-public-type))))
857 )
858 (if (not np)
859 (error "Eieio internal error overriding default value for %s"
860 a)
861 ;; If type is passed in, is it the same?
862 (if (not (eq type t))
863 (if (not (equal type tp))
864 (error
865 "Child slot type `%s' does not match inherited type `%s' for `%s'"
866 type tp a)))
867 ;; If we have a repeat, only update the initarg...
868 (unless (eq d eieio-unbound)
869 (eieio-perform-slot-validation-for-default a tp d skipnil)
870 (setcar dp d))
871 ;; If we have a new initarg, check for it.
872 (when init
873 (let* ((inits (aref newc class-initarg-tuples))
874 (inita (rassq a inits)))
875 ;; Replace the CAR of the associate INITA.
876 ;;(message "Initarg: %S replace %s" inita init)
877 (setcar inita init)
878 ))
879
880 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
881 ;; checked and SHOULD match the superclass
882 ;; protection. Otherwise an error is thrown. However
883 ;; I wonder if a more flexible schedule might be
884 ;; implemented.
885 ;;
886 ;; EML - We used to have (if prot... here,
887 ;; but a prot of 'nil means public.
888 ;;
889 (let ((super-prot (nth num (aref newc class-protection)))
890 )
891 (if (not (eq prot super-prot))
892 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
893 prot super-prot a)))
894 ;; End original PLN
895
896 ;; PLN Tue Jun 26 11:57:06 2007 :
897 ;; We do a non redundant combination of ancient
898 ;; custom groups and new ones using the common lisp
899 ;; `union' method.
900 (when custg
901 (let ((where-groups
902 (nthcdr num (aref newc class-public-custom-group))))
903 (setcar where-groups
904 (union (car where-groups)
905 (if (listp custg) custg (list custg))))))
906 ;; End PLN
907
908 ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is
909 ;; set, simply replaces the old one.
910 (when cust
911 ;; (message "Custom type redefined to %s" cust)
912 (setcar (nthcdr num (aref newc class-public-custom)) cust))
913
914 ;; If a new label is specified, it simply replaces
915 ;; the old one.
916 (when label
917 ;; (message "Custom label redefined to %s" label)
918 (setcar (nthcdr num (aref newc class-public-custom-label)) label))
919 ;; End PLN
920
921 ;; PLN Sat Jun 30 17:24:42 2007 : when a new
922 ;; doc is specified, simply replaces the old one.
923 (when doc
924 ;;(message "Documentation redefined to %s" doc)
925 (setcar (nthcdr num (aref newc class-public-doc))
926 doc))
927 ;; End PLN
928
929 ;; If a new printer is specified, it simply replaces
930 ;; the old one.
931 (when print
932 ;; (message "printer redefined to %s" print)
933 (setcar (nthcdr num (aref newc class-public-printer)) print))
934
935 )))
936 ))
937
938 ;; CLASS ALLOCATED SLOTS
939 (let ((value (eieio-default-eval-maybe d)))
940 (if (not (member a (aref newc class-class-allocation-a)))
941 (progn
942 (eieio-perform-slot-validation-for-default a type value skipnil)
943 ;; Here we have found a :class version of a slot. This
944 ;; requires a very different aproach.
945 (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a)))
946 (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc)))
947 (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type)))
948 (aset newc class-class-allocation-custom (cons cust (aref newc class-class-allocation-custom)))
949 (aset newc class-class-allocation-custom-label (cons label (aref newc class-class-allocation-custom-label)))
950 (aset newc class-class-allocation-custom-group (cons custg (aref newc class-class-allocation-custom-group)))
951 (aset newc class-class-allocation-protection (cons prot (aref newc class-class-allocation-protection)))
952 ;; Default value is stored in the 'values section, since new objects
953 ;; can't initialize from this element.
954 (aset newc class-class-allocation-values (cons value (aref newc class-class-allocation-values))))
955 (when defaultoverride
956 ;; There is a match, and we must override the old value.
957 (let* ((ca (aref newc class-class-allocation-a))
958 (np (member a ca))
959 (num (- (length ca) (length np)))
960 (dp (if np
961 (nthcdr num
962 (aref newc class-class-allocation-values))
963 nil))
964 (tp (if np (nth num (aref newc class-class-allocation-type))
965 nil)))
966 (if (not np)
967 (error "Eieio internal error overriding default value for %s"
968 a)
969 ;; If type is passed in, is it the same?
970 (if (not (eq type t))
971 (if (not (equal type tp))
972 (error
973 "Child slot type `%s' does not match inherited type `%s' for `%s'"
974 type tp a)))
975 ;; EML - Note: the only reason to override a class bound slot
976 ;; is to change the default, so allow unbound in.
977
978 ;; If we have a repeat, only update the vlaue...
979 (eieio-perform-slot-validation-for-default a tp value skipnil)
980 (setcar dp value))
981
982 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
983 ;; checked and SHOULD match the superclass
984 ;; protection. Otherwise an error is thrown. However
985 ;; I wonder if a more flexible schedule might be
986 ;; implemented.
987 (let ((super-prot
988 (car (nthcdr num (aref newc class-class-allocation-protection)))))
989 (if (not (eq prot super-prot))
990 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
991 prot super-prot a)))
992 ;; We do a non redundant combination of ancient
993 ;; custom groups and new ones using the common lisp
994 ;; `union' method.
995 (when custg
996 (let ((where-groups
997 (nthcdr num (aref newc class-class-allocation-custom-group))))
998 (setcar where-groups
999 (union (car where-groups)
1000 (if (listp custg) custg (list custg))))))
1001 ;; End PLN
1002
1003 ;; PLN Sat Jun 30 17:24:42 2007 : when a new
1004 ;; doc is specified, simply replaces the old one.
1005 (when doc
1006 ;;(message "Documentation redefined to %s" doc)
1007 (setcar (nthcdr num (aref newc class-class-allocation-doc))
1008 doc))
1009 ;; End PLN
1010
1011 ;; If a new printer is specified, it simply replaces
1012 ;; the old one.
1013 (when print
1014 ;; (message "printer redefined to %s" print)
1015 (setcar (nthcdr num (aref newc class-class-allocation-printer)) print))
1016
1017 ))
1018 ))
1019 ))
1020
1021(defun eieio-copy-parents-into-subclass (newc parents)
1022 "Copy into NEWC the slots of PARENTS.
1023Follow the rules of not overwritting early parents when applying to
1024the new child class."
1025 (let ((ps (aref newc class-parent))
1026 (sn (class-option-assoc (aref newc class-options)
1027 ':allow-nil-initform)))
1028 (while ps
1029 ;; First, duplicate all the slots of the parent.
1030 (let ((pcv (class-v (car ps))))
1031 (let ((pa (aref pcv class-public-a))
1032 (pd (aref pcv class-public-d))
1033 (pdoc (aref pcv class-public-doc))
1034 (ptype (aref pcv class-public-type))
1035 (pcust (aref pcv class-public-custom))
1036 (plabel (aref pcv class-public-custom-label))
1037 (pcustg (aref pcv class-public-custom-group))
1038 (printer (aref pcv class-public-printer))
1039 (pprot (aref pcv class-protection))
1040 (pinit (aref pcv class-initarg-tuples))
1041 (i 0))
1042 (while pa
1043 (eieio-add-new-slot newc
1044 (car pa) (car pd) (car pdoc) (aref ptype i)
1045 (car pcust) (car plabel) (car pcustg)
1046 (car printer)
1047 (car pprot) (car-safe (car pinit)) nil nil sn)
1048 ;; Increment each value.
1049 (setq pa (cdr pa)
1050 pd (cdr pd)
1051 pdoc (cdr pdoc)
1052 i (1+ i)
1053 pcust (cdr pcust)
1054 plabel (cdr plabel)
1055 pcustg (cdr pcustg)
1056 printer (cdr printer)
1057 pprot (cdr pprot)
1058 pinit (cdr pinit))
1059 )) ;; while/let
1060 ;; Now duplicate all the class alloc slots.
1061 (let ((pa (aref pcv class-class-allocation-a))
1062 (pdoc (aref pcv class-class-allocation-doc))
1063 (ptype (aref pcv class-class-allocation-type))
1064 (pcust (aref pcv class-class-allocation-custom))
1065 (plabel (aref pcv class-class-allocation-custom-label))
1066 (pcustg (aref pcv class-class-allocation-custom-group))
1067 (printer (aref pcv class-class-allocation-printer))
1068 (pprot (aref pcv class-class-allocation-protection))
1069 (pval (aref pcv class-class-allocation-values))
1070 (i 0))
1071 (while pa
1072 (eieio-add-new-slot newc
1073 (car pa) (aref pval i) (car pdoc) (aref ptype i)
1074 (car pcust) (car plabel) (car pcustg)
1075 (car printer)
1076 (car pprot) nil ':class sn)
1077 ;; Increment each value.
1078 (setq pa (cdr pa)
1079 pdoc (cdr pdoc)
1080 pcust (cdr pcust)
1081 plabel (cdr plabel)
1082 pcustg (cdr pcustg)
1083 printer (cdr printer)
1084 pprot (cdr pprot)
1085 i (1+ i))
1086 ))) ;; while/let
1087 ;; Loop over each parent class
1088 (setq ps (cdr ps)))
1089 ))
1090
1091;;; CLOS style implementation of object creators.
1092;;
1093(defun make-instance (class &rest initargs)
1094 "Make a new instance of CLASS based on INITARGS.
1095CLASS is a class symbol. For example:
1096
1097 (make-instance 'foo)
1098
1099 INITARGS is a property list with keywords based on the :initarg
1100for each slot. For example:
1101
1102 (make-instance 'foo :slot1 value1 :slotN valueN)
1103
1104Compatability note:
1105
1106If the first element of INITARGS is a string, it is used as the
1107name of the class.
1108
1109In EIEIO, the class' constructor requires a name for use when printing.
1110`make-instance' in CLOS doesn't use names the way Emacs does, so the
1111class is used as the name slot instead when INITARGS doesn't start with
1112a string."
1113 (if (and (car initargs) (stringp (car initargs)))
1114 (apply (class-constructor class) initargs)
1115 (apply (class-constructor class)
1116 (cond ((symbolp class) (symbol-name class))
1117 (t (format "%S" class)))
1118 initargs)))
1119
1120
1121;;; CLOS methods and generics
1122;;
1123(defmacro defgeneric (method args &optional doc-string)
1124 "Create a generic function METHOD. ARGS is ignored.
1125DOC-STRING is the base documentation for this class. A generic
1126function has no body, as it's purpose is to decide which method body
1127is appropriate to use. Use `defmethod' to create methods, and it
1128calls defgeneric for you. With this implementation the arguments are
1129currently ignored. You can use `defgeneric' to apply specialized
1130top level documentation to a method."
1131 `(eieio-defgeneric (quote ,method) ,doc-string))
1132
1133(defun eieio-defgeneric-form (method doc-string)
1134 "The lambda form that would be used as the function defined on METHOD.
1135All methods should call the same EIEIO function for dispatch.
1136DOC-STRING is the documentation attached to METHOD."
1137 `(lambda (&rest local-args)
1138 ,doc-string
1139 (eieio-generic-call (quote ,method) local-args)))
1140
1141(defsubst eieio-defgeneric-reset-generic-form (method)
1142 "Setup METHOD to call the generic form."
1143 (let ((doc-string (documentation method)))
1144 (fset method (eieio-defgeneric-form method doc-string))))
1145
1146(defun eieio-defgeneric-form-primary-only (method doc-string)
1147 "The lambda form that would be used as the function defined on METHOD.
1148All methods should call the same EIEIO function for dispatch.
1149DOC-STRING is the documentation attached to METHOD."
1150 `(lambda (&rest local-args)
1151 ,doc-string
1152 (eieio-generic-call-primary-only (quote ,method) local-args)))
1153
1154(defsubst eieio-defgeneric-reset-generic-form-primary-only (method)
1155 "Setup METHOD to call the generic form."
1156 (let ((doc-string (documentation method)))
1157 (fset method (eieio-defgeneric-form-primary-only method doc-string))))
1158
1159(defun eieio-defgeneric-form-primary-only-one (method doc-string
1160 class
1161 impl
1162 )
1163 "The lambda form that would be used as the function defined on METHOD.
1164All methods should call the same EIEIO function for dispatch.
1165DOC-STRING is the documentation attached to METHOD.
1166CLASS is the class symbol needed for private method access.
1167IMPL is the symbol holding the method implementation."
1168 ;; NOTE: I tried out byte compiling this little fcn. Turns out it
1169 ;; is faster to execute this for not byte-compiled. ie, install this,
1170 ;; then measure calls going through here. I wonder why.
1171 (require 'bytecomp)
1172 (let ((byte-compile-free-references nil)
1173 (byte-compile-warnings nil)
1174 )
1175 (byte-compile-lambda
1176 `(lambda (&rest local-args)
1177 ,doc-string
1178 ;; This is a cool cheat. Usually we need to look up in the
1179 ;; method table to find out if there is a method or not. We can
1180 ;; instead make that determination at load time when there is
1181 ;; only one method. If the first arg is not a child of the class
1182 ;; of that one implementation, then clearly, there is no method def.
1183 (if (not (eieio-object-p (car local-args)))
1184 ;; Not an object. Just signal.
1185 (signal 'no-method-definition (list ,(list 'quote method) local-args))
1186
1187 ;; We do have an object. Make sure it is the right type.
1188 (if ,(if (eq class eieio-default-superclass)
1189 nil ; default superclass means just an obj. Already asked.
1190 `(not (child-of-class-p (aref (car local-args) object-class)
1191 ,(list 'quote class)))
1192 )
1193
1194 ;; If not the right kind of object, call no applicable
1195 (apply 'no-applicable-method (car local-args)
1196 ,(list 'quote method) local-args)
1197
1198 ;; It is ok, do the call.
1199 ;; Fill in inter-call variables then evaluate the method.
1200 (let ((scoped-class ,(list 'quote class))
1201 (eieio-generic-call-next-method-list nil)
1202 (eieio-generic-call-key method-primary)
1203 (eieio-generic-call-methodname ,(list 'quote method))
1204 (eieio-generic-call-arglst local-args)
1205 )
1206 (apply ,(list 'quote impl) local-args)
1207 ;(,impl local-args)
1208 ))))
1209 )
1210 ))
1211
1212(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
1213 "Setup METHOD to call the generic form."
1214 (let* ((doc-string (documentation method))
1215 (M (get method 'eieio-method-tree))
1216 (entry (car (aref M method-primary)))
1217 )
1218 (fset method (eieio-defgeneric-form-primary-only-one
1219 method doc-string
1220 (car entry)
1221 (cdr entry)
1222 ))))
1223
1224(defun eieio-defgeneric (method doc-string)
1225 "Engine part to `defgeneric' macro defining METHOD with DOC-STRING."
1226 (if (and (fboundp method) (not (generic-p method))
1227 (or (byte-code-function-p (symbol-function method))
1228 (not (eq 'autoload (car (symbol-function method)))))
1229 )
1230 (error "You cannot create a generic/method over an existing symbol: %s"
1231 method))
1232 ;; Don't do this over and over.
1233 (unless (fboundp 'method)
1234 ;; This defun tells emacs where the first definition of this
1235 ;; method is defined.
1236 `(defun ,method nil)
1237 ;; Make sure the method tables are installed.
1238 (eieiomt-install method)
1239 ;; Apply the actual body of this function.
1240 (fset method (eieio-defgeneric-form method doc-string))
1241 ;; Return the method
1242 'method))
1243
1244(defun eieio-unbind-method-implementations (method)
1245 "Make the generic method METHOD have no implementations..
1246It will leave the original generic function in place, but remove
1247reference to all implementations of METHOD."
1248 (put method 'eieio-method-tree nil)
1249 (put method 'eieio-method-obarray nil))
1250
1251(defmacro defmethod (method &rest args)
1252 "Create a new METHOD through `defgeneric' with ARGS.
1253
1254The second optional argument KEY is a specifier that
1255modifies how the method is called, including:
1256 :before - Method will be called before the :primary
1257 :primary - The default if not specified.
1258 :after - Method will be called after the :primary
1259 :static - First arg could be an object or class
1260The next argument is the ARGLIST. The ARGLIST specifies the arguments
1261to the method as with `defun'. The first argument can have a type
1262specifier, such as:
1263 ((VARNAME CLASS) ARG2 ...)
1264where VARNAME is the name of the local variable for the method being
1265created. The CLASS is a class symbol for a class made with `defclass'.
1266A DOCSTRING comes after the ARGLIST, and is optional.
1267All the rest of the args are the BODY of the method. A method will
1268return the value of the last form in the BODY.
1269
1270Summary:
1271
1272 (defmethod mymethod [:before | :primary | :after | :static]
1273 ((typearg class-name) arg2 &optional opt &rest rest)
1274 \"doc-string\"
1275 body)"
1276 `(eieio-defmethod (quote ,method) (quote ,args)))
1277
1278(defun eieio-defmethod (method args)
1279 "Work part of the `defmethod' macro defining METHOD with ARGS."
1280 (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
1281 ;; find optional keys
1282 (setq key
1283 (cond ((or (eq ':BEFORE (car args))
1284 (eq ':before (car args)))
1285 (setq args (cdr args))
1286 method-before)
1287 ((or (eq ':AFTER (car args))
1288 (eq ':after (car args)))
1289 (setq args (cdr args))
1290 method-after)
1291 ((or (eq ':PRIMARY (car args))
1292 (eq ':primary (car args)))
1293 (setq args (cdr args))
1294 method-primary)
1295 ((or (eq ':STATIC (car args))
1296 (eq ':static (car args)))
1297 (setq args (cdr args))
1298 method-static)
1299 ;; Primary key
1300 (t method-primary)))
1301 ;; get body, and fix contents of args to be the arguments of the fn.
1302 (setq body (cdr args)
1303 args (car args))
1304 (setq loopa args)
1305 ;; Create a fixed version of the arguments
1306 (while loopa
1307 (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
1308 argfix))
1309 (setq loopa (cdr loopa)))
1310 ;; make sure there is a generic
1311 (eieio-defgeneric
1312 method
1313 (if (stringp (car body))
1314 (car body) (format "Generically created method `%s'" method)))
1315 ;; create symbol for property to bind to. If the first arg is of
1316 ;; the form (varname vartype) and `vartype' is a class, then
1317 ;; that class will be the type symbol. If not, then it will fall
1318 ;; under the type `primary' which is a non-specific calling of the
1319 ;; function.
1320 (setq firstarg (car args))
1321 (if (listp firstarg)
1322 (progn
1323 (setq argclass (nth 1 firstarg))
1324 (if (not (class-p argclass))
1325 (error "Unknown class type %s in method parameters"
1326 (nth 1 firstarg))))
1327 (if (= key -1)
1328 (signal 'wrong-type-argument (list :static 'non-class-arg)))
1329 ;; generics are higher
1330 (setq key (+ key 3)))
1331 ;; Put this lambda into the symbol so we can find it
1332 (if (byte-code-function-p (car-safe body))
1333 (eieiomt-add method (car-safe body) key argclass)
1334 (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
1335 key argclass))
1336 )
1337
1338 (when eieio-optimize-primary-methods-flag
1339 ;; Optimizing step:
1340 ;;
1341 ;; If this method, after this setup, only has primary methods, then
1342 ;; we can setup the generic that way.
1343 (if (generic-primary-only-p method)
1344 ;; If there is only one primary method, then we can go one more
1345 ;; optimization step.
1346 (if (generic-primary-only-one-p method)
1347 (eieio-defgeneric-reset-generic-form-primary-only-one method)
1348 (eieio-defgeneric-reset-generic-form-primary-only method))
1349 (eieio-defgeneric-reset-generic-form method)))
1350
1351 method)
1352
1353;;; Slot type validation
1354;;
1355(defun eieio-perform-slot-validation (spec value)
1356 "Return non-nil if SPEC does not match VALUE."
1357 ;; typep is in cl-macs
1358 (or (eq spec t) ; t always passes
1359 (eq value eieio-unbound) ; unbound always passes
1360 (typep value spec)))
1361
1362(defun eieio-validate-slot-value (class slot-idx value slot)
1363 "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid.
1364Checks the :type specifier.
1365SLOT is the slot that is being checked, and is only used when throwing
1366and error."
1367 (if eieio-skip-typecheck
1368 nil
1369 ;; Trim off object IDX junk added in for the object index.
1370 (setq slot-idx (- slot-idx 3))
1371 (let ((st (aref (aref (class-v class) class-public-type) slot-idx)))
1372 (if (not (eieio-perform-slot-validation st value))
1373 (signal 'invalid-slot-type (list class slot st value))))))
1374
1375(defun eieio-validate-class-slot-value (class slot-idx value slot)
1376 "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid.
1377Checks the :type specifier.
1378SLOT is the slot that is being checked, and is only used when throwing
1379and error."
1380 (if eieio-skip-typecheck
1381 nil
1382 (let ((st (aref (aref (class-v class) class-class-allocation-type)
1383 slot-idx)))
1384 (if (not (eieio-perform-slot-validation st value))
1385 (signal 'invalid-slot-type (list class slot st value))))))
1386
1387(defun eieio-barf-if-slot-unbound (value instance slotname fn)
1388 "Throw a signal if VALUE is a representation of an UNBOUND slot.
1389INSTANCE is the object being referenced. SLOTNAME is the offending
1390slot. If the slot is ok, return VALUE.
1391Argument FN is the function calling this verifier."
1392 (if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
1393 (slot-unbound instance (object-class instance) slotname fn)
1394 value))
1395
1396;;; Missing types that are useful to me.
1397;;
1398(defun boolean-p (bool)
1399 "Return non-nil if BOOL is nil or t."
1400 (or (null bool) (eq bool t)))
1401
1402;;; Get/Set slots in an object.
1403;;
1404(defmacro oref (obj slot)
1405 "Retrieve the value stored in OBJ in the slot named by SLOT.
1406Slot is the name of the slot when created by `defclass' or the label
1407created by the :initarg tag."
1408 `(eieio-oref ,obj (quote ,slot)))
1409
1410(defun eieio-oref (obj slot)
1411 "Return the value in OBJ at SLOT in the object vector."
1412 (if (not (or (eieio-object-p obj) (class-p obj)))
1413 (signal 'wrong-type-argument (list '(or eieio-object-p class-p) obj)))
1414 (if (not (symbolp slot))
1415 (signal 'wrong-type-argument (list 'symbolp slot)))
1416 (if (class-p obj) (eieio-class-un-autoload obj))
1417 (let* ((class (if (class-p obj) obj (aref obj object-class)))
1418 (c (eieio-slot-name-index class obj slot)))
1419 (if (not c)
1420 ;; It might be missing because it is a :class allocated slot.
1421 ;; Lets check that info out.
1422 (if (setq c (eieio-class-slot-name-index class slot))
1423 ;; Oref that slot.
1424 (aref (aref (class-v class) class-class-allocation-values) c)
1425 ;; The slot-missing method is a cool way of allowing an object author
1426 ;; to intercept missing slot definitions. Since it is also the LAST
1427 ;; thing called in this fn, it's return value would be retrieved.
1428 (slot-missing obj slot 'oref)
1429 ;;(signal 'invalid-slot-name (list (object-name obj) slot))
1430 )
1431 (if (not (eieio-object-p obj))
1432 (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1433 (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
1434
1435(defalias 'slot-value 'eieio-oref)
1436(defalias 'set-slot-value 'eieio-oset)
1437
1438(defmacro oref-default (obj slot)
1439 "Gets the default value of OBJ (maybe a class) for SLOT.
1440The default value is the value installed in a class with the :initform
1441tag. SLOT can be the slot name, or the tag specified by the :initarg
1442tag in the `defclass' call."
1443 `(eieio-oref-default ,obj (quote ,slot)))
1444
1445(defun eieio-oref-default (obj slot)
1446 "Does the work for the macro `oref-default' with similar parameters.
1447Fills in OBJ's SLOT with it's default value."
1448 (if (not (or (eieio-object-p obj) (class-p obj))) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1449 (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
1450 (let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj))
1451 (c (eieio-slot-name-index cl obj slot)))
1452 (if (not c)
1453 ;; It might be missing because it is a :class allocated slot.
1454 ;; Lets check that info out.
1455 (if (setq c
1456 (eieio-class-slot-name-index cl slot))
1457 ;; Oref that slot.
1458 (aref (aref (class-v cl) class-class-allocation-values)
1459 c)
1460 (slot-missing obj slot 'oref-default)
1461 ;;(signal 'invalid-slot-name (list (class-name cl) slot))
1462 )
1463 (eieio-barf-if-slot-unbound
1464 (let ((val (nth (- c 3) (aref (class-v cl) class-public-d))))
1465 (eieio-default-eval-maybe val))
1466 obj cl 'oref-default))))
1467
1468(defun eieio-default-eval-maybe (val)
1469 "Check VAL, and return what `oref-default' would provide."
1470 ;; check for quoted things, and unquote them
1471 (if (and (listp val) (eq (car val) 'quote))
1472 (car (cdr val))
1473 ;; return it verbatim
1474 val))
1475
1476;;; Object Set macros
1477;;
1478(defmacro oset (obj slot value)
1479 "Set the value in OBJ for slot SLOT to VALUE.
1480SLOT is the slot name as specified in `defclass' or the tag created
1481with in the :initarg slot. VALUE can be any Lisp object."
1482 `(eieio-oset ,obj (quote ,slot) ,value))
1483
1484(defun eieio-oset (obj slot value)
1485 "Does the work for the macro `oset'.
1486Fills in OBJ's SLOT with VALUE."
1487 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1488 (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
1489 (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot)))
1490 (if (not c)
1491 ;; It might be missing because it is a :class allocated slot.
1492 ;; Lets check that info out.
1493 (if (setq c
1494 (eieio-class-slot-name-index (aref obj object-class) slot))
1495 ;; Oset that slot.
1496 (progn
1497 (eieio-validate-class-slot-value (object-class-fast obj) c value slot)
1498 (aset (aref (class-v (aref obj object-class))
1499 class-class-allocation-values)
1500 c value))
1501 ;; See oref for comment on `slot-missing'
1502 (slot-missing obj slot 'oset value)
1503 ;;(signal 'invalid-slot-name (list (object-name obj) slot))
1504 )
1505 (eieio-validate-slot-value (object-class-fast obj) c value slot)
1506 (aset obj c value))))
1507
1508(defmacro oset-default (class slot value)
1509 "Set the default slot in CLASS for SLOT to VALUE.
1510The default value is usually set with the :initform tag during class
1511creation. This allows users to change the default behavior of classes
1512after they are created."
1513 `(eieio-oset-default ,class (quote ,slot) ,value))
1514
1515(defun eieio-oset-default (class slot value)
1516 "Does the work for the macro `oset-default'.
1517Fills in the default value in CLASS' in SLOT with VALUE."
1518 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
1519 (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
1520 (let* ((scoped-class class)
1521 (c (eieio-slot-name-index class nil slot)))
1522 (if (not c)
1523 ;; It might be missing because it is a :class allocated slot.
1524 ;; Lets check that info out.
1525 (if (setq c (eieio-class-slot-name-index class slot))
1526 (progn
1527 ;; Oref that slot.
1528 (eieio-validate-class-slot-value class c value slot)
1529 (aset (aref (class-v class) class-class-allocation-values) c
1530 value))
1531 (signal 'invalid-slot-name (list (class-name class) slot)))
1532 (eieio-validate-slot-value class c value slot)
1533 ;; Set this into the storage for defaults.
1534 (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d))
1535 value)
1536 ;; Take the value, and put it into our cache object.
1537 (eieio-oset (aref (class-v class) class-default-object-cache)
1538 slot value)
1539 )))
1540
1541;;; Handy CLOS macros
1542;;
1543(defmacro with-slots (spec-list object &rest body)
1544 "Bind SPEC-LIST lexically to slot values in OBJECT, and execute BODY.
1545This establishes a lexical environment for referring to the slots in
1546the instance named by the given slot-names as though they were
1547variables. Within such a context the value of the slot can be
1548specified by using its slot name, as if it were a lexically bound
1549variable. Both setf and setq can be used to set the value of the
1550slot.
1551
1552SPEC-LIST is of a form similar to `let'. For example:
1553
1554 ((VAR1 SLOT1)
1555 SLOT2
1556 SLOTN
1557 (VARN+1 SLOTN+1))
1558
1559Where each VAR is the local variable given to the associated
1560SLOT. A Slot specified without a variable name is given a
1561variable name of the same name as the slot."
1562 ;; Transform the spec-list into a symbol-macrolet spec-list.
1563 (let ((mappings (mapcar (lambda (entry)
1564 (let ((var (if (listp entry) (car entry) entry))
1565 (slot (if (listp entry) (cadr entry) entry)))
1566 (list var `(slot-value ,object ',slot))))
1567 spec-list)))
1568 (append (list 'symbol-macrolet mappings)
1569 body)))
1570(put 'with-slots 'lisp-indent-function 2)
1571
1572
1573;;; Simple generators, and query functions. None of these would do
1574;; well embedded into an object.
1575;;
1576(defmacro object-class-fast (obj) "Return the class struct defining OBJ with no check."
1577 `(aref ,obj object-class))
1578
1579(defun class-name (class) "Return a Lisp like symbol name for CLASS."
1580 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
1581 ;; I think this is supposed to return a symbol, but to me CLASS is a symbol,
1582 ;; and I wanted a string. Arg!
1583 (format "#<class %s>" (symbol-name class)))
1584
1585(defun object-name (obj &optional extra)
1586 "Return a Lisp like symbol string for object OBJ.
1587If EXTRA, include that in the string returned to represent the symbol."
1588 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1589 (format "#<%s %s%s>" (symbol-name (object-class-fast obj))
1590 (aref obj object-name) (or extra "")))
1591
1592(defun object-name-string (obj) "Return a string which is OBJ's name."
1593 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1594 (aref obj object-name))
1595
1596(defun object-set-name-string (obj name) "Set the string which is OBJ's NAME."
1597 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1598 (if (not (stringp name)) (signal 'wrong-type-argument (list 'stringp name)))
1599 (aset obj object-name name))
1600
1601(defun object-class (obj) "Return the class struct defining OBJ."
1602 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1603 (object-class-fast obj))
1604(defalias 'class-of 'object-class)
1605
1606(defun object-class-name (obj) "Return a Lisp like symbol name for OBJ's class."
1607 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1608 (class-name (object-class-fast obj)))
1609
1610(defmacro class-parents-fast (class) "Return parent classes to CLASS with no check."
1611 `(aref (class-v ,class) class-parent))
1612
1613(defun class-parents (class)
1614 "Return parent classes to CLASS. (overload of variable).
1615
1616The CLOS function `class-direct-superclasses' is aliased to this function."
1617 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
1618 (class-parents-fast class))
1619
1620(defmacro class-children-fast (class) "Return child classes to CLASS with no check."
1621 `(aref (class-v ,class) class-children))
1622
1623(defun class-children (class)
1624"Return child classses to CLASS.
1625
1626The CLOS function `class-direct-subclasses' is aliased to this function."
1627 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
1628 (class-children-fast class))
1629
1630;; Official CLOS functions.
1631(defalias 'class-direct-superclasses 'class-parents)
1632(defalias 'class-direct-subclasses 'class-children)
1633
1634(defmacro class-parent-fast (class) "Return first parent class to CLASS with no check."
1635 `(car (class-parents-fast ,class)))
1636
1637(defmacro class-parent (class) "Return first parent class to CLASS. (overload of variable)."
1638 `(car (class-parents ,class)))
1639
1640(defmacro same-class-fast-p (obj class) "Return t if OBJ is of class-type CLASS with no error checking."
1641 `(eq (aref ,obj object-class) ,class))
1642
1643(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS."
1644 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
1645 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1646 (same-class-fast-p obj class))
1647
1648(defun object-of-class-p (obj class)
1649 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
1650 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1651 ;; class will be checked one layer down
1652 (child-of-class-p (aref obj object-class) class))
1653;; Backwards compatibility
1654(defalias 'obj-of-class-p 'object-of-class-p)
1655
1656(defun child-of-class-p (child class)
1657 "If CHILD class is a subclass of CLASS."
1658 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
1659 (if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p child)))
1660 (let ((p nil))
1661 (while (and child (not (eq child class)))
1662 (setq p (append p (aref (class-v child) class-parent))
1663 child (car p)
1664 p (cdr p)))
1665 (if child t)))
1666
1667(defun object-slots (obj) "List of slots available in OBJ."
1668 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1669 (aref (class-v (object-class-fast obj)) class-public-a))
1670
1671(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
1672 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
1673 (let ((ia (aref (class-v class) class-initarg-tuples))
1674 (f nil))
1675 (while (and ia (not f))
1676 (if (eq (cdr (car ia)) slot)
1677 (setq f (car (car ia))))
1678 (setq ia (cdr ia)))
1679 f))
1680
1681;;; CLOS queries into classes and slots
1682;;
1683(defun slot-boundp (object slot)
1684 "Non-nil if OBJECT's SLOT is bound.
1685Setting a slot's value makes it bound. Calling `slot-makeunbound' will
1686make a slot unbound.
1687OBJECT can be an instance or a class."
1688 ;; Skip typechecking while retrieving this value.
1689 (let ((eieio-skip-typecheck t))
1690 ;; Return nil if the magic symbol is in there.
1691 (if (eieio-object-p object)
1692 (if (eq (eieio-oref object slot) eieio-unbound) nil t)
1693 (if (class-p object)
1694 (if (eq (eieio-oref-default object slot) eieio-unbound) nil t)
1695 (signal 'wrong-type-argument (list 'eieio-object-p object))))))
1696
1697(defun slot-makeunbound (object slot)
1698 "In OBJECT, make SLOT unbound."
1699 (eieio-oset object slot eieio-unbound))
1700
1701(defun slot-exists-p (object-or-class slot)
1702 "Non-nil if OBJECT-OR-CLASS has SLOT."
1703 (let ((cv (class-v (cond ((eieio-object-p object-or-class)
1704 (object-class object-or-class))
1705 ((class-p object-or-class)
1706 object-or-class))
1707 )))
1708 (or (memq slot (aref cv class-public-a))
1709 (memq slot (aref cv class-class-allocation-a)))
1710 ))
1711
1712(defun find-class (symbol &optional errorp)
1713 "Return the class that SYMBOL represents.
1714If there is no class, nil is returned if ERRORP is nil.
1715If ERRORP is non-nil, `wrong-argument-type' is signaled."
1716 (if (not (class-p symbol))
1717 (if errorp (signal 'wrong-type-argument (list 'class-p symbol))
1718 nil)
1719 (class-v symbol)))
1720
1721;;; Slightly more complex utility functions for objects
1722;;
1723(defun object-assoc (key slot list)
1724 "Return an object if KEY is `equal' to SLOT's value of an object in LIST.
1725LIST is a list of objects who's slots are searched.
1726Objects in LIST do not need to have a slot named SLOT, nor does
1727SLOT need to be bound. If these errors occur, those objects will
1728be ignored."
1729 (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list)))
1730 (while (and list (not (condition-case nil
1731 ;; This prevents errors for missing slots.
1732 (equal key (eieio-oref (car list) slot))
1733 (error nil))))
1734 (setq list (cdr list)))
1735 (car list))
1736
1737(defun object-assoc-list (slot list)
1738 "Return an association list with the contents of SLOT as the key element.
1739LIST must be a list of objects with SLOT in it.
1740This is useful when you need to do completing read on an object group."
1741 (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list)))
1742 (let ((assoclist nil))
1743 (while list
1744 (setq assoclist (cons (cons (eieio-oref (car list) slot)
1745 (car list))
1746 assoclist))
1747 (setq list (cdr list)))
1748 (nreverse assoclist)))
1749
1750(defun object-assoc-list-safe (slot list)
1751 "Return an association list with the contents of SLOT as the key element.
1752LIST must be a list of objects, but those objects do not need to have
1753SLOT in it. If it does not, then that element is left out of the association
1754list."
1755 (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list)))
1756 (let ((assoclist nil))
1757 (while list
1758 (if (slot-exists-p (car list) slot)
1759 (setq assoclist (cons (cons (eieio-oref (car list) slot)
1760 (car list))
1761 assoclist)))
1762 (setq list (cdr list)))
1763 (nreverse assoclist)))
1764
1765(defun object-add-to-list (object slot item &optional append)
1766 "In OBJECT's SLOT, add ITEM to the list of elements.
1767Optional argument APPEND indicates we need to append to the list.
1768If ITEM already exists in the list in SLOT, then it is not added.
1769Comparison is done with `equal' through the `member' function call.
1770If SLOT is unbound, bind it to the list containing ITEM."
1771 (let (ov)
1772 ;; Find the originating list.
1773 (if (not (slot-boundp object slot))
1774 (setq ov (list item))
1775 (setq ov (eieio-oref object slot))
1776 ;; turn it into a list.
1777 (unless (listp ov)
1778 (setq ov (list ov)))
1779 ;; Do the combination
1780 (if (not (member item ov))
1781 (setq ov
1782 (if append
1783 (append ov (list item))
1784 (cons item ov)))))
1785 ;; Set back into the slot.
1786 (eieio-oset object slot ov)))
1787
1788(defun object-remove-from-list (object slot item)
1789 "In OBJECT's SLOT, remove occurrences of ITEM.
1790Deletion is done with `delete', which deletes by side effect
1791and comparisons are done with `equal'.
1792If SLOT is unbound, do nothing."
1793 (if (not (slot-boundp object slot))
1794 nil
1795 (eieio-oset object slot (delete item (eieio-oref object slot)))))
1796
1797;;; EIEIO internal search functions
1798;;
1799(defun eieio-slot-originating-class-p (start-class slot)
1800 "Return Non-nil if START-CLASS is the first class to define SLOT.
1801This is for testing if `scoped-class' is the class that defines SLOT
1802so that we can protect private slots."
1803 (let ((par (class-parents start-class))
1804 (ret t))
1805 (if (not par)
1806 t
1807 (while (and par ret)
1808 (if (intern-soft (symbol-name slot)
1809 (aref (class-v (car par))
1810 class-symbol-obarray))
1811 (setq ret nil))
1812 (setq par (cdr par)))
1813 ret)))
1814
1815(defun eieio-slot-name-index (class obj slot)
1816 "In CLASS for OBJ find the index of the named SLOT.
1817The slot is a symbol which is installed in CLASS by the `defclass'
1818call. OBJ can be nil, but if it is an object, and the slot in question
1819is protected, access will be allowed if obj is a child of the currently
1820`scoped-class'.
1821If SLOT is the value created with :initarg instead,
1822reverse-lookup that name, and recurse with the associated slot value."
1823 ;; Removed checks to outside this call
1824 (let* ((fsym (intern-soft (symbol-name slot)
1825 (aref (class-v class)
1826 class-symbol-obarray)))
1827 (fsi (if (symbolp fsym) (symbol-value fsym) nil)))
1828 (if (integerp fsi)
1829 (cond
1830 ((not (get fsym 'protection))
1831 (+ 3 fsi))
1832 ((and (eq (get fsym 'protection) 'protected)
1833 scoped-class
1834 (or (child-of-class-p class scoped-class)
1835 (and (eieio-object-p obj)
1836 (child-of-class-p class (object-class obj)))))
1837 (+ 3 fsi))
1838 ((and (eq (get fsym 'protection) 'private)
1839 (or (and scoped-class
1840 (eieio-slot-originating-class-p scoped-class slot))
1841 eieio-initializing-object))
1842 (+ 3 fsi))
1843 (t nil))
1844 (let ((fn (eieio-initarg-to-attribute class slot)))
1845 (if fn (eieio-slot-name-index class obj fn) nil)))))
1846
1847(defun eieio-class-slot-name-index (class slot)
1848 "In CLASS find the index of the named SLOT.
1849The slot is a symbol which is installed in CLASS by the `defclass'
1850call. If SLOT is the value created with :initarg instead,
1851reverse-lookup that name, and recurse with the associated slot value."
1852 ;; This will happen less often, and with fewer slots. Do this the
1853 ;; storage cheap way.
1854 (let* ((a (aref (class-v class) class-class-allocation-a))
1855 (l1 (length a))
1856 (af (memq slot a))
1857 (l2 (length af)))
1858 ;; Slot # is length of the total list, minus the remaining list of
1859 ;; the found slot.
1860 (if af (- l1 l2))))
1861
1862;;; CLOS generics internal function handling
1863;;
1864(defvar eieio-generic-call-methodname nil
1865 "When using `call-next-method', provides a context on how to do it.")
1866(defvar eieio-generic-call-arglst nil
1867 "When using `call-next-method', provides a context for parameters.")
1868(defvar eieio-generic-call-key nil
1869 "When using `call-next-method', provides a context for the current key.
1870Keys are a number representing :before, :primary, and :after methods.")
1871(defvar eieio-generic-call-next-method-list nil
1872 "When executing a PRIMARY or STATIC method, track the 'next-method'.
1873During executions, the list is first generated, then as each next method
1874is called, the next method is popped off the stack.")
1875
1876(defvar eieio-pre-method-execution-hooks nil
1877 "*Hooks run just before a method is executed.
1878The hook function must accept on argument, this list of forms
1879about to be executed.")
1880
1881(defun eieio-generic-call (method args)
1882 "Call METHOD with ARGS.
1883ARGS provides the context on which implementation to use.
1884This should only be called from a generic function."
1885 ;; We must expand our arguments first as they are always
1886 ;; passed in as quoted symbols
1887 (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil)
1888 (eieio-generic-call-methodname method)
1889 (eieio-generic-call-arglst args)
1890 (firstarg nil)
1891 (primarymethodlist nil))
1892 ;; get a copy
1893 (setq newargs args
1894 firstarg (car newargs))
1895 ;; Is the class passed in autoloaded?
1896 ;; Since class names are also constructors, they can be autoloaded
1897 ;; via the autoload command. Check for this, and load them in.
1898 ;; It's ok if it doesn't turn out to be a class. Probably want that
1899 ;; function loaded anyway.
1900 (if (and (symbolp firstarg)
1901 (fboundp firstarg)
1902 (listp (symbol-function firstarg))
1903 (eq 'autoload (car (symbol-function firstarg))))
1904 (load (nth 1 (symbol-function firstarg))))
1905 ;; Determine the class to use.
1906 (cond ((eieio-object-p firstarg)
1907 (setq mclass (object-class-fast firstarg)))
1908 ((class-p firstarg)
1909 (setq mclass firstarg))
1910 )
1911 ;; Make sure the class is a valid class
1912 ;; mclass can be nil (meaning a generic for should be used.
1913 ;; mclass cannot have a value that is not a class, however.
1914 (when (and (not (null mclass)) (not (class-p mclass)))
1915 (error "Cannot dispatch method %S on class %S"
1916 method mclass)
1917 )
1918 ;; Now create a list in reverse order of all the calls we have
1919 ;; make in order to successfully do this right. Rules:
1920 ;; 1) Only call generics if scoped-class is not defined
1921 ;; This prevents multiple calls in the case of recursion
1922 ;; 2) Only call static if this is a static method.
1923 ;; 3) Only call specifics if the definition allows for them.
1924 ;; 4) Call in order based on :before, :primary, and :after
1925 (when (eieio-object-p firstarg)
1926 ;; Non-static calls do all this stuff.
1927
1928 ;; :after methods
1929 (setq tlambdas
1930 (if mclass
1931 (eieiomt-method-list method method-after mclass)
1932 (list (eieio-generic-form method method-after nil)))
1933 ;;(or (and mclass (eieio-generic-form method method-after mclass))
1934 ;; (eieio-generic-form method method-after nil))
1935 )
1936 (setq lambdas (append tlambdas lambdas)
1937 keys (append (make-list (length tlambdas) method-after) keys))
1938
1939 ;; :primary methods
1940 (setq tlambdas
1941 (or (and mclass (eieio-generic-form method method-primary mclass))
1942 (eieio-generic-form method method-primary nil)))
1943 (when tlambdas
1944 (setq lambdas (cons tlambdas lambdas)
1945 keys (cons method-primary keys)
1946 primarymethodlist
1947 (eieiomt-method-list method method-primary mclass)))
1948
1949 ;; :before methods
1950 (setq tlambdas
1951 (if mclass
1952 (eieiomt-method-list method method-before mclass)
1953 (list (eieio-generic-form method method-before nil)))
1954 ;;(or (and mclass (eieio-generic-form method method-before mclass))
1955 ;; (eieio-generic-form method method-before nil))
1956 )
1957 (setq lambdas (append tlambdas lambdas)
1958 keys (append (make-list (length tlambdas) method-before) keys))
1959 )
1960
1961 ;; If there were no methods found, then there could be :static methods.
1962 (when (not lambdas)
1963 (setq tlambdas
1964 (eieio-generic-form method method-static mclass))
1965 (setq lambdas (cons tlambdas lambdas)
1966 keys (cons method-static keys)
1967 primarymethodlist ;; Re-use even with bad name here
1968 (eieiomt-method-list method method-static mclass)))
1969
1970 (run-hook-with-args 'eieio-pre-method-execution-hooks
1971 primarymethodlist)
1972
1973 ;; Now loop through all occurances forms which we must execute
1974 ;; (which are happily sorted now) and execute them all!
1975 (let ((rval nil) (lastval nil) (rvalever nil) (found nil))
1976 (while lambdas
1977 (if (car lambdas)
1978 (let* ((scoped-class (cdr (car lambdas)))
1979 (eieio-generic-call-key (car keys))
1980 (has-return-val
1981 (or (= eieio-generic-call-key method-primary)
1982 (= eieio-generic-call-key method-static)))
1983 (eieio-generic-call-next-method-list
1984 ;; Use the cdr, as the first element is the fcn
1985 ;; we are calling right now.
1986 (when has-return-val (cdr primarymethodlist)))
1987 )
1988 (setq found t)
1989 ;;(setq rval (apply (car (car lambdas)) newargs))
1990 (setq lastval (apply (car (car lambdas)) newargs))
1991 (when has-return-val
1992 (setq rval lastval
1993 rvalever t))
1994 ))
1995 (setq lambdas (cdr lambdas)
1996 keys (cdr keys)))
1997 (if (not found)
1998 (if (eieio-object-p (car args))
1999 (setq rval (apply 'no-applicable-method (car args) method args)
2000 rvalever t)
2001 (signal
2002 'no-method-definition
2003 (list method args))))
2004 ;; Right Here... it could be that lastval is returned when
2005 ;; rvalever is nil. Is that right?
2006 rval)))
2007
2008(defun eieio-generic-call-primary-only (method args)
2009 "Call METHOD with ARGS for methods with only :PRIMARY implementations.
2010ARGS provides the context on which implementation to use.
2011This should only be called from a generic function.
2012
2013This method is like `eieio-generic-call', but only
2014implementations in the :PRIMARY slot are queried. After many
2015years of use, it appears that over 90% of methods in use
2016have :PRIMARY implementations only. We can therefore optimize
2017for this common case to improve performance."
2018 ;; We must expand our arguments first as they are always
2019 ;; passed in as quoted symbols
2020 (let ((newargs nil) (mclass nil) (lambdas nil)
2021 (eieio-generic-call-methodname method)
2022 (eieio-generic-call-arglst args)
2023 (firstarg nil)
2024 (primarymethodlist nil)
2025 )
2026 ;; get a copy
2027 (setq newargs args
2028 firstarg (car newargs))
2029
2030 ;; Determine the class to use.
2031 (cond ((eieio-object-p firstarg)
2032 (setq mclass (object-class-fast firstarg)))
2033 ((not firstarg)
2034 (error "Method %s called on nil" method))
2035 ((not (eieio-object-p firstarg))
2036 (error "Primary-only method %s called on something not an object" method))
2037 (t
2038 (error "EIEIO Error: Improperly classified method %s as primary only"
2039 method)
2040 ))
2041 ;; Make sure the class is a valid class
2042 ;; mclass can be nil (meaning a generic for should be used.
2043 ;; mclass cannot have a value that is not a class, however.
2044 (when (null mclass)
2045 (error "Cannot dispatch method %S on class %S" method mclass)
2046 )
2047
2048 ;; :primary methods
2049 (setq lambdas (eieio-generic-form method method-primary mclass))
2050 (setq primarymethodlist ;; Re-use even with bad name here
2051 (eieiomt-method-list method method-primary mclass))
2052
2053 ;; Now loop through all occurances forms which we must execute
2054 ;; (which are happily sorted now) and execute them all!
2055 (let* ((rval nil) (lastval nil) (rvalever nil)
2056 (scoped-class (cdr lambdas))
2057 (eieio-generic-call-key method-primary)
2058 ;; Use the cdr, as the first element is the fcn
2059 ;; we are calling right now.
2060 (eieio-generic-call-next-method-list (cdr primarymethodlist))
2061 )
2062
2063 (if (or (not lambdas) (not (car lambdas)))
2064
2065 ;; No methods found for this impl...
2066 (if (eieio-object-p (car args))
2067 (setq rval (apply 'no-applicable-method (car args) method args)
2068 rvalever t)
2069 (signal
2070 'no-method-definition
2071 (list method args)))
2072
2073 ;; Do the regular implementation here.
2074
2075 (run-hook-with-args 'eieio-pre-method-execution-hooks
2076 lambdas)
2077
2078 (setq lastval (apply (car lambdas) newargs))
2079 (setq rval lastval
2080 rvalever t)
2081 )
2082
2083 ;; Right Here... it could be that lastval is returned when
2084 ;; rvalever is nil. Is that right?
2085 rval)))
2086
2087(defun eieiomt-method-list (method key class)
2088 "Return an alist list of methods lambdas.
2089METHOD is the method name.
2090KEY represents either :before, or :after methods.
2091CLASS is the starting class to search from in the method tree.
2092If CLASS is nil, then an empty list of methods should be returned."
2093 ;; Note: eieiomt - the MT means MethodTree. See more comments below
2094 ;; for the rest of the eieiomt methods.
2095 (let ((lambdas nil)
2096 (mclass (list class)))
2097 (while mclass
2098 ;; Note: a nil can show up in the class list once we start
2099 ;; searching through the method tree.
2100 (when (car mclass)
2101 ;; lookup the form to use for the PRIMARY object for the next level
2102 (let ((tmpl (eieio-generic-form method key (car mclass))))
2103 (when (or (not lambdas)
2104 ;; This prevents duplicates coming out of the
2105 ;; class method optimizer. Perhaps we should
2106 ;; just not optimize before/afters?
2107 (not (eq (car tmpl) (car (car lambdas)))))
2108 (setq lambdas (cons tmpl lambdas))
2109 (if (null (car lambdas))
2110 (setq lambdas (cdr lambdas))))))
2111 ;; Add new classes to mclass. Since our input might not be a class
2112 ;; protect against that.
2113 (if (car mclass)
2114 ;; If there is a class, append any methods it may provide
2115 ;; to the remainder of the class list.
2116 (let ((io (class-method-invocation-order (car mclass))))
2117 (if (eq io :depth-first)
2118 ;; Depth first.
2119 (setq mclass (append (eieiomt-next (car mclass)) (cdr mclass)))
2120 ;; Breadth first.
2121 (setq mclass (append (cdr mclass) (eieiomt-next (car mclass)))))
2122 )
2123 ;; Advance to next entry in mclass if it is nil.
2124 (setq mclass (cdr mclass)))
2125 )
2126 (if (eq key method-after)
2127 lambdas
2128 (nreverse lambdas))))
2129
2130(defun next-method-p ()
2131 "Non-nil if there is a next method.
2132Returns a list of lambda expressions which is the `next-method'
2133order."
2134 eieio-generic-call-next-method-list)
2135
2136(defun call-next-method (&rest replacement-args)
2137 "Call the superclass method from a subclass method.
2138The superclass method is specified in the current method list,
2139and is called the next method.
2140
2141If REPLACEMENT-ARGS is non-nil, then use them instead of
2142`eieio-generic-call-arglst'. The generic arg list are the
2143arguments passed in at the top level.
2144
2145Use `next-method-p' to find out if there is a next method to call."
2146 (if (not scoped-class)
2147 (error "Call-next-method not called within a class specific method"))
2148 (if (and (/= eieio-generic-call-key method-primary)
2149 (/= eieio-generic-call-key method-static))
2150 (error "Cannot `call-next-method' except in :primary or :static methods")
2151 )
2152 (let ((newargs (or replacement-args eieio-generic-call-arglst))
2153 (next (car eieio-generic-call-next-method-list))
2154 )
2155 (if (or (not next) (not (car next)))
2156 (apply 'no-next-method (car newargs) (cdr newargs))
2157 (let* ((eieio-generic-call-next-method-list
2158 (cdr eieio-generic-call-next-method-list))
2159 (scoped-class (cdr next))
2160 (fcn (car next))
2161 )
2162 (apply fcn newargs)
2163 ))))
2164
2165;;;
2166;; eieio-method-tree : eieiomt-
2167;;
2168;; Stored as eieio-method-tree in property list of a generic method
2169;;
2170;; (eieio-method-tree . [BEFORE PRIMARY AFTER
2171;; genericBEFORE genericPRIMARY genericAFTER])
2172;; and
2173;; (eieio-method-obarray . [BEFORE PRIMARY AFTER
2174;; genericBEFORE genericPRIMARY genericAFTER])
2175;; where the association is a vector.
2176;; (aref 0 -- all static methods.
2177;; (aref 1 -- all methods classified as :before
2178;; (aref 2 -- all methods classified as :primary
2179;; (aref 3 -- all methods classified as :after
2180;; (aref 4 -- a generic classified as :before
2181;; (aref 5 -- a generic classified as :primary
2182;; (aref 6 -- a generic classified as :after
2183;;
2184(defvar eieiomt-optimizing-obarray nil
2185 "While mapping atoms, this contain the obarray being optimized.")
2186
2187(defun eieiomt-install (method-name)
2188 "Install the method tree, and obarray onto METHOD-NAME.
2189Do not do the work if they already exist."
2190 (let ((emtv (get method-name 'eieio-method-tree))
2191 (emto (get method-name 'eieio-method-obarray)))
2192 (if (or (not emtv) (not emto))
2193 (progn
2194 (setq emtv (put method-name 'eieio-method-tree
2195 (make-vector method-num-slots nil))
2196 emto (put method-name 'eieio-method-obarray
2197 (make-vector method-num-slots nil)))
2198 (aset emto 0 (make-vector 11 0))
2199 (aset emto 1 (make-vector 11 0))
2200 (aset emto 2 (make-vector 41 0))
2201 (aset emto 3 (make-vector 11 0))
2202 ))))
2203
2204(defun eieiomt-add (method-name method key class)
2205 "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS.
2206METHOD-NAME is the name created by a call to `defgeneric'.
2207METHOD are the forms for a given implementation.
2208KEY is an integer (see comment in eieio.el near this function) which
2209is associated with the :static :before :primary and :after tags.
2210It also indicates if CLASS is defined or not.
2211CLASS is the class this method is associated with."
2212 (if (or (> key method-num-slots) (< key 0))
2213 (error "Eieiomt-add: method key error!"))
2214 (let ((emtv (get method-name 'eieio-method-tree))
2215 (emto (get method-name 'eieio-method-obarray)))
2216 ;; Make sure the method tables are available.
2217 (if (or (not emtv) (not emto))
2218 (error "Programmer error: eieiomt-add"))
2219 ;; only add new cells on if it doesn't already exist!
2220 (if (assq class (aref emtv key))
2221 (setcdr (assq class (aref emtv key)) method)
2222 (aset emtv key (cons (cons class method) (aref emtv key))))
2223 ;; Add function definition into newly created symbol, and store
2224 ;; said symbol in the correct obarray, otherwise use the
2225 ;; other array to keep this stuff
2226 (if (< key method-num-lists)
2227 (let ((nsym (intern (symbol-name class) (aref emto key))))
2228 (fset nsym method)))
2229 ;; Now optimize the entire obarray
2230 (if (< key method-num-lists)
2231 (let ((eieiomt-optimizing-obarray (aref emto key)))
2232 ;; @todo - Is this overkill? Should we just clear the symbol?
2233 (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray)))
2234 ))
2235
2236(defun eieiomt-next (class)
2237 "Return the next parent class for CLASS.
2238If CLASS is a superclass, return variable `eieio-default-superclass'. If CLASS
2239is variable `eieio-default-superclass' then return nil. This is different from
2240function `class-parent' as class parent returns nil for superclasses. This
2241function performs no type checking!"
2242 ;; No type-checking because all calls are made from functions which
2243 ;; are safe and do checking for us.
2244 (or (class-parents-fast class)
2245 (if (eq class 'eieio-default-superclass)
2246 nil
2247 '(eieio-default-superclass))))
2248
2249(defun eieiomt-sym-optimize (s)
2250 "Find the next class above S which has a function body for the optimizer."
2251 ;; (message "Optimizing %S" s)
2252 (let* ((es (intern-soft (symbol-name s))) ;external symbol of class
2253 (io (class-method-invocation-order es))
2254 (ov nil)
2255 (cont t))
2256 ;; This converts ES from a single symbol to a list of parent classes.
2257 (setq es (eieiomt-next es))
2258 ;; Loop over ES, then it's children individually.
2259 ;; We can have multiple hits only at one level of the parent tree.
2260 (while (and es cont)
2261 (setq ov (intern-soft (symbol-name (car es)) eieiomt-optimizing-obarray))
2262 (if (fboundp ov)
2263 (progn
2264 (set s ov) ;store ov as our next symbol
2265 (setq cont nil))
2266 (if (eq io :depth-first)
2267 ;; Pre-pend the subclasses of (car es) so we get
2268 ;; DEPTH FIRST optimization.
2269 (setq es (append (eieiomt-next (car es)) (cdr es)))
2270 ;; Else, we are breadth first.
2271 ;; (message "Class %s is breadth first" es)
2272 (setq es (append (cdr es) (eieiomt-next (car es))))
2273 )))
2274 ;; If there is no nearest call, then set our value to nil
2275 (if (not es) (set s nil))
2276 ))
2277
2278(defun eieio-generic-form (method key class)
2279 "Return the lambda form belonging to METHOD using KEY based upon CLASS.
2280If CLASS is not a class then use `generic' instead. If class has no
2281form, but has a parent class, then trace to that parent class. The
2282first time a form is requested from a symbol, an optimized path is
2283memoized for future faster use."
2284 (let ((emto (aref (get method 'eieio-method-obarray)
2285 (if class key (+ key 3)))))
2286 (if (class-p class)
2287 ;; 1) find our symbol
2288 (let ((cs (intern-soft (symbol-name class) emto)))
2289 (if (not cs)
2290 ;; 2) If there isn't one, then make one.
2291 ;; This can be slow since it only occurs once
2292 (progn
2293 (setq cs (intern (symbol-name class) emto))
2294 ;; 2.1) Cache it's nearest neighbor with a quick optimize
2295 ;; which should only occur once for this call ever
2296 (let ((eieiomt-optimizing-obarray emto))
2297 (eieiomt-sym-optimize cs))))
2298 ;; 3) If it's bound return this one.
2299 (if (fboundp cs)
2300 (cons cs (aref (class-v class) class-symbol))
2301 ;; 4) If it's not bound then this variable knows something
2302 (if (symbol-value cs)
2303 (progn
2304 ;; 4.1) This symbol holds the next class in it's value
2305 (setq class (symbol-value cs)
2306 cs (intern-soft (symbol-name class) emto))
2307 ;; 4.2) The optimizer should always have chosen a
2308 ;; function-symbol
2309 ;;(if (fboundp cs)
2310 (cons cs (aref (class-v (intern (symbol-name class)))
2311 class-symbol))
2312 ;;(error "EIEIO optimizer: erratic data loss!"))
2313 )
2314 ;; There never will be a funcall...
2315 nil)))
2316 ;; for a generic call, what is a list, is the function body we want.
2317 (let ((emtl (aref (get method 'eieio-method-tree)
2318 (if class key (+ key 3)))))
2319 (if emtl
2320 ;; The car of EMTL is supposed to be a class, which in this
2321 ;; case is nil, so skip it.
2322 (cons (cdr (car emtl)) nil)
2323 nil)))))
2324
2325;;;
2326;; Way to assign slots based on a list. Used for constructors, or
2327;; even resetting an object at run-time
2328;;
2329(defun eieio-set-defaults (obj &optional set-all)
2330 "Take object OBJ, and reset all slots to their defaults.
2331If SET-ALL is non-nil, then when a default is nil, that value is
2332reset. If SET-ALL is nil, the slots are only reset if the default is
2333not nil."
2334 (let ((scoped-class (aref obj object-class))
2335 (eieio-initializing-object t)
2336 (pub (aref (class-v (aref obj object-class)) class-public-a)))
2337 (while pub
2338 (let ((df (eieio-oref-default obj (car pub))))
2339 (if (or df set-all)
2340 (eieio-oset obj (car pub) df)))
2341 (setq pub (cdr pub)))))
2342
2343(defun eieio-initarg-to-attribute (class initarg)
2344 "For CLASS, convert INITARG to the actual attribute name.
2345If there is no translation, pass it in directly (so we can cheat if
2346need be.. May remove that later...)"
2347 (let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples))))
2348 (if tuple
2349 (cdr tuple)
2350 nil)))
2351
2352(defun eieio-attribute-to-initarg (class attribute)
2353 "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
2354This is usually a symbol that starts with `:'."
2355 (let ((tuple (rassoc attribute (aref (class-v class) class-initarg-tuples))))
2356 (if tuple
2357 (car tuple)
2358 nil)))
2359
2360
2361;;; Here are some special types of errors
2362;;
2363(intern "no-method-definition")
2364(put 'no-method-definition 'error-conditions '(no-method-definition error))
2365(put 'no-method-definition 'error-message "No method definition")
2366
2367(intern "no-next-method")
2368(put 'no-next-method 'error-conditions '(no-next-method error))
2369(put 'no-next-method 'error-message "No next method")
2370
2371(intern "invalid-slot-name")
2372(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error))
2373(put 'invalid-slot-name 'error-message "Invalid slot name")
2374
2375(intern "invalid-slot-type")
2376(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil))
2377(put 'invalid-slot-type 'error-message "Invalid slot type")
2378
2379(intern "unbound-slot")
2380(put 'unbound-slot 'error-conditions '(unbound-slot error nil))
2381(put 'unbound-slot 'error-message "Unbound slot")
2382
2383;;; Here are some CLOS items that need the CL package
2384;;
2385
2386(defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store))
2387(defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store))
2388
2389;; The below setf method was written by Arnd Kohrs <kohrs@acm.org>
2390(define-setf-method oref (obj slot)
2391 (let ((obj-temp (gensym))
2392 (slot-temp (gensym))
2393 (store-temp (gensym)))
2394 (list (list obj-temp slot-temp)
2395 (list obj `(quote ,slot))
2396 (list store-temp)
2397 (list 'set-slot-value obj-temp slot-temp
2398 store-temp)
2399 (list 'slot-value obj-temp slot-temp))))
2400
2401
2402;;;
2403;; We want all objects created by EIEIO to have some default set of
2404;; behaviours so we can create object utilities, and allow various
2405;; types of error checking. To do this, create the default EIEIO
2406;; class, and when no parent class is specified, use this as the
2407;; default. (But don't store it in the other classes as the default,
2408;; allowing for transparent support.)
2409;;
2410
2411(defclass eieio-default-superclass nil
2412 nil
2413 "Default parent class for classes with no specified parent class.
2414Its slots are automatically adopted by classes with no specified
2415parents. This class is not stored in the `parent' slot of a class vector."
2416 :abstract t)
2417
2418(defalias 'standard-class 'eieio-default-superclass)
2419
2420(defgeneric constructor (class newname &rest slots)
2421 "Default constructor for CLASS `eieio-defualt-superclass'.")
2422
2423(defmethod constructor :static
2424 ((class eieio-default-superclass) newname &rest slots)
2425 "Default constructor for CLASS `eieio-defualt-superclass'.
2426NEWNAME is the name to be given to the constructed object.
2427SLOTS are the initialization slots used by `shared-initialize'.
2428This static method is called when an object is constructed.
2429It allocates the vector used to represent an EIEIO object, and then
2430calls `shared-initialize' on that object."
2431 (let* ((new-object (copy-sequence (aref (class-v class)
2432 class-default-object-cache))))
2433 ;; Update the name for the newly created object.
2434 (aset new-object object-name newname)
2435 ;; Call the initialize method on the new object with the slots
2436 ;; that were passed down to us.
2437 (initialize-instance new-object slots)
2438 ;; Return the created object.
2439 new-object))
2440
2441(defgeneric shared-initialize (obj slots)
2442 "Set slots of OBJ with SLOTS which is a list of name/value pairs.
2443Called from the constructor routine.")
2444
2445(defmethod shared-initialize ((obj eieio-default-superclass) slots)
2446 "Set slots of OBJ with SLOTS which is a list of name/value pairs.
2447Called from the constructor routine."
2448 (let ((scoped-class (aref obj object-class)))
2449 (while slots
2450 (let ((rn (eieio-initarg-to-attribute (object-class-fast obj)
2451 (car slots))))
2452 (if (not rn)
2453 (slot-missing obj (car slots) 'oset (car (cdr slots)))
2454 (eieio-oset obj rn (car (cdr slots)))))
2455 (setq slots (cdr (cdr slots))))))
2456
2457(defgeneric initialize-instance (this &optional slots)
2458 "Constructs the new object THIS based on SLOTS.")
2459
2460(defmethod initialize-instance ((this eieio-default-superclass)
2461 &optional slots)
2462 "Constructs the new object THIS based on SLOTS.
2463SLOTS is a tagged list where odd numbered elements are tags, and
2464even numbered elements are the values to store in the tagged slot. If
2465you overload the `initialize-instance', there you will need to call
2466`shared-initialize' yourself, or you can call `call-next-method' to
2467have this constructor called automatically. If these steps are not
2468taken, then new objects of your class will not have their values
2469dynamically set from SLOTS."
2470 ;; First, see if any of our defaults are `lambda', and
2471 ;; re-evaluate them and apply the value to our slots.
2472 (let* ((scoped-class (class-v (aref this object-class)))
2473 (slot (aref scoped-class class-public-a))
2474 (defaults (aref scoped-class class-public-d)))
2475 (while slot
2476 (setq slot (cdr slot)
2477 defaults (cdr defaults))))
2478 ;; Shared initialize will parse our slots for us.
2479 (shared-initialize this slots))
2480
2481(defgeneric slot-missing (object slot-name operation &optional new-value)
2482 "Method invoked when an attempt to access a slot in OBJECT fails.")
2483
2484(defmethod slot-missing ((object eieio-default-superclass) slot-name
2485 operation &optional new-value)
2486 "Method invoked when an attempt to access a slot in OBJECT fails.
2487SLOT-NAME is the name of the failed slot, OPERATION is the type of access
2488that was requested, and optional NEW-VALUE is the value that was desired
2489to be set.
2490
2491This method is called from `oref', `oset', and other functions which
2492directly reference slots in EIEIO objects."
2493 (signal 'invalid-slot-name (list (object-name object)
2494 slot-name)))
2495
2496(defgeneric slot-unbound (object class slot-name fn)
2497 "Slot unbound is invoked during an attempt to reference an unbound slot.")
2498
2499(defmethod slot-unbound ((object eieio-default-superclass)
2500 class slot-name fn)
2501 "Slot unbound is invoked during an attempt to reference an unbound slot.
2502OBJECT is the instance of the object being reference. CLASS is the
2503class of OBJECT, and SLOT-NAME is the offending slot. This function
2504throws the signal `unbound-slot'. You can overload this function and
2505return the value to use in place of the unbound value.
2506Argument FN is the function signaling this error.
2507Use `slot-boundp' to determine if a slot is bound or not.
2508
2509In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but
2510EIEIO can only dispatch on the first argument, so the first two are swapped."
2511 (signal 'unbound-slot (list (class-name class) (object-name object)
2512 slot-name fn)))
2513
2514(defgeneric no-applicable-method (object method &rest args)
2515 "Called if there are no implementations for OBJECT in METHOD.")
2516
2517(defmethod no-applicable-method ((object eieio-default-superclass)
2518 method &rest args)
2519 "Called if there are no implementations for OBJECT in METHOD.
2520OBJECT is the object which has no method implementation.
2521ARGS are the arguments that were passed to METHOD.
2522
2523Implement this for a class to block this signal. The return
2524value becomes the return value of the original method call."
2525 (signal 'no-method-definition (list method (object-name object)))
2526 )
2527
2528(defgeneric no-next-method (object &rest args)
2529"Called from `call-next-method' when no additional methods are available.")
2530
2531(defmethod no-next-method ((object eieio-default-superclass)
2532 &rest args)
2533 "Called from `call-next-method' when no additional methods are available.
2534OBJECT is othe object being called on `call-next-method'.
2535ARGS are the arguments it is called by.
2536This method signals `no-next-method' by default. Override this
2537method to not throw an error, and it's return value becomes the
2538return value of `call-next-method'."
2539 (signal 'no-next-method (list (object-name object) args))
2540)
2541
2542(defgeneric clone (obj &rest params)
2543 "Make a copy of OBJ, and then supply PARAMS.
2544PARAMS is a parameter list of the same form used by `initialize-instance'.
2545
2546When overloading `clone', be sure to call `call-next-method'
2547first and modify the returned object.")
2548
2549(defmethod clone ((obj eieio-default-superclass) &rest params)
2550 "Make a copy of OBJ, and then apply PARAMS."
2551 (let ((nobj (copy-sequence obj))
2552 (nm (aref obj object-name))
2553 (passname (and params (stringp (car params))))
2554 (num 1))
2555 (if params (shared-initialize nobj (if passname (cdr params) params)))
2556 (if (not passname)
2557 (save-match-data
2558 (if (string-match "-\\([0-9]+\\)" nm)
2559 (setq num (1+ (string-to-number (match-string 1 nm)))
2560 nm (substring nm 0 (match-beginning 0))))
2561 (aset nobj object-name (concat nm "-" (int-to-string num))))
2562 (aset nobj object-name (car params)))
2563 nobj))
2564
2565(defgeneric destructor (this &rest params)
2566 "Destructor for cleaning up any dynamic links to our object.")
2567
2568(defmethod destructor ((this eieio-default-superclass) &rest params)
2569 "Destructor for cleaning up any dynamic links to our object.
2570Argument THIS is the object being destroyed. PARAMS are additional
2571ignored parameters."
2572 ;; No cleanup... yet.
2573 )
2574
2575(defgeneric object-print (this &rest strings)
2576 "Pretty printer for object THIS. Call function `object-name' with STRINGS.
2577
2578It is sometimes useful to put a summary of the object into the
2579default #<notation> string when using eieio browsing tools.
2580Implement this method to customize the summary.")
2581
2582(defmethod object-print ((this eieio-default-superclass) &rest strings)
2583 "Pretty printer for object THIS. Call function `object-name' with STRINGS.
2584The default method for printing object THIS is to use the
2585function `object-name'.
2586
2587It is sometimes useful to put a summary of the object into the
2588default #<notation> string when using eieio browsing tools.
2589
2590Implement this function and specify STRINGS in a call to
2591`call-next-method' to provide additional summary information.
2592When passing in extra strings from child classes, always remember
2593to prepend a space."
2594 (object-name this (apply 'concat strings)))
2595
2596(defvar eieio-print-depth 0
2597 "When printing, keep track of the current indentation depth.")
2598
2599(defgeneric object-write (this &optional comment)
2600 "Write out object THIS to the current stream.
2601Optional COMMENDS will add comments to the beginning of the output.")
2602
2603(defmethod object-write ((this eieio-default-superclass) &optional comment)
2604 "Write object THIS out to the current stream.
2605This writes out the vector version of this object. Complex and recursive
2606object are discouraged from being written.
2607 If optional COMMENT is non-nil, include comments when outputting
2608this object."
2609 (when comment
2610 (princ ";; Object ")
2611 (princ (object-name-string this))
2612 (princ "\n")
2613 (princ comment)
2614 (princ "\n"))
2615 (let* ((cl (object-class this))
2616 (cv (class-v cl)))
2617 ;; Now output readable lisp to recreate this object
2618 ;; It should look like this:
2619 ;; (<constructor> <name> <slot> <slot> ... )
2620 ;; Each slot's slot is writen using its :writer.
2621 (princ (make-string (* eieio-print-depth 2) ? ))
2622 (princ "(")
2623 (princ (symbol-name (class-constructor (object-class this))))
2624 (princ " \"")
2625 (princ (object-name-string this))
2626 (princ "\"\n")
2627 ;; Loop over all the public slots
2628 (let ((publa (aref cv class-public-a))
2629 (publd (aref cv class-public-d))
2630 (publp (aref cv class-public-printer))
2631 (eieio-print-depth (1+ eieio-print-depth)))
2632 (while publa
2633 (when (slot-boundp this (car publa))
2634 (let ((i (class-slot-initarg cl (car publa)))
2635 (v (eieio-oref this (car publa)))
2636 )
2637 (unless (or (not i) (equal v (car publd)))
2638 (princ (make-string (* eieio-print-depth 2) ? ))
2639 (princ (symbol-name i))
2640 (princ " ")
2641 (if (car publp)
2642 ;; Use our public printer
2643 (funcall (car publp) v)
2644 ;; Use our generic override prin1 function.
2645 (eieio-override-prin1 v))
2646 (princ "\n"))))
2647 (setq publa (cdr publa) publd (cdr publd)
2648 publp (cdr publp)))
2649 (princ (make-string (* eieio-print-depth 2) ? )))
2650 (princ ")\n")))
2651
2652(defun eieio-override-prin1 (thing)
2653 "Perform a prin1 on THING taking advantage of object knowledge."
2654 (cond ((eieio-object-p thing)
2655 (object-write thing))
2656 ((listp thing)
2657 (eieio-list-prin1 thing))
2658 ((class-p thing)
2659 (princ (class-name thing)))
2660 ((symbolp thing)
2661 (princ (concat "'" (symbol-name thing))))
2662 (t (prin1 thing))))
2663
2664(defun eieio-list-prin1 (list)
2665 "Display LIST where list may contain objects."
2666 (if (not (eieio-object-p (car list)))
2667 (progn
2668 (princ "'")
2669 (prin1 list))
2670 (princ "(list ")
2671 (if (eieio-object-p (car list)) (princ "\n "))
2672 (while list
2673 (if (eieio-object-p (car list))
2674 (object-write (car list))
2675 (princ "'")
2676 (prin1 (car list)))
2677 (princ " ")
2678 (setq list (cdr list)))
2679 (princ (make-string (* eieio-print-depth 2) ? ))
2680 (princ ")")))
2681
2682
2683;;; Unimplemented functions from CLOS
2684;;
2685(defun change-class (obj class)
2686 "Change the class of OBJ to type CLASS.
2687This may create or delete slots, but does not affect the return value
2688of `eq'."
2689 (error "Eieio: `change-class' is unimplemented"))
2690
2691)
2692
2693
2694;;; Interfacing with edebug
2695;;
2696(defun eieio-edebug-prin1-to-string (object &optional noescape)
2697 "Display eieio OBJECT in fancy format. Overrides the edebug default.
2698Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate."
2699 (cond ((class-p object) (class-name object))
2700 ((eieio-object-p object) (object-print object))
2701 ((and (listp object) (or (class-p (car object))
2702 (eieio-object-p (car object))))
2703 (concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")"))
2704 (t (prin1-to-string object noescape))))
2705
2706(add-hook 'edebug-setup-hook
2707 (lambda ()
2708 (def-edebug-spec defmethod
2709 (&define ; this means we are defining something
2710 [&or name ("setf" :name setf name)]
2711 ;; ^^ This is the methods symbol
2712 [ &optional symbolp ] ; this is key :before etc
2713 list ; arguments
2714 [ &optional stringp ] ; documentation string
2715 def-body ; part to be debugged
2716 ))
2717 ;; The rest of the macros
2718 (def-edebug-spec oref (form quote))
2719 (def-edebug-spec oref-default (form quote))
2720 (def-edebug-spec oset (form quote form))
2721 (def-edebug-spec oset-default (form quote form))
2722 (def-edebug-spec class-v form)
2723 (def-edebug-spec class-p form)
2724 (def-edebug-spec eieio-object-p form)
2725 (def-edebug-spec class-constructor form)
2726 (def-edebug-spec generic-p form)
2727 (def-edebug-spec with-slots (list list def-body))
2728 ;; I suspect this isn't the best way to do this, but when
2729 ;; cust-print was used on my system all my objects
2730 ;; appeared as "#1 =" which was not useful. This allows
2731 ;; edebug to print my objects in the nice way they were
2732 ;; meant to with `object-print' and `class-name'
2733 ;; (defalias 'edebug-prin1-to-string 'eieio-edebug-prin1-to-string)
2734 )
2735 )
2736
2737(eval-after-load "cedet-edebug"
2738 '(progn
2739 (cedet-edebug-add-print-override '(class-p object) '(class-name object) )
2740 (cedet-edebug-add-print-override '(eieio-object-p object) '(object-print object) )
2741 (cedet-edebug-add-print-override '(and (listp object)
2742 (or (class-p (car object)) (eieio-object-p (car object))))
2743 '(cedet-edebug-prin1-recurse object) )
2744 ))
2745
2746;;; Interfacing with imenu in emacs lisp mode
2747;; (Only if the expression is defined)
2748;;
2749(if (eval-when-compile (boundp 'list-imenu-generic-expression))
2750(progn
2751
2752(defun eieio-update-lisp-imenu-expression ()
2753 "Examine `lisp-imenu-generic-expression' and modify it to find `defmethod'."
2754 (let ((exp lisp-imenu-generic-expression))
2755 (while exp
2756 ;; it's of the form '( ( title expr indx ) ... )
2757 (let* ((subcar (cdr (car exp)))
2758 (substr (car subcar)))
2759 (if (and (not (string-match "|method\\\\" substr))
2760 (string-match "|advice\\\\" substr))
2761 (setcar subcar
2762 (replace-match "|advice\\|method\\" t t substr 0))))
2763 (setq exp (cdr exp)))))
2764
2765(eieio-update-lisp-imenu-expression)
2766
2767))
2768
2769;;; Autoloading some external symbols, and hooking into the help system
2770;;
2771
2772(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "For buffers thrown into help mode, augment for eieio.")
2773(autoload 'eieio-browse "eieio-opt" "Create an object browser window" t)
2774(autoload 'eieio-describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t)
2775(autoload 'eieio-describe-constructor "eieio-opt" "Describe the constructor function FCN." t)
2776(autoload 'describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t)
2777(autoload 'eieio-describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t)
2778(autoload 'describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t)
2779(autoload 'eieiodoc-class "eieio-doc" "Create texinfo documentation about a class hierarchy." t)
2780
2781(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.")
2782
2783;; make sure this shows up after the help mode hook.
2784(add-hook 'temp-buffer-show-hook 'eieio-help-mode-augmentation-maybee t)
2785;; (require 'advice)
2786;; (defadvice describe-variable (around eieio-describe activate)
2787;; "Display the full documentation of FUNCTION (a symbol).
2788;; Returns the documentation as a string, also."
2789;; (if (class-p (ad-get-arg 0))
2790;; (eieio-describe-class (ad-get-arg 0))
2791;; ad-do-it))
2792
2793;; (defadvice describe-function (around eieio-describe activate)
2794;; "Display the full documentation of VARIABLE (a symbol).
2795;; Returns the documentation as a string, also."
2796;; (if (generic-p (ad-get-arg 0))
2797;; (eieio-describe-generic (ad-get-arg 0))
2798;; (if (class-p (ad-get-arg 0))
2799;; (eieio-describe-constructor (ad-get-arg 0))
2800;; ad-do-it)))
2801
2802(provide 'eieio)
2803;;; eieio ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-27 06:26:36 +0000