Update copyright year to 2016

[gnu-emacs] / lisp / emacs-lisp / eieio-base.el

diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index a1c2cb54a9e7c0a66a25beed68d3cd26a7b0c743..b99905cf1982722354f86a224ed11c7454df12b7 100644 (file)
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -1,6 +1,6 @@
 ;;; eieio-base.el --- Base classes for EIEIO.  -*- lexical-binding:t -*-
 
 ;;; 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-2016 Free Software

 ;;; Foundation, Inc.
 
 ;; Author: Eric M. Ludlam  <zappo@gnu.org>
 ;;; Foundation, Inc.
 
 ;; Author: Eric M. Ludlam  <zappo@gnu.org>


@@ -40,7 +40,7 @@
 ;; error if a slot is unbound.
 (defclass eieio-instance-inheritor ()
   ((parent-instance :initarg :parent-instance
 ;; 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
                    :documentation
                    "The parent of this instance.
 If a slot of this class is referenced, and is unbound, then the parent


@@ -52,7 +52,7 @@ a parent instance.  When a slot in the child is referenced, and has
 not been set, use values from the parent."
   :abstract t)
 
 not been set, use values from the parent."
   :abstract t)
 

-(defmethod slot-unbound ((object eieio-instance-inheritor)
+(cl-defmethod slot-unbound ((object eieio-instance-inheritor)

                          _class slot-name _fn)
   "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
 SLOT-NAME is the offending slot.  FN is the function signaling the error."
                          _class slot-name _fn)
   "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
 SLOT-NAME is the offending slot.  FN is the function signaling the error."


@@ -61,31 +61,16 @@ SLOT-NAME is the offending slot.  FN is the function signaling the error."
       ;; method if the parent instance's slot is unbound.
       (eieio-oref (oref object parent-instance) slot-name)
     ;; Throw the regular signal.
       ;; method if the parent instance's slot is unbound.
       (eieio-oref (oref object parent-instance) slot-name)
     ;; Throw the regular signal.

-    (call-next-method)))
+    (cl-call-next-method)))

 
 

-(defmethod clone ((obj eieio-instance-inheritor) &rest params)
+(cl-defmethod clone ((obj eieio-instance-inheritor) &rest _params)

   "Clone OBJ, initializing `:parent' to OBJ.
 All slots are unbound, except those initialized with 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 (cl-call-next-method)))

     (oset nobj parent-instance obj)
     nobj))
 
     (oset nobj parent-instance obj)
     nobj))
 

-(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
+(cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)

                                                slot)
   "Return non-nil if the instance inheritor OBJECT's SLOT is bound.
 See `slot-boundp' for details on binding slots.
                                                slot)
   "Return non-nil if the instance inheritor OBJECT's SLOT is bound.
 See `slot-boundp' for details on binding slots.


@@ -118,7 +103,7 @@ Inheritors from this class must overload `tracking-symbol' which is
 a variable symbol used to store a list of all instances."
   :abstract t)
 
 a variable symbol used to store a list of all instances."
   :abstract t)
 

-(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
+(cl-defmethod initialize-instance :after ((this eieio-instance-tracker)

                                       &rest _slots)
   "Make sure THIS is in our master list of this class.
 Optional argument SLOTS are the initialization arguments."
                                       &rest _slots)
   "Make sure THIS is in our master list of this class.
 Optional argument SLOTS are the initialization arguments."


@@ -127,7 +112,7 @@ Optional argument SLOTS are the initialization arguments."
     (if (not (memq this (symbol-value sym)))
        (set sym (append (symbol-value sym) (list this))))))
 
     (if (not (memq this (symbol-value sym)))
        (set sym (append (symbol-value sym) (list this))))))
 

-(defmethod delete-instance ((this eieio-instance-tracker))
+(cl-defmethod delete-instance ((this eieio-instance-tracker))

   "Remove THIS from the master list of this class."
   (set (oref this tracking-symbol)
        (delq this (symbol-value (oref this tracking-symbol)))))
   "Remove THIS from the master list of this class."
   (set (oref this tracking-symbol)
        (delq this (symbol-value (oref this tracking-symbol)))))


@@ -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)
 
 A singleton is a class which will only ever have one instance."
   :abstract t)
 

-(defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots)
+(cl-defmethod make-instance ((class (subclass 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,
   "Constructor for singleton CLASS.
 NAME and SLOTS initialize the new object.
 This constructor guarantees that no matter how many you request,


@@ -164,7 +149,7 @@ only one object ever exists."
   ;; with class allocated slots or default values.
   (let ((old (oref-default class singleton)))
     (if (eq old eieio-unbound)
   ;; with class allocated slots or default values.
   (let ((old (oref-default class singleton)))
     (if (eq old eieio-unbound)

-       (oset-default class singleton (call-next-method))
+       (oset-default class singleton (cl-call-next-method))

       old)))
 
 \f
       old)))
 
 \f


@@ -213,7 +198,7 @@ object.  For this reason, only slots which do not have an `:initarg'
 specified will not be saved."
   :abstract t)
 
 specified will not be saved."
   :abstract t)
 

