# HG changeset patch # User Chong Yidong # Date 1255227567 0 # Node ID eff4c06fb1e282d6fd5914aa7ca6ccce3823390e # Parent 2ee9eaa0490b7f1f03616f59cde78ba32537abed * 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. diff -r 2ee9eaa0490b -r eff4c06fb1e2 lisp/ChangeLog --- a/lisp/ChangeLog Sun Oct 11 00:07:05 2009 +0000 +++ b/lisp/ChangeLog Sun Oct 11 02:19:27 2009 +0000 @@ -1,3 +1,12 @@ +2009-10-11 Chong Yidong + + * 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 * bookmark.el: (bookmark-yank-word, bookmark-insert-current-bookmark): diff -r 2ee9eaa0490b -r eff4c06fb1e2 lisp/emacs-lisp/eieio.el --- a/lisp/emacs-lisp/eieio.el Sun Oct 11 00:07:05 2009 +0000 +++ b/lisp/emacs-lisp/eieio.el Sun Oct 11 02:19:27 2009 +0000 @@ -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 - ;; 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,15 +2439,17 @@ ;; The below setf method was written by Arnd Kohrs (define-setf-method oref (obj slot) - (let ((obj-temp (gensym)) - (slot-temp (gensym)) - (store-temp (gensym))) - (list (list obj-temp slot-temp) - (list obj `(quote ,slot)) - (list store-temp) - (list 'set-slot-value obj-temp slot-temp - store-temp) - (list 'slot-value obj-temp slot-temp)))) + (with-no-warnings + (require 'cl) + (let ((obj-temp (gensym)) + (slot-temp (gensym)) + (store-temp (gensym))) + (list (list obj-temp slot-temp) + (list obj `(quote ,slot)) + (list store-temp) + (list 'set-slot-value obj-temp slot-temp + store-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