[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] emacs/lisp ChangeLog emacs-lisp/eieio.el
From: |
Chong Yidong |
Subject: |
[Emacs-diffs] emacs/lisp ChangeLog emacs-lisp/eieio.el |
Date: |
Sun, 11 Oct 2009 02:19:32 +0000 |
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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] emacs/lisp ChangeLog emacs-lisp/eieio.el,
Chong Yidong <=