* lisp/emacs-lisp/eieio-base.el: Use lexical-binding and cl-lib.

* lisp/emacs-lisp/eieio-core.el: Use lexical-binding and cl-lib.
(list-of): New type.
(eieio--typep): Remove.
(eieio-perform-slot-validation): Use cl-typep instead.
* lisp/emacs-lisp/eieio.el: Use lexical-binding drop non-GV fallback.
(defclass, defgeneric, defmethod): Add doc-string position.
(with-slots): Require cl-lib.
* lisp/emacs-lisp/cl-macs.el (cl--make-type-test): Avoid ((lambda ..) ..).
This commit is contained in:
Stefan Monnier 2014-10-17 01:09:24 -04:00
parent 60727a5494
commit 942501730f
5 changed files with 96 additions and 126 deletions

View file

@ -1,10 +1,25 @@
2014-10-17 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el: Use lexical-binding drop non-GV fallback.
(defclass, defgeneric, defmethod): Add doc-string position.
(with-slots): Require cl-lib.
* emacs-lisp/eieio-core.el: Use lexical-binding and cl-lib.
(list-of): New type.
(eieio--typep): Remove.
(eieio-perform-slot-validation): Use cl-typep instead.
* emacs-lisp/eieio-base.el: Use lexical-binding and cl-lib.
* emacs-lisp/cl-macs.el (cl--make-type-test): Avoid ((lambda ..) ..).
2014-10-16 Alan Mackenzie <acm@muc.de> 2014-10-16 Alan Mackenzie <acm@muc.de>
Trigger showing when point is in the "periphery" of a line or just Trigger showing when point is in the "periphery" of a line or just
inside a paren. inside a paren.
* paren.el (show-paren-style, show-paren-delay) * paren.el (show-paren-style, show-paren-delay)
(show-paren-priority, show-paren-ring-bell-on-mismatch): Remove (show-paren-priority, show-paren-ring-bell-on-mismatch):
superfluous :group specifications. Remove superfluous :group specifications.
(show-paren-when-point-inside-paren) (show-paren-when-point-inside-paren)
(show-paren-when-point-in-periphery): New customizable variables. (show-paren-when-point-in-periphery): New customizable variables.
(show-paren-highlight-openparen): Make into a defcustom. (show-paren-highlight-openparen): Make into a defcustom.
@ -532,7 +547,7 @@
* term.el (term-mouse-paste): * term.el (term-mouse-paste):
* mouse.el (mouse-yank-primary): Use gui-get-primary-selection. * mouse.el (mouse-yank-primary): Use gui-get-primary-selection.
2014-10-02 H. Dieter Wilhelm <dieter@duenenhof-wilhelm.de> (tiny change) 2014-10-02 H. Dieter Wilhelm <dieter@duenenhof-wilhelm.de>
* calc/calc-help.el (calc-describe-thing): Quote strings * calc/calc-help.el (calc-describe-thing): Quote strings
which could look like regexps. which could look like regexps.

View file

