]> git.eshelyaron.com Git - emacs.git/commitdiff
Add files for the EIEIO library.
authorChong Yidong <cyd@stupidchicken.com>
Sat, 22 Aug 2009 04:12:52 +0000 (04:12 +0000)
committerChong Yidong <cyd@stupidchicken.com>
Sat, 22 Aug 2009 04:12:52 +0000 (04:12 +0000)
lisp/cedet/data-debug.el [new file with mode: 0644]
lisp/eieio/chart.el [new file with mode: 0644]
lisp/eieio/eieio-base.el [new file with mode: 0644]
lisp/eieio/eieio-comp.el [new file with mode: 0644]
lisp/eieio/eieio-custom.el [new file with mode: 0644]
lisp/eieio/eieio-datadebug.el [new file with mode: 0644]
lisp/eieio/eieio-doc.el [new file with mode: 0644]
lisp/eieio/eieio-opt.el [new file with mode: 0644]
lisp/eieio/eieio-speedbar.el [new file with mode: 0644]
lisp/eieio/eieio.el [new file with mode: 0644]

diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el
new file mode 100644 (file)
index 0000000..1f30ccd
--- /dev/null
@@ -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")
+    )
+  )
+
+\f
+;;; 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
diff --git a/lisp/eieio/chart.el b/lisp/eieio/chart.el
new file mode 100644 (file)
index 0000000..1da3528
--- /dev/null
@@ -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
diff --git a/lisp/eieio/eieio-base.el b/lisp/eieio/eieio-base.el
new file mode 100644 (file)
index 0000000..6bd09a7
--- /dev/null
@@ -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)))
+
+\f
+;;; 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)))
+
+\f
+;;; 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.
+
+\f
+;;; 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
diff --git a/lisp/eieio/eieio-comp.el b/lisp/eieio/eieio-comp.el
new file mode 100644 (file)
index 0000000..652d3e9
--- /dev/null
@@ -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
diff --git a/lisp/eieio/eieio-custom.el b/lisp/eieio/eieio-custom.el
new file mode 100644 (file)
index 0000000..71ebf79
--- /dev/null
@@ -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)
+
+\f
+;;; 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
diff --git a/lisp/eieio/eieio-datadebug.el b/lisp/eieio/eieio-datadebug.el
new file mode 100644 (file)
index 0000000..f9ec56d
--- /dev/null
@@ -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
diff --git a/lisp/eieio/eieio-doc.el b/lisp/eieio/eieio-doc.el
new file mode 100644 (file)
index 0000000..966c489
--- /dev/null
@@ -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
diff --git a/lisp/eieio/eieio-opt.el b/lisp/eieio/eieio-opt.el
new file mode 100644 (file)
index 0000000..db39909
--- /dev/null
@@ -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
diff --git a/lisp/eieio/eieio-speedbar.el b/lisp/eieio/eieio-speedbar.el
new file mode 100644 (file)
index 0000000..c6738f8
--- /dev/null
@@ -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))))))
+
+\f
+;;; 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))
+
+\f
+;;; 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)
+
+\f
+;;; 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)))))
+
+\f
+;;; 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))))
+
+\f
+;;; 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
diff --git a/lisp/eieio/eieio.el b/lisp/eieio/eieio.el
new file mode 100644 (file)
index 0000000..b68e911
--- /dev/null
@@ -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))
+
+  )
+
+\f
+;;;
+;; 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))
+
+\f
+;;; 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))
+
+\f
+;;; 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)))
+
+\f
+;;; 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)
+
+\f
+;;; 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)))))
+\f
+;;; 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))))
+\f
+;;; 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)
+       ))))
+\f
+;;;
+;; 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)))
+
+\f
+;;; 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))))
+
+\f
+;;;
+;; 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 ")")))
+
+\f
+;;; 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"))
+
+)
+
+\f
+;;; 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