Mercurial > emacs
changeset 104430:b93dbe652ecd
eieio/eieio-comp.el, eieio/eieio-custom.el, eieio/eieio-datadebug.el,
eieio/eieio-doc.el, eieio/eieio-opt.el, eieio/eieio-speedbar.el,
eieio/eieio.el: Move into emacs-lisp directory.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Sun, 30 Aug 2009 02:00:36 +0000 |
| parents | cc1b5aa56f20 |
| children | a64f3429f0ac |
| files | lisp/eieio/eieio-comp.el lisp/eieio/eieio-custom.el lisp/eieio/eieio-datadebug.el lisp/eieio/eieio-doc.el lisp/eieio/eieio-opt.el lisp/eieio/eieio-speedbar.el lisp/eieio/eieio.el |
| diffstat | 7 files changed, 0 insertions(+), 5125 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/eieio/eieio-comp.el Sat Aug 29 22:28:15 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -;;; 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: - -(eval-and-compile - (if (featurep 'xemacs) - (progn - ;; XEmacs compatibility settings. - (if (not (fboundp 'byte-compile-compiled-obj-to-list)) - (defun byte-compile-compiled-obj-to-list (moose) nil)) - (if (not (boundp 'byte-compile-outbuffer)) - (defvar byte-compile-outbuffer nil)) - (defmacro eieio-byte-compile-princ-code (code outbuffer) - `(progn (if (atom ,code) - (princ "#[" ,outbuffer) - (princ "'(" ,outbuffer)) - (let ((codelist (if (byte-code-function-p ,code) - (byte-compile-compiled-obj-to-list ,code) - (append ,code nil)))) - (while codelist - (eieio-prin1 (car codelist) ,outbuffer) - (princ " " ,outbuffer) - (setq codelist (cdr codelist)))) - (if (atom ,code) - (princ "]" ,outbuffer) - (princ ")" ,outbuffer)))) - (defun eieio-prin1 (code outbuffer) - (cond ((byte-code-function-p code) - (let ((codelist (byte-compile-compiled-obj-to-list code))) - (princ "#[" outbuffer) - (while codelist - (eieio-prin1 (car codelist) outbuffer) - (princ " " outbuffer) - (setq codelist (cdr codelist))) - (princ "]" outbuffer))) - ((vectorp code) - (let ((i 0) (ln (length code))) - (princ "[" outbuffer) - (while (< i ln) - (eieio-prin1 (aref code i) outbuffer) - (princ " " outbuffer) - (setq i (1+ i))) - (princ "]" outbuffer))) - (t (prin1 code outbuffer))))) - ;; Emacs: - (defmacro eieio-byte-compile-princ-code (code outbuffer) - (list 'prin1 code outbuffer)) - ;; Dynamically bound in byte-compile-from-buffer. - (defvar bytecomp-outbuffer) - (defvar bytecomp-filename))) - -(declare-function eieio-defgeneric-form "eieio" (method doc-string)) - -(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))) - -;; 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 (featurep 'xemacs) - byte-compile-outbuffer - bytecomp-outbuffer))) - (let ((name (format "%s::%s" (or class "#<generic>") meth))) - (if byte-compile-verbose - ;; bytecomp-filename is from byte-compile-from-buffer. - (message "Compiling %s... (%s)" (or bytecomp-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) - (eieio-byte-compile-princ-code 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)) - -(provide 'eieio-comp) - -;;; eieio-comp.el ends here
--- a/lisp/eieio/eieio-custom.el Sat Aug 29 22:28:15 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,471 +0,0 @@ -;;; eieio-custom.el -- eieio object customization - -;;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009 -;;; Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 -;; Keywords: OO, lisp - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; This contains support customization of eieio objects. Enabling -;; your object to be customizable requires use of the slot attirbute -;; `:custom'. - -(require 'eieio) -(require 'widget) -(require 'wid-edit) -(require 'custom) - -;;; Compatibility -;; -(eval-and-compile - (if (featurep 'xemacs) - (defalias 'eieio-overlay-lists (lambda () (list (extent-list)))) - (defalias 'eieio-overlay-lists 'overlay-lists) - ) - ) -;;; Code: -(defclass eieio-widget-test-class nil - ((a-string :initarg :a-string - :initform "The moose is loose" - :custom string - :label "Amorphous String" - :group (default foo) - :documentation "A string for testing custom. -This is the next line of documentation.") - (listostuff :initarg :listostuff - :initform ("1" "2" "3") - :type list - :custom (repeat (string :tag "Stuff")) - :label "List of Strings" - :group foo - :documentation "A list of stuff.") - (uninitialized :initarg :uninitialized - :type string - :custom string - :documentation "This slot is not initialized. -Used to make sure that custom doesn't barf when it encounters one -of these.") - (a-number :initarg :a-number - :initform 2 - :custom integer - :documentation "A number of thingies.")) - "A class for testing the widget on.") - -(defcustom eieio-widget-test (eieio-widget-test-class "Foo") - "Test variable for editing an object." - :type 'object - :group 'eieio) - -(defface eieio-custom-slot-tag-face '((((class color) - (background dark)) - (:foreground "light blue")) - (((class color) - (background light)) - (:foreground "blue")) - (t (:italic t))) - "Face used for unpushable variable tags." - :group 'custom-faces) - -(defvar eieio-wo nil - "Buffer local variable in object customize buffers for the current widget.") -(defvar eieio-co nil - "Buffer local variable in object customize buffers for the current obj.") -(defvar eieio-cog nil - "Buffer local variable in object customize buffers for the current group.") - - (defvar eieio-custom-ignore-eieio-co nil - "When true, all customizable slots of the current object are updated. -Updates occur regardless of the current customization group.") - -(define-widget 'object-slot 'group - "Abstractly modify a single slot in an object." - :tag "Slot" - :format "%t %v%h\n" - :convert-widget 'widget-types-convert-widget - :value-create 'eieio-slot-value-create - :value-get 'eieio-slot-value-get - :value-delete 'widget-children-value-delete - :validate 'widget-children-validate - :match 'eieio-object-match ;; same - ) - -(defun eieio-slot-value-create (widget) - "Create the value of WIDGET." - (let ((chil nil) - ) -; (setq chil (cons (widget-create-child-and-convert -; widget 'visibility -; :help-echo "Hide the value of this option." -; :action 'eieio-custom-toggle-parent -; t) -; chil)) - (setq chil (cons - (widget-create-child-and-convert - widget (widget-get widget :childtype) - :tag "" - :value (widget-get widget :value)) - chil)) - (widget-put widget :children chil))) - -(defun eieio-slot-value-get (widget) - "Get the value of WIDGET." - (widget-value (car (widget-get widget :children)))) - -(defun eieio-custom-toggle-hide (widget) - "Toggle visibility of WIDGET." - (let ((vc (car (widget-get widget :children)))) - (cond ((eq (widget-get vc :eieio-custom-state) 'hidden) - (widget-put vc :eieio-custom-state 'visible) - (widget-put vc :value-face (widget-get vc :orig-face))) - (t - (widget-put vc :eieio-custom-state 'hidden) - (widget-put vc :orig-face (widget-get vc :value-face)) - (widget-put vc :value-face 'invisible) - )) - (widget-value-set vc (widget-value vc)))) - -(defun eieio-custom-toggle-parent (widget &rest ignore) - "Toggle visibility of parent of WIDGET. -Optional argument IGNORE is an extraneous parameter." - (eieio-custom-toggle-hide (widget-get widget :parent))) - -(define-widget 'object-edit 'group - "Abstractly modify a CLOS object." - :tag "Object" - :format "%v" - :convert-widget 'widget-types-convert-widget - :value-create 'eieio-object-value-create - :value-get 'eieio-object-value-get - :value-delete 'widget-children-value-delete - :validate 'widget-children-validate - :match 'eieio-object-match - :clone-object-children nil - ) - -(defun eieio-object-match (widget value) - "Match info for WIDGET against VALUE." - ;; Write me - t) - -(defun eieio-filter-slot-type (widget slottype) - "Filter WIDGETs SLOTTYPE." - (if (widget-get widget :clone-object-children) - slottype - (cond ((eq slottype 'object) - 'object-edit) - ((and (listp slottype) - (eq (car slottype) 'object)) - (cons 'object-edit (cdr slottype))) - ((equal slottype '(repeat object)) - '(repeat object-edit)) - ((and (listp slottype) - (equal (car slottype) 'repeat) - (listp (car (cdr slottype))) - (equal (car (car (cdr slottype))) 'object)) - (list 'repeat - (cons 'object-edit - (cdr (car (cdr slottype)))))) - (t slottype)))) - -(defun eieio-object-value-create (widget) - "Create the value of WIDGET." - (if (not (widget-get widget :value)) - (widget-put widget - :value (cond ((widget-get widget :objecttype) - (funcall (class-constructor - (widget-get widget :objecttype)) - "Custom-new")) - ((widget-get widget :objectcreatefcn) - (funcall (widget-get widget :objectcreatefcn))) - (t (error "No create method specified"))))) - (let* ((chil nil) - (obj (widget-get widget :value)) - (master-group (widget-get widget :eieio-group)) - (cv (class-v (object-class-fast obj))) - (slots (aref cv class-public-a)) - (flabel (aref cv class-public-custom-label)) - (fgroup (aref cv class-public-custom-group)) - (fdoc (aref cv class-public-doc)) - (fcust (aref cv class-public-custom))) - ;; First line describes the object, but may not editable. - (if (widget-get widget :eieio-show-name) - (setq chil (cons (widget-create-child-and-convert - widget 'string :tag "Object " - :sample-face 'bold - (object-name-string obj)) - chil))) - ;; Display information about the group being shown - (when master-group - (let ((groups (class-option (object-class-fast obj) :custom-groups))) - (widget-insert "Groups:") - (while groups - (widget-insert " ") - (if (eq (car groups) master-group) - (widget-insert "*" (capitalize (symbol-name master-group)) "*") - (widget-create 'push-button - :thing (cons obj (car groups)) - :notify (lambda (widget &rest stuff) - (eieio-customize-object - (car (widget-get widget :thing)) - (cdr (widget-get widget :thing)))) - (capitalize (symbol-name (car groups))))) - (setq groups (cdr groups))) - (widget-insert "\n\n"))) - ;; Loop over all the slots, creating child widgets. - (while slots - ;; Output this slot if it has a customize flag associated with it. - (when (and (car fcust) - (or (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - ;; In this case, this slot has a custom type. Create it's - ;; children widgets. - (let ((type (eieio-filter-slot-type widget (car fcust))) - (stuff nil)) - ;; This next bit is an evil hack to get some EDE functions - ;; working the way I like. - (if (and (listp type) - (setq stuff (member :slotofchoices type))) - (let ((choices (eieio-oref obj (car (cdr stuff)))) - (newtype nil)) - (while (not (eq (car type) :slotofchoices)) - (setq newtype (cons (car type) newtype) - type (cdr type))) - (while choices - (setq newtype (cons (list 'const (car choices)) - newtype) - choices (cdr choices))) - (setq type (nreverse newtype)))) - (setq chil (cons (widget-create-child-and-convert - widget 'object-slot - :childtype type - :sample-face 'eieio-custom-slot-tag-face - :tag - (concat - (make-string - (or (widget-get widget :indent) 0) - ? ) - (if (car flabel) - (car flabel) - (let ((s (symbol-name - (or - (class-slot-initarg - (object-class-fast obj) - (car slots)) - (car slots))))) - (capitalize - (if (string-match "^:" s) - (substring s (match-end 0)) - s))))) - :value (slot-value obj (car slots)) - :doc (if (car fdoc) (car fdoc) - "Slot not Documented.") - :eieio-custom-visibility 'visible - ) - chil)) - ) - ) - (setq slots (cdr slots) - fdoc (cdr fdoc) - fcust (cdr fcust) - flabel (cdr flabel) - fgroup (cdr fgroup))) - (widget-put widget :children (nreverse chil)) - )) - -(defun eieio-object-value-get (widget) - "Get the value of WIDGET." - (let* ((obj (widget-get widget :value)) - (master-group eieio-cog) - (cv (class-v (object-class-fast obj))) - (fgroup (aref cv class-public-custom-group)) - (wids (widget-get widget :children)) - (name (if (widget-get widget :eieio-show-name) - (car (widget-apply (car wids) :value-inline)) - nil)) - (chil (if (widget-get widget :eieio-show-name) - (nthcdr 1 wids) wids)) - (cv (class-v (object-class-fast obj))) - (slots (aref cv class-public-a)) - (fcust (aref cv class-public-custom))) - ;; If there are any prefix widgets, clear them. - ;; -- None yet - ;; Create a batch of initargs for each slot. - (while (and slots chil) - (if (and (car fcust) - (or eieio-custom-ignore-eieio-co - (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - (progn - ;; Only customized slots have widgets - (let ((eieio-custom-ignore-eieio-co t)) - (eieio-oset obj (car slots) - (car (widget-apply (car chil) :value-inline)))) - (setq chil (cdr chil)))) - (setq slots (cdr slots) - fgroup (cdr fgroup) - fcust (cdr fcust))) - ;; Set any name updates on it. - (if name (aset obj object-name name)) - ;; This is the same object we had before. - obj)) - -(defmethod eieio-done-customizing ((obj eieio-default-superclass)) - "When a applying change to a widget, call this method. -This method is called by the default widget-edit commands. User made -commands should also call this method when applying changes. -Argument OBJ is the object that has been customized." - nil) - -(defun customize-object (obj &optional group) - "Customize OBJ in a custom buffer. -Optional argument GROUP is the sub-group of slots to display." - (eieio-customize-object obj group)) - -(defmethod eieio-customize-object ((obj eieio-default-superclass) - &optional group) - "Customize OBJ in a specialized custom buffer. -To override call the `eieio-custom-widget-insert' to just insert the -object widget. -Optional argument GROUP specifies a subgroup of slots to edit as a symbol. -These groups are specified with the `:group' slot flag." - ;; Insert check for multiple edits here. - (let* ((g (or group 'default))) - (switch-to-buffer (get-buffer-create - (concat "*CUSTOMIZE " - (object-name obj) " " - (symbol-name g) "*"))) - (toggle-read-only -1) - (kill-all-local-variables) - (erase-buffer) - (let ((all (eieio-overlay-lists))) - ;; Delete all the overlays. - (mapc 'delete-overlay (car all)) - (mapc 'delete-overlay (cdr all))) - ;; Add an apply reset option at the top of the buffer. - (eieio-custom-object-apply-reset obj) - (widget-insert "\n\n") - (widget-insert "Edit object " (object-name obj) "\n\n") - ;; Create the widget editing the object. - (make-local-variable 'eieio-wo) - (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g)) - ;;Now generate the apply buttons - (widget-insert "\n") - (eieio-custom-object-apply-reset obj) - ;; Now initialize the buffer - (use-local-map widget-keymap) - (widget-setup) - ;;(widget-minor-mode) - (goto-char (point-min)) - (widget-forward 3) - (make-local-variable 'eieio-co) - (setq eieio-co obj) - (make-local-variable 'eieio-cog) - (setq eieio-cog group))) - -(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass)) - "Insert an Apply and Reset button into the object editor. -Argument OBJ os the object being customized." - (widget-create 'push-button - :notify (lambda (&rest ignore) - (widget-apply eieio-wo :value-get) - (eieio-done-customizing eieio-co) - (bury-buffer)) - "Accept") - (widget-insert " ") - (widget-create 'push-button - :notify (lambda (&rest ignore) - ;; I think the act of getting it sets - ;; it's value through the get function. - (message "Applying Changes...") - (widget-apply eieio-wo :value-get) - (eieio-done-customizing eieio-co) - (message "Applying Changes...Done.")) - "Apply") - (widget-insert " ") - (widget-create 'push-button - :notify (lambda (&rest ignore) - (message "Resetting.") - (eieio-customize-object eieio-co eieio-cog)) - "Reset") - (widget-insert " ") - (widget-create 'push-button - :notify (lambda (&rest ignore) - (bury-buffer)) - "Cancel")) - -(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) - &rest flags) - "Insert the widget used for editing object OBJ in the current buffer. -Arguments FLAGS are widget compatible flags. -Must return the created widget." - (apply 'widget-create 'object-edit :value obj flags)) - -(define-widget 'object 'object-edit - "Instance of a CLOS class." - :format "%{%t%}:\n%v" - :value-to-internal 'eieio-object-value-to-abstract - :value-to-external 'eieio-object-abstract-to-value - :clone-object-children t - ) - -(defun eieio-object-value-to-abstract (widget value) - "For WIDGET, convert VALUE to an abstract /safe/ representation." - (if (eieio-object-p value) value - (if (null value) value - nil))) - -(defun eieio-object-abstract-to-value (widget value) - "For WIDGET, convert VALUE from an abstract /safe/ representation." - value) - - -;;; customization group functions -;; -;; These functions provide the ability to create dynamic menus to -;; customize specific sections of an object. They do not hook directly -;; into a filter, but can be used to create easymenu vectors. -(defmethod eieio-customize-object-group ((obj eieio-default-superclass)) - "Create a list of vectors for customizing sections of OBJ." - (mapcar (lambda (group) - (vector (concat "Group " (symbol-name group)) - (list 'customize-object obj (list 'quote group)) - t)) - (class-option (object-class-fast obj) :custom-groups))) - -(defvar eieio-read-custom-group-history nil - "History for the custom group reader.") - -(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) - "Do a completing read on the name of a customization group in OBJ. -Return the symbol for the group, or nil" - (let ((g (class-option (object-class-fast obj) :custom-groups))) - (if (= (length g) 1) - (car g) - ;; Make the association list - (setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g)) - (cdr (assoc - (completing-read (concat (oref obj name) " Custom Group: ") - g nil t nil 'eieio-read-custom-group-history) - g))))) - -(provide 'eieio-custom) - -;;; eieio-custom.el ends here
--- a/lisp/eieio/eieio-datadebug.el Sat Aug 29 22:28:15 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,151 +0,0 @@ -;;; 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
--- a/lisp/eieio/eieio-doc.el Sat Aug 29 22:28:15 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -;;; 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)) - -(defvar eieiodoc--class-indexstring) -(defvar eieiodoc--class-root) - -(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") - (let ((eieiodoc--class-indexstring indexstring) - (eieiodoc--class-root root-class)) - (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" - "@" eieiodoc--class-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 - (insert "@table @code\n@item " - (if (and (child-of-class-p (car revlist) eieiodoc--class-root) - (not (eq class (car revlist)))) - (concat "@w{@xref{" (symbol-name (car revlist)) "}.}") - (symbol-name (car revlist))) - "\n") - (setq revlist (cdr revlist) - depth (1+ depth))) - (let ((clist (reverse (aref (class-v class) 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
--- a/lisp/eieio/eieio-opt.el Sat Aug 29 22:28:15 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,699 +0,0 @@ -;;; 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
--- a/lisp/eieio/eieio-speedbar.el Sat Aug 29 22:28:15 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,424 +0,0 @@ -;;; eieio-speedbar.el -- Classes for managing speedbar displays. - -;;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008 Free -;;; Software Foundation, Inc. - -;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 -;; Keywords: OO, tools - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; This provides some classes that can be used as a parent which -;; will automatically provide SPEEDBAR support for any list of objects -;; of that type. -;; -;; This file requires speedbar version 0.10 or later. - -;;; Creating a new speedbar mode based on a pre-existing object hierarchy -;; -;; To create a new speedbar mode based on lists of objects is easier -;; than creating a whole new speedbar mode from scratch. -;; -;; 1) Objects that will have lists of items that can be expanded -;; should also inherit from the classes: -;; * `eieio-speedbar' - specify your own button behavior -;; * `eieio-speedbar-directory-button' - objects that behave like directories -;; * `eieio-speedbar-file-button' - objects that behave like files -;; -;; 2) Objects that have lists of children should implement the method -;; `eieio-speedbar-object-children' which returns a list of more -;; objects, or a list of strings. -;; -;; 3) Objects that return a list of strings should also implement these -;; methods: -;; * `eieio-speedbar-child-make-tag-lines' - make tag lines for a child. -;; * `eieio-speedbar-child-description' - describe non-object children -;; -;; 4) Objects which have expanded information should implement the method -;; `eieio-speedbar-description' to produce more information. -;; -;; 5) Objects that are associated with a directory should implement -;; the method `eieio-speedbar-derive-line-path' which returns a -;; path. -;; -;; 6) Objects that have a specialized behavior when clicked should -;; define the method `eieio-speedbar-handle-click'. -;; -;; To initialize a new eieio based speedbar display, do the following. -;; -;; 1) Create a keymap variable `foo-speedbar-key-map'. -;; This keymap variable should be initialized in a function. -;; If you have no special needs, use `eieio-speedbar-key-map' -;; -;; 2) Create a variable containing an easymenu definition compatible -;; with speedbar. if you have no special needs, use -;; `eieio-speedbar-menu'. -;; -;; 3) Create a function which returns the top-level list of children -;; objects to be displayed in speedbar. -;; -;; 4) Call `eieio-speedbar-create' as specified in it's documentation -;; string. This will automatically handle cases when speedbar is -;; not already loaded, and specifying all overload functions. -;; -;; 5) Create an initliazer function which looks like this: -;; -;; (defun my-speedbar-mode-initilaize () -;; "documentation" -;; (interactive) -;; (speedbar-frame-mode 1) -;; (speedbar-change-initial-expansion-list mymodename) -;; (speedbar-get-focus)) -;; -;; where `mymodename' is the same value as passed to `eieio-speedbar-create' -;; as the MODENAME parameter. - -;; @todo - Can we make this ECB friendly? - -;;; Code: -(require 'eieio) -(require 'eieio-custom) -(require 'speedbar) - -;;; Support a way of adding generic object based modes into speedbar. -;; -(defun eieio-speedbar-make-map () - "Make the generic object based speedbar keymap." - (let ((map (speedbar-make-specialized-keymap))) - - ;; General viewing things - (define-key map "\C-m" 'speedbar-edit-line) - (define-key map "+" 'speedbar-expand-line) - (define-key map "=" 'speedbar-expand-line) - (define-key map "-" 'speedbar-contract-line) - - ;; Some object based things - (define-key map "C" 'eieio-speedbar-customize-line) - map)) - -(defvar eieio-speedbar-key-map (eieio-speedbar-make-map) - "A Generic object based speedbar display keymap.") - -(defvar eieio-speedbar-menu - '([ "Edit Object/Field" speedbar-edit-line t] - [ "Expand Object" speedbar-expand-line - (save-excursion (beginning-of-line) - (looking-at "[0-9]+: *.\\+. "))] - [ "Contract Object" speedbar-contract-line - (save-excursion (beginning-of-line) - (looking-at "[0-9]+: *.-. "))] - "---" - [ "Customize Object" eieio-speedbar-customize-line - (eieio-object-p (speedbar-line-token)) ] - ) - "Menu part in easymenu format used in speedbar while browsing objects.") - -;; Note to self: Fix this silly thing! -(defalias 'eieio-speedbar-customize-line 'speedbar-edit-line) - -(defun eieio-speedbar-create (map-fn map-var menu-var modename fetcher) - "Create a speedbar mode for displaying an object hierarchy. -MAP-FN is the keymap generator function used for extra keys. -MAP-VAR is the keymap variable used. -MENU-VAR is the symbol containting an easymenu compatible menu part to use. -MODENAME is a s tring used to identify this browser mode. -FETCHER is a generic function used to fetch the base object list used when -creating the speedbar display." - (if (not (featurep 'speedbar)) - (add-hook 'speedbar-load-hook - (list 'lambda nil - (list 'eieio-speedbar-create-engine - map-fn map-var menu-var modename fetcher))) - (eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher))) - -(defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher) - "Create a speedbar mode for displaying an object hierarchy. -Called from `eieio-speedbar-create', or the speedbar load-hook. -MAP-FN, MAP-VAR, MENU-VAR, MODENAME, and FETCHER are the same as -`eieio-speedbar-create'." - ;; make sure the keymap exists - (funcall map-fn) - ;; Add to the expansion list. - (speedbar-add-expansion-list - (list modename - menu-var - map-var - (list 'lambda '(dir depth) - (list 'eieio-speedbar-buttons 'dir 'depth - (list 'quote fetcher))))) - ;; Set the special functions. - (speedbar-add-mode-functions-list - (list modename - '(speedbar-item-info . eieio-speedbar-item-info) - '(speedbar-line-directory . eieio-speedbar-line-path)))) - -(defun eieio-speedbar-buttons (dir-or-object depth fetcher) - "Create buttons for the speedbar display. -Start in directory DIR-OR-OBJECT. If it is an object, just display that -objects subelements. -Argument DEPTH specifies how far down we have already been displayed. -If it is a directory, use FETCHER to fetch all objects associated with -that path." - (let ((objlst (cond ((eieio-object-p dir-or-object) - (list dir-or-object)) - ((stringp dir-or-object) - (funcall fetcher dir-or-object)) - (t dir-or-object)))) - (if (not objlst) - (speedbar-make-tag-line nil nil nil nil "Empty display" nil nil nil - depth) - ;; Dump all objects into speedbar - (while objlst - (eieio-speedbar-make-tag-line (car objlst) depth) - (setq objlst (cdr objlst)))))) - - -;;; DEFAULT SUPERCLASS baseline methods -;; -;; First, define methods onto the superclass so all classes -;; will have some minor support. - -(defmethod eieio-speedbar-description ((object eieio-default-superclass)) - "Return a string describing OBJECT." - (object-name-string object)) - -(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass)) - "Return the path which OBJECT has something to do with." - nil) - -(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass)) - "Return a string to use as a speedbar button for OBJECT." - (object-name-string object)) - -(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass) - depth) - "Insert a tag line into speedbar at point for OBJECT. -By default, all objects appear as simple TAGS with no need to inherit from -the special `eieio-speedbar' classes. Child classes should redefine this -method to create more accurate tag lines. -Argument DEPTH is the depth at which the tag line is inserted." - (speedbar-make-tag-line nil nil nil nil - (eieio-speedbar-object-buttonname object) - 'eieio-speedbar-object-click - object - 'speedbar-tag-face - depth)) - -(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass)) - "Handle a click action on OBJECT in speedbar. -Any object can be represented as a tag in SPEEDBAR without special -attributes. These default objects will be pulled up in a custom -object edit buffer doing an in-place edit. - -If your object represents some other item, override this method -and take the apropriate action." - (require 'eieio-custom) - (speedbar-with-attached-buffer - (eieio-customize-object object)) - (speedbar-maybee-jump-to-attached-frame)) - - -;;; Class definitions -;; -;; Now define a special speedbar class with some -;; variables with :allocation class which can be attached into -;; object hierarchies. -;; -;; These more complex types are for objects which wish to display -;; lists of children buttons. - -(defclass eieio-speedbar nil - ((buttontype :initform nil - :type symbol - :documentation - "The type of expansion button used for objects of this class. -Possible values are those symbols supported by the `exp-button-type' argument -to `speedbar-make-tag-line'." - :allocation :class) - (buttonface :initform speedbar-tag-face - :type (or symbol face) - :documentation - "The face used on the textual part of the button for this class. -See `speedbar-make-tag-line' for details." - :allocation :class) - (expanded :initform nil - :type boolean - :documentation - "State of an object being expanded in speedbar.") - ) - "Class which provides basic speedbar support for child classes. -Add one of thie child classes to this class to the parent list of a class." - :method-invocation-order :depth-first - :abstract t) - -(defclass eieio-speedbar-directory-button (eieio-speedbar) - ((buttontype :initform angle) - (buttonface :initform speedbar-directory-face)) - "Class providing support for objects which behave like a directory." - :method-invocation-order :depth-first - :abstract t) - -(defclass eieio-speedbar-file-button (eieio-speedbar) - ((buttontype :initform bracket) - (buttonface :initform speedbar-file-face)) - "Class providing support for objects which behave like a directory." - :method-invocation-order :depth-first - :abstract t) - - -;;; Methods to eieio-speedbar-* which do not need to be overriden -;; -(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) - depth) - "Insert a tag line into speedbar at point for OBJECT. -All objects a child of symbol `eieio-speedbar' can be created from this -method. Override this if you need non-traditional tag lines. -Argument DEPTH is the depth at which the tag line is inserted." - (let ((children (eieio-speedbar-object-children object)) - (exp (oref object expanded))) - (if (not children) - (if (eq (oref object buttontype) 'expandtag) - (speedbar-make-tag-line 'statictag - ? nil nil - (eieio-speedbar-object-buttonname object) - 'eieio-speedbar-object-click - object - (oref object buttonface) - depth) - (speedbar-make-tag-line (oref object buttontype) - ? nil nil - (eieio-speedbar-object-buttonname object) - 'eieio-speedbar-object-click - object - (oref object buttonface) - depth)) - (speedbar-make-tag-line (oref object buttontype) - (if exp ?- ?+) - 'eieio-speedbar-object-expand - object - (eieio-speedbar-object-buttonname object) - 'eieio-speedbar-object-click - object - (oref object buttonface) - depth) - (if exp - (eieio-speedbar-expand object (1+ depth)))))) - -(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth) - "Base method for creating tag lines for non-object children." - (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" - (object-name object))) - -(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) - "Expand OBJECT at indentation DEPTH. -Inserts a list of new tag lines representing expanded elements withing -OBJECT." - (let ((children (eieio-speedbar-object-children object))) - (cond ((eieio-object-p (car children)) - (mapcar (lambda (car) - (eieio-speedbar-make-tag-line car depth)) - children)) - (children (eieio-speedbar-child-make-tag-lines object depth))))) - - -;;; Speedbar specific function callbacks. -;; -(defun eieio-speedbar-object-click (text token indent) - "Handle a user click on TEXT representing object TOKEN. -The object is at indentation level INDENT." - (eieio-speedbar-handle-click token)) - -(defun eieio-speedbar-object-expand (text token indent) - "Expand object represented by TEXT. TOKEN is the object. -INDENT is the current indentation level." - (cond ((string-match "+" text) ;we have to expand this file - (speedbar-change-expand-button-char ?-) - (oset token expanded t) - (speedbar-with-writable - (save-excursion - (end-of-line) (forward-char 1) - (eieio-speedbar-expand token (1+ indent))))) - ((string-match "-" text) ;we have to contract this node - (speedbar-change-expand-button-char ?+) - (oset token expanded nil) - (speedbar-delete-subblock indent)) - (t (error "Ooops... not sure what to do"))) - (speedbar-center-buffer-smartly)) - -(defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) - "Return a description for a child of OBJ which is not an object." - (error "You must implement `eieio-speedbar-child-description' for %s" - (object-name obj))) - -(defun eieio-speedbar-item-info () - "Display info for the current line when in EDE display mode." - ;; Switch across the types of the tokens. - (let ((tok (speedbar-line-token))) - (cond ((eieio-object-p tok) - (message (eieio-speedbar-description tok))) - (t - (let ((no (eieio-speedbar-find-nearest-object))) - (if no - (eieio-speedbar-child-description no))))))) - -(defun eieio-speedbar-find-nearest-object (&optional depth) - "Search backwards to the first line associated with an object. -Optional argument DEPTH is the current depth of the search." - (save-excursion - (if (not depth) - (progn - (beginning-of-line) - (when (looking-at "^\\([0-9]+\\):") - (setq depth (string-to-number (match-string 1)))))) - (when depth - (while (and (not (eieio-object-p (speedbar-line-token))) - (> depth 0)) - (setq depth (1- depth)) - (re-search-backward (format "^%d:" depth) nil t)) - (speedbar-line-token)))) - -(defun eieio-speedbar-line-path (&optional depth) - "If applicable, return the path to the file the cursor is on. -Optional DEPTH is the depth we start at." - (save-match-data - (if (not depth) - (progn - (beginning-of-line) - (looking-at "^\\([0-9]+\\):") - (setq depth (string-to-number (match-string 1))))) - ;; This whole function is presently bogus. Make it better later. - (let ((tok (eieio-speedbar-find-nearest-object depth))) - (if (eieio-object-p tok) - (eieio-speedbar-derive-line-path tok) - default-directory)))) - - -;;; Methods to the eieio-speedbar-* classes which need to be overriden. -;; -(defmethod eieio-speedbar-object-children ((object eieio-speedbar)) - "Return a list of children to be displayed in SPEEDBAR. -If the return value is a list of OBJECTs, then those objects are -queried for details. If the return list is made of strings, -then this object will be queried for the details needed -to create a speedbar button." - nil) - -(provide 'eieio-speedbar) - -;;; eieio-speedbar.el ends here
--- a/lisp/eieio/eieio.el Sat Aug 29 22:28:15 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2842 +0,0 @@ -;;; 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.") - -(require 'cl) - -(defun eieio-version () - "Display the current version of EIEIO." - (interactive) - (message eieio-version)) - -(eval-and-compile -;; Abount the above. EIEIO must process it's own code when it compiles -;; itself, thus, by eval-and-compiling outselves, we solve the problem. - -;; Compatibility -(if (fboundp 'compiled-function-arglist) - - ;; XEmacs can only access a compiled functions arglist like this: - (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) - - ;; Emacs doesn't have this function, but since FUNC is a vector, we can just - ;; grab the appropriate element. - (defun eieio-compiled-function-arglist (func) - "Return the argument list for the compiled function FUNC." - (aref func 0)) - - ) - - -;;; -;; Variable declarations. -;; - -(defvar eieio-hook nil - "*This hook is executed, then cleared each time `defclass' is called.") - -(defvar eieio-error-unsupported-class-tags nil - "*Non nil to throw an error if an encountered tag us unsupported. -This may prevent classes from CLOS applications from being used with EIEIO -since EIEIO does not support all CLOS tags.") - -(defvar eieio-skip-typecheck nil - "*If non-nil, skip all slot typechecking. -Set this to t permanently if a program is functioning well to get a -small speed increase. This variable is also used internally to handle -default setting for optimization purposes.") - -(defvar eieio-optimize-primary-methods-flag t - "Non-nil means to optimize the method dispatch on primary methods.") - -;; State Variables -(defvar this nil - "Inside a method, this variable is the object in question. -DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. - -Note: Embedded methods are no longer supported. The variable THIS is -still set for CLOS methods for the sake of routines like -`call-next-method'") - -(defvar scoped-class nil - "This is set to a class when a method is running. -This is so we know we are allowed to check private parts or how to -execute a `call-next-method'. DO NOT SET THIS YOURSELF!") - -(defvar eieio-initializing-object nil - "Set to non-nil while initializing an object.") - -(defconst eieio-unbound (make-symbol "unbound") - "Uninterned symbol representing an unbound slot in an object.") - -;; This is a bootstrap for eieio-default-superclass so it has a value -;; while it is being built itself. -(defvar eieio-default-superclass nil) - -(defconst class-symbol 1 "Class's symbol (self-referencing.).") -(defconst class-parent 2 "Class parent slot.") -(defconst class-children 3 "Class children class slot.") -(defconst class-symbol-obarray 4 "Obarray permitting fast access to variable position indexes.") -;; @todo -;; the word "public" here is leftovers from the very first version. -;; Get rid of it! -(defconst class-public-a 5 "Class attribute index.") -(defconst class-public-d 6 "Class attribute defaults index.") -(defconst class-public-doc 7 "Class documentation strings for attributes.") -(defconst class-public-type 8 "Class type for a slot.") -(defconst class-public-custom 9 "Class custom type for a slot.") -(defconst class-public-custom-label 10 "Class custom group for a slot.") -(defconst class-public-custom-group 11 "Class custom group for a slot.") -(defconst class-public-printer 12 "Printer for a slot.") -(defconst class-protection 13 "Class protection for a slot.") -(defconst class-initarg-tuples 14 "Class initarg tuples list.") -(defconst class-class-allocation-a 15 "Class allocated attributes.") -(defconst class-class-allocation-doc 16 "Class allocated documentation.") -(defconst class-class-allocation-type 17 "Class allocated value type.") -(defconst class-class-allocation-custom 18 "Class allocated custom descriptor.") -(defconst class-class-allocation-custom-label 19 "Class allocated custom descriptor.") -(defconst class-class-allocation-custom-group 20 "Class allocated custom group.") -(defconst class-class-allocation-printer 21 "Class allocated printer for a slot.") -(defconst class-class-allocation-protection 22 "Class allocated protection list.") -(defconst class-class-allocation-values 23 "Class allocated value vector.") -(defconst class-default-object-cache 24 - "Cache index of what a newly created object would look like. -This will speed up instantiation time as only a `copy-sequence' will -be needed, instead of looping over all the values and setting them -from the default.") -(defconst class-options 25 - "Storage location of tagged class options. -Stored outright without modifications or stripping.") - -(defconst class-num-slots 26 - "Number of slots in the class definition object.") - -(defconst object-class 1 "Index in an object vector where the class is stored.") -(defconst object-name 2 "Index in an object where the name is stored.") - -(defconst method-static 0 "Index into :static tag on a method.") -(defconst method-before 1 "Index into :before tag on a method.") -(defconst method-primary 2 "Index into :primary tag on a method.") -(defconst method-after 3 "Index into :after tag on a method.") -(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") -(defconst method-generic-before 4 "Index into generic :before tag on a method.") -(defconst method-generic-primary 5 "Index into generic :primary tag on a method.") -(defconst method-generic-after 6 "Index into generic :after tag on a method.") -(defconst method-num-slots 7 "Number of indexes into a method's vector.") - -;; How to specialty compile stuff. -(autoload 'byte-compile-file-form-defmethod "eieio-comp" - "This function is used to byte compile methods in a nice way.") -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) - -(eval-when-compile (require 'eieio-comp)) - - -;;; Important macros used in eieio. -;; -(defmacro class-v (class) - "Internal: Return the class vector from the CLASS symbol." - ;; No check: If eieio gets this far, it's probably been checked already. - `(get ,class 'eieio-class-definition)) - -(defmacro class-p (class) - "Return t if CLASS is a valid class vector. -CLASS is a symbol." - ;; this new method is faster since it doesn't waste time checking lots of - ;; things. - `(condition-case nil - (eq (aref (class-v ,class) 0) 'defclass) - (error nil))) - -;;;###autoload -(defmacro eieio-object-p (obj) - "Return non-nil if OBJ is an EIEIO object." - `(condition-case nil - (let ((tobj ,obj)) - (and (eq (aref tobj 0) 'object) - (class-p (aref tobj object-class)))) - (error nil))) -(defalias 'object-p 'eieio-object-p) - -(defmacro class-constructor (class) - "Return the symbol representing the constructor of CLASS." - `(aref (class-v ,class) class-symbol)) - -(defmacro generic-p (method) - "Return t if symbol METHOD is a generic function. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.)" - `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) - -(defun generic-primary-only-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (< 0 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defun generic-primary-only-one-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (= 1 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defmacro class-option-assoc (list option) - "Return from LIST the found OPTION. Nil if it doesn't exist." - `(car-safe (cdr (memq ,option ,list)))) - -(defmacro class-option (class option) - "Return the value stored for CLASS' OPTION. -Return nil if that option doesn't exist." - `(class-option-assoc (aref (class-v ,class) class-options) ',option)) - -(defmacro class-abstract-p (class) - "Return non-nil if CLASS is abstract. -Abstract classes cannot be instantiated." - `(class-option ,class :abstract)) - -(defmacro class-method-invocation-order (class) - "Return the invocation order of CLASS. -Abstract classes cannot be instantiated." - `(or (class-option ,class :method-invocation-order) - :breadth-first)) - - -;;; Defining a new class -;; -(defmacro defclass (name superclass slots &rest options-and-doc) - "Define NAME as a new class derived from SUPERCLASS with SLOTS. -OPTIONS-AND-DOC is used as the class' options and base documentation. -SUPERCLASS is a list of superclasses to inherit from, with SLOTS -being the slots residing in that class definition. NOTE: Currently -only one slot may exist in SUPERCLASS as multiple inheritance is not -yet supported. Supported tags are: - - :initform - initializing form - :initarg - tag used during initialization - :accessor - tag used to create a function to access this slot - :allocation - specify where the value is stored. - defaults to `:instance', but could also be `:class' - :writer - a function symbol which will `write' an object's slot - :reader - a function symbol which will `read' an object - :type - the type of data allowed in this slot (see `typep') - :documentation - - A string documenting use of this slot. - -The following are extensions on CLOS: - :protection - Specify protection for this slot. - Defaults to `:public'. Also use `:protected', or `:private' - :custom - When customizing an object, the custom :type. Public only. - :label - A text string label used for a slot when customizing. - :group - Name of a customization group this slot belongs in. - :printer - A function to call to print the value of a slot. - See `eieio-override-prin1' as an example. - -A class can also have optional options. These options happen in place -of documentation, (including a :documentation tag) in addition to -documentation, or not at all. Supported options are: - - :documentation - The doc-string used for this class. - -Options added to EIEIO: - - :allow-nil-initform - Non-nil to skip typechecking of initforms if nil. - :custom-groups - List of custom group names. Organizes slots into - reasonable groups for customizations. - :abstract - Non-nil to prevent instances of this class. - If a string, use as an error string if someone does - try to make an instance. - :method-invocation-order - - Control the method invokation order if there is - multiple inheritance. Valid values are: - :breadth-first - The default. - :depth-first - -Options in CLOS not supported in EIEIO: - - :metaclass - Class to use in place of `standard-class' - :default-initargs - Initargs to use when initializing new objects of - this class. - -Due to the way class options are set up, you can add any tags in you -wish, and reference them using the function `class-option'." - ;; We must `eval-and-compile' this so that when we byte compile - ;; an eieio program, there is no need to load it ahead of time. - ;; It also provides lots of nice debugging errors at compile time. - `(eval-and-compile - (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) - -(defvar eieio-defclass-autoload-map (make-vector 7 nil) - "Symbol map of superclasses we find in autoloads.") - -(defun eieio-defclass-autoload (cname superclasses filename doc) - "Create autoload symbols for the EIEIO class CNAME. -SUPERCLASSES are the superclasses that CNAME inherites from. -DOC is the docstring for CNAME. -This function creates a mock-class for CNAME and adds it into -SUPERCLASSES as children. -It creates an autoload function for CNAME's constructor." - ;; Assume we've already debugged inputs. - - (let* ((oldc (when (class-p cname) (class-v cname))) - (newc (make-vector class-num-slots nil)) - ) - (if oldc - nil ;; Do nothing if we already have this class. - - ;; Create the class in NEWC, but don't fill anything else in. - (aset newc 0 'defclass) - (aset newc class-symbol cname) - - (let ((clear-parent nil)) - ;; No parents? - (when (not superclasses) - (setq superclasses '(eieio-default-superclass) - clear-parent t) - ) - - ;; Hook our new class into the existing structures so we can - ;; autoload it later. - (dolist (SC superclasses) - - - ;; TODO - If we create an autoload that is in the map, that - ;; map needs to be cleared! - - - ;; Does our parent exist? - (if (not (class-p SC)) - - ;; Create a symbol for this parent, and then store this - ;; parent on that symbol. - (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) - (if (not (boundp sym)) - (set sym (list cname)) - (add-to-list sym cname)) - ) - - ;; We have a parent, save the child in there. - (when (not (member cname (aref (class-v SC) class-children))) - (aset (class-v SC) class-children - (cons cname (aref (class-v SC) class-children))))) - - ;; save parent in child - (aset newc class-parent (cons SC (aref newc class-parent))) - ) - - ;; turn this into a useable self-pointing symbol - (set cname cname) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) - - ;; Clear the parent - (if clear-parent (aset newc class-parent nil)) - - ;; Create an autoload on top of our constructor function. - (autoload cname filename doc nil nil) - (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) - - )))) - -(defsubst eieio-class-un-autoload (cname) - "If class CNAME is in an autoload state, load it's file." - (when (eq (car-safe (symbol-function cname)) 'autoload) - (load-library (car (cdr (symbol-function cname)))))) - -(defun eieio-defclass (cname superclasses slots options-and-doc) - "See `defclass' for more information. -Define CNAME as a new subclass of SUPERCLASSES, with SLOTS being the -slots residing in that class definition, and with options or documentation -OPTIONS-AND-DOC as the toplevel documentation for this class." - ;; Run our eieio-hook each time, and clear it when we are done. - ;; This way people can add hooks safely if they want to modify eieio - ;; or add definitions when eieio is loaded or something like that. - (run-hooks 'eieio-hook) - (setq eieio-hook nil) - - (if (not (symbolp cname)) (signal 'wrong-type-argument '(symbolp cname))) - (if (not (listp superclasses)) (signal 'wrong-type-argument '(listp superclasses))) - - (let* ((pname (if superclasses superclasses nil)) - (newc (make-vector class-num-slots nil)) - (oldc (when (class-p cname) (class-v cname))) - (groups nil) ;; list of groups id'd from slots - (options nil) - (clearparent nil)) - - (aset newc 0 'defclass) - (aset newc class-symbol cname) - - ;; If this class already existed, and we are updating it's structure, - ;; make sure we keep the old child list. This can cause bugs, but - ;; if no new slots are created, it also saves time, and prevents - ;; method table breakage, particularly when the users is only - ;; byte compiling an EIEIO file. - (if oldc - (aset newc class-children (aref oldc class-children)) - ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. - ;; This is like the above, but deals with autoloads nicely. - (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) - (when sym - (condition-case nil - (aset newc class-children (symbol-value sym)) - (error nil)) - (unintern (symbol-name cname) eieio-defclass-autoload-map) - )) - ) - - (cond ((and (stringp (car options-and-doc)) - (/= 1 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ((and (symbolp (car options-and-doc)) - (/= 0 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ) - - (setq options - (if (stringp (car options-and-doc)) - (cons :documentation options-and-doc) - options-and-doc)) - - (if pname - (progn - (while pname - (if (and (car pname) (symbolp (car pname))) - (if (not (class-p (car pname))) - ;; bad class - (error "Given parent class %s is not a class" (car pname)) - ;; good parent class... - ;; save new child in parent - (when (not (member cname (aref (class-v (car pname)) class-children))) - (aset (class-v (car pname)) class-children - (cons cname (aref (class-v (car pname)) class-children)))) - ;; Get custom groups, and store them into our local copy. - (mapc (lambda (g) (add-to-list 'groups g)) - (class-option (car pname) :custom-groups)) - ;; save parent in child - (aset newc class-parent (cons (car pname) (aref newc class-parent)))) - (error "Invalid parent class %s" pname)) - (setq pname (cdr pname))) - ;; Reverse the list of our parents so that they are prioritized in - ;; the same order as specified in the code. - (aset newc class-parent (nreverse (aref newc class-parent))) ) - ;; If there is nothing to loop over, then inherit from the - ;; default superclass. - (unless (eq cname 'eieio-default-superclass) - ;; adopt the default parent here, but clear it later... - (setq clearparent t) - ;; save new child in parent - (if (not (member cname (aref (class-v 'eieio-default-superclass) class-children))) - (aset (class-v 'eieio-default-superclass) class-children - (cons cname (aref (class-v 'eieio-default-superclass) class-children)))) - ;; save parent in child - (aset newc class-parent (list eieio-default-superclass)))) - - ;; turn this into a useable self-pointing symbol - (set cname cname) - - ;; These two tests must be created right away so we can have self- - ;; referencing classes. ei, a class whose slot can contain only - ;; pointers to itself. - - ;; Create the test function - (let ((csym (intern (concat (symbol-name cname) "-p")))) - (fset csym - (list 'lambda (list 'obj) - (format "Test OBJ to see if it an object of type %s" cname) - (list 'and '(eieio-object-p obj) - (list 'same-class-p 'obj cname))))) - - ;; Make sure the method invocation order is a valid value. - (let ((io (class-option-assoc options :method-invocation-order))) - (when (and io (not (member io '(:depth-first :breadth-first)))) - (error "Method invocation order %s is not allowed" io) - )) - - ;; Create a handy child test too - (let ((csym (intern (concat (symbol-name cname) "-child-p")))) - (fset csym - `(lambda (obj) - ,(format - "Test OBJ to see if it an object is a child of type %s" - cname) - (and (eieio-object-p obj) - (object-of-class-p obj ,cname)))) - - ;; When using typep, (typep OBJ 'myclass) returns t for objects which - ;; are subclasses of myclass. For our predicates, however, it is - ;; important for EIEIO to be backwards compatible, where - ;; myobject-p, and myobject-child-p are different. - ;; "cl" uses this technique to specify symbols with specific typep - ;; test, so we can let typep have the CLOS documented behavior - ;; while keeping our above predicate clean. - (eval `(deftype ,cname () - '(satisfies - ,(intern (concat (symbol-name cname) "-child-p"))))) - - ) - - ;; before adding new slots, lets add all the methods and classes - ;; in from the parent class - (eieio-copy-parents-into-subclass newc superclasses) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) - - ;; Query each slot in the declaration list and mangle into the - ;; class structure I have defined. - (while slots - (let* ((slot1 (car slots)) - (name (car slot1)) - (slot (cdr slot1)) - (acces (plist-get slot ':accessor)) - (init (or (plist-get slot ':initform) - (if (member ':initform slot) nil - eieio-unbound))) - (initarg (plist-get slot ':initarg)) - (docstr (plist-get slot ':documentation)) - (prot (plist-get slot ':protection)) - (reader (plist-get slot ':reader)) - (writer (plist-get slot ':writer)) - (alloc (plist-get slot ':allocation)) - (type (plist-get slot ':type)) - (custom (plist-get slot ':custom)) - (label (plist-get slot ':label)) - (customg (plist-get slot ':group)) - (printer (plist-get slot ':printer)) - - (skip-nil (class-option-assoc options :allow-nil-initform)) - ) - - (if eieio-error-unsupported-class-tags - (let ((tmp slot)) - (while tmp - (if (not (member (car tmp) '(:accessor - :initform - :initarg - :documentation - :protection - :reader - :writer - :allocation - :type - :custom - :label - :group - :printer - :allow-nil-initform - :custom-groups))) - (signal 'invalid-slot-type (list (car tmp)))) - (setq tmp (cdr (cdr tmp)))))) - - ;; Clean up the meaning of protection. - (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) - ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) - ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) - ((eq prot nil) nil) - (t (signal 'invalid-slot-type (list ':protection prot)))) - - ;; Make sure the :allocation parameter has a valid value. - (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) - (signal 'invalid-slot-type (list ':allocation alloc))) - - ;; The default type specifier is supposed to be t, meaning anything. - (if (not type) (setq type t)) - - ;; Label is nil, or a string - (if (not (or (null label) (stringp label))) - (signal 'invalid-slot-type (list ':label label))) - - ;; Is there an initarg, but allocation of class? - (if (and initarg (eq alloc :class)) - (message "Class allocated slots do not need :initarg")) - - ;; intern the symbol so we can use it blankly - (if initarg (set initarg initarg)) - - ;; The customgroup should be a list of symbols - (cond ((null customg) - (setq customg '(default))) - ((not (listp customg)) - (setq customg (list customg)))) - ;; The customgroup better be a symbol, or list of symbols. - (mapc (lambda (cg) - (if (not (symbolp cg)) - (signal 'invalid-slot-type (list ':group cg)))) - customg) - - ;; First up, add this slot into our new class. - (eieio-add-new-slot newc name init docstr type custom label customg printer - prot initarg alloc 'defaultoverride skip-nil) - - ;; We need to id the group, and store them in a group list attribute. - (mapc (lambda (cg) (add-to-list 'groups cg)) customg) - - ;; anyone can have an accessor function. This creates a function - ;; of the specified name, and also performs a `defsetf' if applicable - ;; so that users can `setf' the space returned by this function - (if acces - (progn - (eieio-defmethod acces - (list (if (eq alloc :class) :static :primary) - (list (list 'this cname)) - (format - "Retrieves the slot `%s' from an object of class `%s'" - name cname) - (list 'if (list 'slot-boundp 'this (list 'quote name)) - (list 'eieio-oref 'this (list 'quote name)) - ;; Else - Some error? nil? - nil - ))) - ;; Thanks Pascal Bourguignon <pjb@informatimago.com> - ;; For this complex macro. - (eval (macroexpand - (list 'defsetf acces '(widget) '(store) - (list 'list ''eieio-oset 'widget - (list 'quote (list 'quote name)) 'store)))) - ;;`(defsetf ,acces (widget) (store) (eieio-oset widget ',cname store)) - ) - ) - ;; If a writer is defined, then create a generic method of that - ;; name whose purpose is to set the value of the slot. - (if writer - (progn - (eieio-defmethod writer - (list (list (list 'this cname) 'value) - (format "Set the slot `%s' of an object of class `%s'" - name cname) - `(setf (slot-value this ',name) value))) - )) - ;; If a reader is defined, then create a generic method - ;; of that name whose purpose is to access this slot value. - (if reader - (progn - (eieio-defmethod reader - (list (list (list 'this cname)) - (format "Access the slot `%s' from object of class `%s'" - name cname) - `(slot-value this ',name))))) - ) - (setq slots (cdr slots))) - - ;; Now that everything has been loaded up, all our lists are backwards! Fix that up now. - (aset newc class-public-a (nreverse (aref newc class-public-a))) - (aset newc class-public-d (nreverse (aref newc class-public-d))) - (aset newc class-public-doc (nreverse (aref newc class-public-doc))) - (aset newc class-public-type - (apply 'vector (nreverse (aref newc class-public-type)))) - (aset newc class-public-custom (nreverse (aref newc class-public-custom))) - (aset newc class-public-custom-label (nreverse (aref newc class-public-custom-label))) - (aset newc class-public-custom-group (nreverse (aref newc class-public-custom-group))) - (aset newc class-public-printer (nreverse (aref newc class-public-printer))) - (aset newc class-protection (nreverse (aref newc class-protection))) - (aset newc class-initarg-tuples (nreverse (aref newc class-initarg-tuples))) - - ;; The storage for class-class-allocation-type needs to be turned into - ;; a vector now. - (aset newc class-class-allocation-type - (apply 'vector (aref newc class-class-allocation-type))) - - ;; Also, take class allocated values, and vectorize them for speed. - (aset newc class-class-allocation-values - (apply 'vector (aref newc class-class-allocation-values))) - - ;; Attach slot symbols into an obarray, and store the index of - ;; this slot as the variable slot in this new symbol. We need to - ;; know about primes, because obarrays are best set in vectors of - ;; prime number length, and we also need to make our vector small - ;; to save space, and also optimal for the number of items we have. - (let* ((cnt 0) - (pubsyms (aref newc class-public-a)) - (prots (aref newc class-protection)) - (l (length pubsyms)) - (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 - 53 59 61 67 71 73 79 83 89 97 101 ))) - (while (and primes (< (car primes) l)) - (setq primes (cdr primes))) - (car primes))) - (oa (make-vector vl 0)) - (newsym)) - (while pubsyms - (setq newsym (intern (symbol-name (car pubsyms)) oa)) - (set newsym cnt) - (setq cnt (1+ cnt)) - (if (car prots) (put newsym 'protection (car prots))) - (setq pubsyms (cdr pubsyms) - prots (cdr prots))) - (aset newc class-symbol-obarray oa) - ) - - ;; Create the constructor function - (if (class-option-assoc options :abstract) - ;; Abstract classes cannot be instantiated. Say so. - (let ((abs (class-option-assoc options :abstract))) - (if (not (stringp abs)) - (setq abs (format "Class %s is abstract" cname))) - (fset cname - `(lambda (&rest stuff) - ,(format "You cannot create a new object of type %s" cname) - (error ,abs)))) - - ;; Non-abstract classes need a constructor. - (fset cname - `(lambda (newname &rest slots) - ,(format "Create a new object with name NAME of class type %s" cname) - (apply 'constructor ,cname newname slots))) - ) - - ;; Set up a specialized doc string. - ;; Use stored value since it is calculated in a non-trivial way - (put cname 'variable-documentation - (class-option-assoc options :documentation)) - - ;; We have a list of custom groups. Store them into the options. - (let ((g (class-option-assoc options :custom-groups))) - (mapc (lambda (cg) (add-to-list 'g cg)) groups) - (if (memq :custom-groups options) - (setcar (cdr (memq :custom-groups options)) g) - (setq options (cons :custom-groups (cons g options))))) - - ;; Set up the options we have collected. - (aset newc class-options options) - - ;; if this is a superclass, clear out parent (which was set to the - ;; default superclass eieio-default-superclass) - (if clearparent (aset newc class-parent nil)) - - ;; Create the cached default object. - (let ((cache (make-vector (+ (length (aref newc class-public-a)) - 3) nil))) - (aset cache 0 'object) - (aset cache object-class cname) - (aset cache object-name 'default-cache-object) - (let ((eieio-skip-typecheck t)) - ;; All type-checking has been done to our satisfaction - ;; before this call. Don't waste our time in this call.. - (eieio-set-defaults cache t)) - (aset newc class-default-object-cache cache)) - - ;; Return our new class object - ;; newc - cname - )) - -(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) - "For SLOT, signal if SPEC does not match VALUE. -If SKIPNIL is non-nil, then if VALUE is nil, return t." - (let ((val (eieio-default-eval-maybe value))) - (if (and (not eieio-skip-typecheck) - (not (and skipnil (null val))) - (not (eieio-perform-slot-validation spec val))) - (signal 'invalid-slot-type (list slot spec val))))) - -(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc - &optional defaultoverride skipnil) - "Add into NEWC attribute A. -If A already exists in NEWC, then do nothing. If it doesn't exist, -then also add in D (defualt), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. -Argument ALLOC specifies if the slot is allocated per instance, or per class. -If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, -we must override it's value for a default. -Optional argument SKIPNIL indicates if type checking should be skipped -if default value is nil." - ;; Make sure we duplicate those items that are sequences. - (condition-case nil - (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Lets skip it if it doesn't work. - (error nil)) - (if (sequencep type) (setq type (copy-sequence type))) - (if (sequencep cust) (setq cust (copy-sequence cust))) - (if (sequencep custg) (setq custg (copy-sequence custg))) - - ;; To prevent override information w/out specification of storage, - ;; we need to do this little hack. - (if (member a (aref newc class-class-allocation-a)) (setq alloc ':class)) - - (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) - ;; In this case, we modify the INSTANCE version of a given slot. - - (progn - - ;; Only add this element if it is so-far unique - (if (not (member a (aref newc class-public-a))) - (progn - (eieio-perform-slot-validation-for-default a type d skipnil) - (aset newc class-public-a (cons a (aref newc class-public-a))) - (aset newc class-public-d (cons d (aref newc class-public-d))) - (aset newc class-public-doc (cons doc (aref newc class-public-doc))) - (aset newc class-public-type (cons type (aref newc class-public-type))) - (aset newc class-public-custom (cons cust (aref newc class-public-custom))) - (aset newc class-public-custom-label (cons label (aref newc class-public-custom-label))) - (aset newc class-public-custom-group (cons custg (aref newc class-public-custom-group))) - (aset newc class-public-printer (cons print (aref newc class-public-printer))) - (aset newc class-protection (cons prot (aref newc class-protection))) - (aset newc class-initarg-tuples (cons (cons init a) (aref newc class-initarg-tuples))) - ) - ;; When defaultoverride is true, we are usually adding new local - ;; attributes which must override the default value of any slot - ;; passed in by one of the parent classes. - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (aref newc class-public-a)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np (nthcdr num (aref newc class-public-d)) - nil)) - (tp (if np (nth num (aref newc class-public-type)))) - ) - (if (not np) - (error "Eieio internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; If we have a repeat, only update the initarg... - (unless (eq d eieio-unbound) - (eieio-perform-slot-validation-for-default a tp d skipnil) - (setcar dp d)) - ;; If we have a new initarg, check for it. - (when init - (let* ((inits (aref newc class-initarg-tuples)) - (inita (rassq a inits))) - ;; Replace the CAR of the associate INITA. - ;;(message "Initarg: %S replace %s" inita init) - (setcar inita init) - )) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - ;; - ;; EML - We used to have (if prot... here, - ;; but a prot of 'nil means public. - ;; - (let ((super-prot (nth num (aref newc class-protection))) - ) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; End original PLN - - ;; PLN Tue Jun 26 11:57:06 2007 : - ;; We do a non redundant combination of ancient - ;; custom groups and new ones using the common lisp - ;; `union' method. - (when custg - (let ((where-groups - (nthcdr num (aref newc class-public-custom-group)))) - (setcar where-groups - (union (car where-groups) - (if (listp custg) custg (list custg)))))) - ;; End PLN - - ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is - ;; set, simply replaces the old one. - (when cust - ;; (message "Custom type redefined to %s" cust) - (setcar (nthcdr num (aref newc class-public-custom)) cust)) - - ;; If a new label is specified, it simply replaces - ;; the old one. - (when label - ;; (message "Custom label redefined to %s" label) - (setcar (nthcdr num (aref newc class-public-custom-label)) label)) - ;; End PLN - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (aref newc class-public-doc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (aref newc class-public-printer)) print)) - - ))) - )) - - ;; CLASS ALLOCATED SLOTS - (let ((value (eieio-default-eval-maybe d))) - (if (not (member a (aref newc class-class-allocation-a))) - (progn - (eieio-perform-slot-validation-for-default a type value skipnil) - ;; Here we have found a :class version of a slot. This - ;; requires a very different aproach. - (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a))) - (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc))) - (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type))) - (aset newc class-class-allocation-custom (cons cust (aref newc class-class-allocation-custom))) - (aset newc class-class-allocation-custom-label (cons label (aref newc class-class-allocation-custom-label))) - (aset newc class-class-allocation-custom-group (cons custg (aref newc class-class-allocation-custom-group))) - (aset newc class-class-allocation-protection (cons prot (aref newc class-class-allocation-protection))) - ;; Default value is stored in the 'values section, since new objects - ;; can't initialize from this element. - (aset newc class-class-allocation-values (cons value (aref newc class-class-allocation-values)))) - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (aref newc class-class-allocation-a)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np - (nthcdr num - (aref newc class-class-allocation-values)) - nil)) - (tp (if np (nth num (aref newc class-class-allocation-type)) - nil))) - (if (not np) - (error "Eieio internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; EML - Note: the only reason to override a class bound slot - ;; is to change the default, so allow unbound in. - - ;; If we have a repeat, only update the vlaue... - (eieio-perform-slot-validation-for-default a tp value skipnil) - (setcar dp value)) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - (let ((super-prot - (car (nthcdr num (aref newc class-class-allocation-protection))))) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; We do a non redundant combination of ancient - ;; custom groups and new ones using the common lisp - ;; `union' method. - (when custg - (let ((where-groups - (nthcdr num (aref newc class-class-allocation-custom-group)))) - (setcar where-groups - (union (car where-groups) - (if (listp custg) custg (list custg)))))) - ;; End PLN - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (aref newc class-class-allocation-doc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (aref newc class-class-allocation-printer)) print)) - - )) - )) - )) - -(defun eieio-copy-parents-into-subclass (newc parents) - "Copy into NEWC the slots of PARENTS. -Follow the rules of not overwritting early parents when applying to -the new child class." - (let ((ps (aref newc class-parent)) - (sn (class-option-assoc (aref newc class-options) - ':allow-nil-initform))) - (while ps - ;; First, duplicate all the slots of the parent. - (let ((pcv (class-v (car ps)))) - (let ((pa (aref pcv class-public-a)) - (pd (aref pcv class-public-d)) - (pdoc (aref pcv class-public-doc)) - (ptype (aref pcv class-public-type)) - (pcust (aref pcv class-public-custom)) - (plabel (aref pcv class-public-custom-label)) - (pcustg (aref pcv class-public-custom-group)) - (printer (aref pcv class-public-printer)) - (pprot (aref pcv class-protection)) - (pinit (aref pcv class-initarg-tuples)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (car pd) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) (car-safe (car pinit)) nil nil sn) - ;; Increment each value. - (setq pa (cdr pa) - pd (cdr pd) - pdoc (cdr pdoc) - i (1+ i) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - pinit (cdr pinit)) - )) ;; while/let - ;; Now duplicate all the class alloc slots. - (let ((pa (aref pcv class-class-allocation-a)) - (pdoc (aref pcv class-class-allocation-doc)) - (ptype (aref pcv class-class-allocation-type)) - (pcust (aref pcv class-class-allocation-custom)) - (plabel (aref pcv class-class-allocation-custom-label)) - (pcustg (aref pcv class-class-allocation-custom-group)) - (printer (aref pcv class-class-allocation-printer)) - (pprot (aref pcv class-class-allocation-protection)) - (pval (aref pcv class-class-allocation-values)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (aref pval i) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) nil ':class sn) - ;; Increment each value. - (setq pa (cdr pa) - pdoc (cdr pdoc) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - i (1+ i)) - ))) ;; while/let - ;; Loop over each parent class - (setq ps (cdr ps))) - )) - -;;; CLOS style implementation of object creators. -;; -(defun make-instance (class &rest initargs) - "Make a new instance of CLASS based on INITARGS. -CLASS is a class symbol. For example: - - (make-instance 'foo) - - INITARGS is a property list with keywords based on the :initarg -for each slot. For example: - - (make-instance 'foo :slot1 value1 :slotN valueN) - -Compatability note: - -If the first element of INITARGS is a string, it is used as the -name of the class. - -In EIEIO, the class' constructor requires a name for use when printing. -`make-instance' in CLOS doesn't use names the way Emacs does, so the -class is used as the name slot instead when INITARGS doesn't start with -a string." - (if (and (car initargs) (stringp (car initargs))) - (apply (class-constructor class) initargs) - (apply (class-constructor class) - (cond ((symbolp class) (symbol-name class)) - (t (format "%S" class))) - initargs))) - - -;;; CLOS methods and generics -;; -(defmacro defgeneric (method args &optional doc-string) - "Create a generic function METHOD. ARGS is ignored. -DOC-STRING is the base documentation for this class. A generic -function has no body, as it's purpose is to decide which method body -is appropriate to use. Use `defmethod' to create methods, and it -calls defgeneric for you. With this implementation the arguments are -currently ignored. You can use `defgeneric' to apply specialized -top level documentation to a method." - `(eieio-defgeneric (quote ,method) ,doc-string)) - -(defun eieio-defgeneric-form (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form method doc-string)))) - -(defun eieio-defgeneric-form-primary-only (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call-primary-only (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form-primary-only method doc-string)))) - -(defun eieio-defgeneric-form-primary-only-one (method doc-string - class - impl - ) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD. -CLASS is the class symbol needed for private method access. -IMPL is the symbol holding the method implementation." - ;; NOTE: I tried out byte compiling this little fcn. Turns out it - ;; is faster to execute this for not byte-compiled. ie, install this, - ;; then measure calls going through here. I wonder why. - (require 'bytecomp) - (let ((byte-compile-free-references nil) - (byte-compile-warnings nil) - ) - (byte-compile-lambda - `(lambda (&rest local-args) - ,doc-string - ;; This is a cool cheat. Usually we need to look up in the - ;; method table to find out if there is a method or not. We can - ;; instead make that determination at load time when there is - ;; only one method. If the first arg is not a child of the class - ;; of that one implementation, then clearly, there is no method def. - (if (not (eieio-object-p (car local-args))) - ;; Not an object. Just signal. - (signal 'no-method-definition (list ,(list 'quote method) local-args)) - - ;; We do have an object. Make sure it is the right type. - (if ,(if (eq class eieio-default-superclass) - nil ; default superclass means just an obj. Already asked. - `(not (child-of-class-p (aref (car local-args) object-class) - ,(list 'quote class))) - ) - - ;; If not the right kind of object, call no applicable - (apply 'no-applicable-method (car local-args) - ,(list 'quote method) local-args) - - ;; It is ok, do the call. - ;; Fill in inter-call variables then evaluate the method. - (let ((scoped-class ,(list 'quote class)) - (eieio-generic-call-next-method-list nil) - (eieio-generic-call-key method-primary) - (eieio-generic-call-methodname ,(list 'quote method)) - (eieio-generic-call-arglst local-args) - ) - (apply ,(list 'quote impl) local-args) - ;(,impl local-args) - )))) - ) - )) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) - "Setup METHOD to call the generic form." - (let* ((doc-string (documentation method)) - (M (get method 'eieio-method-tree)) - (entry (car (aref M method-primary))) - ) - (fset method (eieio-defgeneric-form-primary-only-one - method doc-string - (car entry) - (cdr entry) - )))) - -(defun eieio-defgeneric (method doc-string) - "Engine part to `defgeneric' macro defining METHOD with DOC-STRING." - (if (and (fboundp method) (not (generic-p method)) - (or (byte-code-function-p (symbol-function method)) - (not (eq 'autoload (car (symbol-function method))))) - ) - (error "You cannot create a generic/method over an existing symbol: %s" - method)) - ;; Don't do this over and over. - (unless (fboundp 'method) - ;; This defun tells emacs where the first definition of this - ;; method is defined. - `(defun ,method nil) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Apply the actual body of this function. - (fset method (eieio-defgeneric-form method doc-string)) - ;; Return the method - 'method)) - -(defun eieio-unbind-method-implementations (method) - "Make the generic method METHOD have no implementations.. -It will leave the original generic function in place, but remove -reference to all implementations of METHOD." - (put method 'eieio-method-tree nil) - (put method 'eieio-method-obarray nil)) - -(defmacro defmethod (method &rest args) - "Create a new METHOD through `defgeneric' with ARGS. - -The second optional argument KEY is a specifier that -modifies how the method is called, including: - :before - Method will be called before the :primary - :primary - The default if not specified. - :after - Method will be called after the :primary - :static - First arg could be an object or class -The next argument is the ARGLIST. The ARGLIST specifies the arguments -to the method as with `defun'. The first argument can have a type -specifier, such as: - ((VARNAME CLASS) ARG2 ...) -where VARNAME is the name of the local variable for the method being -created. The CLASS is a class symbol for a class made with `defclass'. -A DOCSTRING comes after the ARGLIST, and is optional. -All the rest of the args are the BODY of the method. A method will -return the value of the last form in the BODY. - -Summary: - - (defmethod mymethod [:before | :primary | :after | :static] - ((typearg class-name) arg2 &optional opt &rest rest) - \"doc-string\" - body)" - `(eieio-defmethod (quote ,method) (quote ,args))) - -(defun eieio-defmethod (method args) - "Work part of the `defmethod' macro defining METHOD with ARGS." - (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) - ;; find optional keys - (setq key - (cond ((or (eq ':BEFORE (car args)) - (eq ':before (car args))) - (setq args (cdr args)) - method-before) - ((or (eq ':AFTER (car args)) - (eq ':after (car args))) - (setq args (cdr args)) - method-after) - ((or (eq ':PRIMARY (car args)) - (eq ':primary (car args))) - (setq args (cdr args)) - method-primary) - ((or (eq ':STATIC (car args)) - (eq ':static (car args))) - (setq args (cdr args)) - method-static) - ;; Primary key - (t method-primary))) - ;; get body, and fix contents of args to be the arguments of the fn. - (setq body (cdr args) - args (car args)) - (setq loopa args) - ;; Create a fixed version of the arguments - (while loopa - (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) - argfix)) - (setq loopa (cdr loopa))) - ;; make sure there is a generic - (eieio-defgeneric - method - (if (stringp (car body)) - (car body) (format "Generically created method `%s'" method))) - ;; create symbol for property to bind to. If the first arg is of - ;; the form (varname vartype) and `vartype' is a class, then - ;; that class will be the type symbol. If not, then it will fall - ;; under the type `primary' which is a non-specific calling of the - ;; function. - (setq firstarg (car args)) - (if (listp firstarg) - (progn - (setq argclass (nth 1 firstarg)) - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - (nth 1 firstarg)))) - (if (= key -1) - (signal 'wrong-type-argument (list :static 'non-class-arg))) - ;; generics are higher - (setq key (+ key 3))) - ;; Put this lambda into the symbol so we can find it - (if (byte-code-function-p (car-safe body)) - (eieiomt-add method (car-safe body) key argclass) - (eieiomt-add method (append (list 'lambda (reverse argfix)) body) - key argclass)) - ) - - (when eieio-optimize-primary-methods-flag - ;; Optimizing step: - ;; - ;; If this method, after this setup, only has primary methods, then - ;; we can setup the generic that way. - (if (generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (generic-primary-only-one-p method) - (eieio-defgeneric-reset-generic-form-primary-only-one method) - (eieio-defgeneric-reset-generic-form-primary-only method)) - (eieio-defgeneric-reset-generic-form method))) - - method) - -;;; Slot type validation -;; -(defun eieio-perform-slot-validation (spec value) - "Return non-nil if SPEC does not match VALUE." - ;; typep is in cl-macs - (or (eq spec t) ; t always passes - (eq value eieio-unbound) ; unbound always passes - (typep value spec))) - -(defun eieio-validate-slot-value (class slot-idx value slot) - "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid. -Checks the :type specifier. -SLOT is the slot that is being checked, and is only used when throwing -and error." - (if eieio-skip-typecheck - nil - ;; Trim off object IDX junk added in for the object index. - (setq slot-idx (- slot-idx 3)) - (let ((st (aref (aref (class-v class) class-public-type) slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) - -(defun eieio-validate-class-slot-value (class slot-idx value slot) - "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid. -Checks the :type specifier. -SLOT is the slot that is being checked, and is only used when throwing -and error." - (if eieio-skip-typecheck - nil - (let ((st (aref (aref (class-v class) class-class-allocation-type) - slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) - -(defun eieio-barf-if-slot-unbound (value instance slotname fn) - "Throw a signal if VALUE is a representation of an UNBOUND slot. -INSTANCE is the object being referenced. SLOTNAME is the offending -slot. If the slot is ok, return VALUE. -Argument FN is the function calling this verifier." - (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) - (slot-unbound instance (object-class instance) slotname fn) - value)) - -;;; Missing types that are useful to me. -;; -(defun boolean-p (bool) - "Return non-nil if BOOL is nil or t." - (or (null bool) (eq bool t))) - -;;; Get/Set slots in an object. -;; -(defmacro oref (obj slot) - "Retrieve the value stored in OBJ in the slot named by SLOT. -Slot is the name of the slot when created by `defclass' or the label -created by the :initarg tag." - `(eieio-oref ,obj (quote ,slot))) - -(defun eieio-oref (obj slot) - "Return the value in OBJ at SLOT in the object vector." - (if (not (or (eieio-object-p obj) (class-p obj))) - (signal 'wrong-type-argument (list '(or eieio-object-p class-p) obj))) - (if (not (symbolp slot)) - (signal 'wrong-type-argument (list 'symbolp slot))) - (if (class-p obj) (eieio-class-un-autoload obj)) - (let* ((class (if (class-p obj) obj (aref obj object-class))) - (c (eieio-slot-name-index class obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) - ;; Oref that slot. - (aref (aref (class-v class) class-class-allocation-values) c) - ;; The slot-missing method is a cool way of allowing an object author - ;; to intercept missing slot definitions. Since it is also the LAST - ;; thing called in this fn, it's return value would be retrieved. - (slot-missing obj slot 'oref) - ;;(signal 'invalid-slot-name (list (object-name obj) slot)) - ) - (if (not (eieio-object-p obj)) - (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) - -(defalias 'slot-value 'eieio-oref) -(defalias 'set-slot-value 'eieio-oset) - -;; @TODO - DELETE THIS AFTER FAIR WARNING - -;; This alias is needed so that functions can be written -;; for defaults, but still behave like lambdas. -(defmacro lambda-default (&rest cdr) - "The same as `lambda' but is used as a default value in `defclass'. -As such, the form (lambda-default ARGS DOCSTRING INTERACTIVE BODY) is -self quoting. This macro is meant for the sole purpose of quoting -lambda expressions into class defaults. Any `lambda-default' -expression is automatically transformed into a `lambda' expression -when copied from the defaults into a new object. The use of -`oref-default', however, will return a `lambda-default' expression. -CDR is function definition and body." - (message "Warning: Use of `labda-default' will be obsoleted in the next version of EIEIO.") - ;; This definition is copied directly from subr.el for lambda - (list 'function (cons 'lambda-default cdr))) - -(put 'lambda-default 'lisp-indent-function 'defun) -(put 'lambda-default 'byte-compile 'byte-compile-lambda-form) - -(defmacro oref-default (obj slot) - "Gets the default value of OBJ (maybe a class) for SLOT. -The default value is the value installed in a class with the :initform -tag. SLOT can be the slot name, or the tag specified by the :initarg -tag in the `defclass' call." - `(eieio-oref-default ,obj (quote ,slot))) - -(defun eieio-oref-default (obj slot) - "Does the work for the macro `oref-default' with similar parameters. -Fills in OBJ's SLOT with it's default value." - (if (not (or (eieio-object-p obj) (class-p obj))) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj)) - (c (eieio-slot-name-index cl obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. - (if (setq c - (eieio-class-slot-name-index cl slot)) - ;; Oref that slot. - (aref (aref (class-v cl) class-class-allocation-values) - c) - (slot-missing obj slot 'oref-default) - ;;(signal 'invalid-slot-name (list (class-name cl) slot)) - ) - (eieio-barf-if-slot-unbound - (let ((val (nth (- c 3) (aref (class-v cl) class-public-d)))) - (eieio-default-eval-maybe val)) - obj cl 'oref-default)))) - -(defun eieio-default-eval-maybe (val) - "Check VAL, and return what `oref-default' would provide." - ;; check for functions to evaluate - (if (and (listp val) (equal (car val) 'lambda)) - (progn - (message "Warning: Evaluation of `lambda' initform will be obsoleted in the next version of EIEIO.") - (funcall val) - ) - ;; check for quoted things, and unquote them - (if (and (listp val) (eq (car val) 'quote)) - (car (cdr val)) - ;; return it verbatim - (if (and (listp val) (eq (car val) 'lambda-default)) - (let ((s (copy-sequence val))) - (setcar s 'lambda) - s) - val)))) - -;;; Object Set macros -;; -(defmacro oset (obj slot value) - "Set the value in OBJ for slot SLOT to VALUE. -SLOT is the slot name as specified in `defclass' or the tag created -with in the :initarg slot. VALUE can be any Lisp object." - `(eieio-oset ,obj (quote ,slot) ,value)) - -(defun eieio-oset (obj slot value) - "Does the work for the macro `oset'. -Fills in OBJ's SLOT with VALUE." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. - (if (setq c - (eieio-class-slot-name-index (aref obj object-class) slot)) - ;; Oset that slot. - (progn - (eieio-validate-class-slot-value (object-class-fast obj) c value slot) - (aset (aref (class-v (aref obj object-class)) - class-class-allocation-values) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value) - ;;(signal 'invalid-slot-name (list (object-name obj) slot)) - ) - (eieio-validate-slot-value (object-class-fast obj) c value slot) - (aset obj c value)))) - -(defmacro oset-default (class slot value) - "Set the default slot in CLASS for SLOT to VALUE. -The default value is usually set with the :initform tag during class -creation. This allows users to change the default behavior of classes -after they are created." - `(eieio-oset-default ,class (quote ,slot) ,value)) - -(defun eieio-oset-default (class slot value) - "Does the work for the macro `oset-default'. -Fills in the default value in CLASS' in SLOT with VALUE." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let* ((scoped-class class) - (c (eieio-slot-name-index class nil slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) - (progn - ;; Oref that slot. - (eieio-validate-class-slot-value class c value slot) - (aset (aref (class-v class) class-class-allocation-values) c - value)) - (signal 'invalid-slot-name (list (class-name class) slot))) - (eieio-validate-slot-value class c value slot) - ;; Set this into the storage for defaults. - (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d)) - value) - ;; Take the value, and put it into our cache object. - (eieio-oset (aref (class-v class) class-default-object-cache) - slot value) - ))) - -;;; Handy CLOS macros -;; -(defmacro with-slots (spec-list object &rest body) - "Bind SPEC-LIST lexically to slot values in OBJECT, and execute BODY. -This establishes a lexical environment for referring to the slots in -the instance named by the given slot-names as though they were -variables. Within such a context the value of the slot can be -specified by using its slot name, as if it were a lexically bound -variable. Both setf and setq can be used to set the value of the -slot. - -SPEC-LIST is of a form similar to `let'. For example: - - ((VAR1 SLOT1) - SLOT2 - SLOTN - (VARN+1 SLOTN+1)) - -Where each VAR is the local variable given to the associated -SLOT. A Slot specified without a variable name is given a -variable name of the same name as the slot." - ;; Transform the spec-list into a symbol-macrolet spec-list. - (let ((mappings (mapcar (lambda (entry) - (let ((var (if (listp entry) (car entry) entry)) - (slot (if (listp entry) (cadr entry) entry))) - (list var `(slot-value ,object ',slot)))) - spec-list))) - (append (list 'symbol-macrolet mappings) - body))) -(put 'with-slots 'lisp-indent-function 2) - - -;;; Simple generators, and query functions. None of these would do -;; well embedded into an object. -;; -(defmacro object-class-fast (obj) "Return the class struct defining OBJ with no check." - `(aref ,obj object-class)) - -(defun class-name (class) "Return a Lisp like symbol name for CLASS." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, - ;; and I wanted a string. Arg! - (format "#<class %s>" (symbol-name class))) - -(defun object-name (obj &optional extra) - "Return a Lisp like symbol string for object OBJ. -If EXTRA, include that in the string returned to represent the symbol." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (format "#<%s %s%s>" (symbol-name (object-class-fast obj)) - (aref obj object-name) (or extra ""))) - -(defun object-name-string (obj) "Return a string which is OBJ's name." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (aref obj object-name)) - -(defun object-set-name-string (obj name) "Set the string which is OBJ's NAME." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (if (not (stringp name)) (signal 'wrong-type-argument (list 'stringp name))) - (aset obj object-name name)) - -(defun object-class (obj) "Return the class struct defining OBJ." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (object-class-fast obj)) -(defalias 'class-of 'object-class) - -(defun object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (class-name (object-class-fast obj))) - -(defmacro class-parents-fast (class) "Return parent classes to CLASS with no check." - `(aref (class-v ,class) class-parent)) - -(defun class-parents (class) - "Return parent classes to CLASS. (overload of variable). - -The CLOS function `class-direct-superclasses' is aliased to this function." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (class-parents-fast class)) - -(defmacro class-children-fast (class) "Return child classes to CLASS with no check." - `(aref (class-v ,class) class-children)) - -(defun class-children (class) -"Return child classses to CLASS. - -The CLOS function `class-direct-subclasses' is aliased to this function." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (class-children-fast class)) - -;; Official CLOS functions. -(defalias 'class-direct-superclasses 'class-parents) -(defalias 'class-direct-subclasses 'class-children) - -(defmacro class-parent-fast (class) "Return first parent class to CLASS with no check." - `(car (class-parents-fast ,class))) - -(defmacro class-parent (class) "Return first parent class to CLASS. (overload of variable)." - `(car (class-parents ,class))) - -(defmacro same-class-fast-p (obj class) "Return t if OBJ is of class-type CLASS with no error checking." - `(eq (aref ,obj object-class) ,class)) - -(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (same-class-fast-p obj class)) - -(defun object-of-class-p (obj class) - "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - ;; class will be checked one layer down - (child-of-class-p (aref obj object-class) class)) -;; Backwards compatibility -(defalias 'obj-of-class-p 'object-of-class-p) - -(defun child-of-class-p (child class) - "If CHILD class is a subclass of CLASS." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p child))) - (let ((p nil)) - (while (and child (not (eq child class))) - (setq p (append p (aref (class-v child) class-parent)) - child (car p) - p (cdr p))) - (if child t))) - -(defun object-slots (obj) "List of slots available in OBJ." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (aref (class-v (object-class-fast obj)) class-public-a)) - -(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (let ((ia (aref (class-v class) class-initarg-tuples)) - (f nil)) - (while (and ia (not f)) - (if (eq (cdr (car ia)) slot) - (setq f (car (car ia)))) - (setq ia (cdr ia))) - f)) - -;;; CLOS queries into classes and slots -;; -(defun slot-boundp (object slot) - "Non-nil if OBJECT's SLOT is bound. -Setting a slot's value makes it bound. Calling `slot-makeunbound' will -make a slot unbound. -OBJECT can be an instance or a class." - ;; Skip typechecking while retrieving this value. - (let ((eieio-skip-typecheck t)) - ;; Return nil if the magic symbol is in there. - (if (eieio-object-p object) - (if (eq (eieio-oref object slot) eieio-unbound) nil t) - (if (class-p object) - (if (eq (eieio-oref-default object slot) eieio-unbound) nil t) - (signal 'wrong-type-argument (list 'eieio-object-p object)))))) - -(defun slot-makeunbound (object slot) - "In OBJECT, make SLOT unbound." - (eieio-oset object slot eieio-unbound)) - -(defun slot-exists-p (object-or-class slot) - "Non-nil if OBJECT-OR-CLASS has SLOT." - (let ((cv (class-v (cond ((eieio-object-p object-or-class) - (object-class object-or-class)) - ((class-p object-or-class) - object-or-class)) - ))) - (or (memq slot (aref cv class-public-a)) - (memq slot (aref cv class-class-allocation-a))) - )) - -(defun find-class (symbol &optional errorp) - "Return the class that SYMBOL represents. -If there is no class, nil is returned if ERRORP is nil. -If ERRORP is non-nil, `wrong-argument-type' is signaled." - (if (not (class-p symbol)) - (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) - nil) - (class-v symbol))) - -;;; Slightly more complex utility functions for objects -;; -(defun object-assoc (key slot list) - "Return an object if KEY is `equal' to SLOT's value of an object in LIST. -LIST is a list of objects who's slots are searched. -Objects in LIST do not need to have a slot named SLOT, nor does -SLOT need to be bound. If these errors occur, those objects will -be ignored." - (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) - (while (and list (not (condition-case nil - ;; This prevents errors for missing slots. - (equal key (eieio-oref (car list) slot)) - (error nil)))) - (setq list (cdr list))) - (car list)) - -(defun object-assoc-list (slot list) - "Return an association list with the contents of SLOT as the key element. -LIST must be a list of objects with SLOT in it. -This is useful when you need to do completing read on an object group." - (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) - (let ((assoclist nil)) - (while list - (setq assoclist (cons (cons (eieio-oref (car list) slot) - (car list)) - assoclist)) - (setq list (cdr list))) - (nreverse assoclist))) - -(defun object-assoc-list-safe (slot list) - "Return an association list with the contents of SLOT as the key element. -LIST must be a list of objects, but those objects do not need to have -SLOT in it. If it does not, then that element is left out of the association -list." - (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) - (let ((assoclist nil)) - (while list - (if (slot-exists-p (car list) slot) - (setq assoclist (cons (cons (eieio-oref (car list) slot) - (car list)) - assoclist))) - (setq list (cdr list))) - (nreverse assoclist))) - -(defun object-add-to-list (object slot item &optional append) - "In OBJECT's SLOT, add ITEM to the list of elements. -Optional argument APPEND indicates we need to append to the list. -If ITEM already exists in the list in SLOT, then it is not added. -Comparison is done with `equal' through the `member' function call. -If SLOT is unbound, bind it to the list containing ITEM." - (let (ov) - ;; Find the originating list. - (if (not (slot-boundp object slot)) - (setq ov (list item)) - (setq ov (eieio-oref object slot)) - ;; turn it into a list. - (unless (listp ov) - (setq ov (list ov))) - ;; Do the combination - (if (not (member item ov)) - (setq ov - (if append - (append ov (list item)) - (cons item ov))))) - ;; Set back into the slot. - (eieio-oset object slot ov))) - -(defun object-remove-from-list (object slot item) - "In OBJECT's SLOT, remove occurrences of ITEM. -Deletion is done with `delete', which deletes by side effect -and comparisons are done with `equal'. -If SLOT is unbound, do nothing." - (if (not (slot-boundp object slot)) - nil - (eieio-oset object slot (delete item (eieio-oref object slot))))) - -;;; EIEIO internal search functions -;; -(defun eieio-slot-originating-class-p (start-class slot) - "Return Non-nil if START-CLASS is the first class to define SLOT. -This is for testing if `scoped-class' is the class that defines SLOT -so that we can protect private slots." - (let ((par (class-parents start-class)) - (ret t)) - (if (not par) - t - (while (and par ret) - (if (intern-soft (symbol-name slot) - (aref (class-v (car par)) - class-symbol-obarray)) - (setq ret nil)) - (setq par (cdr par))) - ret))) - -(defun eieio-slot-name-index (class obj slot) - "In CLASS for OBJ find the index of the named SLOT. -The slot is a symbol which is installed in CLASS by the `defclass' -call. OBJ can be nil, but if it is an object, and the slot in question -is protected, access will be allowed if obj is a child of the currently -`scoped-class'. -If SLOT is the value created with :initarg instead, -reverse-lookup that name, and recurse with the associated slot value." - ;; Removed checks to outside this call - (let* ((fsym (intern-soft (symbol-name slot) - (aref (class-v class) - class-symbol-obarray))) - (fsi (if (symbolp fsym) (symbol-value fsym) nil))) - (if (integerp fsi) - (cond - ((not (get fsym 'protection)) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'protected) - scoped-class - (or (child-of-class-p class scoped-class) - (and (eieio-object-p obj) - (child-of-class-p class (object-class obj))))) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'private) - (or (and scoped-class - (eieio-slot-originating-class-p scoped-class slot)) - eieio-initializing-object)) - (+ 3 fsi)) - (t nil)) - (let ((fn (eieio-initarg-to-attribute class slot))) - (if fn (eieio-slot-name-index class obj fn) nil))))) - -(defun eieio-class-slot-name-index (class slot) - "In CLASS find the index of the named SLOT. -The slot is a symbol which is installed in CLASS by the `defclass' -call. If SLOT is the value created with :initarg instead, -reverse-lookup that name, and recurse with the associated slot value." - ;; This will happen less often, and with fewer slots. Do this the - ;; storage cheap way. - (let* ((a (aref (class-v class) class-class-allocation-a)) - (l1 (length a)) - (af (memq slot a)) - (l2 (length af))) - ;; Slot # is length of the total list, minus the remaining list of - ;; the found slot. - (if af (- l1 l2)))) - -;;; CLOS generics internal function handling -;; -(defvar eieio-generic-call-methodname nil - "When using `call-next-method', provides a context on how to do it.") -(defvar eieio-generic-call-arglst nil - "When using `call-next-method', provides a context for parameters.") -(defvar eieio-generic-call-key nil - "When using `call-next-method', provides a context for the current key. -Keys are a number representing :before, :primary, and :after methods.") -(defvar eieio-generic-call-next-method-list nil - "When executing a PRIMARY or STATIC method, track the 'next-method'. -During executions, the list is first generated, then as each next method -is called, the next method is popped off the stack.") - -(defvar eieio-pre-method-execution-hooks nil - "*Hooks run just before a method is executed. -The hook function must accept on argument, this list of forms -about to be executed.") - -(defun eieio-generic-call (method args) - "Call METHOD with ARGS. -ARGS provides the context on which implementation to use. -This should only be called from a generic function." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil)) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - ;; Is the class passed in autoloaded? - ;; Since class names are also constructors, they can be autoloaded - ;; via the autoload command. Check for this, and load them in. - ;; It's ok if it doesn't turn out to be a class. Probably want that - ;; function loaded anyway. - (if (and (symbolp firstarg) - (fboundp firstarg) - (listp (symbol-function firstarg)) - (eq 'autoload (car (symbol-function firstarg)))) - (load (nth 1 (symbol-function firstarg)))) - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (object-class-fast firstarg))) - ((class-p firstarg) - (setq mclass firstarg)) - ) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (and (not (null mclass)) (not (class-p mclass))) - (error "Cannot dispatch method %S on class %S" - method mclass) - ) - ;; Now create a list in reverse order of all the calls we have - ;; make in order to successfully do this right. Rules: - ;; 1) Only call generics if scoped-class is not defined - ;; This prevents multiple calls in the case of recursion - ;; 2) Only call static if this is a static method. - ;; 3) Only call specifics if the definition allows for them. - ;; 4) Call in order based on :before, :primary, and :after - (when (eieio-object-p firstarg) - ;; Non-static calls do all this stuff. - - ;; :after methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-after mclass) - (list (eieio-generic-form method method-after nil))) - ;;(or (and mclass (eieio-generic-form method method-after mclass)) - ;; (eieio-generic-form method method-after nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-after) keys)) - - ;; :primary methods - (setq tlambdas - (or (and mclass (eieio-generic-form method method-primary mclass)) - (eieio-generic-form method method-primary nil))) - (when tlambdas - (setq lambdas (cons tlambdas lambdas) - keys (cons method-primary keys) - primarymethodlist - (eieiomt-method-list method method-primary mclass))) - - ;; :before methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-before mclass) - (list (eieio-generic-form method method-before nil))) - ;;(or (and mclass (eieio-generic-form method method-before mclass)) - ;; (eieio-generic-form method method-before nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-before) keys)) - ) - - ;; If there were no methods found, then there could be :static methods. - (when (not lambdas) - (setq tlambdas - (eieio-generic-form method method-static mclass)) - (setq lambdas (cons tlambdas lambdas) - keys (cons method-static keys) - primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-static mclass))) - - (run-hook-with-args 'eieio-pre-method-execution-hooks - primarymethodlist) - - ;; Now loop through all occurances forms which we must execute - ;; (which are happily sorted now) and execute them all! - (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) - (while lambdas - (if (car lambdas) - (let* ((scoped-class (cdr (car lambdas))) - (eieio-generic-call-key (car keys)) - (has-return-val - (or (= eieio-generic-call-key method-primary) - (= eieio-generic-call-key method-static))) - (eieio-generic-call-next-method-list - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (when has-return-val (cdr primarymethodlist))) - ) - (setq found t) - ;;(setq rval (apply (car (car lambdas)) newargs)) - (setq lastval (apply (car (car lambdas)) newargs)) - (when has-return-val - (setq rval lastval - rvalever t)) - )) - (setq lambdas (cdr lambdas) - keys (cdr keys))) - (if (not found) - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args)))) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval))) - -(defun eieio-generic-call-primary-only (method args) - "Call METHOD with ARGS for methods with only :PRIMARY implementations. -ARGS provides the context on which implementation to use. -This should only be called from a generic function. - -This method is like `eieio-generic-call', but only -implementations in the :PRIMARY slot are queried. After many -years of use, it appears that over 90% of methods in use -have :PRIMARY implementations only. We can therefore optimize -for this common case to improve performance." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil) - ) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (object-class-fast firstarg))) - ((not firstarg) - (error "Method %s called on nil" method)) - ((not (eieio-object-p firstarg)) - (error "Primary-only method %s called on something not an object" method)) - (t - (error "EIEIO Error: Improperly classified method %s as primary only" - method) - )) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (null mclass) - (error "Cannot dispatch method %S on class %S" method mclass) - ) - - ;; :primary methods - (setq lambdas (eieio-generic-form method method-primary mclass)) - (setq primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-primary mclass)) - - ;; Now loop through all occurances forms which we must execute - ;; (which are happily sorted now) and execute them all! - (let* ((rval nil) (lastval nil) (rvalever nil) - (scoped-class (cdr lambdas)) - (eieio-generic-call-key method-primary) - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (eieio-generic-call-next-method-list (cdr primarymethodlist)) - ) - - (if (or (not lambdas) (not (car lambdas))) - - ;; No methods found for this impl... - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args))) - - ;; Do the regular implementation here. - - (run-hook-with-args 'eieio-pre-method-execution-hooks - lambdas) - - (setq lastval (apply (car lambdas) newargs)) - (setq rval lastval - rvalever t) - ) - - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval))) - -(defun eieiomt-method-list (method key class) - "Return an alist list of methods lambdas. -METHOD is the method name. -KEY represents either :before, or :after methods. -CLASS is the starting class to search from in the method tree. -If CLASS is nil, then an empty list of methods should be returned." - ;; Note: eieiomt - the MT means MethodTree. See more comments below - ;; for the rest of the eieiomt methods. - (let ((lambdas nil) - (mclass (list class))) - (while mclass - ;; Note: a nil can show up in the class list once we start - ;; searching through the method tree. - (when (car mclass) - ;; lookup the form to use for the PRIMARY object for the next level - (let ((tmpl (eieio-generic-form method key (car mclass)))) - (when (or (not lambdas) - ;; This prevents duplicates coming out of the - ;; class method optimizer. Perhaps we should - ;; just not optimize before/afters? - (not (eq (car tmpl) (car (car lambdas))))) - (setq lambdas (cons tmpl lambdas)) - (if (null (car lambdas)) - (setq lambdas (cdr lambdas)))))) - ;; Add new classes to mclass. Since our input might not be a class - ;; protect against that. - (if (car mclass) - ;; If there is a class, append any methods it may provide - ;; to the remainder of the class list. - (let ((io (class-method-invocation-order (car mclass)))) - (if (eq io :depth-first) - ;; Depth first. - (setq mclass (append (eieiomt-next (car mclass)) (cdr mclass))) - ;; Breadth first. - (setq mclass (append (cdr mclass) (eieiomt-next (car mclass))))) - ) - ;; Advance to next entry in mclass if it is nil. - (setq mclass (cdr mclass))) - ) - (if (eq key method-after) - lambdas - (nreverse lambdas)))) - -(defun next-method-p () - "Non-nil if there is a next method. -Returns a list of lambda expressions which is the `next-method' -order." - eieio-generic-call-next-method-list) - -(defun call-next-method (&rest replacement-args) - "Call the superclass method from a subclass method. -The superclass method is specified in the current method list, -and is called the next method. - -If REPLACEMENT-ARGS is non-nil, then use them instead of -`eieio-generic-call-arglst'. The generic arg list are the -arguments passed in at the top level. - -Use `next-method-p' to find out if there is a next method to call." - (if (not scoped-class) - (error "Call-next-method not called within a class specific method")) - (if (and (/= eieio-generic-call-key method-primary) - (/= eieio-generic-call-key method-static)) - (error "Cannot `call-next-method' except in :primary or :static methods") - ) - (let ((newargs (or replacement-args eieio-generic-call-arglst)) - (next (car eieio-generic-call-next-method-list)) - ) - (if (or (not next) (not (car next))) - (apply 'no-next-method (car newargs) (cdr newargs)) - (let* ((eieio-generic-call-next-method-list - (cdr eieio-generic-call-next-method-list)) - (scoped-class (cdr next)) - (fcn (car next)) - ) - (apply fcn newargs) - )))) - -;;; -;; eieio-method-tree : eieiomt- -;; -;; Stored as eieio-method-tree in property list of a generic method -;; -;; (eieio-method-tree . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; and -;; (eieio-method-obarray . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; where the association is a vector. -;; (aref 0 -- all static methods. -;; (aref 1 -- all methods classified as :before -;; (aref 2 -- all methods classified as :primary -;; (aref 3 -- all methods classified as :after -;; (aref 4 -- a generic classified as :before -;; (aref 5 -- a generic classified as :primary -;; (aref 6 -- a generic classified as :after -;; -(defvar eieiomt-optimizing-obarray nil - "While mapping atoms, this contain the obarray being optimized.") - -(defun eieiomt-install (method-name) - "Install the method tree, and obarray onto METHOD-NAME. -Do not do the work if they already exist." - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - (if (or (not emtv) (not emto)) - (progn - (setq emtv (put method-name 'eieio-method-tree - (make-vector method-num-slots nil)) - emto (put method-name 'eieio-method-obarray - (make-vector method-num-slots nil))) - (aset emto 0 (make-vector 11 0)) - (aset emto 1 (make-vector 11 0)) - (aset emto 2 (make-vector 41 0)) - (aset emto 3 (make-vector 11 0)) - )))) - -(defun eieiomt-add (method-name method key class) - "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. -METHOD-NAME is the name created by a call to `defgeneric'. -METHOD are the forms for a given implementation. -KEY is an integer (see comment in eieio.el near this function) which -is associated with the :static :before :primary and :after tags. -It also indicates if CLASS is defined or not. -CLASS is the class this method is associated with." - (if (or (> key method-num-slots) (< key 0)) - (error "Eieiomt-add: method key error!")) - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - ;; Make sure the method tables are available. - (if (or (not emtv) (not emto)) - (error "Programmer error: eieiomt-add")) - ;; only add new cells on if it doesn't already exist! - (if (assq class (aref emtv key)) - (setcdr (assq class (aref emtv key)) method) - (aset emtv key (cons (cons class method) (aref emtv key)))) - ;; Add function definition into newly created symbol, and store - ;; said symbol in the correct obarray, otherwise use the - ;; other array to keep this stuff - (if (< key method-num-lists) - (let ((nsym (intern (symbol-name class) (aref emto key)))) - (fset nsym method))) - ;; Now optimize the entire obarray - (if (< key method-num-lists) - (let ((eieiomt-optimizing-obarray (aref emto key))) - ;; @todo - Is this overkill? Should we just clear the symbol? - (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) - )) - -(defun eieiomt-next (class) - "Return the next parent class for CLASS. -If CLASS is a superclass, return variable `eieio-default-superclass'. If CLASS -is variable `eieio-default-superclass' then return nil. This is different from -function `class-parent' as class parent returns nil for superclasses. This -function performs no type checking!" - ;; No type-checking because all calls are made from functions which - ;; are safe and do checking for us. - (or (class-parents-fast class) - (if (eq class 'eieio-default-superclass) - nil - '(eieio-default-superclass)))) - -(defun eieiomt-sym-optimize (s) - "Find the next class above S which has a function body for the optimizer." - ;; (message "Optimizing %S" s) - (let* ((es (intern-soft (symbol-name s))) ;external symbol of class - (io (class-method-invocation-order es)) - (ov nil) - (cont t)) - ;; This converts ES from a single symbol to a list of parent classes. - (setq es (eieiomt-next es)) - ;; Loop over ES, then it's children individually. - ;; We can have multiple hits only at one level of the parent tree. - (while (and es cont) - (setq ov (intern-soft (symbol-name (car es)) eieiomt-optimizing-obarray)) - (if (fboundp ov) - (progn - (set s ov) ;store ov as our next symbol - (setq cont nil)) - (if (eq io :depth-first) - ;; Pre-pend the subclasses of (car es) so we get - ;; DEPTH FIRST optimization. - (setq es (append (eieiomt-next (car es)) (cdr es))) - ;; Else, we are breadth first. - ;; (message "Class %s is breadth first" es) - (setq es (append (cdr es) (eieiomt-next (car es)))) - ))) - ;; If there is no nearest call, then set our value to nil - (if (not es) (set s nil)) - )) - -(defun eieio-generic-form (method key class) - "Return the lambda form belonging to METHOD using KEY based upon CLASS. -If CLASS is not a class then use `generic' instead. If class has no -form, but has a parent class, then trace to that parent class. The -first time a form is requested from a symbol, an optimized path is -memoized for future faster use." - (let ((emto (aref (get method 'eieio-method-obarray) - (if class key (+ key 3))))) - (if (class-p class) - ;; 1) find our symbol - (let ((cs (intern-soft (symbol-name class) emto))) - (if (not cs) - ;; 2) If there isn't one, then make one. - ;; This can be slow since it only occurs once - (progn - (setq cs (intern (symbol-name class) emto)) - ;; 2.1) Cache it's nearest neighbor with a quick optimize - ;; which should only occur once for this call ever - (let ((eieiomt-optimizing-obarray emto)) - (eieiomt-sym-optimize cs)))) - ;; 3) If it's bound return this one. - (if (fboundp cs) - (cons cs (aref (class-v class) class-symbol)) - ;; 4) If it's not bound then this variable knows something - (if (symbol-value cs) - (progn - ;; 4.1) This symbol holds the next class in it's value - (setq class (symbol-value cs) - cs (intern-soft (symbol-name class) emto)) - ;; 4.2) The optimizer should always have chosen a - ;; function-symbol - ;;(if (fboundp cs) - (cons cs (aref (class-v (intern (symbol-name class))) - class-symbol)) - ;;(error "EIEIO optimizer: erratic data loss!")) - ) - ;; There never will be a funcall... - nil))) - ;; for a generic call, what is a list, is the function body we want. - (let ((emtl (aref (get method 'eieio-method-tree) - (if class key (+ key 3))))) - (if emtl - ;; The car of EMTL is supposed to be a class, which in this - ;; case is nil, so skip it. - (cons (cdr (car emtl)) nil) - nil))))) - -;;; -;; Way to assign slots based on a list. Used for constructors, or -;; even resetting an object at run-time -;; -(defun eieio-set-defaults (obj &optional set-all) - "Take object OBJ, and reset all slots to their defaults. -If SET-ALL is non-nil, then when a default is nil, that value is -reset. If SET-ALL is nil, the slots are only reset if the default is -not nil." - (let ((scoped-class (aref obj object-class)) - (eieio-initializing-object t) - (pub (aref (class-v (aref obj object-class)) class-public-a))) - (while pub - (let ((df (eieio-oref-default obj (car pub)))) - (if (and (listp df) (eq (car df) 'lambda-default)) - (progn - (setq df (copy-sequence df)) - (setcar df 'lambda))) - (if (or df set-all) - (eieio-oset obj (car pub) df))) - (setq pub (cdr pub))))) - -(defun eieio-initarg-to-attribute (class initarg) - "For CLASS, convert INITARG to the actual attribute name. -If there is no translation, pass it in directly (so we can cheat if -need be.. May remove that later...)" - (let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples)))) - (if tuple - (cdr tuple) - nil))) - -(defun eieio-attribute-to-initarg (class attribute) - "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. -This is usually a symbol that starts with `:'." - (let ((tuple (rassoc attribute (aref (class-v class) class-initarg-tuples)))) - (if tuple - (car tuple) - nil))) - - -;;; Here are some special types of errors -;; -(intern "no-method-definition") -(put 'no-method-definition 'error-conditions '(no-method-definition error)) -(put 'no-method-definition 'error-message "No method definition") - -(intern "no-next-method") -(put 'no-next-method 'error-conditions '(no-next-method error)) -(put 'no-next-method 'error-message "No next method") - -(intern "invalid-slot-name") -(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) -(put 'invalid-slot-name 'error-message "Invalid slot name") - -(intern "invalid-slot-type") -(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) -(put 'invalid-slot-type 'error-message "Invalid slot type") - -(intern "unbound-slot") -(put 'unbound-slot 'error-conditions '(unbound-slot error nil)) -(put 'unbound-slot 'error-message "Unbound slot") - -;;; Here are some CLOS items that need the CL package -;; - -(defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store)) -(defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store)) - -;; The below setf method was written by Arnd Kohrs <kohrs@acm.org> -(define-setf-method oref (obj slot) - (let ((obj-temp (gensym)) - (slot-temp (gensym)) - (store-temp (gensym))) - (list (list obj-temp slot-temp) - (list obj `(quote ,slot)) - (list store-temp) - (list 'set-slot-value obj-temp slot-temp - store-temp) - (list 'slot-value obj-temp slot-temp)))) - - -;;; -;; We want all objects created by EIEIO to have some default set of -;; behaviours so we can create object utilities, and allow various -;; types of error checking. To do this, create the default EIEIO -;; class, and when no parent class is specified, use this as the -;; default. (But don't store it in the other classes as the default, -;; allowing for transparent support.) -;; - -(defclass eieio-default-superclass nil - nil - "Default parent class for classes with no specified parent class. -Its slots are automatically adopted by classes with no specified -parents. This class is not stored in the `parent' slot of a class vector." - :abstract t) - -(defalias 'standard-class 'eieio-default-superclass) - -(defgeneric constructor (class newname &rest slots) - "Default constructor for CLASS `eieio-defualt-superclass'.") - -(defmethod constructor :static - ((class eieio-default-superclass) newname &rest slots) - "Default constructor for CLASS `eieio-defualt-superclass'. -NEWNAME is the name to be given to the constructed object. -SLOTS are the initialization slots used by `shared-initialize'. -This static method is called when an object is constructed. -It allocates the vector used to represent an EIEIO object, and then -calls `shared-initialize' on that object." - (let* ((new-object (copy-sequence (aref (class-v class) - class-default-object-cache)))) - ;; Update the name for the newly created object. - (aset new-object object-name newname) - ;; Call the initialize method on the new object with the slots - ;; that were passed down to us. - (initialize-instance new-object slots) - ;; Return the created object. - new-object)) - -(defgeneric shared-initialize (obj slots) - "Set slots of OBJ with SLOTS which is a list of name/value pairs. -Called from the constructor routine.") - -(defmethod shared-initialize ((obj eieio-default-superclass) slots) - "Set slots of OBJ with SLOTS which is a list of name/value pairs. -Called from the constructor routine." - (let ((scoped-class (aref obj object-class))) - (while slots - (let ((rn (eieio-initarg-to-attribute (object-class-fast obj) - (car slots)))) - (if (not rn) - (slot-missing obj (car slots) 'oset (car (cdr slots))) - (eieio-oset obj rn (car (cdr slots))))) - (setq slots (cdr (cdr slots)))))) - -(defgeneric initialize-instance (this &optional slots) - "Constructs the new object THIS based on SLOTS.") - -(defmethod initialize-instance ((this eieio-default-superclass) - &optional slots) - "Constructs the new object THIS based on SLOTS. -SLOTS is a tagged list where odd numbered elements are tags, and -even numbered elements are the values to store in the tagged slot. If -you overload the `initialize-instance', there you will need to call -`shared-initialize' yourself, or you can call `call-next-method' to -have this constructor called automatically. If these steps are not -taken, then new objects of your class will not have their values -dynamically set from SLOTS." - ;; First, see if any of our defaults are `lambda', and - ;; re-evaluate them and apply the value to our slots. - (let* ((scoped-class (class-v (aref this object-class))) - (slot (aref scoped-class class-public-a)) - (defaults (aref scoped-class class-public-d))) - (while slot - (if (and (listp (car defaults)) - (eq 'lambda (car (car defaults)))) - (progn - (message "Warning: Evaluation of `lambda' initform will be obsoleted in the next version of EIEIO.") - (eieio-oset this (car slot) (funcall (car defaults))))) - (setq slot (cdr slot) - defaults (cdr defaults)))) - ;; Shared initialize will parse our slots for us. - (shared-initialize this slots)) - -(defgeneric slot-missing (object slot-name operation &optional new-value) - "Method invoked when an attempt to access a slot in OBJECT fails.") - -(defmethod slot-missing ((object eieio-default-superclass) slot-name - operation &optional new-value) - "Method invoked when an attempt to access a slot in OBJECT fails. -SLOT-NAME is the name of the failed slot, OPERATION is the type of access -that was requested, and optional NEW-VALUE is the value that was desired -to be set. - -This method is called from `oref', `oset', and other functions which -directly reference slots in EIEIO objects." - (signal 'invalid-slot-name (list (object-name object) - slot-name))) - -(defgeneric slot-unbound (object class slot-name fn) - "Slot unbound is invoked during an attempt to reference an unbound slot.") - -(defmethod slot-unbound ((object eieio-default-superclass) - class slot-name fn) - "Slot unbound is invoked during an attempt to reference an unbound slot. -OBJECT is the instance of the object being reference. CLASS is the -class of OBJECT, and SLOT-NAME is the offending slot. This function -throws the signal `unbound-slot'. You can overload this function and -return the value to use in place of the unbound value. -Argument FN is the function signaling this error. -Use `slot-boundp' to determine if a slot is bound or not. - -In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but -EIEIO can only dispatch on the first argument, so the first two are swapped." - (signal 'unbound-slot (list (class-name class) (object-name object) - slot-name fn))) - -(defgeneric no-applicable-method (object method &rest args) - "Called if there are no implementations for OBJECT in METHOD.") - -(defmethod no-applicable-method ((object eieio-default-superclass) - method &rest args) - "Called if there are no implementations for OBJECT in METHOD. -OBJECT is the object which has no method implementation. -ARGS are the arguments that were passed to METHOD. - -Implement this for a class to block this signal. The return -value becomes the return value of the original method call." - (signal 'no-method-definition (list method (object-name object))) - ) - -(defgeneric no-next-method (object &rest args) -"Called from `call-next-method' when no additional methods are available.") - -(defmethod no-next-method ((object eieio-default-superclass) - &rest args) - "Called from `call-next-method' when no additional methods are available. -OBJECT is othe object being called on `call-next-method'. -ARGS are the arguments it is called by. -This method signals `no-next-method' by default. Override this -method to not throw an error, and it's return value becomes the -return value of `call-next-method'." - (signal 'no-next-method (list (object-name object) args)) -) - -(defgeneric clone (obj &rest params) - "Make a copy of OBJ, and then supply PARAMS. -PARAMS is a parameter list of the same form used by `initialize-instance'. - -When overloading `clone', be sure to call `call-next-method' -first and modify the returned object.") - -(defmethod clone ((obj eieio-default-superclass) &rest params) - "Make a copy of OBJ, and then apply PARAMS." - (let ((nobj (copy-sequence obj)) - (nm (aref obj object-name)) - (passname (and params (stringp (car params)))) - (num 1)) - (if params (shared-initialize nobj (if passname (cdr params) params))) - (if (not passname) - (save-match-data - (if (string-match "-\\([0-9]+\\)" nm) - (setq num (1+ (string-to-number (match-string 1 nm))) - nm (substring nm 0 (match-beginning 0)))) - (aset nobj object-name (concat nm "-" (int-to-string num)))) - (aset nobj object-name (car params))) - nobj)) - -(defgeneric destructor (this &rest params) - "Destructor for cleaning up any dynamic links to our object.") - -(defmethod destructor ((this eieio-default-superclass) &rest params) - "Destructor for cleaning up any dynamic links to our object. -Argument THIS is the object being destroyed. PARAMS are additional -ignored parameters." - ;; No cleanup... yet. - ) - -(defgeneric object-print (this &rest strings) - "Pretty printer for object THIS. Call function `object-name' with STRINGS. - -It is sometimes useful to put a summary of the object into the -default #<notation> string when using eieio browsing tools. -Implement this method to customize the summary.") - -(defmethod object-print ((this eieio-default-superclass) &rest strings) - "Pretty printer for object THIS. Call function `object-name' with STRINGS. -The default method for printing object THIS is to use the -function `object-name'. - -It is sometimes useful to put a summary of the object into the -default #<notation> string when using eieio browsing tools. - -Implement this function and specify STRINGS in a call to -`call-next-method' to provide additional summary information. -When passing in extra strings from child classes, always remember -to prepend a space." - (object-name this (apply 'concat strings))) - -(defvar eieio-print-depth 0 - "When printing, keep track of the current indentation depth.") - -(defgeneric object-write (this &optional comment) - "Write out object THIS to the current stream. -Optional COMMENDS will add comments to the beginning of the output.") - -(defmethod object-write ((this eieio-default-superclass) &optional comment) - "Write object THIS out to the current stream. -This writes out the vector version of this object. Complex and recursive -object are discouraged from being written. - If optional COMMENT is non-nil, include comments when outputting -this object." - (when comment - (princ ";; Object ") - (princ (object-name-string this)) - (princ "\n") - (princ comment) - (princ "\n")) - (let* ((cl (object-class this)) - (cv (class-v cl))) - ;; Now output readable lisp to recreate this object - ;; It should look like this: - ;; (<constructor> <name> <slot> <slot> ... ) - ;; Each slot's slot is writen using its :writer. - (princ (make-string (* eieio-print-depth 2) ? )) - (princ "(") - (princ (symbol-name (class-constructor (object-class this)))) - (princ " \"") - (princ (object-name-string this)) - (princ "\"\n") - ;; Loop over all the public slots - (let ((publa (aref cv class-public-a)) - (publd (aref cv class-public-d)) - (publp (aref cv class-public-printer)) - (eieio-print-depth (1+ eieio-print-depth))) - (while publa - (when (slot-boundp this (car publa)) - (let ((i (class-slot-initarg cl (car publa))) - (v (eieio-oref this (car publa))) - ) - (unless (or (not i) (equal v (car publd))) - (princ (make-string (* eieio-print-depth 2) ? )) - (princ (symbol-name i)) - (princ " ") - (if (car publp) - ;; Use our public printer - (funcall (car publp) v) - ;; Use our generic override prin1 function. - (eieio-override-prin1 v)) - (princ "\n")))) - (setq publa (cdr publa) publd (cdr publd) - publp (cdr publp))) - (princ (make-string (* eieio-print-depth 2) ? ))) - (princ ")\n"))) - -(defun eieio-override-prin1 (thing) - "Perform a prin1 on THING taking advantage of object knowledge." - (cond ((eieio-object-p thing) - (object-write thing)) - ((listp thing) - (eieio-list-prin1 thing)) - ((class-p thing) - (princ (class-name thing))) - ((symbolp thing) - (princ (concat "'" (symbol-name thing)))) - (t (prin1 thing)))) - -(defun eieio-list-prin1 (list) - "Display LIST where list may contain objects." - (if (not (eieio-object-p (car list))) - (progn - (princ "'") - (prin1 list)) - (princ "(list ") - (if (eieio-object-p (car list)) (princ "\n ")) - (while list - (if (eieio-object-p (car list)) - (object-write (car list)) - (princ "'") - (prin1 (car list))) - (princ " ") - (setq list (cdr list))) - (princ (make-string (* eieio-print-depth 2) ? )) - (princ ")"))) - - -;;; Unimplemented functions from CLOS -;; -(defun change-class (obj class) - "Change the class of OBJ to type CLASS. -This may create or delete slots, but does not affect the return value -of `eq'." - (error "Eieio: `change-class' is unimplemented")) - -) - - -;;; Interfacing with edebug -;; -(defun eieio-edebug-prin1-to-string (object &optional noescape) - "Display eieio OBJECT in fancy format. Overrides the edebug default. -Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." - (cond ((class-p object) (class-name object)) - ((eieio-object-p object) (object-print object)) - ((and (listp object) (or (class-p (car object)) - (eieio-object-p (car object)))) - (concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")")) - (t (prin1-to-string object noescape)))) - -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec defmethod - (&define ; this means we are defining something - [&or name ("setf" :name setf name)] - ;; ^^ This is the methods symbol - [ &optional symbolp ] ; this is key :before etc - list ; arguments - [ &optional stringp ] ; documentation string - def-body ; part to be debugged - )) - ;; The rest of the macros - (def-edebug-spec oref (form quote)) - (def-edebug-spec oref-default (form quote)) - (def-edebug-spec oset (form quote form)) - (def-edebug-spec oset-default (form quote form)) - (def-edebug-spec class-v form) - (def-edebug-spec class-p form) - (def-edebug-spec eieio-object-p form) - (def-edebug-spec class-constructor form) - (def-edebug-spec generic-p form) - (def-edebug-spec with-slots (list list def-body)) - ;; I suspect this isn't the best way to do this, but when - ;; cust-print was used on my system all my objects - ;; appeared as "#1 =" which was not useful. This allows - ;; edebug to print my objects in the nice way they were - ;; meant to with `object-print' and `class-name' - ;; (defalias 'edebug-prin1-to-string 'eieio-edebug-prin1-to-string) - ) - ) - -(eval-after-load "cedet-edebug" - '(progn - (cedet-edebug-add-print-override '(class-p object) '(class-name object) ) - (cedet-edebug-add-print-override '(eieio-object-p object) '(object-print object) ) - (cedet-edebug-add-print-override '(and (listp object) - (or (class-p (car object)) (eieio-object-p (car object)))) - '(cedet-edebug-prin1-recurse object) ) - )) - -;;; Interfacing with imenu in emacs lisp mode -;; (Only if the expression is defined) -;; -(if (eval-when-compile (boundp 'list-imenu-generic-expression)) -(progn - -(defun eieio-update-lisp-imenu-expression () - "Examine `lisp-imenu-generic-expression' and modify it to find `defmethod'." - (let ((exp lisp-imenu-generic-expression)) - (while exp - ;; it's of the form '( ( title expr indx ) ... ) - (let* ((subcar (cdr (car exp))) - (substr (car subcar))) - (if (and (not (string-match "|method\\\\" substr)) - (string-match "|advice\\\\" substr)) - (setcar subcar - (replace-match "|advice\\|method\\" t t substr 0)))) - (setq exp (cdr exp))))) - -(eieio-update-lisp-imenu-expression) - -)) - -;;; Autoloading some external symbols, and hooking into the help system -;; - -(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "For buffers thrown into help mode, augment for eieio.") -(autoload 'eieio-browse "eieio-opt" "Create an object browser window" t) -(autoload 'eieio-describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t) -(autoload 'eieio-describe-constructor "eieio-opt" "Describe the constructor function FCN." t) -(autoload 'describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t) -(autoload 'eieio-describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t) -(autoload 'describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t) -(autoload 'eieiodoc-class "eieio-doc" "Create texinfo documentation about a class hierarchy." t) - -(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.") - -;; make sure this shows up after the help mode hook. -(add-hook 'temp-buffer-show-hook 'eieio-help-mode-augmentation-maybee t) -;; (require 'advice) -;; (defadvice describe-variable (around eieio-describe activate) -;; "Display the full documentation of FUNCTION (a symbol). -;; Returns the documentation as a string, also." -;; (if (class-p (ad-get-arg 0)) -;; (eieio-describe-class (ad-get-arg 0)) -;; ad-do-it)) - -;; (defadvice describe-function (around eieio-describe activate) -;; "Display the full documentation of VARIABLE (a symbol). -;; Returns the documentation as a string, also." -;; (if (generic-p (ad-get-arg 0)) -;; (eieio-describe-generic (ad-get-arg 0)) -;; (if (class-p (ad-get-arg 0)) -;; (eieio-describe-constructor (ad-get-arg 0)) -;; ad-do-it))) - -(provide 'eieio) -;;; eieio ends here