@ -822,7 +822,8 @@ For more details, see Info node `(cl)Loop Facility'.
"repeat" "while" "until" "always" "never" "repeat" "while" "until" "always" "never"
"thereis" "collect" "append" "nconc" "sum" "thereis" "collect" "append" "nconc" "sum"
"count" "maximize" "minimize" "if" "unless" "count" "maximize" "minimize" "if" "unless"
"return"] form] "return"]
form]
;; Simple default, which covers 99% of the cases. ;; Simple default, which covers 99% of the cases.
symbolp form))) symbolp form)))
(if (not (memq t (mapcar #'symbolp (if (not (memq t (mapcar #'symbolp
@ -1136,7 +1137,8 @@ For more details, see Info node `(cl)Loop Facility'.
(if end (if end
(push (list (push (list
(if down (if excl '> '>=) (if excl '< '<=)) (if down (if excl '> '>=) (if excl '< '<=))
var (or end-var end)) cl--loop-body)) var (or end-var end))
cl--loop-body))
(push (list var (list (if down '- '+) var (push (list var (list (if down '- '+) var
(or step-var step 1))) (or step-var step 1)))
loop-for-steps))) loop-for-steps)))
@ -1194,7 +1196,8 @@ For more details, see Info node `(cl)Loop Facility'.
(push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings)
(push `(< (setq ,temp-idx (1+ ,temp-idx)) (push `(< (setq ,temp-idx (1+ ,temp-idx))
(length ,temp-vec)) cl--loop-body) (length ,temp-vec))
cl--loop-body)
(if (eq word 'across-ref) (if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx)) (push (list var `(aref ,temp-vec ,temp-idx))
cl--loop-symbol-macs) cl--loop-symbol-macs)
@ -1370,7 +1373,8 @@ For more details, see Info node `(cl)Loop Facility'.
(if loop-for-sets (if loop-for-sets
(push `(progn (push `(progn
,(cl--loop-let (nreverse loop-for-sets) 'setq ands) ,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
t) cl--loop-body)) t)
cl--loop-body))
(if loop-for-steps (if loop-for-steps
(push (cons (if ands 'cl-psetq 'setq) (push (cons (if ands 'cl-psetq 'setq)
(apply 'append (nreverse loop-for-steps))) (apply 'append (nreverse loop-for-steps)))
@ -1388,7 +1392,8 @@ For more details, see Info node `(cl)Loop Facility'.
(push `(progn (push ,what ,var) t) cl--loop-body) (push `(progn (push ,what ,var) t) cl--loop-body)
(push `(progn (push `(progn
(setq ,var (nconc ,var (list ,what))) (setq ,var (nconc ,var (list ,what)))
t) cl--loop-body)))) t)
cl--loop-body))))
((memq word '(nconc nconcing append appending)) ((memq word '(nconc nconcing append appending))
(let ((what (pop cl--loop-args)) (let ((what (pop cl--loop-args))
@ -1403,7 +1408,9 @@ For more details, see Info node `(cl)Loop Facility'.
,var) ,var)
`(,(if (memq word '(nconc nconcing)) `(,(if (memq word '(nconc nconcing))
#'nconc #'append) #'nconc #'append)
,var ,what))) t) cl--loop-body))) ,var ,what)))
t)
cl--loop-body)))
((memq word '(concat concating)) ((memq word '(concat concating))
(let ((what (pop cl--loop-args)) (let ((what (pop cl--loop-args))
@ -1434,7 +1441,8 @@ For more details, see Info node `(cl)Loop Facility'.
(set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) (set `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
(push `(progn ,(if (eq temp what) set (push `(progn ,(if (eq temp what) set
`(let ((,temp ,what)) ,set)) `(let ((,temp ,what)) ,set))
t) cl--loop-body))) t)
cl--loop-body)))
((eq word 'with) ((eq word 'with)
(let ((bindings nil)) (let ((bindings nil))
@ -1505,7 +1513,8 @@ For more details, see Info node `(cl)Loop Facility'.
(or cl--loop-result-var (or cl--loop-result-var
(setq cl--loop-result-var (make-symbol "--cl-var--"))) (setq cl--loop-result-var (make-symbol "--cl-var--")))
(push `(setq ,cl--loop-result-var ,(pop cl--loop-args) (push `(setq ,cl--loop-result-var ,(pop cl--loop-args)
,cl--loop-finish-flag nil) cl--loop-body)) ,cl--loop-finish-flag nil)
cl--loop-body))
(t (t
;; This is an advertised interface: (info "(cl)Other Clauses"). ;; This is an advertised interface: (info "(cl)Other Clauses").
@ -2398,7 +2407,8 @@ non-nil value, that slot cannot be set via `setf'.
pred-form pred-check) pred-form pred-check)
(if (stringp (car descs)) (if (stringp (car descs))
(push `(put ',name 'structure-documentation (push `(put ',name 'structure-documentation
,(pop descs)) forms)) ,(pop descs))
forms))
(setq descs (cons '(cl-tag-slot) (setq descs (cons '(cl-tag-slot)
(mapcar (function (lambda (x) (if (consp x) x (list x)))) (mapcar (function (lambda (x) (if (consp x) x (list x))))
descs))) descs)))
@ -2551,7 +2561,8 @@ non-nil value, that slot cannot be set via `setf'.
(progn (push `(cl-defsubst ,predicate (cl-x) (progn (push `(cl-defsubst ,predicate (cl-x)
,(if (eq (car pred-form) 'and) ,(if (eq (car pred-form) 'and)
(append pred-form '(t)) (append pred-form '(t))
`(and ,pred-form t))) forms) `(and ,pred-form t)))
forms)
(push (cons predicate 'error-free) side-eff))) (push (cons predicate 'error-free) side-eff)))
(and copier (and copier
(progn (push `(defun ,copier (x) (copy-sequence x)) forms) (progn (push `(defun ,copier (x) (copy-sequence x)) forms)
@ -2568,7 +2579,8 @@ non-nil value, that slot cannot be set via `setf'.
slots defaults))) slots defaults)))
(push `(cl-defsubst ,name (push `(cl-defsubst ,name
(&cl-defs '(nil ,@descs) ,@args) (&cl-defs '(nil ,@descs) ,@args)
(,type ,@make)) forms) (,type ,@make))
forms)
(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
(push (cons name t) side-eff)))) (push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
@ -2673,7 +2685,7 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(cdr type)))) (cdr type))))
((memq (car type) '(member cl-member)) ((memq (car type) '(member cl-member))
`(and (cl-member ,val ',(cdr type)) t)) `(and (cl-member ,val ',(cdr type)) t))
((eq (car type) 'satisfies) (list (cadr type) val)) ((eq (car type) 'satisfies) `(funcall #',(cadr type) ,val))
(t (error "Bad type spec: %s" type))))) (t (error "Bad type spec: %s" type)))))
(defvar cl--object) (defvar cl--object)

View file

@ -1,4 +1,4 @@
;;; eieio-base.el --- Base classes for EIEIO. ;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*-
;;; Copyright (C) 2000-2002, 2004-2005, 2007-2014 Free Software ;;; Copyright (C) 2000-2002, 2004-2005, 2007-2014 Free Software
;;; Foundation, Inc. ;;; Foundation, Inc.
@ -31,7 +31,7 @@
;;; Code: ;;; Code:
(require 'eieio) (require 'eieio)
(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! (eval-when-compile (require 'cl-lib))
;;; eieio-instance-inheritor ;;; eieio-instance-inheritor
;; ;;
@ -52,7 +52,8 @@ a parent instance. When a slot in the child is referenced, and has
not been set, use values from the parent." not been set, use values from the parent."
:abstract t) :abstract t)
(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn) (defmethod slot-unbound ((object eieio-instance-inheritor)
_class slot-name _fn)
"If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
SLOT-NAME is the offending slot. FN is the function signaling the error." SLOT-NAME is the offending slot. FN is the function signaling the error."
(if (slot-boundp object 'parent-instance) (if (slot-boundp object 'parent-instance)
@ -118,7 +119,7 @@ a variable symbol used to store a list of all instances."
:abstract t) :abstract t)
(defmethod initialize-instance :AFTER ((this eieio-instance-tracker) (defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
&rest slots) &rest _slots)
"Make sure THIS is in our master list of this class. "Make sure THIS is in our master list of this class.
Optional argument SLOTS are the initialization arguments." Optional argument SLOTS are the initialization arguments."
;; Theoretically, this is never called twice for a given instance. ;; Theoretically, this is never called twice for a given instance.
@ -154,7 +155,7 @@ Multiple calls to `make-instance' will return this object."))
A singleton is a class which will only ever have one instance." A singleton is a class which will only ever have one instance."
:abstract t) :abstract t)
(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots) (defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots)
"Constructor for singleton CLASS. "Constructor for singleton CLASS.
NAME and SLOTS initialize the new object. NAME and SLOTS initialize the new object.
This constructor guarantees that no matter how many you request, This constructor guarantees that no matter how many you request,

View file

@ -1,4 +1,4 @@
;;; eieio-core.el --- Core implementation for eieio ;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*-
;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. ;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc.
@ -31,7 +31,7 @@
;;; Code: ;;; Code:
(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! (require 'cl-lib)
;; Compatibility ;; Compatibility
(if (fboundp 'compiled-function-arglist) (if (fboundp 'compiled-function-arglist)
@ -408,6 +408,12 @@ It creates an autoload function for CNAME's constructor."
(when (eq (car-safe (symbol-function cname)) 'autoload) (when (eq (car-safe (symbol-function cname)) 'autoload)
(load-library (car (cdr (symbol-function cname)))))) (load-library (car (cdr (symbol-function cname))))))
(cl-deftype list-of (elem-type)
`(and list
(satisfies (lambda (list)
(cl-every (lambda (elem) (cl-typep elem ',elem-type))
list)))))
(defun eieio-defclass (cname superclasses slots options-and-doc) (defun eieio-defclass (cname superclasses slots options-and-doc)
;; FIXME: Most of this should be moved to the `defclass' macro. ;; FIXME: Most of this should be moved to the `defclass' macro.
"Define CNAME as a new subclass of SUPERCLASSES. "Define CNAME as a new subclass of SUPERCLASSES.
@ -476,7 +482,7 @@ See `defclass' for more information."
(setf (eieio--class-children (class-v (car pname))) (setf (eieio--class-children (class-v (car pname)))
(cons cname (eieio--class-children (class-v (car pname)))))) (cons cname (eieio--class-children (class-v (car pname))))))
;; Get custom groups, and store them into our local copy. ;; Get custom groups, and store them into our local copy.
(mapc (lambda (g) (pushnew g groups :test #'equal)) (mapc (lambda (g) (cl-pushnew g groups :test #'equal))
(class-option (car pname) :custom-groups)) (class-option (car pname) :custom-groups))
;; save parent in child ;; save parent in child
(setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc))))
@ -553,8 +559,7 @@ See `defclass' for more information."
;; test, so we can let typep have the CLOS documented behavior ;; test, so we can let typep have the CLOS documented behavior
;; while keeping our above predicate clean. ;; while keeping our above predicate clean.
;; It would be cleaner to use `defsetf' here, but that requires cl ;; FIXME: It would be cleaner to use `cl-deftype' here.
;; at runtime.
(put cname 'cl-deftype-handler (put cname 'cl-deftype-handler
(list 'lambda () `(list 'satisfies (quote ,csym))))) (list 'lambda () `(list 'satisfies (quote ,csym)))))
@ -655,7 +660,7 @@ See `defclass' for more information."
prot initarg alloc 'defaultoverride skip-nil) prot initarg alloc 'defaultoverride skip-nil)
;; We need to id the group, and store them in a group list attribute. ;; We need to id the group, and store them in a group list attribute.
(mapc (lambda (cg) (pushnew cg groups :test 'equal)) customg) (mapc (lambda (cg) (cl-pushnew cg groups :test 'equal)) customg)
;; Anyone can have an accessor function. This creates a function ;; Anyone can have an accessor function. This creates a function
;; of the specified name, and also performs a `defsetf' if applicable ;; of the specified name, and also performs a `defsetf' if applicable
@ -721,7 +726,7 @@ See `defclass' for more information."
(setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc)))
(setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc)))
(setf (eieio--class-public-type newc) (setf (eieio--class-public-type newc)
(apply 'vector (nreverse (eieio--class-public-type newc)))) (apply #'vector (nreverse (eieio--class-public-type newc))))
(setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc)))
(setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc)))
(setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc)))
@ -732,11 +737,11 @@ See `defclass' for more information."
;; The storage for class-class-allocation-type needs to be turned into ;; The storage for class-class-allocation-type needs to be turned into
;; a vector now. ;; a vector now.
(setf (eieio--class-class-allocation-type newc) (setf (eieio--class-class-allocation-type newc)
(apply 'vector (eieio--class-class-allocation-type newc))) (apply #'vector (eieio--class-class-allocation-type newc)))
;; Also, take class allocated values, and vectorize them for speed. ;; Also, take class allocated values, and vectorize them for speed.
(setf (eieio--class-class-allocation-values newc) (setf (eieio--class-class-allocation-values newc)
(apply 'vector (eieio--class-class-allocation-values newc))) (apply #'vector (eieio--class-class-allocation-values newc)))
;; Attach slot symbols into an obarray, and store the index of ;; Attach slot symbols into an obarray, and store the index of
;; this slot as the variable slot in this new symbol. We need to ;; this slot as the variable slot in this new symbol. We need to
@ -779,7 +784,7 @@ See `defclass' for more information."
(fset cname (fset cname
`(lambda (newname &rest slots) `(lambda (newname &rest slots)
,(format "Create a new object with name NAME of class type %s" cname) ,(format "Create a new object with name NAME of class type %s" cname)
(apply 'constructor ,cname newname slots))) (apply #'constructor ,cname newname slots)))
) )
;; Set up a specialized doc string. ;; Set up a specialized doc string.
@ -798,7 +803,7 @@ See `defclass' for more information."
;; We have a list of custom groups. Store them into the options. ;; We have a list of custom groups. Store them into the options.
(let ((g (class-option-assoc options :custom-groups))) (let ((g (class-option-assoc options :custom-groups)))
(mapc (lambda (cg) (pushnew cg g :test 'equal)) groups) (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups)
(if (memq :custom-groups options) (if (memq :custom-groups options)
(setcar (cdr (memq :custom-groups options)) g) (setcar (cdr (memq :custom-groups options)) g)
(setq options (cons :custom-groups (cons g options))))) (setq options (cons :custom-groups (cons g options)))))
@ -1065,7 +1070,7 @@ if default value is nil."
)) ))
)) ))
(defun eieio-copy-parents-into-subclass (newc parents) (defun eieio-copy-parents-into-subclass (newc _parents)
"Copy into NEWC the slots of PARENTS. "Copy into NEWC the slots of PARENTS.
Follow the rules of not overwriting early parents when applying to Follow the rules of not overwriting early parents when applying to
the new child class." the new child class."
@ -1178,6 +1183,8 @@ DOC-STRING is the documentation attached to METHOD."
(let ((doc-string (documentation method))) (let ((doc-string (documentation method)))
(fset method (eieio-defgeneric-form-primary-only method doc-string)))) (fset method (eieio-defgeneric-form-primary-only method doc-string))))
(declare-function no-applicable-method "eieio" (object method &rest args))
(defun eieio-defgeneric-form-primary-only-one (method doc-string (defun eieio-defgeneric-form-primary-only-one (method doc-string
class class
impl impl
@ -1212,7 +1219,7 @@ IMPL is the symbol holding the method implementation."
',class))) ',class)))
;; If not the right kind of object, call no applicable ;; If not the right kind of object, call no applicable
(apply 'no-applicable-method (car local-args) (apply #'no-applicable-method (car local-args)
',method local-args) ',method local-args)
;; It is ok, do the call. ;; It is ok, do the call.
@ -1299,53 +1306,12 @@ but remove reference to all implementations of METHOD."
;; This is a hideous hack for replacing `typep' from cl-macs, to avoid ;; This is a hideous hack for replacing `typep' from cl-macs, to avoid
;; requiring the CL library at run-time. It can be eliminated if/when ;; requiring the CL library at run-time. It can be eliminated if/when
;; `typep' is merged into Emacs core. ;; `typep' is merged into Emacs core.
(defun eieio--typep (val type)
(if (symbolp type)
(cond ((get type 'cl-deftype-handler)
(eieio--typep val (funcall (get type 'cl-deftype-handler))))
((eq type t) t)
((eq type 'null) (null val))
((eq type 'atom) (atom val))
((eq type 'float) (and (numberp val) (not (integerp val))))
((eq type 'real) (numberp val))
((eq type 'fixnum) (integerp val))
((memq type '(character string-char)) (characterp val))
(t
(let* ((name (symbol-name type))
(namep (intern (concat name "p"))))
(if (fboundp namep)
(funcall `(lambda () (,namep val)))
(funcall `(lambda ()
(,(intern (concat name "-p")) val)))))))
(cond ((get (car type) 'cl-deftype-handler)
(eieio--typep val (apply (get (car type) 'cl-deftype-handler)
(cdr type))))
((memq (car type) '(integer float real number))
(and (eieio--typep val (car type))
(or (memq (cadr type) '(* nil))
(if (consp (cadr type))
(> val (car (cadr type)))
(>= val (cadr type))))
(or (memq (caddr type) '(* nil))
(if (consp (car (cddr type)))
(< val (caar (cddr type)))
(<= val (car (cddr type)))))))
((memq (car type) '(and or not))
(eval (cons (car type)
(mapcar (lambda (x)
`(eieio--typep (quote ,val) (quote ,x)))
(cdr type)))))
((memq (car type) '(member member*))
(memql val (cdr type)))
((eq (car type) 'satisfies)
(funcall `(lambda () (,(cadr type) val))))
(t (error "Bad type spec: %s" type)))))
(defun eieio-perform-slot-validation (spec value) (defun eieio-perform-slot-validation (spec value)
"Return non-nil if SPEC does not match VALUE." "Return non-nil if SPEC does not match VALUE."
(or (eq spec t) ; t always passes (or (eq spec t) ; t always passes
(eq value eieio-unbound) ; unbound always passes (eq value eieio-unbound) ; unbound always passes
(eieio--typep value spec))) (cl-typep value spec)))
(defun eieio-validate-slot-value (class slot-idx value slot) (defun eieio-validate-slot-value (class slot-idx value slot)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
@ -1632,7 +1598,7 @@ If a consistent order does not exist, signal an error."
;; applicable. ;; applicable.
(eieio-c3-merge-lists (eieio-c3-merge-lists
(cons next reversed-partial-result) (cons next reversed-partial-result)
(mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l))
remaining-inputs)) remaining-inputs))
;; The graph is inconsistent, give up ;; The graph is inconsistent, give up
(signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
@ -1700,7 +1666,7 @@ The order, in which the parents are returned depends on the
method invocation orders of the involved classes." method invocation orders of the involved classes."
(if (or (null class) (eq class 'eieio-default-superclass)) (if (or (null class) (eq class 'eieio-default-superclass))
nil nil
(case (class-method-invocation-order class) (cl-case (class-method-invocation-order class)
(:depth-first (:depth-first
(eieio-class-precedence-dfs class)) (eieio-class-precedence-dfs class))
(:breadth-first (:breadth-first
@ -1839,7 +1805,7 @@ This should only be called from a generic function."
;; Now loop through all occurrences forms which we must execute ;; Now loop through all occurrences forms which we must execute
;; (which are happily sorted now) and execute them all! ;; (which are happily sorted now) and execute them all!
(let ((rval nil) (lastval nil) (rvalever nil) (found nil)) (let ((rval nil) (lastval nil) (found nil))
(while lambdas (while lambdas
(if (car lambdas) (if (car lambdas)
(eieio--with-scoped-class (cdr (car lambdas)) (eieio--with-scoped-class (cdr (car lambdas))
@ -1856,20 +1822,16 @@ This should only be called from a generic function."
;;(setq rval (apply (car (car lambdas)) newargs)) ;;(setq rval (apply (car (car lambdas)) newargs))
(setq lastval (apply (car (car lambdas)) newargs)) (setq lastval (apply (car (car lambdas)) newargs))
(when has-return-val (when has-return-val
(setq rval lastval (setq rval lastval))
rvalever t))
))) )))
(setq lambdas (cdr lambdas) (setq lambdas (cdr lambdas)
keys (cdr keys))) keys (cdr keys)))
(if (not found) (if (not found)
(if (eieio-object-p (car args)) (if (eieio-object-p (car args))
(setq rval (apply 'no-applicable-method (car args) method args) (setq rval (apply #'no-applicable-method (car args) method args))
rvalever t)
(signal (signal
'no-method-definition 'no-method-definition
(list method args)))) (list method args))))
;; Right Here... it could be that lastval is returned when
;; rvalever is nil. Is that right?
rval))) rval)))
(defun eieio-generic-call-primary-only (method args) (defun eieio-generic-call-primary-only (method args)
@ -1920,7 +1882,7 @@ for this common case to improve performance."
;; Now loop through all occurrences forms which we must execute ;; Now loop through all occurrences forms which we must execute
;; (which are happily sorted now) and execute them all! ;; (which are happily sorted now) and execute them all!
(eieio--with-scoped-class (cdr lambdas) (eieio--with-scoped-class (cdr lambdas)
(let* ((rval nil) (lastval nil) (rvalever nil) (let* ((rval nil) (lastval nil)
(eieio-generic-call-key method-primary) (eieio-generic-call-key method-primary)
;; Use the cdr, as the first element is the fcn ;; Use the cdr, as the first element is the fcn
;; we are calling right now. ;; we are calling right now.
@ -1931,8 +1893,8 @@ for this common case to improve performance."
;; No methods found for this impl... ;; No methods found for this impl...
(if (eieio-object-p (car args)) (if (eieio-object-p (car args))
(setq rval (apply 'no-applicable-method (car args) method args) (setq rval (apply #'no-applicable-method
rvalever t) (car args) method args))
(signal (signal
'no-method-definition 'no-method-definition
(list method args))) (list method args)))
@ -1943,12 +1905,8 @@ for this common case to improve performance."
lambdas) lambdas)
(setq lastval (apply (car lambdas) newargs)) (setq lastval (apply (car lambdas) newargs))
(setq rval lastval (setq rval lastval))
rvalever t)
)
;; Right Here... it could be that lastval is returned when
;; rvalever is nil. Is that right?
rval)))) rval))))
(defun eieiomt-method-list (method key class) (defun eieiomt-method-list (method key class)
@ -2054,7 +2012,7 @@ CLASS is the class this method is associated with."
(when (string-match "\\.elc$" fname) (when (string-match "\\.elc$" fname)
(setq fname (substring fname 0 (1- (length fname))))) (setq fname (substring fname 0 (1- (length fname)))))
(setq loc (get method-name 'method-locations)) (setq loc (get method-name 'method-locations))
(pushnew (list class fname) loc :test 'equal) (cl-pushnew (list class fname) loc :test 'equal)
(put method-name 'method-locations loc))) (put method-name 'method-locations loc)))
;; Now optimize the entire obarray ;; Now optimize the entire obarray
(if (< key method-num-lists) (if (< key method-num-lists)
@ -2084,7 +2042,8 @@ nil for superclasses. This function performs no type checking!"
;; we replace the nil from above. ;; we replace the nil from above.
(let ((external-symbol (intern-soft (symbol-name s)))) (let ((external-symbol (intern-soft (symbol-name s))))
(catch 'done (catch 'done
(dolist (ancestor (rest (eieio-class-precedence-list external-symbol))) (dolist (ancestor
(cl-rest (eieio-class-precedence-list external-symbol)))
(let ((ov (intern-soft (symbol-name ancestor) (let ((ov (intern-soft (symbol-name ancestor)
eieiomt-optimizing-obarray))) eieiomt-optimizing-obarray)))
(when (fboundp ov) (when (fboundp ov)

View file

@ -1,4 +1,4 @@
;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*-
;;; or maybe Eric's Implementation of Emacs Interpreted Objects ;;; or maybe Eric's Implementation of Emacs Interpreted Objects
;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. ;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc.
@ -44,8 +44,6 @@
;;; Code: ;;; Code:
(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib!
(defvar eieio-version "1.4" (defvar eieio-version "1.4"
"Current version of EIEIO.") "Current version of EIEIO.")
@ -115,6 +113,7 @@ Options in CLOS not supported in EIEIO:
Due to the way class options are set up, you can add any tags you wish, Due to the way class options are set up, you can add any tags you wish,
and reference them using the function `class-option'." and reference them using the function `class-option'."
(declare (doc-string 4))
;; This is eval-and-compile only to silence spurious compiler warnings ;; This is eval-and-compile only to silence spurious compiler warnings
;; about functions and variables not known to be defined. ;; about functions and variables not known to be defined.
;; When eieio-defclass code is merged here and this becomes ;; When eieio-defclass code is merged here and this becomes
@ -155,7 +154,7 @@ a string."
;;; CLOS methods and generics ;;; CLOS methods and generics
;; ;;
(defmacro defgeneric (method args &optional doc-string) (defmacro defgeneric (method _args &optional doc-string)
"Create a generic function METHOD. "Create a generic function METHOD.
DOC-STRING is the base documentation for this class. A generic DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body function has no body, as its purpose is to decide which method body
@ -163,6 +162,7 @@ is appropriate to use. Uses `defmethod' to create methods, and calls
`defgeneric' for you. With this implementation the ARGS are `defgeneric' for you. With this implementation the ARGS are
currently ignored. You can use `defgeneric' to apply specialized currently ignored. You can use `defgeneric' to apply specialized
top level documentation to a method." top level documentation to a method."
(declare (doc-string 3))
`(eieio--defalias ',method `(eieio--defalias ',method
(eieio--defgeneric-init-form ',method ,doc-string))) (eieio--defgeneric-init-form ',method ,doc-string)))
@ -191,6 +191,7 @@ Summary:
((typearg class-name) arg2 &optional opt &rest rest) ((typearg class-name) arg2 &optional opt &rest rest)
\"doc-string\" \"doc-string\"
body)" body)"
(declare (doc-string 3))
(let* ((key (if (keywordp (car args)) (pop args))) (let* ((key (if (keywordp (car args)) (pop args)))
(params (car args)) (params (car args))
(arg1 (car params)) (arg1 (car params))
@ -246,6 +247,7 @@ Where each VAR is the local variable given to the associated
SLOT. A slot specified without a variable name is given a SLOT. A slot specified without a variable name is given a
variable name of the same name as the slot." variable name of the same name as the slot."
(declare (indent 2)) (declare (indent 2))
(require 'cl-lib)
;; Transform the spec-list into a cl-symbol-macrolet spec-list. ;; Transform the spec-list into a cl-symbol-macrolet spec-list.
(let ((mappings (mapcar (lambda (entry) (let ((mappings (mapcar (lambda (entry)
(let ((var (if (listp entry) (car entry) entry)) (let ((var (if (listp entry) (car entry) entry))
@ -523,7 +525,7 @@ Use `next-method-p' to find out if there is a next method to call."
(next (car eieio-generic-call-next-method-list)) (next (car eieio-generic-call-next-method-list))
) )
(if (or (not next) (not (car next))) (if (or (not next) (not (car next)))
(apply 'no-next-method (car newargs) (cdr newargs)) (apply #'no-next-method (car newargs) (cdr newargs))
(let* ((eieio-generic-call-next-method-list (let* ((eieio-generic-call-next-method-list
(cdr eieio-generic-call-next-method-list)) (cdr eieio-generic-call-next-method-list))
(eieio-generic-call-arglst newargs) (eieio-generic-call-arglst newargs)
@ -535,27 +537,7 @@ Use `next-method-p' to find out if there is a next method to call."
;;; Here are some CLOS items that need the CL package ;;; Here are some CLOS items that need the CL package
;; ;;
(defsetf eieio-oref eieio-oset) (gv-define-simple-setter eieio-oref eieio-oset)
(if (eval-when-compile (fboundp 'gv-define-expander))
;; Not needed for Emacs>=24.3 since gv.el's setf expands macros and
;; follows aliases.
nil
(defsetf slot-value eieio-oset)
;; The below setf method was written by Arnd Kohrs <kohrs@acm.org>
(define-setf-method oref (obj slot)
(with-no-warnings
(require 'cl)
(let ((obj-temp (gensym))
(slot-temp (gensym))
(store-temp (gensym)))
(list (list obj-temp slot-temp)
(list obj `(quote ,slot))
(list store-temp)
(list 'set-slot-value obj-temp slot-temp
store-temp)
(list 'slot-value obj-temp slot-temp))))))
;;; ;;;
@ -651,7 +633,7 @@ dynamically set from SLOTS."
"Method invoked when an attempt to access a slot in OBJECT fails.") "Method invoked when an attempt to access a slot in OBJECT fails.")
(defmethod slot-missing ((object eieio-default-superclass) slot-name (defmethod slot-missing ((object eieio-default-superclass) slot-name
operation &optional new-value) _operation &optional _new-value)
"Method invoked when an attempt to access a slot in OBJECT fails. "Method invoked when an attempt to access a slot in OBJECT fails.
SLOT-NAME is the name of the failed slot, OPERATION is the type of access SLOT-NAME is the name of the failed slot, OPERATION is the type of access
that was requested, and optional NEW-VALUE is the value that was desired that was requested, and optional NEW-VALUE is the value that was desired
@ -684,7 +666,7 @@ EIEIO can only dispatch on the first argument, so the first two are swapped."
"Called if there are no implementations for OBJECT in METHOD.") "Called if there are no implementations for OBJECT in METHOD.")
(defmethod no-applicable-method ((object eieio-default-superclass) (defmethod no-applicable-method ((object eieio-default-superclass)
method &rest args) method &rest _args)
"Called if there are no implementations for OBJECT in METHOD. "Called if there are no implementations for OBJECT in METHOD.
OBJECT is the object which has no method implementation. OBJECT is the object which has no method implementation.
ARGS are the arguments that were passed to METHOD. ARGS are the arguments that were passed to METHOD.
@ -734,7 +716,7 @@ first and modify the returned object.")
(defgeneric destructor (this &rest params) (defgeneric destructor (this &rest params)
"Destructor for cleaning up any dynamic links to our object.") "Destructor for cleaning up any dynamic links to our object.")
(defmethod destructor ((this eieio-default-superclass) &rest params) (defmethod destructor ((_this eieio-default-superclass) &rest _params)
"Destructor for cleaning up any dynamic links to our object. "Destructor for cleaning up any dynamic links to our object.
Argument THIS is the object being destroyed. PARAMS are additional Argument THIS is the object being destroyed. PARAMS are additional
ignored parameters." ignored parameters."
@ -760,7 +742,7 @@ Implement this function and specify STRINGS in a call to
`call-next-method' to provide additional summary information. `call-next-method' to provide additional summary information.
When passing in extra strings from child classes, always remember When passing in extra strings from child classes, always remember
to prepend a space." to prepend a space."
(eieio-object-name this (apply 'concat strings))) (eieio-object-name this (apply #'concat strings)))
(defvar eieio-print-depth 0 (defvar eieio-print-depth 0
"When printing, keep track of the current indentation depth.") "When printing, keep track of the current indentation depth.")
@ -859,7 +841,7 @@ this object."
;;; Unimplemented functions from CLOS ;;; Unimplemented functions from CLOS
;; ;;
(defun change-class (obj class) (defun change-class (_obj _class)
"Change the class of OBJ to type CLASS. "Change the class of OBJ to type CLASS.
This may create or delete slots, but does not affect the return value This may create or delete slots, but does not affect the return value
of `eq'." of `eq'."
@ -879,7 +861,8 @@ Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate."
((eieio-object-p object) (object-print object)) ((eieio-object-p object) (object-print object))
((and (listp object) (or (class-p (car object)) ((and (listp object) (or (class-p (car object))
(eieio-object-p (car object)))) (eieio-object-p (car object))))
(concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")")) (concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ")
")"))
(t (prin1-to-string object noescape)))) (t (prin1-to-string object noescape))))
(add-hook 'edebug-setup-hook (add-hook 'edebug-setup-hook