Anonymous avatar Anonymous committed 52dea46

Sync eieio to version 0.16; sync semantic to version 1.3.3

Comments (0)

Files changed (18)

+2001-02-20  Steve Youngs  <youngs@xemacs.org>
+
+	* Import version 0.16.
+
 2001-02-17  Steve Youngs  <youngs@xemacs.org>
 
 	* Initial XEmacs Package - Author version 0.15.
 
 2) Add eieio's directory to your load path.
 
-   (add-to-list 'load-path "~/eieio-0.15")
+   (add-to-list 'load-path "~/eieio-X.XX")
 
    Be sure to replace the directory above with the actual path to
    where eieio was unpacked.  This will make sure the latest version
    of eieio superceeds any version already installed on your system.
 
 
+3) Upgrading EIEIO.
+
+   New versions of EIEIO can be found here:
+
+   http://cedet.sourceforge.net/eieio.shtml
 # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 # Boston, MA 02111-1307, USA.
 
-VERSION = 1.00
-AUTHOR_VERSION = 0.15
+VERSION = 1.01
+AUTHOR_VERSION = 0.16
 MAINTAINER = Eric Ludlam <zappo@gnu.org>
 PACKAGE = eieio
 PKG_TYPE = regular
 REQUIRES = eieio speedbar xemacs-base 
 CATEGORY = prog
 
-ELCS = chart.elc eieio-comp.elc eieio-custom.elc eieio-doc.elc \
-	eieio-opt.elc eieio-speedbar.elc eieio-tests.elc eieio.elc \
-	tree.elc
+ELCS = call-tree.elc chart.elc compare-strings.elc eieio-base.elc eieio-comp.elc \
+	eieio-custom.elc eieio-doc.elc eieio-opt.elc eieio-speedbar.elc \
+	eieio-tests.elc eieio.elc tree.elc
 
 INFO_FILES = $(PACKAGE).info
 TEXI_FILES = $(PACKAGE).texi

Makefile.upstream

 
 ede_FILES=Project.ede Makefile
 
+eieio_LISP=eieio.el eieio-comp.el eieio-opt.el eieio-custom.el eieio-doc.el eieio-base.el compare-strings.el
+EMACS=emacs
+examples_LISP=tree.el call-tree.el chart.el eieio-speedbar.el
+eieio_info_TEXINFOS=eieio.texi
+MAKEINFO=makeinfo
+test_LISP=eieio-tests.el
 Misc_MISC=INSTALL
-eieio_LISP=eieio.el eieio-custom.el eieio-opt.el eieio-comp.el eieio-doc.el
-EMACS=emacs
-eieio_info_INFOS=eieio.texi
-examples_LISP=tree.el chart.el eieio-speedbar.el eieio-tests.el
-VERSION=$(shell grep "Version: " eieio.el | cut -d" " -f3)
+VERSION=0.16
 DISTDIR=eieio-$(VERSION)
 top_builddir = 
 
 DEP_FILES=.deps/.P
 
-all: eieio eieio.info examples
+all: eieio examples eieio.info
 
 DEPS_MAGIC := $(shell mkdir .deps > /dev/null 2>&1 || :)
 -include $(DEP_FILES)
 
-%.o: %.c
-	@echo '$(COMPILE) -c $<'; \
-	$(COMPILE) -Wp,-MD,.deps/$(*F).P -c $<
+eieio: $(eieio_LISP)
+	@echo "(add-to-list 'load-path nil)" > $@-compile-script
+	@for loadpath in "${LOADPATH}"; do \
+	   echo "(add-to-list 'load-path \"$$loadpath\")" >> $@-compile-script; \
+	 done
+	@echo "(setq debug-on-error t)" >> $@-compile-script
+	$(EMACS) -batch -l $@-compile-script -f batch-byte-compile $^
+
+examples: $(examples_LISP)
+	@echo "(add-to-list 'load-path nil)" > $@-compile-script
+	@for loadpath in "${LOADPATH}"; do \
+	   echo "(add-to-list 'load-path \"$$loadpath\")" >> $@-compile-script; \
+	 done
+	@echo "(setq debug-on-error t)" >> $@-compile-script
+	$(EMACS) -batch -l $@-compile-script -f batch-byte-compile $^
+
+eieio.info: $(eieio_info_TEXINFOS)
+	makeinfo -o $@ $<
+
+test: $(test_LISP)
+	@echo "(add-to-list 'load-path nil)" > $@-compile-script
+	@for loadpath in "${LOADPATH}"; do \
+	   echo "(add-to-list 'load-path \"$$loadpath\")" >> $@-compile-script; \
+	 done
+	@echo "(setq debug-on-error t)" >> $@-compile-script
+	$(EMACS) -batch -l $@-compile-script -f batch-byte-compile $^
 
 Misc: 
 	@
 
-eieio:
-	@echo "(add-to-list 'load-path \"$(PWD)\")" > eieio-compile-script
-	@echo "(setq debug-on-error t)" >> eieio-compile-script
-	$(EMACS) -batch -l eieio-compile-script -f batch-byte-compile  $(eieio_LISP)
+tags: $(eieio_LISP) $(examples_LISP) $(eieio_info_TEXINFOS) $(test_LISP) $(Misc_MISC) 
+	etags $^
 
-eieio.info: $(eieio_info_INFOS)
-	makeinfo eieio.texi
-examples:
-	@echo "(add-to-list 'load-path \"$(PWD)\")" > examples-compile-script
-	@echo "(setq debug-on-error t)" >> examples-compile-script
-	$(EMACS) -batch -l examples-compile-script -f batch-byte-compile  $(examples_LISP)
 
 clean:
 	rm -f *.elc *.info
 dist:
 	rm -rf $(DISTDIR)
 	mkdir $(DISTDIR)
-	cp $(Misc_MISC) $(eieio_LISP) $(eieio_info_INFOS) $(examples_LISP) $(ede_FILES) $(DISTDIR)
+	cp $(eieio_LISP) $(examples_LISP) $(eieio_info_TEXINFOS) $(test_LISP) $(Misc_MISC) $(ede_FILES) $(DISTDIR)
 	tar -cvzf $(DISTDIR).tar.gz $(DISTDIR)
 	rm -rf $(DISTDIR)
 
-tags: $(Misc_MISC) $(eieio_LISP) $(eieio_info_INFOS) $(examples_LISP) 
-	etags $^
-
 Makefile: Project.ede
 	@echo Makefile is out of date!  It needs to be regenerated by EDE.
 	@false
-;; Object ede-proj-project
+;; Object eieio
 ;; EDE project file.
-(ede-proj-project "ede-proj-project"
+(ede-proj-project "eieio"
   :name "eieio"
-  :version "$(shell grep \"Version: \" eieio.el | cut -d\" \" -f3)"
+  :version "0.16"
   :file "Project.ede"
-  :targets (list   (ede-proj-target-makefile-miscelaneous "Misc"
-    :name "Misc"
-    :path ""
-    :source '("INSTALL")
-    :partofall 'nil
-    )
+  :targets (list 
    (ede-proj-target-elisp "eieio"
     :name "eieio"
     :path ""
-    :source '("eieio.el" "eieio-custom.el" "eieio-opt.el" "eieio-comp.el" "eieio-doc.el")
+    :source '("eieio.el" "eieio-comp.el" "eieio-opt.el" "eieio-custom.el" "eieio-doc.el" "eieio-base.el" "compare-strings.el")
+    :versionsource '("eieio.el")
+    )
+   (ede-proj-target-elisp "examples"
+    :name "examples"
+    :path ""
+    :source '("tree.el" "call-tree.el" "chart.el" "eieio-speedbar.el")
     )
    (ede-proj-target-makefile-info "eieio.info"
     :name "eieio.info"
     :path ""
     :source '("eieio.texi")
     )
-   (ede-proj-target-elisp "examples"
-    :name "examples"
+   (ede-proj-target-elisp "nil"
+    :name "test"
     :path ""
-    :source '("tree.el" "chart.el" "eieio-speedbar.el" "eieio-tests.el")
+    :source '("eieio-tests.el")
+    :partofall 'nil
+    )
+   (ede-proj-target-makefile-miscelaneous "Misc"
+    :name "Misc"
+    :path ""
+    :source '("INSTALL")
+    :partofall 'nil
     )
    )
   :configuration-variables 'nil
+;;; call-tree.el --- Uses tree mode to display a call tree of the
+;;                  give emacs lisp function.
+;;
+;; Copyright (C) 1996, 1998, 2001 Eric M. Ludlam
+;;
+;; Author: <zappo@gnu.ai.mit.edu>
+;; Version: 0.1
+;; RCS: $Id$
+;; Keywords: OO, tree, call-graph
+;;                                                                          
+;; This program 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 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 this program; if not, you can either send email to this
+;; program's author (see below) or write to:
+;;
+;;              The Free Software Foundation, Inc.
+;;              675 Mass Ave.
+;;              Cambridge, MA 02139, USA.
+;;
+;; Please send bug reports, etc. to zappo@gnu.org
+
+;;; Commentary:
+;;   This function allows the user to display a call tree for a
+;; given function.  Function symbols are expanded only if they are
+;; evaluated Lisp expressions.  Compiled functions and (of course)
+;; subroutines are not expanded.  Subroutines are not even listed in
+;; the tree as they are assumed to be in there.
+;;   This was created in the hopes that it would aid me in debugging
+;; things by being able to visualize the flow of control.  As a
+;; result, symbols are expanded multiple times, and recursion is
+;; removed (and assumed)
+;;
+
+(require 'tree)
+
+;;; Code:
+(defclass call-tree-node (tree-node)
+  ((symbol :initarg :symbol
+	   :initform nil)
+   )
+  "Class used to define a tree node representing a lisp function.
+This function is assumed to have been called from it's parent node")
+
+(defmethod edit ((tn call-tree-node))
+  "Action to take when middle mouse button is clicked."
+  (let* ((sym (oref tn symbol))
+	 (sff (locate-library (describe-function-find-file sym)))
+	 (sffs (if (string-match "\\.elc$" sff)
+		   (substring sff 0 (1- (length sff)))
+		 sff)))
+    (find-file sffs)
+    (goto-char (point-min))
+    (re-search-forward (concat "def\\(un\\|macro\\|method\\)\\s-+"
+			       (symbol-name sym) "\\s-+"))
+  ))
+
+(defmethod select ((tn call-tree-node))
+  "Action to take when first mouse is clicked."
+  (if (featurep 'eldoc)
+      (eldoc-print-fnsym-args (oref tn symbol))
+    (message "Clicked on node %s" (object-name tn))
+  ))
+
+(defun call-tree-new-node (func)
+  "Build a variable `call-tree-node' based on the function FUNC."
+  (call-tree-node (symbol-name func)
+		  :name (symbol-name func)
+		  :symbol func))
+
+(defun call-tree (func)
+  "Build a call tree to show all functions called by FUNC."
+  (interactive "aFunction: ")
+  (switch-to-buffer (tree-new-buffer (format "*CALL-TREE-%s*" func)))
+  (erase-buffer)
+  (let ((np (tree-set-root (call-tree-new-node func))))
+    (call-tree-grow np))
+  (tree-refresh-tree))
+
+(defun call-tree-grow (func)
+  "Decompose the function stored in the object FUNC and create children."
+  (let* ((fvv (symbol-function (oref func symbol)))
+	 (fv (if (and (listp fvv) (listp (cdr fvv))) (cdr (cdr fvv)) nil))
+	 (nnl nil))
+    (if (and fv (listp fv))
+	(progn
+	  ;; elimitate the doc-string
+	  (if (stringp (car fv)) (setq fv (cdr fv)))
+	  (call-tree-grow-recurse func fv)
+	  (setq nnl (oref func children))
+	  (while nnl
+	    (if (not (call-tree-recursive-p func (oref (car nnl) symbol)))
+		(call-tree-grow (car nnl)))
+	    (setq nnl (cdr nnl)))))))
+    
+(defun call-tree-grow-recurse (func forms)
+  "Recurse down FUNC's FORMS list adding tree nodes to func the whole way."
+  (if (and (symbolp (car forms)) (fboundp (car forms)))
+      (if (or (equal (car forms) 'macro))
+	  (setq forms nil)
+	(if (and (not (call-tree-duplicate func (car forms)))
+		 (not (subrp (symbol-function (car forms))))
+		 (not (and (symbolp (symbol-function (car forms)))
+			   (subrp (symbol-function
+				   (symbol-function (car forms)))))))
+	    (tree-add-child func (call-tree-new-node (car forms))))
+	(cond ((equal (car forms) 'let)
+	       (setq forms (cdr (cdr forms))))
+	      (t
+	       (setq forms (cdr forms))))))
+  (while (and forms (listp forms))
+    (if (and forms (listp forms) (listp (car forms)))
+	(call-tree-grow-recurse func (car forms)))
+    (setq forms (cdr forms)))
+  )
+
+(defun call-tree-duplicate (func newfunc)
+  "Scan siblings in FUNC to see if we already have it listed here.
+Argument NEWFUNC is a function I cannot devine at this time."
+  (let ((fp (oref func children)))
+    (while (and fp (not (eq (oref (car fp) symbol) newfunc)))
+      (setq fp (cdr fp)))
+    fp))
+      
+
+(defun call-tree-recursive-p (func newfunc)
+  "Scan parents of FUNC for occurance of NEWFUNC."
+  (let ((fp func))
+    (while (and fp (not (eq newfunc (oref fp symbol))))
+      (setq fp (oref fp parent)))
+    fp))
+
+(provide 'call-tree)
+
+;;; call-tree.el ends here
 ;;; chart.el --- Draw charts (bar charts, etc)
 
-;;; Copyright (C) 1996, 1998, 1999 Eric M. Ludlam
+;;; Copyright (C) 1996, 1998, 1999, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
-;; Version: 0.1
+;; Version: 0.2
 ;; RCS: $Id$
 ;; Keywords: OO, chart, graph
 ;;                                                                          
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
 
-;;; Future versions of Chart can be found at:
-;;  ftp://ftp.ultranet.com/pub/zappo
-
 ;;; 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-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:
 ;;
 ;;
 ;; to your .emacs (or wherever) and load the `chart-face-pixmap-list'
 ;; with all the bitmaps you want to use.
-;;
-;; PREFERRED: Emacs 19.30 or better, but should work with earlier
-;;            versions but without special fonts/colors/pixmaps
 
 (require 'eieio)
 
    (x-margin :initarg :x-margin
 	     :initform 5)
    (x-width :initarg :x-width
-	    :initform (lambda () (- (window-width) 10)))
+	    )
    (y-axis :initarg :y-axis
 	   :initform nil)
    (y-margin :initarg :y-margin
 	     :initform 5)
    (y-width :initarg :y-width
-	    :initform (lambda () (- (window-height) 10)))
+	    )
    (key-label :initarg :key-label
 	      :initform "Key")
    (sequences :initarg :sequences
    )
   "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")
   "Chart the current storage requirements of Emacs."
   (interactive)
   (let* ((data (garbage-collect))
-	 (names '("conses" "free cons" "syms" "free syms"
-		  "markers" "free mark" "floats" "free flt"
-		  "strings/2" "vectors"))
-	 (nums (list (car (car data))
+	 (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))
+		     (car (nth 1 data)) ; syms
 		     (cdr (nth 1 data))
-		     (car (nth 2 data))
+		     (car (nth 2 data))	; markers
 		     (cdr (nth 2 data))
-		     (car (nth 5 data))
-		     (cdr (nth 5 data))
-		     (/ (nth 3 data) 2)
-		     (nth 4 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"
 (defun chart-emacs-lists ()
   "Chart out the size of various important lists."
   (interactive)
-  (let* ((names '("buffers" "frames" "processes" "faces" "x-displays"
-		  ))
+  (let* ((names '("buffers" "frames" "processes" "faces"))
 	 (nums (list (length (buffer-list))
 		     (length (frame-list))
 		     (length (process-list))
 		     (length (face-list))
-		     (length (x-display-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"

compare-strings.el

+;;; compare-strings.el --- Compare Strings (copied from Emacs 21)
+
+;;;
+;; Copyright (C) 2001 David Ponce
+;; C implementation Copyright (C) Free Software Foundation
+;;
+;; This program 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 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 this program; if not, you can either send email to this
+;; program's author (see below) or write to:
+;;
+;;              The Free Software Foundation, Inc.
+;;              675 Mass Ave.
+;;              Cambridge, MA 02139, USA.
+
+;;; Comentary
+;;
+;; Xemacs does not have this function.  Implemented from Emacs 21
+;; built-in compare-strings code in src/fns.c.
+;;
+
+(defun compare-strings (str1 start1 end1 str2 start2 end2 &optional ignore-case)
+  "Compare the contents of two strings, converting to multibyte if needed.
+In string STR1, skip the first START1 characters and stop at END1.
+In string STR2, skip the first START2 characters and stop at END2.
+END1 and END2 default to the full lengths of the respective strings.
+
+Case is significant in this comparison if IGNORE-CASE is nil.
+Unibyte strings are converted to multibyte for comparison.
+
+The value is t if the strings (or specified portions) match.
+If string STR1 is less, the value is a negative number N;
+  - 1 - N is the number of characters that match at the beginning.
+If string STR1 is greater, the value is a positive number N;
+  N - 1 is the number of characters that match at the beginning."
+  (if (null start1)
+      (setq start1 0))
+  (if (null start2)
+      (setq start2 0))
+  (setq end1 (if end1
+		 (min end1 (length str1))
+	       (length str1)))
+  (setq end2 (if end2
+		 (min end2 (length str2))
+	       (length str2)))
+  (let ((i1 start1)
+	(i2 start2)
+	result c1 c2)
+    (while (and (not result) (< i1 end1) (< i2 end2))
+      (setq c1 (aref str1 i1)
+	    c2 (aref str2 i2)
+	    i1 (1+ i1)
+	    i2 (1+ i2))
+      (if ignore-case
+	  (setq c1 (upcase c1)
+		c2 (upcase c2)))
+      (cond ((< c1 c2)
+	     (setq result (- i1)))
+	    ((> c1 c2)
+	     (setq result i1))))
+
+    (if (null result)
+	(setq result
+	      (cond ((< i1 end1)
+		     (1+ (- i1 start1)))
+		    ((< i2 end2)
+		     (1- (- start1 i1)))
+		    (t
+		     t))))
+    result))
+
+
+(provide 'compare-strings)
+
+;;; compare-strings.el ends here
+;;; eieio-base.el --- Base classes for EIEIO.
+
+;;;
+;; Copyright (C) 2000, 2001 Eric M. Ludlam
+;;
+;; Author: <zappo@gnu.org>
+;; RCS: $Id$
+;; Keywords: OO, lisp
+;;
+;; This program 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 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 this program; if not, you can either send email to this
+;; program's author (see below) or write to:
+;;
+;;              The Free Software Foundation, Inc.
+;;              675 Mass Ave.
+;;              Cambridge, MA 02139, USA.
+;;
+;; Please send bug reports, etc. to zappo@gnu.org
+
+;;; 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.
+
+(require 'eieio)
+
+(if (not (fboundp 'compare-strings))
+    (require 'compare-strings))
+
+;;; Code:
+
+;;; 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
+		    :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.")
+
+(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)
+      (eieio-oref (oref object parent-instance) slot-name)
+    (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-int (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))
+
+
+;;; 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.")
+
+(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
+				       &rest fields)
+  "Make sure THIS is in our master list of this class.
+Optional argument FIELDS are the initialization arguments."
+  ;; Theoretically, this is never called twice for a given instance.
+  (let ((sym (oref this tracking-symbol)))
+    (if (not (member 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 field list-symbol)
+  "Find KEY as an element of FIELD in the objects in LIST-SYMBOL.
+Returns the first match."
+  (object-assoc key field (symbol-value list-symbol)))
+
+
+;;; eieio-persistent
+;;
+;; For objects which must save themselves to disk.  Provides a
+;; `object-save' 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
+;; can make the saved object location independent of all file
+;; references are made relative.
+(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.")
+   (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."))
+  "This special class enables persistence through save files.
+Use the `object-save' method to write this object to disk.")
+
+(defun eieio-persistent-read (filename)
+  "Read a persistent object from FILENAME."
+  (save-excursion
+    (let ((ret nil))
+      (set-buffer (get-buffer-create " *tmp eieio read*"))
+      (unwind-protect
+	  (progn
+	    (erase-buffer)
+	    (insert-file filename)
+	    (goto-char (point-min))
+	    (setq ret (read (current-buffer)))
+	    (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."
+  (let* ((src (expand-file-name file))
+	 (dest (file-name-directory (oref this file)))
+	 (cs1  (compare-strings src 0 nil dest 0 nil))
+	 diff abdest absrc)
+    ;; Find the common directory part
+    (setq diff (substring src 0 cs1))
+    (setq cs1 (split-string diff "[\\/]"))
+    (setq cs1 (length (nth (1- (length cs1)) cs1)))
+    (setq diff (substring diff 0 (- (length diff) cs1)))
+    ;; Get the uncommon bits from dest and src.
+    (setq abdest (substring dest (length diff))
+	  absrc (substring src (length diff)))
+    ;; Find number if dirs in absrc, and add those as ".." to dest.
+    ;; Rember we have a file name, so that is the 1-.
+    (setq cs1 (1- (length (split-string absrc "[\\/]"))))
+    (while (> cs1 0)
+      (setq abdest (concat "../" abdest)
+	    cs1 (1- cs1)))
+    absrc))
+
+(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)))
+	    (write-file cfn nil))
+	;; Restore :file, and kill the tmp buffer
+	(oset this file cfn)
+	(kill-buffer b)))))
+
+;; Notes on the persistent object:
+;; It should also set up some hooks to help it keep itself up to date.
+
+
+(provide 'eieio-base)
+
+;;; eieio-base.el ends here
 ;;; eieio-comp.el -- eieio routines to help with byte compilation
 
 ;;;
-;; Copyright (C) 1995,1996, 1998, 1999, 2000 Eric M. Ludlam
+;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
 ;; RCS: $Id$
 ;;              Cambridge, MA 02139, USA.
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
-;;
-;; Updates can be found at:
-;;    ftp://ftp.ultranet.com/pub/zappo
 
 ;;; Commentary:
 ;;  
 ;;; eieio-custom.el -- eieio object customization
 
-;;; Copyright (C) 1999, 2000 Eric M. Ludlam
+;;; Copyright (C) 1999, 2000, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
 ;; RCS: $Id$
 ;;              Cambridge, MA 02139, USA.
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
-;;
-;; Updates can be found at:
-;;    ftp://ftp.ultranet.com/pub/zappo
 
 ;;; Commentary:
 ;;
-;;   This contains support customization of eieio objects.  Enabling your
-;; object to be customizable requires use of the added class slot
-;; attirbute :custom
-;;
+;;   This contains support customization of eieio objects.  Enabling
+;; your object to be customizable requires use of the slot attirbute
+;; `:custom'.
 
 (require 'eieio)
 (require 'widget)
   ((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
   "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.")
+
+(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."
   "Create the value of WIDGET."
   (if (not (widget-get widget :value))
       (widget-put widget
-		  :value (funcall (class-constructor
-				   (widget-get widget :objecttype))
-				  "Custom-new")))
+		  :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)))
 	 (fields (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 is not editable.
-    (setq chil (cons (widget-create-child-and-convert
-		      widget 'string :tag "Object "
-		      :sample-face 'bold
-		      (object-name-string obj))
-		     chil))
+    ;; 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 fields, creating child widgets.
     (while fields
       ;; Output this slot if it has a customize flag associated with it.
-      (if (car fcust)
-	  (when (slot-boundp obj (car fields))
-	    ;; In this case, this field has a custom type.  Create it's
-	    ;; children widgets.
-	    (setq chil (cons (widget-create-child-and-convert
-			      widget
-			      (eieio-filter-slot-type widget (car fcust))
-			      :tag
-			      (concat
-			       (make-string
-				(or (widget-get widget :indent) 0)
-				? )
-			       "Slot "
+      (when (and (car fcust)
+		 (or (not master-group) (member master-group (car fgroup)))
+		 (slot-boundp obj (car fields)))
+	;; In this case, this field 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 fields))
-					     (car fields)))))
+					 (or
+					  (class-slot-initarg
+					   (object-class-fast obj)
+					   (car fields))
+					  (car fields)))))
 				 (capitalize
 				  (if (string-match "^:" s)
 				      (substring s (match-end 0))
-				    s))))
-			      :value (slot-value obj (car fields))
-			      :sample-face 'eieio-custom-slot-tag-face
-			      )
-			     chil))
-	    (setq chil (cons (widget-create-child-and-convert
-			      widget 'documentation-string
-			      :format "%t   %v"
-			      :tag (make-string
-				    (or (widget-get widget :indent) 0)
-				    ? )
-			      :value (if (car fdoc) (car fdoc)
-				       "Slot not Documented."))
-			     chil))
-	    ))
+				    s)))))
+			    :value (slot-value obj (car fields))
+			    :doc  (if (car fdoc) (car fdoc)
+				    "Slot not Documented.")
+			    :eieio-custom-visibility 'visible
+			    )
+			   chil))
+	  )
+	)
       (setq fields (cdr fields)
 	    fdoc (cdr fdoc)
-	    fcust (cdr fcust)))
+	    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 (car (widget-apply (car wids) :value-inline)))
-	 (chil (nthcdr 1 wids))
+	 (chil (if (widget-get widget :eieio-show-name)
+		   (nthcdr 1 wids) wids))
 	 (cv (class-v (object-class-fast obj)))
 	 (fields (aref cv class-public-a))
 	 (fcust (aref cv class-public-custom)))
     ;; -- None yet
     ;; Create a batch of initargs for each slot.
     (while (and fields chil)
-      (if (car fcust)
+      (if (and (car fcust)
+	       (or (not master-group) (member master-group (car fgroup)))
+	       (slot-boundp obj (car fields)))
 	  (progn
 	    ;; Only customized fields have widgets
 	    (eieio-oset obj (car fields)
-			 (car (widget-apply (car chil) :value-inline)))
-	    ;; Two widets per field.  The slot value, and the doc.
-	    (setq chil (cdr (cdr chil)))))
+			(car (widget-apply (car chil) :value-inline)))
+	    (setq chil (cdr chil))))
       (setq fields (cdr fields)
+	    fgroup (cdr fgroup)
 	    fcust (cdr fcust)))
     ;; Set any name updates on it.
     (aset obj object-name name)
 Argument OBJ is the object that has been customized."
   nil)
 