-(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
+(cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt

                                              &optional name)
   "Prepare to save THIS.  Use in an `interactive' statement.
 Query user for file name with PROMPT if THIS does not yet specify
                                              &optional name)
   "Prepare to save THIS.  Use in an `interactive' statement.
 Query user for file name with PROMPT if THIS does not yet specify


@@ -234,7 +219,7 @@ for CLASS.  Optional ALLOW-SUBCLASS says that it is ok for
 being pedantic."
   (unless class
     (message "Unsafe call to `eieio-persistent-read'."))
 being pedantic."
   (unless class
     (message "Unsafe call to `eieio-persistent-read'."))

-  (when class (eieio--check-type class-p class))
+  (when class (cl-check-type class class))

   (let ((ret nil)
        (buffstr nil))
     (unwind-protect
   (let ((ret nil)
        (buffstr nil))
     (unwind-protect


@@ -269,31 +254,34 @@ malicious code.
 
 Note: This function recurses when a slot of :type of some object is
 identified, and needing more object creation."
 
 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))
-       (slots (nthcdr 2 inputlist))
-       (createslots nil))
-
-    ;; If OBJCLASS is an eieio autoload object, then we need to load it.
-    (eieio-class-un-autoload objclass)
+  (let* ((objclass (nth 0 inputlist))
+        ;; (objname (nth 1 inputlist))
+        (slots (nthcdr 2 inputlist))
+        (createslots nil)
+        (class
+         (progn
+           ;; If OBJCLASS is an eieio autoload object, then we need to
+           ;; load it.
+           (eieio-class-un-autoload objclass)
+           (eieio--class-object objclass))))

 
     (while slots
 
     (while slots

-      (let ((name (car slots))
+      (let ((initarg (car slots))

            (value (car (cdr slots))))
 
        ;; Make sure that the value proposed for SLOT is valid.
        ;; In addition, strip out quotes, list functions, and update
        ;; object constructors as needed.
        (setq value (eieio-persistent-validate/fix-slot-value
            (value (car (cdr slots))))
 
        ;; Make sure that the value proposed for SLOT is valid.
        ;; In addition, strip out quotes, list functions, and update
        ;; object constructors as needed.
        (setq value (eieio-persistent-validate/fix-slot-value

-                    objclass name value))
+                    class (eieio--initarg-to-attribute class initarg) value))

 
 

-       (push name createslots)
+       (push initarg createslots)

        (push value createslots)
        )
 
       (setq slots (cdr (cdr slots))))
 
        (push value createslots)
        )
 
       (setq slots (cdr (cdr slots))))
 

-    (apply 'make-instance objclass objname (nreverse createslots))
+    (apply #'make-instance objclass (nreverse createslots))

 
     ;;(eval inputlist)
     ))
 
     ;;(eval inputlist)
     ))


@@ -305,15 +293,12 @@ 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.
 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))
-              (type nil)
-              (classtype nil))
-          (setq slot-idx (- slot-idx 3))
-          (setq type (aref (eieio--class-public-type (class-v class))
-                           slot-idx))
-
-          (setq classtype (eieio-persistent-slot-type-is-class-p
-                           type))
+        (let* ((slot-idx (- (eieio--slot-name-index class slot)
+                             (eval-when-compile
+                               (length (cl-struct-slot-info 'eieio--object)))))
+                (type (cl--slot-descriptor-type (aref (eieio--class-slots class)
+                                                      slot-idx)))
+                (classtype (eieio-persistent-slot-type-is-class-p type)))

 
           (cond ((eq (car proposed-value) 'quote)
                  (car (cdr proposed-value)))
 
           (cond ((eq (car proposed-value) 'quote)
                  (car (cdr proposed-value)))


@@ -346,8 +331,8 @@ Second, any text properties will be stripped from strings."
                  (unless (and
                           ;; Do we have a type?
                           (consp classtype) (class-p (car classtype)))
                  (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))
 
                  ;; We have a predicate, but it doesn't satisfy the predicate?
                  (dolist (PV (cdr proposed-value))


@@ -375,31 +360,49 @@ Second, any text properties will be stripped from strings."
   )
 
 (defun eieio-persistent-slot-type-is-class-p (type)
   )
 
 (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)
 If no class is referenced there, then return nil."
   (cond ((class-p type)
         ;; If the type is a class, then return it.
         type)

-
-       ((and (symbolp type) (string-match "-child$" (symbol-name 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) (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)))))
              (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))))
         ;; 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)))))
              (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))
 
         ;; 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))
         ;; If type is a list, and is an or, it is possibly something
         ;; like (or null myclass), so check for that.
         (let ((ans nil))


@@ -412,85 +415,89 @@ If no class is referenced there, then return nil."
         ;; No match, not a class.
         nil)))
 
         ;; No match, not a class.
         nil)))
 

