Shrink EIEIO object header. Move generics to eieio-generic.el.
This commit is contained in:
Stefan Monnier
commit
a749f1c648
41 changed files with 2384 additions and 1987 deletions
|
|
@ -422,7 +422,7 @@ or is created with the bounds of SEQ."
|
|||
(if (stringp (car (oref seq data)))
|
||||
(let ((labels (oref seq data)))
|
||||
(if (not axis)
|
||||
(setq axis (make-instance chart-axis-names
|
||||
(setq axis (make-instance 'chart-axis-names
|
||||
:name (oref seq name)
|
||||
:items labels
|
||||
:chart c))
|
||||
|
|
@ -430,7 +430,7 @@ or is created with the bounds of SEQ."
|
|||
(let ((range (cons 0 1))
|
||||
(l (oref seq data)))
|
||||
(if (not axis)
|
||||
(setq axis (make-instance chart-axis-range
|
||||
(setq axis (make-instance 'chart-axis-range
|
||||
:name (oref seq name)
|
||||
:chart c)))
|
||||
(while l
|
||||
|
|
@ -577,19 +577,19 @@ labeled NUMTITLE.
|
|||
Optional arguments:
|
||||
Set the chart's max element display to MAX, and sort lists with
|
||||
SORT-PRED if desired."
|
||||
(let ((nc (make-instance chart-bar
|
||||
(let ((nc (make-instance 'chart-bar
|
||||
:title title
|
||||
:key-label "8-m" ; This is a text key pic
|
||||
:direction dir
|
||||
))
|
||||
(iv (eq dir 'vertical)))
|
||||
(chart-add-sequence nc
|
||||
(make-instance chart-sequece
|
||||
(make-instance 'chart-sequece
|
||||
:data namelst
|
||||
:name nametitle)
|
||||
(if iv 'x-axis 'y-axis))
|
||||
(chart-add-sequence nc
|
||||
(make-instance chart-sequece
|
||||
(make-instance 'chart-sequece
|
||||
:data numlst
|
||||
:name numtitle)
|
||||
(if iv 'y-axis 'x-axis))
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@
|
|||
;; error if a slot is unbound.
|
||||
(defclass eieio-instance-inheritor ()
|
||||
((parent-instance :initarg :parent-instance
|
||||
:type eieio-instance-inheritor-child
|
||||
:type eieio-instance-inheritor
|
||||
:documentation
|
||||
"The parent of this instance.
|
||||
If a slot of this class is referenced, and is unbound, then the parent
|
||||
|
|
@ -63,25 +63,10 @@ SLOT-NAME is the offending slot. FN is the function signaling the error."
|
|||
;; Throw the regular signal.
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod clone ((obj eieio-instance-inheritor) &rest params)
|
||||
(defmethod clone ((obj eieio-instance-inheritor) &rest _params)
|
||||
"Clone OBJ, initializing `:parent' to OBJ.
|
||||
All slots are unbound, except those initialized with PARAMS."
|
||||
(let ((nobj (make-vector (length obj) eieio-unbound))
|
||||
(nm (eieio--object-name obj))
|
||||
(passname (and params (stringp (car params))))
|
||||
(num 1))
|
||||
(aset nobj 0 'object)
|
||||
(setf (eieio--object-class nobj) (eieio--object-class obj))
|
||||
;; The following was copied from the default clone.
|
||||
(if (not passname)
|
||||
(save-match-data
|
||||
(if (string-match "-\\([0-9]+\\)" nm)
|
||||
(setq num (1+ (string-to-number (match-string 1 nm)))
|
||||
nm (substring nm 0 (match-beginning 0))))
|
||||
(setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
|
||||
(setf (eieio--object-name nobj) (car params)))
|
||||
;; Now initialize from params.
|
||||
(if params (shared-initialize nobj (if passname (cdr params) params)))
|
||||
(let ((nobj (call-next-method)))
|
||||
(oset nobj parent-instance obj)
|
||||
nobj))
|
||||
|
||||
|
|
@ -155,7 +140,7 @@ Multiple calls to `make-instance' will return this object."))
|
|||
A singleton is a class which will only ever have one instance."
|
||||
:abstract t)
|
||||
|
||||
(defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots)
|
||||
(defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots)
|
||||
"Constructor for singleton CLASS.
|
||||
NAME and SLOTS initialize the new object.
|
||||
This constructor guarantees that no matter how many you request,
|
||||
|
|
@ -270,7 +255,7 @@ malicious code.
|
|||
Note: This function recurses when a slot of :type of some object is
|
||||
identified, and needing more object creation."
|
||||
(let ((objclass (nth 0 inputlist))
|
||||
(objname (nth 1 inputlist))
|
||||
;; (objname (nth 1 inputlist))
|
||||
(slots (nthcdr 2 inputlist))
|
||||
(createslots nil))
|
||||
|
||||
|
|
@ -285,7 +270,7 @@ identified, and needing more object creation."
|
|||
;; In addition, strip out quotes, list functions, and update
|
||||
;; object constructors as needed.
|
||||
(setq value (eieio-persistent-validate/fix-slot-value
|
||||
objclass name value))
|
||||
(eieio--class-v objclass) name value))
|
||||
|
||||
(push name createslots)
|
||||
(push value createslots)
|
||||
|
|
@ -293,7 +278,7 @@ identified, and needing more object creation."
|
|||
|
||||
(setq slots (cdr (cdr slots))))
|
||||
|
||||
(apply 'make-instance objclass objname (nreverse createslots))
|
||||
(apply #'make-instance objclass (nreverse createslots))
|
||||
|
||||
;;(eval inputlist)
|
||||
))
|
||||
|
|
@ -305,11 +290,13 @@ constructor functions are considered valid.
|
|||
Second, any text properties will be stripped from strings."
|
||||
(cond ((consp proposed-value)
|
||||
;; Lists with something in them need special treatment.
|
||||
(let ((slot-idx (eieio-slot-name-index class nil slot))
|
||||
(let ((slot-idx (eieio--slot-name-index class
|
||||
nil slot))
|
||||
(type nil)
|
||||
(classtype nil))
|
||||
(setq slot-idx (- slot-idx 3))
|
||||
(setq type (aref (eieio--class-public-type (class-v class))
|
||||
(setq slot-idx (- slot-idx
|
||||
(eval-when-compile eieio--object-num-slots)))
|
||||
(setq type (aref (eieio--class-public-type class)
|
||||
slot-idx))
|
||||
|
||||
(setq classtype (eieio-persistent-slot-type-is-class-p
|
||||
|
|
@ -346,8 +333,8 @@ Second, any text properties will be stripped from strings."
|
|||
(unless (and
|
||||
;; Do we have a type?
|
||||
(consp classtype) (class-p (car classtype)))
|
||||
(error "In save file, list of object constructors found, but no :type specified for slot %S"
|
||||
slot))
|
||||
(error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
|
||||
slot classtype))
|
||||
|
||||
;; We have a predicate, but it doesn't satisfy the predicate?
|
||||
(dolist (PV (cdr proposed-value))
|
||||
|
|
@ -375,31 +362,49 @@ Second, any text properties will be stripped from strings."
|
|||
)
|
||||
|
||||
(defun eieio-persistent-slot-type-is-class-p (type)
|
||||
"Return the class refered to in TYPE.
|
||||
"Return the class referred to in TYPE.
|
||||
If no class is referenced there, then return nil."
|
||||
(cond ((class-p type)
|
||||
;; If the type is a class, then return it.
|
||||
type)
|
||||
((and (eq 'list-of (car-safe type)) (class-p (cadr type)))
|
||||
;; If it is the type of a list of a class, then return that class and
|
||||
;; the type.
|
||||
(cons (cadr type) type))
|
||||
|
||||
((and (symbolp type) (string-match "-child$" (symbol-name type))
|
||||
((and (symbolp type) (get type 'cl-deftype-handler))
|
||||
;; Macro-expand the type according to cl-deftype definitions.
|
||||
(eieio-persistent-slot-type-is-class-p
|
||||
(funcall (get type 'cl-deftype-handler))))
|
||||
|
||||
;; FIXME: foo-child should not be a valid type!
|
||||
((and (symbolp type) (string-match "-child\\'" (symbol-name type))
|
||||
(class-p (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
(unless eieio-backward-compatibility
|
||||
(error "Use of bogus %S type instead of %S"
|
||||
type (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
;; If it is the predicate ending with -child, then return
|
||||
;; that class. Unfortunately, in EIEIO, typep of just the
|
||||
;; class is the same as if we used -child, so no further work needed.
|
||||
(intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0))))
|
||||
|
||||
((and (symbolp type) (string-match "-list$" (symbol-name type))
|
||||
;; FIXME: foo-list should not be a valid type!
|
||||
((and (symbolp type) (string-match "-list\\'" (symbol-name type))
|
||||
(class-p (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
(unless eieio-backward-compatibility
|
||||
(error "Use of bogus %S type instead of (list-of %S)"
|
||||
type (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
;; If it is the predicate ending with -list, then return
|
||||
;; that class and the predicate to use.
|
||||
(cons (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))
|
||||
type))
|
||||
|
||||
((and (consp type) (eq (car type) 'or))
|
||||
((eq (car-safe type) 'or)
|
||||
;; If type is a list, and is an or, it is possibly something
|
||||
;; like (or null myclass), so check for that.
|
||||
(let ((ans nil))
|
||||
|
|
@ -463,34 +468,38 @@ instance."
|
|||
|
||||
|
||||
;;; Named object
|
||||
;;
|
||||
;; Named objects use the objects `name' as a slot, and that slot
|
||||
;; is accessed with the `object-name' symbol.
|
||||
|
||||
(defclass eieio-named ()
|
||||
()
|
||||
"Object with a name.
|
||||
Name storage already occurs in an object. This object provides get/set
|
||||
access to it."
|
||||
((object-name :initarg :object-name :initform nil))
|
||||
"Object with a name."
|
||||
:abstract t)
|
||||
|
||||
(defmethod slot-missing ((obj eieio-named)
|
||||
slot-name operation &optional new-value)
|
||||
"Called when a non-existent slot is accessed.
|
||||
For variable `eieio-named', provide an imaginary `object-name' slot.
|
||||
Argument OBJ is the named object.
|
||||
Argument SLOT-NAME is the slot that was attempted to be accessed.
|
||||
OPERATION is the type of access, such as `oref' or `oset'.
|
||||
NEW-VALUE is the value that was being set into SLOT if OPERATION were
|
||||
a set type."
|
||||
(if (memq slot-name '(object-name :object-name))
|
||||
(cond ((eq operation 'oset)
|
||||
(if (not (stringp new-value))
|
||||
(signal 'invalid-slot-type
|
||||
(list obj slot-name 'string new-value)))
|
||||
(eieio-object-set-name-string obj new-value))
|
||||
(t (eieio-object-name-string obj)))
|
||||
(call-next-method)))
|
||||
(defmethod eieio-object-name-string ((obj eieio-named))
|
||||
"Return a string which is OBJ's name."
|
||||
(or (slot-value obj 'object-name)
|
||||
(symbol-name (eieio-object-class obj))))
|
||||
|
||||
(defmethod eieio-object-set-name-string ((obj eieio-named) name)
|
||||
"Set the string which is OBJ's NAME."
|
||||
(eieio--check-type stringp name)
|
||||
(eieio-oset obj 'object-name name))
|
||||
|
||||
(defmethod clone ((obj eieio-named) &rest params)
|
||||
"Clone OBJ, initializing `:parent' to OBJ.
|
||||
All slots are unbound, except those initialized with PARAMS."
|
||||
(let* ((newname (and (stringp (car params)) (pop params)))
|
||||
(nobj (apply #'call-next-method obj params))
|
||||
(nm (slot-value obj 'object-name)))
|
||||
(eieio-oset obj 'object-name
|
||||
(or newname
|
||||
(save-match-data
|
||||
(if (and nm (string-match "-\\([0-9]+\\)" nm))
|
||||
(let ((num (1+ (string-to-number
|
||||
(match-string 1 nm)))))
|
||||
(concat (substring nm 0 (match-beginning 0))
|
||||
"-" (int-to-string num)))
|
||||
(concat nm "-1")))))
|
||||
nobj))
|
||||
|
||||
(provide 'eieio-base)
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -1,4 +1,4 @@
|
|||
;;; eieio-custom.el -- eieio object customization
|
||||
;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation,
|
||||
;; Inc.
|
||||
|
|
@ -70,7 +70,7 @@ of these.")
|
|||
:documentation "A number of thingies."))
|
||||
"A class for testing the widget on.")
|
||||
|
||||
(defcustom eieio-widget-test (eieio-widget-test-class "Foo")
|
||||
(defcustom eieio-widget-test (eieio-widget-test-class)
|
||||
"Test variable for editing an object."
|
||||
:type 'object
|
||||
:group 'eieio)
|
||||
|
|
@ -136,7 +136,7 @@ Updates occur regardless of the current customization group.")
|
|||
))
|
||||
(widget-value-set vc (widget-value vc))))
|
||||
|
||||
(defun eieio-custom-toggle-parent (widget &rest ignore)
|
||||
(defun eieio-custom-toggle-parent (widget &rest _)
|
||||
"Toggle visibility of parent of WIDGET.
|
||||
Optional argument IGNORE is an extraneous parameter."
|
||||
(eieio-custom-toggle-hide (widget-get widget :parent)))
|
||||
|
|
@ -154,7 +154,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
:clone-object-children nil
|
||||
)
|
||||
|
||||
(defun eieio-object-match (widget value)
|
||||
(defun eieio-object-match (_widget _value)
|
||||
"Match info for WIDGET against VALUE."
|
||||
;; Write me
|
||||
t)
|
||||
|
|
@ -193,7 +193,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
(let* ((chil nil)
|
||||
(obj (widget-get widget :value))
|
||||
(master-group (widget-get widget :eieio-group))
|
||||
(cv (class-v (eieio--object-class obj)))
|
||||
(cv (eieio--object-class-object obj))
|
||||
(slots (eieio--class-public-a cv))
|
||||
(flabel (eieio--class-public-custom-label cv))
|
||||
(fgroup (eieio--class-public-custom-group cv))
|
||||
|
|
@ -208,7 +208,8 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
chil)))
|
||||
;; Display information about the group being shown
|
||||
(when master-group
|
||||
(let ((groups (class-option (eieio--object-class obj) :custom-groups)))
|
||||
(let ((groups (eieio--class-option (eieio--object-class-object obj)
|
||||
:custom-groups)))
|
||||
(widget-insert "Groups:")
|
||||
(while groups
|
||||
(widget-insert " ")
|
||||
|
|
@ -216,7 +217,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
(widget-insert "*" (capitalize (symbol-name master-group)) "*")
|
||||
(widget-create 'push-button
|
||||
:thing (cons obj (car groups))
|
||||
:notify (lambda (widget &rest stuff)
|
||||
:notify (lambda (widget &rest _)
|
||||
(eieio-customize-object
|
||||
(car (widget-get widget :thing))
|
||||
(cdr (widget-get widget :thing))))
|
||||
|
|
@ -260,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
(car flabel)
|
||||
(let ((s (symbol-name
|
||||
(or
|
||||
(class-slot-initarg
|
||||
(eieio--object-class obj)
|
||||
(eieio--class-slot-initarg
|
||||
(eieio--object-class-object obj)
|
||||
(car slots))
|
||||
(car slots)))))
|
||||
(capitalize
|
||||
|
|
@ -288,7 +289,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
"Get the value of WIDGET."
|
||||
(let* ((obj (widget-get widget :value))
|
||||
(master-group eieio-cog)
|
||||
(cv (class-v (eieio--object-class obj)))
|
||||
(cv (eieio--object-class-object obj))
|
||||
(fgroup (eieio--class-public-custom-group cv))
|
||||
(wids (widget-get widget :children))
|
||||
(name (if (widget-get widget :eieio-show-name)
|
||||
|
|
@ -296,7 +297,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
nil))
|
||||
(chil (if (widget-get widget :eieio-show-name)
|
||||
(nthcdr 1 wids) wids))
|
||||
(cv (class-v (eieio--object-class obj)))
|
||||
(cv (eieio--object-class-object obj))
|
||||
(slots (eieio--class-public-a cv))
|
||||
(fcust (eieio--class-public-custom cv)))
|
||||
;; If there are any prefix widgets, clear them.
|
||||
|
|
@ -317,11 +318,11 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
fgroup (cdr fgroup)
|
||||
fcust (cdr fcust)))
|
||||
;; Set any name updates on it.
|
||||
(if name (setf (eieio--object-name obj) name))
|
||||
(if name (eieio-object-set-name-string obj name))
|
||||
;; This is the same object we had before.
|
||||
obj))
|
||||
|
||||
(defmethod eieio-done-customizing ((obj eieio-default-superclass))
|
||||
(defmethod eieio-done-customizing ((_obj eieio-default-superclass))
|
||||
"When 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.
|
||||
|
|
@ -385,18 +386,18 @@ These groups are specified with the `:group' slot flag."
|
|||
(make-local-variable 'eieio-cog)
|
||||
(setq eieio-cog g)))
|
||||
|
||||
(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass))
|
||||
(defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
|
||||
"Insert an Apply and Reset button into the object editor.
|
||||
Argument OBJ is the object being customized."
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
(widget-apply eieio-wo :value-get)
|
||||
(eieio-done-customizing eieio-co)
|
||||
(bury-buffer))
|
||||
"Accept")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
;; I think the act of getting it sets
|
||||
;; its value through the get function.
|
||||
(message "Applying Changes...")
|
||||
|
|
@ -406,13 +407,13 @@ Argument OBJ is the object being customized."
|
|||
"Apply")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
(message "Resetting")
|
||||
(eieio-customize-object eieio-co eieio-cog))
|
||||
"Reset")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
(bury-buffer))
|
||||
"Cancel"))
|
||||
|
||||
|
|
@ -431,13 +432,11 @@ Must return the created widget."
|
|||
:clone-object-children t
|
||||
)
|
||||
|
||||
(defun eieio-object-value-to-abstract (widget value)
|
||||
(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)))
|
||||
(if (eieio-object-p value) value))
|
||||
|
||||
(defun eieio-object-abstract-to-value (widget value)
|
||||
(defun eieio-object-abstract-to-value (_widget value)
|
||||
"For WIDGET, convert VALUE from an abstract /safe/ representation."
|
||||
value)
|
||||
|
||||
|
|
@ -453,7 +452,7 @@ Must return the created widget."
|
|||
(vector (concat "Group " (symbol-name group))
|
||||
(list 'customize-object obj (list 'quote group))
|
||||
t))
|
||||
(class-option (eieio--object-class obj) :custom-groups)))
|
||||
(eieio--class-option (eieio--object-class-object obj) :custom-groups)))
|
||||
|
||||
(defvar eieio-read-custom-group-history nil
|
||||
"History for the custom group reader.")
|
||||
|
|
@ -461,7 +460,8 @@ Must return the created widget."
|
|||
(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 (eieio--object-class obj) :custom-groups)))
|
||||
(let ((g (eieio--class-option (eieio--object-class-object obj)
|
||||
:custom-groups)))
|
||||
(if (= (length g) 1)
|
||||
(car g)
|
||||
;; Make the association list
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; eieio-datadebug.el --- EIEIO extensions to the data debugger.
|
||||
;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
|
||||
|
||||
|
|
@ -87,7 +87,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
prefix
|
||||
"Name: ")
|
||||
(let* ((cl (eieio-object-class obj))
|
||||
(cv (class-v cl)))
|
||||
(cv (eieio--class-v cl)))
|
||||
(data-debug-insert-thing (class-constructor cl)
|
||||
prefix
|
||||
"Class: ")
|
||||
|
|
@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
)
|
||||
(while publa
|
||||
(if (slot-boundp obj (car publa))
|
||||
(let* ((i (class-slot-initarg cl (car publa)))
|
||||
(let* ((i (eieio--class-slot-initarg (eieio--class-v cl)
|
||||
(car publa)))
|
||||
(v (eieio-oref obj (car publa))))
|
||||
(data-debug-insert-thing
|
||||
v prefix (concat
|
||||
|
|
@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
(symbol-name (car publa)))
|
||||
" ")))
|
||||
;; Unbound case
|
||||
(let ((i (class-slot-initarg cl (car publa))))
|
||||
(let ((i (eieio--class-slot-initarg (eieio--class-v cl)
|
||||
(car publa))))
|
||||
(data-debug-insert-custom
|
||||
"#unbound" prefix
|
||||
(concat (if i (symbol-name i)
|
||||
|
|
@ -135,9 +137,9 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
(let* ((eieio-pre-method-execution-functions
|
||||
(lambda (l) (throw 'moose l) ))
|
||||
(data
|
||||
(catch 'moose (eieio-generic-call
|
||||
(catch 'moose (eieio--generic-call
|
||||
method (list class))))
|
||||
(buf (data-debug-new-buffer "*Method Invocation*"))
|
||||
(_buf (data-debug-new-buffer "*Method Invocation*"))
|
||||
(data2 (mapcar (lambda (sym)
|
||||
(symbol-function (car sym)))
|
||||
data)))
|
||||
|
|
|
|||
904
lisp/emacs-lisp/eieio-generic.el
Normal file
904
lisp/emacs-lisp/eieio-generic.el
Normal file
|
|
@ -0,0 +1,904 @@
|
|||
;;; eieio-generic.el --- CLOS-style generics for EIEIO -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 1995-1996, 1998-2015 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:
|
||||
;;
|
||||
;; The "core" part of EIEIO is the implementation for the object
|
||||
;; system (such as eieio-defclass, or eieio-defmethod) but not the
|
||||
;; base classes for the object system, which are defined in EIEIO.
|
||||
;;
|
||||
;; See the commentary for eieio.el for more about EIEIO itself.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'eieio-core)
|
||||
(declare-function child-of-class-p "eieio")
|
||||
|
||||
(defconst eieio--method-static 0 "Index into :static tag on a method.")
|
||||
(defconst eieio--method-before 1 "Index into :before tag on a method.")
|
||||
(defconst eieio--method-primary 2 "Index into :primary tag on a method.")
|
||||
(defconst eieio--method-after 3 "Index into :after tag on a method.")
|
||||
(defconst eieio--method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.")
|
||||
(defconst eieio--method-generic-before 4 "Index into generic :before tag on a method.")
|
||||
(defconst eieio--method-generic-primary 5 "Index into generic :primary tag on a method.")
|
||||
(defconst eieio--method-generic-after 6 "Index into generic :after tag on a method.")
|
||||
(defconst eieio--method-num-slots 7 "Number of indexes into a method's vector.")
|
||||
|
||||
(defsubst eieio--specialized-key-to-generic-key (key)
|
||||
"Convert a specialized KEY into a generic method key."
|
||||
(cond ((eq key eieio--method-static) 0) ;; don't convert
|
||||
((< key eieio--method-num-lists) (+ key 3)) ;; The conversion
|
||||
(t key) ;; already generic.. maybe.
|
||||
))
|
||||
|
||||
|
||||
(defsubst generic-p (method)
|
||||
"Return non-nil if symbol METHOD is a generic function.
|
||||
Only methods have the symbol `eieio-method-hashtable' as a property
|
||||
\(which contains a list of all bindings to that method type.)"
|
||||
(and (fboundp method) (get method 'eieio-method-hashtable)))
|
||||
|
||||
(defun eieio--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-hashtable' 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)))
|
||||
(not (or (>= 0 (length (aref M eieio--method-primary)))
|
||||
(aref M eieio--method-static)
|
||||
(aref M eieio--method-before)
|
||||
(aref M eieio--method-after)
|
||||
(aref M eieio--method-generic-before)
|
||||
(aref M eieio--method-generic-primary)
|
||||
(aref M eieio--method-generic-after)))
|
||||
)))
|
||||
|
||||
(defun eieio--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-hashtable' 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)))
|
||||
(not (or (/= 1 (length (aref M eieio--method-primary)))
|
||||
(aref M eieio--method-static)
|
||||
(aref M eieio--method-before)
|
||||
(aref M eieio--method-after)
|
||||
(aref M eieio--method-generic-before)
|
||||
(aref M eieio--method-generic-primary)
|
||||
(aref M eieio--method-generic-after)))
|
||||
)))
|
||||
|
||||
(defun eieio--defgeneric-init-form (method doc-string)
|
||||
"Form to use for the initial definition of a generic."
|
||||
(while (and (fboundp method) (symbolp (symbol-function method)))
|
||||
;; Follow aliases, so methods applied to obsolete aliases still work.
|
||||
(setq method (symbol-function method)))
|
||||
|
||||
(cond
|
||||
((or (not (fboundp method))
|
||||
(eq 'autoload (car-safe (symbol-function method))))
|
||||
;; Make sure the method tables are installed.
|
||||
(eieio--mt-install method)
|
||||
;; Construct the actual body of this function.
|
||||
(put method 'function-documentation doc-string)
|
||||
(eieio--defgeneric-form method))
|
||||
((generic-p method) (symbol-function method)) ;Leave it as-is.
|
||||
(t (error "You cannot create a generic/method over an existing symbol: %s"
|
||||
method))))
|
||||
|
||||
(defun eieio--defgeneric-form (method)
|
||||
"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)
|
||||
(eieio--generic-call method local-args)))
|
||||
|
||||
(defun eieio--defgeneric-form-primary-only (method)
|
||||
"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)
|
||||
(eieio--generic-call-primary-only method local-args)))
|
||||
|
||||
(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.")
|
||||
|
||||
(defun eieio--defgeneric-form-primary-only-one (method 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.
|
||||
CLASS is the class symbol needed for private method access.
|
||||
IMPL is the symbol holding the method implementation."
|
||||
(lambda (&rest local-args)
|
||||
;; 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 method local-args))
|
||||
|
||||
;; We do have an object. Make sure it is the right type.
|
||||
(if (not (child-of-class-p (eieio--object-class-object (car local-args))
|
||||
class))
|
||||
|
||||
;; If not the right kind of object, call no applicable
|
||||
(apply #'no-applicable-method (car local-args)
|
||||
method local-args)
|
||||
|
||||
;; It is ok, do the call.
|
||||
;; Fill in inter-call variables then evaluate the method.
|
||||
(let ((eieio--generic-call-next-method-list nil)
|
||||
(eieio--generic-call-key eieio--method-primary)
|
||||
(eieio--generic-call-arglst local-args)
|
||||
)
|
||||
(eieio--with-scoped-class (eieio--class-v class)
|
||||
(apply impl local-args)))))))
|
||||
|
||||
(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-hashtable nil))
|
||||
|
||||
(defun eieio--method-optimize-primary (method)
|
||||
(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.
|
||||
(let ((doc-string (documentation method 'raw)))
|
||||
(put method 'function-documentation doc-string)
|
||||
;; Use `defalias' so as to interact properly with nadvice.el.
|
||||
(defalias method
|
||||
(if (eieio--generic-primary-only-p method)
|
||||
;; If there is only one primary method, then we can go one more
|
||||
;; optimization step.
|
||||
(if (eieio--generic-primary-only-one-p method)
|
||||
(let* ((M (get method 'eieio-method-tree))
|
||||
(entry (car (aref M eieio--method-primary))))
|
||||
(eieio--defgeneric-form-primary-only-one
|
||||
method (car entry) (cdr entry)))
|
||||
(eieio--defgeneric-form-primary-only method))
|
||||
(eieio--defgeneric-form method))))))
|
||||
|
||||
(defun eieio--defmethod (method kind argclass code)
|
||||
"Work part of the `defmethod' macro defining METHOD with ARGS."
|
||||
(let ((key
|
||||
;; Find optional keys.
|
||||
(cond ((memq kind '(:BEFORE :before)) eieio--method-before)
|
||||
((memq kind '(:AFTER :after)) eieio--method-after)
|
||||
((memq kind '(:STATIC :static)) eieio--method-static)
|
||||
((memq kind '(:PRIMARY :primary nil)) eieio--method-primary)
|
||||
;; Primary key.
|
||||
;; (t eieio--method-primary)
|
||||
(t (error "Unknown method kind %S" kind)))))
|
||||
|
||||
(while (and (fboundp method) (symbolp (symbol-function method)))
|
||||
;; Follow aliases, so methods applied to obsolete aliases still work.
|
||||
(setq method (symbol-function method)))
|
||||
|
||||
;; Make sure there is a generic (when called from defclass).
|
||||
(eieio--defalias
|
||||
method (eieio--defgeneric-init-form
|
||||
method (or (documentation code)
|
||||
(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.
|
||||
(if argclass
|
||||
(if (not (class-p argclass)) ;FIXME: Accept cl-defstructs!
|
||||
(error "Unknown class type %s in method parameters"
|
||||
argclass))
|
||||
;; Generics are higher.
|
||||
(setq key (eieio--specialized-key-to-generic-key key)))
|
||||
;; Put this lambda into the symbol so we can find it.
|
||||
(eieio--mt-add method code key argclass)
|
||||
)
|
||||
|
||||
(eieio--method-optimize-primary method)
|
||||
|
||||
method)
|
||||
|
||||
(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks
|
||||
'eieio-pre-method-execution-functions "24.3")
|
||||
(defvar eieio-pre-method-execution-functions nil
|
||||
"Abnormal hook run just before an EIEIO method is executed.
|
||||
The hook function must accept one argument, the 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-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 is ok if it doesn't turn out to be a class. Probably want that
|
||||
;; function loaded anyway.
|
||||
(if (and (symbolp firstarg)
|
||||
(fboundp firstarg)
|
||||
(autoloadp (symbol-function firstarg)))
|
||||
(autoload-do-load (symbol-function firstarg)))
|
||||
;; Determine the class to use.
|
||||
(cond ((eieio-object-p firstarg)
|
||||
(setq mclass (eieio--object-class-name 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.
|
||||
(unless (or (null mclass) (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
|
||||
(eieio--mt-method-list method eieio--method-after mclass)
|
||||
(list (eieio--generic-form method eieio--method-after nil)))
|
||||
;;(or (and mclass (eieio--generic-form method eieio--method-after mclass))
|
||||
;; (eieio--generic-form method eieio--method-after nil))
|
||||
)
|
||||
(setq lambdas (append tlambdas lambdas)
|
||||
keys (append (make-list (length tlambdas) eieio--method-after) keys))
|
||||
|
||||
;; :primary methods
|
||||
(setq tlambdas
|
||||
(or (and mclass (eieio--generic-form method eieio--method-primary mclass))
|
||||
(eieio--generic-form method eieio--method-primary nil)))
|
||||
(when tlambdas
|
||||
(setq lambdas (cons tlambdas lambdas)
|
||||
keys (cons eieio--method-primary keys)
|
||||
primarymethodlist
|
||||
(eieio--mt-method-list method eieio--method-primary mclass)))
|
||||
|
||||
;; :before methods
|
||||
(setq tlambdas
|
||||
(if mclass
|
||||
(eieio--mt-method-list method eieio--method-before mclass)
|
||||
(list (eieio--generic-form method eieio--method-before nil)))
|
||||
;;(or (and mclass (eieio--generic-form method eieio--method-before mclass))
|
||||
;; (eieio--generic-form method eieio--method-before nil))
|
||||
)
|
||||
(setq lambdas (append tlambdas lambdas)
|
||||
keys (append (make-list (length tlambdas) eieio--method-before) keys))
|
||||
)
|
||||
|
||||
(if mclass
|
||||
;; For the case of a class,
|
||||
;; if there were no methods found, then there could be :static methods.
|
||||
(when (not lambdas)
|
||||
(setq tlambdas
|
||||
(eieio--generic-form method eieio--method-static mclass))
|
||||
(setq lambdas (cons tlambdas lambdas)
|
||||
keys (cons eieio--method-static keys)
|
||||
primarymethodlist ;; Re-use even with bad name here
|
||||
(eieio--mt-method-list method eieio--method-static mclass)))
|
||||
;; For the case of no class (ie - mclass == nil) then there may
|
||||
;; be a primary method.
|
||||
(setq tlambdas
|
||||
(eieio--generic-form method eieio--method-primary nil))
|
||||
(when tlambdas
|
||||
(setq lambdas (cons tlambdas lambdas)
|
||||
keys (cons eieio--method-primary keys)
|
||||
primarymethodlist
|
||||
(eieio--mt-method-list method eieio--method-primary nil)))
|
||||
)
|
||||
|
||||
(run-hook-with-args 'eieio-pre-method-execution-functions
|
||||
primarymethodlist)
|
||||
|
||||
;; Now loop through all occurrences forms which we must execute
|
||||
;; (which are happily sorted now) and execute them all!
|
||||
(let ((rval nil) (lastval nil) (found nil))
|
||||
(while lambdas
|
||||
(if (car lambdas)
|
||||
(eieio--with-scoped-class (cdr (car lambdas))
|
||||
(let* ((eieio--generic-call-key (car keys))
|
||||
(has-return-val
|
||||
(or (= eieio--generic-call-key eieio--method-primary)
|
||||
(= eieio--generic-call-key eieio--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))
|
||||
)))
|
||||
(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))
|
||||
(signal
|
||||
'no-method-definition
|
||||
(list method args))))
|
||||
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-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 (eieio--object-class-name firstarg)))
|
||||
((not firstarg)
|
||||
(error "Method %s called on nil" method))
|
||||
(t
|
||||
(error "Primary-only method %s called on something not an object" 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 eieio--method-primary mclass))
|
||||
(setq primarymethodlist ;; Re-use even with bad name here
|
||||
(eieio--mt-method-list method eieio--method-primary mclass))
|
||||
|
||||
;; Now loop through all occurrences forms which we must execute
|
||||
;; (which are happily sorted now) and execute them all!
|
||||
(eieio--with-scoped-class (cdr lambdas)
|
||||
(let* ((rval nil) (lastval nil)
|
||||
(eieio--generic-call-key eieio--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))
|
||||
(signal
|
||||
'no-method-definition
|
||||
(list method args)))
|
||||
|
||||
;; Do the regular implementation here.
|
||||
|
||||
(run-hook-with-args 'eieio-pre-method-execution-functions
|
||||
lambdas)
|
||||
|
||||
(setq lastval (apply (car lambdas) newargs))
|
||||
(setq rval lastval))
|
||||
|
||||
rval))))
|
||||
|
||||
(defun eieio--mt-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.
|
||||
|
||||
;; Collect lambda expressions stored for the class and its parent
|
||||
;; classes.
|
||||
(let (lambdas)
|
||||
(dolist (ancestor (eieio--class-precedence-list (eieio--class-v class)))
|
||||
;; Lookup the form to use for the PRIMARY object for the next level
|
||||
(let ((tmpl (eieio--generic-form method key ancestor)))
|
||||
(when (and tmpl
|
||||
(or (not lambdas)
|
||||
;; This prevents duplicates coming out of the
|
||||
;; class method optimizer. Perhaps we should
|
||||
;; just not optimize before/afters?
|
||||
(not (member tmpl lambdas))))
|
||||
(push tmpl lambdas))))
|
||||
|
||||
;; Return collected lambda. For :after methods, return in current
|
||||
;; order (most general class last); Otherwise, reverse order.
|
||||
(if (eq key eieio--method-after)
|
||||
lambdas
|
||||
(nreverse lambdas))))
|
||||
|
||||
|
||||
;;;
|
||||
;; eieio-method-tree : eieio--mt-
|
||||
;;
|
||||
;; Stored as eieio-method-tree in property list of a generic method
|
||||
;;
|
||||
;; (eieio-method-tree . [BEFORE PRIMARY AFTER
|
||||
;; genericBEFORE genericPRIMARY genericAFTER])
|
||||
;; and
|
||||
;; (eieio-method-hashtable . [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 eieio--mt--optimizing-hashtable nil
|
||||
"While mapping atoms, this contain the hashtable being optimized.")
|
||||
|
||||
(defun eieio--mt-install (method-name)
|
||||
"Install the method tree, and hashtable onto METHOD-NAME.
|
||||
Do not do the work if they already exist."
|
||||
(unless (and (get method-name 'eieio-method-tree)
|
||||
(get method-name 'eieio-method-hashtable))
|
||||
(put method-name 'eieio-method-tree
|
||||
(make-vector eieio--method-num-slots nil))
|
||||
(let ((emto (put method-name 'eieio-method-hashtable
|
||||
(make-vector eieio--method-num-slots nil))))
|
||||
(aset emto 0 (make-hash-table :test 'eq))
|
||||
(aset emto 1 (make-hash-table :test 'eq))
|
||||
(aset emto 2 (make-hash-table :test 'eq))
|
||||
(aset emto 3 (make-hash-table :test 'eq)))))
|
||||
|
||||
(defun eieio--mt-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 eieio--method-num-slots) (< key 0))
|
||||
(error "eieio--mt-add: method key error!"))
|
||||
(let ((emtv (get method-name 'eieio-method-tree))
|
||||
(emto (get method-name 'eieio-method-hashtable)))
|
||||
;; Make sure the method tables are available.
|
||||
(unless (and emtv emto)
|
||||
(error "Programmer error: eieio--mt-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 hashtable, otherwise use the
|
||||
;; other array to keep this stuff.
|
||||
(if (< key eieio--method-num-lists)
|
||||
(puthash (eieio--class-v class) (list method) (aref emto key)))
|
||||
;; Save the defmethod file location in a symbol property.
|
||||
(let ((fname (if load-in-progress
|
||||
load-file-name
|
||||
buffer-file-name)))
|
||||
(when fname
|
||||
(when (string-match "\\.elc\\'" fname)
|
||||
(setq fname (substring fname 0 (1- (length fname)))))
|
||||
(cl-pushnew (list class fname) (get method-name 'method-locations)
|
||||
:test 'equal)))
|
||||
;; Now optimize the entire hashtable.
|
||||
(if (< key eieio--method-num-lists)
|
||||
(let ((eieio--mt--optimizing-hashtable (aref emto key)))
|
||||
;; @todo - Is this overkill? Should we just clear the symbol?
|
||||
(maphash #'eieio--mt--sym-optimize eieio--mt--optimizing-hashtable)))
|
||||
))
|
||||
|
||||
(defun eieio--mt-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 (eieio--class-parent (eieio--class-v class))
|
||||
(if (eq class 'eieio-default-superclass)
|
||||
nil
|
||||
'(eieio-default-superclass))))
|
||||
|
||||
(defun eieio--mt--sym-optimize (class s)
|
||||
"Find the next class above S which has a function body for the optimizer."
|
||||
;; Set the value to nil in case there is no nearest cell.
|
||||
(setcdr s nil)
|
||||
;; Find the nearest cell that has a function body. If we find one,
|
||||
;; we replace the nil from above.
|
||||
(catch 'done
|
||||
(dolist (ancestor
|
||||
(cl-rest (eieio--class-precedence-list class)))
|
||||
(let ((ov (gethash ancestor eieio--mt--optimizing-hashtable)))
|
||||
(when (car ov)
|
||||
(setcdr s ancestor) ;; store ov as our next symbol
|
||||
(throw 'done ancestor))))))
|
||||
|
||||
(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 memorized for faster future use."
|
||||
(if (symbolp class) (setq class (eieio--class-v class)))
|
||||
(let ((emto (aref (get method 'eieio-method-hashtable)
|
||||
(if class key (eieio--specialized-key-to-generic-key key)))))
|
||||
(if (eieio--class-p class)
|
||||
;; 1) find our symbol
|
||||
(let ((cs (gethash class emto)))
|
||||
(unless cs
|
||||
;; 2) If there isn't one, then make one.
|
||||
;; This can be slow since it only occurs once
|
||||
(puthash class (setq cs (list nil)) emto)
|
||||
;; 2.1) Cache its nearest neighbor with a quick optimize
|
||||
;; which should only occur once for this call ever
|
||||
(let ((eieio--mt--optimizing-hashtable emto))
|
||||
(eieio--mt--sym-optimize class cs)))
|
||||
;; 3) If it's bound return this one.
|
||||
(if (car cs)
|
||||
(cons (car cs) class)
|
||||
;; 4) If it's not bound then this variable knows something
|
||||
(if (cdr cs)
|
||||
(progn
|
||||
;; 4.1) This symbol holds the next class in its value
|
||||
(setq class (cdr cs)
|
||||
cs (gethash class emto))
|
||||
;; 4.2) The optimizer should always have chosen a
|
||||
;; function-symbol
|
||||
;;(if (car cs)
|
||||
(cons (car cs) class)
|
||||
;;(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 (eieio--specialized-key-to-generic-key key)))))
|
||||
(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)))))
|
||||
|
||||
|
||||
(define-error 'no-method-definition "No method definition")
|
||||
(define-error 'no-next-method "No next method")
|
||||
|
||||
;;; CLOS methods and generics
|
||||
;;
|
||||
(defmacro defgeneric (method _args &optional doc-string)
|
||||
"Create a generic function METHOD.
|
||||
DOC-STRING is the base documentation for this class. A generic
|
||||
function has no body, as its purpose is to decide which method body
|
||||
is appropriate to use. Uses `defmethod' to create methods, and calls
|
||||
`defgeneric' for you. With this implementation the ARGS are
|
||||
currently ignored. You can use `defgeneric' to apply specialized
|
||||
top level documentation to a method."
|
||||
(declare (doc-string 3))
|
||||
`(eieio--defalias ',method
|
||||
(eieio--defgeneric-init-form ',method ,doc-string)))
|
||||
|
||||
(defmacro defmethod (method &rest args)
|
||||
"Create a new METHOD through `defgeneric' with ARGS.
|
||||
|
||||
The optional second 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)"
|
||||
(declare (doc-string 3)
|
||||
(debug
|
||||
(&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
|
||||
)))
|
||||
(let* ((key (if (keywordp (car args)) (pop args)))
|
||||
(params (car args))
|
||||
(arg1 (car params))
|
||||
(fargs (if (consp arg1)
|
||||
(cons (car arg1) (cdr params))
|
||||
params))
|
||||
(class (if (consp arg1) (nth 1 arg1)))
|
||||
(code `(lambda ,fargs ,@(cdr args))))
|
||||
`(progn
|
||||
;; Make sure there is a generic and the byte-compiler sees it.
|
||||
(defgeneric ,method ,args
|
||||
,(or (documentation code)
|
||||
(format "Generically created method `%s'." method)))
|
||||
(eieio--defmethod ',method ',key ',class #',code))))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;; Method Calling Functions
|
||||
|
||||
(defun next-method-p ()
|
||||
"Return 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 (eieio--scoped-class))
|
||||
(error "`call-next-method' not called within a class specific method"))
|
||||
(if (and (/= eieio--generic-call-key eieio--method-primary)
|
||||
(/= eieio--generic-call-key eieio--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 (not (and next (car next)))
|
||||
(apply #'no-next-method newargs)
|
||||
(let* ((eieio--generic-call-next-method-list
|
||||
(cdr eieio--generic-call-next-method-list))
|
||||
(eieio--generic-call-arglst newargs)
|
||||
(fcn (car next))
|
||||
)
|
||||
(eieio--with-scoped-class (cdr next)
|
||||
(apply fcn newargs)) ))))
|
||||
|
||||
(defgeneric no-applicable-method (object method &rest args)
|
||||
"Called if there are no implementations for OBJECT in METHOD.")
|
||||
|
||||
(defmethod no-applicable-method (object 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)))
|
||||
|
||||
(defgeneric no-next-method (object &rest args)
|
||||
"Called from `call-next-method' when no additional methods are available.")
|
||||
|
||||
(defmethod no-next-method (object &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 its return value becomes the
|
||||
return value of `call-next-method'."
|
||||
(signal 'no-next-method (list object args)))
|
||||
|
||||
(add-hook 'help-fns-describe-function-functions 'eieio--help-generic)
|
||||
(defun eieio--help-generic (generic)
|
||||
"Describe GENERIC if it is a generic function."
|
||||
(when (and (symbolp generic) (generic-p generic))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward " in `.+'.$" nil t)
|
||||
(replace-match ".")))
|
||||
(save-excursion
|
||||
(insert "\n\nThis is a generic function"
|
||||
(cond
|
||||
((and (eieio--generic-primary-only-p generic)
|
||||
(eieio--generic-primary-only-one-p generic))
|
||||
" with only one primary method")
|
||||
((eieio--generic-primary-only-p generic)
|
||||
" with only primary methods")
|
||||
(t ""))
|
||||
".\n\n")
|
||||
(insert (propertize "Implementations:\n\n" 'face 'bold))
|
||||
(let ((i 4)
|
||||
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
|
||||
;; Loop over fanciful generics
|
||||
(while (< i 7)
|
||||
(let ((gm (aref (get generic 'eieio-method-tree) i)))
|
||||
(when gm
|
||||
(insert "Generic "
|
||||
(aref prefix (- i 3))
|
||||
"\n"
|
||||
(or (nth 2 gm) "Undocumented")
|
||||
"\n\n")))
|
||||
(setq i (1+ i)))
|
||||
(setq i 0)
|
||||
;; Loop over defined class-specific methods
|
||||
(while (< i 4)
|
||||
(let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
|
||||
cname location)
|
||||
(while gm
|
||||
(setq cname (caar gm))
|
||||
(insert "`")
|
||||
(help-insert-xref-button (symbol-name cname)
|
||||
'help-variable cname)
|
||||
(insert "' " (aref prefix i) " ")
|
||||
;; argument list
|
||||
(let* ((func (cdr (car gm)))
|
||||
(arglst (help-function-arglist func)))
|
||||
(prin1 arglst (current-buffer)))
|
||||
(insert "\n"
|
||||
(or (documentation (cdr (car gm)))
|
||||
"Undocumented"))
|
||||
;; Print file location if available
|
||||
(when (and (setq location (get generic 'method-locations))
|
||||
(setq location (assoc cname location)))
|
||||
(setq location (cadr location))
|
||||
(insert "\n\nDefined in `")
|
||||
(help-insert-xref-button
|
||||
(file-name-nondirectory location)
|
||||
'eieio-method-def cname generic location)
|
||||
(insert "'\n"))
|
||||
(setq gm (cdr gm))
|
||||
(insert "\n")))
|
||||
(setq i (1+ i)))))))
|
||||
|
||||
;;; Obsolete backward compatibility functions.
|
||||
;; Needed to run byte-code compiled with the EIEIO of Emacs-23.
|
||||
|
||||
(defun eieio-defmethod (method args)
|
||||
"Obsolete work part of an old version of the `defmethod' macro."
|
||||
(let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
|
||||
;; find optional keys
|
||||
(setq key
|
||||
(cond ((memq (car args) '(:BEFORE :before))
|
||||
(setq args (cdr args))
|
||||
eieio--method-before)
|
||||
((memq (car args) '(:AFTER :after))
|
||||
(setq args (cdr args))
|
||||
eieio--method-after)
|
||||
((memq (car args) '(:STATIC :static))
|
||||
(setq args (cdr args))
|
||||
eieio--method-static)
|
||||
((memq (car args) '(:PRIMARY :primary))
|
||||
(setq args (cdr args))
|
||||
eieio--method-primary)
|
||||
;; Primary key.
|
||||
(t eieio--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))))
|
||||
;; Generics are higher.
|
||||
(setq key (eieio--specialized-key-to-generic-key key)))
|
||||
;; Put this lambda into the symbol so we can find it.
|
||||
(if (byte-code-function-p (car-safe body))
|
||||
(eieio--mt-add method (car-safe body) key argclass)
|
||||
(eieio--mt-add method (append (list 'lambda (reverse argfix)) body)
|
||||
key argclass))
|
||||
)
|
||||
|
||||
(eieio--method-optimize-primary method)
|
||||
|
||||
method)
|
||||
(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")
|
||||
|
||||
(defun eieio-defgeneric (method doc-string)
|
||||
"Obsolete work part of an old version of the `defgeneric' macro."
|
||||
(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.
|
||||
(eieio--mt-install method)
|
||||
;; Apply the actual body of this function.
|
||||
(put method 'function-documentation doc-string)
|
||||
(fset method (eieio--defgeneric-form method))
|
||||
;; Return the method
|
||||
'method))
|
||||
(make-obsolete 'eieio-defgeneric nil "24.1")
|
||||
|
||||
(provide 'eieio-generic)
|
||||
|
||||
;;; eieio-generic.el ends here
|
||||
|
|
@ -60,7 +60,7 @@ Argument PREFIX is the character prefix to use.
|
|||
Argument CH-PREFIX is another character prefix to display."
|
||||
(eieio--check-type class-p this-root)
|
||||
(let ((myname (symbol-name this-root))
|
||||
(chl (eieio--class-children (class-v this-root)))
|
||||
(chl (eieio--class-children (eieio--class-v this-root)))
|
||||
(fprefix (concat ch-prefix " +--"))
|
||||
(mprefix (concat ch-prefix " | "))
|
||||
(lprefix (concat ch-prefix " ")))
|
||||
|
|
@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object.
|
|||
;; Header line
|
||||
(prin1 class)
|
||||
(insert " is a"
|
||||
(if (class-option class :abstract)
|
||||
(if (eieio--class-option (eieio--class-v class) :abstract)
|
||||
"n abstract"
|
||||
"")
|
||||
" class")
|
||||
|
|
@ -149,7 +149,7 @@ If CLASS is actually an object, then also display current values of that object.
|
|||
(defun eieio-help-class-slots (class)
|
||||
"Print help description for the slots in CLASS.
|
||||
Outputs to the current buffer."
|
||||
(let* ((cv (class-v class))
|
||||
(let* ((cv (eieio--class-v class))
|
||||
(docs (eieio--class-public-doc cv))
|
||||
(names (eieio--class-public-a cv))
|
||||
(deflt (eieio--class-public-d cv))
|
||||
|
|
@ -218,11 +218,10 @@ Outputs to the current buffer."
|
|||
(defun eieio-build-class-list (class)
|
||||
"Return a list of all classes that inherit from CLASS."
|
||||
(if (class-p class)
|
||||
(apply #'append
|
||||
(mapcar
|
||||
(lambda (c)
|
||||
(append (list c) (eieio-build-class-list c)))
|
||||
(eieio-class-children-fast class)))
|
||||
(cl-mapcan
|
||||
(lambda (c)
|
||||
(append (list c) (eieio-build-class-list c)))
|
||||
(eieio--class-children (eieio--class-v class)))
|
||||
(list class)))
|
||||
|
||||
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
|
||||
|
|
@ -231,15 +230,16 @@ 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 (eieio--class-children (class-v cc))))
|
||||
(let* ((cc (or class 'eieio-default-superclass))
|
||||
(sublst (eieio--class-children (eieio--class-v cc))))
|
||||
(unless (assoc (symbol-name cc) buildlist)
|
||||
(when (or (not instantiable-only) (not (class-abstract-p cc)))
|
||||
;; FIXME: Completion tables don't need alists, and ede/generic.el needs
|
||||
;; the symbols rather than their names.
|
||||
(setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
|
||||
(while sublst
|
||||
(dolist (elem sublst)
|
||||
(setq buildlist (eieio-build-class-alist
|
||||
(car sublst) instantiable-only buildlist))
|
||||
(setq sublst (cdr sublst)))
|
||||
elem instantiable-only buildlist)))
|
||||
buildlist))
|
||||
|
||||
(defvar eieio-read-class nil
|
||||
|
|
@ -311,132 +311,59 @@ are not abstract."
|
|||
(eieio-help-class ctr))
|
||||
))))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defun eieio-help-generic (generic)
|
||||
"Describe GENERIC if it is a generic function."
|
||||
(when (and (symbolp generic) (generic-p generic))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward " in `.+'.$" nil t)
|
||||
(replace-match ".")))
|
||||
(save-excursion
|
||||
(insert "\n\nThis is a generic function"
|
||||
(cond
|
||||
((and (generic-primary-only-p generic)
|
||||
(generic-primary-only-one-p generic))
|
||||
" with only one primary method")
|
||||
((generic-primary-only-p generic)
|
||||
" with only primary methods")
|
||||
(t ""))
|
||||
".\n\n")
|
||||
(insert (propertize "Implementations:\n\n" 'face 'bold))
|
||||
(let ((i 4)
|
||||
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
|
||||
;; Loop over fanciful generics
|
||||
(while (< i 7)
|
||||
(let ((gm (aref (get generic 'eieio-method-tree) i)))
|
||||
(when gm
|
||||
(insert "Generic "
|
||||
(aref prefix (- i 3))
|
||||
"\n"
|
||||
(or (nth 2 gm) "Undocumented")
|
||||
"\n\n")))
|
||||
(setq i (1+ i)))
|
||||
(setq i 0)
|
||||
;; Loop over defined class-specific methods
|
||||
(while (< i 4)
|
||||
(let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
|
||||
cname location)
|
||||
(while gm
|
||||
(setq cname (caar gm))
|
||||
(insert "`")
|
||||
(help-insert-xref-button (symbol-name cname)
|
||||
'help-variable cname)
|
||||
(insert "' " (aref prefix i) " ")
|
||||
;; argument list
|
||||
(let* ((func (cdr (car gm)))
|
||||
(arglst (help-function-arglist func)))
|
||||
(prin1 arglst (current-buffer)))
|
||||
(insert "\n"
|
||||
(or (documentation (cdr (car gm)))
|
||||
"Undocumented"))
|
||||
;; Print file location if available
|
||||
(when (and (setq location (get generic 'method-locations))
|
||||
(setq location (assoc cname location)))
|
||||
(setq location (cadr location))
|
||||
(insert "\n\nDefined in `")
|
||||
(help-insert-xref-button
|
||||
(file-name-nondirectory location)
|
||||
'eieio-method-def cname generic location)
|
||||
(insert "'\n"))
|
||||
(setq gm (cdr gm))
|
||||
(insert "\n")))
|
||||
(setq i (1+ i)))))))
|
||||
|
||||
(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)))
|
||||
(let ((l 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)))))))
|
||||
(let ((tree (get symbol 'eieio-method-hashtable)))
|
||||
(when tree
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(if (or (not class)
|
||||
(car (gethash class (aref tree 0)))
|
||||
(car (gethash class (aref tree 1)))
|
||||
(car (gethash class (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
|
||||
(let ((tree (get generic 'eieio-method-hashtable)))
|
||||
(when tree
|
||||
;; 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 (help-function-arglist before)
|
||||
(documentation before))
|
||||
nil)
|
||||
(if (fboundp primary)
|
||||
(cons (help-function-arglist primary)
|
||||
(documentation primary))
|
||||
nil)
|
||||
(if (fboundp after)
|
||||
(cons (help-function-arglist after)
|
||||
(documentation after))
|
||||
nil))))))
|
||||
;; these three slots in the method-hashtable.
|
||||
;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static,
|
||||
;; 1 for before, and 2 for primary (and 3 for after)?
|
||||
(let ((before (car (gethash class (aref tree 0))))
|
||||
(primary (car (gethash class (aref tree 1))))
|
||||
(after (car (gethash class (aref tree 2)))))
|
||||
(if (not (or before primary after))
|
||||
nil
|
||||
(list (if before
|
||||
(cons (help-function-arglist before)
|
||||
(documentation before))
|
||||
nil)
|
||||
(if primary
|
||||
(cons (help-function-arglist primary)
|
||||
(documentation primary))
|
||||
nil)
|
||||
(if after
|
||||
(cons (help-function-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
|
||||
(intern (completing-read prompt obarray #'generic-p
|
||||
t nil (or historyvar 'eieio-read-generic))))
|
||||
|
||||
;;; METHOD STATS
|
||||
|
|
@ -627,21 +554,21 @@ Optional argument HISTORYVAR is the variable to use as history."
|
|||
()
|
||||
"Menu part in easymenu format used in speedbar while in `eieio' mode.")
|
||||
|
||||
(defun eieio-class-speedbar (dir-or-object depth)
|
||||
(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.
|
||||
;; Create and expand the default object.
|
||||
(eieio-class-button eieio-default-superclass 0)
|
||||
(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."
|
||||
(eieio--check-type class-p class)
|
||||
(let ((subclasses (eieio--class-children (class-v class))))
|
||||
(let ((subclasses (eieio--class-children (eieio--class-v class))))
|
||||
(if subclasses
|
||||
(speedbar-make-tag-line 'angle ?+
|
||||
'eieio-sb-expand
|
||||
|
|
@ -666,7 +593,7 @@ Argument INDENT is the depth of indentation."
|
|||
(speedbar-with-writable
|
||||
(save-excursion
|
||||
(end-of-line) (forward-char 1)
|
||||
(let ((subclasses (eieio--class-children (class-v class))))
|
||||
(let ((subclasses (eieio--class-children (eieio--class-v class))))
|
||||
(while subclasses
|
||||
(eieio-class-button (car subclasses) (1+ indent))
|
||||
(setq subclasses (cdr subclasses)))))))
|
||||
|
|
@ -676,7 +603,7 @@ Argument INDENT is the depth of indentation."
|
|||
(t (error "Ooops... not sure what to do")))
|
||||
(speedbar-center-buffer-smartly))
|
||||
|
||||
(defun eieio-describe-class-sb (text token indent)
|
||||
(defun eieio-describe-class-sb (_text token _indent)
|
||||
"Describe the class TEXT in TOKEN.
|
||||
INDENT is the current indentation level."
|
||||
(dframe-with-attached-buffer
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; eieio-speedbar.el -- Classes for managing speedbar displays.
|
||||
;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation,
|
||||
;; Inc.
|
||||
|
|
@ -200,7 +200,7 @@ that path."
|
|||
"Return a string describing OBJECT."
|
||||
(eieio-object-name-string object))
|
||||
|
||||
(defmethod eieio-speedbar-derive-line-path (object)
|
||||
(defmethod eieio-speedbar-derive-line-path (_object)
|
||||
"Return the path which OBJECT has something to do with."
|
||||
nil)
|
||||
|
||||
|
|
@ -321,7 +321,7 @@ Argument DEPTH is the depth at which the tag line is inserted."
|
|||
(if exp
|
||||
(eieio-speedbar-expand object (1+ depth))))))
|
||||
|
||||
(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) 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"
|
||||
(eieio-object-name object)))
|
||||
|
|
@ -340,7 +340,7 @@ OBJECT."
|
|||
|
||||
;;; Speedbar specific function callbacks.
|
||||
;;
|
||||
(defun eieio-speedbar-object-click (text token indent)
|
||||
(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))
|
||||
|
|
@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at."
|
|||
|
||||
;;; Methods to the eieio-speedbar-* classes which need to be overridden.
|
||||
;;
|
||||
(defmethod eieio-speedbar-object-children ((object eieio-speedbar))
|
||||
(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,
|
||||
|
|
|
|||
|
|
@ -53,17 +53,16 @@
|
|||
(message eieio-version))
|
||||
|
||||
(require 'eieio-core)
|
||||
(require 'eieio-generic)
|
||||
|
||||
|
||||
;;; Defining a new class
|
||||
;;
|
||||
(defmacro defclass (name superclass slots &rest options-and-doc)
|
||||
(defmacro defclass (name superclasses 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:
|
||||
SUPERCLASSES is a list of superclasses to inherit from, with SLOTS
|
||||
being the slots residing in that class definition. Supported tags are:
|
||||
|
||||
:initform - Initializing form.
|
||||
:initarg - Tag used during initialization.
|
||||
|
|
@ -114,12 +113,178 @@ Options in CLOS not supported in EIEIO:
|
|||
Due to the way class options are set up, you can add any tags you wish,
|
||||
and reference them using the function `class-option'."
|
||||
(declare (doc-string 4))
|
||||
;; This is eval-and-compile only to silence spurious compiler warnings
|
||||
;; about functions and variables not known to be defined.
|
||||
;; When eieio-defclass code is merged here and this becomes
|
||||
;; transparent to the compiler, the eval-and-compile can be removed.
|
||||
`(eval-and-compile
|
||||
(eieio-defclass ',name ',superclass ',slots ',options-and-doc)))
|
||||
(eieio--check-type listp superclasses)
|
||||
|
||||
(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'")))
|
||||
|
||||
(if (stringp (car options-and-doc))
|
||||
(setq options-and-doc
|
||||
(cons :documentation options-and-doc)))
|
||||
|
||||
;; Make sure the method invocation order is a valid value.
|
||||
(let ((io (eieio--class-option-assoc options-and-doc
|
||||
:method-invocation-order)))
|
||||
(when (and io (not (member io '(:depth-first :breadth-first :c3))))
|
||||
(error "Method invocation order %s is not allowed" io)))
|
||||
|
||||
(let ((testsym1 (intern (concat (symbol-name name) "-p")))
|
||||
(testsym2 (intern (format "eieio--childp--%s" name)))
|
||||
(accessors ()))
|
||||
|
||||
;; Collect the accessors we need to define.
|
||||
(pcase-dolist (`(,sname . ,soptions) slots)
|
||||
(let* ((acces (plist-get soptions :accessor))
|
||||
(initarg (plist-get soptions :initarg))
|
||||
(reader (plist-get soptions :reader))
|
||||
(writer (plist-get soptions :writer))
|
||||
(alloc (plist-get soptions :allocation))
|
||||
(label (plist-get soptions :label)))
|
||||
|
||||
(if eieio-error-unsupported-class-tags
|
||||
(let ((tmp soptions))
|
||||
(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))))))
|
||||
|
||||
;; Make sure the :allocation parameter has a valid value.
|
||||
(if (not (memq alloc '(nil :class :instance)))
|
||||
(signal 'invalid-slot-type (list :allocation alloc)))
|
||||
|
||||
;; 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"))
|
||||
|
||||
;; 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.
|
||||
(when acces
|
||||
;; FIXME: The defmethod below only defines a part of the generic
|
||||
;; function (good), but the define-setter below affects the whole
|
||||
;; generic function (bad)!
|
||||
(push `(gv-define-setter ,acces (store object)
|
||||
;; Apparently, eieio-oset-default doesn't work like
|
||||
;; oref-default and only accept class arguments!
|
||||
(list ',(if nil ;; (eq alloc :class)
|
||||
'eieio-oset-default
|
||||
'eieio-oset)
|
||||
object '',sname store))
|
||||
accessors)
|
||||
(push `(defmethod ,acces ,(if (eq alloc :class) :static :primary)
|
||||
((this ,name))
|
||||
,(format
|
||||
"Retrieve the slot `%S' from an object of class `%S'."
|
||||
sname name)
|
||||
(if (slot-boundp this ',sname)
|
||||
;; Use oref-default for :class allocated slots, since
|
||||
;; these also accept the use of a class argument instead
|
||||
;; of an object argument.
|
||||
(,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
|
||||
this ',sname)
|
||||
;; Else - Some error? nil?
|
||||
nil))
|
||||
accessors))
|
||||
|
||||
;; 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
|
||||
(push `(defmethod ,writer ((this ,name) value)
|
||||
,(format "Set the slot `%S' of an object of class `%S'."
|
||||
sname name)
|
||||
(setf (slot-value this ',sname) value))
|
||||
accessors))
|
||||
;; If a reader is defined, then create a generic method
|
||||
;; of that name whose purpose is to access this slot value.
|
||||
(if reader
|
||||
(push `(defmethod ,reader ((this ,name))
|
||||
,(format "Access the slot `%S' from object of class `%S'."
|
||||
sname name)
|
||||
(slot-value this ',sname))
|
||||
accessors))
|
||||
))
|
||||
|
||||
`(progn
|
||||
;; This test 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.
|
||||
(defun ,testsym1 (obj)
|
||||
,(format "Test OBJ to see if it an object of type %S." name)
|
||||
(and (eieio-object-p obj)
|
||||
(same-class-p obj ',name)))
|
||||
|
||||
(defun ,testsym2 (obj)
|
||||
,(format
|
||||
"Test OBJ to see if it an object is a child of type %S."
|
||||
name)
|
||||
(and (eieio-object-p obj)
|
||||
(object-of-class-p obj ',name)))
|
||||
|
||||
,@(when eieio-backward-compatibility
|
||||
(let ((f (intern (format "%s-child-p" name))))
|
||||
`((defalias ',f ',testsym2)
|
||||
(make-obsolete
|
||||
',f ,(format "use (cl-typep ... '%s) instead" name) "25.1"))))
|
||||
|
||||
;; 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.
|
||||
|
||||
(put ',name 'cl-deftype-satisfies #',testsym2)
|
||||
|
||||
(eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc)
|
||||
|
||||
,@accessors
|
||||
|
||||
;; Create the constructor function
|
||||
,(if (eieio--class-option-assoc options-and-doc :abstract)
|
||||
;; Abstract classes cannot be instantiated. Say so.
|
||||
(let ((abs (eieio--class-option-assoc options-and-doc :abstract)))
|
||||
(if (not (stringp abs))
|
||||
(setq abs (format "Class %s is abstract" name)))
|
||||
`(defun ,name (&rest _)
|
||||
,(format "You cannot create a new object of type %S." name)
|
||||
(error ,abs)))
|
||||
|
||||
;; Non-abstract classes need a constructor.
|
||||
`(defun ,name (&rest slots)
|
||||
,(format "Create a new object with name NAME of class type %S."
|
||||
name)
|
||||
(if (and slots
|
||||
(let ((x (car slots)))
|
||||
(or (stringp x) (null x))))
|
||||
(funcall (if eieio-backward-compatibility #'ignore #'message)
|
||||
"Obsolete name %S passed to %S constructor"
|
||||
(pop slots) ',name))
|
||||
(apply #'eieio-constructor ',name slots))))))
|
||||
|
||||
|
||||
;;; CLOS style implementation of object creators.
|
||||
|
|
@ -144,75 +309,16 @@ 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)))
|
||||
(apply (class-constructor class) initargs))
|
||||
|
||||
|
||||
;;; CLOS methods and generics
|
||||
;;
|
||||
(defmacro defgeneric (method _args &optional doc-string)
|
||||
"Create a generic function METHOD.
|
||||
DOC-STRING is the base documentation for this class. A generic
|
||||
function has no body, as its purpose is to decide which method body
|
||||
is appropriate to use. Uses `defmethod' to create methods, and calls
|
||||
`defgeneric' for you. With this implementation the ARGS are
|
||||
currently ignored. You can use `defgeneric' to apply specialized
|
||||
top level documentation to a method."
|
||||
(declare (doc-string 3))
|
||||
`(eieio--defalias ',method
|
||||
(eieio--defgeneric-init-form ',method ,doc-string)))
|
||||
|
||||
(defmacro defmethod (method &rest args)
|
||||
"Create a new METHOD through `defgeneric' with ARGS.
|
||||
|
||||
The optional second 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)"
|
||||
(declare (doc-string 3))
|
||||
(let* ((key (if (keywordp (car args)) (pop args)))
|
||||
(params (car args))
|
||||
(arg1 (car params))
|
||||
(fargs (if (consp arg1)
|
||||
(cons (car arg1) (cdr params))
|
||||
params))
|
||||
(class (if (consp arg1) (nth 1 arg1)))
|
||||
(code `(lambda ,fargs ,@(cdr args))))
|
||||
`(progn
|
||||
;; Make sure there is a generic and the byte-compiler sees it.
|
||||
(defgeneric ,method ,args
|
||||
,(or (documentation code)
|
||||
(format "Generically created method `%s'." method)))
|
||||
(eieio--defmethod ',method ',key ',class #',code))))
|
||||
|
||||
;;; 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."
|
||||
(declare (debug (form symbolp)))
|
||||
`(eieio-oref ,obj (quote ,slot)))
|
||||
|
||||
(defalias 'slot-value 'eieio-oref)
|
||||
|
|
@ -223,6 +329,7 @@ created by the :initarg tag."
|
|||
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."
|
||||
(declare (debug (form symbolp)))
|
||||
`(eieio-oref-default ,obj (quote ,slot)))
|
||||
|
||||
;;; Handy CLOS macros
|
||||
|
|
@ -246,7 +353,7 @@ SPEC-LIST is of a form similar to `let'. For example:
|
|||
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."
|
||||
(declare (indent 2))
|
||||
(declare (indent 2) (debug (sexp sexp def-body)))
|
||||
(require 'cl-lib)
|
||||
;; Transform the spec-list into a cl-symbol-macrolet spec-list.
|
||||
(let ((mappings (mapcar (lambda (entry)
|
||||
|
|
@ -261,33 +368,43 @@ variable name of the same name as the slot."
|
|||
;; well embedded into an object.
|
||||
;;
|
||||
(define-obsolete-function-alias
|
||||
'object-class-fast #'eieio--object-class "24.4")
|
||||
'object-class-fast #'eieio--object-class-name "24.4")
|
||||
|
||||
(defun eieio-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."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(format "#<%s %s%s>" (symbol-name (eieio--object-class obj))
|
||||
(eieio--object-name obj) (or extra "")))
|
||||
(format "#<%s %s%s>" (eieio--object-class-name obj)
|
||||
(eieio-object-name-string obj) (or extra "")))
|
||||
(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
|
||||
|
||||
(defun eieio-object-name-string (obj) "Return a string which is OBJ's name."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio--object-name obj))
|
||||
(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key))
|
||||
|
||||
;; In the past, every EIEIO object had a `name' field, so we had the two method
|
||||
;; below "for free". Since this field is very rarely used, we got rid of it
|
||||
;; and instead we keep it in a weak hash-tables, for those very rare objects
|
||||
;; that use it.
|
||||
(defmethod eieio-object-name-string (obj)
|
||||
"Return a string which is OBJ's name."
|
||||
(declare (obsolete eieio-named "25.1"))
|
||||
(or (gethash obj eieio--object-names)
|
||||
(symbol-name (eieio-object-class obj))))
|
||||
(define-obsolete-function-alias
|
||||
'object-name-string #'eieio-object-name-string "24.4")
|
||||
|
||||
(defun eieio-object-set-name-string (obj name)
|
||||
(defmethod eieio-object-set-name-string (obj name)
|
||||
"Set the string which is OBJ's NAME."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(declare (obsolete eieio-named "25.1"))
|
||||
(eieio--check-type stringp name)
|
||||
(setf (eieio--object-name obj) name))
|
||||
(setf (gethash obj eieio--object-names) name))
|
||||
(define-obsolete-function-alias
|
||||
'object-set-name-string 'eieio-object-set-name-string "24.4")
|
||||
|
||||
(defun eieio-object-class (obj) "Return the class struct defining OBJ."
|
||||
(defun eieio-object-class (obj)
|
||||
"Return the class struct defining OBJ."
|
||||
;; FIXME: We say we return a "struct" but we return a symbol instead!
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio--object-class obj))
|
||||
(eieio--object-class-name obj))
|
||||
(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4")
|
||||
;; CLOS name, maybe?
|
||||
(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4")
|
||||
|
|
@ -295,7 +412,7 @@ If EXTRA, include that in the string returned to represent the symbol."
|
|||
(defun eieio-object-class-name (obj)
|
||||
"Return a Lisp like symbol name for OBJ's class."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio-class-name (eieio--object-class obj)))
|
||||
(eieio-class-name (eieio--object-class-name obj)))
|
||||
(define-obsolete-function-alias
|
||||
'object-class-name 'eieio-object-class-name "24.4")
|
||||
|
||||
|
|
@ -303,15 +420,16 @@ If EXTRA, include that in the string returned to represent the symbol."
|
|||
"Return parent classes to CLASS. (overload of variable).
|
||||
|
||||
The CLOS function `class-direct-superclasses' is aliased to this function."
|
||||
(eieio--check-type class-p class)
|
||||
(eieio-class-parents-fast class))
|
||||
(let ((c (eieio-class-object class)))
|
||||
(eieio--class-parent c)))
|
||||
|
||||
(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
|
||||
|
||||
(defun eieio-class-children (class)
|
||||
"Return child classes to CLASS.
|
||||
The CLOS function `class-direct-subclasses' is aliased to this function."
|
||||
(eieio--check-type class-p class)
|
||||
(eieio-class-children-fast class))
|
||||
(eieio--class-children (eieio--class-v class)))
|
||||
(define-obsolete-function-alias
|
||||
'class-children #'eieio-class-children "24.4")
|
||||
|
||||
|
|
@ -326,38 +444,44 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
|
|||
`(car (eieio-class-parents ,class)))
|
||||
(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4")
|
||||
|
||||
(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS."
|
||||
(eieio--check-type class-p class)
|
||||
(defun same-class-p (obj class)
|
||||
"Return t if OBJ is of class-type CLASS."
|
||||
(setq class (eieio--class-object class))
|
||||
(eieio--check-type eieio--class-p class)
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(same-class-fast-p obj class))
|
||||
(eq (eieio--object-class-object obj) class))
|
||||
|
||||
(defun object-of-class-p (obj class)
|
||||
"Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
;; class will be checked one layer down
|
||||
(child-of-class-p (eieio--object-class obj) class))
|
||||
(child-of-class-p (eieio--object-class-object obj) class))
|
||||
;; Backwards compatibility
|
||||
(defalias 'obj-of-class-p 'object-of-class-p)
|
||||
|
||||
(defun child-of-class-p (child class)
|
||||
"Return non-nil if CHILD class is a subclass of CLASS."
|
||||
(eieio--check-type class-p class)
|
||||
(eieio--check-type class-p child)
|
||||
(let ((p nil))
|
||||
(while (and child (not (eq child class)))
|
||||
(setq p (append p (eieio--class-parent (class-v child)))
|
||||
child (car p)
|
||||
p (cdr p)))
|
||||
(if child t)))
|
||||
(setq child (eieio--class-object child))
|
||||
(eieio--check-type eieio--class-p child)
|
||||
;; `eieio-default-superclass' is never mentioned in eieio--class-parent,
|
||||
;; so we have to special case it here.
|
||||
(or (eq class 'eieio-default-superclass)
|
||||
(let ((p nil))
|
||||
(setq class (eieio--class-object class))
|
||||
(eieio--check-type eieio--class-p class)
|
||||
(while (and child (not (eq child class)))
|
||||
(setq p (append p (eieio--class-parent child))
|
||||
child (pop p)))
|
||||
(if child t))))
|
||||
|
||||
(defun object-slots (obj)
|
||||
"Return list of slots available in OBJ."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio--class-public-a (class-v (eieio--object-class obj))))
|
||||
(eieio--class-public-a (eieio--object-class-object obj)))
|
||||
|
||||
(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
|
||||
(eieio--check-type class-p class)
|
||||
(let ((ia (eieio--class-initarg-tuples (class-v class)))
|
||||
(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
|
||||
(eieio--check-type eieio--class-p class)
|
||||
(let ((ia (eieio--class-initarg-tuples class))
|
||||
(f nil))
|
||||
(while (and ia (not f))
|
||||
(if (eq (cdr (car ia)) slot)
|
||||
|
|
@ -371,6 +495,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
|
|||
"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."
|
||||
(declare (debug (form symbolp form)))
|
||||
`(eieio-oset ,obj (quote ,slot) ,value))
|
||||
|
||||
(defmacro oset-default (class slot value)
|
||||
|
|
@ -378,6 +503,7 @@ with in the :initarg slot. VALUE can be any Lisp object."
|
|||
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."
|
||||
(declare (debug (form symbolp form)))
|
||||
`(eieio-oset-default ,class (quote ,slot) ,value))
|
||||
|
||||
;;; CLOS queries into classes and slots
|
||||
|
|
@ -402,11 +528,9 @@ OBJECT can be an instance or a class."
|
|||
|
||||
(defun slot-exists-p (object-or-class slot)
|
||||
"Return non-nil if OBJECT-OR-CLASS has SLOT."
|
||||
(let ((cv (class-v (cond ((eieio-object-p object-or-class)
|
||||
(eieio-object-class object-or-class))
|
||||
((class-p object-or-class)
|
||||
object-or-class))
|
||||
)))
|
||||
(let ((cv (cond ((eieio-object-p object-or-class)
|
||||
(eieio--object-class-object object-or-class))
|
||||
(t (eieio-class-object object-or-class)))))
|
||||
(or (memq slot (eieio--class-public-a cv))
|
||||
(memq slot (eieio--class-class-allocation-a cv)))
|
||||
))
|
||||
|
|
@ -418,7 +542,7 @@ 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)))
|
||||
(eieio--class-v symbol)))
|
||||
|
||||
;;; Slightly more complex utility functions for objects
|
||||
;;
|
||||
|
|
@ -496,44 +620,6 @@ If SLOT is unbound, do nothing."
|
|||
nil
|
||||
(eieio-oset object slot (delete item (eieio-oref object slot)))))
|
||||
|
||||
;;;
|
||||
;; Method Calling Functions
|
||||
|
||||
(defun next-method-p ()
|
||||
"Return 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 (eieio--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))
|
||||
(eieio-generic-call-arglst newargs)
|
||||
(fcn (car next))
|
||||
)
|
||||
(eieio--with-scoped-class (cdr next)
|
||||
(apply fcn newargs)) ))))
|
||||
|
||||
;;; Here are some CLOS items that need the CL package
|
||||
;;
|
||||
|
||||
|
|
@ -556,22 +642,23 @@ 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)
|
||||
|
||||
(setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass))
|
||||
|
||||
(defalias 'standard-class 'eieio-default-superclass)
|
||||
|
||||
(defgeneric constructor (class newname &rest slots)
|
||||
(defgeneric eieio-constructor (class &rest slots)
|
||||
"Default constructor for CLASS `eieio-default-superclass'.")
|
||||
|
||||
(defmethod constructor :static
|
||||
((class eieio-default-superclass) newname &rest slots)
|
||||
(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1")
|
||||
|
||||
(defmethod eieio-constructor :static
|
||||
((class eieio-default-superclass) &rest slots)
|
||||
"Default constructor for CLASS `eieio-default-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 (eieio--class-default-object-cache (class-v class)))))
|
||||
;; Update the name for the newly created object.
|
||||
(setf (eieio--object-name new-object) newname)
|
||||
(let* ((new-object (copy-sequence (eieio--class-default-object-cache (eieio--class-v class)))))
|
||||
;; Call the initialize method on the new object with the slots
|
||||
;; that were passed down to us.
|
||||
(initialize-instance new-object slots)
|
||||
|
|
@ -585,10 +672,10 @@ 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."
|
||||
(eieio--with-scoped-class (eieio--object-class obj)
|
||||
(eieio--with-scoped-class (eieio--object-class-object obj)
|
||||
(while slots
|
||||
(let ((rn (eieio-initarg-to-attribute (eieio--object-class obj)
|
||||
(car slots))))
|
||||
(let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj)
|
||||
(car slots))))
|
||||
(if (not rn)
|
||||
(slot-missing obj (car slots) 'oset (car (cdr slots)))
|
||||
(eieio-oset obj rn (car (cdr slots)))))
|
||||
|
|
@ -609,7 +696,7 @@ 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* ((this-class (class-v (eieio--object-class this)))
|
||||
(let* ((this-class (eieio--object-class-object this))
|
||||
(slot (eieio--class-public-a this-class))
|
||||
(defaults (eieio--class-public-d this-class)))
|
||||
(while slot
|
||||
|
|
@ -662,34 +749,6 @@ EIEIO can only dispatch on the first argument, so the first two are swapped."
|
|||
(signal 'unbound-slot (list (eieio-class-name class) (eieio-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 (eieio-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 its return value becomes the
|
||||
return value of `call-next-method'."
|
||||
(signal 'no-next-method (list (eieio-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'.
|
||||
|
|
@ -699,18 +758,11 @@ 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 (eieio--object-name obj))
|
||||
(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))))
|
||||
(setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
|
||||
(setf (eieio--object-name nobj) (car params)))
|
||||
(let ((nobj (copy-sequence obj)))
|
||||
(if (stringp (car params))
|
||||
(funcall (if eieio-backward-compatibility #'ignore #'message)
|
||||
"Obsolete name %S passed to clone" (pop params)))
|
||||
(if params (shared-initialize nobj params))
|
||||
nobj))
|
||||
|
||||
(defgeneric destructor (this &rest params)
|
||||
|
|
@ -764,7 +816,7 @@ this object."
|
|||
(princ comment)
|
||||
(princ "\n"))
|
||||
(let* ((cl (eieio-object-class this))
|
||||
(cv (class-v cl)))
|
||||
(cv (eieio--class-v cl)))
|
||||
;; Now output readable lisp to recreate this object
|
||||
;; It should look like this:
|
||||
;; (<constructor> <name> <slot> <slot> ... )
|
||||
|
|
@ -782,7 +834,7 @@ this object."
|
|||
(eieio-print-depth (1+ eieio-print-depth)))
|
||||
(while publa
|
||||
(when (slot-boundp this (car publa))
|
||||
(let ((i (class-slot-initarg cl (car publa)))
|
||||
(let ((i (eieio--class-slot-initarg cv (car publa)))
|
||||
(v (eieio-oref this (car publa)))
|
||||
)
|
||||
(unless (or (not i) (equal v (car publd)))
|
||||
|
|
@ -848,7 +900,6 @@ of `eq'."
|
|||
(error "EIEIO: `change-class' is unimplemented"))
|
||||
|
||||
;; Hook ourselves into help system for describing classes and methods.
|
||||
(add-hook 'help-fns-describe-function-functions 'eieio-help-generic)
|
||||
(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor)
|
||||
|
||||
;;; Interfacing with edebug
|
||||
|
|
@ -859,43 +910,23 @@ of `eq'."
|
|||
Used as advice around `edebug-prin1-to-string', held in the
|
||||
variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
|
||||
`prin1-to-string' when appropriate."
|
||||
(cond ((class-p object) (eieio-class-name object))
|
||||
(cond ((eieio--class-p object) (eieio-class-name object))
|
||||
((eieio-object-p object) (object-print object))
|
||||
((and (listp object) (or (class-p (car object))
|
||||
((and (listp object) (or (eieio--class-p (car object))
|
||||
(eieio-object-p (car object))))
|
||||
(concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ")
|
||||
(concat "(" (mapconcat
|
||||
(lambda (x) (eieio-edebug-prin1-to-string print-function x))
|
||||
object " ")
|
||||
")"))
|
||||
(t (funcall print-function 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))
|
||||
(advice-add 'edebug-prin1-to-string
|
||||
:around #'eieio-edebug-prin1-to-string)))
|
||||
(advice-add 'edebug-prin1-to-string
|
||||
:around #'eieio-edebug-prin1-to-string)
|
||||
|
||||
|
||||
;;; Start of automatically extracted autoloads.
|
||||
|
||||
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "62709d76ae43f4fe70ed922391f9c64d")
|
||||
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "9a908efef1720439feb6323c1dd01770")
|
||||
;;; Generated autoloads from eieio-custom.el
|
||||
|
||||
(autoload 'customize-object "eieio-custom" "\
|
||||
|
|
@ -906,7 +937,7 @@ Optional argument GROUP is the sub-group of slots to display.
|
|||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "76058d02377b677eed3d15c28fc7ab21")
|
||||
;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "e922bf7ebc7dcb272480c4ba148da1ac")
|
||||
;;; Generated autoloads from eieio-opt.el
|
||||
|
||||
(autoload 'eieio-browse "eieio-opt" "\
|
||||
|
|
@ -927,11 +958,6 @@ Describe CTR if it is a class constructor.
|
|||
|
||||
\(fn CTR)" nil nil)
|
||||
|
||||
(autoload 'eieio-help-generic "eieio-opt" "\
|
||||
Describe GENERIC if it is a generic function.
|
||||
|
||||
\(fn GENERIC)" nil nil)
|
||||
|
||||
;;;***
|
||||
|
||||
;;; End of automatically extracted autoloads.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue