Mercurial > emacs
annotate lisp/emacs-lisp/eieio-opt.el @ 109313:e856a274549b
Constify functions taking char *
* alloc.c (pending_malloc_warning, malloc_warning): Add const.
* callproc.c (relocate_fd, getenv_internal_1, getenv_internal)
(egetenv): Likewise.
* doprnt.c (doprnt): Likewise.
* editfns.c (set_time_zone_rule, format2): Likewise.
* emacs.c (decode_env_path): Likewise.
* eval.c (signal_error, error): Likewise.
* insdel.c (replace_range_2): Likewise.
* keyboard.c (cmd_error_internal): Likewise.
* lread.c (isfloat_string, make_symbol, dir_warning): Likewise.
* print.c (write_string, write_string_1, print_error_message):
Likewise.
* vm-limit.c (warn_function, memory_warnings): Likewise.
* xdisp.c (message1, message1_nolog, message_with_string)
(vmessage, message, message_nolog): Likewise.
* emacs.c: Remove duplicate declaration.
* keyboard.h: Likewise.
* lisp.h: Update prototypes.
author | Andreas Schwab <schwab@linux-m68k.org> |
---|---|
date | Sun, 11 Jul 2010 11:27:13 +0200 |
parents | 1d1d5d9bd884 |
children | 280c8ae2476d 376148b31b5e |
rev | line source |
---|---|
105237 | 1 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) |
2 | |
105327 | 3 ;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008, |
106815 | 4 ;; 2009, 2010 Free Software Foundation, Inc. |
105237 | 5 |
105327 | 6 ;; Author: Eric M. Ludlam <zappo@gnu.org> |
105237 | 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. | |
36 If optional ROOT-CLASS, then start with that, otherwise start with | |
37 variable `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) | |
105813
df4934f25eef
* textmodes/two-column.el (2C-split):
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
105474
diff
changeset
|
46 (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") |
105237 | 47 (erase-buffer) |
48 (goto-char 0) | |
49 (eieio-browse-tree root-class "" "") | |
50 )) | |
51 | |
52 (defun eieio-browse-tree (this-root prefix ch-prefix) | |
105474 | 53 "Recursively draw the children of the given class on the screen. |
105237 | 54 Argument THIS-ROOT is the local root of the tree. |
55 Argument PREFIX is the character prefix to use. | |
56 Argument CH-PREFIX is another character prefix to display." | |
57 (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root))) | |
58 (let ((myname (symbol-name this-root)) | |
59 (chl (aref (class-v this-root) class-children)) | |
60 (fprefix (concat ch-prefix " +--")) | |
61 (mprefix (concat ch-prefix " | ")) | |
62 (lprefix (concat ch-prefix " "))) | |
63 (insert prefix myname "\n") | |
64 (while (cdr chl) | |
65 (eieio-browse-tree (car chl) fprefix mprefix) | |
66 (setq chl (cdr chl))) | |
67 (if chl | |
68 (eieio-browse-tree (car chl) fprefix lprefix)) | |
69 )) | |
70 | |
71 ;;; CLASS COMPLETION / DOCUMENTATION | |
72 | |
73 (defalias 'describe-class 'eieio-describe-class) | |
74 | |
75 (defun eieio-describe-class (class &optional headerfcn) | |
76 "Describe a CLASS defined by a string or symbol. | |
105327 | 77 If CLASS is actually an object, then also display current values of that object. |
105237 | 78 Optional HEADERFCN should be called to insert a few bits of info first." |
79 (interactive (list (eieio-read-class "Class: "))) | |
80 (with-output-to-temp-buffer (help-buffer) ;"*Help*" | |
81 (help-setup-xref (list #'eieio-describe-class class headerfcn) | |
105372
bd2966850aac
Use `called-interactively-p' instead of `interactive-p'.
Juanma Barranquero <lekktu@gmail.com>
parents:
105327
diff
changeset
|
82 (called-interactively-p 'interactive)) |
105237 | 83 |
84 (when headerfcn (funcall headerfcn)) | |
85 | |
86 (if (class-option class :abstract) | |
87 (princ "Abstract ")) | |
88 (princ "Class ") | |
89 (prin1 class) | |
90 (terpri) | |
91 ;; Inheritence tree information | |
92 (let ((pl (class-parents class))) | |
93 (when pl | |
94 (princ " Inherits from ") | |
95 (while pl | |
96 (princ "`") (prin1 (car pl)) (princ "'") | |
97 (setq pl (cdr pl)) | |
98 (if pl (princ ", "))) | |
99 (terpri))) | |
100 (let ((ch (class-children class))) | |
101 (when ch | |
102 (princ " Children ") | |
103 (while ch | |
104 (princ "`") (prin1 (car ch)) (princ "'") | |
105 (setq ch (cdr ch)) | |
106 (if ch (princ ", "))) | |
107 (terpri))) | |
108 (terpri) | |
109 ;; System documentation | |
110 (let ((doc (documentation-property class 'variable-documentation))) | |
111 (when doc | |
112 (princ "Documentation:") | |
113 (terpri) | |
114 (princ doc) | |
115 (terpri) | |
116 (terpri))) | |
117 ;; Describe all the slots in this class | |
118 (eieio-describe-class-slots class) | |
119 ;; Describe all the methods specific to this class. | |
120 (let ((methods (eieio-all-generic-functions class)) | |
121 (doc nil)) | |
122 (if (not methods) nil | |
123 (princ "Specialized Methods:") | |
124 (terpri) | |
125 (terpri) | |
126 (while methods | |
127 (setq doc (eieio-method-documentation (car methods) class)) | |
128 (princ "`") | |
129 (prin1 (car methods)) | |
130 (princ "'") | |
131 (if (not doc) | |
132 (princ " Undocumented") | |
133 (if (car doc) | |
134 (progn | |
135 (princ " :STATIC ") | |
136 (prin1 (car (car doc))) | |
137 (terpri) | |
138 (princ (cdr (car doc))))) | |
139 (setq doc (cdr doc)) | |
140 (if (car doc) | |
141 (progn | |
142 (princ " :BEFORE ") | |
143 (prin1 (car (car doc))) | |
144 (terpri) | |
145 (princ (cdr (car doc))))) | |
146 (setq doc (cdr doc)) | |
147 (if (car doc) | |
148 (progn | |
149 (princ " :PRIMARY ") | |
150 (prin1 (car (car doc))) | |
151 (terpri) | |
152 (princ (cdr (car doc))))) | |
153 (setq doc (cdr doc)) | |
154 (if (car doc) | |
155 (progn | |
156 (princ " :AFTER ") | |
157 (prin1 (car (car doc))) | |
158 (terpri) | |
159 (princ (cdr (car doc))))) | |
160 (terpri) | |
161 (terpri)) | |
162 (setq methods (cdr methods)))))) | |
105813
df4934f25eef
* textmodes/two-column.el (2C-split):
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
105474
diff
changeset
|
163 (with-current-buffer (help-buffer) |
105237 | 164 (buffer-string))) |
165 | |
166 (defun eieio-describe-class-slots (class) | |
167 "Describe the slots in CLASS. | |
168 Outputs to the standard output." | |
169 (let* ((cv (class-v class)) | |
170 (docs (aref cv class-public-doc)) | |
171 (names (aref cv class-public-a)) | |
172 (deflt (aref cv class-public-d)) | |
173 (types (aref cv class-public-type)) | |
174 (publp (aref cv class-public-printer)) | |
175 (i 0) | |
176 (prot (aref cv class-protection)) | |
177 ) | |
178 (princ "Instance Allocated Slots:") | |
179 (terpri) | |
180 (terpri) | |
181 (while names | |
182 (if (car prot) (princ "Private ")) | |
183 (princ "Slot: ") | |
184 (prin1 (car names)) | |
185 (when (not (eq (aref types i) t)) | |
186 (princ " type = ") | |
187 (prin1 (aref types i))) | |
188 (unless (eq (car deflt) eieio-unbound) | |
189 (princ " default = ") | |
190 (prin1 (car deflt))) | |
191 (when (car publp) | |
192 (princ " printer = ") | |
193 (prin1 (car publp))) | |
194 (when (car docs) | |
195 (terpri) | |
196 (princ " ") | |
197 (princ (car docs)) | |
198 (terpri)) | |
199 (terpri) | |
200 (setq names (cdr names) | |
201 docs (cdr docs) | |
202 deflt (cdr deflt) | |
203 publp (cdr publp) | |
204 prot (cdr prot) | |
205 i (1+ i))) | |
206 (setq docs (aref cv class-class-allocation-doc) | |
207 names (aref cv class-class-allocation-a) | |
208 types (aref cv class-class-allocation-type) | |
209 i 0 | |
210 prot (aref cv class-class-allocation-protection)) | |
211 (when names | |
212 (terpri) | |
213 (princ "Class Allocated Slots:")) | |
214 (terpri) | |
215 (terpri) | |
216 (while names | |
217 (when (car prot) | |
218 (princ "Private ")) | |
219 (princ "Slot: ") | |
220 (prin1 (car names)) | |
221 (unless (eq (aref types i) t) | |
222 (princ " type = ") | |
223 (prin1 (aref types i))) | |
224 (condition-case nil | |
225 (let ((value (eieio-oref class (car names)))) | |
226 (princ " value = ") | |
227 (prin1 value)) | |
228 (error nil)) | |
229 (when (car docs) | |
230 (terpri) | |
231 (princ " ") | |
232 (princ (car docs)) | |
233 (terpri)) | |
234 (terpri) | |
235 (setq names (cdr names) | |
236 docs (cdr docs) | |
237 prot (cdr prot) | |
238 i (1+ i))))) | |
239 | |
240 (defun eieio-describe-constructor (fcn) | |
241 "Describe the constructor function FCN. | |
242 Uses `eieio-describe-class' to describe the class being constructed." | |
243 (interactive | |
244 ;; Use eieio-read-class since all constructors have the same name as | |
245 ;; the class they create. | |
246 (list (eieio-read-class "Class: "))) | |
247 (eieio-describe-class | |
248 fcn (lambda () | |
249 ;; Describe the constructor part. | |
250 (princ "Object Constructor Function: ") | |
251 (prin1 fcn) | |
252 (terpri) | |
253 (princ "Creates an object of class ") | |
254 (prin1 fcn) | |
255 (princ ".") | |
256 (terpri) | |
257 (terpri) | |
258 )) | |
259 ) | |
260 | |
261 (defun eieio-build-class-alist (&optional class instantiable-only buildlist) | |
262 "Return an alist of all currently active classes for completion purposes. | |
263 Optional argument CLASS is the class to start with. | |
264 If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
265 are not abstract, otherwise allow all classes. | |
266 Optional argument BUILDLIST is more list to attach and is used internally." | |
267 (let* ((cc (or class eieio-default-superclass)) | |
268 (sublst (aref (class-v cc) class-children))) | |
269 (if (or (not instantiable-only) (not (class-abstract-p cc))) | |
270 (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))) | |
271 (while sublst | |
272 (setq buildlist (eieio-build-class-alist | |
273 (car sublst) instantiable-only buildlist)) | |
274 (setq sublst (cdr sublst))) | |
275 buildlist)) | |
276 | |
277 (defvar eieio-read-class nil | |
278 "History of the function `eieio-read-class' prompt.") | |
279 | |
280 (defun eieio-read-class (prompt &optional histvar instantiable-only) | |
281 "Return a class chosen by the user using PROMPT. | |
282 Optional argument HISTVAR is a variable to use as history. | |
283 If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
284 are not abstract." | |
285 (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only) | |
286 nil t nil | |
287 (or histvar 'eieio-read-class)))) | |
288 | |
289 (defun eieio-read-subclass (prompt class &optional histvar instantiable-only) | |
290 "Return a class chosen by the user using PROMPT. | |
291 CLASS is the base class, and completion occurs across all subclasses. | |
292 Optional argument HISTVAR is a variable to use as history. | |
293 If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
294 are not abstract." | |
295 (intern (completing-read prompt | |
296 (eieio-build-class-alist class instantiable-only) | |
297 nil t nil | |
298 (or histvar 'eieio-read-class)))) | |
299 | |
300 ;;; METHOD COMPLETION / DOC | |
301 | |
302 (defalias 'describe-method 'eieio-describe-generic) | |
303 (defalias 'describe-generic 'eieio-describe-generic) | |
304 (defalias 'eieio-describe-method 'eieio-describe-generic) | |
305 | |
306 (defun eieio-describe-generic (generic) | |
307 "Describe the generic function GENERIC. | |
308 Also extracts information about all methods specific to this generic." | |
309 (interactive (list (eieio-read-generic "Generic Method: "))) | |
310 (if (not (generic-p generic)) | |
311 (signal 'wrong-type-argument '(generic-p generic))) | |
312 (with-output-to-temp-buffer (help-buffer) ; "*Help*" | |
105372
bd2966850aac
Use `called-interactively-p' instead of `interactive-p'.
Juanma Barranquero <lekktu@gmail.com>
parents:
105327
diff
changeset
|
313 (help-setup-xref (list #'eieio-describe-generic generic) |
bd2966850aac
Use `called-interactively-p' instead of `interactive-p'.
Juanma Barranquero <lekktu@gmail.com>
parents:
105327
diff
changeset
|
314 (called-interactively-p 'interactive)) |
105237 | 315 |
316 (prin1 generic) | |
317 (princ " is a generic function") | |
318 (when (generic-primary-only-p generic) | |
319 (princ " with only ") | |
320 (when (generic-primary-only-one-p generic) | |
321 (princ "one ")) | |
322 (princ "primary method") | |
323 (when (not (generic-primary-only-one-p generic)) | |
324 (princ "s")) | |
325 ) | |
326 (princ ".") | |
327 (terpri) | |
328 (terpri) | |
329 (let ((d (documentation generic))) | |
330 (if (not d) | |
331 (princ "The generic is not documented.\n") | |
332 (princ "Documentation:") | |
333 (terpri) | |
334 (princ d) | |
335 (terpri) | |
336 (terpri))) | |
337 (princ "Implementations:") | |
338 (terpri) | |
339 (terpri) | |
340 (let ((i 3) | |
341 (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) | |
342 ;; Loop over fanciful generics | |
343 (while (< i 6) | |
344 (let ((gm (aref (get generic 'eieio-method-tree) i))) | |
345 (when gm | |
346 (princ "Generic ") | |
347 (princ (aref prefix (- i 3))) | |
348 (terpri) | |
349 (princ (or (nth 2 gm) "Undocumented")) | |
350 (terpri) | |
351 (terpri))) | |
352 (setq i (1+ i))) | |
353 (setq i 0) | |
354 ;; Loop over defined class-specific methods | |
355 (while (< i 3) | |
356 (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))) | |
357 (while gm | |
358 (princ "`") | |
359 (prin1 (car (car gm))) | |
360 (princ "'") | |
361 ;; prefix type | |
362 (princ " ") | |
363 (princ (aref prefix i)) | |
364 (princ " ") | |
365 ;; argument list | |
366 (let* ((func (cdr (car gm))) | |
367 (arglst (eieio-lambda-arglist func))) | |
368 (prin1 arglst)) | |
369 (terpri) | |
370 ;; 3 because of cdr | |
371 (princ (or (documentation (cdr (car gm))) | |
372 "Undocumented")) | |
373 (setq gm (cdr gm)) | |
374 (terpri) | |
375 (terpri))) | |
376 (setq i (1+ i))))) | |
105813
df4934f25eef
* textmodes/two-column.el (2C-split):
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
105474
diff
changeset
|
377 (with-current-buffer (help-buffer) |
105237 | 378 (buffer-string))) |
379 | |
380 (defun eieio-lambda-arglist (func) | |
381 "Return the argument list of FUNC, a function body." | |
382 (if (symbolp func) (setq func (symbol-function func))) | |
383 (if (byte-code-function-p func) | |
384 (eieio-compiled-function-arglist func) | |
385 (car (cdr func)))) | |
386 | |
387 (defun eieio-all-generic-functions (&optional class) | |
388 "Return a list of all generic functions. | |
105474 | 389 Optional CLASS argument returns only those functions that contain |
390 methods for CLASS." | |
105237 | 391 (let ((l nil) tree (cn (if class (symbol-name class) nil))) |
392 (mapatoms | |
393 (lambda (symbol) | |
394 (setq tree (get symbol 'eieio-method-obarray)) | |
395 (if tree | |
396 (progn | |
397 ;; A symbol might be interned for that class in one of | |
398 ;; these three slots in the method-obarray. | |
399 (if (or (not class) | |
400 (fboundp (intern-soft cn (aref tree 0))) | |
401 (fboundp (intern-soft cn (aref tree 1))) | |
402 (fboundp (intern-soft cn (aref tree 2)))) | |
403 (setq l (cons symbol l))))))) | |
404 l)) | |
405 | |
406 (defun eieio-method-documentation (generic class) | |
407 "Return a list of the specific documentation of GENERIC for CLASS. | |
408 If there is not an explicit method for CLASS in GENERIC, or if that | |
409 function has no documentation, then return nil." | |
410 (let ((tree (get generic 'eieio-method-obarray)) | |
411 (cn (symbol-name class)) | |
412 before primary after) | |
413 (if (not tree) | |
414 nil | |
415 ;; A symbol might be interned for that class in one of | |
416 ;; these three slots in the method-obarray. | |
417 (setq before (intern-soft cn (aref tree 0)) | |
418 primary (intern-soft cn (aref tree 1)) | |
419 after (intern-soft cn (aref tree 2))) | |
420 (if (not (or (fboundp before) | |
421 (fboundp primary) | |
422 (fboundp after))) | |
423 nil | |
424 (list (if (fboundp before) | |
425 (cons (eieio-lambda-arglist before) | |
426 (documentation before)) | |
427 nil) | |
428 (if (fboundp primary) | |
429 (cons (eieio-lambda-arglist primary) | |
430 (documentation primary)) | |
431 nil) | |
432 (if (fboundp after) | |
433 (cons (eieio-lambda-arglist after) | |
434 (documentation after)) | |
435 nil)))))) | |
436 | |
437 (defvar eieio-read-generic nil | |
438 "History of the `eieio-read-generic' prompt.") | |
439 | |
440 (defun eieio-read-generic-p (fn) | |
441 "Function used in function `eieio-read-generic'. | |
442 This is because `generic-p' is a macro. | |
443 Argument FN is the function to test." | |
444 (generic-p fn)) | |
445 | |
446 (defun eieio-read-generic (prompt &optional historyvar) | |
447 "Read a generic function from the minibuffer with PROMPT. | |
448 Optional argument HISTORYVAR is the variable to use as history." | |
449 (intern (completing-read prompt obarray 'eieio-read-generic-p | |
450 t nil (or historyvar 'eieio-read-generic)))) | |
451 | |
452 ;;; METHOD STATS | |
453 ;; | |
454 ;; Dump out statistics about all the active methods in a session. | |
455 (defun eieio-display-method-list () | |
456 "Display a list of all the methods and what features are used." | |
457 (interactive) | |
458 (let* ((meth1 (eieio-all-generic-functions)) | |
459 (meth (sort meth1 (lambda (a b) | |
460 (string< (symbol-name a) | |
461 (symbol-name b))))) | |
462 (buff (get-buffer-create "*EIEIO Method List*")) | |
463 (methidx 0) | |
464 (standard-output buff) | |
465 (slots '(method-static | |
466 method-before | |
467 method-primary | |
468 method-after | |
469 method-generic-before | |
470 method-generic-primary | |
471 method-generic-after)) | |
472 (slotn '("static" | |
473 "before" | |
474 "primary" | |
475 "after" | |
476 "G bef" | |
477 "G prim" | |
478 "G aft")) | |
479 (idxarray (make-vector (length slots) 0)) | |
480 (primaryonly 0) | |
481 (oneprimary 0) | |
482 ) | |
483 (switch-to-buffer-other-window buff) | |
484 (erase-buffer) | |
485 (dolist (S slotn) | |
486 (princ S) | |
487 (princ "\t") | |
488 ) | |
489 (princ "Method Name") | |
490 (terpri) | |
491 (princ "--------------------------------------------------------------------") | |
492 (terpri) | |
493 (dolist (M meth) | |
494 (let ((mtree (get M 'eieio-method-tree)) | |
495 (P nil) (numP) | |
496 (!P nil)) | |
497 (dolist (S slots) | |
498 (let ((num (length (aref mtree (symbol-value S))))) | |
499 (aset idxarray (symbol-value S) | |
500 (+ num (aref idxarray (symbol-value S)))) | |
501 (prin1 num) | |
502 (princ "\t") | |
503 (when (< 0 num) | |
504 (if (eq S 'method-primary) | |
505 (setq P t numP num) | |
506 (setq !P t))) | |
507 )) | |
508 ;; Is this a primary-only impl method? | |
509 (when (and P (not !P)) | |
510 (setq primaryonly (1+ primaryonly)) | |
511 (when (= numP 1) | |
512 (setq oneprimary (1+ oneprimary)) | |
513 (princ "*")) | |
514 (princ "* ") | |
515 ) | |
516 (prin1 M) | |
517 (terpri) | |
518 (setq methidx (1+ methidx)) | |
519 ) | |
520 ) | |
521 (princ "--------------------------------------------------------------------") | |
522 (terpri) | |
523 (dolist (S slots) | |
524 (prin1 (aref idxarray (symbol-value S))) | |
525 (princ "\t") | |
526 ) | |
527 (prin1 methidx) | |
528 (princ " Total symbols") | |
529 (terpri) | |
530 (dolist (S slotn) | |
531 (princ S) | |
532 (princ "\t") | |
533 ) | |
534 (terpri) | |
535 (terpri) | |
536 (princ "Methods Primary Only: ") | |
537 (prin1 primaryonly) | |
538 (princ "\t") | |
539 (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100))) | |
540 (princ "% of total methods") | |
541 (terpri) | |
542 (princ "Only One Primary Impl: ") | |
543 (prin1 oneprimary) | |
544 (princ "\t") | |
545 (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100))) | |
546 (princ "% of total primary methods") | |
547 (terpri) | |
548 )) | |
549 | |
550 ;;; HELP AUGMENTATION | |
551 ;; | |
552 (defun eieio-help-mode-augmentation-maybee (&rest unused) | |
105474 | 553 "For buffers thrown into help mode, augment for EIEIO. |
105237 | 554 Arguments UNUSED are not used." |
555 ;; Scan created buttons so far if we are in help mode. | |
556 (when (eq major-mode 'help-mode) | |
557 (save-excursion | |
558 (goto-char (point-min)) | |
559 (let ((pos t) (inhibit-read-only t)) | |
560 (while pos | |
561 (if (get-text-property (point) 'help-xref) ; move off reference | |
562 (goto-char | |
563 (or (next-single-property-change (point) 'help-xref) | |
564 (point)))) | |
565 (setq pos (next-single-property-change (point) 'help-xref)) | |
566 (when pos | |
567 (goto-char pos) | |
568 (let* ((help-data (get-text-property (point) 'help-xref)) | |
569 ;(method (car help-data)) | |
570 (args (cdr help-data))) | |
571 (when (symbolp (car args)) | |
572 (cond ((class-p (car args)) | |
573 (setcar help-data 'eieio-describe-class)) | |
574 ((generic-p (car args)) | |
575 (setcar help-data 'eieio-describe-generic)) | |
576 (t nil)) | |
577 )))) | |
578 ;; start back at the beginning, and highlight some sections | |
579 (goto-char (point-min)) | |
580 (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t) | |
581 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
582 (goto-char (point-min)) | |
583 (if (re-search-forward "^Specialized Methods:$" nil t) | |
584 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
585 (goto-char (point-min)) | |
586 (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t) | |
587 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
588 (goto-char (point-min)) | |
589 (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t) | |
590 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
591 (goto-char (point-min)) | |
592 (while (re-search-forward "^\\(Private \\)?Slot:" nil t) | |
593 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
594 )))) | |
595 | |
596 ;;; SPEEDBAR SUPPORT | |
597 ;; | |
598 (eval-when-compile | |
599 (condition-case nil | |
600 (require 'speedbar) | |
105474 | 601 (error (message "Error loading speedbar... ignored")))) |
105237 | 602 |
603 (defvar eieio-class-speedbar-key-map nil | |
604 "Keymap used when working with a project in speedbar.") | |
605 | |
606 (defun eieio-class-speedbar-make-map () | |
105474 | 607 "Make a keymap for EIEIO under speedbar." |
105237 | 608 (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap)) |
609 | |
610 ;; General viewing stuff | |
611 (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line) | |
612 (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line) | |
613 (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line) | |
614 ) | |
615 | |
616 (if eieio-class-speedbar-key-map | |
617 nil | |
618 (if (not (featurep 'speedbar)) | |
619 (add-hook 'speedbar-load-hook (lambda () | |
620 (eieio-class-speedbar-make-map) | |
621 (speedbar-add-expansion-list | |
622 '("EIEIO" | |
623 eieio-class-speedbar-menu | |
624 eieio-class-speedbar-key-map | |
625 eieio-class-speedbar)))) | |
626 (eieio-class-speedbar-make-map) | |
627 (speedbar-add-expansion-list '("EIEIO" | |
628 eieio-class-speedbar-menu | |
629 eieio-class-speedbar-key-map | |
630 eieio-class-speedbar)))) | |
631 | |
632 (defvar eieio-class-speedbar-menu | |
633 () | |
634 "Menu part in easymenu format used in speedbar while in `eieio' mode.") | |
635 | |
636 (defun eieio-class-speedbar (dir-or-object depth) | |
637 "Create buttons in speedbar that represents the current project. | |
105474 | 638 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the |
639 current expansion depth." | |
105237 | 640 (when (eq (point-min) (point-max)) |
641 ;; This function is only called once, to start the whole deal. | |
642 ;; Ceate, and expand the default object. | |
643 (eieio-class-button eieio-default-superclass 0) | |
644 (forward-line -1) | |
645 (speedbar-expand-line))) | |
646 | |
647 (defun eieio-class-button (class depth) | |
648 "Draw a speedbar button at the current point for CLASS at DEPTH." | |
649 (if (not (class-p class)) | |
650 (signal 'wrong-type-argument (list 'class-p class))) | |
651 (let ((subclasses (aref (class-v class) class-children))) | |
652 (if subclasses | |
653 (speedbar-make-tag-line 'angle ?+ | |
654 'eieio-sb-expand | |
655 class | |
656 (symbol-name class) | |
657 'eieio-describe-class-sb | |
658 class | |
659 'speedbar-directory-face | |
660 depth) | |
661 (speedbar-make-tag-line 'angle ? nil nil | |
662 (symbol-name class) | |
663 'eieio-describe-class-sb | |
664 class | |
665 'speedbar-directory-face | |
666 depth)))) | |
667 | |
668 (defun eieio-sb-expand (text class indent) | |
669 "For button TEXT, expand CLASS at the current location. | |
670 Argument INDENT is the depth of indentation." | |
671 (cond ((string-match "+" text) ;we have to expand this file | |
672 (speedbar-change-expand-button-char ?-) | |
673 (speedbar-with-writable | |
674 (save-excursion | |
675 (end-of-line) (forward-char 1) | |
676 (let ((subclasses (aref (class-v class) class-children))) | |
677 (while subclasses | |
678 (eieio-class-button (car subclasses) (1+ indent)) | |
679 (setq subclasses (cdr subclasses))))))) | |
680 ((string-match "-" text) ;we have to contract this node | |
681 (speedbar-change-expand-button-char ?+) | |
682 (speedbar-delete-subblock indent)) | |
683 (t (error "Ooops... not sure what to do"))) | |
684 (speedbar-center-buffer-smartly)) | |
685 | |
686 (defun eieio-describe-class-sb (text token indent) | |
687 "Describe the class TEXT in TOKEN. | |
688 INDENT is the current indentation level." | |
689 (speedbar-with-attached-buffer | |
690 (eieio-describe-class token)) | |
691 (speedbar-maybee-jump-to-attached-frame)) | |
692 | |
693 (provide 'eieio-opt) | |
694 | |
105377 | 695 ;; arch-tag: 71eab5f5-462f-4fa1-8ed1-f5ca1bf9adb6 |
105237 | 696 ;;; eieio-opt.el ends here |