-(defmethod object-write ((this eieio-persistent) &optional comment)
+(cl-defmethod object-write ((this eieio-persistent) &optional comment)

   "Write persistent object THIS out to the current stream.
 Optional argument COMMENT is a header line comment."
   "Write persistent object THIS out to the current stream.
 Optional argument COMMENT is a header line comment."

-  (call-next-method this (or comment (oref this file-header-line))))
+  (cl-call-next-method this (or comment (oref this file-header-line))))

 
 

-(defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
+(cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file)

   "For object THIS, make absolute file name FILE relative."
   (file-relative-name (expand-file-name file)
                      (file-name-directory (oref this file))))
 
   "For object THIS, make absolute file name FILE relative."
   (file-relative-name (expand-file-name file)
                      (file-name-directory (oref this file))))
 

-(defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
+(cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file)

   "Save persistent object THIS to disk.
 Optional argument FILE overrides the file name specified in the object
 instance."
   "Save persistent object THIS to disk.
 Optional argument FILE overrides the file name specified in the object
 instance."

-  (save-excursion
-    (let ((b (set-buffer (get-buffer-create " *tmp object write*")))
-         (default-directory (file-name-directory (oref this file)))
-         (cfn (oref this file)))
-      (unwind-protect
-         (save-excursion
-           (erase-buffer)
-           (let ((standard-output (current-buffer)))
-             (oset this file
-                   (if file
-                       (eieio-persistent-path-relative this file)
-                     (file-name-nondirectory cfn)))
-             (object-write this (oref this file-header-line)))
-           (let ((backup-inhibited (not (oref this do-backups)))
-                 (cs (car (find-coding-systems-region
-                           (point-min) (point-max)))))
-             (unless (eq cs 'undecided)
-               (setq buffer-file-coding-system cs))
-             ;; Old way - write file.  Leaves message behind.
-             ;;(write-file cfn nil)
-
-             ;; New way - Avoid the vast quantities of error checking
-             ;; just so I can get at the special flags that disable
-             ;; displaying random messages.
-             (write-region (point-min) (point-max)
-                           cfn nil 1)
-             ))
-       ;; Restore :file, and kill the tmp buffer
-       (oset this file cfn)
-       (setq buffer-file-name nil)
-       (kill-buffer b)))))
+  (when file (setq file (expand-file-name file)))
+  (with-temp-buffer
+    (let* ((cfn (or file (oref this file)))
+           (default-directory (file-name-directory cfn)))
+      (cl-letf ((standard-output (current-buffer))
+                ((oref this file)       ;FIXME: Why change it?
+                 (if file
+                     ;; FIXME: Makes a name relative to (oref this file),
+                     ;; whereas I think it should be relative to cfn.
+                     (eieio-persistent-path-relative this file)
+                   (file-name-nondirectory cfn))))
+        (object-write this (oref this file-header-line)))
+      (let ((backup-inhibited (not (oref this do-backups)))
+            (coding-system-for-write 'utf-8-emacs))
+        ;; Old way - write file.  Leaves message behind.
+        ;;(write-file cfn nil)
+
+        ;; New way - Avoid the vast quantities of error checking
+        ;; just so I can get at the special flags that disable
+        ;; displaying random messages.
+        (write-region (point-min) (point-max) cfn nil 1)
+        ))))

 
 ;; Notes on the persistent object:
 ;; It should also set up some hooks to help it keep itself up to date.
 
 \f
 ;;; Named object
 
 ;; Notes on the persistent object:
 ;; It should also set up some hooks to help it keep itself up to date.
 
 \f
 ;;; Named object

-;;
-;; Named objects use the objects `name' as a slot, and that slot
-;; is accessed with the `object-name' symbol.

 
 (defclass eieio-named ()
 
 (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)
 
   :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)))
+(cl-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))))
+
+(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
+  "Set the string which is OBJ's NAME."
+  (cl-check-type name string)
+  (eieio-oset obj 'object-name name))
+
+(cl-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 #'cl-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))
+
+(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args)
+  (if (not (stringp (car args)))
+      (cl-call-next-method)
+    (funcall (if eieio-backward-compatibility #'ignore #'message)
+             "Obsolete: name passed without :object-name to %S constructor"
+             class)
+    (apply #'cl-call-next-method class :object-name args)))
+

 
 (provide 'eieio-base)
 
 
 (provide 'eieio-base)