comparison lisp/emacs-lisp/eieio.el @ 105547:eff4c06fb1e2

* 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.

105546:2ee9eaa0490b

;; @TODO - fix :initform to be a form, not a quoted value
;; @TODO - Prefix non-clos functions with `eieio-'.

;;; Code:

(require 'cl)
(eval-when-compile (require 'eieio-comp))

(defvar eieio-version "1.2"
  "Current version of EIEIO.")

(defun eieio-version ()

      ;; important for EIEIO to be backwards compatible, where
      ;; myobject-p, and myobject-child-p are different.
      ;; "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")))))

      )

    ;; before adding new slots, lets add all the methods and classes
    ;; in from the parent class
    (eieio-copy-parents-into-subclass newc superclasses)

		       "Retrieves the slot `%s' from an object of class `%s'"
		       name cname)
		      (list 'if (list 'slot-boundp 'this (list 'quote name))
			    (list 'eieio-oref 'this (list 'quote name))
			    ;; Else - Some error?  nil?
			    nil
			    )))
	      ;; Thanks Pascal Bourguignon <[e-mail]>
	      ;; 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))
	      )
	  )
	;; 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
	    (progn
	      (eieio-defmethod writer

		      (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
			     prot super-prot a)))
		;; 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.
		(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))))))
		;;  End PLN

		;;  PLN Mon Jun 25 22:44:34 2007 : If a new cust is
		;;  set, simply replaces the old one.
		(when cust

	    (let ((super-prot
		   (car (nthcdr num (aref newc class-class-allocation-protection)))))
	      (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.
	    (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

	    ;; PLN Sat Jun 30 17:24:42 2007 : when a new
	    ;; doc is specified, simply replaces the old one.
	    (when doc
	      ;;(message "Documentation redefined to %s" doc)

      (eieio-defgeneric-reset-generic-form method)))

  method)

;;; Slot type validation
;;
(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)))

(defun eieio-validate-slot-value (class slot-idx value slot)
  "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing

(defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store))
(defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store))

;; The below setf method was written by Arnd Kohrs <[e-mail]>
(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))))


;;;
;; We want all objects created by EIEIO to have some default set of
;; behaviours so we can create object utilities, and allow various

(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.")

(provide 'eieio)

;; Local variables:
;; byte-compile-warnings: (not cl-functions)
;; End:

;; arch-tag: c1aeab9c-2938-41a3-842b-1a38bd26e9f2
;;; eieio ends here

105547:eff4c06fb1e2

;; @TODO - fix :initform to be a form, not a quoted value
;; @TODO - Prefix non-clos functions with `eieio-'.

;;; Code:

(eval-when-compile
  (require 'cl)
  (require 'eieio-comp))

(defvar eieio-version "1.2"
  "Current version of EIEIO.")

(defun eieio-version ()

      ;; important for EIEIO to be backwards compatible, where
      ;; myobject-p, and myobject-child-p are different.
      ;; "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.

      ;; 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
    (eieio-copy-parents-into-subclass newc superclasses)

		       "Retrieves the slot `%s' from an object of class `%s'"
		       name cname)
		      (list 'if (list 'slot-boundp 'this (list 'quote name))
			    (list 'eieio-oref 'this (list 'quote name))
			    ;; 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 a writer is defined, then create a generic method of that
	;; name whose purpose is to set the value of the slot.
	(if writer
	    (progn
	      (eieio-defmethod writer

		      (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
			     prot super-prot a)))
		;; End original PLN

		;; PLN Tue Jun 26 11:57:06 2007 :
		;; Do a non redundant combination of ancient custom
		;; groups and new ones.
		(when 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
		;;  set, simply replaces the old one.
		(when cust

	    (let ((super-prot
		   (car (nthcdr num (aref newc class-class-allocation-protection)))))
	      (if (not (eq prot super-prot))
		  (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
			 prot super-prot a)))
	    ;; Do a non redundant combination of ancient custom groups
	    ;; and new ones.
	    (when custg
	      (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.
	    (when doc
	      ;;(message "Documentation redefined to %s" doc)

      (eieio-defgeneric-reset-generic-form method)))

  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."
  (or (eq spec t)			; t always passes
      (eq value eieio-unbound)		; unbound always passes
      (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.
Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing

(defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store))
(defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store))

;; The below setf method was written by Arnd Kohrs <[e-mail]>
(define-setf-method oref (obj slot)
  (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)))))


;;;
;; We want all objects created by EIEIO to have some default set of
;; behaviours so we can create object utilities, and allow various

(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.")

(provide 'eieio)

;; arch-tag: c1aeab9c-2938-41a3-842b-1a38bd26e9f2
;;; eieio ends here