-(defun customize-object (obj)
-  "Customize OBJ in a custom buffer."
-  (eieio-customize-object obj))
+(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))
+(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."
+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 ((b (switch-to-buffer (get-buffer-create
-			      (concat "*CUSTOMIZE " (object-name obj) "*")))))
+  (let* ((g (or group 'default))
+	 (b (switch-to-buffer (get-buffer-create
+			       (concat "*CUSTOMIZE "
+				       (object-name obj) " "
+				       (symbol-name g) "*")))))
     (toggle-read-only -1)
     (kill-all-local-variables)
     (erase-buffer)
     (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))
+    (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)
+					;(widget-minor-mode)
     (goto-char (point-min))
     (widget-forward 3)
     (make-local-variable 'eieio-co)
-    (setq eieio-co obj)))
+    (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-create 'push-button
 		 :notify (lambda (&rest ignore)
 			   (message "Resetting.")
-			   (eieio-customize-object eieio-co))
-		 "Reset"))
+			   (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."
-  (widget-create 'object-edit :value obj))
+  (apply 'widget-create 'object-edit :value obj flags))
 
 (define-widget 'object 'object-edit
   "Instance of a CLOS class."
 
 (defun eieio-object-value-to-abstract (widget value)
   "For WIDGET, convert VALUE to an abstract /safe/ representation."
-  (clone value))
+  (if (object-p value) value
+    (if (null value) value
+      nil)))
 
 (defun eieio-object-abstract-to-value (widget value)
   "For WIDGET, convert VALUE to an abstract /safe/ representation."
   value)
 
+
+;;; customization group functions
+;;
+;; These functions provide the ability to create dynamic menus to
+;; customize specific sections of an object.  The 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
+;; 
 ;;; eieio-doc.el --- create texinfo documentation for an eieio class
 
-;;; Copyright (C) 1996, 1998, 1999 Eric M. Ludlam
+;;; Copyright (C) 1996, 1998, 1999, 2000, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
 ;; RCS: $Id$
 ;;              Cambridge, MA 02139, USA.
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
-;;
-;; Updates can be found at:
-;;    ftp://ftp.ultranet.com/pub/zappo
 
 ;;; 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:
   "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
 	  (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
+	(insert "@sub" eieiodoc-current-section-level
+		" 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
       (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 " @*\nDefault Value: @code{"(format "%S" deflt) "}"))
       (insert "\n\n")
       (if (eq pv 'default)
 	  ;; default differs only, xref the parent
 			     (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)
+  (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 "\\( \\|^\\)\\(\\(non-\\)\\(nil\\)\\)\\([ ,]\\|$\\)" string)
-    (setq string (replace-match "\\2@code{\\3}" 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)
 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
 
-;;; Copyright (C) 1996, 1998, 1999, 2000 Eric M. Ludlam
+;;; Copyright (C) 1996, 1998, 1999, 2000, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
 ;; RCS: $Id$
 ;;              Cambridge, MA 02139, USA.
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
-;;
-;; Updates can be found at:
-;;    ftp://ftp.ultranet.com/pub/zappo
 
 ;;; Commentary:
 ;;
 	      (princ "  Undocumented")
 	    (if (car doc)
 		(progn
-		  (princ "  :BEFORE method:")
+		  (princ "  :BEFORE ")
+		  (prin1 (car (car doc)))
 		  (terpri)
-		  (princ (car doc))))
+		  (princ (cdr (car doc)))))
 	    (setq doc (cdr doc))
 	    (if (car doc)
 		(progn
-		  (princ "  :PRIMARY method:")
+		  (princ "  :PRIMARY ")
+		  (prin1 (car (car doc)))
 		  (terpri)
-		  (princ (car doc))))
+		  (princ (cdr (car doc)))))
 	    (setq doc (cdr doc))
 	    (if (car doc)
 		(progn
-		  (princ "  :AFTER method:")
+		  (princ "  :AFTER ")
+		  (prin1 (car (car doc)))
 		  (terpri)
-		  (princ (car doc))))
+		  (princ (cdr (car doc)))))
 	    (terpri)
 	    (terpri))
 	  (setq methods (cdr methods)))))
 	    (princ " ")
 	    ;; argument list
 	    (let* ((func (cdr (car gm)))
-		   (arglst
-		    (if (byte-code-function-p func)
-			(eieio-compiled-function-arglist func)
-		      (car (cdr func)))))
+		   (arglst (eieio-lambda-arglist func)))
 	      (prin1 arglst))
 	    (terpri)
 	    ;; 3 because of cdr
 	(setq i (1+ i))))
     (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."
 		   (fboundp primary)
 		   (fboundp after)))
 	  nil
