Mercurial > emacs
changeset 104401:2efe3dc24373
Add files for the EIEIO library.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Sat, 22 Aug 2009 04:12:52 +0000 |
| parents | ed5d844496e7 |
| children | 5df6945a3eaa |
| files | lisp/cedet/data-debug.el lisp/eieio/chart.el lisp/eieio/eieio-base.el lisp/eieio/eieio-comp.el lisp/eieio/eieio-custom.el lisp/eieio/eieio-datadebug.el lisp/eieio/eieio-doc.el lisp/eieio/eieio-opt.el lisp/eieio/eieio-speedbar.el lisp/eieio/eieio.el |
| diffstat | 10 files changed, 7273 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/data-debug.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,1103 @@ +;;; data-debug.el --- Datastructure Debugger + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Provide a simple way to investigate particularly large and complex +;; data structures. +;; +;; The best way to get started is to bind M-: to 'data-debug-eval-expression. +;; +;; (global-set-key "\M-:" 'data-debug-eval-expression) +;; +;; If you write functions with complex output that need debugging, you +;; can make them interactive with data-debug-show-stuff. For example: +;; +;; (defun my-complex-output-fcn () +;; "Calculate something complicated at point, and return it." +;; (interactive) ;; function not normally interactive +;; (let ((stuff (do-stuff))) +;; (when (interactive-p) +;; (data-debug-show-stuff stuff "myStuff")) +;; stuff)) + +(require 'font-lock) +;;; Code: + +;;; Compatibility +;; +(if (featurep 'xemacs) + (eval-and-compile + (defalias 'data-debug-overlay-properties 'extent-properties) + (defalias 'data-debug-overlay-p 'extentp) + (if (not (fboundp 'propertize)) + (defun dd-propertize (string &rest properties) + "Mimic 'propertize' in from Emacs 23." + (add-text-properties 0 (length string) properties string) + string + ) + (defalias 'dd-propertize 'propertize)) + ) + ;; Regular Emacs + (eval-and-compile + (defalias 'data-debug-overlay-properties 'overlay-properties) + (defalias 'data-debug-overlay-p 'overlayp) + (defalias 'dd-propertize 'propertize) + ) + ) + +;;; GENERIC STUFF +;; +;;;###autoload +(defun data-debug-insert-property-list (proplist prefix &optional parent) + "Insert the property list PROPLIST. +Each line starts with PREFIX. +The attributes belong to the tag PARENT." + (while proplist + (let ((pretext (concat (symbol-name (car proplist)) " : "))) + (data-debug-insert-thing (car (cdr proplist)) + prefix + pretext + parent)) + (setq proplist (cdr (cdr proplist))))) + +;;; overlays +;; +(defun data-debug-insert-overlay-props (overlay prefix) + "Insert all the parts of OVERLAY. +PREFIX specifies what to insert at the start of each line." + (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) + (proplist (data-debug-overlay-properties overlay))) + (data-debug-insert-property-list + proplist attrprefix) + ) + ) + +(defun data-debug-insert-overlay-from-point (point) + "Insert the overlay found at the overlay button at POINT." + (let ((overlay (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-overlay-props overlay + (concat (make-string indent ? ) + "| ")) + (goto-char start) + )) + +(defun data-debug-insert-overlay-button (overlay prefix prebuttontext) + "Insert a button representing OVERLAY. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the overlay button." + (let ((start (point)) + (end nil) + (str (format "%s" overlay)) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug overlay) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-overlay-from-point) + (insert "\n") + ) + ) + +;;; overlay list +;; +(defun data-debug-insert-overlay-list (overlaylist prefix) + "Insert all the parts of OVERLAYLIST. +PREFIX specifies what to insert at the start of each line." + (while overlaylist + (data-debug-insert-overlay-button (car overlaylist) + prefix + "") + (setq overlaylist (cdr overlaylist)))) + +(defun data-debug-insert-overlay-list-from-point (point) + "Insert the overlay found at the overlay list button at POINT." + (let ((overlaylist (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-overlay-list overlaylist + (concat (make-string indent ? ) + "* ")) + (goto-char start) + )) + +(defun data-debug-insert-overlay-list-button (overlaylist + prefix + prebuttontext) + "Insert a button representing OVERLAYLIST. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the overlay list button." + (let ((start (point)) + (end nil) + (str (format "#<overlay list: %d entries>" (length overlaylist))) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug overlaylist) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-overlay-list-from-point) + (insert "\n") + ) + ) + +;;; buffers +;; +(defun data-debug-insert-buffer-props (buffer prefix) + "Insert all the parts of BUFFER. +PREFIX specifies what to insert at the start of each line." + (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) + (proplist + (list :filename (buffer-file-name buffer) + :live (buffer-live-p buffer) + :modified (buffer-modified-p buffer) + :size (buffer-size buffer) + :process (get-buffer-process buffer) + :localvars (buffer-local-variables buffer) + ))) + (data-debug-insert-property-list + proplist attrprefix) + ) + ) + +(defun data-debug-insert-buffer-from-point (point) + "Insert the buffer found at the buffer button at POINT." + (let ((buffer (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-buffer-props buffer + (concat (make-string indent ? ) + "| ")) + (goto-char start) + )) + +(defun data-debug-insert-buffer-button (buffer prefix prebuttontext) + "Insert a button representing BUFFER. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the buffer button." + (let ((start (point)) + (end nil) + (str (format "%S" buffer)) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug buffer) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-buffer-from-point) + (insert "\n") + ) + ) + +;;; buffer list +;; +(defun data-debug-insert-buffer-list (bufferlist prefix) + "Insert all the parts of BUFFERLIST. +PREFIX specifies what to insert at the start of each line." + (while bufferlist + (data-debug-insert-buffer-button (car bufferlist) + prefix + "") + (setq bufferlist (cdr bufferlist)))) + +(defun data-debug-insert-buffer-list-from-point (point) + "Insert the buffer found at the buffer list button at POINT." + (let ((bufferlist (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-buffer-list bufferlist + (concat (make-string indent ? ) + "* ")) + (goto-char start) + )) + +(defun data-debug-insert-buffer-list-button (bufferlist + prefix + prebuttontext) + "Insert a button representing BUFFERLIST. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the buffer list button." + (let ((start (point)) + (end nil) + (str (format "#<buffer list: %d entries>" (length bufferlist))) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug bufferlist) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-buffer-list-from-point) + (insert "\n") + ) + ) + +;;; processes +;; +(defun data-debug-insert-process-props (process prefix) + "Insert all the parts of PROCESS. +PREFIX specifies what to insert at the start of each line." + (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) + (id (process-id process)) + (tty (process-tty-name process)) + (pcontact (process-contact process t)) + (proplist (process-plist process))) + (data-debug-insert-property-list + (append + (if id (list 'id id)) + (if tty (list 'tty tty)) + (if pcontact pcontact) + proplist) + attrprefix) + ) + ) + +(defun data-debug-insert-process-from-point (point) + "Insert the process found at the process button at POINT." + (let ((process (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-process-props process + (concat (make-string indent ? ) + "| ")) + (goto-char start) + )) + +(defun data-debug-insert-process-button (process prefix prebuttontext) + "Insert a button representing PROCESS. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the process button." + (let ((start (point)) + (end nil) + (str (format "%S : %s" process (process-status process))) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug process) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-process-from-point) + (insert "\n") + ) + ) + +;;; Rings +;; +;; A ring (like kill-ring, or whatever.) +(defun data-debug-insert-ring-contents (ring prefix) + "Insert all the parts of RING. +PREFIX specifies what to insert at the start of each line." + (let ((len (ring-length ring)) + (idx 0) + ) + (while (< idx len) + (data-debug-insert-thing (ring-ref ring idx) prefix "") + (setq idx (1+ idx)) + ))) + +(defun data-debug-insert-ring-items-from-point (point) + "Insert the ring found at the ring button at POINT." + (let ((ring (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-ring-contents ring + (concat (make-string indent ? ) + "} ")) + (goto-char start) + )) + +(defun data-debug-insert-ring-button (ring + prefix + prebuttontext) + "Insert a button representing RING. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the stuff list button." + (let* ((start (point)) + (end nil) + (str (format "#<RING: %d, %d max>" + (ring-length ring) + (ring-size ring))) + (ringthing + (if (= (ring-length ring) 0) nil (ring-ref ring 0))) + (tip (format "Ring max-size %d, length %d. Full of: %S" + (ring-size ring) + (ring-length ring) + (cond ((stringp ringthing) + "strings") + ((semantic-tag-p ringthing) + "tags") + ((eieio-object-p ringthing) + "eieio objects") + ((listp ringthing) + "List of somethin'") + (t "stuff")))) + ) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-type-face) + (put-text-property start end 'ddebug ring) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-ring-items-from-point) + (insert "\n") + ) + ) + + +;;; Hash-table +;; + +;;;###autoload +(defun data-debug-insert-hash-table (hash-table prefix) + "Insert the contents of HASH-TABLE inserting PREFIX before each element." + (maphash + (lambda (key value) + (data-debug-insert-thing + key prefix + (dd-propertize "key " 'face font-lock-comment-face)) + (data-debug-insert-thing + value prefix + (dd-propertize "val " 'face font-lock-comment-face))) + hash-table)) + +(defun data-debug-insert-hash-table-from-point (point) + "Insert the contents of the hash-table button at POINT." + (let ((hash-table (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-hash-table + hash-table + (concat (make-string indent ? ) "> ")) + (goto-char start)) + ) + +(defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext) + "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text." + (let ((string (dd-propertize (format "%s" hash-table) + 'face 'font-lock-keyword-face))) + (insert (dd-propertize + (concat prefix prebuttontext string) + 'ddebug hash-table + 'ddebug-indent (length prefix) + 'ddebug-prefix prefix + 'help-echo + (format "Hash-table\nTest: %s\nWeakness: %s\nElements: %d (of %d)" + (hash-table-test hash-table) + (if (hash-table-weakness hash-table) "yes" "no") + (hash-table-count hash-table) + (hash-table-size hash-table)) + 'ddebug-function + 'data-debug-insert-hash-table-from-point) + "\n")) + ) + +;;; Widget +;; +;; Widgets have a long list of properties +;;;###autoload +(defun data-debug-insert-widget-properties (widget prefix) + "Insert the contents of WIDGET inserting PREFIX before each element." + (let ((type (car widget)) + (rest (cdr widget))) + (while rest + (data-debug-insert-thing (car (cdr rest)) + prefix + (concat + (dd-propertize (format "%s" (car rest)) + 'face font-lock-comment-face) + " : ")) + (setq rest (cdr (cdr rest)))) + )) + +(defun data-debug-insert-widget-from-point (point) + "Insert the contents of the widget button at POINT." + (let ((widget (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-widget-properties + widget (concat (make-string indent ? ) "# ")) + (goto-char start)) + ) + +(defun data-debug-insert-widget (widget prefix prebuttontext) + "Insert one WIDGET. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget)) + 'face 'font-lock-keyword-face))) + (insert (dd-propertize + (concat prefix prebuttontext string) + 'ddebug widget + 'ddebug-indent (length prefix) + 'ddebug-prefix prefix + 'help-echo + (format "Widget\nType: %s\n# Properties: %d" + (car widget) + (/ (1- (length widget)) 2)) + 'ddebug-function + 'data-debug-insert-widget-from-point) + "\n"))) + +;;; list of stuff +;; +;; just a list. random stuff inside. +;;;###autoload +(defun data-debug-insert-stuff-list (stufflist prefix) + "Insert all the parts of STUFFLIST. +PREFIX specifies what to insert at the start of each line." + (while stufflist + (data-debug-insert-thing + ;; Some lists may put a value in the CDR + (if (listp stufflist) (car stufflist) stufflist) + prefix + "") + (setq stufflist + (if (listp stufflist) + (cdr-safe stufflist) + nil)))) + +(defun data-debug-insert-stuff-list-from-point (point) + "Insert the stuff found at the stuff list button at POINT." + (let ((stufflist (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-stuff-list stufflist + (concat (make-string indent ? ) + "> ")) + (goto-char start) + )) + +(defun data-debug-insert-stuff-list-button (stufflist + prefix + prebuttontext) + "Insert a button representing STUFFLIST. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the stuff list button." + (let ((start (point)) + (end nil) + (str + (condition-case nil + (format "#<list o' stuff: %d entries>" (safe-length stufflist)) + (error "#<list o' stuff>"))) + (tip (if (or (listp (car stufflist)) + (vectorp (car stufflist))) + "" + (format "%s" stufflist)))) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) + (put-text-property start end 'ddebug stufflist) + (put-text-property start end 'ddebug-indent (length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-stuff-list-from-point) + (insert "\n") + ) + ) + +;;; vector of stuff +;; +;; just a vector. random stuff inside. +;;;###autoload +(defun data-debug-insert-stuff-vector (stuffvector prefix) + "Insert all the parts of STUFFVECTOR. +PREFIX specifies what to insert at the start of each line." + (let ((idx 0)) + (while (< idx (length stuffvector)) + (data-debug-insert-thing + ;; Some vectors may put a value in the CDR + (aref stuffvector idx) + prefix + "") + (setq idx (1+ idx))))) + +(defun data-debug-insert-stuff-vector-from-point (point) + "Insert the stuff found at the stuff vector button at POINT." + (let ((stuffvector (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-stuff-vector stuffvector + (concat (make-string indent ? ) + "[ ")) + (goto-char start) + )) + +(defun data-debug-insert-stuff-vector-button (stuffvector + prefix + prebuttontext) + "Insert a button representing STUFFVECTOR. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the stuff vector button." + (let* ((start (point)) + (end nil) + (str (format "#<vector o' stuff: %d entries>" (length stuffvector))) + (tip str)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) + (put-text-property start end 'ddebug stuffvector) + (put-text-property start end 'ddebug-indent (length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-stuff-vector-from-point) + (insert "\n") + ) + ) + +;;; Symbol +;; + +(defun data-debug-insert-symbol-from-point (point) + "Insert attached properties and possibly the value of symbol at POINT." + (let ((symbol (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start) + (end-of-line) + (setq start (point)) + (forward-char 1) + (when (and (not (fboundp symbol)) (boundp symbol)) + (data-debug-insert-thing + (symbol-value symbol) + (concat (make-string indent ? ) "> ") + (concat + (dd-propertize "value" + 'face 'font-lock-comment-face) + " "))) + (data-debug-insert-property-list + (symbol-plist symbol) + (concat (make-string indent ? ) "> ")) + (goto-char start)) + ) + +(defun data-debug-insert-symbol-button (symbol prefix prebuttontext) + "Insert a button representing SYMBOL. + PREFIX is the text that preceeds the button. + PREBUTTONTEXT is some text between prefix and the symbol button." + (let ((string + (cond ((fboundp symbol) + (dd-propertize (concat "#'" (symbol-name symbol)) + 'face 'font-lock-function-name-face)) + ((boundp symbol) + (dd-propertize (concat "'" (symbol-name symbol)) + 'face 'font-lock-variable-name-face)) + (t (format "'%s" symbol))))) + (insert (dd-propertize + (concat prefix prebuttontext string) + 'ddebug symbol + 'ddebug-indent (length prefix) + 'ddebug-prefix prefix + 'help-echo "" + 'ddebug-function + 'data-debug-insert-symbol-from-point) + "\n")) + ) + +;;; String +(defun data-debug-insert-string (thing prefix prebuttontext) + "Insert one symbol THING. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (let ((newstr thing)) + (while (string-match "\n" newstr) + (setq newstr (replace-match "\\n" t t newstr))) + (while (string-match "\t" newstr) + (setq newstr (replace-match "\\t" t t newstr))) + (insert prefix prebuttontext + (dd-propertize (format "\"%s\"" newstr) + 'face font-lock-string-face) + "\n" ))) + +;;; Number +(defun data-debug-insert-number (thing prefix prebuttontext) + "Insert one symbol THING. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (insert prefix prebuttontext + (dd-propertize (format "%S" thing) + 'face font-lock-string-face) + "\n")) + +;;; Lambda Expression +(defun data-debug-insert-lambda-expression (thing prefix prebuttontext) + "Insert one lambda expression THING. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (let ((txt (prin1-to-string thing))) + (data-debug-insert-simple-thing + txt prefix prebuttontext 'font-lock-keyword-face)) + ) + +;;; nil thing +(defun data-debug-insert-nil (thing prefix prebuttontext) + "Insert one simple THING with a face. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing. +FACE is the face to use." + (insert prefix prebuttontext) + (insert ": ") + (let ((start (point)) + (end nil)) + (insert "nil") + (setq end (point)) + (insert "\n" ) + (put-text-property start end 'face 'font-lock-variable-name-face) + )) + +;;; simple thing +(defun data-debug-insert-simple-thing (thing prefix prebuttontext face) + "Insert one simple THING with a face. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing. +FACE is the face to use." + (insert prefix prebuttontext) + (let ((start (point)) + (end nil)) + (insert (format "%s" thing)) + (setq end (point)) + (insert "\n" ) + (put-text-property start end 'face face) + )) + +;;; custom thing +(defun data-debug-insert-custom (thingstring prefix prebuttontext face) + "Insert one simple THINGSTRING with a face. +Use for simple items that need a custom insert. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing. +FACE is the face to use." + (insert prefix prebuttontext) + (let ((start (point)) + (end nil)) + (insert thingstring) + (setq end (point)) + (insert "\n" ) + (put-text-property start end 'face face) + )) + + +(defvar data-debug-thing-alist + '( + ;; nil + (null . data-debug-insert-nil) + + ;; eieio object + ((lambda (thing) (object-p thing)) . data-debug-insert-object-button) + + ;; tag + (semantic-tag-p . data-debug-insert-tag) + + ;; taglist + ((lambda (thing) (and (listp thing) (semantic-tag-p (car thing)))) . + data-debug-insert-tag-list-button) + + ;; find results + (semanticdb-find-results-p . data-debug-insert-find-results-button) + + ;; Elt of a find-results + ((lambda (thing) (and (listp thing) + (semanticdb-abstract-table-child-p (car thing)) + (semantic-tag-p (cdr thing)))) . + data-debug-insert-db-and-tag-button) + + ;; Overlay + (data-debug-overlay-p . data-debug-insert-overlay-button) + + ;; Overlay list + ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) . + data-debug-insert-overlay-list-button) + + ;; Buffer + (bufferp . data-debug-insert-buffer-button) + + ;; Buffer list + ((lambda (thing) (and (consp thing) (bufferp (car thing)))) . + data-debug-insert-buffer-list-button) + + ;; Process + (processp . data-debug-insert-process-button) + + ;; String + (stringp . data-debug-insert-string) + + ;; Number + (numberp . data-debug-insert-number) + + ;; Symbol + (symbolp . data-debug-insert-symbol-button) + + ;; Ring + (ring-p . data-debug-insert-ring-button) + + ;; Lambda Expression + ((lambda (thing) (and (consp thing) (eq (car thing) 'lambda))) . + data-debug-insert-lambda-expression) + + ;; Hash-table + (hash-table-p . data-debug-insert-hash-table-button) + + ;; Widgets + (widgetp . data-debug-insert-widget) + + ;; List of stuff + (listp . data-debug-insert-stuff-list-button) + + ;; Vector of stuff + (vectorp . data-debug-insert-stuff-vector-button) + ) + "Alist of methods used to insert things into an Ddebug buffer.") + +;; uber insert method +;;;###autoload +(defun data-debug-insert-thing (thing prefix prebuttontext &optional parent) + "Insert THING with PREFIX. +PREBUTTONTEXT is some text to insert between prefix and the thing +that is not included in the indentation calculation of any children. +If PARENT is non-nil, it is somehow related as a parent to thing." + (when (catch 'done + (dolist (test data-debug-thing-alist) + (when (funcall (car test) thing) + (condition-case nil + (funcall (cdr test) thing prefix prebuttontext parent) + (error + (funcall (cdr test) thing prefix prebuttontext))) + (throw 'done nil)) + ) + nil) + (data-debug-insert-simple-thing (format "%S" thing) + prefix + prebuttontext + 'bold))) + +;;; MAJOR MODE +;; +;; The Ddebug major mode provides an interactive space to explore +;; the current state of semantic's parsing and analysis +;; +(defgroup data-debug nil + "data-debug group." + :group 'langauges) + +(defvar data-debug-mode-syntax-table + (let ((table (make-syntax-table (standard-syntax-table)))) + (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;; + (modify-syntax-entry ?\n ">" table) ;; Comment end + (modify-syntax-entry ?\" "\"" table) ;; String + (modify-syntax-entry ?\- "_" table) ;; Symbol + (modify-syntax-entry ?\\ "\\" table) ;; Quote + (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote) + (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote) + (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma) + + table) + "Syntax table used in data-debug macro buffers.") + +(defvar data-debug-map + (let ((km (make-sparse-keymap))) + (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse) + (define-key km " " 'data-debug-expand-or-contract) + (define-key km "\C-m" 'data-debug-expand-or-contract) + (define-key km "n" 'data-debug-next) + (define-key km "p" 'data-debug-prev) + (define-key km "N" 'data-debug-next-expando) + (define-key km "P" 'data-debug-prev-expando) + km) + "Keymap used in data-debug.") + +(defcustom data-debug-mode-hook nil + "*Hook run when data-debug starts." + :group 'data-debug + :type 'hook) + +;;;###autoload +(defun data-debug-mode () + "Major-mode for the Analyzer debugger. + +\\{data-debug-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'data-debug-mode + mode-name "DATA-DEBUG" + comment-start ";;" + comment-end "") + (set (make-local-variable 'comment-start-skip) + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + (set-syntax-table data-debug-mode-syntax-table) + (use-local-map data-debug-map) + (run-hooks 'data-debug-hook) + (buffer-disable-undo) + (set (make-local-variable 'font-lock-global-modes) nil) + (font-lock-mode -1) + ) + +;;;###autoload +(defun data-debug-new-buffer (name) + "Create a new ddebug buffer with NAME." + (let ((b (get-buffer-create name))) + (pop-to-buffer b) + (set-buffer b) + (erase-buffer) + (data-debug-mode) + b)) + +;;; Ddebug mode commands +;; +(defun data-debug-next () + "Go to the next line in the Ddebug buffer." + (interactive) + (forward-line 1) + (beginning-of-line) + (skip-chars-forward " *-><[]" (point-at-eol))) + +(defun data-debug-prev () + "Go to the next line in the Ddebug buffer." + (interactive) + (forward-line -1) + (beginning-of-line) + (skip-chars-forward " *-><[]" (point-at-eol))) + +(defun data-debug-next-expando () + "Go to the next line in the Ddebug buffer. +Contract the current line (if open) and expand the line +we move to." + (interactive) + (data-debug-contract-current-line) + (data-debug-next) + (data-debug-expand-current-line) + ) + +(defun data-debug-prev-expando () + "Go to the previous line in the Ddebug buffer. +Contract the current line (if open) and expand the line +we move to." + (interactive) + (data-debug-contract-current-line) + (data-debug-prev) + (data-debug-expand-current-line) + ) + +(defun data-debug-current-line-expanded-p () + "Return non-nil if the current line is expanded." + (let ((ti (current-indentation)) + (ni (condition-case nil + (save-excursion + (end-of-line) + (forward-char 1) + (current-indentation)) + (error 0)))) + (> ni ti))) + +(defun data-debug-line-expandable-p () + "Return non-nil if the current line is expandable. +Lines that are not expandable are assumed to not be contractable." + (not (get-text-property (point) 'ddebug-noexpand))) + +(defun data-debug-expand-current-line () + "Expand the current line (if possible). +Do nothing if already expanded." + (when (or (not (data-debug-line-expandable-p)) + (not (data-debug-current-line-expanded-p))) + ;; If the next line is the same or less indentation, expand. + (let ((fcn (get-text-property (point) 'ddebug-function))) + (when fcn + (funcall fcn (point)) + (beginning-of-line) + )))) + +(defun data-debug-contract-current-line () + "Contract the current line (if possible). +Do nothing if already expanded." + (when (and (data-debug-current-line-expanded-p) + ;; Don't contract if the current line is not expandable. + (get-text-property (point) 'ddebug-function)) + (let ((ti (current-indentation)) + ) + ;; If next indentation is larger, collapse. + (end-of-line) + (forward-char 1) + (let ((start (point)) + (end nil)) + (condition-case nil + (progn + ;; Keep checking indentation + (while (or (> (current-indentation) ti) + (looking-at "^\\s-*$")) + (end-of-line) + (forward-char 1)) + (setq end (point)) + ) + (error (setq end (point-max)))) + (delete-region start end) + (forward-char -1) + (beginning-of-line))))) + +(defun data-debug-expand-or-contract () + "Expand or contract anything at the current point." + (interactive) + (if (and (data-debug-line-expandable-p) + (data-debug-current-line-expanded-p)) + (data-debug-contract-current-line) + (data-debug-expand-current-line)) + (skip-chars-forward " *-><[]" (point-at-eol))) + +(defun data-debug-expand-or-contract-mouse (event) + "Expand or contract anything at event EVENT." + (interactive "e") + (let* ((win (car (car (cdr event)))) + ) + (select-window win t) + (save-excursion + ;(goto-char (window-start win)) + (mouse-set-point event) + (data-debug-expand-or-contract)) + )) + +;;; GENERIC STRUCTURE DUMP +;; +;;;###autoload +(defun data-debug-show-stuff (stuff name) + "Data debug STUFF in a buffer named *NAME DDebug*." + (data-debug-new-buffer (concat "*" name " DDebug*")) + (data-debug-insert-thing stuff "?" "") + (goto-char (point-min)) + (when (data-debug-line-expandable-p) + (data-debug-expand-current-line))) + +;;; DEBUG COMMANDS +;; +;; Various commands to output aspects of the current semantic environment. + +;;;###autoload +(defun data-debug-edebug-expr (expr) + "Dump out the contets of some expression EXPR in edebug with ddebug." + (interactive + (list (let ((minibuffer-completing-symbol t)) + (read-from-minibuffer "Eval: " + nil read-expression-map t + 'read-expression-history)) + )) + (let ((v (eval expr))) + (if (not v) + (message "Expression %s is nil." expr) + (data-debug-show-stuff v "expression")))) + +;;;###autoload +(defun data-debug-eval-expression (expr) + "Evaluate EXPR and display the value. +If the result is something simple, show it in the echo area. +If the result is a list or vector, then use the data debugger to display it." + (interactive + (list (let ((minibuffer-completing-symbol t)) + (read-from-minibuffer "Eval: " + nil read-expression-map t + 'read-expression-history)) + )) + + (if (null eval-expression-debug-on-error) + (setq values (cons (eval expr) values)) + (let ((old-value (make-symbol "t")) new-value) + ;; Bind debug-on-error to something unique so that we can + ;; detect when evaled code changes it. + (let ((debug-on-error old-value)) + (setq values (cons (eval expr) values)) + (setq new-value debug-on-error)) + ;; If evaled code has changed the value of debug-on-error, + ;; propagate that change to the global binding. + (unless (eq old-value new-value) + (setq debug-on-error new-value)))) + + (if (or (consp (car values)) (vectorp (car values))) + (let ((v (car values))) + (data-debug-show-stuff v "Expression")) + ;; Old style + (prog1 + (prin1 (car values) t) + (let ((str (eval-expression-print-format (car values)))) + (if str (princ str t)))))) + + +(provide 'data-debug) + +;;; data-debug.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/chart.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,755 @@ +;;; chart.el --- Draw charts (bar charts, etc) + +;;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, chart, graph + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This package is an experiment of mine aiding in the debugging of +;; eieio, and proved to be neat enough that others may like to use +;; it. To quickly see what you can do with chart, run the command +;; `chart-test-it-all'. +;; +;; Chart current can display bar-charts in either of two +;; directions. It also supports ranged (integer) axis, and axis +;; defined by some set of strings or names. These name can be +;; automatically derived from data sequences, which are just lists of +;; anything encapsulated in a nice eieio object. +;; +;; Current example apps for chart can be accessed via these commands: +;; `chart-file-count' - count files w/ matching extensions +;; `chart-space-usage' - display space used by files/directories +;; `chart-emacs-storage' - Emacs storage units used/free (garbage-collect) +;; `chart-emacs-lists' - length of Emacs lists +;; `chart-rmail-from' - who sends you the most mail (in -summary only) +;; +;; Customization: +;; +;; If you find the default colors and pixmaps unpleasant, or too +;; short, you can change them. The variable `chart-face-color-list' +;; contains a list of colors, and `chart-face-pixmap-list' contains +;; all the pixmaps to use. The current pixmaps are those found on +;; several systems I found. The two lists should be the same length, +;; as the long list will just be truncated. +;; +;; If you would like to draw your own stipples, simply create some +;; xbm's and put them in a directory, then you can add: +;; +;; (setq x-bitmap-file-path (cons "~/mybitmaps" x-bitmap-file-path)) +;; +;; to your .emacs (or wherever) and load the `chart-face-pixmap-list' +;; with all the bitmaps you want to use. + +(require 'eieio) + +;;; Code: +(defvar chart-map nil "Keymap used in chart mode.") +(if chart-map + () + (setq chart-map (make-sparse-keymap)) + ) + +(defvar chart-local-object nil + "Local variable containing the locally displayed chart object.") +(make-variable-buffer-local 'chart-local-object) + +(defvar chart-face-list nil + "Faces used to colorize charts. +List is limited currently, which is ok since you really can't display +too much in text characters anyways.") + +(defvar chart-face-color-list '("red" "green" "blue" + "cyan" "yellow" "purple") + "Colors to use when generating `chart-face-list'. +Colors will be the background color.") + +(defvar chart-face-pixmap-list + (if (and (fboundp 'display-graphic-p) + (display-graphic-p)) + '("dimple1" "scales" "dot" "cross_weave" "boxes" "dimple3")) + "If pixmaps are allowed, display these background pixmaps. +Useful if new Emacs is used on B&W display") + +(defcustom chart-face-use-pixmaps nil + "*Non-nil to use fancy pixmaps in the background of chart face colors." + :group 'eieio + :type 'boolean) + +(if (and (if (fboundp 'display-color-p) + (display-color-p) + window-system) + (not chart-face-list)) + (let ((cl chart-face-color-list) + (pl chart-face-pixmap-list) + nf) + (while cl + (setq nf (make-face (intern (concat "chart-" (car cl) "-" (car pl))))) + (if (condition-case nil + (> (x-display-color-cells) 4) + (error t)) + (set-face-background nf (car cl)) + (set-face-background nf "white")) + (set-face-foreground nf "black") + (if (and chart-face-use-pixmaps + pl + (fboundp 'set-face-background-pixmap)) + (condition-case nil + (set-face-background-pixmap nf (car pl)) + (error (message "Cannot set background pixmap %s" (car pl))))) + (setq chart-face-list (cons nf chart-face-list)) + (setq cl (cdr cl) + pl (cdr pl))))) + +(defun chart-mode () + "Define a mode in Emacs for displaying a chart." + (kill-all-local-variables) + (use-local-map chart-map) + (setq major-mode 'chart-mode + mode-name "CHART") + (buffer-disable-undo) + (set (make-local-variable 'font-lock-global-modes) nil) + (font-lock-mode -1) + (run-hooks 'chart-mode-hook) + ) + +(defun chart-new-buffer (obj) + "Create a new buffer NAME in which the chart OBJ is displayed. +Returns the newly created buffer" + (save-excursion + (set-buffer (get-buffer-create (format "*%s*" (oref obj title)))) + (chart-mode) + (setq chart-local-object obj) + (current-buffer))) + +(defclass chart () + ((title :initarg :title + :initform "Emacs Chart") + (title-face :initarg :title-face + :initform 'bold-italic) + (x-axis :initarg :x-axis + :initform nil ) + (x-margin :initarg :x-margin + :initform 5) + (x-width :initarg :x-width + ) + (y-axis :initarg :y-axis + :initform nil) + (y-margin :initarg :y-margin + :initform 5) + (y-width :initarg :y-width + ) + (key-label :initarg :key-label + :initform "Key") + (sequences :initarg :sequences + :initform nil) + ) + "Superclass for all charts to be displayed in an emacs buffer") + +(defmethod initialize-instance :AFTER ((obj chart) &rest fields) + "Initialize the chart OBJ being created with FIELDS. +Make sure the width/height is correct." + (oset obj x-width (- (window-width) 10)) + (oset obj y-width (- (window-height) 12))) + +(defclass chart-axis () + ((name :initarg :name + :initform "Generic Axis") + (loweredge :initarg :loweredge + :initform t) + (name-face :initarg :name-face + :initform 'bold) + (labels-face :initarg :lables-face + :initform 'italic) + (chart :initarg :chart + :initform nil) + ) + "Superclass used for display of an axis.") + +(defclass chart-axis-range (chart-axis) + ((bounds :initarg :bounds + :initform '(0.0 . 50.0)) + ) + "Class used to display an axis defined by a range of values") + +(defclass chart-axis-names (chart-axis) + ((items :initarg :items + :initform nil) + ) + "Class used to display an axis which represents different named items") + +(defclass chart-sequece () + ((data :initarg :data + :initform nil) + (name :initarg :name + :initform "Data") + ) + "Class used for all data in different charts") + +(defclass chart-bar (chart) + ((direction :initarg :direction + :initform vertical)) + "Subclass for bar charts. (Vertical or horizontal)") + +(defmethod chart-draw ((c chart) &optional buff) + "Start drawing a chart object C in optional BUFF. +Erases current contents of buffer" + (save-excursion + (if buff (set-buffer buff)) + (erase-buffer) + (insert (make-string 100 ?\n)) + ;; Start by displaying the axis + (chart-draw-axis c) + ;; Display title + (chart-draw-title c) + ;; Display data + (message "Rendering chart...") + (sit-for 0) + (chart-draw-data c) + ;; Display key + ; (chart-draw-key c) + (message "Rendering chart...done") + )) + +(defmethod chart-draw-title ((c chart)) + "Draw a title upon the chart. +Argument C is the chart object." + (chart-display-label (oref c title) 'horizontal 0 0 (window-width) + (oref c title-face))) + +(defmethod chart-size-in-dir ((c chart) dir) + "Return the physical size of chart C in direction DIR." + (if (eq dir 'vertical) + (oref c y-width) + (oref c x-width))) + +(defmethod chart-draw-axis ((c chart)) + "Draw axis into the current buffer defined by chart C." + (let ((ymarg (oref c y-margin)) + (xmarg (oref c x-margin)) + (ylen (oref c y-width)) + (xlen (oref c x-width))) + (chart-axis-draw (oref c y-axis) 'vertical ymarg + (if (oref (oref c y-axis) loweredge) nil xlen) + xmarg (+ xmarg ylen)) + (chart-axis-draw (oref c x-axis) 'horizontal xmarg + (if (oref (oref c x-axis) loweredge) nil ylen) + ymarg (+ ymarg xlen))) + ) + +(defmethod chart-axis-draw ((a chart-axis) &optional dir margin zone start end) + "Draw some axis for A in direction DIR at with MARGIN in boundry. +ZONE is a zone specification. +START and END represent the boundary." + (chart-draw-line dir (+ margin (if zone zone 0)) start end) + (chart-display-label (oref a name) dir (if zone (+ zone margin 3) + (if (eq dir 'horizontal) + 1 0)) + start end (oref a name-face))) + +(defmethod chart-translate-xpos ((c chart) x) + "Translate in chart C the coordinate X into a screen column." + (let ((range (oref (oref c x-axis) bounds))) + (+ (oref c x-margin) + (round (* (float (- x (car range))) + (/ (float (oref c x-width)) + (float (- (cdr range) (car range)))))))) + ) + +(defmethod chart-translate-ypos ((c chart) y) + "Translate in chart C the coordinate Y into a screen row." + (let ((range (oref (oref c y-axis) bounds))) + (+ (oref c x-margin) + (- (oref c y-width) + (round (* (float (- y (car range))) + (/ (float (oref c y-width)) + (float (- (cdr range) (car range))))))))) + ) + +(defmethod chart-axis-draw ((a chart-axis-range) &optional dir margin zone start end) + "Draw axis information based upon a range to be spread along the edge. +A is the chart to draw. DIR is the direction. +MARGIN, ZONE, START, and END specify restrictions in chart space." + (call-next-method) + ;; We prefer about 5 spaces between each value + (let* ((i (car (oref a bounds))) + (e (cdr (oref a bounds))) + (z (if zone zone 0)) + (s nil) + (rng (- e i)) + ;; want to jump by units of 5 spaces or so + (j (/ rng (/ (chart-size-in-dir (oref a chart) dir) 4))) + p1) + (if (= j 0) (setq j 1)) + (while (<= i e) + (setq s + (cond ((> i 999999) + (format "%dM" (/ i 1000000))) + ((> i 999) + (format "%dK" (/ i 1000))) + (t + (format "%d" i)))) + (if (eq dir 'vertical) + (let ((x (+ (+ margin z) (if (oref a loweredge) + (- (length s)) 1)))) + (if (< x 1) (setq x 1)) + (chart-goto-xy x (chart-translate-ypos (oref a chart) i))) + (chart-goto-xy (chart-translate-xpos (oref a chart) i) + (+ margin z (if (oref a loweredge) -1 1)))) + (setq p1 (point)) + (insert s) + (chart-zap-chars (length s)) + (put-text-property p1 (point) 'face (oref a labels-face)) + (setq i (+ i j)))) +) + +(defmethod chart-translate-namezone ((c chart) n) + "Return a dot-pair representing a positional range for a name. +The name in chart C of the Nth name resides. +Automatically compensates for for direction." + (let* ((dir (oref c direction)) + (w (if (eq dir 'vertical) (oref c x-width) (oref c y-width))) + (m (if (eq dir 'vertical) (oref c y-margin) (oref c x-margin))) + (ns (length + (oref (if (eq dir 'vertical) (oref c x-axis) (oref c y-axis)) + items))) + (lpn (/ (+ 1.0 (float w)) (float ns))) + ) + (cons (+ m (round (* lpn (float n)))) + (+ m -1 (round (* lpn (+ 1.0 (float n)))))) + )) + +(defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone start end) + "Draw axis information based upon A range to be spread along the edge. +Optional argument DIR the direction of the chart. +Optional argument MARGIN , ZONE, START and END specify boundaries of the drawing." + (call-next-method) + ;; We prefer about 5 spaces between each value + (let* ((i 0) + (s (oref a items)) + (z (if zone zone 0)) + (r nil) + (p nil) + (odd nil) + p1) + (while s + (setq odd (= (% (length s) 2) 1)) + (setq r (chart-translate-namezone (oref a chart) i)) + (if (eq dir 'vertical) + (setq p (/ (+ (car r) (cdr r)) 2)) + (setq p (- (+ (car r) (/ (- (cdr r) (car r)) 2)) + (/ (length (car s)) 2)))) + (if (eq dir 'vertical) + (let ((x (+ (+ margin z) (if (oref a loweredge) + (- (length (car s))) + (length (car s)))))) + (if (< x 1) (setq x 1)) + (if (> (length (car s)) (1- margin)) + (setq x (+ x margin))) + (chart-goto-xy x p)) + (chart-goto-xy p (+ (+ margin z) (if (oref a loweredge) + (if odd -2 -1) + (if odd 2 1))))) + (setq p1 (point)) + (insert (car s)) + (chart-zap-chars (length (car s))) + (put-text-property p1 (point) 'face (oref a labels-face)) + (setq i (+ i 1) + s (cdr s)))) +) + +(defmethod chart-draw-data ((c chart-bar)) + "Display the data available in a bar chart C." + (let* ((data (oref c sequences)) + (dir (oref c direction)) + (odir (if (eq dir 'vertical) 'horizontal 'vertical)) + ) + (while data + (if (stringp (car (oref (car data) data))) + ;; skip string lists... + nil + ;; display number lists... + (let ((i 0) + (seq (oref (car data) data))) + (while seq + (let* ((rng (chart-translate-namezone c i)) + (dp (if (eq dir 'vertical) + (chart-translate-ypos c (car seq)) + (chart-translate-xpos c (car seq)))) + (zp (if (eq dir 'vertical) + (chart-translate-ypos c 0) + (chart-translate-xpos c 0))) + (fc (if chart-face-list + (nth (% i (length chart-face-list)) chart-face-list) + 'default)) + ) + (if (< dp zp) + (progn + (chart-draw-line dir (car rng) dp zp) + (chart-draw-line dir (cdr rng) dp zp)) + (chart-draw-line dir (car rng) zp (1+ dp)) + (chart-draw-line dir (cdr rng) zp (1+ dp))) + (if (= (car rng) (cdr rng)) nil + (chart-draw-line odir dp (1+ (car rng)) (cdr rng)) + (chart-draw-line odir zp (car rng) (1+ (cdr rng)))) + (if (< dp zp) + (chart-deface-rectangle dir rng (cons dp zp) fc) + (chart-deface-rectangle dir rng (cons zp dp) fc)) + ) + ;; find the bounds, and chart it! + ;; for now, only do one! + (setq i (1+ i) + seq (cdr seq))))) + (setq data (cdr data)))) + ) + +(defmethod chart-add-sequence ((c chart) &optional seq axis-label) + "Add to chart object C the sequence object SEQ. +If AXIS-LABEL, then the axis stored in C is updated with the bounds of SEQ, +or is created with the bounds of SEQ." + (if axis-label + (let ((axis (eieio-oref c axis-label))) + (if (stringp (car (oref seq data))) + (let ((labels (oref seq data))) + (if (not axis) + (setq axis (make-instance chart-axis-names + :name (oref seq name) + :items labels + :chart c)) + (oset axis items labels))) + (let ((range (cons 0 1)) + (l (oref seq data))) + (if (not axis) + (setq axis (make-instance chart-axis-range + :name (oref seq name) + :chart c))) + (while l + (if (< (car l) (car range)) (setcar range (car l))) + (if (> (car l) (cdr range)) (setcdr range (car l))) + (setq l (cdr l))) + (oset axis bounds range))) + (if (eq axis-label 'x-axis) (oset axis loweredge nil)) + (eieio-oset c axis-label axis) + )) + (oset c sequences (append (oref c sequences) (list seq)))) + +;;; Charting optimizers + +(defmethod chart-trim ((c chart) max) + "Trim all sequences in chart C to be at most MAX elements long." + (let ((s (oref c sequences))) + (while s + (let ((sl (oref (car s) data))) + (if (> (length sl) max) + (setcdr (nthcdr (1- max) sl) nil))) + (setq s (cdr s)))) + ) + +(defmethod chart-sort ((c chart) pred) + "Sort the data in chart C using predicate PRED. +See `chart-sort-matchlist' for more details" + (let* ((sl (oref c sequences)) + (s1 (car sl)) + (s2 (car (cdr sl))) + (s nil)) + (if (stringp (car (oref s1 data))) + (progn + (chart-sort-matchlist s1 s2 pred) + (setq s (oref s1 data))) + (if (stringp (car (oref s2 data))) + (progn + (chart-sort-matchlist s2 s1 pred) + (setq s (oref s2 data))) + (error "Sorting of chart %s not supported" (object-name c)))) + (if (eq (oref c direction) 'horizontal) + (oset (oref c y-axis) items s) + (oset (oref c x-axis) items s) + )) + ) + +(defun chart-sort-matchlist (namelst numlst pred) + "Sort NAMELST and NUMLST (both SEQUENCE objects) based on predicate PRED. +PRED should be the equivalent of '<, except it must expect two +cons cells of the form (NAME . NUM). See SORT for more details." + ;; 1 - create 1 list of cons cells + (let ((newlist nil) + (alst (oref namelst data)) + (ulst (oref numlst data))) + (while alst + ;; this is reversed, but were are sorting anyway + (setq newlist (cons (cons (car alst) (car ulst)) newlist)) + (setq alst (cdr alst) + ulst (cdr ulst))) + ;; 2 - Run sort routine on it + (setq newlist (sort newlist pred) + alst nil + ulst nil) + ;; 3 - Separate the lists + (while newlist + (setq alst (cons (car (car newlist)) alst) + ulst (cons (cdr (car newlist)) ulst)) + (setq newlist (cdr newlist))) + ;; 4 - Store them back + (oset namelst data (reverse alst)) + (oset numlst data (reverse ulst)))) + +;;; Utilities + +(defun chart-goto-xy (x y) + "Move cursor to position X Y in buffer, and add spaces and CRs if needed." + + (let ((indent-tabs-mode nil) + (num (goto-line (1+ y)))) + (if (and (= 0 num) (/= 0 (current-column))) (newline 1)) + (if (eobp) (newline num)) + (if (< x 0) (setq x 0)) + (if (< y 0) (setq y 0)) + ;; Now, a quicky column moveto/forceto method. + (or (= (move-to-column x) x) + (let ((p (point))) + (indent-to x) + (remove-text-properties p (point) '(face)))))) + +(defun chart-zap-chars (n) + "Zap up to N chars without deleteting EOLs." + (if (not (eobp)) + (if (< n (- (save-excursion (end-of-line) (point)) (point))) + (delete-char n) + (delete-region (point) (save-excursion (end-of-line) (point)))))) + +(defun chart-display-label (label dir zone start end &optional face) + "Display LABEL in direction DIR in column/row ZONE between START and END. +Optional argument FACE is the property we wish to place on this text." + (if (eq dir 'horizontal) + (let (p1) + (chart-goto-xy (+ start (- (/ (- end start) 2) (/ (length label) 2))) + zone) + (setq p1 (point)) + (insert label) + (chart-zap-chars (length label)) + (put-text-property p1 (point) 'face face) + ) + (let ((i 0) + (stz (+ start (- (/ (- end start) 2) (/ (length label) 2))))) + (while (< i (length label)) + (chart-goto-xy zone (+ stz i)) + (insert (aref label i)) + (chart-zap-chars 1) + (put-text-property (1- (point)) (point) 'face face) + (setq i (1+ i)))))) + +(defun chart-draw-line (dir zone start end) + "Draw a line using line-drawing characters in direction DIR. +Use column or row ZONE between START and END" + (chart-display-label + (make-string (- end start) (if (eq dir 'vertical) ?| ?\-)) + dir zone start end)) + +(defun chart-deface-rectangle (dir r1 r2 face) + "Colorize a rectangle in direction DIR across range R1 by range R2. +R1 and R2 are dotted pairs. Colorize it with FACE." + (let* ((range1 (if (eq dir 'vertical) r1 r2)) + (range2 (if (eq dir 'vertical) r2 r1)) + (y (car range2))) + (while (<= y (cdr range2)) + (chart-goto-xy (car range1) y) + (put-text-property (point) (+ (point) (1+ (- (cdr range1) (car range1)))) + 'face face) + (setq y (1+ y))))) + +;;; Helpful `I don't want to learn eieio just now' washover functions + +(defun chart-bar-quickie (dir title namelst nametitle numlst numtitle + &optional max sort-pred) + "Wash over the complex eieio stuff and create a nice bar chart. +Creat it going in direction DIR ['horizontal 'vertical] with TITLE +using a name sequence NAMELST labeled NAMETITLE with values NUMLST +labeled NUMTITLE. +Optional arguments: +Set the charts' max element display to MAX, and sort lists with +SORT-PRED if desired." + (let ((nc (make-instance chart-bar + :title title + :key-label "8-m" ; This is a text key pic + :direction dir + )) + (iv (eq dir 'vertical))) + (chart-add-sequence nc + (make-instance chart-sequece + :data namelst + :name nametitle) + (if iv 'x-axis 'y-axis)) + (chart-add-sequence nc + (make-instance chart-sequece + :data numlst + :name numtitle) + (if iv 'y-axis 'x-axis)) + (if sort-pred (chart-sort nc sort-pred)) + (if (integerp max) (chart-trim nc max)) + (switch-to-buffer (chart-new-buffer nc)) + (chart-draw nc))) + +;;; Test code + +(defun chart-test-it-all () + "Test out various charting features." + (interactive) + (chart-bar-quickie 'vertical "Test Bar Chart" + '( "U1" "ME2" "C3" "B4" "QT" "EZ") "Items" + '( 5 -10 23 20 30 -3) "Values") + ) + +;;; Sample utility function + +(defun chart-file-count (dir) + "Draw a chart displaying the number of different file extentions in DIR." + (interactive "DDirectory: ") + (if (not (string-match "/$" dir)) + (setq dir (concat dir "/"))) + (message "Collecting statistics...") + (let ((flst (directory-files dir nil nil t)) + (extlst (list "<dir>")) + (cntlst (list 0))) + (while flst + (let* ((j (string-match "[^\\.]\\(\\.[a-zA-Z]+\\|~\\|#\\)$" (car flst))) + (s (if (file-accessible-directory-p (concat dir (car flst))) + "<dir>" + (if j + (substring (car flst) (match-beginning 1) (match-end 1)) + nil))) + (m (member s extlst))) + (if (not s) nil + (if m + (let ((cell (nthcdr (- (length extlst) (length m)) cntlst))) + (setcar cell (1+ (car cell)))) + (setq extlst (cons s extlst) + cntlst (cons 1 cntlst))))) + (setq flst (cdr flst))) + ;; Lets create the chart! + (chart-bar-quickie 'vertical "Files Extension Distribution" + extlst "File Extensions" + cntlst "# of occurances" + 10 + '(lambda (a b) (> (cdr a) (cdr b)))) + )) + +(defun chart-space-usage (d) + "Display a top usage chart for directory D." + (interactive "DDirectory: ") + (message "Collecting statistics...") + (let ((nmlst nil) + (cntlst nil) + (b (get-buffer-create " *du-tmp*"))) + (set-buffer b) + (erase-buffer) + (insert "cd " d ";du -sk * \n") + (message "Running `cd %s;du -sk *'..." d) + (call-process-region (point-min) (point-max) shell-file-name t + (current-buffer) nil) + (goto-char (point-min)) + (message "Scanning output ...") + (while (re-search-forward "^\\([0-9]+\\)[ \t]+\\([^ \n]+\\)$" nil t) + (let* ((nam (buffer-substring (match-beginning 2) (match-end 2))) + (num (buffer-substring (match-beginning 1) (match-end 1)))) + (setq nmlst (cons nam nmlst) + ;; * 1000 to put it into bytes + cntlst (cons (* (string-to-number num) 1000) cntlst)))) + (if (not nmlst) + (error "No files found!")) + (chart-bar-quickie 'vertical (format "Largest files in %s" d) + nmlst "File Name" + cntlst "File Size" + 10 + '(lambda (a b) (> (cdr a) (cdr b)))) + )) + +(defun chart-emacs-storage () + "Chart the current storage requirements of Emacs." + (interactive) + (let* ((data (garbage-collect)) + (names '("strings/2" "vectors" + "conses" "free cons" + "syms" "free syms" + "markers" "free mark" + ;; "floats" "free flt" + )) + (nums (list (/ (nth 3 data) 2) + (nth 4 data) + (car (car data)) ; conses + (cdr (car data)) + (car (nth 1 data)) ; syms + (cdr (nth 1 data)) + (car (nth 2 data)) ; markers + (cdr (nth 2 data)) + ;(car (nth 5 data)) ; floats are Emacs only + ;(cdr (nth 5 data)) + ))) + ;; Lets create the chart! + (chart-bar-quickie 'vertical "Emacs Runtime Storage Usage" + names "Storage Items" + nums "Objects"))) + +(defun chart-emacs-lists () + "Chart out the size of various important lists." + (interactive) + (let* ((names '("buffers" "frames" "processes" "faces")) + (nums (list (length (buffer-list)) + (length (frame-list)) + (length (process-list)) + (length (face-list)) + ))) + (if (fboundp 'x-display-list) + (setq names (append names '("x-displays")) + nums (append nums (list (length (x-display-list)))))) + ;; Lets create the chart! + (chart-bar-quickie 'vertical "Emacs List Size Chart" + names "Various Lists" + nums "Objects"))) + +(defun chart-rmail-from () + "If we are in an rmail summary buffer, then chart out the froms." + (interactive) + (if (not (eq major-mode 'rmail-summary-mode)) + (error "You must invoke chart-rmail-from in an rmail summary buffer")) + (let ((nmlst nil) + (cntlst nil)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\\-[A-Z][a-z][a-z] +\\(\\w+\\)@\\w+" nil t) + (let* ((nam (buffer-substring (match-beginning 1) (match-end 1))) + (m (member nam nmlst))) + (message "Scanned username %s" nam) + (if m + (let ((cell (nthcdr (- (length nmlst) (length m)) cntlst))) + (setcar cell (1+ (car cell)))) + (setq nmlst (cons nam nmlst) + cntlst (cons 1 cntlst)))))) + (chart-bar-quickie 'vertical "Username Occurance in RMAIL box" + nmlst "User Names" + cntlst "# of occurances" + 10 + '(lambda (a b) (> (cdr a) (cdr b)))) + )) + + +(provide 'chart) + +;;; chart.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio-base.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,328 @@ +;;; eieio-base.el --- Base classes for EIEIO. + +;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Base classes for EIEIO. These classes perform some basic tasks +;; but are generally useless on their own. To use any of these classes, +;; inherit from one or more of them. + +;;; Code: + +(require 'eieio) + +;;; eieio-instance-inheritor +;; +;; Enable instance inheritance via the `clone' method. +;; Works by using the `slot-unbound' method which usually throws an +;; error if a slot is unbound. +(defclass eieio-instance-inheritor () + ((parent-instance :initarg :parent-instance + :type eieio-instance-inheritor-child + :documentation + "The parent of this instance. +If a slot of this class is reference, and is unbound, then the parent +is checked for a value.") + ) + "This special class can enable instance inheritance. +Use `clone' to make a new object that does instance inheritance from +a parent instance. When a slot in the child is referenced, and has +not been set, use values from the parent." + :abstract t) + +(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn) + "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. +SLOT-NAME, is the offending slot. FN is the function signalling the error." + (if (slot-boundp object 'parent-instance) + ;; It may not look like it, but this line recurses back into this + ;; method if the parent instance's slot is unbound. + (eieio-oref (oref object parent-instance) slot-name) + ;; Throw the regular signal. + (call-next-method))) + +(defmethod clone ((obj eieio-instance-inheritor) &rest params) + "Clone OBJ, initializing `:parent' to OBJ. +All slots are unbound, except those initialized with PARAMS." + (let ((nobj (make-vector (length obj) eieio-unbound)) + (nm (aref obj object-name)) + (passname (and params (stringp (car params)))) + (num 1)) + (aset nobj 0 'object) + (aset nobj object-class (aref obj object-class)) + ;; The following was copied from the default clone. + (if (not passname) + (save-match-data + (if (string-match "-\\([0-9]+\\)" nm) + (setq num (1+ (string-to-number (match-string 1 nm))) + nm (substring nm 0 (match-beginning 0)))) + (aset nobj object-name (concat nm "-" (int-to-string num)))) + (aset nobj object-name (car params))) + ;; Now initialize from params. + (if params (shared-initialize nobj (if passname (cdr params) params))) + (oset nobj parent-instance obj) + nobj)) + +(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) + slot) + "Non-nil if the instance inheritor OBJECT's SLOT is bound. +See `slot-boundp' for for details on binding slots. +The instance inheritor uses unbound slots as a way cascading cloned +slot values, so testing for a slot being bound requires extra steps +for this kind of object." + (if (slot-boundp object slot) + ;; If it is regularly bound, return t. + t + (if (slot-boundp object 'parent-instance) + (eieio-instance-inheritor-slot-boundp (oref object parent-instance) + slot) + nil))) + + +;;; eieio-instance-tracker +;; +;; Track all created instances of this class. +;; The class must initialize the `tracking-symbol' slot, and that +;; symbol is then used to contain these objects. +(defclass eieio-instance-tracker () + ((tracking-symbol :type symbol + :allocation :class + :documentation + "The symbol used to maintain a list of our instances. +The instance list is treated as a variable, with new instances added to it.") + ) + "This special class enables instance tracking. +Inheritors from this class must overload `tracking-symbol' which is +a variable symbol used to store a list of all instances." + :abstract t) + +(defmethod initialize-instance :AFTER ((this eieio-instance-tracker) + &rest slots) + "Make sure THIS is in our master list of this class. +Optional argument SLOTS are the initialization arguments." + ;; Theoretically, this is never called twice for a given instance. + (let ((sym (oref this tracking-symbol))) + (if (not (memq this (symbol-value sym))) + (set sym (append (symbol-value sym) (list this)))))) + +(defmethod delete-instance ((this eieio-instance-tracker)) + "Remove THIS from the master list of this class." + (set (oref this tracking-symbol) + (delq this (symbol-value (oref this tracking-symbol))))) + +;; In retrospect, this is a silly function. +(defun eieio-instance-tracker-find (key slot list-symbol) + "Find KEY as an element of SLOT in the objects in LIST-SYMBOL. +Returns the first match." + (object-assoc key slot (symbol-value list-symbol))) + +;;; eieio-singleton +;; +;; The singleton Design Pattern specifies that there is but one object +;; of a given class ever created. The EIEIO singleton base class defines +;; a CLASS allocated slot which contains the instance used. All calls to +;; `make-instance' will either create a new instance and store it in this +;; slot, or it will just return what is there. +(defclass eieio-singleton () + ((singleton :type eieio-singleton + :allocation :class + :documentation + "The only instance of this class that will be instantiated. +Multiple calls to `make-instance' will return this object.")) + "This special class causes subclasses to be singletons. +A singleton is a class which will only ever have one instace." + :abstract t) + +(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots) + "Constructor for singleton CLASS. +NAME and SLOTS initialize the new object. +This constructor guarantees that no matter how many you request, +only one object ever exists." + ;; NOTE TO SELF: In next version, make `slot-boundp' support classes + ;; with class allocated slots or default values. + (let ((old (oref-default class singleton))) + (if (eq old eieio-unbound) + (oset-default class singleton (call-next-method)) + old))) + + +;;; eieio-persistent +;; +;; For objects which must save themselves to disk. Provides an +;; `object-write' method to save an object to disk, and a +;; `eieio-persistent-read' function to call to read an object +;; from disk. +;; +;; Also provide the method `eieio-persistent-path-relative' to +;; calculate path names relative to a given instance. This will +;; make the saved object location independent by converting all file +;; references to be relative to the directory the object is saved to. +;; You must call `eieio-peristent-path-relative' on each file name +;; saved in your object. +(defclass eieio-persistent () + ((file :initarg :file + :type string + :documentation + "The save file for this persistent object. +This must be a string, and must be specified when the new object is +instantiated.") + (extension :type string + :allocation :class + :initform ".eieio" + :documentation + "Extension of files saved by this object. +Enables auto-choosing nice file names based on name.") + (file-header-line :type string + :allocation :class + :initform ";; EIEIO PERSISTENT OBJECT" + :documentation + "Header line for the save file. +This is used with the `object-write' method.") + (do-backups :type boolean + :allocation :class + :initform t + :documentation + "Saving this object should make backup files. +Setting to nil will mean no backups are made.")) + "This special class enables persistence through save files +Use the `object-save' method to write this object to disk. The save +format is Emacs Lisp code which calls the constructor for the saved +object. For this reason, only slots which do not have an `:initarg' +specified will not be saved." + :abstract t) + +(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt + &optional name) + "Perpare to save THIS. Use in an `interactive' statement. +Query user for file name with PROMPT if THIS does not yet specify +a file. Optional argument NAME specifies a default file name." + (unless (slot-boundp this 'file) + (oset this file + (read-file-name prompt nil + (if name + (concat name (oref this extension)) + )))) + (oref this file)) + +(defun eieio-persistent-read (filename) + "Read a persistent object from FILENAME, and return it." + (let ((ret nil) + (buffstr nil)) + (unwind-protect + (progn + (save-excursion + (set-buffer (get-buffer-create " *tmp eieio read*")) + (insert-file-contents filename nil nil nil t) + (goto-char (point-min)) + (setq buffstr (buffer-string))) + ;; Do the read in the buffer the read was initialized from + ;; so that any initialize-instance calls that depend on + ;; the current buffer will work. + (setq ret (read buffstr)) + (if (not (child-of-class-p (car ret) 'eieio-persistent)) + (error "Corrupt object on disk")) + (setq ret (eval ret)) + (oset ret file filename)) + (kill-buffer " *tmp eieio read*")) + ret)) + +(defmethod object-write ((this eieio-persistent) &optional comment) + "Write persistent object THIS out to the current stream. +Optional argument COMMENT is a header line comment." + (call-next-method this (or comment (oref this file-header-line)))) + +(defmethod eieio-persistent-path-relative ((this eieio-persistent) file) + "For object THIS, make absolute file name FILE relative." + (file-relative-name (expand-file-name file) + (file-name-directory (oref this file)))) + +(defmethod eieio-persistent-save ((this eieio-persistent) &optional file) + "Save persistent object THIS to disk. +Optional argument FILE overrides the file name specified in the object +instance." + (save-excursion + (let ((b (set-buffer (get-buffer-create " *tmp object write*"))) + (default-directory (file-name-directory (oref this file))) + (cfn (oref this file))) + (unwind-protect + (save-excursion + (erase-buffer) + (let ((standard-output (current-buffer))) + (oset this file + (if file + (eieio-persistent-path-relative this file) + (file-name-nondirectory cfn))) + (object-write this (oref this file-header-line))) + (let ((backup-inhibited (not (oref this do-backups)))) + ;; Old way - write file. Leaves message behind. + ;;(write-file cfn nil) + + ;; New way - Avoid the vast quantities of error checking + ;; just so I can get at the special flags that disable + ;; displaying random messages. + (write-region (point-min) (point-max) + cfn nil 1) + )) + ;; Restore :file, and kill the tmp buffer + (oset this file cfn) + (setq buffer-file-name nil) + (kill-buffer b))))) + +;; Notes on the persistent object: +;; It should also set up some hooks to help it keep itself up to date. + + +;;; Named object +;; +;; Named objects use the objects `name' as a slot, and that slot +;; is accessed with the `object-name' symbol. + +(defclass eieio-named () + () + "Object with a name. +Name storage already occurs in an object. This object provides get/set +access to it." + :abstract t) + +(defmethod slot-missing ((obj eieio-named) + slot-name operation &optional new-value) + "Called when a on-existant slot is accessed. +For variable `eieio-named', provide an imaginary `object-name' slot. +Argument OBJ is the Named object. +Argument SLOT-NAME is the slot that was attempted to be accessed. +OPERATION is the type of access, such as `oref' or `oset'. +NEW-VALUE is the value that was being set into SLOT if OPERATION were +a set type." + (if (or (eq slot-name 'object-name) + (eq slot-name :object-name)) + (cond ((eq operation 'oset) + (if (not (stringp new-value)) + (signal 'invalid-slot-type + (list obj slot-name 'string new-value))) + (object-set-name-string obj new-value)) + (t (object-name-string obj))) + (call-next-method))) + +(provide 'eieio-base) + +;;; eieio-base.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio-comp.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,126 @@ +;;; eieio-comp.el -- eieio routines to help with byte compilation + +;;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005, 2008, +;;; 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: oop, lisp, tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Byte compiler functions for defmethod. This will affect the new GNU +;; byte compiler for Emacs 19 and better. This function will be called by +;; the byte compiler whenever a `defmethod' is encountered in a file. +;; It will output a function call to `eieio-defmethod' with the byte +;; compiled function as a parameter. + +;;; Code: + +;; This teaches the byte compiler how to do this sort of thing. +(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) + +(defun byte-compile-file-form-defmethod (form) + "Mumble about the method we are compiling. +This function is mostly ripped from `byte-compile-file-form-defun', but +it's been modified to handle the special syntax of the defmethod +command. There should probably be one for defgeneric as well, but +that is called but rarely. Argument FORM is the body of the method." + (setq form (cdr form)) + (let* ((meth (car form)) + (key (progn (setq form (cdr form)) + (cond ((or (eq ':BEFORE (car form)) + (eq ':before (car form))) + (setq form (cdr form)) + ":before ") + ((or (eq ':AFTER (car form)) + (eq ':after (car form))) + (setq form (cdr form)) + ":after ") + ((or (eq ':PRIMARY (car form)) + (eq ':primary (car form))) + (setq form (cdr form)) + ":primary ") + ((or (eq ':STATIC (car form)) + (eq ':static (car form))) + (setq form (cdr form)) + ":static ") + (t "")))) + (params (car form)) + (lamparams (byte-compile-defmethod-param-convert params)) + (arg1 (car params)) + (class (if (listp arg1) (nth 1 arg1) nil)) + (my-outbuffer (if (eval-when-compile + (string-match "XEmacs" emacs-version)) + byte-compile-outbuffer + (condition-case nil + bytecomp-outbuffer + (error outbuffer)))) + ) + (let ((name (format "%s::%s" (or class "#<generic>") meth))) + (if byte-compile-verbose + ;; #### filename used free + (message "Compiling %s... (%s)" (or filename "") name)) + (setq byte-compile-current-form name) ; for warnings + ) + ;; Flush any pending output + (byte-compile-flush-pending) + ;; Byte compile the body. For the byte compiled forms, add the + ;; rest arguments, which will get ignored by the engine which will + ;; add them later (I hope) + (let* ((new-one (byte-compile-lambda + (append (list 'lambda lamparams) + (cdr form)))) + (code (byte-compile-byte-code-maker new-one))) + (princ "\n(eieio-defmethod '" my-outbuffer) + (princ meth my-outbuffer) + (princ " '(" my-outbuffer) + (princ key my-outbuffer) + (prin1 params my-outbuffer) + (princ " " my-outbuffer) + (prin1 code my-outbuffer) + (princ "))" my-outbuffer)) + ;; Now add this function to the list of known functions. + ;; Don't bother with a doc string. Not relevant here. + (add-to-list 'byte-compile-function-environment + (cons meth + (eieio-defgeneric-form meth ""))) + + ;; Remove it from the undefined list if it is there. + (let ((elt (assq meth byte-compile-unresolved-functions))) + (if elt (setq byte-compile-unresolved-functions + (delq elt byte-compile-unresolved-functions)))) + + ;; nil prevents cruft from appearing in the output buffer. + nil)) + +(defun byte-compile-defmethod-param-convert (paramlist) + "Convert method params into the params used by the defmethod thingy. +Argument PARAMLIST is the paramter list to convert." + (let ((argfix nil)) + (while paramlist + (setq argfix (cons (if (listp (car paramlist)) + (car (car paramlist)) + (car paramlist)) + argfix)) + (setq paramlist (cdr paramlist))) + (nreverse argfix))) + +(provide 'eieio-comp) + +;;; eieio-comp.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio-custom.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,471 @@ +;;; eieio-custom.el -- eieio object customization + +;;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This contains support customization of eieio objects. Enabling +;; your object to be customizable requires use of the slot attirbute +;; `:custom'. + +(require 'eieio) +(require 'widget) +(require 'wid-edit) +(require 'custom) + +;;; Compatibility +;; +(eval-and-compile + (if (featurep 'xemacs) + (defalias 'eieio-overlay-lists (lambda () (list (extent-list)))) + (defalias 'eieio-overlay-lists 'overlay-lists) + ) + ) +;;; Code: +(defclass eieio-widget-test-class nil + ((a-string :initarg :a-string + :initform "The moose is loose" + :custom string + :label "Amorphous String" + :group (default foo) + :documentation "A string for testing custom. +This is the next line of documentation.") + (listostuff :initarg :listostuff + :initform ("1" "2" "3") + :type list + :custom (repeat (string :tag "Stuff")) + :label "List of Strings" + :group foo + :documentation "A list of stuff.") + (uninitialized :initarg :uninitialized + :type string + :custom string + :documentation "This slot is not initialized. +Used to make sure that custom doesn't barf when it encounters one +of these.") + (a-number :initarg :a-number + :initform 2 + :custom integer + :documentation "A number of thingies.")) + "A class for testing the widget on.") + +(defcustom eieio-widget-test (eieio-widget-test-class "Foo") + "Test variable for editing an object." + :type 'object + :group 'eieio) + +(defface eieio-custom-slot-tag-face '((((class color) + (background dark)) + (:foreground "light blue")) + (((class color) + (background light)) + (:foreground "blue")) + (t (:italic t))) + "Face used for unpushable variable tags." + :group 'custom-faces) + +(defvar eieio-wo nil + "Buffer local variable in object customize buffers for the current widget.") +(defvar eieio-co nil + "Buffer local variable in object customize buffers for the current obj.") +(defvar eieio-cog nil + "Buffer local variable in object customize buffers for the current group.") + + (defvar eieio-custom-ignore-eieio-co nil + "When true, all customizable slots of the current object are updated. +Updates occur regardless of the current customization group.") + +(define-widget 'object-slot 'group + "Abstractly modify a single slot in an object." + :tag "Slot" + :format "%t %v%h\n" + :convert-widget 'widget-types-convert-widget + :value-create 'eieio-slot-value-create + :value-get 'eieio-slot-value-get + :value-delete 'widget-children-value-delete + :validate 'widget-children-validate + :match 'eieio-object-match ;; same + ) + +(defun eieio-slot-value-create (widget) + "Create the value of WIDGET." + (let ((chil nil) + ) +; (setq chil (cons (widget-create-child-and-convert +; widget 'visibility +; :help-echo "Hide the value of this option." +; :action 'eieio-custom-toggle-parent +; t) +; chil)) + (setq chil (cons + (widget-create-child-and-convert + widget (widget-get widget :childtype) + :tag "" + :value (widget-get widget :value)) + chil)) + (widget-put widget :children chil))) + +(defun eieio-slot-value-get (widget) + "Get the value of WIDGET." + (widget-value (car (widget-get widget :children)))) + +(defun eieio-custom-toggle-hide (widget) + "Toggle visibility of WIDGET." + (let ((vc (car (widget-get widget :children)))) + (cond ((eq (widget-get vc :eieio-custom-state) 'hidden) + (widget-put vc :eieio-custom-state 'visible) + (widget-put vc :value-face (widget-get vc :orig-face))) + (t + (widget-put vc :eieio-custom-state 'hidden) + (widget-put vc :orig-face (widget-get vc :value-face)) + (widget-put vc :value-face 'invisible) + )) + (widget-value-set vc (widget-value vc)))) + +(defun eieio-custom-toggle-parent (widget &rest ignore) + "Toggle visibility of parent of WIDGET. +Optional argument IGNORE is an extraneous parameter." + (eieio-custom-toggle-hide (widget-get widget :parent))) + +(define-widget 'object-edit 'group + "Abstractly modify a CLOS object." + :tag "Object" + :format "%v" + :convert-widget 'widget-types-convert-widget + :value-create 'eieio-object-value-create + :value-get 'eieio-object-value-get + :value-delete 'widget-children-value-delete + :validate 'widget-children-validate + :match 'eieio-object-match + :clone-object-children nil + ) + +(defun eieio-object-match (widget value) + "Match info for WIDGET against VALUE." + ;; Write me + t) + +(defun eieio-filter-slot-type (widget slottype) + "Filter WIDGETs SLOTTYPE." + (if (widget-get widget :clone-object-children) + slottype + (cond ((eq slottype 'object) + 'object-edit) + ((and (listp slottype) + (eq (car slottype) 'object)) + (cons 'object-edit (cdr slottype))) + ((equal slottype '(repeat object)) + '(repeat object-edit)) + ((and (listp slottype) + (equal (car slottype) 'repeat) + (listp (car (cdr slottype))) + (equal (car (car (cdr slottype))) 'object)) + (list 'repeat + (cons 'object-edit + (cdr (car (cdr slottype)))))) + (t slottype)))) + +(defun eieio-object-value-create (widget) + "Create the value of WIDGET." + (if (not (widget-get widget :value)) + (widget-put widget + :value (cond ((widget-get widget :objecttype) + (funcall (class-constructor + (widget-get widget :objecttype)) + "Custom-new")) + ((widget-get widget :objectcreatefcn) + (funcall (widget-get widget :objectcreatefcn))) + (t (error "No create method specified"))))) + (let* ((chil nil) + (obj (widget-get widget :value)) + (master-group (widget-get widget :eieio-group)) + (cv (class-v (object-class-fast obj))) + (slots (aref cv class-public-a)) + (flabel (aref cv class-public-custom-label)) + (fgroup (aref cv class-public-custom-group)) + (fdoc (aref cv class-public-doc)) + (fcust (aref cv class-public-custom))) + ;; First line describes the object, but may not editable. + (if (widget-get widget :eieio-show-name) + (setq chil (cons (widget-create-child-and-convert + widget 'string :tag "Object " + :sample-face 'bold + (object-name-string obj)) + chil))) + ;; Display information about the group being shown + (when master-group + (let ((groups (class-option (object-class-fast obj) :custom-groups))) + (widget-insert "Groups:") + (while groups + (widget-insert " ") + (if (eq (car groups) master-group) + (widget-insert "*" (capitalize (symbol-name master-group)) "*") + (widget-create 'push-button + :thing (cons obj (car groups)) + :notify (lambda (widget &rest stuff) + (eieio-customize-object + (car (widget-get widget :thing)) + (cdr (widget-get widget :thing)))) + (capitalize (symbol-name (car groups))))) + (setq groups (cdr groups))) + (widget-insert "\n\n"))) + ;; Loop over all the slots, creating child widgets. + (while slots + ;; Output this slot if it has a customize flag associated with it. + (when (and (car fcust) + (or (not master-group) (member master-group (car fgroup))) + (slot-boundp obj (car slots))) + ;; In this case, this slot has a custom type. Create it's + ;; children widgets. + (let ((type (eieio-filter-slot-type widget (car fcust))) + (stuff nil)) + ;; This next bit is an evil hack to get some EDE functions + ;; working the way I like. + (if (and (listp type) + (setq stuff (member :slotofchoices type))) + (let ((choices (eieio-oref obj (car (cdr stuff)))) + (newtype nil)) + (while (not (eq (car type) :slotofchoices)) + (setq newtype (cons (car type) newtype) + type (cdr type))) + (while choices + (setq newtype (cons (list 'const (car choices)) + newtype) + choices (cdr choices))) + (setq type (nreverse newtype)))) + (setq chil (cons (widget-create-child-and-convert + widget 'object-slot + :childtype type + :sample-face 'eieio-custom-slot-tag-face + :tag + (concat + (make-string + (or (widget-get widget :indent) 0) + ? ) + (if (car flabel) + (car flabel) + (let ((s (symbol-name + (or + (class-slot-initarg + (object-class-fast obj) + (car slots)) + (car slots))))) + (capitalize + (if (string-match "^:" s) + (substring s (match-end 0)) + s))))) + :value (slot-value obj (car slots)) + :doc (if (car fdoc) (car fdoc) + "Slot not Documented.") + :eieio-custom-visibility 'visible + ) + chil)) + ) + ) + (setq slots (cdr slots) + fdoc (cdr fdoc) + fcust (cdr fcust) + flabel (cdr flabel) + fgroup (cdr fgroup))) + (widget-put widget :children (nreverse chil)) + )) + +(defun eieio-object-value-get (widget) + "Get the value of WIDGET." + (let* ((obj (widget-get widget :value)) + (master-group eieio-cog) + (cv (class-v (object-class-fast obj))) + (fgroup (aref cv class-public-custom-group)) + (wids (widget-get widget :children)) + (name (if (widget-get widget :eieio-show-name) + (car (widget-apply (car wids) :value-inline)) + nil)) + (chil (if (widget-get widget :eieio-show-name) + (nthcdr 1 wids) wids)) + (cv (class-v (object-class-fast obj))) + (slots (aref cv class-public-a)) + (fcust (aref cv class-public-custom))) + ;; If there are any prefix widgets, clear them. + ;; -- None yet + ;; Create a batch of initargs for each slot. + (while (and slots chil) + (if (and (car fcust) + (or eieio-custom-ignore-eieio-co + (not master-group) (member master-group (car fgroup))) + (slot-boundp obj (car slots))) + (progn + ;; Only customized slots have widgets + (let ((eieio-custom-ignore-eieio-co t)) + (eieio-oset obj (car slots) + (car (widget-apply (car chil) :value-inline)))) + (setq chil (cdr chil)))) + (setq slots (cdr slots) + fgroup (cdr fgroup) + fcust (cdr fcust))) + ;; Set any name updates on it. + (if name (aset obj object-name name)) + ;; This is the same object we had before. + obj)) + +(defmethod eieio-done-customizing ((obj eieio-default-superclass)) + "When a applying change to a widget, call this method. +This method is called by the default widget-edit commands. User made +commands should also call this method when applying changes. +Argument OBJ is the object that has been customized." + nil) + +(defun customize-object (obj &optional group) + "Customize OBJ in a custom buffer. +Optional argument GROUP is the sub-group of slots to display." + (eieio-customize-object obj group)) + +(defmethod eieio-customize-object ((obj eieio-default-superclass) + &optional group) + "Customize OBJ in a specialized custom buffer. +To override call the `eieio-custom-widget-insert' to just insert the +object widget. +Optional argument GROUP specifies a subgroup of slots to edit as a symbol. +These groups are specified with the `:group' slot flag." + ;; Insert check for multiple edits here. + (let* ((g (or group 'default))) + (switch-to-buffer (get-buffer-create + (concat "*CUSTOMIZE " + (object-name obj) " " + (symbol-name g) "*"))) + (toggle-read-only -1) + (kill-all-local-variables) + (erase-buffer) + (let ((all (eieio-overlay-lists))) + ;; Delete all the overlays. + (mapc 'delete-overlay (car all)) + (mapc 'delete-overlay (cdr all))) + ;; Add an apply reset option at the top of the buffer. + (eieio-custom-object-apply-reset obj) + (widget-insert "\n\n") + (widget-insert "Edit object " (object-name obj) "\n\n") + ;; Create the widget editing the object. + (make-local-variable 'eieio-wo) + (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g)) + ;;Now generate the apply buttons + (widget-insert "\n") + (eieio-custom-object-apply-reset obj) + ;; Now initialize the buffer + (use-local-map widget-keymap) + (widget-setup) + ;;(widget-minor-mode) + (goto-char (point-min)) + (widget-forward 3) + (make-local-variable 'eieio-co) + (setq eieio-co obj) + (make-local-variable 'eieio-cog) + (setq eieio-cog group))) + +(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass)) + "Insert an Apply and Reset button into the object editor. +Argument OBJ os the object being customized." + (widget-create 'push-button + :notify (lambda (&rest ignore) + (widget-apply eieio-wo :value-get) + (eieio-done-customizing eieio-co) + (bury-buffer)) + "Accept") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + ;; I think the act of getting it sets + ;; it's value through the get function. + (message "Applying Changes...") + (widget-apply eieio-wo :value-get) + (eieio-done-customizing eieio-co) + (message "Applying Changes...Done.")) + "Apply") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (message "Resetting.") + (eieio-customize-object eieio-co eieio-cog)) + "Reset") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (bury-buffer)) + "Cancel")) + +(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) + &rest flags) + "Insert the widget used for editing object OBJ in the current buffer. +Arguments FLAGS are widget compatible flags. +Must return the created widget." + (apply 'widget-create 'object-edit :value obj flags)) + +(define-widget 'object 'object-edit + "Instance of a CLOS class." + :format "%{%t%}:\n%v" + :value-to-internal 'eieio-object-value-to-abstract + :value-to-external 'eieio-object-abstract-to-value + :clone-object-children t + ) + +(defun eieio-object-value-to-abstract (widget value) + "For WIDGET, convert VALUE to an abstract /safe/ representation." + (if (eieio-object-p value) value + (if (null value) value + nil))) + +(defun eieio-object-abstract-to-value (widget value) + "For WIDGET, convert VALUE from an abstract /safe/ representation." + value) + + +;;; customization group functions +;; +;; These functions provide the ability to create dynamic menus to +;; customize specific sections of an object. They do not hook directly +;; into a filter, but can be used to create easymenu vectors. +(defmethod eieio-customize-object-group ((obj eieio-default-superclass)) + "Create a list of vectors for customizing sections of OBJ." + (mapcar (lambda (group) + (vector (concat "Group " (symbol-name group)) + (list 'customize-object obj (list 'quote group)) + t)) + (class-option (object-class-fast obj) :custom-groups))) + +(defvar eieio-read-custom-group-history nil + "History for the custom group reader.") + +(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) + "Do a completing read on the name of a customization group in OBJ. +Return the symbol for the group, or nil" + (let ((g (class-option (object-class-fast obj) :custom-groups))) + (if (= (length g) 1) + (car g) + ;; Make the association list + (setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g)) + (cdr (assoc + (completing-read (concat (oref obj name) " Custom Group: ") + g nil t nil 'eieio-read-custom-group-history) + g))))) + +(provide 'eieio-custom) + +;;; eieio-custom.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio-datadebug.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,151 @@ +;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Extensions to data-debug for EIEIO objects. +;; + +(require 'eieio) +(require 'data-debug) + +;;; Code: + +(defun data-debug-insert-object-slots (object prefix) + "Insert all the slots of OBJECT. +PREFIX specifies what to insert at the start of each line." + (let ((attrprefix (concat (make-string (length prefix) ? ) "] ")) + ) + (data-debug/eieio-insert-slots object attrprefix) + ) + ) + +(defun data-debug-insert-object-slots-from-point (point) + "Insert the object slots found at the object button at POINT." + (let ((object (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-object-slots object + (concat (make-string indent ? ) + "~ ")) + (goto-char start) + )) + +(defun data-debug-insert-object-button (object prefix prebuttontext) + "Insert a button representing OBJECT. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between PREFIX and the object button." + (let ((start (point)) + (end nil) + (str (object-print object)) + (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" + (object-name-string object) + (object-class object) + (class-parents (object-class object)) + (length (object-slots object)) + )) + ) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face) + (put-text-property start end 'ddebug object) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-object-slots-from-point) + (insert "\n") + ) + ) + +;;; METHODS +;; +;; Each object should have an opportunity to show stuff about itself. + +(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) + prefix) + "Insert the slots of OBJ into the current DDEBUG buffer." + (data-debug-insert-thing (object-name-string obj) + prefix + "Name: ") + (let* ((cl (object-class obj)) + (cv (class-v cl))) + (data-debug-insert-thing (class-constructor cl) + prefix + "Class: ") + ;; Loop over all the public slots + (let ((publa (aref cv class-public-a)) + (publd (aref cv class-public-d)) + ) + (while publa + (if (slot-boundp obj (car publa)) + (let ((i (class-slot-initarg cl (car publa))) + (v (eieio-oref obj (car publa)))) + (data-debug-insert-thing + v prefix (concat + (if i (symbol-name i) + (symbol-name (car publa))) + " "))) + ;; Unbound case + (let ((i (class-slot-initarg cl (car publa)))) + (data-debug-insert-custom + "#unbound" prefix + (concat (if i (symbol-name i) + (symbol-name (car publa))) + " ") + 'font-lock-keyword-face)) + ) + (setq publa (cdr publa) publd (cdr publd))) + ))) + +;;; DEBUG METHODS +;; +;; A generic function to run DDEBUG on an object and popup a new buffer. +;; +(defmethod data-debug-show ((obj eieio-default-superclass)) + "Run ddebug against any EIEIO object OBJ" + (data-debug-new-buffer (format "*%s DDEBUG*" (object-name obj))) + (data-debug-insert-object-slots obj "]")) + +;;; DEBUG FUNCTIONS +;; +(defun eieio-debug-methodinvoke (method class) + "Show the method invocation order for METHOD with CLASS object." + (interactive "aMethod: \nXClass Expression: ") + (let* ((eieio-pre-method-execution-hooks + (lambda (l) (throw 'moose l) )) + (data + (catch 'moose (eieio-generic-call + method (list class)))) + (buf (data-debug-new-buffer "*Method Invocation*")) + (data2 (mapcar (lambda (sym) + (symbol-function (car sym))) + data))) + (data-debug-insert-thing data2 ">" ""))) + +(provide 'eieio-datadebug) + +;;; eieio-datadebug.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio-doc.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,365 @@ +;;; eieio-doc.el --- create texinfo documentation for an eieio class + +;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2004, 2005 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, lisp, docs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Outputs into the current buffer documentation in texinfo format + +(require 'eieio-opt) + +;; for a class, all it's children, and all it's slots. + +;;; Code: +(defvar eieiodoc-currently-in-node nil + "String representing the node we go BACK to.") + +(defvar eieiodoc-current-section-level nil + "String represending what type of section header to use.") + +(defvar eieiodoc-prev-class nil + "Non-nil when while `eieiodoc-recurse' is running. +Can be referenced from the recursed function.") + +(defvar eieiodoc-next-class nil + "Non-nil when `eieiodoc-recurse' is running. +Can be referenced from the recursed function.") + +(defun eieiodoc-class-nuke (root-class indexstring &optional skiplist) + "Call `eieiodoc-class' after nuking everything from POINT on. +ROOT-CLASS, INDEXSTRING, and SKIPLIST are the same as `eieiodoc-class'." + (delete-region (point) (point-max)) + (sit-for 0) + (eieiodoc-class root-class indexstring skiplist)) + +(defun eieiodoc-class (root-class indexstring &optional skiplist) + "Create documentation starting with ROOT-CLASS. +The first job is to create an indented menu of all the classes +starting with `root-class' and including all it's children. Once this +is done, @nodes are created for all the subclasses. Each node is then +documented with a description of the class, a brief inheritance tree +\(with xrefs) and a list of all slots in a big table. Where each slot +is inherited from is also documented. In addition, each class is +documented in the index referenced by INDEXSTRING, a two letter code +described in the texinfo manual. + +The optional third argument SKIPLIST is a list of object not to put +into any menus, nodes or lists." + (interactive + (list (intern-soft + (completing-read "Class: " (eieio-build-class-alist) nil t)) + (read-string "Index name (2 chars): "))) + (if (looking-at "[ \t\n]+@end ignore") + (goto-char (match-end 0))) + (save-excursion + (setq eieiodoc-currently-in-node + (if (re-search-backward "@node \\([^,]+\\)" nil t) + (buffer-substring (match-beginning 1) (match-end 1)) + "Top") + eieiodoc-current-section-level + (if (re-search-forward "@\\(chapter\\|\\(sub\\)*section\\)" + (+ (point) 500) t) + (progn + (goto-char (match-beginning 0)) + (cond ((looking-at "@chapter") "section") + ((looking-at "@section") "subsection") + ((looking-at "@\\(sub\\)+section") "subsubsection") + (t "subsubsection"))) + "subsubsection"))) + (save-excursion + (eieiodoc-main-menu root-class skiplist) + (insert "\n") + (eieiodoc-recurse root-class 'eieiodoc-one-node nil skiplist))) + +(defun eieiodoc-main-menu (class skiplist) + "Create a menu of all classes under CLASS indented the correct amount. +SKIPLIST is a list of objects to skip" + (end-of-line) + (insert "\n@menu\n") + (eieiodoc-recurse class (lambda (class level) + (insert "* " (make-string level ? ) + (symbol-name class) " ::\n")) + nil skiplist) + (insert "@end menu\n")) + +(defun eieiodoc-one-node (class level) + "Create a node for CLASS, and for all subclasses of CLASS in order. +This function should only be called by `eieiodoc-class' +Argument LEVEL is the current level of recursion we have hit." + (message "Building node for %s" class) + (insert "\n@node " (symbol-name class) ", " + (if eieiodoc-next-class (symbol-name eieiodoc-next-class) " ") ", " + (if eieiodoc-prev-class (symbol-name eieiodoc-prev-class) " ") ", " + eieiodoc-currently-in-node "\n" + "@comment node-name, next, previous, up\n" + "@" eieiodoc-current-section-level " " (symbol-name class) "\n" + ;; indexstring is grabbed from parent calling function + "@" indexstring "index " (symbol-name class) "\n\n") + ;; Now lets create a nifty little inheritance tree + (let ((cl class) + (revlist nil) + (depth 0)) + (while cl + (setq revlist (cons cl revlist) + cl (class-parent cl))) + (insert "@table @asis\n@item Inheritance Tree:\n") + (while revlist + ;; root-class is dragged in from the top-level function + (insert "@table @code\n@item " + (if (and (child-of-class-p (car revlist) root-class) + (not (eq class (car revlist)))) + (concat "@w{@xref{" (symbol-name (car revlist)) "}.}") + (symbol-name (car revlist))) + "\n") + (setq revlist (cdr revlist) + depth (1+ depth))) + ;; the value of rclass is brought in from caller + (let ((clist (reverse (aref (class-v rclass) class-children)))) + (if (not clist) + (insert "No children") + (insert "@table @asis\n@item Children:\n") + (while clist + (insert "@w{@xref{" (symbol-name (car clist)) "}") + (if (cdr clist) (insert ",") (insert ".")) + (insert "} ") + (setq clist (cdr clist))) + (insert "\n@end table\n") + )) + (while (> depth 0) + (insert "\n@end table\n") + (setq depth (1- depth))) + (insert "@end table\n\n ")) + ;; Now lets build some documentation by extracting information from + ;; the class description vector + (let* ((cv (class-v class)) + (docs (aref cv class-public-doc)) + (names (aref cv class-public-a)) + (deflt (aref cv class-public-d)) + (prot (aref cv class-protection)) + (typev (aref cv class-public-type)) + (i 0) + (set-one nil) + (anchor nil) + ) + ;; doc of the class itself + (insert (eieiodoc-texify-docstring (documentation class) class) + "\n\n@table @asis\n") + (if names + (progn + (setq anchor (point)) + (insert "@item Slots:\n\n@table @code\n") + (while names + (if (eieiodoc-one-attribute class (car names) (car docs) + (car prot) (car deflt) (aref typev i)) + (setq set-one t)) + (setq names (cdr names) + docs (cdr docs) + prot (cdr prot) + deflt (cdr deflt) + i (1+ i))) + (insert "@end table\n\n") + (if (not set-one) (delete-region (point) anchor)) + )) + (insert "@end table\n") + ;; Finally, document all the methods associated with this class. + (let ((methods (eieio-all-generic-functions class)) + (doc nil)) + (if (not methods) nil + (if (string= eieiodoc-current-section-level "subsubsection") + (insert "@" eieiodoc-current-section-level) + (insert "@sub" eieiodoc-current-section-level)) + (insert " Specialized Methods\n\n") + (while methods + (setq doc (eieio-method-documentation (car methods) class)) + (insert "@deffn Method " (symbol-name (car methods))) + (if (not doc) + (insert "\n Undocumented") + (if (car doc) + (progn + (insert " :BEFORE ") + (eieiodoc-output-deffn-args (car (car doc))) + (insert "\n") + (eieiodoc-insert-and-massage-docstring-with-args + (cdr (car doc)) (car (car doc)) class))) + (setq doc (cdr doc)) + (if (car doc) + (progn + (insert " :PRIMARY ") + (eieiodoc-output-deffn-args (car (car doc))) + (insert "\n") + (eieiodoc-insert-and-massage-docstring-with-args + (cdr (car doc)) (car (car doc)) class))) + (setq doc (cdr doc)) + (if (car doc) + (progn + (insert " :AFTER ") + (eieiodoc-output-deffn-args (car (car doc))) + (insert "\n") + (eieiodoc-insert-and-massage-docstring-with-args + (cdr (car doc)) (car (car doc)) class))) + (insert "\n@end deffn\n\n")) + (setq methods (cdr methods))))) + )) + +(defun eieiodoc-insert-and-massage-docstring-with-args (doc arglst class) + "Update DOC with texinfo strings using ARGLST with @var. +Argument CLASS is the class passed to `eieiodoc-texify-docstring'." + (let ((start (point)) + (end nil) + (case-fold-search nil)) + ;; Insert the text + (insert (eieiodoc-texify-docstring doc class)) + (setq end (point)) + (save-restriction + (narrow-to-region start end) + (save-excursion + ;; Now find arguments + (while arglst + (goto-char (point-min)) + (while (re-search-forward (upcase (symbol-name (car arglst))) nil t) + (replace-match "@var{\\&}" t)) + (setq arglst (cdr arglst))))))) + +(defun eieiodoc-output-deffn-args (arglst) + "Output ARGLST for a deffn." + (while arglst + (insert (symbol-name (car arglst)) " ") + (setq arglst (cdr arglst)))) + +(defun eieiodoc-one-attribute (class attribute doc priv deflt type) + "Create documentation of CLASS for a single ATTRIBUTE. +Assume this attribute is inside a table, so it is initiated with the +@item indicator. If this attribute is not inserted (because it is +contained in the parent) then return nil, else return t. +DOC is the documentation to use, PRIV is non-nil if it is a private slot, +and DEFLT is the default value. TYPE is the symbol describing what type +validation is done on that slot." + (let ((pv (eieiodoc-parent-diff class attribute)) + (ia (eieio-attribute-to-initarg class attribute)) + (set-me nil)) + (if (or (eq pv t) (not ia)) + nil ;; same in parent or no init arg + (setq set-me t) + (insert "@item " (if priv "Private: " "") + (symbol-name ia)) + (if (and type (not (eq type t))) + (insert "\nType: @code{" (format "%S" type) "}")) + (if (not (eq deflt eieio-unbound)) + (insert " @*\nDefault Value: @code{"(format "%S" deflt) "}")) + (insert "\n\n") + (if (eq pv 'default) + ;; default differs only, xref the parent + ;; This should be upgraded to actually search for the last + ;; differing default (or the original.) + (insert "@xref{" (symbol-name (class-parent class)) "}.\n") + (insert (if doc (eieiodoc-texify-docstring doc class) "Not Documented") + "\n@refill\n\n"))) + set-me)) +;;; +;; Utilities +;; +(defun eieiodoc-recurse (rclass func &optional level skiplist) + "Recurse down all children of RCLASS, calling FUNC on each one. +LEVEL indicates the current depth below the first call we are. The +function FUNC will be called with RCLASS and LEVEL. This will then +recursivly call itself once for each child class of RCLASS. The +optional fourth argument SKIPLIST is a list of objects to ignore while +recursing." + + (if (not level) (setq level 0)) + + ;; we reverse the children so they appear in the same order as it + ;; does in the code that creates them. + (let* ((children (reverse (aref (class-v rclass) class-children))) + (ocnc eieiodoc-next-class) + (eieiodoc-next-class (or (car children) ocnc)) + (eieiodoc-prev-class eieiodoc-prev-class)) + + (if (not (member rclass skiplist)) + (progn + (apply func (list rclass level)) + + (setq eieiodoc-prev-class rclass))) + + (while children + (setq eieiodoc-next-class (or (car (cdr children)) ocnc)) + (setq eieiodoc-prev-class (eieiodoc-recurse (car children) func (1+ level))) + (setq children (cdr children))) + ;; return the previous class so that the prev/next node gets it right + eieiodoc-prev-class)) + +(defun eieiodoc-parent-diff (class slot) + "Return nil if the parent of CLASS does not have slot SLOT. +Return t if it does, and return 'default if the default has changed." + (let ((df nil) (err t) + (scoped-class (class-parent class)) + (eieio-skip-typecheck)) + (condition-case nil + (setq df (eieio-oref-default (class-parent class) slot) + err nil) + (invalid-slot-name (setq df nil)) + (error (setq df nil))) + (if err + nil + (if (equal df (eieio-oref-default class slot)) + t + 'default)))) + +(defun eieiodoc-texify-docstring (string class) + "Take STRING, (a normal doc string), and convert it into a texinfo string. +For instances where CLASS is the class being referenced, do not Xref +that class. + + `function' => @dfn{function} + `variable' => @code{variable} + `class' => @code{class} @xref{class} + `unknown' => @code{unknonwn} + 'quoteme => @code{quoteme} + non-nil => non-@code{nil} + t => @code{t} + :tag => @code{:tag} + [ stuff ] => @code{[ stuff ]} + Key => @kbd{Key}" + (while (string-match "`\\([-a-zA-Z0-9]+\\)'" string) + (let* ((vs (substring string (match-beginning 1) (match-end 1))) + (v (intern-soft vs))) + (setq string + (concat + (replace-match (concat + (if (and (not (class-p v))(fboundp v)) + "@dfn{" "@code{") + vs "}" + (if (and (class-p v) (not (eq v class))) + (concat " @xref{" vs "}."))) + nil t string))))) + (while (string-match "\\( \\|^\\|-\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([ ,]\\|$\\)" string) + (setq string (replace-match "@code{\\2}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string) + (setq string (replace-match "@code{\\2}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|$\\)" string) + (setq string (replace-match "@kbd{\\2}" t nil string 2))) + string) + +(provide 'eieio-doc) + +;;; eieio-doc.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio-opt.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,699 @@ +;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) + +;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This contains support functions to eieio. These functions contain +;; some small class browser and class printing functions. +;; + +(require 'eieio) + +;;; Code: +(defun eieio-browse (&optional root-class) + "Create an object browser window to show all objects. +If optional ROOT-CLASS, then start with that, otherwise start with +variable `eieio-default-superclass'." + (interactive (if current-prefix-arg + (list (read (completing-read "Class: " + (eieio-build-class-alist) + nil t))) + nil)) + (if (not root-class) (setq root-class 'eieio-default-superclass)) + (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class))) + (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) + (save-excursion + (set-buffer (get-buffer "*EIEIO OBJECT BROWSE*")) + (erase-buffer) + (goto-char 0) + (eieio-browse-tree root-class "" "") + )) + +(defun eieio-browse-tree (this-root prefix ch-prefix) + "Recursively, draws the children of the given class on the screen. +Argument THIS-ROOT is the local root of the tree. +Argument PREFIX is the character prefix to use. +Argument CH-PREFIX is another character prefix to display." + (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root))) + (let ((myname (symbol-name this-root)) + (chl (aref (class-v this-root) class-children)) + (fprefix (concat ch-prefix " +--")) + (mprefix (concat ch-prefix " | ")) + (lprefix (concat ch-prefix " "))) + (insert prefix myname "\n") + (while (cdr chl) + (eieio-browse-tree (car chl) fprefix mprefix) + (setq chl (cdr chl))) + (if chl + (eieio-browse-tree (car chl) fprefix lprefix)) + )) + +;;; CLASS COMPLETION / DOCUMENTATION +;;;###autoload +(defalias 'describe-class 'eieio-describe-class) +;;;###autoload +(defun eieio-describe-class (class &optional headerfcn) + "Describe a CLASS defined by a string or symbol. +If CLASS is actually an object, then also display current values of that obect. +Optional HEADERFCN should be called to insert a few bits of info first." + (interactive (list (eieio-read-class "Class: "))) + (with-output-to-temp-buffer (help-buffer) ;"*Help*" + (help-setup-xref (list #'eieio-describe-class class headerfcn) + (interactive-p)) + + (when headerfcn (funcall headerfcn)) + + (if (class-option class :abstract) + (princ "Abstract ")) + (princ "Class ") + (prin1 class) + (terpri) + ;; Inheritence tree information + (let ((pl (class-parents class))) + (when pl + (princ " Inherits from ") + (while pl + (princ "`") (prin1 (car pl)) (princ "'") + (setq pl (cdr pl)) + (if pl (princ ", "))) + (terpri))) + (let ((ch (class-children class))) + (when ch + (princ " Children ") + (while ch + (princ "`") (prin1 (car ch)) (princ "'") + (setq ch (cdr ch)) + (if ch (princ ", "))) + (terpri))) + (terpri) + ;; System documentation + (let ((doc (documentation-property class 'variable-documentation))) + (when doc + (princ "Documentation:") + (terpri) + (princ doc) + (terpri) + (terpri))) + ;; Describe all the slots in this class + (eieio-describe-class-slots class) + ;; Describe all the methods specific to this class. + (let ((methods (eieio-all-generic-functions class)) + (doc nil)) + (if (not methods) nil + (princ "Specialized Methods:") + (terpri) + (terpri) + (while methods + (setq doc (eieio-method-documentation (car methods) class)) + (princ "`") + (prin1 (car methods)) + (princ "'") + (if (not doc) + (princ " Undocumented") + (if (car doc) + (progn + (princ " :STATIC ") + (prin1 (car (car doc))) + (terpri) + (princ (cdr (car doc))))) + (setq doc (cdr doc)) + (if (car doc) + (progn + (princ " :BEFORE ") + (prin1 (car (car doc))) + (terpri) + (princ (cdr (car doc))))) + (setq doc (cdr doc)) + (if (car doc) + (progn + (princ " :PRIMARY ") + (prin1 (car (car doc))) + (terpri) + (princ (cdr (car doc))))) + (setq doc (cdr doc)) + (if (car doc) + (progn + (princ " :AFTER ") + (prin1 (car (car doc))) + (terpri) + (princ (cdr (car doc))))) + (terpri) + (terpri)) + (setq methods (cdr methods)))))) + (save-excursion + (set-buffer (help-buffer)) + (buffer-string))) + +(defun eieio-describe-class-slots (class) + "Describe the slots in CLASS. +Outputs to the standard output." + (let* ((cv (class-v class)) + (docs (aref cv class-public-doc)) + (names (aref cv class-public-a)) + (deflt (aref cv class-public-d)) + (types (aref cv class-public-type)) + (publp (aref cv class-public-printer)) + (i 0) + (prot (aref cv class-protection)) + ) + (princ "Instance Allocated Slots:") + (terpri) + (terpri) + (while names + (if (car prot) (princ "Private ")) + (princ "Slot: ") + (prin1 (car names)) + (when (not (eq (aref types i) t)) + (princ " type = ") + (prin1 (aref types i))) + (unless (eq (car deflt) eieio-unbound) + (princ " default = ") + (prin1 (car deflt))) + (when (car publp) + (princ " printer = ") + (prin1 (car publp))) + (when (car docs) + (terpri) + (princ " ") + (princ (car docs)) + (terpri)) + (terpri) + (setq names (cdr names) + docs (cdr docs) + deflt (cdr deflt) + publp (cdr publp) + prot (cdr prot) + i (1+ i))) + (setq docs (aref cv class-class-allocation-doc) + names (aref cv class-class-allocation-a) + types (aref cv class-class-allocation-type) + i 0 + prot (aref cv class-class-allocation-protection)) + (when names + (terpri) + (princ "Class Allocated Slots:")) + (terpri) + (terpri) + (while names + (when (car prot) + (princ "Private ")) + (princ "Slot: ") + (prin1 (car names)) + (unless (eq (aref types i) t) + (princ " type = ") + (prin1 (aref types i))) + (condition-case nil + (let ((value (eieio-oref class (car names)))) + (princ " value = ") + (prin1 value)) + (error nil)) + (when (car docs) + (terpri) + (princ " ") + (princ (car docs)) + (terpri)) + (terpri) + (setq names (cdr names) + docs (cdr docs) + prot (cdr prot) + i (1+ i))))) + +(defun eieio-describe-constructor (fcn) + "Describe the constructor function FCN. +Uses `eieio-describe-class' to describe the class being constructed." + (interactive + ;; Use eieio-read-class since all constructors have the same name as + ;; the class they create. + (list (eieio-read-class "Class: "))) + (eieio-describe-class + fcn (lambda () + ;; Describe the constructor part. + (princ "Object Constructor Function: ") + (prin1 fcn) + (terpri) + (princ "Creates an object of class ") + (prin1 fcn) + (princ ".") + (terpri) + (terpri) + )) + ) + +(defun eieio-build-class-alist (&optional class instantiable-only buildlist) + "Return an alist of all currently active classes for completion purposes. +Optional argument CLASS is the class to start with. +If INSTANTIABLE-ONLY is non nil, only allow names of classes which +are not abstract, otherwise allow all classes. +Optional argument BUILDLIST is more list to attach and is used internally." + (let* ((cc (or class eieio-default-superclass)) + (sublst (aref (class-v cc) class-children))) + (if (or (not instantiable-only) (not (class-abstract-p cc))) + (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))) + (while sublst + (setq buildlist (eieio-build-class-alist + (car sublst) instantiable-only buildlist)) + (setq sublst (cdr sublst))) + buildlist)) + +(defvar eieio-read-class nil + "History of the function `eieio-read-class' prompt.") + +(defun eieio-read-class (prompt &optional histvar instantiable-only) + "Return a class chosen by the user using PROMPT. +Optional argument HISTVAR is a variable to use as history. +If INSTANTIABLE-ONLY is non nil, only allow names of classes which +are not abstract." + (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only) + nil t nil + (or histvar 'eieio-read-class)))) + +(defun eieio-read-subclass (prompt class &optional histvar instantiable-only) + "Return a class chosen by the user using PROMPT. +CLASS is the base class, and completion occurs across all subclasses. +Optional argument HISTVAR is a variable to use as history. +If INSTANTIABLE-ONLY is non nil, only allow names of classes which +are not abstract." + (intern (completing-read prompt + (eieio-build-class-alist class instantiable-only) + nil t nil + (or histvar 'eieio-read-class)))) + +;;; METHOD COMPLETION / DOC +;; +;;;###autoload +(defalias 'describe-method 'eieio-describe-generic) +;;;###autoload +(defalias 'describe-generic 'eieio-describe-generic) +;;;###autoload +(defalias 'eieio-describe-method 'eieio-describe-generic) +;;;###autoload +(defun eieio-describe-generic (generic) + "Describe the generic function GENERIC. +Also extracts information about all methods specific to this generic." + (interactive (list (eieio-read-generic "Generic Method: "))) + (if (not (generic-p generic)) + (signal 'wrong-type-argument '(generic-p generic))) + (with-output-to-temp-buffer (help-buffer) ; "*Help*" + (help-setup-xref (list #'eieio-describe-generic generic) (interactive-p)) + + (prin1 generic) + (princ " is a generic function") + (when (generic-primary-only-p generic) + (princ " with only ") + (when (generic-primary-only-one-p generic) + (princ "one ")) + (princ "primary method") + (when (not (generic-primary-only-one-p generic)) + (princ "s")) + ) + (princ ".") + (terpri) + (terpri) + (let ((d (documentation generic))) + (if (not d) + (princ "The generic is not documented.\n") + (princ "Documentation:") + (terpri) + (princ d) + (terpri) + (terpri))) + (princ "Implementations:") + (terpri) + (terpri) + (let ((i 3) + (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) + ;; Loop over fanciful generics + (while (< i 6) + (let ((gm (aref (get generic 'eieio-method-tree) i))) + (when gm + (princ "Generic ") + (princ (aref prefix (- i 3))) + (terpri) + (princ (or (nth 2 gm) "Undocumented")) + (terpri) + (terpri))) + (setq i (1+ i))) + (setq i 0) + ;; Loop over defined class-specific methods + (while (< i 3) + (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))) + (while gm + (princ "`") + (prin1 (car (car gm))) + (princ "'") + ;; prefix type + (princ " ") + (princ (aref prefix i)) + (princ " ") + ;; argument list + (let* ((func (cdr (car gm))) + (arglst (eieio-lambda-arglist func))) + (prin1 arglst)) + (terpri) + ;; 3 because of cdr + (princ (or (documentation (cdr (car gm))) + "Undocumented")) + (setq gm (cdr gm)) + (terpri) + (terpri))) + (setq i (1+ i))))) + (save-excursion + (set-buffer (help-buffer)) + (buffer-string))) + +(defun eieio-lambda-arglist (func) + "Return the argument list of FUNC, a function body." + (if (symbolp func) (setq func (symbol-function func))) + (if (byte-code-function-p func) + (eieio-compiled-function-arglist func) + (car (cdr func)))) + +(defun eieio-all-generic-functions (&optional class) + "Return a list of all generic functions. +Optional CLASS argument returns only those functions that contain methods for CLASS." + (let ((l nil) tree (cn (if class (symbol-name class) nil))) + (mapatoms + (lambda (symbol) + (setq tree (get symbol 'eieio-method-obarray)) + (if tree + (progn + ;; A symbol might be interned for that class in one of + ;; these three slots in the method-obarray. + (if (or (not class) + (fboundp (intern-soft cn (aref tree 0))) + (fboundp (intern-soft cn (aref tree 1))) + (fboundp (intern-soft cn (aref tree 2)))) + (setq l (cons symbol l))))))) + l)) + +(defun eieio-method-documentation (generic class) + "Return a list of the specific documentation of GENERIC for CLASS. +If there is not an explicit method for CLASS in GENERIC, or if that +function has no documentation, then return nil." + (let ((tree (get generic 'eieio-method-obarray)) + (cn (symbol-name class)) + before primary after) + (if (not tree) + nil + ;; A symbol might be interned for that class in one of + ;; these three slots in the method-obarray. + (setq before (intern-soft cn (aref tree 0)) + primary (intern-soft cn (aref tree 1)) + after (intern-soft cn (aref tree 2))) + (if (not (or (fboundp before) + (fboundp primary) + (fboundp after))) + nil + (list (if (fboundp before) + (cons (eieio-lambda-arglist before) + (documentation before)) + nil) + (if (fboundp primary) + (cons (eieio-lambda-arglist primary) + (documentation primary)) + nil) + (if (fboundp after) + (cons (eieio-lambda-arglist after) + (documentation after)) + nil)))))) + +(defvar eieio-read-generic nil + "History of the `eieio-read-generic' prompt.") + +(defun eieio-read-generic-p (fn) + "Function used in function `eieio-read-generic'. +This is because `generic-p' is a macro. +Argument FN is the function to test." + (generic-p fn)) + +(defun eieio-read-generic (prompt &optional historyvar) + "Read a generic function from the minibuffer with PROMPT. +Optional argument HISTORYVAR is the variable to use as history." + (intern (completing-read prompt obarray 'eieio-read-generic-p + t nil (or historyvar 'eieio-read-generic)))) + +;;; METHOD STATS +;; +;; Dump out statistics about all the active methods in a session. +(defun eieio-display-method-list () + "Display a list of all the methods and what features are used." + (interactive) + (let* ((meth1 (eieio-all-generic-functions)) + (meth (sort meth1 (lambda (a b) + (string< (symbol-name a) + (symbol-name b))))) + (buff (get-buffer-create "*EIEIO Method List*")) + (methidx 0) + (standard-output buff) + (slots '(method-static + method-before + method-primary + method-after + method-generic-before + method-generic-primary + method-generic-after)) + (slotn '("static" + "before" + "primary" + "after" + "G bef" + "G prim" + "G aft")) + (idxarray (make-vector (length slots) 0)) + (primaryonly 0) + (oneprimary 0) + ) + (switch-to-buffer-other-window buff) + (erase-buffer) + (dolist (S slotn) + (princ S) + (princ "\t") + ) + (princ "Method Name") + (terpri) + (princ "--------------------------------------------------------------------") + (terpri) + (dolist (M meth) + (let ((mtree (get M 'eieio-method-tree)) + (P nil) (numP) + (!P nil)) + (dolist (S slots) + (let ((num (length (aref mtree (symbol-value S))))) + (aset idxarray (symbol-value S) + (+ num (aref idxarray (symbol-value S)))) + (prin1 num) + (princ "\t") + (when (< 0 num) + (if (eq S 'method-primary) + (setq P t numP num) + (setq !P t))) + )) + ;; Is this a primary-only impl method? + (when (and P (not !P)) + (setq primaryonly (1+ primaryonly)) + (when (= numP 1) + (setq oneprimary (1+ oneprimary)) + (princ "*")) + (princ "* ") + ) + (prin1 M) + (terpri) + (setq methidx (1+ methidx)) + ) + ) + (princ "--------------------------------------------------------------------") + (terpri) + (dolist (S slots) + (prin1 (aref idxarray (symbol-value S))) + (princ "\t") + ) + (prin1 methidx) + (princ " Total symbols") + (terpri) + (dolist (S slotn) + (princ S) + (princ "\t") + ) + (terpri) + (terpri) + (princ "Methods Primary Only: ") + (prin1 primaryonly) + (princ "\t") + (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100))) + (princ "% of total methods") + (terpri) + (princ "Only One Primary Impl: ") + (prin1 oneprimary) + (princ "\t") + (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100))) + (princ "% of total primary methods") + (terpri) + )) + +;;; HELP AUGMENTATION +;; +(defun eieio-help-mode-augmentation-maybee (&rest unused) + "For buffers thrown into help mode, augment for eieio. +Arguments UNUSED are not used." + ;; Scan created buttons so far if we are in help mode. + (when (eq major-mode 'help-mode) + (save-excursion + (goto-char (point-min)) + (let ((pos t) (inhibit-read-only t)) + (while pos + (if (get-text-property (point) 'help-xref) ; move off reference + (goto-char + (or (next-single-property-change (point) 'help-xref) + (point)))) + (setq pos (next-single-property-change (point) 'help-xref)) + (when pos + (goto-char pos) + (let* ((help-data (get-text-property (point) 'help-xref)) + ;(method (car help-data)) + (args (cdr help-data))) + (when (symbolp (car args)) + (cond ((class-p (car args)) + (setcar help-data 'eieio-describe-class)) + ((generic-p (car args)) + (setcar help-data 'eieio-describe-generic)) + (t nil)) + )))) + ;; start back at the beginning, and highlight some sections + (goto-char (point-min)) + (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t) + (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (goto-char (point-min)) + (if (re-search-forward "^Specialized Methods:$" nil t) + (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (goto-char (point-min)) + (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t) + (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (goto-char (point-min)) + (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t) + (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (goto-char (point-min)) + (while (re-search-forward "^\\(Private \\)?Slot:" nil t) + (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + )))) + +;;; SPEEDBAR SUPPORT +;; +(eval-when-compile + (condition-case nil + (require 'speedbar) + (error (message "Error loading speedbar... ignored.")))) + +(defvar eieio-class-speedbar-key-map nil + "Keymap used when working with a project in speedbar.") + +(defun eieio-class-speedbar-make-map () + "Make a keymap for eieio under speedbar." + (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap)) + + ;; General viewing stuff + (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line) + (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line) + (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line) + ) + +(if eieio-class-speedbar-key-map + nil + (if (not (featurep 'speedbar)) + (add-hook 'speedbar-load-hook (lambda () + (eieio-class-speedbar-make-map) + (speedbar-add-expansion-list + '("EIEIO" + eieio-class-speedbar-menu + eieio-class-speedbar-key-map + eieio-class-speedbar)))) + (eieio-class-speedbar-make-map) + (speedbar-add-expansion-list '("EIEIO" + eieio-class-speedbar-menu + eieio-class-speedbar-key-map + eieio-class-speedbar)))) + +(defvar eieio-class-speedbar-menu + () + "Menu part in easymenu format used in speedbar while in `eieio' mode.") + +(defun eieio-class-speedbar (dir-or-object depth) + "Create buttons in speedbar that represents the current project. +DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current +expansion depth." + (when (eq (point-min) (point-max)) + ;; This function is only called once, to start the whole deal. + ;; Ceate, and expand the default object. + (eieio-class-button eieio-default-superclass 0) + (forward-line -1) + (speedbar-expand-line))) + +(defun eieio-class-button (class depth) + "Draw a speedbar button at the current point for CLASS at DEPTH." + (if (not (class-p class)) + (signal 'wrong-type-argument (list 'class-p class))) + (let ((subclasses (aref (class-v class) class-children))) + (if subclasses + (speedbar-make-tag-line 'angle ?+ + 'eieio-sb-expand + class + (symbol-name class) + 'eieio-describe-class-sb + class + 'speedbar-directory-face + depth) + (speedbar-make-tag-line 'angle ? nil nil + (symbol-name class) + 'eieio-describe-class-sb + class + 'speedbar-directory-face + depth)))) + +(defun eieio-sb-expand (text class indent) + "For button TEXT, expand CLASS at the current location. +Argument INDENT is the depth of indentation." + (cond ((string-match "+" text) ;we have to expand this file + (speedbar-change-expand-button-char ?-) + (speedbar-with-writable + (save-excursion + (end-of-line) (forward-char 1) + (let ((subclasses (aref (class-v class) class-children))) + (while subclasses + (eieio-class-button (car subclasses) (1+ indent)) + (setq subclasses (cdr subclasses))))))) + ((string-match "-" text) ;we have to contract this node + (speedbar-change-expand-button-char ?+) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + +(defun eieio-describe-class-sb (text token indent) + "Describe the class TEXT in TOKEN. +INDENT is the current indentation level." + (speedbar-with-attached-buffer + (eieio-describe-class token)) + (speedbar-maybee-jump-to-attached-frame)) + +(provide 'eieio-opt) + +;;; eieio-opt.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio-speedbar.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,424 @@ +;;; eieio-speedbar.el -- Classes for managing speedbar displays. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008 Free +;;; Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This provides some classes that can be used as a parent which +;; will automatically provide SPEEDBAR support for any list of objects +;; of that type. +;; +;; This file requires speedbar version 0.10 or later. + +;;; Creating a new speedbar mode based on a pre-existing object hierarchy +;; +;; To create a new speedbar mode based on lists of objects is easier +;; than creating a whole new speedbar mode from scratch. +;; +;; 1) Objects that will have lists of items that can be expanded +;; should also inherit from the classes: +;; * `eieio-speedbar' - specify your own button behavior +;; * `eieio-speedbar-directory-button' - objects that behave like directories +;; * `eieio-speedbar-file-button' - objects that behave like files +;; +;; 2) Objects that have lists of children should implement the method +;; `eieio-speedbar-object-children' which returns a list of more +;; objects, or a list of strings. +;; +;; 3) Objects that return a list of strings should also implement these +;; methods: +;; * `eieio-speedbar-child-make-tag-lines' - make tag lines for a child. +;; * `eieio-speedbar-child-description' - describe non-object children +;; +;; 4) Objects which have expanded information should implement the method +;; `eieio-speedbar-description' to produce more information. +;; +;; 5) Objects that are associated with a directory should implement +;; the method `eieio-speedbar-derive-line-path' which returns a +;; path. +;; +;; 6) Objects that have a specialized behavior when clicked should +;; define the method `eieio-speedbar-handle-click'. +;; +;; To initialize a new eieio based speedbar display, do the following. +;; +;; 1) Create a keymap variable `foo-speedbar-key-map'. +;; This keymap variable should be initialized in a function. +;; If you have no special needs, use `eieio-speedbar-key-map' +;; +;; 2) Create a variable containing an easymenu definition compatible +;; with speedbar. if you have no special needs, use +;; `eieio-speedbar-menu'. +;; +;; 3) Create a function which returns the top-level list of children +;; objects to be displayed in speedbar. +;; +;; 4) Call `eieio-speedbar-create' as specified in it's documentation +;; string. This will automatically handle cases when speedbar is +;; not already loaded, and specifying all overload functions. +;; +;; 5) Create an initliazer function which looks like this: +;; +;; (defun my-speedbar-mode-initilaize () +;; "documentation" +;; (interactive) +;; (speedbar-frame-mode 1) +;; (speedbar-change-initial-expansion-list mymodename) +;; (speedbar-get-focus)) +;; +;; where `mymodename' is the same value as passed to `eieio-speedbar-create' +;; as the MODENAME parameter. + +;; @todo - Can we make this ECB friendly? + +;;; Code: +(require 'eieio) +(require 'eieio-custom) +(require 'speedbar) + +;;; Support a way of adding generic object based modes into speedbar. +;; +(defun eieio-speedbar-make-map () + "Make the generic object based speedbar keymap." + (let ((map (speedbar-make-specialized-keymap))) + + ;; General viewing things + (define-key map "\C-m" 'speedbar-edit-line) + (define-key map "+" 'speedbar-expand-line) + (define-key map "=" 'speedbar-expand-line) + (define-key map "-" 'speedbar-contract-line) + + ;; Some object based things + (define-key map "C" 'eieio-speedbar-customize-line) + map)) + +(defvar eieio-speedbar-key-map (eieio-speedbar-make-map) + "A Generic object based speedbar display keymap.") + +(defvar eieio-speedbar-menu + '([ "Edit Object/Field" speedbar-edit-line t] + [ "Expand Object" speedbar-expand-line + (save-excursion (beginning-of-line) + (looking-at "[0-9]+: *.\\+. "))] + [ "Contract Object" speedbar-contract-line + (save-excursion (beginning-of-line) + (looking-at "[0-9]+: *.-. "))] + "---" + [ "Customize Object" eieio-speedbar-customize-line + (eieio-object-p (speedbar-line-token)) ] + ) + "Menu part in easymenu format used in speedbar while browsing objects.") + +;; Note to self: Fix this silly thing! +(defalias 'eieio-speedbar-customize-line 'speedbar-edit-line) + +(defun eieio-speedbar-create (map-fn map-var menu-var modename fetcher) + "Create a speedbar mode for displaying an object hierarchy. +MAP-FN is the keymap generator function used for extra keys. +MAP-VAR is the keymap variable used. +MENU-VAR is the symbol containting an easymenu compatible menu part to use. +MODENAME is a s tring used to identify this browser mode. +FETCHER is a generic function used to fetch the base object list used when +creating the speedbar display." + (if (not (featurep 'speedbar)) + (add-hook 'speedbar-load-hook + (list 'lambda nil + (list 'eieio-speedbar-create-engine + map-fn map-var menu-var modename fetcher))) + (eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher))) + +(defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher) + "Create a speedbar mode for displaying an object hierarchy. +Called from `eieio-speedbar-create', or the speedbar load-hook. +MAP-FN, MAP-VAR, MENU-VAR, MODENAME, and FETCHER are the same as +`eieio-speedbar-create'." + ;; make sure the keymap exists + (funcall map-fn) + ;; Add to the expansion list. + (speedbar-add-expansion-list + (list modename + menu-var + map-var + (list 'lambda '(dir depth) + (list 'eieio-speedbar-buttons 'dir 'depth + (list 'quote fetcher))))) + ;; Set the special functions. + (speedbar-add-mode-functions-list + (list modename + '(speedbar-item-info . eieio-speedbar-item-info) + '(speedbar-line-directory . eieio-speedbar-line-path)))) + +(defun eieio-speedbar-buttons (dir-or-object depth fetcher) + "Create buttons for the speedbar display. +Start in directory DIR-OR-OBJECT. If it is an object, just display that +objects subelements. +Argument DEPTH specifies how far down we have already been displayed. +If it is a directory, use FETCHER to fetch all objects associated with +that path." + (let ((objlst (cond ((eieio-object-p dir-or-object) + (list dir-or-object)) + ((stringp dir-or-object) + (funcall fetcher dir-or-object)) + (t dir-or-object)))) + (if (not objlst) + (speedbar-make-tag-line nil nil nil nil "Empty display" nil nil nil + depth) + ;; Dump all objects into speedbar + (while objlst + (eieio-speedbar-make-tag-line (car objlst) depth) + (setq objlst (cdr objlst)))))) + + +;;; DEFAULT SUPERCLASS baseline methods +;; +;; First, define methods onto the superclass so all classes +;; will have some minor support. + +(defmethod eieio-speedbar-description ((object eieio-default-superclass)) + "Return a string describing OBJECT." + (object-name-string object)) + +(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass)) + "Return the path which OBJECT has something to do with." + nil) + +(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass)) + "Return a string to use as a speedbar button for OBJECT." + (object-name-string object)) + +(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass) + depth) + "Insert a tag line into speedbar at point for OBJECT. +By default, all objects appear as simple TAGS with no need to inherit from +the special `eieio-speedbar' classes. Child classes should redefine this +method to create more accurate tag lines. +Argument DEPTH is the depth at which the tag line is inserted." + (speedbar-make-tag-line nil nil nil nil + (eieio-speedbar-object-buttonname object) + 'eieio-speedbar-object-click + object + 'speedbar-tag-face + depth)) + +(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass)) + "Handle a click action on OBJECT in speedbar. +Any object can be represented as a tag in SPEEDBAR without special +attributes. These default objects will be pulled up in a custom +object edit buffer doing an in-place edit. + +If your object represents some other item, override this method +and take the apropriate action." + (require 'eieio-custom) + (speedbar-with-attached-buffer + (eieio-customize-object object)) + (speedbar-maybee-jump-to-attached-frame)) + + +;;; Class definitions +;; +;; Now define a special speedbar class with some +;; variables with :allocation class which can be attached into +;; object hierarchies. +;; +;; These more complex types are for objects which wish to display +;; lists of children buttons. + +(defclass eieio-speedbar nil + ((buttontype :initform nil + :type symbol + :documentation + "The type of expansion button used for objects of this class. +Possible values are those symbols supported by the `exp-button-type' argument +to `speedbar-make-tag-line'." + :allocation :class) + (buttonface :initform speedbar-tag-face + :type (or symbol face) + :documentation + "The face used on the textual part of the button for this class. +See `speedbar-make-tag-line' for details." + :allocation :class) + (expanded :initform nil + :type boolean + :documentation + "State of an object being expanded in speedbar.") + ) + "Class which provides basic speedbar support for child classes. +Add one of thie child classes to this class to the parent list of a class." + :method-invocation-order :depth-first + :abstract t) + +(defclass eieio-speedbar-directory-button (eieio-speedbar) + ((buttontype :initform angle) + (buttonface :initform speedbar-directory-face)) + "Class providing support for objects which behave like a directory." + :method-invocation-order :depth-first + :abstract t) + +(defclass eieio-speedbar-file-button (eieio-speedbar) + ((buttontype :initform bracket) + (buttonface :initform speedbar-file-face)) + "Class providing support for objects which behave like a directory." + :method-invocation-order :depth-first + :abstract t) + + +;;; Methods to eieio-speedbar-* which do not need to be overriden +;; +(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) + depth) + "Insert a tag line into speedbar at point for OBJECT. +All objects a child of symbol `eieio-speedbar' can be created from this +method. Override this if you need non-traditional tag lines. +Argument DEPTH is the depth at which the tag line is inserted." + (let ((children (eieio-speedbar-object-children object)) + (exp (oref object expanded))) + (if (not children) + (if (eq (oref object buttontype) 'expandtag) + (speedbar-make-tag-line 'statictag + ? nil nil + (eieio-speedbar-object-buttonname object) + 'eieio-speedbar-object-click + object + (oref object buttonface) + depth) + (speedbar-make-tag-line (oref object buttontype) + ? nil nil + (eieio-speedbar-object-buttonname object) + 'eieio-speedbar-object-click + object + (oref object buttonface) + depth)) + (speedbar-make-tag-line (oref object buttontype) + (if exp ?- ?+) + 'eieio-speedbar-object-expand + object + (eieio-speedbar-object-buttonname object) + 'eieio-speedbar-object-click + object + (oref object buttonface) + depth) + (if exp + (eieio-speedbar-expand object (1+ depth)))))) + +(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth) + "Base method for creating tag lines for non-object children." + (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" + (object-name object))) + +(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) + "Expand OBJECT at indentation DEPTH. +Inserts a list of new tag lines representing expanded elements withing +OBJECT." + (let ((children (eieio-speedbar-object-children object))) + (cond ((eieio-object-p (car children)) + (mapcar (lambda (car) + (eieio-speedbar-make-tag-line car depth)) + children)) + (children (eieio-speedbar-child-make-tag-lines object depth))))) + + +;;; Speedbar specific function callbacks. +;; +(defun eieio-speedbar-object-click (text token indent) + "Handle a user click on TEXT representing object TOKEN. +The object is at indentation level INDENT." + (eieio-speedbar-handle-click token)) + +(defun eieio-speedbar-object-expand (text token indent) + "Expand object represented by TEXT. TOKEN is the object. +INDENT is the current indentation level." + (cond ((string-match "+" text) ;we have to expand this file + (speedbar-change-expand-button-char ?-) + (oset token expanded t) + (speedbar-with-writable + (save-excursion + (end-of-line) (forward-char 1) + (eieio-speedbar-expand token (1+ indent))))) + ((string-match "-" text) ;we have to contract this node + (speedbar-change-expand-button-char ?+) + (oset token expanded nil) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + +(defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) + "Return a description for a child of OBJ which is not an object." + (error "You must implement `eieio-speedbar-child-description' for %s" + (object-name obj))) + +(defun eieio-speedbar-item-info () + "Display info for the current line when in EDE display mode." + ;; Switch across the types of the tokens. + (let ((tok (speedbar-line-token))) + (cond ((eieio-object-p tok) + (message (eieio-speedbar-description tok))) + (t + (let ((no (eieio-speedbar-find-nearest-object))) + (if no + (eieio-speedbar-child-description no))))))) + +(defun eieio-speedbar-find-nearest-object (&optional depth) + "Search backwards to the first line associated with an object. +Optional argument DEPTH is the current depth of the search." + (save-excursion + (if (not depth) + (progn + (beginning-of-line) + (when (looking-at "^\\([0-9]+\\):") + (setq depth (string-to-number (match-string 1)))))) + (when depth + (while (and (not (eieio-object-p (speedbar-line-token))) + (> depth 0)) + (setq depth (1- depth)) + (re-search-backward (format "^%d:" depth) nil t)) + (speedbar-line-token)))) + +(defun eieio-speedbar-line-path (&optional depth) + "If applicable, return the path to the file the cursor is on. +Optional DEPTH is the depth we start at." + (save-match-data + (if (not depth) + (progn + (beginning-of-line) + (looking-at "^\\([0-9]+\\):") + (setq depth (string-to-number (match-string 1))))) + ;; This whole function is presently bogus. Make it better later. + (let ((tok (eieio-speedbar-find-nearest-object depth))) + (if (eieio-object-p tok) + (eieio-speedbar-derive-line-path tok) + default-directory)))) + + +;;; Methods to the eieio-speedbar-* classes which need to be overriden. +;; +(defmethod eieio-speedbar-object-children ((object eieio-speedbar)) + "Return a list of children to be displayed in SPEEDBAR. +If the return value is a list of OBJECTs, then those objects are +queried for details. If the return list is made of strings, +then this object will be queried for the details needed +to create a speedbar button." + nil) + +(provide 'eieio-speedbar) + +;;; eieio-speedbar.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/eieio/eieio.el Sat Aug 22 04:12:52 2009 +0000 @@ -0,0 +1,2851 @@ +;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects +;;; or maybe Eric's Implementation of Emacs Intrepreted Objects + +;;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, +;;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; EIEIO is a series of Lisp routines which implements a subset of +;; CLOS, the Common Lisp Object System. In addition, EIEIO also adds +;; a few new features which help it integrate more strongly with the +;; Emacs running environment. +;; +;; See eieio.texi for complete documentation on using this package. + +;; There is funny stuff going on with typep and deftype. This +;; is the only way I seem to be able to make this stuff load properly. + +;; @TODO - fix :initform to be a form, not a quoted value +;; @TODO - For API calls like `object-p', replace with something +;; that does not conflict with "object", meaning a lisp object. +;; @TODO - Prefix non-clos functions with `eieio-'. + +;;; Code: + +(defvar eieio-version "1.2" + "Current version of EIEIO.") + +(when (featurep 'eieio) + (error "Do not load EIEIO twice.")) + +(eval-when-compile + (when (featurep 'eieio) + (error "Do not byte-compile EIEIO if EIEIO is already loaded."))) + +(require 'cl) +;;(load "cl-macs" nil t) ; No provide in this file. + +;;; Code: +(defun eieio-version () + "Display the current version of EIEIO." + (interactive) + (message eieio-version)) + +(eval-and-compile +;; Abount the above. EIEIO must process it's own code when it compiles +;; itself, thus, by eval-and-compiling outselves, we solve the problem. + +;; Compatibility +(if (fboundp 'compiled-function-arglist) + + ;; XEmacs can only access a compiled functions arglist like this: + (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) + + ;; Emacs doesn't have this function, but since FUNC is a vector, we can just + ;; grab the appropriate element. + (defun eieio-compiled-function-arglist (func) + "Return the argument list for the compiled function FUNC." + (aref func 0)) + + ) + + +;;; +;; Variable declarations. +;; + +(defvar eieio-hook nil + "*This hook is executed, then cleared each time `defclass' is called.") + +(defvar eieio-error-unsupported-class-tags nil + "*Non nil to throw an error if an encountered tag us unsupported. +This may prevent classes from CLOS applications from being used with EIEIO +since EIEIO does not support all CLOS tags.") + +(defvar eieio-skip-typecheck nil + "*If non-nil, skip all slot typechecking. +Set this to t permanently if a program is functioning well to get a +small speed increase. This variable is also used internally to handle +default setting for optimization purposes.") + +(defvar eieio-optimize-primary-methods-flag t + "Non-nil means to optimize the method dispatch on primary methods.") + +;; State Variables +(defvar this nil + "Inside a method, this variable is the object in question. +DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. + +Note: Embedded methods are no longer supported. The variable THIS is +still set for CLOS methods for the sake of routines like +`call-next-method'") + +(defvar scoped-class nil + "This is set to a class when a method is running. +This is so we know we are allowed to check private parts or how to +execute a `call-next-method'. DO NOT SET THIS YOURSELF!") + +(defvar eieio-initializing-object nil + "Set to non-nil while initializing an object.") + +(defconst eieio-unbound (make-symbol "unbound") + "Uninterned symbol representing an unbound slot in an object.") + +;; This is a bootstrap for eieio-default-superclass so it has a value +;; while it is being built itself. +(defvar eieio-default-superclass nil) + +(defconst class-symbol 1 "Class's symbol (self-referencing.).") +(defconst class-parent 2 "Class parent slot.") +(defconst class-children 3 "Class children class slot.") +(defconst class-symbol-obarray 4 "Obarray permitting fast access to variable position indexes.") +;; @todo +;; the word "public" here is leftovers from the very first version. +;; Get rid of it! +(defconst class-public-a 5 "Class attribute index.") +(defconst class-public-d 6 "Class attribute defaults index.") +(defconst class-public-doc 7 "Class documentation strings for attributes.") +(defconst class-public-type 8 "Class type for a slot.") +(defconst class-public-custom 9 "Class custom type for a slot.") +(defconst class-public-custom-label 10 "Class custom group for a slot.") +(defconst class-public-custom-group 11 "Class custom group for a slot.") +(defconst class-public-printer 12 "Printer for a slot.") +(defconst class-protection 13 "Class protection for a slot.") +(defconst class-initarg-tuples 14 "Class initarg tuples list.") +(defconst class-class-allocation-a 15 "Class allocated attributes.") +(defconst class-class-allocation-doc 16 "Class allocated documentation.") +(defconst class-class-allocation-type 17 "Class allocated value type.") +(defconst class-class-allocation-custom 18 "Class allocated custom descriptor.") +(defconst class-class-allocation-custom-label 19 "Class allocated custom descriptor.") +(defconst class-class-allocation-custom-group 20 "Class allocated custom group.") +(defconst class-class-allocation-printer 21 "Class allocated printer for a slot.") +(defconst class-class-allocation-protection 22 "Class allocated protection list.") +(defconst class-class-allocation-values 23 "Class allocated value vector.") +(defconst class-default-object-cache 24 + "Cache index of what a newly created object would look like. +This will speed up instantiation time as only a `copy-sequence' will +be needed, instead of looping over all the values and setting them +from the default.") +(defconst class-options 25 + "Storage location of tagged class options. +Stored outright without modifications or stripping.") + +(defconst class-num-slots 26 + "Number of slots in the class definition object.") + +(defconst object-class 1 "Index in an object vector where the class is stored.") +(defconst object-name 2 "Index in an object where the name is stored.") + +(defconst method-static 0 "Index into :static tag on a method.") +(defconst method-before 1 "Index into :before tag on a method.") +(defconst method-primary 2 "Index into :primary tag on a method.") +(defconst method-after 3 "Index into :after tag on a method.") +(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") +(defconst method-generic-before 4 "Index into generic :before tag on a method.") +(defconst method-generic-primary 5 "Index into generic :primary tag on a method.") +(defconst method-generic-after 6 "Index into generic :after tag on a method.") +(defconst method-num-slots 7 "Number of indexes into a method's vector.") + +;; How to specialty compile stuff. +(autoload 'byte-compile-file-form-defmethod "eieio-comp" + "This function is used to byte compile methods in a nice way.") +(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) + +(eval-when-compile (require 'eieio-comp)) + + +;;; Important macros used in eieio. +;; +(defmacro class-v (class) + "Internal: Return the class vector from the CLASS symbol." + ;; No check: If eieio gets this far, it's probably been checked already. + `(get ,class 'eieio-class-definition)) + +(defmacro class-p (class) + "Return t if CLASS is a valid class vector. +CLASS is a symbol." + ;; this new method is faster since it doesn't waste time checking lots of + ;; things. + `(condition-case nil + (eq (aref (class-v ,class) 0) 'defclass) + (error nil))) + +;;;###autoload +(defmacro eieio-object-p (obj) + "Return non-nil if OBJ is an EIEIO object." + `(condition-case nil + (let ((tobj ,obj)) + (and (eq (aref tobj 0) 'object) + (class-p (aref tobj object-class)))) + (error nil))) +(defalias 'object-p 'eieio-object-p) + +(defmacro class-constructor (class) + "Return the symbol representing the constructor of CLASS." + `(aref (class-v ,class) class-symbol)) + +(defmacro generic-p (method) + "Return t if symbol METHOD is a generic function. +Only methods have the symbol `eieio-method-obarray' as a property (which +contains a list of all bindings to that method type.)" + `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) + +(defun generic-primary-only-p (method) + "Return t if symbol METHOD is a generic function with only primary methods. +Only methods have the symbol `eieio-method-obarray' as a property (which +contains a list of all bindings to that method type.) +Methods with only primary implementations are executed in an optimized way." + (and (generic-p method) + (let ((M (get method 'eieio-method-tree))) + (and (< 0 (length (aref M method-primary))) + (not (aref M method-static)) + (not (aref M method-before)) + (not (aref M method-after)) + (not (aref M method-generic-before)) + (not (aref M method-generic-primary)) + (not (aref M method-generic-after)))) + )) + +(defun generic-primary-only-one-p (method) + "Return t if symbol METHOD is a generic function with only primary methods. +Only methods have the symbol `eieio-method-obarray' as a property (which +contains a list of all bindings to that method type.) +Methods with only primary implementations are executed in an optimized way." + (and (generic-p method) + (let ((M (get method 'eieio-method-tree))) + (and (= 1 (length (aref M method-primary))) + (not (aref M method-static)) + (not (aref M method-before)) + (not (aref M method-after)) + (not (aref M method-generic-before)) + (not (aref M method-generic-primary)) + (not (aref M method-generic-after)))) + )) + +(defmacro class-option-assoc (list option) + "Return from LIST the found OPTION. Nil if it doesn't exist." + `(car-safe (cdr (memq ,option ,list)))) + +(defmacro class-option (class option) + "Return the value stored for CLASS' OPTION. +Return nil if that option doesn't exist." + `(class-option-assoc (aref (class-v ,class) class-options) ',option)) + +(defmacro class-abstract-p (class) + "Return non-nil if CLASS is abstract. +Abstract classes cannot be instantiated." + `(class-option ,class :abstract)) + +(defmacro class-method-invocation-order (class) + "Return the invocation order of CLASS. +Abstract classes cannot be instantiated." + `(or (class-option ,class :method-invocation-order) + :breadth-first)) + + +;;; Defining a new class +;; +(defmacro defclass (name superclass slots &rest options-and-doc) + "Define NAME as a new class derived from SUPERCLASS with SLOTS. +OPTIONS-AND-DOC is used as the class' options and base documentation. +SUPERCLASS is a list of superclasses to inherit from, with SLOTS +being the slots residing in that class definition. NOTE: Currently +only one slot may exist in SUPERCLASS as multiple inheritance is not +yet supported. Supported tags are: + + :initform - initializing form + :initarg - tag used during initialization + :accessor - tag used to create a function to access this slot + :allocation - specify where the value is stored. + defaults to `:instance', but could also be `:class' + :writer - a function symbol which will `write' an object's slot + :reader - a function symbol which will `read' an object + :type - the type of data allowed in this slot (see `typep') + :documentation + - A string documenting use of this slot. + +The following are extensions on CLOS: + :protection - Specify protection for this slot. + Defaults to `:public'. Also use `:protected', or `:private' + :custom - When customizing an object, the custom :type. Public only. + :label - A text string label used for a slot when customizing. + :group - Name of a customization group this slot belongs in. + :printer - A function to call to print the value of a slot. + See `eieio-override-prin1' as an example. + +A class can also have optional options. These options happen in place +of documentation, (including a :documentation tag) in addition to +documentation, or not at all. Supported options are: + + :documentation - The doc-string used for this class. + +Options added to EIEIO: + + :allow-nil-initform - Non-nil to skip typechecking of initforms if nil. + :custom-groups - List of custom group names. Organizes slots into + reasonable groups for customizations. + :abstract - Non-nil to prevent instances of this class. + If a string, use as an error string if someone does + try to make an instance. + :method-invocation-order + - Control the method invokation order if there is + multiple inheritance. Valid values are: + :breadth-first - The default. + :depth-first + +Options in CLOS not supported in EIEIO: + + :metaclass - Class to use in place of `standard-class' + :default-initargs - Initargs to use when initializing new objects of + this class. + +Due to the way class options are set up, you can add any tags in you +wish, and reference them using the function `class-option'." + ;; We must `eval-and-compile' this so that when we byte compile + ;; an eieio program, there is no need to load it ahead of time. + ;; It also provides lots of nice debugging errors at compile time. + `(eval-and-compile + (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) + +(defvar eieio-defclass-autoload-map (make-vector 7 nil) + "Symbol map of superclasses we find in autoloads.") + +(defun eieio-defclass-autoload (cname superclasses filename doc) + "Create autoload symbols for the EIEIO class CNAME. +SUPERCLASSES are the superclasses that CNAME inherites from. +DOC is the docstring for CNAME. +This function creates a mock-class for CNAME and adds it into +SUPERCLASSES as children. +It creates an autoload function for CNAME's constructor." + ;; Assume we've already debugged inputs. + + (let* ((oldc (when (class-p cname) (class-v cname))) + (newc (make-vector class-num-slots nil)) + ) + (if oldc + nil ;; Do nothing if we already have this class. + + ;; Create the class in NEWC, but don't fill anything else in. + (aset newc 0 'defclass) + (aset newc class-symbol cname) + + (let ((clear-parent nil)) + ;; No parents? + (when (not superclasses) + (setq superclasses '(eieio-default-superclass) + clear-parent t) + ) + + ;; Hook our new class into the existing structures so we can + ;; autoload it later. + (dolist (SC superclasses) + + + ;; TODO - If we create an autoload that is in the map, that + ;; map needs to be cleared! + + + ;; Does our parent exist? + (if (not (class-p SC)) + + ;; Create a symbol for this parent, and then store this + ;; parent on that symbol. + (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) + (if (not (boundp sym)) + (set sym (list cname)) + (add-to-list sym cname)) + ) + + ;; We have a parent, save the child in there. + (when (not (member cname (aref (class-v SC) class-children))) + (aset (class-v SC) class-children + (cons cname (aref (class-v SC) class-children))))) + + ;; save parent in child + (aset newc class-parent (cons SC (aref newc class-parent))) + ) + + ;; turn this into a useable self-pointing symbol + (set cname cname) + + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (put cname 'eieio-class-definition newc) + + ;; Clear the parent + (if clear-parent (aset newc class-parent nil)) + + ;; Create an autoload on top of our constructor function. + (autoload cname filename doc nil nil) + (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) + (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) + + )))) + +(defsubst eieio-class-un-autoload (cname) + "If class CNAME is in an autoload state, load it's file." + (when (eq (car-safe (symbol-function cname)) 'autoload) + (load-library (car (cdr (symbol-function cname)))))) + +(defun eieio-defclass (cname superclasses slots options-and-doc) + "See `defclass' for more information. +Define CNAME as a new subclass of SUPERCLASSES, with SLOTS being the +slots residing in that class definition, and with options or documentation +OPTIONS-AND-DOC as the toplevel documentation for this class." + ;; Run our eieio-hook each time, and clear it when we are done. + ;; This way people can add hooks safely if they want to modify eieio + ;; or add definitions when eieio is loaded or something like that. + (run-hooks 'eieio-hook) + (setq eieio-hook nil) + + (if (not (symbolp cname)) (signal 'wrong-type-argument '(symbolp cname))) + (if (not (listp superclasses)) (signal 'wrong-type-argument '(listp superclasses))) + + (let* ((pname (if superclasses superclasses nil)) + (newc (make-vector class-num-slots nil)) + (oldc (when (class-p cname) (class-v cname))) + (groups nil) ;; list of groups id'd from slots + (options nil) + (clearparent nil)) + + (aset newc 0 'defclass) + (aset newc class-symbol cname) + + ;; If this class already existed, and we are updating it's structure, + ;; make sure we keep the old child list. This can cause bugs, but + ;; if no new slots are created, it also saves time, and prevents + ;; method table breakage, particularly when the users is only + ;; byte compiling an EIEIO file. + (if oldc + (aset newc class-children (aref oldc class-children)) + ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. + ;; This is like the above, but deals with autoloads nicely. + (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) + (when sym + (condition-case nil + (aset newc class-children (symbol-value sym)) + (error nil)) + (unintern (symbol-name cname) eieio-defclass-autoload-map) + )) + ) + + (cond ((and (stringp (car options-and-doc)) + (/= 1 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'")) + ((and (symbolp (car options-and-doc)) + (/= 0 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'")) + ) + + (setq options + (if (stringp (car options-and-doc)) + (cons :documentation options-and-doc) + options-and-doc)) + + (if pname + (progn + (while pname + (if (and (car pname) (symbolp (car pname))) + (if (not (class-p (car pname))) + ;; bad class + (error "Given parent class %s is not a class" (car pname)) + ;; good parent class... + ;; save new child in parent + (when (not (member cname (aref (class-v (car pname)) class-children))) + (aset (class-v (car pname)) class-children + (cons cname (aref (class-v (car pname)) class-children)))) + ;; Get custom groups, and store them into our local copy. + (mapc (lambda (g) (add-to-list 'groups g)) + (class-option (car pname) :custom-groups)) + ;; save parent in child + (aset newc class-parent (cons (car pname) (aref newc class-parent)))) + (error "Invalid parent class %s" pname)) + (setq pname (cdr pname))) + ;; Reverse the list of our parents so that they are prioritized in + ;; the same order as specified in the code. + (aset newc class-parent (nreverse (aref newc class-parent))) ) + ;; If there is nothing to loop over, then inherit from the + ;; default superclass. + (unless (eq cname 'eieio-default-superclass) + ;; adopt the default parent here, but clear it later... + (setq clearparent t) + ;; save new child in parent + (if (not (member cname (aref (class-v 'eieio-default-superclass) class-children))) + (aset (class-v 'eieio-default-superclass) class-children + (cons cname (aref (class-v 'eieio-default-superclass) class-children)))) + ;; save parent in child + (aset newc class-parent (list eieio-default-superclass)))) + + ;; turn this into a useable self-pointing symbol + (set cname cname) + + ;; These two tests must be created right away so we can have self- + ;; referencing classes. ei, a class whose slot can contain only + ;; pointers to itself. + + ;; Create the test function + (let ((csym (intern (concat (symbol-name cname) "-p")))) + (fset csym + (list 'lambda (list 'obj) + (format "Test OBJ to see if it an object of type %s" cname) + (list 'and '(eieio-object-p obj) + (list 'same-class-p 'obj cname))))) + + ;; Make sure the method invocation order is a valid value. + (let ((io (class-option-assoc options :method-invocation-order))) + (when (and io (not (member io '(:depth-first :breadth-first)))) + (error "Method invocation order %s is not allowed" io) + )) + + ;; Create a handy child test too + (let ((csym (intern (concat (symbol-name cname) "-child-p")))) + (fset csym + `(lambda (obj) + ,(format + "Test OBJ to see if it an object is a child of type %s" + cname) + (and (eieio-object-p obj) + (object-of-class-p obj ,cname)))) + + ;; When using typep, (typep OBJ 'myclass) returns t for objects which + ;; are subclasses of myclass. For our predicates, however, it is + ;; important for EIEIO to be backwards compatible, where + ;; myobject-p, and myobject-child-p are different. + ;; "cl" uses this technique to specify symbols with specific typep + ;; test, so we can let typep have the CLOS documented behavior + ;; while keeping our above predicate clean. + (eval `(deftype ,cname () + '(satisfies + ,(intern (concat (symbol-name cname) "-child-p"))))) + + ) + + ;; before adding new slots, lets add all the methods and classes + ;; in from the parent class + (eieio-copy-parents-into-subclass newc superclasses) + + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (put cname 'eieio-class-definition newc) + + ;; Query each slot in the declaration list and mangle into the + ;; class structure I have defined. + (while slots + (let* ((slot1 (car slots)) + (name (car slot1)) + (slot (cdr slot1)) + (acces (plist-get slot ':accessor)) + (init (or (plist-get slot ':initform) + (if (member ':initform slot) nil + eieio-unbound))) + (initarg (plist-get slot ':initarg)) + (docstr (plist-get slot ':documentation)) + (prot (plist-get slot ':protection)) + (reader (plist-get slot ':reader)) + (writer (plist-get slot ':writer)) + (alloc (plist-get slot ':allocation)) + (type (plist-get slot ':type)) + (custom (plist-get slot ':custom)) + (label (plist-get slot ':label)) + (customg (plist-get slot ':group)) + (printer (plist-get slot ':printer)) + + (skip-nil (class-option-assoc options :allow-nil-initform)) + ) + + (if eieio-error-unsupported-class-tags + (let ((tmp slot)) + (while tmp + (if (not (member (car tmp) '(:accessor + :initform + :initarg + :documentation + :protection + :reader + :writer + :allocation + :type + :custom + :label + :group + :printer + :allow-nil-initform + :custom-groups))) + (signal 'invalid-slot-type (list (car tmp)))) + (setq tmp (cdr (cdr tmp)))))) + + ;; Clean up the meaning of protection. + (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) + ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) + ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) + ((eq prot nil) nil) + (t (signal 'invalid-slot-type (list ':protection prot)))) + + ;; Make sure the :allocation parameter has a valid value. + (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) + (signal 'invalid-slot-type (list ':allocation alloc))) + + ;; The default type specifier is supposed to be t, meaning anything. + (if (not type) (setq type t)) + + ;; Label is nil, or a string + (if (not (or (null label) (stringp label))) + (signal 'invalid-slot-type (list ':label label))) + + ;; Is there an initarg, but allocation of class? + (if (and initarg (eq alloc :class)) + (message "Class allocated slots do not need :initarg")) + + ;; intern the symbol so we can use it blankly + (if initarg (set initarg initarg)) + + ;; The customgroup should be a list of symbols + (cond ((null customg) + (setq customg '(default))) + ((not (listp customg)) + (setq customg (list customg)))) + ;; The customgroup better be a symbol, or list of symbols. + (mapc (lambda (cg) + (if (not (symbolp cg)) + (signal 'invalid-slot-type (list ':group cg)))) + customg) + + ;; First up, add this slot into our new class. + (eieio-add-new-slot newc name init docstr type custom label customg printer + prot initarg alloc 'defaultoverride skip-nil) + + ;; We need to id the group, and store them in a group list attribute. + (mapc (lambda (cg) (add-to-list 'groups cg)) customg) + + ;; anyone can have an accessor function. This creates a function + ;; of the specified name, and also performs a `defsetf' if applicable + ;; so that users can `setf' the space returned by this function + (if acces + (progn + (eieio-defmethod acces + (list (if (eq alloc :class) :static :primary) + (list (list 'this cname)) + (format + "Retrieves the slot `%s' from an object of class `%s'" + name cname) + (list 'if (list 'slot-boundp 'this (list 'quote name)) + (list 'eieio-oref 'this (list 'quote name)) + ;; Else - Some error? nil? + nil + ))) + ;; Thanks Pascal Bourguignon <pjb@informatimago.com> + ;; For this complex macro. + (eval (macroexpand + (list 'defsetf acces '(widget) '(store) + (list 'list ''eieio-oset 'widget + (list 'quote (list 'quote name)) 'store)))) + ;;`(defsetf ,acces (widget) (store) (eieio-oset widget ',cname store)) + ) + ) + ;; If a writer is defined, then create a generic method of that + ;; name whose purpose is to set the value of the slot. + (if writer + (progn + (eieio-defmethod writer + (list (list (list 'this cname) 'value) + (format "Set the slot `%s' of an object of class `%s'" + name cname) + `(setf (slot-value this ',name) value))) + )) + ;; If a reader is defined, then create a generic method + ;; of that name whose purpose is to access this slot value. + (if reader + (progn + (eieio-defmethod reader + (list (list (list 'this cname)) + (format "Access the slot `%s' from object of class `%s'" + name cname) + `(slot-value this ',name))))) + ) + (setq slots (cdr slots))) + + ;; Now that everything has been loaded up, all our lists are backwards! Fix that up now. + (aset newc class-public-a (nreverse (aref newc class-public-a))) + (aset newc class-public-d (nreverse (aref newc class-public-d))) + (aset newc class-public-doc (nreverse (aref newc class-public-doc))) + (aset newc class-public-type + (apply 'vector (nreverse (aref newc class-public-type)))) + (aset newc class-public-custom (nreverse (aref newc class-public-custom))) + (aset newc class-public-custom-label (nreverse (aref newc class-public-custom-label))) + (aset newc class-public-custom-group (nreverse (aref newc class-public-custom-group))) + (aset newc class-public-printer (nreverse (aref newc class-public-printer))) + (aset newc class-protection (nreverse (aref newc class-protection))) + (aset newc class-initarg-tuples (nreverse (aref newc class-initarg-tuples))) + + ;; The storage for class-class-allocation-type needs to be turned into + ;; a vector now. + (aset newc class-class-allocation-type + (apply 'vector (aref newc class-class-allocation-type))) + + ;; Also, take class allocated values, and vectorize them for speed. + (aset newc class-class-allocation-values + (apply 'vector (aref newc class-class-allocation-values))) + + ;; Attach slot symbols into an obarray, and store the index of + ;; this slot as the variable slot in this new symbol. We need to + ;; know about primes, because obarrays are best set in vectors of + ;; prime number length, and we also need to make our vector small + ;; to save space, and also optimal for the number of items we have. + (let* ((cnt 0) + (pubsyms (aref newc class-public-a)) + (prots (aref newc class-protection)) + (l (length pubsyms)) + (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 + 53 59 61 67 71 73 79 83 89 97 101 ))) + (while (and primes (< (car primes) l)) + (setq primes (cdr primes))) + (car primes))) + (oa (make-vector vl 0)) + (newsym)) + (while pubsyms + (setq newsym (intern (symbol-name (car pubsyms)) oa)) + (set newsym cnt) + (setq cnt (1+ cnt)) + (if (car prots) (put newsym 'protection (car prots))) + (setq pubsyms (cdr pubsyms) + prots (cdr prots))) + (aset newc class-symbol-obarray oa) + ) + + ;; Create the constructor function + (if (class-option-assoc options :abstract) + ;; Abstract classes cannot be instantiated. Say so. + (let ((abs (class-option-assoc options :abstract))) + (if (not (stringp abs)) + (setq abs (format "Class %s is abstract" cname))) + (fset cname + `(lambda (&rest stuff) + ,(format "You cannot create a new object of type %s" cname) + (error ,abs)))) + + ;; Non-abstract classes need a constructor. + (fset cname + `(lambda (newname &rest slots) + ,(format "Create a new object with name NAME of class type %s" cname) + (apply 'constructor ,cname newname slots))) + ) + + ;; Set up a specialized doc string. + ;; Use stored value since it is calculated in a non-trivial way + (put cname 'variable-documentation + (class-option-assoc options :documentation)) + + ;; We have a list of custom groups. Store them into the options. + (let ((g (class-option-assoc options :custom-groups))) + (mapc (lambda (cg) (add-to-list 'g cg)) groups) + (if (memq :custom-groups options) + (setcar (cdr (memq :custom-groups options)) g) + (setq options (cons :custom-groups (cons g options))))) + + ;; Set up the options we have collected. + (aset newc class-options options) + + ;; if this is a superclass, clear out parent (which was set to the + ;; default superclass eieio-default-superclass) + (if clearparent (aset newc class-parent nil)) + + ;; Create the cached default object. + (let ((cache (make-vector (+ (length (aref newc class-public-a)) + 3) nil))) + (aset cache 0 'object) + (aset cache object-class cname) + (aset cache object-name 'default-cache-object) + (let ((eieio-skip-typecheck t)) + ;; All type-checking has been done to our satisfaction + ;; before this call. Don't waste our time in this call.. + (eieio-set-defaults cache t)) + (aset newc class-default-object-cache cache)) + + ;; Return our new class object + ;; newc + cname + )) + +(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) + "For SLOT, signal if SPEC does not match VALUE. +If SKIPNIL is non-nil, then if VALUE is nil, return t." + (let ((val (eieio-default-eval-maybe value))) + (if (and (not eieio-skip-typecheck) + (not (and skipnil (null val))) + (not (eieio-perform-slot-validation spec val))) + (signal 'invalid-slot-type (list slot spec val))))) + +(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc + &optional defaultoverride skipnil) + "Add into NEWC attribute A. +If A already exists in NEWC, then do nothing. If it doesn't exist, +then also add in D (defualt), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. +Argument ALLOC specifies if the slot is allocated per instance, or per class. +If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, +we must override it's value for a default. +Optional argument SKIPNIL indicates if type checking should be skipped +if default value is nil." + ;; Make sure we duplicate those items that are sequences. + (condition-case nil + (if (sequencep d) (setq d (copy-sequence d))) + ;; This copy can fail on a cons cell with a non-cons in the cdr. Lets skip it if it doesn't work. + (error nil)) + (if (sequencep type) (setq type (copy-sequence type))) + (if (sequencep cust) (setq cust (copy-sequence cust))) + (if (sequencep custg) (setq custg (copy-sequence custg))) + + ;; To prevent override information w/out specification of storage, + ;; we need to do this little hack. + (if (member a (aref newc class-class-allocation-a)) (setq alloc ':class)) + + (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) + ;; In this case, we modify the INSTANCE version of a given slot. + + (progn + + ;; Only add this element if it is so-far unique + (if (not (member a (aref newc class-public-a))) + (progn + (eieio-perform-slot-validation-for-default a type d skipnil) + (aset newc class-public-a (cons a (aref newc class-public-a))) + (aset newc class-public-d (cons d (aref newc class-public-d))) + (aset newc class-public-doc (cons doc (aref newc class-public-doc))) + (aset newc class-public-type (cons type (aref newc class-public-type))) + (aset newc class-public-custom (cons cust (aref newc class-public-custom))) + (aset newc class-public-custom-label (cons label (aref newc class-public-custom-label))) + (aset newc class-public-custom-group (cons custg (aref newc class-public-custom-group))) + (aset newc class-public-printer (cons print (aref newc class-public-printer))) + (aset newc class-protection (cons prot (aref newc class-protection))) + (aset newc class-initarg-tuples (cons (cons init a) (aref newc class-initarg-tuples))) + ) + ;; When defaultoverride is true, we are usually adding new local + ;; attributes which must override the default value of any slot + ;; passed in by one of the parent classes. + (when defaultoverride + ;; There is a match, and we must override the old value. + (let* ((ca (aref newc class-public-a)) + (np (member a ca)) + (num (- (length ca) (length np))) + (dp (if np (nthcdr num (aref newc class-public-d)) + nil)) + (tp (if np (nth num (aref newc class-public-type)))) + ) + (if (not np) + (error "Eieio internal error overriding default value for %s" + a) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a))) + ;; If we have a repeat, only update the initarg... + (unless (eq d eieio-unbound) + (eieio-perform-slot-validation-for-default a tp d skipnil) + (setcar dp d)) + ;; If we have a new initarg, check for it. + (when init + (let* ((inits (aref newc class-initarg-tuples)) + (inita (rassq a inits))) + ;; Replace the CAR of the associate INITA. + ;;(message "Initarg: %S replace %s" inita init) + (setcar inita init) + )) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + ;; + ;; EML - We used to have (if prot... here, + ;; but a prot of 'nil means public. + ;; + (let ((super-prot (nth num (aref newc class-protection))) + ) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; End original PLN + + ;; PLN Tue Jun 26 11:57:06 2007 : + ;; We do a non redundant combination of ancient + ;; custom groups and new ones using the common lisp + ;; `union' method. + (when custg + (let ((where-groups + (nthcdr num (aref newc class-public-custom-group)))) + (setcar where-groups + (union (car where-groups) + (if (listp custg) custg (list custg)))))) + ;; End PLN + + ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is + ;; set, simply replaces the old one. + (when cust + ;; (message "Custom type redefined to %s" cust) + (setcar (nthcdr num (aref newc class-public-custom)) cust)) + + ;; If a new label is specified, it simply replaces + ;; the old one. + (when label + ;; (message "Custom label redefined to %s" label) + (setcar (nthcdr num (aref newc class-public-custom-label)) label)) + ;; End PLN + + ;; PLN Sat Jun 30 17:24:42 2007 : when a new + ;; doc is specified, simply replaces the old one. + (when doc + ;;(message "Documentation redefined to %s" doc) + (setcar (nthcdr num (aref newc class-public-doc)) + doc)) + ;; End PLN + + ;; If a new printer is specified, it simply replaces + ;; the old one. + (when print + ;; (message "printer redefined to %s" print) + (setcar (nthcdr num (aref newc class-public-printer)) print)) + + ))) + )) + + ;; CLASS ALLOCATED SLOTS + (let ((value (eieio-default-eval-maybe d))) + (if (not (member a (aref newc class-class-allocation-a))) + (progn + (eieio-perform-slot-validation-for-default a type value skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different aproach. + (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a))) + (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc))) + (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type))) + (aset newc class-class-allocation-custom (cons cust (aref newc class-class-allocation-custom))) + (aset newc class-class-allocation-custom-label (cons label (aref newc class-class-allocation-custom-label))) + (aset newc class-class-allocation-custom-group (cons custg (aref newc class-class-allocation-custom-group))) + (aset newc class-class-allocation-protection (cons prot (aref newc class-class-allocation-protection))) + ;; Default value is stored in the 'values section, since new objects + ;; can't initialize from this element. + (aset newc class-class-allocation-values (cons value (aref newc class-class-allocation-values)))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (let* ((ca (aref newc class-class-allocation-a)) + (np (member a ca)) + (num (- (length ca) (length np))) + (dp (if np + (nthcdr num + (aref newc class-class-allocation-values)) + nil)) + (tp (if np (nth num (aref newc class-class-allocation-type)) + nil))) + (if (not np) + (error "Eieio internal error overriding default value for %s" + a) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a))) + ;; EML - Note: the only reason to override a class bound slot + ;; is to change the default, so allow unbound in. + + ;; If we have a repeat, only update the vlaue... + (eieio-perform-slot-validation-for-default a tp value skipnil) + (setcar dp value)) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + (let ((super-prot + (car (nthcdr num (aref newc class-class-allocation-protection))))) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; We do a non redundant combination of ancient + ;; custom groups and new ones using the common lisp + ;; `union' method. + (when custg + (let ((where-groups + (nthcdr num (aref newc class-class-allocation-custom-group)))) + (setcar where-groups + (union (car where-groups) + (if (listp custg) custg (list custg)))))) + ;; End PLN + + ;; PLN Sat Jun 30 17:24:42 2007 : when a new + ;; doc is specified, simply replaces the old one. + (when doc + ;;(message "Documentation redefined to %s" doc) + (setcar (nthcdr num (aref newc class-class-allocation-doc)) + doc)) + ;; End PLN + + ;; If a new printer is specified, it simply replaces + ;; the old one. + (when print + ;; (message "printer redefined to %s" print) + (setcar (nthcdr num (aref newc class-class-allocation-printer)) print)) + + )) + )) + )) + +(defun eieio-copy-parents-into-subclass (newc parents) + "Copy into NEWC the slots of PARENTS. +Follow the rules of not overwritting early parents when applying to +the new child class." + (let ((ps (aref newc class-parent)) + (sn (class-option-assoc (aref newc class-options) + ':allow-nil-initform))) + (while ps + ;; First, duplicate all the slots of the parent. + (let ((pcv (class-v (car ps)))) + (let ((pa (aref pcv class-public-a)) + (pd (aref pcv class-public-d)) + (pdoc (aref pcv class-public-doc)) + (ptype (aref pcv class-public-type)) + (pcust (aref pcv class-public-custom)) + (plabel (aref pcv class-public-custom-label)) + (pcustg (aref pcv class-public-custom-group)) + (printer (aref pcv class-public-printer)) + (pprot (aref pcv class-protection)) + (pinit (aref pcv class-initarg-tuples)) + (i 0)) + (while pa + (eieio-add-new-slot newc + (car pa) (car pd) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) (car-safe (car pinit)) nil nil sn) + ;; Increment each value. + (setq pa (cdr pa) + pd (cdr pd) + pdoc (cdr pdoc) + i (1+ i) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + pinit (cdr pinit)) + )) ;; while/let + ;; Now duplicate all the class alloc slots. + (let ((pa (aref pcv class-class-allocation-a)) + (pdoc (aref pcv class-class-allocation-doc)) + (ptype (aref pcv class-class-allocation-type)) + (pcust (aref pcv class-class-allocation-custom)) + (plabel (aref pcv class-class-allocation-custom-label)) + (pcustg (aref pcv class-class-allocation-custom-group)) + (printer (aref pcv class-class-allocation-printer)) + (pprot (aref pcv class-class-allocation-protection)) + (pval (aref pcv class-class-allocation-values)) + (i 0)) + (while pa + (eieio-add-new-slot newc + (car pa) (aref pval i) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) nil ':class sn) + ;; Increment each value. + (setq pa (cdr pa) + pdoc (cdr pdoc) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + i (1+ i)) + ))) ;; while/let + ;; Loop over each parent class + (setq ps (cdr ps))) + )) + +;;; CLOS style implementation of object creators. +;; +(defun make-instance (class &rest initargs) + "Make a new instance of CLASS based on INITARGS. +CLASS is a class symbol. For example: + + (make-instance 'foo) + + INITARGS is a property list with keywords based on the :initarg +for each slot. For example: + + (make-instance 'foo :slot1 value1 :slotN valueN) + +Compatability note: + +If the first element of INITARGS is a string, it is used as the +name of the class. + +In EIEIO, the class' constructor requires a name for use when printing. +`make-instance' in CLOS doesn't use names the way Emacs does, so the +class is used as the name slot instead when INITARGS doesn't start with +a string." + (if (and (car initargs) (stringp (car initargs))) + (apply (class-constructor class) initargs) + (apply (class-constructor class) + (cond ((symbolp class) (symbol-name class)) + (t (format "%S" class))) + initargs))) + + +;;; CLOS methods and generics +;; +(defmacro defgeneric (method args &optional doc-string) + "Create a generic function METHOD. ARGS is ignored. +DOC-STRING is the base documentation for this class. A generic +function has no body, as it's purpose is to decide which method body +is appropriate to use. Use `defmethod' to create methods, and it +calls defgeneric for you. With this implementation the arguments are +currently ignored. You can use `defgeneric' to apply specialized +top level documentation to a method." + `(eieio-defgeneric (quote ,method) ,doc-string)) + +(defun eieio-defgeneric-form (method doc-string) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD." + `(lambda (&rest local-args) + ,doc-string + (eieio-generic-call (quote ,method) local-args))) + +(defsubst eieio-defgeneric-reset-generic-form (method) + "Setup METHOD to call the generic form." + (let ((doc-string (documentation method))) + (fset method (eieio-defgeneric-form method doc-string)))) + +(defun eieio-defgeneric-form-primary-only (method doc-string) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD." + `(lambda (&rest local-args) + ,doc-string + (eieio-generic-call-primary-only (quote ,method) local-args))) + +(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) + "Setup METHOD to call the generic form." + (let ((doc-string (documentation method))) + (fset method (eieio-defgeneric-form-primary-only method doc-string)))) + +(defun eieio-defgeneric-form-primary-only-one (method doc-string + class + impl + ) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD. +CLASS is the class symbol needed for private method access. +IMPL is the symbol holding the method implementation." + ;; NOTE: I tried out byte compiling this little fcn. Turns out it + ;; is faster to execute this for not byte-compiled. ie, install this, + ;; then measure calls going through here. I wonder why. + (require 'bytecomp) + (let ((byte-compile-free-references nil) + (byte-compile-warnings nil) + ) + (byte-compile-lambda + `(lambda (&rest local-args) + ,doc-string + ;; This is a cool cheat. Usually we need to look up in the + ;; method table to find out if there is a method or not. We can + ;; instead make that determination at load time when there is + ;; only one method. If the first arg is not a child of the class + ;; of that one implementation, then clearly, there is no method def. + (if (not (eieio-object-p (car local-args))) + ;; Not an object. Just signal. + (signal 'no-method-definition (list ,(list 'quote method) local-args)) + + ;; We do have an object. Make sure it is the right type. + (if ,(if (eq class eieio-default-superclass) + nil ; default superclass means just an obj. Already asked. + `(not (child-of-class-p (aref (car local-args) object-class) + ,(list 'quote class))) + ) + + ;; If not the right kind of object, call no applicable + (apply 'no-applicable-method (car local-args) + ,(list 'quote method) local-args) + + ;; It is ok, do the call. + ;; Fill in inter-call variables then evaluate the method. + (let ((scoped-class ,(list 'quote class)) + (eieio-generic-call-next-method-list nil) + (eieio-generic-call-key method-primary) + (eieio-generic-call-methodname ,(list 'quote method)) + (eieio-generic-call-arglst local-args) + ) + (apply ,(list 'quote impl) local-args) + ;(,impl local-args) + )))) + ) + )) + +(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) + "Setup METHOD to call the generic form." + (let* ((doc-string (documentation method)) + (M (get method 'eieio-method-tree)) + (entry (car (aref M method-primary))) + ) + (fset method (eieio-defgeneric-form-primary-only-one + method doc-string + (car entry) + (cdr entry) + )))) + +(defun eieio-defgeneric (method doc-string) + "Engine part to `defgeneric' macro defining METHOD with DOC-STRING." + (if (and (fboundp method) (not (generic-p method)) + (or (byte-code-function-p (symbol-function method)) + (not (eq 'autoload (car (symbol-function method))))) + ) + (error "You cannot create a generic/method over an existing symbol: %s" + method)) + ;; Don't do this over and over. + (unless (fboundp 'method) + ;; This defun tells emacs where the first definition of this + ;; method is defined. + `(defun ,method nil) + ;; Make sure the method tables are installed. + (eieiomt-install method) + ;; Apply the actual body of this function. + (fset method (eieio-defgeneric-form method doc-string)) + ;; Return the method + 'method)) + +(defun eieio-unbind-method-implementations (method) + "Make the generic method METHOD have no implementations.. +It will leave the original generic function in place, but remove +reference to all implementations of METHOD." + (put method 'eieio-method-tree nil) + (put method 'eieio-method-obarray nil)) + +(defmacro defmethod (method &rest args) + "Create a new METHOD through `defgeneric' with ARGS. + +The second optional argument KEY is a specifier that +modifies how the method is called, including: + :before - Method will be called before the :primary + :primary - The default if not specified. + :after - Method will be called after the :primary + :static - First arg could be an object or class +The next argument is the ARGLIST. The ARGLIST specifies the arguments +to the method as with `defun'. The first argument can have a type +specifier, such as: + ((VARNAME CLASS) ARG2 ...) +where VARNAME is the name of the local variable for the method being +created. The CLASS is a class symbol for a class made with `defclass'. +A DOCSTRING comes after the ARGLIST, and is optional. +All the rest of the args are the BODY of the method. A method will +return the value of the last form in the BODY. + +Summary: + + (defmethod mymethod [:before | :primary | :after | :static] + ((typearg class-name) arg2 &optional opt &rest rest) + \"doc-string\" + body)" + `(eieio-defmethod (quote ,method) (quote ,args))) + +(defun eieio-defmethod (method args) + "Work part of the `defmethod' macro defining METHOD with ARGS." + (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) + ;; find optional keys + (setq key + (cond ((or (eq ':BEFORE (car args)) + (eq ':before (car args))) + (setq args (cdr args)) + method-before) + ((or (eq ':AFTER (car args)) + (eq ':after (car args))) + (setq args (cdr args)) + method-after) + ((or (eq ':PRIMARY (car args)) + (eq ':primary (car args))) + (setq args (cdr args)) + method-primary) + ((or (eq ':STATIC (car args)) + (eq ':static (car args))) + (setq args (cdr args)) + method-static) + ;; Primary key + (t method-primary))) + ;; get body, and fix contents of args to be the arguments of the fn. + (setq body (cdr args) + args (car args)) + (setq loopa args) + ;; Create a fixed version of the arguments + (while loopa + (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) + argfix)) + (setq loopa (cdr loopa))) + ;; make sure there is a generic + (eieio-defgeneric + method + (if (stringp (car body)) + (car body) (format "Generically created method `%s'" method))) + ;; create symbol for property to bind to. If the first arg is of + ;; the form (varname vartype) and `vartype' is a class, then + ;; that class will be the type symbol. If not, then it will fall + ;; under the type `primary' which is a non-specific calling of the + ;; function. + (setq firstarg (car args)) + (if (listp firstarg) + (progn + (setq argclass (nth 1 firstarg)) + (if (not (class-p argclass)) + (error "Unknown class type %s in method parameters" + (nth 1 firstarg)))) + (if (= key -1) + (signal 'wrong-type-argument (list :static 'non-class-arg))) + ;; generics are higher + (setq key (+ key 3))) + ;; Put this lambda into the symbol so we can find it + (if (byte-code-function-p (car-safe body)) + (eieiomt-add method (car-safe body) key argclass) + (eieiomt-add method (append (list 'lambda (reverse argfix)) body) + key argclass)) + ) + + (when eieio-optimize-primary-methods-flag + ;; Optimizing step: + ;; + ;; If this method, after this setup, only has primary methods, then + ;; we can setup the generic that way. + (if (generic-primary-only-p method) + ;; If there is only one primary method, then we can go one more + ;; optimization step. + (if (generic-primary-only-one-p method) + (eieio-defgeneric-reset-generic-form-primary-only-one method) + (eieio-defgeneric-reset-generic-form-primary-only method)) + (eieio-defgeneric-reset-generic-form method))) + + method) + +;;; Slot type validation +;; +(defun eieio-perform-slot-validation (spec value) + "Return non-nil if SPEC does not match VALUE." + ;; typep is in cl-macs + (or (eq spec t) ; t always passes + (eq value eieio-unbound) ; unbound always passes + (typep value spec))) + +(defun eieio-validate-slot-value (class slot-idx value slot) + "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid. +Checks the :type specifier. +SLOT is the slot that is being checked, and is only used when throwing +and error." + (if eieio-skip-typecheck + nil + ;; Trim off object IDX junk added in for the object index. + (setq slot-idx (- slot-idx 3)) + (let ((st (aref (aref (class-v class) class-public-type) slot-idx))) + (if (not (eieio-perform-slot-validation st value)) + (signal 'invalid-slot-type (list class slot st value)))))) + +(defun eieio-validate-class-slot-value (class slot-idx value slot) + "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid. +Checks the :type specifier. +SLOT is the slot that is being checked, and is only used when throwing +and error." + (if eieio-skip-typecheck + nil + (let ((st (aref (aref (class-v class) class-class-allocation-type) + slot-idx))) + (if (not (eieio-perform-slot-validation st value)) + (signal 'invalid-slot-type (list class slot st value)))))) + +(defun eieio-barf-if-slot-unbound (value instance slotname fn) + "Throw a signal if VALUE is a representation of an UNBOUND slot. +INSTANCE is the object being referenced. SLOTNAME is the offending +slot. If the slot is ok, return VALUE. +Argument FN is the function calling this verifier." + (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) + (slot-unbound instance (object-class instance) slotname fn) + value)) + +;;; Missing types that are useful to me. +;; +(defun boolean-p (bool) + "Return non-nil if BOOL is nil or t." + (or (null bool) (eq bool t))) + +;;; Get/Set slots in an object. +;; +(defmacro oref (obj slot) + "Retrieve the value stored in OBJ in the slot named by SLOT. +Slot is the name of the slot when created by `defclass' or the label +created by the :initarg tag." + `(eieio-oref ,obj (quote ,slot))) + +(defun eieio-oref (obj slot) + "Return the value in OBJ at SLOT in the object vector." + (if (not (or (eieio-object-p obj) (class-p obj))) + (signal 'wrong-type-argument (list '(or eieio-object-p class-p) obj))) + (if (not (symbolp slot)) + (signal 'wrong-type-argument (list 'symbolp slot))) + (if (class-p obj) (eieio-class-un-autoload obj)) + (let* ((class (if (class-p obj) obj (aref obj object-class))) + (c (eieio-slot-name-index class obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Lets check that info out. + (if (setq c (eieio-class-slot-name-index class slot)) + ;; Oref that slot. + (aref (aref (class-v class) class-class-allocation-values) c) + ;; The slot-missing method is a cool way of allowing an object author + ;; to intercept missing slot definitions. Since it is also the LAST + ;; thing called in this fn, it's return value would be retrieved. + (slot-missing obj slot 'oref) + ;;(signal 'invalid-slot-name (list (object-name obj) slot)) + ) + (if (not (eieio-object-p obj)) + (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + +(defalias 'slot-value 'eieio-oref) +(defalias 'set-slot-value 'eieio-oset) + +;; @TODO - DELETE THIS AFTER FAIR WARNING + +;; This alias is needed so that functions can be written +;; for defaults, but still behave like lambdas. +(defmacro lambda-default (&rest cdr) + "The same as `lambda' but is used as a default value in `defclass'. +As such, the form (lambda-default ARGS DOCSTRING INTERACTIVE BODY) is +self quoting. This macro is meant for the sole purpose of quoting +lambda expressions into class defaults. Any `lambda-default' +expression is automatically transformed into a `lambda' expression +when copied from the defaults into a new object. The use of +`oref-default', however, will return a `lambda-default' expression. +CDR is function definition and body." + (message "Warning: Use of `labda-default' will be obsoleted in the next version of EIEIO.") + ;; This definition is copied directly from subr.el for lambda + (list 'function (cons 'lambda-default cdr))) + +(put 'lambda-default 'lisp-indent-function 'defun) +(put 'lambda-default 'byte-compile 'byte-compile-lambda-form) + +(defmacro oref-default (obj slot) + "Gets the default value of OBJ (maybe a class) for SLOT. +The default value is the value installed in a class with the :initform +tag. SLOT can be the slot name, or the tag specified by the :initarg +tag in the `defclass' call." + `(eieio-oref-default ,obj (quote ,slot))) + +(defun eieio-oref-default (obj slot) + "Does the work for the macro `oref-default' with similar parameters. +Fills in OBJ's SLOT with it's default value." + (if (not (or (eieio-object-p obj) (class-p obj))) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) + (let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj)) + (c (eieio-slot-name-index cl obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Lets check that info out. + (if (setq c + (eieio-class-slot-name-index cl slot)) + ;; Oref that slot. + (aref (aref (class-v cl) class-class-allocation-values) + c) + (slot-missing obj slot 'oref-default) + ;;(signal 'invalid-slot-name (list (class-name cl) slot)) + ) + (eieio-barf-if-slot-unbound + (let ((val (nth (- c 3) (aref (class-v cl) class-public-d)))) + (eieio-default-eval-maybe val)) + obj cl 'oref-default)))) + +(defun eieio-default-eval-maybe (val) + "Check VAL, and return what `oref-default' would provide." + ;; check for functions to evaluate + (if (and (listp val) (equal (car val) 'lambda)) + (progn + (message "Warning: Evaluation of `lambda' initform will be obsoleted in the next version of EIEIO.") + (funcall val) + ) + ;; check for quoted things, and unquote them + (if (and (listp val) (eq (car val) 'quote)) + (car (cdr val)) + ;; return it verbatim + (if (and (listp val) (eq (car val) 'lambda-default)) + (let ((s (copy-sequence val))) + (setcar s 'lambda) + s) + val)))) + +;;; Object Set macros +;; +(defmacro oset (obj slot value) + "Set the value in OBJ for slot SLOT to VALUE. +SLOT is the slot name as specified in `defclass' or the tag created +with in the :initarg slot. VALUE can be any Lisp object." + `(eieio-oset ,obj (quote ,slot) ,value)) + +(defun eieio-oset (obj slot value) + "Does the work for the macro `oset'. +Fills in OBJ's SLOT with VALUE." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) + (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Lets check that info out. + (if (setq c + (eieio-class-slot-name-index (aref obj object-class) slot)) + ;; Oset that slot. + (progn + (eieio-validate-class-slot-value (object-class-fast obj) c value slot) + (aset (aref (class-v (aref obj object-class)) + class-class-allocation-values) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value) + ;;(signal 'invalid-slot-name (list (object-name obj) slot)) + ) + (eieio-validate-slot-value (object-class-fast obj) c value slot) + (aset obj c value)))) + +(defmacro oset-default (class slot value) + "Set the default slot in CLASS for SLOT to VALUE. +The default value is usually set with the :initform tag during class +creation. This allows users to change the default behavior of classes +after they are created." + `(eieio-oset-default ,class (quote ,slot) ,value)) + +(defun eieio-oset-default (class slot value) + "Does the work for the macro `oset-default'. +Fills in the default value in CLASS' in SLOT with VALUE." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) + (let* ((scoped-class class) + (c (eieio-slot-name-index class nil slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Lets check that info out. + (if (setq c (eieio-class-slot-name-index class slot)) + (progn + ;; Oref that slot. + (eieio-validate-class-slot-value class c value slot) + (aset (aref (class-v class) class-class-allocation-values) c + value)) + (signal 'invalid-slot-name (list (class-name class) slot))) + (eieio-validate-slot-value class c value slot) + ;; Set this into the storage for defaults. + (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d)) + value) + ;; Take the value, and put it into our cache object. + (eieio-oset (aref (class-v class) class-default-object-cache) + slot value) + ))) + +;;; Handy CLOS macros +;; +(defmacro with-slots (spec-list object &rest body) + "Bind SPEC-LIST lexically to slot values in OBJECT, and execute BODY. +This establishes a lexical environment for referring to the slots in +the instance named by the given slot-names as though they were +variables. Within such a context the value of the slot can be +specified by using its slot name, as if it were a lexically bound +variable. Both setf and setq can be used to set the value of the +slot. + +SPEC-LIST is of a form similar to `let'. For example: + + ((VAR1 SLOT1) + SLOT2 + SLOTN + (VARN+1 SLOTN+1)) + +Where each VAR is the local variable given to the associated +SLOT. A Slot specified without a variable name is given a +variable name of the same name as the slot." + ;; Transform the spec-list into a symbol-macrolet spec-list. + (let ((mappings (mapcar (lambda (entry) + (let ((var (if (listp entry) (car entry) entry)) + (slot (if (listp entry) (cadr entry) entry))) + (list var `(slot-value ,object ',slot)))) + spec-list))) + (append (list 'symbol-macrolet mappings) + body))) +(put 'with-slots 'lisp-indent-function 2) + + +;;; Simple generators, and query functions. None of these would do +;; well embedded into an object. +;; +(defmacro object-class-fast (obj) "Return the class struct defining OBJ with no check." + `(aref ,obj object-class)) + +(defun class-name (class) "Return a Lisp like symbol name for CLASS." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, + ;; and I wanted a string. Arg! + (format "#<class %s>" (symbol-name class))) + +(defun object-name (obj &optional extra) + "Return a Lisp like symbol string for object OBJ. +If EXTRA, include that in the string returned to represent the symbol." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (format "#<%s %s%s>" (symbol-name (object-class-fast obj)) + (aref obj object-name) (or extra ""))) + +(defun object-name-string (obj) "Return a string which is OBJ's name." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (aref obj object-name)) + +(defun object-set-name-string (obj name) "Set the string which is OBJ's NAME." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (if (not (stringp name)) (signal 'wrong-type-argument (list 'stringp name))) + (aset obj object-name name)) + +(defun object-class (obj) "Return the class struct defining OBJ." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (object-class-fast obj)) +(defalias 'class-of 'object-class) + +(defun object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (class-name (object-class-fast obj))) + +(defmacro class-parents-fast (class) "Return parent classes to CLASS with no check." + `(aref (class-v ,class) class-parent)) + +(defun class-parents (class) + "Return parent classes to CLASS. (overload of variable). + +The CLOS function `class-direct-superclasses' is aliased to this function." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + (class-parents-fast class)) + +(defmacro class-children-fast (class) "Return child classes to CLASS with no check." + `(aref (class-v ,class) class-children)) + +(defun class-children (class) +"Return child classses to CLASS. + +The CLOS function `class-direct-subclasses' is aliased to this function." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + (class-children-fast class)) + +;; Official CLOS functions. +(defalias 'class-direct-superclasses 'class-parents) +(defalias 'class-direct-subclasses 'class-children) + +(defmacro class-parent-fast (class) "Return first parent class to CLASS with no check." + `(car (class-parents-fast ,class))) + +(defmacro class-parent (class) "Return first parent class to CLASS. (overload of variable)." + `(car (class-parents ,class))) + +(defmacro same-class-fast-p (obj class) "Return t if OBJ is of class-type CLASS with no error checking." + `(eq (aref ,obj object-class) ,class)) + +(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (same-class-fast-p obj class)) + +(defun object-of-class-p (obj class) + "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + ;; class will be checked one layer down + (child-of-class-p (aref obj object-class) class)) +;; Backwards compatibility +(defalias 'obj-of-class-p 'object-of-class-p) + +(defun child-of-class-p (child class) + "If CHILD class is a subclass of CLASS." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + (if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p child))) + (let ((p nil)) + (while (and child (not (eq child class))) + (setq p (append p (aref (class-v child) class-parent)) + child (car p) + p (cdr p))) + (if child t))) + +(defun object-slots (obj) "List of slots available in OBJ." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (aref (class-v (object-class-fast obj)) class-public-a)) + +(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + (let ((ia (aref (class-v class) class-initarg-tuples)) + (f nil)) + (while (and ia (not f)) + (if (eq (cdr (car ia)) slot) + (setq f (car (car ia)))) + (setq ia (cdr ia))) + f)) + +;;; CLOS queries into classes and slots +;; +(defun slot-boundp (object slot) + "Non-nil if OBJECT's SLOT is bound. +Setting a slot's value makes it bound. Calling `slot-makeunbound' will +make a slot unbound. +OBJECT can be an instance or a class." + ;; Skip typechecking while retrieving this value. + (let ((eieio-skip-typecheck t)) + ;; Return nil if the magic symbol is in there. + (if (eieio-object-p object) + (if (eq (eieio-oref object slot) eieio-unbound) nil t) + (if (class-p object) + (if (eq (eieio-oref-default object slot) eieio-unbound) nil t) + (signal 'wrong-type-argument (list 'eieio-object-p object)))))) + +(defun slot-makeunbound (object slot) + "In OBJECT, make SLOT unbound." + (eieio-oset object slot eieio-unbound)) + +(defun slot-exists-p (object-or-class slot) + "Non-nil if OBJECT-OR-CLASS has SLOT." + (let ((cv (class-v (cond ((eieio-object-p object-or-class) + (object-class object-or-class)) + ((class-p object-or-class) + object-or-class)) + ))) + (or (memq slot (aref cv class-public-a)) + (memq slot (aref cv class-class-allocation-a))) + )) + +(defun find-class (symbol &optional errorp) + "Return the class that SYMBOL represents. +If there is no class, nil is returned if ERRORP is nil. +If ERRORP is non-nil, `wrong-argument-type' is signaled." + (if (not (class-p symbol)) + (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) + nil) + (class-v symbol))) + +;;; Slightly more complex utility functions for objects +;; +(defun object-assoc (key slot list) + "Return an object if KEY is `equal' to SLOT's value of an object in LIST. +LIST is a list of objects who's slots are searched. +Objects in LIST do not need to have a slot named SLOT, nor does +SLOT need to be bound. If these errors occur, those objects will +be ignored." + (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) + (while (and list (not (condition-case nil + ;; This prevents errors for missing slots. + (equal key (eieio-oref (car list) slot)) + (error nil)))) + (setq list (cdr list))) + (car list)) + +(defun object-assoc-list (slot list) + "Return an association list with the contents of SLOT as the key element. +LIST must be a list of objects with SLOT in it. +This is useful when you need to do completing read on an object group." + (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) + (let ((assoclist nil)) + (while list + (setq assoclist (cons (cons (eieio-oref (car list) slot) + (car list)) + assoclist)) + (setq list (cdr list))) + (nreverse assoclist))) + +(defun object-assoc-list-safe (slot list) + "Return an association list with the contents of SLOT as the key element. +LIST must be a list of objects, but those objects do not need to have +SLOT in it. If it does not, then that element is left out of the association +list." + (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) + (let ((assoclist nil)) + (while list + (if (slot-exists-p (car list) slot) + (setq assoclist (cons (cons (eieio-oref (car list) slot) + (car list)) + assoclist))) + (setq list (cdr list))) + (nreverse assoclist))) + +(defun object-add-to-list (object slot item &optional append) + "In OBJECT's SLOT, add ITEM to the list of elements. +Optional argument APPEND indicates we need to append to the list. +If ITEM already exists in the list in SLOT, then it is not added. +Comparison is done with `equal' through the `member' function call. +If SLOT is unbound, bind it to the list containing ITEM." + (let (ov) + ;; Find the originating list. + (if (not (slot-boundp object slot)) + (setq ov (list item)) + (setq ov (eieio-oref object slot)) + ;; turn it into a list. + (unless (listp ov) + (setq ov (list ov))) + ;; Do the combination + (if (not (member item ov)) + (setq ov + (if append + (append ov (list item)) + (cons item ov))))) + ;; Set back into the slot. + (eieio-oset object slot ov))) + +(defun object-remove-from-list (object slot item) + "In OBJECT's SLOT, remove occurrences of ITEM. +Deletion is done with `delete', which deletes by side effect +and comparisons are done with `equal'. +If SLOT is unbound, do nothing." + (if (not (slot-boundp object slot)) + nil + (eieio-oset object slot (delete item (eieio-oref object slot))))) + +;;; EIEIO internal search functions +;; +(defun eieio-slot-originating-class-p (start-class slot) + "Return Non-nil if START-CLASS is the first class to define SLOT. +This is for testing if `scoped-class' is the class that defines SLOT +so that we can protect private slots." + (let ((par (class-parents start-class)) + (ret t)) + (if (not par) + t + (while (and par ret) + (if (intern-soft (symbol-name slot) + (aref (class-v (car par)) + class-symbol-obarray)) + (setq ret nil)) + (setq par (cdr par))) + ret))) + +(defun eieio-slot-name-index (class obj slot) + "In CLASS for OBJ find the index of the named SLOT. +The slot is a symbol which is installed in CLASS by the `defclass' +call. OBJ can be nil, but if it is an object, and the slot in question +is protected, access will be allowed if obj is a child of the currently +`scoped-class'. +If SLOT is the value created with :initarg instead, +reverse-lookup that name, and recurse with the associated slot value." + ;; Removed checks to outside this call + (let* ((fsym (intern-soft (symbol-name slot) + (aref (class-v class) + class-symbol-obarray))) + (fsi (if (symbolp fsym) (symbol-value fsym) nil))) + (if (integerp fsi) + (cond + ((not (get fsym 'protection)) + (+ 3 fsi)) + ((and (eq (get fsym 'protection) 'protected) + scoped-class + (or (child-of-class-p class scoped-class) + (and (eieio-object-p obj) + (child-of-class-p class (object-class obj))))) + (+ 3 fsi)) + ((and (eq (get fsym 'protection) 'private) + (or (and scoped-class + (eieio-slot-originating-class-p scoped-class slot)) + eieio-initializing-object)) + (+ 3 fsi)) + (t nil)) + (let ((fn (eieio-initarg-to-attribute class slot))) + (if fn (eieio-slot-name-index class obj fn) nil))))) + +(defun eieio-class-slot-name-index (class slot) + "In CLASS find the index of the named SLOT. +The slot is a symbol which is installed in CLASS by the `defclass' +call. If SLOT is the value created with :initarg instead, +reverse-lookup that name, and recurse with the associated slot value." + ;; This will happen less often, and with fewer slots. Do this the + ;; storage cheap way. + (let* ((a (aref (class-v class) class-class-allocation-a)) + (l1 (length a)) + (af (memq slot a)) + (l2 (length af))) + ;; Slot # is length of the total list, minus the remaining list of + ;; the found slot. + (if af (- l1 l2)))) + +;;; CLOS generics internal function handling +;; +(defvar eieio-generic-call-methodname nil + "When using `call-next-method', provides a context on how to do it.") +(defvar eieio-generic-call-arglst nil + "When using `call-next-method', provides a context for parameters.") +(defvar eieio-generic-call-key nil + "When using `call-next-method', provides a context for the current key. +Keys are a number representing :before, :primary, and :after methods.") +(defvar eieio-generic-call-next-method-list nil + "When executing a PRIMARY or STATIC method, track the 'next-method'. +During executions, the list is first generated, then as each next method +is called, the next method is popped off the stack.") + +(defvar eieio-pre-method-execution-hooks nil + "*Hooks run just before a method is executed. +The hook function must accept on argument, this list of forms +about to be executed.") + +(defun eieio-generic-call (method args) + "Call METHOD with ARGS. +ARGS provides the context on which implementation to use. +This should only be called from a generic function." + ;; We must expand our arguments first as they are always + ;; passed in as quoted symbols + (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) + (eieio-generic-call-methodname method) + (eieio-generic-call-arglst args) + (firstarg nil) + (primarymethodlist nil)) + ;; get a copy + (setq newargs args + firstarg (car newargs)) + ;; Is the class passed in autoloaded? + ;; Since class names are also constructors, they can be autoloaded + ;; via the autoload command. Check for this, and load them in. + ;; It's ok if it doesn't turn out to be a class. Probably want that + ;; function loaded anyway. + (if (and (symbolp firstarg) + (fboundp firstarg) + (listp (symbol-function firstarg)) + (eq 'autoload (car (symbol-function firstarg)))) + (load (nth 1 (symbol-function firstarg)))) + ;; Determine the class to use. + (cond ((eieio-object-p firstarg) + (setq mclass (object-class-fast firstarg))) + ((class-p firstarg) + (setq mclass firstarg)) + ) + ;; Make sure the class is a valid class + ;; mclass can be nil (meaning a generic for should be used. + ;; mclass cannot have a value that is not a class, however. + (when (and (not (null mclass)) (not (class-p mclass))) + (error "Cannot dispatch method %S on class %S" + method mclass) + ) + ;; Now create a list in reverse order of all the calls we have + ;; make in order to successfully do this right. Rules: + ;; 1) Only call generics if scoped-class is not defined + ;; This prevents multiple calls in the case of recursion + ;; 2) Only call static if this is a static method. + ;; 3) Only call specifics if the definition allows for them. + ;; 4) Call in order based on :before, :primary, and :after + (when (eieio-object-p firstarg) + ;; Non-static calls do all this stuff. + + ;; :after methods + (setq tlambdas + (if mclass + (eieiomt-method-list method method-after mclass) + (list (eieio-generic-form method method-after nil))) + ;;(or (and mclass (eieio-generic-form method method-after mclass)) + ;; (eieio-generic-form method method-after nil)) + ) + (setq lambdas (append tlambdas lambdas) + keys (append (make-list (length tlambdas) method-after) keys)) + + ;; :primary methods + (setq tlambdas + (or (and mclass (eieio-generic-form method method-primary mclass)) + (eieio-generic-form method method-primary nil))) + (when tlambdas + (setq lambdas (cons tlambdas lambdas) + keys (cons method-primary keys) + primarymethodlist + (eieiomt-method-list method method-primary mclass))) + + ;; :before methods + (setq tlambdas + (if mclass + (eieiomt-method-list method method-before mclass) + (list (eieio-generic-form method method-before nil))) + ;;(or (and mclass (eieio-generic-form method method-before mclass)) + ;; (eieio-generic-form method method-before nil)) + ) + (setq lambdas (append tlambdas lambdas) + keys (append (make-list (length tlambdas) method-before) keys)) + ) + + ;; If there were no methods found, then there could be :static methods. + (when (not lambdas) + (setq tlambdas + (eieio-generic-form method method-static mclass)) + (setq lambdas (cons tlambdas lambdas) + keys (cons method-static keys) + primarymethodlist ;; Re-use even with bad name here + (eieiomt-method-list method method-static mclass))) + + (run-hook-with-args 'eieio-pre-method-execution-hooks + primarymethodlist) + + ;; Now loop through all occurances forms which we must execute + ;; (which are happily sorted now) and execute them all! + (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) + (while lambdas + (if (car lambdas) + (let* ((scoped-class (cdr (car lambdas))) + (eieio-generic-call-key (car keys)) + (has-return-val + (or (= eieio-generic-call-key method-primary) + (= eieio-generic-call-key method-static))) + (eieio-generic-call-next-method-list + ;; Use the cdr, as the first element is the fcn + ;; we are calling right now. + (when has-return-val (cdr primarymethodlist))) + ) + (setq found t) + ;;(setq rval (apply (car (car lambdas)) newargs)) + (setq lastval (apply (car (car lambdas)) newargs)) + (when has-return-val + (setq rval lastval + rvalever t)) + )) + (setq lambdas (cdr lambdas) + keys (cdr keys))) + (if (not found) + (if (eieio-object-p (car args)) + (setq rval (apply 'no-applicable-method (car args) method args) + rvalever t) + (signal + 'no-method-definition + (list method args)))) + ;; Right Here... it could be that lastval is returned when + ;; rvalever is nil. Is that right? + rval))) + +(defun eieio-generic-call-primary-only (method args) + "Call METHOD with ARGS for methods with only :PRIMARY implementations. +ARGS provides the context on which implementation to use. +This should only be called from a generic function. + +This method is like `eieio-generic-call', but only +implementations in the :PRIMARY slot are queried. After many +years of use, it appears that over 90% of methods in use +have :PRIMARY implementations only. We can therefore optimize +for this common case to improve performance." + ;; We must expand our arguments first as they are always + ;; passed in as quoted symbols + (let ((newargs nil) (mclass nil) (lambdas nil) + (eieio-generic-call-methodname method) + (eieio-generic-call-arglst args) + (firstarg nil) + (primarymethodlist nil) + ) + ;; get a copy + (setq newargs args + firstarg (car newargs)) + + ;; Determine the class to use. + (cond ((eieio-object-p firstarg) + (setq mclass (object-class-fast firstarg))) + ((not firstarg) + (error "Method %s called on nil" method)) + ((not (eieio-object-p firstarg)) + (error "Primary-only method %s called on something not an object" method)) + (t + (error "EIEIO Error: Improperly classified method %s as primary only" + method) + )) + ;; Make sure the class is a valid class + ;; mclass can be nil (meaning a generic for should be used. + ;; mclass cannot have a value that is not a class, however. + (when (null mclass) + (error "Cannot dispatch method %S on class %S" method mclass) + ) + + ;; :primary methods + (setq lambdas (eieio-generic-form method method-primary mclass)) + (setq primarymethodlist ;; Re-use even with bad name here + (eieiomt-method-list method method-primary mclass)) + + ;; Now loop through all occurances forms which we must execute + ;; (which are happily sorted now) and execute them all! + (let* ((rval nil) (lastval nil) (rvalever nil) + (scoped-class (cdr lambdas)) + (eieio-generic-call-key method-primary) + ;; Use the cdr, as the first element is the fcn + ;; we are calling right now. + (eieio-generic-call-next-method-list (cdr primarymethodlist)) + ) + + (if (or (not lambdas) (not (car lambdas))) + + ;; No methods found for this impl... + (if (eieio-object-p (car args)) + (setq rval (apply 'no-applicable-method (car args) method args) + rvalever t) + (signal + 'no-method-definition + (list method args))) + + ;; Do the regular implementation here. + + (run-hook-with-args 'eieio-pre-method-execution-hooks + lambdas) + + (setq lastval (apply (car lambdas) newargs)) + (setq rval lastval + rvalever t) + ) + + ;; Right Here... it could be that lastval is returned when + ;; rvalever is nil. Is that right? + rval))) + +(defun eieiomt-method-list (method key class) + "Return an alist list of methods lambdas. +METHOD is the method name. +KEY represents either :before, or :after methods. +CLASS is the starting class to search from in the method tree. +If CLASS is nil, then an empty list of methods should be returned." + ;; Note: eieiomt - the MT means MethodTree. See more comments below + ;; for the rest of the eieiomt methods. + (let ((lambdas nil) + (mclass (list class))) + (while mclass + ;; Note: a nil can show up in the class list once we start + ;; searching through the method tree. + (when (car mclass) + ;; lookup the form to use for the PRIMARY object for the next level + (let ((tmpl (eieio-generic-form method key (car mclass)))) + (when (or (not lambdas) + ;; This prevents duplicates coming out of the + ;; class method optimizer. Perhaps we should + ;; just not optimize before/afters? + (not (eq (car tmpl) (car (car lambdas))))) + (setq lambdas (cons tmpl lambdas)) + (if (null (car lambdas)) + (setq lambdas (cdr lambdas)))))) + ;; Add new classes to mclass. Since our input might not be a class + ;; protect against that. + (if (car mclass) + ;; If there is a class, append any methods it may provide + ;; to the remainder of the class list. + (let ((io (class-method-invocation-order (car mclass)))) + (if (eq io :depth-first) + ;; Depth first. + (setq mclass (append (eieiomt-next (car mclass)) (cdr mclass))) + ;; Breadth first. + (setq mclass (append (cdr mclass) (eieiomt-next (car mclass))))) + ) + ;; Advance to next entry in mclass if it is nil. + (setq mclass (cdr mclass))) + ) + (if (eq key method-after) + lambdas + (nreverse lambdas)))) + +(defun next-method-p () + "Non-nil if there is a next method. +Returns a list of lambda expressions which is the `next-method' +order." + eieio-generic-call-next-method-list) + +(defun call-next-method (&rest replacement-args) + "Call the superclass method from a subclass method. +The superclass method is specified in the current method list, +and is called the next method. + +If REPLACEMENT-ARGS is non-nil, then use them instead of +`eieio-generic-call-arglst'. The generic arg list are the +arguments passed in at the top level. + +Use `next-method-p' to find out if there is a next method to call." + (if (not scoped-class) + (error "Call-next-method not called within a class specific method")) + (if (and (/= eieio-generic-call-key method-primary) + (/= eieio-generic-call-key method-static)) + (error "Cannot `call-next-method' except in :primary or :static methods") + ) + (let ((newargs (or replacement-args eieio-generic-call-arglst)) + (next (car eieio-generic-call-next-method-list)) + ) + (if (or (not next) (not (car next))) + (apply 'no-next-method (car newargs) (cdr newargs)) + (let* ((eieio-generic-call-next-method-list + (cdr eieio-generic-call-next-method-list)) + (scoped-class (cdr next)) + (fcn (car next)) + ) + (apply fcn newargs) + )))) + +;;; +;; eieio-method-tree : eieiomt- +;; +;; Stored as eieio-method-tree in property list of a generic method +;; +;; (eieio-method-tree . [BEFORE PRIMARY AFTER +;; genericBEFORE genericPRIMARY genericAFTER]) +;; and +;; (eieio-method-obarray . [BEFORE PRIMARY AFTER +;; genericBEFORE genericPRIMARY genericAFTER]) +;; where the association is a vector. +;; (aref 0 -- all static methods. +;; (aref 1 -- all methods classified as :before +;; (aref 2 -- all methods classified as :primary +;; (aref 3 -- all methods classified as :after +;; (aref 4 -- a generic classified as :before +;; (aref 5 -- a generic classified as :primary +;; (aref 6 -- a generic classified as :after +;; +(defvar eieiomt-optimizing-obarray nil + "While mapping atoms, this contain the obarray being optimized.") + +(defun eieiomt-install (method-name) + "Install the method tree, and obarray onto METHOD-NAME. +Do not do the work if they already exist." + (let ((emtv (get method-name 'eieio-method-tree)) + (emto (get method-name 'eieio-method-obarray))) + (if (or (not emtv) (not emto)) + (progn + (setq emtv (put method-name 'eieio-method-tree + (make-vector method-num-slots nil)) + emto (put method-name 'eieio-method-obarray + (make-vector method-num-slots nil))) + (aset emto 0 (make-vector 11 0)) + (aset emto 1 (make-vector 11 0)) + (aset emto 2 (make-vector 41 0)) + (aset emto 3 (make-vector 11 0)) + )))) + +(defun eieiomt-add (method-name method key class) + "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. +METHOD-NAME is the name created by a call to `defgeneric'. +METHOD are the forms for a given implementation. +KEY is an integer (see comment in eieio.el near this function) which +is associated with the :static :before :primary and :after tags. +It also indicates if CLASS is defined or not. +CLASS is the class this method is associated with." + (if (or (> key method-num-slots) (< key 0)) + (error "Eieiomt-add: method key error!")) + (let ((emtv (get method-name 'eieio-method-tree)) + (emto (get method-name 'eieio-method-obarray))) + ;; Make sure the method tables are available. + (if (or (not emtv) (not emto)) + (error "Programmer error: eieiomt-add")) + ;; only add new cells on if it doesn't already exist! + (if (assq class (aref emtv key)) + (setcdr (assq class (aref emtv key)) method) + (aset emtv key (cons (cons class method) (aref emtv key)))) + ;; Add function definition into newly created symbol, and store + ;; said symbol in the correct obarray, otherwise use the + ;; other array to keep this stuff + (if (< key method-num-lists) + (let ((nsym (intern (symbol-name class) (aref emto key)))) + (fset nsym method))) + ;; Now optimize the entire obarray + (if (< key method-num-lists) + (let ((eieiomt-optimizing-obarray (aref emto key))) + ;; @todo - Is this overkill? Should we just clear the symbol? + (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) + )) + +(defun eieiomt-next (class) + "Return the next parent class for CLASS. +If CLASS is a superclass, return variable `eieio-default-superclass'. If CLASS +is variable `eieio-default-superclass' then return nil. This is different from +function `class-parent' as class parent returns nil for superclasses. This +function performs no type checking!" + ;; No type-checking because all calls are made from functions which + ;; are safe and do checking for us. + (or (class-parents-fast class) + (if (eq class 'eieio-default-superclass) + nil + '(eieio-default-superclass)))) + +(defun eieiomt-sym-optimize (s) + "Find the next class above S which has a function body for the optimizer." + ;; (message "Optimizing %S" s) + (let* ((es (intern-soft (symbol-name s))) ;external symbol of class + (io (class-method-invocation-order es)) + (ov nil) + (cont t)) + ;; This converts ES from a single symbol to a list of parent classes. + (setq es (eieiomt-next es)) + ;; Loop over ES, then it's children individually. + ;; We can have multiple hits only at one level of the parent tree. + (while (and es cont) + (setq ov (intern-soft (symbol-name (car es)) eieiomt-optimizing-obarray)) + (if (fboundp ov) + (progn + (set s ov) ;store ov as our next symbol + (setq cont nil)) + (if (eq io :depth-first) + ;; Pre-pend the subclasses of (car es) so we get + ;; DEPTH FIRST optimization. + (setq es (append (eieiomt-next (car es)) (cdr es))) + ;; Else, we are breadth first. + ;; (message "Class %s is breadth first" es) + (setq es (append (cdr es) (eieiomt-next (car es)))) + ))) + ;; If there is no nearest call, then set our value to nil + (if (not es) (set s nil)) + )) + +(defun eieio-generic-form (method key class) + "Return the lambda form belonging to METHOD using KEY based upon CLASS. +If CLASS is not a class then use `generic' instead. If class has no +form, but has a parent class, then trace to that parent class. The +first time a form is requested from a symbol, an optimized path is +memoized for future faster use." + (let ((emto (aref (get method 'eieio-method-obarray) + (if class key (+ key 3))))) + (if (class-p class) + ;; 1) find our symbol + (let ((cs (intern-soft (symbol-name class) emto))) + (if (not cs) + ;; 2) If there isn't one, then make one. + ;; This can be slow since it only occurs once + (progn + (setq cs (intern (symbol-name class) emto)) + ;; 2.1) Cache it's nearest neighbor with a quick optimize + ;; which should only occur once for this call ever + (let ((eieiomt-optimizing-obarray emto)) + (eieiomt-sym-optimize cs)))) + ;; 3) If it's bound return this one. + (if (fboundp cs) + (cons cs (aref (class-v class) class-symbol)) + ;; 4) If it's not bound then this variable knows something + (if (symbol-value cs) + (progn + ;; 4.1) This symbol holds the next class in it's value + (setq class (symbol-value cs) + cs (intern-soft (symbol-name class) emto)) + ;; 4.2) The optimizer should always have chosen a + ;; function-symbol + ;;(if (fboundp cs) + (cons cs (aref (class-v (intern (symbol-name class))) + class-symbol)) + ;;(error "EIEIO optimizer: erratic data loss!")) + ) + ;; There never will be a funcall... + nil))) + ;; for a generic call, what is a list, is the function body we want. + (let ((emtl (aref (get method 'eieio-method-tree) + (if class key (+ key 3))))) + (if emtl + ;; The car of EMTL is supposed to be a class, which in this + ;; case is nil, so skip it. + (cons (cdr (car emtl)) nil) + nil))))) + +;;; +;; Way to assign slots based on a list. Used for constructors, or +;; even resetting an object at run-time +;; +(defun eieio-set-defaults (obj &optional set-all) + "Take object OBJ, and reset all slots to their defaults. +If SET-ALL is non-nil, then when a default is nil, that value is +reset. If SET-ALL is nil, the slots are only reset if the default is +not nil." + (let ((scoped-class (aref obj object-class)) + (eieio-initializing-object t) + (pub (aref (class-v (aref obj object-class)) class-public-a))) + (while pub + (let ((df (eieio-oref-default obj (car pub)))) + (if (and (listp df) (eq (car df) 'lambda-default)) + (progn + (setq df (copy-sequence df)) + (setcar df 'lambda))) + (if (or df set-all) + (eieio-oset obj (car pub) df))) + (setq pub (cdr pub))))) + +(defun eieio-initarg-to-attribute (class initarg) + "For CLASS, convert INITARG to the actual attribute name. +If there is no translation, pass it in directly (so we can cheat if +need be.. May remove that later...)" + (let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples)))) + (if tuple + (cdr tuple) + nil))) + +(defun eieio-attribute-to-initarg (class attribute) + "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. +This is usually a symbol that starts with `:'." + (let ((tuple (rassoc attribute (aref (class-v class) class-initarg-tuples)))) + (if tuple + (car tuple) + nil))) + + +;;; Here are some special types of errors +;; +(intern "no-method-definition") +(put 'no-method-definition 'error-conditions '(no-method-definition error)) +(put 'no-method-definition 'error-message "No method definition") + +(intern "no-next-method") +(put 'no-next-method 'error-conditions '(no-next-method error)) +(put 'no-next-method 'error-message "No next method") + +(intern "invalid-slot-name") +(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) +(put 'invalid-slot-name 'error-message "Invalid slot name") + +(intern "invalid-slot-type") +(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) +(put 'invalid-slot-type 'error-message "Invalid slot type") + +(intern "unbound-slot") +(put 'unbound-slot 'error-conditions '(unbound-slot error nil)) +(put 'unbound-slot 'error-message "Unbound slot") + +;;; Here are some CLOS items that need the CL package +;; + +(defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store)) +(defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store)) + +;; The below setf method was written by Arnd Kohrs <kohrs@acm.org> +(define-setf-method oref (obj slot) + (let ((obj-temp (gensym)) + (slot-temp (gensym)) + (store-temp (gensym))) + (list (list obj-temp slot-temp) + (list obj `(quote ,slot)) + (list store-temp) + (list 'set-slot-value obj-temp slot-temp + store-temp) + (list 'slot-value obj-temp slot-temp)))) + + +;;; +;; We want all objects created by EIEIO to have some default set of +;; behaviours so we can create object utilities, and allow various +;; types of error checking. To do this, create the default EIEIO +;; class, and when no parent class is specified, use this as the +;; default. (But don't store it in the other classes as the default, +;; allowing for transparent support.) +;; + +(defclass eieio-default-superclass nil + nil + "Default parent class for classes with no specified parent class. +Its slots are automatically adopted by classes with no specified +parents. This class is not stored in the `parent' slot of a class vector." + :abstract t) + +(defalias 'standard-class 'eieio-default-superclass) + +(defgeneric constructor (class newname &rest slots) + "Default constructor for CLASS `eieio-defualt-superclass'.") + +(defmethod constructor :static + ((class eieio-default-superclass) newname &rest slots) + "Default constructor for CLASS `eieio-defualt-superclass'. +NEWNAME is the name to be given to the constructed object. +SLOTS are the initialization slots used by `shared-initialize'. +This static method is called when an object is constructed. +It allocates the vector used to represent an EIEIO object, and then +calls `shared-initialize' on that object." + (let* ((new-object (copy-sequence (aref (class-v class) + class-default-object-cache)))) + ;; Update the name for the newly created object. + (aset new-object object-name newname) + ;; Call the initialize method on the new object with the slots + ;; that were passed down to us. + (initialize-instance new-object slots) + ;; Return the created object. + new-object)) + +(defgeneric shared-initialize (obj slots) + "Set slots of OBJ with SLOTS which is a list of name/value pairs. +Called from the constructor routine.") + +(defmethod shared-initialize ((obj eieio-default-superclass) slots) + "Set slots of OBJ with SLOTS which is a list of name/value pairs. +Called from the constructor routine." + (let ((scoped-class (aref obj object-class))) + (while slots + (let ((rn (eieio-initarg-to-attribute (object-class-fast obj) + (car slots)))) + (if (not rn) + (slot-missing obj (car slots) 'oset (car (cdr slots))) + (eieio-oset obj rn (car (cdr slots))))) + (setq slots (cdr (cdr slots)))))) + +(defgeneric initialize-instance (this &optional slots) + "Constructs the new object THIS based on SLOTS.") + +(defmethod initialize-instance ((this eieio-default-superclass) + &optional slots) + "Constructs the new object THIS based on SLOTS. +SLOTS is a tagged list where odd numbered elements are tags, and +even numbered elements are the values to store in the tagged slot. If +you overload the `initialize-instance', there you will need to call +`shared-initialize' yourself, or you can call `call-next-method' to +have this constructor called automatically. If these steps are not +taken, then new objects of your class will not have their values +dynamically set from SLOTS." + ;; First, see if any of our defaults are `lambda', and + ;; re-evaluate them and apply the value to our slots. + (let* ((scoped-class (class-v (aref this object-class))) + (slot (aref scoped-class class-public-a)) + (defaults (aref scoped-class class-public-d))) + (while slot + (if (and (listp (car defaults)) + (eq 'lambda (car (car defaults)))) + (progn + (message "Warning: Evaluation of `lambda' initform will be obsoleted in the next version of EIEIO.") + (eieio-oset this (car slot) (funcall (car defaults))))) + (setq slot (cdr slot) + defaults (cdr defaults)))) + ;; Shared initialize will parse our slots for us. + (shared-initialize this slots)) + +(defgeneric slot-missing (object slot-name operation &optional new-value) + "Method invoked when an attempt to access a slot in OBJECT fails.") + +(defmethod slot-missing ((object eieio-default-superclass) slot-name + operation &optional new-value) + "Method invoked when an attempt to access a slot in OBJECT fails. +SLOT-NAME is the name of the failed slot, OPERATION is the type of access +that was requested, and optional NEW-VALUE is the value that was desired +to be set. + +This method is called from `oref', `oset', and other functions which +directly reference slots in EIEIO objects." + (signal 'invalid-slot-name (list (object-name object) + slot-name))) + +(defgeneric slot-unbound (object class slot-name fn) + "Slot unbound is invoked during an attempt to reference an unbound slot.") + +(defmethod slot-unbound ((object eieio-default-superclass) + class slot-name fn) + "Slot unbound is invoked during an attempt to reference an unbound slot. +OBJECT is the instance of the object being reference. CLASS is the +class of OBJECT, and SLOT-NAME is the offending slot. This function +throws the signal `unbound-slot'. You can overload this function and +return the value to use in place of the unbound value. +Argument FN is the function signaling this error. +Use `slot-boundp' to determine if a slot is bound or not. + +In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but +EIEIO can only dispatch on the first argument, so the first two are swapped." + (signal 'unbound-slot (list (class-name class) (object-name object) + slot-name fn))) + +(defgeneric no-applicable-method (object method &rest args) + "Called if there are no implementations for OBJECT in METHOD.") + +(defmethod no-applicable-method ((object eieio-default-superclass) + method &rest args) + "Called if there are no implementations for OBJECT in METHOD. +OBJECT is the object which has no method implementation. +ARGS are the arguments that were passed to METHOD. + +Implement this for a class to block this signal. The return +value becomes the return value of the original method call." + (signal 'no-method-definition (list method (object-name object))) + ) + +(defgeneric no-next-method (object &rest args) +"Called from `call-next-method' when no additional methods are available.") + +(defmethod no-next-method ((object eieio-default-superclass) + &rest args) + "Called from `call-next-method' when no additional methods are available. +OBJECT is othe object being called on `call-next-method'. +ARGS are the arguments it is called by. +This method signals `no-next-method' by default. Override this +method to not throw an error, and it's return value becomes the +return value of `call-next-method'." + (signal 'no-next-method (list (object-name object) args)) +) + +(defgeneric clone (obj &rest params) + "Make a copy of OBJ, and then supply PARAMS. +PARAMS is a parameter list of the same form used by `initialize-instance'. + +When overloading `clone', be sure to call `call-next-method' +first and modify the returned object.") + +(defmethod clone ((obj eieio-default-superclass) &rest params) + "Make a copy of OBJ, and then apply PARAMS." + (let ((nobj (copy-sequence obj)) + (nm (aref obj object-name)) + (passname (and params (stringp (car params)))) + (num 1)) + (if params (shared-initialize nobj (if passname (cdr params) params))) + (if (not passname) + (save-match-data + (if (string-match "-\\([0-9]+\\)" nm) + (setq num (1+ (string-to-number (match-string 1 nm))) + nm (substring nm 0 (match-beginning 0)))) + (aset nobj object-name (concat nm "-" (int-to-string num)))) + (aset nobj object-name (car params))) + nobj)) + +(defgeneric destructor (this &rest params) + "Destructor for cleaning up any dynamic links to our object.") + +(defmethod destructor ((this eieio-default-superclass) &rest params) + "Destructor for cleaning up any dynamic links to our object. +Argument THIS is the object being destroyed. PARAMS are additional +ignored parameters." + ;; No cleanup... yet. + ) + +(defgeneric object-print (this &rest strings) + "Pretty printer for object THIS. Call function `object-name' with STRINGS. + +It is sometimes useful to put a summary of the object into the +default #<notation> string when using eieio browsing tools. +Implement this method to customize the summary.") + +(defmethod object-print ((this eieio-default-superclass) &rest strings) + "Pretty printer for object THIS. Call function `object-name' with STRINGS. +The default method for printing object THIS is to use the +function `object-name'. + +It is sometimes useful to put a summary of the object into the +default #<notation> string when using eieio browsing tools. + +Implement this function and specify STRINGS in a call to +`call-next-method' to provide additional summary information. +When passing in extra strings from child classes, always remember +to prepend a space." + (object-name this (apply 'concat strings))) + +(defvar eieio-print-depth 0 + "When printing, keep track of the current indentation depth.") + +(defgeneric object-write (this &optional comment) + "Write out object THIS to the current stream. +Optional COMMENDS will add comments to the beginning of the output.") + +(defmethod object-write ((this eieio-default-superclass) &optional comment) + "Write object THIS out to the current stream. +This writes out the vector version of this object. Complex and recursive +object are discouraged from being written. + If optional COMMENT is non-nil, include comments when outputting +this object." + (when comment + (princ ";; Object ") + (princ (object-name-string this)) + (princ "\n") + (princ comment) + (princ "\n")) + (let* ((cl (object-class this)) + (cv (class-v cl))) + ;; Now output readable lisp to recreate this object + ;; It should look like this: + ;; (<constructor> <name> <slot> <slot> ... ) + ;; Each slot's slot is writen using its :writer. + (princ (make-string (* eieio-print-depth 2) ? )) + (princ "(") + (princ (symbol-name (class-constructor (object-class this)))) + (princ " \"") + (princ (object-name-string this)) + (princ "\"\n") + ;; Loop over all the public slots + (let ((publa (aref cv class-public-a)) + (publd (aref cv class-public-d)) + (publp (aref cv class-public-printer)) + (eieio-print-depth (1+ eieio-print-depth))) + (while publa + (when (slot-boundp this (car publa)) + (let ((i (class-slot-initarg cl (car publa))) + (v (eieio-oref this (car publa))) + ) + (unless (or (not i) (equal v (car publd))) + (princ (make-string (* eieio-print-depth 2) ? )) + (princ (symbol-name i)) + (princ " ") + (if (car publp) + ;; Use our public printer + (funcall (car publp) v) + ;; Use our generic override prin1 function. + (eieio-override-prin1 v)) + (princ "\n")))) + (setq publa (cdr publa) publd (cdr publd) + publp (cdr publp))) + (princ (make-string (* eieio-print-depth 2) ? ))) + (princ ")\n"))) + +(defun eieio-override-prin1 (thing) + "Perform a prin1 on THING taking advantage of object knowledge." + (cond ((eieio-object-p thing) + (object-write thing)) + ((listp thing) + (eieio-list-prin1 thing)) + ((class-p thing) + (princ (class-name thing))) + ((symbolp thing) + (princ (concat "'" (symbol-name thing)))) + (t (prin1 thing)))) + +(defun eieio-list-prin1 (list) + "Display LIST where list may contain objects." + (if (not (eieio-object-p (car list))) + (progn + (princ "'") + (prin1 list)) + (princ "(list ") + (if (eieio-object-p (car list)) (princ "\n ")) + (while list + (if (eieio-object-p (car list)) + (object-write (car list)) + (princ "'") + (prin1 (car list))) + (princ " ") + (setq list (cdr list))) + (princ (make-string (* eieio-print-depth 2) ? )) + (princ ")"))) + + +;;; Unimplemented functions from CLOS +;; +(defun change-class (obj class) + "Change the class of OBJ to type CLASS. +This may create or delete slots, but does not affect the return value +of `eq'." + (error "Eieio: `change-class' is unimplemented")) + +) + + +;;; Interfacing with edebug +;; +(defun eieio-edebug-prin1-to-string (object &optional noescape) + "Display eieio OBJECT in fancy format. Overrides the edebug default. +Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." + (cond ((class-p object) (class-name object)) + ((eieio-object-p object) (object-print object)) + ((and (listp object) (or (class-p (car object)) + (eieio-object-p (car object)))) + (concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")")) + (t (prin1-to-string object noescape)))) + +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec defmethod + (&define ; this means we are defining something + [&or name ("setf" :name setf name)] + ;; ^^ This is the methods symbol + [ &optional symbolp ] ; this is key :before etc + list ; arguments + [ &optional stringp ] ; documentation string + def-body ; part to be debugged + )) + ;; The rest of the macros + (def-edebug-spec oref (form quote)) + (def-edebug-spec oref-default (form quote)) + (def-edebug-spec oset (form quote form)) + (def-edebug-spec oset-default (form quote form)) + (def-edebug-spec class-v form) + (def-edebug-spec class-p form) + (def-edebug-spec eieio-object-p form) + (def-edebug-spec class-constructor form) + (def-edebug-spec generic-p form) + (def-edebug-spec with-slots (list list def-body)) + ;; I suspect this isn't the best way to do this, but when + ;; cust-print was used on my system all my objects + ;; appeared as "#1 =" which was not useful. This allows + ;; edebug to print my objects in the nice way they were + ;; meant to with `object-print' and `class-name' + ;; (defalias 'edebug-prin1-to-string 'eieio-edebug-prin1-to-string) + ) + ) + +(eval-after-load "cedet-edebug" + '(progn + (cedet-edebug-add-print-override '(class-p object) '(class-name object) ) + (cedet-edebug-add-print-override '(eieio-object-p object) '(object-print object) ) + (cedet-edebug-add-print-override '(and (listp object) + (or (class-p (car object)) (eieio-object-p (car object)))) + '(cedet-edebug-prin1-recurse object) ) + )) + +;;; Interfacing with imenu in emacs lisp mode +;; (Only if the expression is defined) +;; +(if (eval-when-compile (boundp 'list-imenu-generic-expression)) +(progn + +(defun eieio-update-lisp-imenu-expression () + "Examine `lisp-imenu-generic-expression' and modify it to find `defmethod'." + (let ((exp lisp-imenu-generic-expression)) + (while exp + ;; it's of the form '( ( title expr indx ) ... ) + (let* ((subcar (cdr (car exp))) + (substr (car subcar))) + (if (and (not (string-match "|method\\\\" substr)) + (string-match "|advice\\\\" substr)) + (setcar subcar + (replace-match "|advice\\|method\\" t t substr 0)))) + (setq exp (cdr exp))))) + +(eieio-update-lisp-imenu-expression) + +)) + +;;; Autoloading some external symbols, and hooking into the help system +;; + +(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "For buffers thrown into help mode, augment for eieio.") +(autoload 'eieio-browse "eieio-opt" "Create an object browser window" t) +(autoload 'eieio-describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t) +(autoload 'eieio-describe-constructor "eieio-opt" "Describe the constructor function FCN." t) +(autoload 'describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t) +(autoload 'eieio-describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t) +(autoload 'describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t) +(autoload 'eieiodoc-class "eieio-doc" "Create texinfo documentation about a class hierarchy." t) + +(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.") + +;; make sure this shows up after the help mode hook. +(add-hook 'temp-buffer-show-hook 'eieio-help-mode-augmentation-maybee t) +;; (require 'advice) +;; (defadvice describe-variable (around eieio-describe activate) +;; "Display the full documentation of FUNCTION (a symbol). +;; Returns the documentation as a string, also." +;; (if (class-p (ad-get-arg 0)) +;; (eieio-describe-class (ad-get-arg 0)) +;; ad-do-it)) + +;; (defadvice describe-function (around eieio-describe activate) +;; "Display the full documentation of VARIABLE (a symbol). +;; Returns the documentation as a string, also." +;; (if (generic-p (ad-get-arg 0)) +;; (eieio-describe-generic (ad-get-arg 0)) +;; (if (class-p (ad-get-arg 0)) +;; (eieio-describe-constructor (ad-get-arg 0)) +;; ad-do-it))) + +(provide 'eieio) +;;; eieio ends here