| 1 | ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) |
| 2 | |
| 3 | ;; Copyright (C) 1996, 1998-2003, 2005, 2008-2013 Free Software |
| 4 | ;; Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 7 | ;; Keywords: OO, lisp |
| 8 | ;; Package: eieio |
| 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 | (require 'find-func) |
| 33 | (require 'speedbar) |
| 34 | (require 'help-mode) |
| 35 | |
| 36 | ;;; Code: |
| 37 | ;;;###autoload |
| 38 | (defun eieio-browse (&optional root-class) |
| 39 | "Create an object browser window to show all objects. |
| 40 | If optional ROOT-CLASS, then start with that, otherwise start with |
| 41 | variable `eieio-default-superclass'." |
| 42 | (interactive (if current-prefix-arg |
| 43 | (list (read (completing-read "Class: " |
| 44 | (eieio-build-class-alist) |
| 45 | nil t))) |
| 46 | nil)) |
| 47 | (if (not root-class) (setq root-class 'eieio-default-superclass)) |
| 48 | (eieio--check-type class-p root-class) |
| 49 | (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) |
| 50 | (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") |
| 51 | (erase-buffer) |
| 52 | (goto-char 0) |
| 53 | (eieio-browse-tree root-class "" "") |
| 54 | )) |
| 55 | |
| 56 | (defun eieio-browse-tree (this-root prefix ch-prefix) |
| 57 | "Recursively draw the children of the given class on the screen. |
| 58 | Argument THIS-ROOT is the local root of the tree. |
| 59 | Argument PREFIX is the character prefix to use. |
| 60 | Argument CH-PREFIX is another character prefix to display." |
| 61 | (eieio--check-type class-p this-root) |
| 62 | (let ((myname (symbol-name this-root)) |
| 63 | (chl (eieio--class-children (class-v this-root))) |
| 64 | (fprefix (concat ch-prefix " +--")) |
| 65 | (mprefix (concat ch-prefix " | ")) |
| 66 | (lprefix (concat ch-prefix " "))) |
| 67 | (insert prefix myname "\n") |
| 68 | (while (cdr chl) |
| 69 | (eieio-browse-tree (car chl) fprefix mprefix) |
| 70 | (setq chl (cdr chl))) |
| 71 | (if chl |
| 72 | (eieio-browse-tree (car chl) fprefix lprefix)) |
| 73 | )) |
| 74 | |
| 75 | ;;; CLASS COMPLETION / DOCUMENTATION |
| 76 | |
| 77 | ;;;###autoload(defalias 'describe-class 'eieio-describe-class) |
| 78 | |
| 79 | ;;;###autoload |
| 80 | (defun eieio-describe-class (class &optional headerfcn) |
| 81 | "Describe a CLASS defined by a string or symbol. |
| 82 | If CLASS is actually an object, then also display current values of that object. |
| 83 | Optional HEADERFCN should be called to insert a few bits of info first." |
| 84 | (interactive (list (eieio-read-class "Class: "))) |
| 85 | (with-output-to-temp-buffer (help-buffer) ;"*Help*" |
| 86 | (help-setup-xref (list #'eieio-describe-class class headerfcn) |
| 87 | (called-interactively-p 'interactive)) |
| 88 | |
| 89 | (when headerfcn (funcall headerfcn)) |
| 90 | (prin1 class) |
| 91 | (princ " is a") |
| 92 | (if (class-option class :abstract) |
| 93 | (princ "n abstract")) |
| 94 | (princ " class") |
| 95 | ;; Print file location |
| 96 | (when (get class 'class-location) |
| 97 | (princ " in `") |
| 98 | (princ (file-name-nondirectory (get class 'class-location))) |
| 99 | (princ "'")) |
| 100 | (terpri) |
| 101 | ;; Inheritance tree information |
| 102 | (let ((pl (eieio-class-parents class))) |
| 103 | (when pl |
| 104 | (princ " Inherits from ") |
| 105 | (while pl |
| 106 | (princ "`") (prin1 (car pl)) (princ "'") |
| 107 | (setq pl (cdr pl)) |
| 108 | (if pl (princ ", "))) |
| 109 | (terpri))) |
| 110 | (let ((ch (eieio-class-children class))) |
| 111 | (when ch |
| 112 | (princ " Children ") |
| 113 | (while ch |
| 114 | (princ "`") (prin1 (car ch)) (princ "'") |
| 115 | (setq ch (cdr ch)) |
| 116 | (if ch (princ ", "))) |
| 117 | (terpri))) |
| 118 | (terpri) |
| 119 | ;; System documentation |
| 120 | (let ((doc (documentation-property class 'variable-documentation))) |
| 121 | (when doc |
| 122 | (princ "Documentation:") |
| 123 | (terpri) |
| 124 | (princ doc) |
| 125 | (terpri) |
| 126 | (terpri))) |
| 127 | ;; Describe all the slots in this class |
| 128 | (eieio-describe-class-slots class) |
| 129 | ;; Describe all the methods specific to this class. |
| 130 | (let ((methods (eieio-all-generic-functions class)) |
| 131 | (doc nil)) |
| 132 | (if (not methods) nil |
| 133 | (princ "Specialized Methods:") |
| 134 | (terpri) |
| 135 | (terpri) |
| 136 | (while methods |
| 137 | (setq doc (eieio-method-documentation (car methods) class)) |
| 138 | (princ "`") |
| 139 | (prin1 (car methods)) |
| 140 | (princ "'") |
| 141 | (if (not doc) |
| 142 | (princ " Undocumented") |
| 143 | (if (car doc) |
| 144 | (progn |
| 145 | (princ " :STATIC ") |
| 146 | (prin1 (car (car doc))) |
| 147 | (terpri) |
| 148 | (princ (cdr (car doc))))) |
| 149 | (setq doc (cdr doc)) |
| 150 | (if (car doc) |
| 151 | (progn |
| 152 | (princ " :BEFORE ") |
| 153 | (prin1 (car (car doc))) |
| 154 | (terpri) |
| 155 | (princ (cdr (car doc))))) |
| 156 | (setq doc (cdr doc)) |
| 157 | (if (car doc) |
| 158 | (progn |
| 159 | (princ " :PRIMARY ") |
| 160 | (prin1 (car (car doc))) |
| 161 | (terpri) |
| 162 | (princ (cdr (car doc))))) |
| 163 | (setq doc (cdr doc)) |
| 164 | (if (car doc) |
| 165 | (progn |
| 166 | (princ " :AFTER ") |
| 167 | (prin1 (car (car doc))) |
| 168 | (terpri) |
| 169 | (princ (cdr (car doc))))) |
| 170 | (terpri) |
| 171 | (terpri)) |
| 172 | (setq methods (cdr methods)))))) |
| 173 | (with-current-buffer (help-buffer) |
| 174 | (buffer-string))) |
| 175 | |
| 176 | (defun eieio-describe-class-slots (class) |
| 177 | "Describe the slots in CLASS. |
| 178 | Outputs to the standard output." |
| 179 | (let* ((cv (class-v class)) |
| 180 | (docs (eieio--class-public-doc cv)) |
| 181 | (names (eieio--class-public-a cv)) |
| 182 | (deflt (eieio--class-public-d cv)) |
| 183 | (types (eieio--class-public-type cv)) |
| 184 | (publp (eieio--class-public-printer cv)) |
| 185 | (i 0) |
| 186 | (prot (eieio--class-protection cv)) |
| 187 | ) |
| 188 | (princ "Instance Allocated Slots:") |
| 189 | (terpri) |
| 190 | (terpri) |
| 191 | (while names |
| 192 | (if (car prot) (princ "Private ")) |
| 193 | (princ "Slot: ") |
| 194 | (prin1 (car names)) |
| 195 | (when (not (eq (aref types i) t)) |
| 196 | (princ " type = ") |
| 197 | (prin1 (aref types i))) |
| 198 | (unless (eq (car deflt) eieio-unbound) |
| 199 | (princ " default = ") |
| 200 | (prin1 (car deflt))) |
| 201 | (when (car publp) |
| 202 | (princ " printer = ") |
| 203 | (prin1 (car publp))) |
| 204 | (when (car docs) |
| 205 | (terpri) |
| 206 | (princ " ") |
| 207 | (princ (car docs)) |
| 208 | (terpri)) |
| 209 | (terpri) |
| 210 | (setq names (cdr names) |
| 211 | docs (cdr docs) |
| 212 | deflt (cdr deflt) |
| 213 | publp (cdr publp) |
| 214 | prot (cdr prot) |
| 215 | i (1+ i))) |
| 216 | (setq docs (eieio--class-class-allocation-doc cv) |
| 217 | names (eieio--class-class-allocation-a cv) |
| 218 | types (eieio--class-class-allocation-type cv) |
| 219 | i 0 |
| 220 | prot (eieio--class-class-allocation-protection cv)) |
| 221 | (when names |
| 222 | (terpri) |
| 223 | (princ "Class Allocated Slots:")) |
| 224 | (terpri) |
| 225 | (terpri) |
| 226 | (while names |
| 227 | (when (car prot) |
| 228 | (princ "Private ")) |
| 229 | (princ "Slot: ") |
| 230 | (prin1 (car names)) |
| 231 | (unless (eq (aref types i) t) |
| 232 | (princ " type = ") |
| 233 | (prin1 (aref types i))) |
| 234 | (condition-case nil |
| 235 | (let ((value (eieio-oref class (car names)))) |
| 236 | (princ " value = ") |
| 237 | (prin1 value)) |
| 238 | (error nil)) |
| 239 | (when (car docs) |
| 240 | (terpri) |
| 241 | (princ " ") |
| 242 | (princ (car docs)) |
| 243 | (terpri)) |
| 244 | (terpri) |
| 245 | (setq names (cdr names) |
| 246 | docs (cdr docs) |
| 247 | prot (cdr prot) |
| 248 | i (1+ i))))) |
| 249 | |
| 250 | ;;;###autoload |
| 251 | (defun eieio-describe-constructor (fcn) |
| 252 | "Describe the constructor function FCN. |
| 253 | Uses `eieio-describe-class' to describe the class being constructed." |
| 254 | (interactive |
| 255 | ;; Use eieio-read-class since all constructors have the same name as |
| 256 | ;; the class they create. |
| 257 | (list (eieio-read-class "Class: "))) |
| 258 | (eieio-describe-class |
| 259 | fcn (lambda () |
| 260 | ;; Describe the constructor part. |
| 261 | (prin1 fcn) |
| 262 | (princ " is an object constructor function") |
| 263 | ;; Print file location |
| 264 | (when (get fcn 'class-location) |
| 265 | (princ " in `") |
| 266 | (princ (file-name-nondirectory (get fcn 'class-location))) |
| 267 | (princ "'")) |
| 268 | (terpri) |
| 269 | (princ "Creates an object of class ") |
| 270 | (prin1 fcn) |
| 271 | (princ ".") |
| 272 | (terpri) |
| 273 | (terpri) |
| 274 | )) |
| 275 | ) |
| 276 | |
| 277 | (defun eieio-build-class-list (class) |
| 278 | "Return a list of all classes that inherit from CLASS." |
| 279 | (if (class-p class) |
| 280 | (apply #'append |
| 281 | (mapcar |
| 282 | (lambda (c) |
| 283 | (append (list c) (eieio-build-class-list c))) |
| 284 | (eieio-class-children-fast class))) |
| 285 | (list class))) |
| 286 | |
| 287 | (defun eieio-build-class-alist (&optional class instantiable-only buildlist) |
| 288 | "Return an alist of all currently active classes for completion purposes. |
| 289 | Optional argument CLASS is the class to start with. |
| 290 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which |
| 291 | are not abstract, otherwise allow all classes. |
| 292 | Optional argument BUILDLIST is more list to attach and is used internally." |
| 293 | (let* ((cc (or class eieio-default-superclass)) |
| 294 | (sublst (eieio--class-children (class-v cc)))) |
| 295 | (unless (assoc (symbol-name cc) buildlist) |
| 296 | (when (or (not instantiable-only) (not (class-abstract-p cc))) |
| 297 | (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) |
| 298 | (while sublst |
| 299 | (setq buildlist (eieio-build-class-alist |
| 300 | (car sublst) instantiable-only buildlist)) |
| 301 | (setq sublst (cdr sublst))) |
| 302 | buildlist)) |
| 303 | |
| 304 | (defvar eieio-read-class nil |
| 305 | "History of the function `eieio-read-class' prompt.") |
| 306 | |
| 307 | (defun eieio-read-class (prompt &optional histvar instantiable-only) |
| 308 | "Return a class chosen by the user using PROMPT. |
| 309 | Optional argument HISTVAR is a variable to use as history. |
| 310 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which |
| 311 | are not abstract." |
| 312 | (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only) |
| 313 | nil t nil |
| 314 | (or histvar 'eieio-read-class)))) |
| 315 | |
| 316 | (defun eieio-read-subclass (prompt class &optional histvar instantiable-only) |
| 317 | "Return a class chosen by the user using PROMPT. |
| 318 | CLASS is the base class, and completion occurs across all subclasses. |
| 319 | Optional argument HISTVAR is a variable to use as history. |
| 320 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which |
| 321 | are not abstract." |
| 322 | (intern (completing-read prompt |
| 323 | (eieio-build-class-alist class instantiable-only) |
| 324 | nil t nil |
| 325 | (or histvar 'eieio-read-class)))) |
| 326 | |
| 327 | ;;; METHOD COMPLETION / DOC |
| 328 | |
| 329 | (defalias 'describe-method 'eieio-describe-generic) |
| 330 | ;;;###autoload(defalias 'describe-generic 'eieio-describe-generic) |
| 331 | (defalias 'eieio-describe-method 'eieio-describe-generic) |
| 332 | |
| 333 | ;;;###autoload |
| 334 | (defun eieio-describe-generic (generic) |
| 335 | "Describe the generic function GENERIC. |
| 336 | Also extracts information about all methods specific to this generic." |
| 337 | (interactive (list (eieio-read-generic "Generic Method: "))) |
| 338 | (eieio--check-type generic-p generic) |
| 339 | (with-output-to-temp-buffer (help-buffer) ; "*Help*" |
| 340 | (help-setup-xref (list #'eieio-describe-generic generic) |
| 341 | (called-interactively-p 'interactive)) |
| 342 | |
| 343 | (prin1 generic) |
| 344 | (princ " is a generic function") |
| 345 | (when (generic-primary-only-p generic) |
| 346 | (princ " with only ") |
| 347 | (when (generic-primary-only-one-p generic) |
| 348 | (princ "one ")) |
| 349 | (princ "primary method") |
| 350 | (when (not (generic-primary-only-one-p generic)) |
| 351 | (princ "s")) |
| 352 | ) |
| 353 | (princ ".") |
| 354 | (terpri) |
| 355 | (terpri) |
| 356 | (let ((d (documentation generic))) |
| 357 | (if (not d) |
| 358 | (princ "The generic is not documented.\n") |
| 359 | (princ "Documentation:") |
| 360 | (terpri) |
| 361 | (princ d) |
| 362 | (terpri) |
| 363 | (terpri))) |
| 364 | (princ "Implementations:") |
| 365 | (terpri) |
| 366 | (terpri) |
| 367 | (let ((i 4) |
| 368 | (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) |
| 369 | ;; Loop over fanciful generics |
| 370 | (while (< i 7) |
| 371 | (let ((gm (aref (get generic 'eieio-method-tree) i))) |
| 372 | (when gm |
| 373 | (princ "Generic ") |
| 374 | (princ (aref prefix (- i 3))) |
| 375 | (terpri) |
| 376 | (princ (or (nth 2 gm) "Undocumented")) |
| 377 | (terpri) |
| 378 | (terpri))) |
| 379 | (setq i (1+ i))) |
| 380 | (setq i 0) |
| 381 | ;; Loop over defined class-specific methods |
| 382 | (while (< i 4) |
| 383 | (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))) |
| 384 | location) |
| 385 | (while gm |
| 386 | (princ "`") |
| 387 | (prin1 (car (car gm))) |
| 388 | (princ "'") |
| 389 | ;; prefix type |
| 390 | (princ " ") |
| 391 | (princ (aref prefix i)) |
| 392 | (princ " ") |
| 393 | ;; argument list |
| 394 | (let* ((func (cdr (car gm))) |
| 395 | (arglst (eieio-lambda-arglist func))) |
| 396 | (prin1 arglst)) |
| 397 | (terpri) |
| 398 | ;; 3 because of cdr |
| 399 | (princ (or (documentation (cdr (car gm))) |
| 400 | "Undocumented")) |
| 401 | ;; Print file location if available |
| 402 | (when (and (setq location (get generic 'method-locations)) |
| 403 | (setq location (assoc (caar gm) location))) |
| 404 | (setq location (cadr location)) |
| 405 | (princ "\n\nDefined in `") |
| 406 | (princ (file-name-nondirectory location)) |
| 407 | (princ "'\n")) |
| 408 | (setq gm (cdr gm)) |
| 409 | (terpri) |
| 410 | (terpri))) |
| 411 | (setq i (1+ i))))) |
| 412 | (with-current-buffer (help-buffer) |
| 413 | (buffer-string))) |
| 414 | |
| 415 | (defun eieio-lambda-arglist (func) |
| 416 | "Return the argument list of FUNC, a function body." |
| 417 | (if (symbolp func) (setq func (symbol-function func))) |
| 418 | (if (byte-code-function-p func) |
| 419 | (eieio-compiled-function-arglist func) |
| 420 | (car (cdr func)))) |
| 421 | |
| 422 | (defun eieio-all-generic-functions (&optional class) |
| 423 | "Return a list of all generic functions. |
| 424 | Optional CLASS argument returns only those functions that contain |
| 425 | methods for CLASS." |
| 426 | (let ((l nil) tree (cn (if class (symbol-name class) nil))) |
| 427 | (mapatoms |
| 428 | (lambda (symbol) |
| 429 | (setq tree (get symbol 'eieio-method-obarray)) |
| 430 | (if tree |
| 431 | (progn |
| 432 | ;; A symbol might be interned for that class in one of |
| 433 | ;; these three slots in the method-obarray. |
| 434 | (if (or (not class) |
| 435 | (fboundp (intern-soft cn (aref tree 0))) |
| 436 | (fboundp (intern-soft cn (aref tree 1))) |
| 437 | (fboundp (intern-soft cn (aref tree 2)))) |
| 438 | (setq l (cons symbol l))))))) |
| 439 | l)) |
| 440 | |
| 441 | (defun eieio-method-documentation (generic class) |
| 442 | "Return a list of the specific documentation of GENERIC for CLASS. |
| 443 | If there is not an explicit method for CLASS in GENERIC, or if that |
| 444 | function has no documentation, then return nil." |
| 445 | (let ((tree (get generic 'eieio-method-obarray)) |
| 446 | (cn (symbol-name class)) |
| 447 | before primary after) |
| 448 | (if (not tree) |
| 449 | nil |
| 450 | ;; A symbol might be interned for that class in one of |
| 451 | ;; these three slots in the method-obarray. |
| 452 | (setq before (intern-soft cn (aref tree 0)) |
| 453 | primary (intern-soft cn (aref tree 1)) |
| 454 | after (intern-soft cn (aref tree 2))) |
| 455 | (if (not (or (fboundp before) |
| 456 | (fboundp primary) |
| 457 | (fboundp after))) |
| 458 | nil |
| 459 | (list (if (fboundp before) |
| 460 | (cons (eieio-lambda-arglist before) |
| 461 | (documentation before)) |
| 462 | nil) |
| 463 | (if (fboundp primary) |
| 464 | (cons (eieio-lambda-arglist primary) |
| 465 | (documentation primary)) |
| 466 | nil) |
| 467 | (if (fboundp after) |
| 468 | (cons (eieio-lambda-arglist after) |
| 469 | (documentation after)) |
| 470 | nil)))))) |
| 471 | |
| 472 | (defvar eieio-read-generic nil |
| 473 | "History of the `eieio-read-generic' prompt.") |
| 474 | |
| 475 | (defun eieio-read-generic-p (fn) |
| 476 | "Function used in function `eieio-read-generic'. |
| 477 | This is because `generic-p' is a macro. |
| 478 | Argument FN is the function to test." |
| 479 | (generic-p fn)) |
| 480 | |
| 481 | (defun eieio-read-generic (prompt &optional historyvar) |
| 482 | "Read a generic function from the minibuffer with PROMPT. |
| 483 | Optional argument HISTORYVAR is the variable to use as history." |
| 484 | (intern (completing-read prompt obarray 'eieio-read-generic-p |
| 485 | t nil (or historyvar 'eieio-read-generic)))) |
| 486 | |
| 487 | ;;; METHOD STATS |
| 488 | ;; |
| 489 | ;; Dump out statistics about all the active methods in a session. |
| 490 | (defun eieio-display-method-list () |
| 491 | "Display a list of all the methods and what features are used." |
| 492 | (interactive) |
| 493 | (let* ((meth1 (eieio-all-generic-functions)) |
| 494 | (meth (sort meth1 (lambda (a b) |
| 495 | (string< (symbol-name a) |
| 496 | (symbol-name b))))) |
| 497 | (buff (get-buffer-create "*EIEIO Method List*")) |
| 498 | (methidx 0) |
| 499 | (standard-output buff) |
| 500 | (slots '(method-static |
| 501 | method-before |
| 502 | method-primary |
| 503 | method-after |
| 504 | method-generic-before |
| 505 | method-generic-primary |
| 506 | method-generic-after)) |
| 507 | (slotn '("static" |
| 508 | "before" |
| 509 | "primary" |
| 510 | "after" |
| 511 | "G bef" |
| 512 | "G prim" |
| 513 | "G aft")) |
| 514 | (idxarray (make-vector (length slots) 0)) |
| 515 | (primaryonly 0) |
| 516 | (oneprimary 0) |
| 517 | ) |
| 518 | (switch-to-buffer-other-window buff) |
| 519 | (erase-buffer) |
| 520 | (dolist (S slotn) |
| 521 | (princ S) |
| 522 | (princ "\t") |
| 523 | ) |
| 524 | (princ "Method Name") |
| 525 | (terpri) |
| 526 | (princ "--------------------------------------------------------------------") |
| 527 | (terpri) |
| 528 | (dolist (M meth) |
| 529 | (let ((mtree (get M 'eieio-method-tree)) |
| 530 | (P nil) (numP) |
| 531 | (!P nil)) |
| 532 | (dolist (S slots) |
| 533 | (let ((num (length (aref mtree (symbol-value S))))) |
| 534 | (aset idxarray (symbol-value S) |
| 535 | (+ num (aref idxarray (symbol-value S)))) |
| 536 | (prin1 num) |
| 537 | (princ "\t") |
| 538 | (when (< 0 num) |
| 539 | (if (eq S 'method-primary) |
| 540 | (setq P t numP num) |
| 541 | (setq !P t))) |
| 542 | )) |
| 543 | ;; Is this a primary-only impl method? |
| 544 | (when (and P (not !P)) |
| 545 | (setq primaryonly (1+ primaryonly)) |
| 546 | (when (= numP 1) |
| 547 | (setq oneprimary (1+ oneprimary)) |
| 548 | (princ "*")) |
| 549 | (princ "* ") |
| 550 | ) |
| 551 | (prin1 M) |
| 552 | (terpri) |
| 553 | (setq methidx (1+ methidx)) |
| 554 | ) |
| 555 | ) |
| 556 | (princ "--------------------------------------------------------------------") |
| 557 | (terpri) |
| 558 | (dolist (S slots) |
| 559 | (prin1 (aref idxarray (symbol-value S))) |
| 560 | (princ "\t") |
| 561 | ) |
| 562 | (prin1 methidx) |
| 563 | (princ " Total symbols") |
| 564 | (terpri) |
| 565 | (dolist (S slotn) |
| 566 | (princ S) |
| 567 | (princ "\t") |
| 568 | ) |
| 569 | (terpri) |
| 570 | (terpri) |
| 571 | (princ "Methods Primary Only: ") |
| 572 | (prin1 primaryonly) |
| 573 | (princ "\t") |
| 574 | (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100))) |
| 575 | (princ "% of total methods") |
| 576 | (terpri) |
| 577 | (princ "Only One Primary Impl: ") |
| 578 | (prin1 oneprimary) |
| 579 | (princ "\t") |
| 580 | (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100))) |
| 581 | (princ "% of total primary methods") |
| 582 | (terpri) |
| 583 | )) |
| 584 | |
| 585 | ;;; HELP AUGMENTATION |
| 586 | ;; |
| 587 | (define-button-type 'eieio-method-def |
| 588 | :supertype 'help-xref |
| 589 | 'help-function (lambda (class method file) |
| 590 | (eieio-help-find-method-definition class method file)) |
| 591 | 'help-echo (purecopy "mouse-2, RET: find method's definition")) |
| 592 | |
| 593 | (define-button-type 'eieio-class-def |
| 594 | :supertype 'help-xref |
| 595 | 'help-function (lambda (class file) |
| 596 | (eieio-help-find-class-definition class file)) |
| 597 | 'help-echo (purecopy "mouse-2, RET: find class definition")) |
| 598 | |
| 599 | (defun eieio-help-find-method-definition (class method file) |
| 600 | (let ((filename (find-library-name file)) |
| 601 | location buf) |
| 602 | (when (null filename) |
| 603 | (error "Cannot find library %s" file)) |
| 604 | (setq buf (find-file-noselect filename)) |
| 605 | (with-current-buffer buf |
| 606 | (goto-char (point-min)) |
| 607 | (when |
| 608 | (re-search-forward |
| 609 | ;; Regexp for searching methods. |
| 610 | (concat "(defmethod[ \t\r\n]+" method |
| 611 | "\\([ \t\r\n]+:[a-zA-Z]+\\)?" |
| 612 | "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+" |
| 613 | class |
| 614 | "\\s-*)") |
| 615 | nil t) |
| 616 | (setq location (match-beginning 0)))) |
| 617 | (if (null location) |
| 618 | (message "Unable to find location in file") |
| 619 | (pop-to-buffer buf) |
| 620 | (goto-char location) |
| 621 | (recenter) |
| 622 | (beginning-of-line)))) |
| 623 | |
| 624 | (defun eieio-help-find-class-definition (class file) |
| 625 | (let ((filename (find-library-name file)) |
| 626 | location buf) |
| 627 | (when (null filename) |
| 628 | (error "Cannot find library %s" file)) |
| 629 | (setq buf (find-file-noselect filename)) |
| 630 | (with-current-buffer buf |
| 631 | (goto-char (point-min)) |
| 632 | (when |
| 633 | (re-search-forward |
| 634 | ;; Regexp for searching a class. |
| 635 | (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+") |
| 636 | nil t) |
| 637 | (setq location (match-beginning 0)))) |
| 638 | (if (null location) |
| 639 | (message "Unable to find location in file") |
| 640 | (pop-to-buffer buf) |
| 641 | (goto-char location) |
| 642 | (recenter) |
| 643 | (beginning-of-line)))) |
| 644 | |
| 645 | |
| 646 | (defun eieio-help-mode-augmentation-maybee (&rest unused) |
| 647 | "For buffers thrown into help mode, augment for EIEIO. |
| 648 | Arguments UNUSED are not used." |
| 649 | ;; Scan created buttons so far if we are in help mode. |
| 650 | (when (eq major-mode 'help-mode) |
| 651 | (save-excursion |
| 652 | (goto-char (point-min)) |
| 653 | (let ((pos t) (inhibit-read-only t)) |
| 654 | (while pos |
| 655 | (if (get-text-property (point) 'help-xref) ; move off reference |
| 656 | (goto-char |
| 657 | (or (next-single-property-change (point) 'help-xref) |
| 658 | (point)))) |
| 659 | (setq pos (next-single-property-change (point) 'help-xref)) |
| 660 | (when pos |
| 661 | (goto-char pos) |
| 662 | (let* ((help-data (get-text-property (point) 'help-xref)) |
| 663 | ;(method (car help-data)) |
| 664 | (args (cdr help-data))) |
| 665 | (when (symbolp (car args)) |
| 666 | (cond ((class-p (car args)) |
| 667 | (setcar help-data 'eieio-describe-class)) |
| 668 | ((generic-p (car args)) |
| 669 | (setcar help-data 'eieio-describe-generic)) |
| 670 | (t nil)) |
| 671 | )))) |
| 672 | ;; start back at the beginning, and highlight some sections |
| 673 | (goto-char (point-min)) |
| 674 | (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t) |
| 675 | (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) |
| 676 | (goto-char (point-min)) |
| 677 | (if (re-search-forward "^Specialized Methods:$" nil t) |
| 678 | (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) |
| 679 | (goto-char (point-min)) |
| 680 | (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t) |
| 681 | (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) |
| 682 | (goto-char (point-min)) |
| 683 | (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t) |
| 684 | (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) |
| 685 | (goto-char (point-min)) |
| 686 | (while (re-search-forward "^\\(Private \\)?Slot:" nil t) |
| 687 | (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) |
| 688 | (goto-char (point-min)) |
| 689 | (cond |
| 690 | ((looking-at "\\(.+\\) is a generic function") |
| 691 | (let ((mname (match-string 1)) |
| 692 | cname) |
| 693 | (while (re-search-forward "^`\\(.+\\)'[^\0]+?Defined in `\\(.+\\)'" nil t) |
| 694 | (setq cname (match-string-no-properties 1)) |
| 695 | (help-xref-button 2 'eieio-method-def cname |
| 696 | mname |
| 697 | (cadr (assoc (intern cname) |
| 698 | (get (intern mname) |
| 699 | 'method-locations))))))) |
| 700 | ((looking-at "\\(.+\\) is an object constructor function in `\\(.+\\)'") |
| 701 | (let ((cname (match-string-no-properties 1))) |
| 702 | (help-xref-button 2 'eieio-class-def cname |
| 703 | (get (intern cname) 'class-location)))) |
| 704 | ((looking-at "\\(.+\\) is a\\(n abstract\\)? class in `\\(.+\\)'") |
| 705 | (let ((cname (match-string-no-properties 1))) |
| 706 | (help-xref-button 3 'eieio-class-def cname |
| 707 | (get (intern cname) 'class-location))))) |
| 708 | )))) |
| 709 | |
| 710 | ;;; SPEEDBAR SUPPORT |
| 711 | ;; |
| 712 | |
| 713 | (defvar eieio-class-speedbar-key-map nil |
| 714 | "Keymap used when working with a project in speedbar.") |
| 715 | |
| 716 | (defun eieio-class-speedbar-make-map () |
| 717 | "Make a keymap for EIEIO under speedbar." |
| 718 | (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap)) |
| 719 | |
| 720 | ;; General viewing stuff |
| 721 | (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line) |
| 722 | (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line) |
| 723 | (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line) |
| 724 | ) |
| 725 | |
| 726 | (if eieio-class-speedbar-key-map |
| 727 | nil |
| 728 | (if (not (featurep 'speedbar)) |
| 729 | (add-hook 'speedbar-load-hook (lambda () |
| 730 | (eieio-class-speedbar-make-map) |
| 731 | (speedbar-add-expansion-list |
| 732 | '("EIEIO" |
| 733 | eieio-class-speedbar-menu |
| 734 | eieio-class-speedbar-key-map |
| 735 | eieio-class-speedbar)))) |
| 736 | (eieio-class-speedbar-make-map) |
| 737 | (speedbar-add-expansion-list '("EIEIO" |
| 738 | eieio-class-speedbar-menu |
| 739 | eieio-class-speedbar-key-map |
| 740 | eieio-class-speedbar)))) |
| 741 | |
| 742 | (defvar eieio-class-speedbar-menu |
| 743 | () |
| 744 | "Menu part in easymenu format used in speedbar while in `eieio' mode.") |
| 745 | |
| 746 | (defun eieio-class-speedbar (dir-or-object depth) |
| 747 | "Create buttons in speedbar that represents the current project. |
| 748 | DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the |
| 749 | current expansion depth." |
| 750 | (when (eq (point-min) (point-max)) |
| 751 | ;; This function is only called once, to start the whole deal. |
| 752 | ;; Ceate, and expand the default object. |
| 753 | (eieio-class-button eieio-default-superclass 0) |
| 754 | (forward-line -1) |
| 755 | (speedbar-expand-line))) |
| 756 | |
| 757 | (defun eieio-class-button (class depth) |
| 758 | "Draw a speedbar button at the current point for CLASS at DEPTH." |
| 759 | (eieio--check-type class-p class) |
| 760 | (let ((subclasses (eieio--class-children (class-v class)))) |
| 761 | (if subclasses |
| 762 | (speedbar-make-tag-line 'angle ?+ |
| 763 | 'eieio-sb-expand |
| 764 | class |
| 765 | (symbol-name class) |
| 766 | 'eieio-describe-class-sb |
| 767 | class |
| 768 | 'speedbar-directory-face |
| 769 | depth) |
| 770 | (speedbar-make-tag-line 'angle ? nil nil |
| 771 | (symbol-name class) |
| 772 | 'eieio-describe-class-sb |
| 773 | class |
| 774 | 'speedbar-directory-face |
| 775 | depth)))) |
| 776 | |
| 777 | (defun eieio-sb-expand (text class indent) |
| 778 | "For button TEXT, expand CLASS at the current location. |
| 779 | Argument INDENT is the depth of indentation." |
| 780 | (cond ((string-match "+" text) ;we have to expand this file |
| 781 | (speedbar-change-expand-button-char ?-) |
| 782 | (speedbar-with-writable |
| 783 | (save-excursion |
| 784 | (end-of-line) (forward-char 1) |
| 785 | (let ((subclasses (eieio--class-children (class-v class)))) |
| 786 | (while subclasses |
| 787 | (eieio-class-button (car subclasses) (1+ indent)) |
| 788 | (setq subclasses (cdr subclasses))))))) |
| 789 | ((string-match "-" text) ;we have to contract this node |
| 790 | (speedbar-change-expand-button-char ?+) |
| 791 | (speedbar-delete-subblock indent)) |
| 792 | (t (error "Ooops... not sure what to do"))) |
| 793 | (speedbar-center-buffer-smartly)) |
| 794 | |
| 795 | (defun eieio-describe-class-sb (text token indent) |
| 796 | "Describe the class TEXT in TOKEN. |
| 797 | INDENT is the current indentation level." |
| 798 | (dframe-with-attached-buffer |
| 799 | (eieio-describe-class token)) |
| 800 | (dframe-maybee-jump-to-attached-frame)) |
| 801 | |
| 802 | (provide 'eieio-opt) |
| 803 | |
| 804 | ;;; eieio-opt.el ends here |