-	(list (if (fboundp before) (documentation before) nil)
-	      (if (fboundp primary) (documentation primary) nil)
-	      (if (fboundp after) (documentation after)))))))
+	(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.")
 		      ((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 ":\\(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))
+	))))
 
 (defun eieio-help-augment-keymap ()
   "Augment the help keymap for cool EIEIO stuff."

eieio-speedbar.el

 ;;; eieio-speedbar.el -- Classes for managing speedbar displays.
 
 ;;;
-;; Copyright (C) 1999, 2000 Eric M. Ludlam
+;; Copyright (C) 1999, 2000, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
 ;; RCS: $Id$
 ;;              Cambridge, MA 02139, USA.
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
-;;
-;; Updates can be found at:
-;;    ftp://ftp.ultranet.com/pub/zappo
 
 ;;; Commentary:
 ;;  
 
 ;;; Code:
 (require 'eieio)
+(require 'eieio-custom)
 (require 'speedbar)
 
 ;;; Support a way of adding generic object based modes into speedbar.
 	       :type symbol
 	       :documentation
 	       "The type of expansion button used for objects of this class.
-Possible values are 'bracket, 'angle, 'curly, and nil.
-See `speedbar-make-tag-line' for details."
+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)
     (if (not depth)
 	(progn
 	  (beginning-of-line)
-	  (looking-at "^\\([0-9]+\\):")
-	  (setq depth (string-to-int (match-string 1)))))
-    (while (and (not (object-p (speedbar-line-token)))
-		(> depth 0))
-      (setq depth (1- depth))
-      (re-search-backward (format "^%d:" depth) nil t))
-    (speedbar-line-token)))
+	  (when (looking-at "^\\([0-9]+\\):")
+	    (setq depth (string-to-int (match-string 1))))))
+    (when depth
+      (while (and (not (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.
 ;;; eieio-tests.el -- eieio tests routines
 
 ;;;
-;; Copyright (C) 1999, 2000 Eric M. Ludlam
+;; Copyright (C) 1999, 2000, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
 ;; RCS: $Id$
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
 ;;
-;; Updates can be found at:
-;;    ftp://ftp.ultranet.com/pub/zappo
 
 ;;; Commentary:
 ;;  
 ;; Test the various features of EIEIO.  To run the tests, evaluate the
 ;; entire buffer.
 
+(require 'eieio-base)
+
 ;;; Code:
 
 ;;; Multiple Inheritance, and method signal testing
 	      :allocation class)
    (test-tag :initform nil
 	     :documentation "Used to make sure methods are called.")
+   (self :initform nil
+	 :type (or null class-a)
+	 :documentation "Test self referencing types.")
    )
   "Class A")
 
 (defvar a  (class-a "aye"))
 (defvar b (class-b "fooby"))
 
+(condition-case nil
+    (progn
+      ;; Try make-instance on these guys...
+      (make-instance 'class-ab)
+      (make-instance 'class-a :water 'cho)
+      (make-instance 'class-b "a name")
+      )
+  (error "make-instance error."))
+
 ;; Play with call-next-method
 (defmethod class-cn ((a class-a))
   "Try calling `call-next-method' when there isn't one.
     nil
   (error "Call next method MI check failed."))
 
+;; Try the self referencing test
+(oset a self a)
+
 
 ;;; Test the BEFORE, PRIMARY, and AFTER method tags.
 ;;
     nil
   (error "Slot exists-p failed"))
 
+(condition-case nil
+    (progn
+      (oref a water)
+      (error ""))
+  (unbound-slot nil)
+  (error (error "Oref of unbound slot succeeded.")))
+  
+
 (defmethod slot-unbound ((a class-a) &rest foo)
   "If a slot in A is unbound, ignore FOO."
   'moose)
 (if (eq (oref a classslot) (oref aa classslot))
     nil
   (error "Class slots are tracking between objects"))
+
+;;; Test function type in a class
+;;
+(defclass class-typep ()
+  ((slot1 :type function
+	  :initform <
+	  )
+   (slot2 :type integer
+	  :initform (lambda () 1)
+	  )
+   (slot4 :type function
+	  :initform (lambda-default () 2)
+	  )
+   )
+  "Test different types in a class.")
+
+(defvar ct (class-typep "foo"))
 
 
 ;;; Inheritance status
 	   :allocation :instance
 	   :documentation "Fisrt slot testing slot arguments."
 	   :custom symbol
+	   :label "Wild Animal"
+	   :group borg
 	   :protection public)
    (slot-2 :initarg :penguin
 	   :initform "penguin"
 	   :allocation :instance
 	   :documentation "Second slot testing slot arguments."
 	   :custom string
+	   :label "Wild bird"
+	   :group vorlon
 	   :accessor get-slot-2
 	   :protection private)
    )
-  '(:documentation "A class for testing slot arguments.")
+  (:custom-groups (foo))
+  "A class for testing slot arguments."
   )
 
 (defvar t1 (class-c "C1"))
       (error "A string was set on a symbol slot during init."))
   (invalid-slot-type nil))
 
