[Emacs-diffs] /srv/bzr/emacs/trunk r109132: * lisp/emacs-lisp/eieio.el: Adapt further to gv.el.

[Stefan Monnier]

------------------------------------------------------------
revno: 109132
fixes bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=11970
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Wed 2012-07-18 03:20:04 -0400
message:
  * lisp/emacs-lisp/eieio.el: Adapt further to gv.el.
  (eieio-defclass): Use gv-define-setter when possible.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/eieio.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2012-07-18 05:44:36 +0000
+++ b/lisp/ChangeLog    2012-07-18 07:20:04 +0000
@@ -1,3 +1,8 @@
+2012-07-18  Stefan Monnier  <address@hidden>
+
+       * emacs-lisp/eieio.el: Adapt further to gv.el (bug#11970).
+       (eieio-defclass): Use gv-define-setter when possible.
+
 2012-07-18  Dmitry Antipov  <address@hidden>
 
        Reflect recent changes in Fgarbage_collect.

=== modified file 'lisp/emacs-lisp/eieio.el'
--- a/lisp/emacs-lisp/eieio.el  2012-07-13 07:06:09 +0000
+++ b/lisp/emacs-lisp/eieio.el  2012-07-18 07:20:04 +0000
@@ -44,8 +44,7 @@
 
 ;;; Code:
 
-(eval-when-compile
-  (require 'cl))
+(eval-when-compile (require 'cl))       ;FIXME: Use cl-lib!
 
 (defvar eieio-version "1.3"
   "Current version of EIEIO.")
@@ -431,10 +430,10 @@
   (run-hooks 'eieio-hook)
   (setq eieio-hook nil)
 
-  (if (not (symbolp cname)) (signal 'wrong-type-argument '(symbolp cname)))
-  (if (not (listp superclasses)) (signal 'wrong-type-argument '(listp 
superclasses)))
+  (if (not (listp superclasses))
+      (signal 'wrong-type-argument '(listp superclasses)))
 
-  (let* ((pname (if superclasses superclasses nil))
+  (let* ((pname superclasses)
         (newc (make-vector class-num-slots nil))
         (oldc (when (class-p cname) (class-v cname)))
         (groups nil) ;; list of groups id'd from slots
@@ -553,8 +552,8 @@
       (put cname 'cl-deftype-handler
           (list 'lambda () `(list 'satisfies (quote ,csym)))))
 
-    ;; before adding new slots, let's add all the methods and classes
-    ;; in from the parent class
+    ;; Before adding new slots, let's add all the methods and classes
+    ;; in from the parent class.
     (eieio-copy-parents-into-subclass newc superclasses)
 
     ;; Store the new class vector definition into the symbol.  We need to
@@ -652,9 +651,9 @@
        ;; We need to id the group, and store them in a group list attribute.
        (mapc (lambda (cg) (add-to-list 'groups cg)) customg)
 
-       ;; anyone can have an accessor function.  This creates a function
+       ;; 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
+       ;; so that users can `setf' the space returned by this function.
        (if acces
            (progn
              (eieio--defmethod
@@ -668,18 +667,26 @@
                            ;; Else - Some error?  nil?
                            nil)))
 
-             ;; 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--)))))))
+              (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--))))))))
 
        ;; If a writer is defined, then create a generic method of that
        ;; name whose purpose is to set the value of the slot.
@@ -702,7 +709,8 @@
        )
       (setq slots (cdr slots)))
 
-    ;; Now that everything has been loaded up, all our lists are backwards!  
Fix that up now.
+    ;; Now that everything has been loaded up, all our lists are backwards!
+    ;; Fix that up now.
     (aset newc class-public-a (nreverse (aref newc class-public-a)))
     (aset newc class-public-d (nreverse (aref newc class-public-d)))
     (aset newc class-public-doc (nreverse (aref newc class-public-doc)))
@@ -2544,11 +2552,14 @@
 ;;
 
 (defsetf eieio-oref eieio-oset)
-;; FIXME: Not needed for Emacs>=24.2 since setf follows function aliases.
+
+(if (eval-when-compile (fboundp 'gv-define-expander))
+    ;; Not needed for Emacs>=24.2 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 <address@hidden>
-;; FIXME: Not needed for Emacs>=24.2 since setf expands macros.
 (define-setf-method oref (obj slot)
   (with-no-warnings
     (require 'cl)
@@ -2560,7 +2571,7 @@
            (list store-temp)
            (list 'set-slot-value obj-temp slot-temp
                  store-temp)
-           (list 'slot-value obj-temp slot-temp)))))
+           (list 'slot-value obj-temp slot-temp))))))
 
 
 ;;;