-;;; eieio-core.el --- Core implementation for eieio
+;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*-
-;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.4
;;; Code:
-(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib!
-
-;; Compatibility
-(if (fboundp 'compiled-function-arglist)
-
- ;; XEmacs can only access a compiled functions arglist like this:
- (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist)
-
- ;; Emacs doesn't have this function, but since FUNC is a vector, we can just
- ;; grab the appropriate element.
- (defun eieio-compiled-function-arglist (func)
- "Return the argument list for the compiled function FUNC."
- (aref func 0))
-
- )
+(require 'cl-lib)
(put 'eieio--defalias 'byte-hunk-handler
#'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
(defmacro eieio--with-scoped-class (class &rest forms)
"Set CLASS as the currently scoped class while executing FORMS."
+ (declare (indent 1))
`(unwind-protect
(progn
(push ,class eieio--scoped-class-stack)
,@forms)
(pop eieio--scoped-class-stack)))
-(put 'eieio--with-scoped-class 'lisp-indent-function 1)
;;;
;; Field Accessors
;; No check: If eieio gets this far, it has probably been checked already.
`(get ,class 'eieio-class-definition))
-(defmacro class-p (class)
- "Return t if CLASS is a valid class vector.
+(defsubst class-p (class)
+ "Return non-nil if CLASS is a valid class vector.
CLASS is a symbol."
;; this new method is faster since it doesn't waste time checking lots of
;; things.
- `(condition-case nil
- (eq (aref (class-v ,class) 0) 'defclass)
- (error nil)))
+ (condition-case nil
+ (eq (aref (class-v class) 0) 'defclass)
+ (error nil)))
(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS."
(eieio--check-type class-p class)
"Return the symbol representing the constructor of CLASS."
`(eieio--class-symbol (class-v ,class)))
-(defmacro generic-p (method)
- "Return t if symbol METHOD is a generic function.
+(defsubst generic-p (method)
+ "Return non-nil if symbol METHOD is a generic function.
Only methods have the symbol `eieio-method-obarray' as a property
\(which contains a list of all bindings to that method type.)"
- `(and (fboundp ,method) (get ,method 'eieio-method-obarray)))
+ (and (fboundp method) (get method 'eieio-method-obarray)))
(defun generic-primary-only-p (method)
"Return t if symbol METHOD is a generic function with only primary methods.
Return nil if that option doesn't exist."
`(class-option-assoc (eieio--class-options (class-v ,class)) ',option))
-(defmacro eieio-object-p (obj)
+(defsubst eieio-object-p (obj)
"Return non-nil if OBJ is an EIEIO object."
- `(condition-case nil
- (let ((tobj ,obj))
- (and (eq (aref tobj 0) 'object)
- (class-p (eieio--object-class tobj))))
- (error nil)))
+ (condition-case nil
+ (and (eq (aref obj 0) 'object)
+ (class-p (eieio--object-class obj)))
+ (error nil)))
(defalias 'object-p 'eieio-object-p)
-(defmacro class-abstract-p (class)
+(defsubst class-abstract-p (class)
"Return non-nil if CLASS is abstract.
Abstract classes cannot be instantiated."
- `(class-option ,class :abstract))
+ (class-option class :abstract))
(defmacro class-method-invocation-order (class)
"Return the invocation order of CLASS.
(when (eq (car-safe (symbol-function cname)) 'autoload)
(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)
;; FIXME: Most of this should be moved to the `defclass' macro.
"Define CNAME as a new subclass of SUPERCLASSES.
(setf (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.
- (mapc (lambda (g) (pushnew g groups :test #'equal))
+ (mapc (lambda (g) (cl-pushnew g groups :test #'equal))
(class-option (car pname) :custom-groups))
;; save parent in child
(setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc))))
;; test, so we can let typep have the CLOS documented behavior
;; while keeping our above predicate clean.
- ;; It would be cleaner to use `defsetf' here, but that requires cl
- ;; at runtime.
+ ;; FIXME: It would be cleaner to use `cl-deftype' here.
(put cname 'cl-deftype-handler
(list 'lambda () `(list 'satisfies (quote ,csym)))))
prot initarg alloc 'defaultoverride skip-nil)
;; 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
;; of the specified name, and also performs a `defsetf' if applicable
;; Else - Some error? nil?
nil)))
- (if (fboundp 'gv-define-setter)
- ;; FIXME: We should move more of eieio-defclass into the
- ;; defclass macro so we don't have to use `eval' and require
- ;; `gv' at run-time.
- (eval `(gv-define-setter ,acces (eieio--store eieio--object)
- (list 'eieio-oset eieio--object '',name
- eieio--store)))
- ;; Provide a setf method. It would be cleaner to use
- ;; defsetf, but that would require CL at runtime.
- (put acces 'setf-method
- `(lambda (widget)
- (let* ((--widget-sym-- (make-symbol "--widget--"))
- (--store-sym-- (make-symbol "--store--")))
- (list
- (list --widget-sym--)
- (list widget)
- (list --store-sym--)
- (list 'eieio-oset --widget-sym-- '',name
- --store-sym--)
- (list 'getfoo --widget-sym--))))))))
+ ;; FIXME: We should move more of eieio-defclass into the
+ ;; defclass macro so we don't have to use `eval' and require
+ ;; `gv' at run-time.
+ (eval `(gv-define-setter ,acces (eieio--store eieio--object)
+ (list 'eieio-oset eieio--object '',name
+ eieio--store)))))
;; If a writer is defined, then create a generic method of that
;; name whose purpose is to set the value of the slot.
(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-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-label newc) (nreverse (eieio--class-public-custom-label newc)))
(setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc)))
;; The storage for class-class-allocation-type needs to be turned into
;; a vector now.
(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.
(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
;; this slot as the variable slot in this new symbol. We need to
(fset cname
`(lambda (newname &rest slots)
,(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.
;; We have a list of custom groups. Store them into the options.
(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)
(setcar (cdr (memq :custom-groups options)) g)
(setq options (cons :custom-groups (cons g options)))))
))
))
-(defun eieio-copy-parents-into-subclass (newc parents)
+(defun eieio-copy-parents-into-subclass (newc _parents)
"Copy into NEWC the slots of PARENTS.
Follow the rules of not overwriting early parents when applying to
the new child class."
(let ((doc-string (documentation method)))
(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
class
impl
',class)))
;; 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)
;; It is ok, do the call.
;; 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
;; `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)
"Return non-nil if SPEC does not match VALUE."
(or (eq spec t) ; t 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)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
;; applicable.
(eieio-c3-merge-lists
(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))
;; The graph is inconsistent, give up
(signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
method invocation orders of the involved classes."
(if (or (null class) (eq class 'eieio-default-superclass))
nil
- (case (class-method-invocation-order class)
+ (cl-case (class-method-invocation-order class)
(:depth-first
(eieio-class-precedence-dfs class))
(:breadth-first
;; Now loop through all occurrences forms which we must execute
;; (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
(if (car lambdas)
(eieio--with-scoped-class (cdr (car lambdas))
;;(setq rval (apply (car (car lambdas)) newargs))
(setq lastval (apply (car (car lambdas)) newargs))
(when has-return-val
- (setq rval lastval
- rvalever t))
+ (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)
- rvalever t)
+ (setq rval (apply #'no-applicable-method (car args) method args))
(signal
'no-method-definition
(list method args))))
- ;; Right Here... it could be that lastval is returned when
- ;; rvalever is nil. Is that right?
rval)))
(defun eieio-generic-call-primary-only (method args)
;; 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) (rvalever nil)
+ (let* ((rval nil) (lastval nil)
(eieio-generic-call-key method-primary)
;; Use the cdr, as the first element is the fcn
;; we are calling right now.
;; No methods found for this impl...
(if (eieio-object-p (car args))
- (setq rval (apply 'no-applicable-method (car args) method args)
- rvalever t)
+ (setq rval (apply #'no-applicable-method
+ (car args) method args))
(signal
'no-method-definition
(list method args)))
lambdas)
(setq lastval (apply (car lambdas) newargs))
- (setq rval lastval
- rvalever t)
- )
+ (setq rval lastval))
- ;; Right Here... it could be that lastval is returned when
- ;; rvalever is nil. Is that right?
rval))))
(defun eieiomt-method-list (method key class)
(when (string-match "\\.elc$" fname)
(setq fname (substring fname 0 (1- (length fname)))))
(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)))
;; Now optimize the entire obarray
(if (< key method-num-lists)
;; we replace the nil from above.
(let ((external-symbol (intern-soft (symbol-name s))))
(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)
eieiomt-optimizing-obarray)))
(when (fboundp ov)
\f
;;; Here are some special types of errors
;;
-(intern "no-method-definition")
-(put 'no-method-definition 'error-conditions '(no-method-definition error))
-(put 'no-method-definition 'error-message "No method definition")
-
-(intern "no-next-method")
-(put 'no-next-method 'error-conditions '(no-next-method error))
-(put 'no-next-method 'error-message "No next method")
-
-(intern "invalid-slot-name")
-(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error))
-(put 'invalid-slot-name 'error-message "Invalid slot name")
-
-(intern "invalid-slot-type")
-(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil))
-(put 'invalid-slot-type 'error-message "Invalid slot type")
-
-(intern "unbound-slot")
-(put 'unbound-slot 'error-conditions '(unbound-slot error nil))
-(put 'unbound-slot 'error-message "Unbound slot")
-
-(intern "inconsistent-class-hierarchy")
-(put 'inconsistent-class-hierarchy 'error-conditions
- '(inconsistent-class-hierarchy error nil))
-(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy")
+(define-error 'no-method-definition "No method definition")
+(define-error 'no-next-method "No next method")
+(define-error 'invalid-slot-name "Invalid slot name")
+(define-error 'invalid-slot-type "Invalid slot type")
+(define-error 'unbound-slot "Unbound slot")
+(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")
;;; Obsolete backward compatibility functions.
;; Needed to run byte-code compiled with the EIEIO of Emacs-23.