[Emacs-diffs] emacs/lisp ChangeLog emacs-lisp/eieio.el

[Chong Yidong]

CVSROOT:        /sources/emacs
Module name:    emacs
Changes by:     Chong Yidong <cyd>      09/10/11 02:19:31

Modified files:
        lisp           : ChangeLog 
        lisp/emacs-lisp: eieio.el 

Log message:
        * emacs-lisp/eieio.el: Avoid requiring cl at runtime.
        (eieio-defclass): Apply deftype handler and setf-method properties
        directly.
        (eieio-add-new-slot): Avoid union function from cl library.
        (eieio--typep): New function.
        (eieio-perform-slot-validation): Use it.

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/ChangeLog?cvsroot=emacs&r1=1.16402&r2=1.16403
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/emacs-lisp/eieio.el?cvsroot=emacs&r1=1.7&r2=1.8

Patches:
Index: ChangeLog
===================================================================
RCS file: /sources/emacs/emacs/lisp/ChangeLog,v
retrieving revision 1.16402
retrieving revision 1.16403
diff -u -b -r1.16402 -r1.16403
--- ChangeLog   10 Oct 2009 23:50:10 -0000      1.16402
+++ ChangeLog   11 Oct 2009 02:19:27 -0000      1.16403
@@ -1,3 +1,12 @@
+2009-10-11  Chong Yidong  <address@hidden>
+
+       * emacs-lisp/eieio.el: Avoid requiring cl at runtime.
+       (eieio-defclass): Apply deftype handler and setf-method properties
+       directly.
+       (eieio-add-new-slot): Avoid union function from cl library.
+       (eieio--typep): New function.
+       (eieio-perform-slot-validation): Use it.
+
 2009-10-10  Karl Fogel  <address@hidden>
 
        * bookmark.el: (bookmark-yank-word, bookmark-insert-current-bookmark):

Index: emacs-lisp/eieio.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/emacs-lisp/eieio.el,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -b -r1.7 -r1.8
--- emacs-lisp/eieio.el 5 Oct 2009 15:32:11 -0000       1.7
+++ emacs-lisp/eieio.el 11 Oct 2009 02:19:31 -0000      1.8
@@ -40,8 +40,9 @@
 
 ;;; Code:
 
-(require 'cl)
-(eval-when-compile (require 'eieio-comp))
+(eval-when-compile
+  (require 'cl)
+  (require 'eieio-comp))
 
 (defvar eieio-version "1.2"
   "Current version of EIEIO.")
@@ -538,11 +539,11 @@
       ;; "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.
-      (eval `(deftype ,cname ()
-              '(satisfies
-                ,(intern (concat (symbol-name cname) "-child-p")))))
 
-      )
+      ;; It would be cleaner to use `defsetf' here, but that requires cl
+      ;; at runtime.
+      (put cname 'cl-deftype-handler
+          (list 'lambda () `(list 'satisfies (quote ,csym)))))
 
     ;; before adding new slots, lets add all the methods and classes
     ;; in from the parent class
@@ -657,17 +658,21 @@
                      (list 'if (list 'slot-boundp 'this (list 'quote name))
                            (list 'eieio-oref 'this (list 'quote name))
                            ;; Else - Some error?  nil?
-                           nil
-                           )))
-             ;; Thanks Pascal Bourguignon <address@hidden>
-             ;; For this complex macro.
-             (eval (macroexpand
-                    (list  'defsetf acces '(widget) '(store)
-                           (list 'list ''eieio-oset 'widget
-                                 (list 'quote (list 'quote name)) 'store))))
-             ;;`(defsetf ,acces (widget) (store) (eieio-oset widget ',cname 
store))
-             )
-         )
+                           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 a writer is defined, then create a generic method of that
        ;; name whose purpose is to set the value of the slot.
        (if writer
@@ -895,15 +900,19 @@
                ;; End original PLN
 
                ;; PLN Tue Jun 26 11:57:06 2007 :
-               ;; We do a non redundant combination of ancient
-               ;; custom groups and new ones using the common lisp
-               ;; `union' method.
+               ;; Do a non redundant combination of ancient custom
+               ;; groups and new ones.
                (when custg
-                 (let ((where-groups
-                        (nthcdr num (aref newc class-public-custom-group))))
-                   (setcar where-groups
-                           (union (car where-groups)
-                                  (if (listp custg) custg (list custg))))))
+                 (let* ((groups
+                         (nthcdr num (aref newc class-public-custom-group)))
+                        (list1 (car groups))
+                        (list2 (if (listp custg) custg (list custg))))
+                   (if (< (length list1) (length list2))
+                       (setq list1 (prog1 list2 (setq list2 list1))))
+                   (dolist (elt list2)
+                     (unless (memq elt list1)
+                       (push elt list1)))
+                   (setcar groups list1)))
                ;;  End PLN
 
                ;;  PLN Mon Jun 25 22:44:34 2007 : If a new cust is
@@ -990,16 +999,19 @@
              (if (not (eq prot super-prot))
                  (error "Child slot protection `%s' does not match inherited 
protection `%s' for `%s'"
                         prot super-prot a)))
-           ;; We do a non redundant combination of ancient
-           ;; custom groups and new ones using the common lisp
-           ;; `union' method.
+           ;; Do a non redundant combination of ancient custom groups
+           ;; and new ones.
            (when custg
-             (let ((where-groups
-                    (nthcdr num (aref newc 
class-class-allocation-custom-group))))
-               (setcar where-groups
-                       (union (car where-groups)
-                              (if (listp custg) custg (list custg))))))
-           ;;  End PLN
+             (let* ((groups
+                     (nthcdr num (aref newc 
class-class-allocation-custom-group)))
+                    (list1 (car groups))
+                    (list2 (if (listp custg) custg (list custg))))
+               (if (< (length list1) (length list2))
+                   (setq list1 (prog1 list2 (setq list2 list1))))
+               (dolist (elt list2)
+                 (unless (memq elt list1)
+                   (push elt list1)))
+               (setcar groups list1)))
 
            ;; PLN Sat Jun 30 17:24:42 2007 : when a new
            ;; doc is specified, simply replaces the old one.
@@ -1352,13 +1364,57 @@
   method)
 
 ;;; Slot type validation
-;;
+
+;; 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."
-  ;; typep is in cl-macs
   (or (eq spec t)                      ; t always passes
       (eq value eieio-unbound)         ; unbound always passes
-      (typep value spec)))
+      (eieio--typep value spec)))
 
 (defun eieio-validate-slot-value (class slot-idx value slot)
   "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
@@ -2383,6 +2439,8 @@
 
 ;; The below setf method was written by Arnd Kohrs <address@hidden>
 (define-setf-method oref (obj slot)
+  (with-no-warnings
+    (require 'cl)
   (let ((obj-temp (gensym))
        (slot-temp (gensym))
        (store-temp (gensym)))
@@ -2391,7 +2449,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)))))
 
 
 ;;;
@@ -2768,9 +2826,5 @@
 
 (provide 'eieio)
 
-;; Local variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End:
-
 ;; arch-tag: c1aeab9c-2938-41a3-842b-1a38bd26e9f2
 ;;; eieio ends here