+;;; eieio-instance-inheritor
+;; Test to make sure this works.
+(defclass II (eieio-instance-inheritor)
+  ((slot1 :initform 1)
+   (slot2)
+   (slot3))
+  "Instance Inheritor test class.")
+
+(defvar II1 (II "II Test."))
+(oset II1 slot2 'cat)
+(defvar II2 (clone II1 "II2 Test."))
+(oset II2 slot1 'moose)
+(defvar II3 (clone II2 "II3 Test."))
+(oset II3 slot3 'penguin)
+
+(cond ((not (eq (oref II3 slot1) 'moose))
+       (error "Instance inheritor: Level one inheritance failed."))
+      ((not (eq (oref II3 slot2) 'cat))
+       (error "Instance inheritor: Level two inheritance failed."))
+      ((not (eq (oref II3 slot3) 'penguin))
+       (error "Instance inheritor: Level zero inheritance failed."))
+      (t t))
+
+
+;;; Test the persistent object, and object-write by side-effect.
+;;
+(defclass PO (eieio-persistent)
+  ((slot1 :initarg :slot1
+	  :initform 2)
+   (slot2 :initarg :slot2
+	  :initform "foo"))
+  "A Persistent object with two initializable slots.")
+
+(defvar PO1 (PO "persist" :slot1 4 :slot2 "testing"
+		:file (concat default-directory "test-p.el")))
+
+(eieio-persistent-save PO1)
+
+(eieio-persistent-read "test-p.el")
+
+
+;;; Test the instance tracker
+;;
+(defclass IT (eieio-instance-tracker)
+  ((tracking-symbol :initform IT-list)
+   (slot1 :initform 'die))
+  "Instance Tracker test object.")
+
+(defvar IT-list nil)
+(defvar IT1 (IT "trackme"))
+
+(if (not (eieio-instance-tracker-find 'die 'slot1 'IT-list))
+    (error "Instance tracker lost an instance."))
+
+(delete-instance IT1)
+
+(if (eieio-instance-tracker-find 'die 'slot1 'IT-list)
+    (error "Instance tracker delete failed."))
 
 (message "All tests passed.")
 
 ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects
-;;              or maybe Eric's Implementation of Emacs Intrepreted Objects
+;;               or maybe Eric's Implementation of Emacs Intrepreted Objects
 
 ;;;
-;; Copyright (C) 1995,1996, 1998, 1999, 2000 Eric M. Ludlam
+;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
-;; Version: 0.15
+;; Version: 0.16
 ;; RCS: $Id$
 ;; Keywords: OO, lisp
-(defvar eieio-version "0.15"
+(defvar eieio-version "0.16"
   "Current version of EIEIO.")
 ;;
 ;; This program is free software; you can redistribute it and/or modify
 ;;              Cambridge, MA 02139, USA.
 ;;
 ;; Please send bug reports, etc. to zappo@gnu.org
-;;
-;; Updates can be found at:
-;;    ftp://ftp.ultranet.com/pub/zappo
 
 ;;; Commentary:
 ;;
 (defvar eieio-default-superclass nil)
 
 (defconst class-symbol 1 "Class's symbol (self-referencing.).")
-(defconst class-doc 2 "Class's documentation string.")
-(defconst class-parent 3 "Class parent field.")
-(defconst class-children 4 "Class children class field.")
-(defconst class-symbol-obarray 5 "Obarray permitting fast access to variable position indexes.")
-(defconst class-public-a 6 "Class public attribute index.")
-(defconst class-public-d 7 "Class public attribute defaults index.")
-(defconst class-public-doc 8 "Class public documentation strings for attributes.")
-(defconst class-public-type 9 "Class public type for a slot.")
-(defconst class-public-custom 10 "Class public type for a slot.")
-(defconst class-protection 11 "Class protection for a slot.")
-(defconst class-initarg-tuples 12 "Class initarg tuples list.")
-(defconst class-class-allocation-a 13 "Class allocated attributes.")
-(defconst class-class-allocation-doc 14 "Class allocated documentation.")
-(defconst class-class-allocation-type 15 "Class allocated value type.")
-(defconst class-class-allocation-custom 16 "Class allocated custom descriptor.")
-(defconst class-class-allocation-protection 17 "Class allocated protection list.")
-(defconst class-class-allocation-values 18 "Class allocated value vector.")
-(defconst class-default-object-cache 19
+(defconst class-parent 2 "Class parent field.")
+(defconst class-children 3 "Class children class field.")
+(defconst class-symbol-obarray 4 "Obarray permitting fast access to variable position indexes.")
+(defconst class-public-a 5 "Class public attribute index.")
+(defconst class-public-d 6 "Class public attribute defaults index.")
+(defconst class-public-doc 7 "Class public documentation strings for attributes.")
+(defconst class-public-type 8 "Class public type for a slot.")
+(defconst class-public-custom 9 "Class public custom type for a slot.")
+(defconst class-public-custom-label 10 "Class public custom group for a slot.")
+(defconst class-public-custom-group 11 "Class public custom group for a slot.")
+(defconst class-protection 12 "Class protection for a slot.")
+(defconst class-initarg-tuples 13 "Class initarg tuples list.")
+(defconst class-class-allocation-a 14 "Class allocated attributes.")
+(defconst class-class-allocation-doc 15 "Class allocated documentation.")
+(defconst class-class-allocation-type 16 "Class allocated value type.")
+(defconst class-class-allocation-custom 17 "Class allocated custom descriptor.")
+(defconst class-class-allocation-custom-label 18 "Class allocated custom descriptor.")
+(defconst class-class-allocation-custom-group 19 "Class allocated custom group.")
+(defconst class-class-allocation-protection 20 "Class allocated protection list.")
+(defconst class-class-allocation-values 21 "Class allocated value vector.")
+(defconst class-default-object-cache 22
   "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 20
+(defconst class-options 23
   "Storage location of tagged class options.
 Stored outright without modifications or stripping.")
 
-(defconst class-num-fields 21
+(defconst class-num-fields 24
   "Number of fields in the class definition object.")
 
 (defconst object-class 1 "Index in an object vector where the class is stored.")
 
 (defmacro generic-p (method)
   "Return t if symbol METHOD is a generic function.
-Only methods have the symbol `eieio-method-tree' as a property (which
+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)))
 
 (defmacro class-option (class option)
   "Return the value stored for CLASS' OPTION.
 Return nil if that option doesn't exist."
-  `(class-option-assoc ',option (aref (class-v ,class) class-options)))
+  `(class-option-assoc (aref (class-v ,class) class-options) ',option))
 
 
 ;;; Defining a new class
 The following are extensions on CLOS:
   :protection - non-nil means a private slot (accessible when THIS is set)
   :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.
 
 A class can also have optional options.  These options happen in place
 of documentation, (including a :documentation tag) in addition to
 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.
 
 Options in CLOS not supported in EIEIO:
 
 
   (let* ((pname (if superclasses superclasses nil))
 	 (newc (make-vector class-num-fields 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)
 
-    ;; Snarf out documentation, or options here:
-    (if (stringp (car options-and-doc))
-	(progn
-	  (aset newc class-doc (car options-and-doc))
-	  (if (< 1 (length options-and-doc))
-	      (error "Too many arguments to `defclass'")))
-      (let* ((co (car options-and-doc))
-	     (ds (car-safe (cdr options-and-doc)))
-	     (od (class-option-assoc co :documentation)))
-	(aset newc class-options co)
-	(if (and ds od)
-	    (error "Documentation provided in options and in doc-string position")
-	(aset newc class-doc (or ds od)))))
+    ;; 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.
+    (when oldc
+      (aset newc class-children (aref oldc class-children)))
+
+    (cond ((< 2 (length options-and-doc))
+	   (error "Too many arguments to `defclass'"))
+	  ((= 2 (length options-and-doc))
+	   (if (stringp (car (cdr options-and-doc)))
+	       (setq options (car options-and-doc)
+		     options-and-doc (cdr options-and-doc))
+	     (error "Too many arguments to `defclass'"))))
+
+    (setq options
+	  (if (stringp (car options-and-doc))
+	      (cons :documentation (cons (car options-and-doc) options))
+	    (car options-and-doc)))
 
     (if pname
 	(progn
 		  (if (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.
+		  (mapcar (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))
 		  (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 '(object-p obj)
+			(list 'same-class-p 'obj cname)))))
+
+    ;; Create a handy child test too
+    (let ((csym (intern (concat (symbol-name cname) "-child-p"))))
+      (fset csym
+	    (list 'lambda (list 'obj)
+		  (format
+		   "Test OBJ to see if it an object is a child of type %s"
+		   cname)
+		  (list 'and '(object-p obj)
+			(list 'obj-of-class-p 'obj cname)))))
     
     ;; before adding new fields, lets add all the methods and classes
     ;; in from the parent class
 	     (alloc (car (cdr (member ':allocation field))))
 	     (type (member ':type field))
 	     (custom (car (cdr (member ':custom field))))
+	     (label (car (cdr (member ':label field))))
+	     (customg (car (cdr (member ':group field))))
 	     
 	     (skip-nil (class-option-assoc (aref newc class-options)
 					   :allow-nil-initform))
 					     :allocation
 					     :type
 					     :custom
-					     :allow-nil-initform)))
+					     :label
+					     :group
+					     :allow-nil-initform
+					     :custom-groups)))
 		    (signal 'invalid-slot-type (list (car tmp))))
 		(setq tmp (cdr (cdr tmp))))))
 
 	;; The default type specifier is supposed to be t, meaning anything.
 	(if (not type) (setq type t)
 	  (setq type (car (cdr type))))
+
+	;; Label is nil, or a string
+	(if (not (or (null label) (stringp label)))
+	    (signal 'invalid-slot-type (list ':label label)))
 	
 	;; 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 o symbols.
+	(mapcar (lambda (cg)
+		  (if (not (symbolp cg))
+		      (signal 'invalid-slot-type (list ':group cg))))
+		customg)
+
 	;; First up, add this field into our new class.
-	(eieio-add-new-field newc name init docstr type custom
+	(eieio-add-new-field newc name init docstr type custom label customg
 			     prot initarg alloc 'defaultoverride skip-nil)
 
+	;; We need to id the group, and store them in a group list attribute.
+	(mapcar (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
     (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-protection (nreverse (aref newc class-protection)))
     (aset newc class-initarg-tuples (nreverse (aref newc class-initarg-tuples)))
 
     (aset newc class-class-allocation-values
 	  (apply 'vector (aref newc class-class-allocation-values)))
 
-    ;; turn this into a useable self-pointing symbol
-    (set cname cname)
-
     ;; Attach field symbols into an obarray, and store the index of
     ;; this field as the variable slot in this new symbol.  We need to
     ;; know about primes, because obarrays are best set in vectors of
 		 '(initialize-instance no fields)
 		 'no)))
 
-    ;; 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 '(object-p obj)
-			(list 'same-class-p 'obj cname)))))
-
-    ;; Create a handy child test too
-    (let ((csym (intern (concat (symbol-name cname) "-child-p"))))
-      (fset csym
-	    (list 'lambda (list 'obj)
-		  (format
-		   "Test OBJ to see if it an object is a child of type %s"
-		   cname)
-		  (list 'and '(object-p obj)
-			(list 'obj-of-class-p 'obj cname)))))
-
     ;; Set up a specialized doc string.
     ;; Use stored value since it is calculated in a non-trivial way
-    (put cname 'variable-documentation (aref newc class-doc))
+    (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)))
+      (mapcar (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)
 (defun eieio-perform-slot-validation-for-default (field spec value skipnil)
   "For FIELD, signal if SPEC does not match VALUE.
 If SKIPNIL is non-nil, then if VALUE is nil, return t."
-  (if (and (not eieio-skip-typecheck)
-	   (not (and skipnil (null value)))
-	   (not (eieio-perform-slot-validation spec value)))
-      (signal 'invalid-slot-type (list field spec value))))
+  (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 field spec val)))))
 
-
-(defun eieio-add-new-field (newc a d doc type cust prot init alloc
+(defun eieio-add-new-field (newc a d doc type cust label custg 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, PROT, and INIT arg.
+then also add in D (defualt), DOC, TYPE, CUST, LABEL, CUSTG, PROT, and INIT arg.
 Argument ALLOC specifies if the field 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.
   (if (sequencep d) (setq d (copy-sequence d)))
   (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.
 	    (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-protection (cons prot (aref newc class-protection)))
 	    (aset newc class-initarg-tuples (cons (cons init a) (aref newc class-initarg-tuples)))
 	    )
 	  (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.
 	      (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))
 	      (pprot (aref pcv class-protection))
 	      (pinit (aref pcv class-initarg-tuples))
 	      (i 0))
 	  (while pa
 	    (eieio-add-new-field newc
-				 (car pa) (car pd) (car pdoc)
-				 (aref ptype i) (car pcust) (car pprot)
-				 (car-safe (car pinit)) nil nil sn)
+				 (car pa) (car pd) (car pdoc) (aref ptype i)
+				 (car pcust) (car plabel) (car pcustg)
+				 (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)
 		  pprot (cdr pprot)
 		  pinit (cdr pinit))
 	    )) ;; while/let
 	      (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))
 	      (pprot (aref pcv class-class-allocation-protection))
 	      (pval (aref pcv class-class-allocation-values))
 	      (i 0))
 	  (while pa
 	    (eieio-add-new-field newc
-				 (car pa) (aref pval i) (car pdoc)
-				 (aref ptype i) (car pcust) (car pprot)
-				 nil ':class sn)
+				 (car pa) (aref pval i) (car pdoc) (aref ptype i)
+				 (car pcust) (car plabel) (car pcustg)
+				 (car pprot) nil ':class sn)
 	    ;; Increment each value.
 	    (setq pa (cdr pa)
 		  pdoc (cdr pdoc)
 		  pcust (cdr pcust)
+		  plabel (cdr plabel)
+		  pcustg (cdr pcustg)
 		  pprot (cdr pprot)
 		  i (1+ i))
 	    ))) ;; while/let
 ;;; CLOS style implementation of object creators.
 ;;
 (defun make-instance (class &rest initargs)
-  "Make a new instance of CLASS with initialization based on INITARGS.
-INITARGS starts with a name for the class.  This can be any valid Lisp
-object, but is generally a string.  The rest of the init args are
-label/value pairs.  The label's are the symbols created with the
-:initarg tag from the `defclass' call.  The value is the value stored
-in that slot."
-  (let ((cc (class-constructor class))) (apply cc class initargs)))
+  "Make a new instance of CLASS with NAME and initialization based on INITARGS.
+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.  The rest of INITARGS are label/value pairs.  The label's
+are the symbols created with the :initarg tag from the `defclass' call.
+The value is the value stored in that slot."
+  (if (and (car initargs) (stringp (car initargs)))
+      (apply (class-constructor class) initargs)
+    (apply  (class-constructor class) class initargs)))
+
 
 ;;; CLOS methods and generics
 ;;
     (if (not (fboundp method))
 	(eieio-defgeneric method
 	  (if (stringp (car body))
-	      (car body) (format "Generically created method %s" method))))
+	      (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
 ;;; Slot type validation
 ;;
 (defun eieio-perform-slot-validation (spec value)
-  "Signal if SPEC does not match 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
 
 (defun eieio-oref (obj field)
   "Return the value in OBJ at FIELD in the object vector."
-  (if (not (object-p obj)) (signal 'wrong-type-argument (list 'object-p obj)))
-  (if (not (symbolp field)) (signal 'wrong-type-argument (list 'symbolp field)))
-  (let ((c (eieio-field-name-index (aref obj object-class) field)))
+  (if (not (or (object-p obj) (class-p obj)))
+      (signal 'wrong-type-argument (list '(or object-p class-p) obj)))
+  (if (not (symbolp field))
+      (signal 'wrong-type-argument (list 'symbolp field)))
+  (let* ((class (if (class-p obj) obj (aref obj object-class)))
+	 (c (eieio-field-name-index class field)))
     (if (not c)
 	;; It might be missing because it is a :class allocated field.
 	;; Lets check that info out.
-	(if (setq c
-		  (eieio-class-field-name-index (aref obj object-class) field))
+	(if (setq c (eieio-class-field-name-index class field))
 	    ;; Oref that slot.
-	    (aref (aref (class-v (aref obj object-class)) class-class-allocation-values)
-		  c)
+	    (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 field 'oref)
 	  ;;(signal 'invalid-slot-name (list (object-name obj) field))
 	  )
+      (if (not (object-p obj))
+	  (signal 'wrong-type-argument (list 'object-p obj)))
       (eieio-barf-if-slot-unbound (aref obj c) obj field 'oref))))
 
 (defalias 'slot-value 'eieio-oref)
 (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 mean for the sole purpose of quoting
+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
 	  )
       (eieio-barf-if-slot-unbound
        (let ((val (nth (- c 3) (aref (class-v cl) class-public-d))))
-	 ;; check for functions to evaluate
-	 (if (or (and (listp val) (equal (car val) 'lambda))
-		 (and (symbolp val) (fboundp val)))
-	     (let ((this obj))
-	       (funcall val))
-	   ;; check for quoted things
-	   (if (and (listp val) (equal (car val) 'quote))
-	       (car (cdr val))
-	     ;; return it verbatim
-	     val)))
-       obj (aref obj object-class) 'oref-default))))
+	 (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))