X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/6b8bc570715801cb194dc4273370eab87628e8bf..ee7683ebb70c308e596103e379ef6b91d001eebc:/lisp/emacs-lisp/eieio.el

diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 7a119e6bbc..db3236afc1 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -1,5 +1,5 @@
 ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects
-;;;              or maybe Eric's Implementation of Emacs Intrepreted Objects
+;;;              or maybe Eric's Implementation of Emacs Interpreted Objects
 
 ;; Copyright (C) 1995-1996, 1998-2011  Free Software Foundation, Inc.
 
@@ -395,7 +395,7 @@ It creates an autoload function for CNAME's constructor."
 	  (aset newc class-parent (cons SC (aref newc class-parent)))
 	  )
 
-	;; turn this into a useable self-pointing symbol
+	;; turn this into a usable self-pointing symbol
 	(set cname cname)
 
 	;; Store the new class vector definition into the symbol.  We need to
@@ -420,6 +420,7 @@ It creates an autoload function for CNAME's constructor."
     (load-library (car (cdr (symbol-function cname))))))
 
 (defun eieio-defclass (cname superclasses slots options-and-doc)
+  ;; FIXME: Most of this should be moved to the `defclass' macro.
   "Define CNAME as a new subclass of SUPERCLASSES.
 SLOTS are the slots residing in that class definition, and options or
 documentation OPTIONS-AND-DOC is the toplevel documentation for this class.
@@ -508,7 +509,7 @@ See `defclass' for more information."
 	;; save parent in child
 	(aset newc class-parent (list eieio-default-superclass))))
 
-    ;; turn this into a useable self-pointing symbol
+    ;; turn this into a usable self-pointing symbol
     (set cname cname)
 
     ;; These two tests must be created right away so we can have self-
@@ -552,7 +553,7 @@ See `defclass' for more information."
       (put cname 'cl-deftype-handler
 	   (list 'lambda () `(list 'satisfies (quote ,csym)))))
 
-    ;; before adding new slots, lets add all the methods and classes
+    ;; before adding new slots, let's add all the methods and classes
     ;; in from the parent class
     (eieio-copy-parents-into-subclass newc superclasses)
 
@@ -656,14 +657,14 @@ See `defclass' for more information."
 	;; so that users can `setf' the space returned by this function
 	(if acces
 	    (progn
-	      (eieio-defmethod acces
-		(list (if (eq alloc :class) :static :primary)
-		      (list (list 'this cname))
-		      (format
+	      (eieio--defmethod
+               acces (if (eq alloc :class) :static :primary) cname
+               `(lambda (this)
+                  ,(format
 		       "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))
+                  (if (slot-boundp this ',name)
+                      (eieio-oref this ',name)
 			    ;; Else - Some error?  nil?
 			    nil)))
 
@@ -683,22 +684,21 @@ See `defclass' for more information."
 	;; 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
-		(list (list (list 'this cname) 'value)
-		      (format "Set the slot `%s' of an object of class `%s'"
+            (eieio--defmethod
+             writer nil cname
+             `(lambda (this value)
+                ,(format "Set the slot `%s' of an object of class `%s'"
 			      name cname)
-		      `(setf (slot-value this ',name) value)))
-	      ))
+                (setf (slot-value this ',name) value))))
 	;; If a reader is defined, then create a generic method
 	;; of that name whose purpose is to access this slot value.
 	(if reader
-	    (progn
-	      (eieio-defmethod reader
-		(list (list (list 'this cname))
-		      (format "Access the slot `%s' from object of class `%s'"
+            (eieio--defmethod
+             reader nil cname
+             `(lambda (this)
+                ,(format "Access the slot `%s' from object of class `%s'"
 			      name cname)
-		      `(slot-value this ',name)))))
+                (slot-value this ',name))))
 	)
       (setq slots (cdr slots)))
 
@@ -826,7 +826,7 @@ if default value is nil."
   ;; Make sure we duplicate those items that are sequences.
   (condition-case nil
       (if (sequencep d) (setq d (copy-sequence d)))
-    ;; This copy can fail on a cons cell with a non-cons in the cdr.  Lets skip it if it doesn't work.
+    ;; This copy can fail on a cons cell with a non-cons in the cdr.  Let's skip it if it doesn't work.
     (error nil))
   (if (sequencep type) (setq type (copy-sequence type)))
   (if (sequencep cust) (setq cust (copy-sequence cust)))
@@ -958,7 +958,7 @@ if default value is nil."
 	  (progn
 	    (eieio-perform-slot-validation-for-default a type value skipnil)
 	    ;; Here we have found a :class version of a slot.  This
-	    ;; requires a very different aproach.
+	    ;; requires a very different approach.
 	    (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a)))
 	    (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc)))
 	    (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type)))
@@ -992,7 +992,7 @@ if default value is nil."
 	      ;; EML - Note: the only reason to override a class bound slot
 	      ;;       is to change the default, so allow unbound in.
 
-	      ;; If we have a repeat, only update the vlaue...
+	      ;; If we have a repeat, only update the value...
 	      (eieio-perform-slot-validation-for-default a tp value skipnil)
 	      (setcar dp value))
 
@@ -1140,6 +1140,17 @@ a string."
 
 ;;; CLOS methods and generics
 ;;
+
+(put 'eieio--defalias 'byte-hunk-handler
+     #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
+(defun eieio--defalias (name body)
+  "Like `defalias', but with less side-effects.
+More specifically, it has no side-effects at all when the new function
+definition is the same (`eq') as the old one."
+  (unless (and (fboundp name)
+               (eq (symbol-function name) body))
+    (defalias name body)))
+
 (defmacro defgeneric (method args &optional doc-string)
   "Create a generic function METHOD.
 DOC-STRING is the base documentation for this class.  A generic
@@ -1148,7 +1159,21 @@ is appropriate to use.  Uses `defmethod' to create methods, and calls
 `defgeneric' for you.  With this implementation the ARGS are
 currently ignored.  You can use `defgeneric' to apply specialized
 top level documentation to a method."
-  `(eieio-defgeneric (quote ,method) ,doc-string))
+  `(eieio--defalias ',method
+                    (eieio--defgeneric-init-form ',method ,doc-string)))
+
+(defun eieio--defgeneric-init-form (method doc-string)
+  "Form to use for the initial definition of a generic."
+  (cond
+   ((or (not (fboundp method))
+        (eq 'autoload (car-safe (symbol-function method))))
+    ;; Make sure the method tables are installed.
+    (eieiomt-install method)
+    ;; Construct the actual body of this function.
+    (eieio-defgeneric-form method doc-string))
+   ((generic-p method) (symbol-function method))           ;Leave it as-is.
+   (t (error "You cannot create a generic/method over an existing symbol: %s"
+             method))))
 
 (defun eieio-defgeneric-form (method doc-string)
   "The lambda form that would be used as the function defined on METHOD.
@@ -1201,29 +1226,28 @@ IMPL is the symbol holding the method implementation."
 	(if (not (eieio-object-p (car local-args)))
 	    ;; Not an object.  Just signal.
 	    (signal 'no-method-definition
-                    (list ,(list 'quote method) local-args))
+                    (list ',method local-args))
 
 	  ;; We do have an object.  Make sure it is the right type.
 	  (if ,(if (eq class eieio-default-superclass)
-		   nil ; default superclass means just an obj.  Already asked.
+		   nil  ; default superclass means just an obj.  Already asked.
 		 `(not (child-of-class-p (aref (car local-args) object-class)
-					 ,(list 'quote class)))
-		 )
+					 ',class)))
 
 	      ;; If not the right kind of object, call no applicable
 	      (apply 'no-applicable-method (car local-args)
-		     ,(list 'quote method) local-args)
+		     ',method local-args)
 
 	    ;; It is ok, do the call.
 	    ;; Fill in inter-call variables then evaluate the method.
-	    (let ((scoped-class ,(list 'quote class))
+	    (let ((scoped-class ',class)
 		  (eieio-generic-call-next-method-list nil)
 		  (eieio-generic-call-key method-primary)
-		  (eieio-generic-call-methodname ,(list 'quote method))
+		  (eieio-generic-call-methodname ',method)
 		  (eieio-generic-call-arglst local-args)
 		  )
-	      (apply ,(list 'quote impl) local-args)
-	      ;(,impl local-args)
+	      (apply #',impl local-args)
+              ;;(,impl local-args)
 	      )))))))
 
 (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
@@ -1238,26 +1262,6 @@ IMPL is the symbol holding the method implementation."
 		  (cdr entry)
 		  ))))
 
-(defun eieio-defgeneric (method doc-string)
-  "Engine part to `defgeneric' macro defining METHOD with DOC-STRING."
-  (if (and (fboundp method) (not (generic-p method))
-	   (or (byte-code-function-p (symbol-function method))
-	       (not (eq 'autoload (car (symbol-function method)))))
-	   )
-      (error "You cannot create a generic/method over an existing symbol: %s"
-	     method))
-  ;; Don't do this over and over.
-  (unless (fboundp 'method)
-    ;; This defun tells emacs where the first definition of this
-    ;; method is defined.
-    `(defun ,method nil)
-    ;; Make sure the method tables are installed.
-    (eieiomt-install method)
-    ;; Apply the actual body of this function.
-    (fset method (eieio-defgeneric-form method doc-string))
-    ;; Return the method
-    'method))
-
 (defun eieio-unbind-method-implementations (method)
   "Make the generic method METHOD have no implementations.
 It will leave the original generic function in place,
@@ -1290,83 +1294,53 @@ Summary:
                      ((typearg class-name) arg2 &optional opt &rest rest)
     \"doc-string\"
      body)"
-  (let* ((key (cond ((or (eq ':BEFORE (car args))
-                         (eq ':before (car args)))
-                     (setq args (cdr args))
-                     :before)
-                    ((or (eq ':AFTER (car args))
-                         (eq ':after (car args)))
-                     (setq args (cdr args))
-                     :after)
-                    ((or (eq ':PRIMARY (car args))
-                         (eq ':primary (car args)))
-                     (setq args (cdr args))
-                     :primary)
-                    ((or (eq ':STATIC (car args))
-                         (eq ':static (car args)))
-                     (setq args (cdr args))
-                     :static)
-                    (t nil)))
+  (let* ((key (if (keywordp (car args)) (pop args)))
 	 (params (car args))
-	 (lamparams
-          (mapcar (lambda (param) (if (listp param) (car param) param))
-                  params))
 	 (arg1 (car params))
-	 (class (if (listp arg1) (nth 1 arg1) nil)))
-    `(eieio-defmethod ',method
-                      '(,@(if key (list key))
-                        ,params)
-                      (lambda ,lamparams ,@(cdr args)))))
-
-(defun eieio-defmethod (method args &optional code)
+         (fargs (if (consp arg1)
+                   (cons (car arg1) (cdr params))
+                 params))
+	 (class (if (consp arg1) (nth 1 arg1)))
+         (code `(lambda ,fargs ,@(cdr args))))
+    `(progn
+       ;; Make sure there is a generic and the byte-compiler sees it.
+       (defgeneric ,method ,args
+         ,(or (documentation code)
+              (format "Generically created method `%s'." method)))
+       (eieio--defmethod ',method ',key ',class #',code))))
+
+(defun eieio--defmethod (method kind argclass code)
   "Work part of the `defmethod' macro defining METHOD with ARGS."
-  (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
-    ;; find optional keys
-    (setq key
-	  (cond ((or (eq ':BEFORE (car args))
-		     (eq ':before (car args)))
-		 (setq args (cdr args))
-		 method-before)
-		((or (eq ':AFTER (car args))
-		     (eq ':after (car args)))
-		 (setq args (cdr args))
-		 method-after)
-		((or (eq ':PRIMARY (car args))
-		     (eq ':primary (car args)))
-		 (setq args (cdr args))
-		 method-primary)
-		((or (eq ':STATIC (car args))
-		     (eq ':static (car args)))
-		 (setq args (cdr args))
-		 method-static)
-		;; Primary key
-		(t method-primary)))
-    ;; get body, and fix contents of args to be the arguments of the fn.
-    (setq body (cdr args)
-	  args (car args))
-    (setq loopa args)
-    ;; Create a fixed version of the arguments
-    (while loopa
-      (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
-			 argfix))
-      (setq loopa (cdr loopa)))
-    ;; make sure there is a generic
-    (eieio-defgeneric
-     method
-     (if (stringp (car body))
-	 (car body) (format "Generically created method `%s'." method)))
+  (let ((key
+         ;; find optional keys
+         (cond ((or (eq ':BEFORE kind)
+                    (eq ':before kind))
+                method-before)
+               ((or (eq ':AFTER kind)
+                    (eq ':after kind))
+                method-after)
+               ((or (eq ':PRIMARY kind)
+                    (eq ':primary kind))
+                method-primary)
+               ((or (eq ':STATIC kind)
+                    (eq ':static kind))
+                method-static)
+               ;; Primary key
+               (t method-primary))))
+    ;; Make sure there is a generic (when called from defclass).
+    (eieio--defalias
+     method (eieio--defgeneric-init-form
+             method (or (documentation code)
+                        (format "Generically created method `%s'." method))))
     ;; create symbol for property to bind to.  If the first arg is of
     ;; the form (varname vartype) and `vartype' is a class, then
     ;; that class will be the type symbol.  If not, then it will fall
     ;; under the type `primary' which is a non-specific calling of the
     ;; function.
-    (setq firstarg (car args))
-    (if (listp firstarg)
-	(progn
-	  (setq argclass  (nth 1 firstarg))
-	  (if (not (class-p argclass))
-	      (error "Unknown class type %s in method parameters"
-		     (nth 1 firstarg))))
+    (if argclass
+        (if (not (class-p argclass))
+            (error "Unknown class type %s in method parameters"
+                   argclass))
       (if (= key -1)
 	  (signal 'wrong-type-argument (list :static 'non-class-arg)))
       ;; generics are higher
@@ -1496,7 +1470,7 @@ created by the :initarg tag."
 	 (c (eieio-slot-name-index class obj slot)))
     (if (not c)
 	;; It might be missing because it is a :class allocated slot.
-	;; Lets check that info out.
+	;; Let's check that info out.
 	(if (setq c (eieio-class-slot-name-index class slot))
 	    ;; Oref that slot.
 	    (aref (aref (class-v class) class-class-allocation-values) c)
@@ -1529,7 +1503,7 @@ Fills in OBJ's SLOT with its default value."
 	 (c (eieio-slot-name-index cl obj slot)))
     (if (not c)
 	;; It might be missing because it is a :class allocated slot.
-	;; Lets check that info out.
+	;; Let's check that info out.
 	(if (setq c
 		  (eieio-class-slot-name-index cl slot))
 	    ;; Oref that slot.
@@ -1575,7 +1549,7 @@ Fills in OBJ's SLOT with VALUE."
   (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot)))
     (if (not c)
 	;; It might be missing because it is a :class allocated slot.
-	;; Lets check that info out.
+	;; Let's check that info out.
 	(if (setq c
 		  (eieio-class-slot-name-index (aref obj object-class) slot))
 	    ;; Oset that slot.
@@ -1607,7 +1581,7 @@ Fills in the default value in CLASS' in SLOT with VALUE."
 	 (c (eieio-slot-name-index class nil slot)))
     (if (not c)
 	;; It might be missing because it is a :class allocated slot.
-	;; Lets check that info out.
+	;; Let's check that info out.
 	(if (setq c (eieio-class-slot-name-index class slot))
 	    (progn
 	      ;; Oref that slot.
@@ -1884,11 +1858,11 @@ OBJECT can be an instance or a class."
   ;; Skip typechecking while retrieving this value.
   (let ((eieio-skip-typecheck t))
     ;; Return nil if the magic symbol is in there.
-    (if (eieio-object-p object)
-	(if (eq (eieio-oref object slot) eieio-unbound) nil t)
-      (if (class-p object)
-	  (if (eq (eieio-oref-default object slot) eieio-unbound) nil t)
-	(signal 'wrong-type-argument (list 'eieio-object-p object))))))
+    (not (eq (cond
+	      ((eieio-object-p object) (eieio-oref object slot))
+	      ((class-p object)        (eieio-oref-default object slot))
+	      (t (signal 'wrong-type-argument (list 'eieio-object-p object))))
+	     eieio-unbound))))
 
 (defun slot-makeunbound (object slot)
   "In OBJECT, make SLOT unbound."
@@ -2589,7 +2563,7 @@ This is usually a symbol that starts with `:'."
 
 ;;;
 ;; We want all objects created by EIEIO to have some default set of
-;; behaviours so we can create object utilities, and allow various
+;; behaviors so we can create object utilities, and allow various
 ;; types of error checking.  To do this, create the default EIEIO
 ;; class, and when no parent class is specified, use this as the
 ;; default.  (But don't store it in the other classes as the default,
@@ -2890,6 +2864,106 @@ of `eq'."
 )
 
 
+;;; Obsolete backward compatibility functions.
+;; Needed to run byte-code compiled with the EIEIO of Emacs-23.
+
+(defun eieio-defmethod (method args)
+  "Obsolete work part of an old version of the `defmethod' macro."
+  (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
+    ;; find optional keys
+    (setq key
+	  (cond ((or (eq ':BEFORE (car args))
+		     (eq ':before (car args)))
+		 (setq args (cdr args))
+		 method-before)
+		((or (eq ':AFTER (car args))
+		     (eq ':after (car args)))
+		 (setq args (cdr args))
+		 method-after)
+		((or (eq ':PRIMARY (car args))
+		     (eq ':primary (car args)))
+		 (setq args (cdr args))
+		 method-primary)
+		((or (eq ':STATIC (car args))
+		     (eq ':static (car args)))
+		 (setq args (cdr args))
+		 method-static)
+		;; Primary key
+		(t method-primary)))
+    ;; get body, and fix contents of args to be the arguments of the fn.
+    (setq body (cdr args)
+	  args (car args))
+    (setq loopa args)
+    ;; Create a fixed version of the arguments
+    (while loopa
+      (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
+			 argfix))
+      (setq loopa (cdr loopa)))
+    ;; make sure there is a generic
+    (eieio-defgeneric
+     method
+     (if (stringp (car body))
+	 (car body) (format "Generically created method `%s'." method)))
+    ;; create symbol for property to bind to.  If the first arg is of
+    ;; the form (varname vartype) and `vartype' is a class, then
+    ;; that class will be the type symbol.  If not, then it will fall
+    ;; under the type `primary' which is a non-specific calling of the
+    ;; function.
+    (setq firstarg (car args))
+    (if (listp firstarg)
+	(progn
+	  (setq argclass  (nth 1 firstarg))
+	  (if (not (class-p argclass))
+	      (error "Unknown class type %s in method parameters"
+		     (nth 1 firstarg))))
+      (if (= key -1)
+	  (signal 'wrong-type-argument (list :static 'non-class-arg)))
+      ;; generics are higher
+      (setq key (eieio-specialized-key-to-generic-key key)))
+    ;; Put this lambda into the symbol so we can find it
+    (if (byte-code-function-p (car-safe body))
+	(eieiomt-add method (car-safe body) key argclass)
+      (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
+		   key argclass))
+    )
+
+  (when eieio-optimize-primary-methods-flag
+    ;; Optimizing step:
+    ;;
+    ;; If this method, after this setup, only has primary methods, then
+    ;; we can setup the generic that way.
+    (if (generic-primary-only-p method)
+	;; If there is only one primary method, then we can go one more
+	;; optimization step.
+	(if (generic-primary-only-one-p method)
+	    (eieio-defgeneric-reset-generic-form-primary-only-one method)
+	  (eieio-defgeneric-reset-generic-form-primary-only method))
+      (eieio-defgeneric-reset-generic-form method)))
+
+  method)
+(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")
+
+(defun eieio-defgeneric (method doc-string)
+  "Obsolete work part of an old version of the `defgeneric' macro."
+  (if (and (fboundp method) (not (generic-p method))
+	   (or (byte-code-function-p (symbol-function method))
+	       (not (eq 'autoload (car (symbol-function method)))))
+	   )
+      (error "You cannot create a generic/method over an existing symbol: %s"
+	     method))
+  ;; Don't do this over and over.
+  (unless (fboundp 'method)
+    ;; This defun tells emacs where the first definition of this
+    ;; method is defined.
+    `(defun ,method nil)
+    ;; Make sure the method tables are installed.
+    (eieiomt-install method)
+    ;; Apply the actual body of this function.
+    (fset method (eieio-defgeneric-form method doc-string))
+    ;; Return the method
+    'method))
+(make-obsolete 'eieio-defgeneric nil "24.1")
+
 ;;; Interfacing with edebug
 ;;
 (defun eieio-edebug-prin1-to-string (object &optional noescape)
@@ -2977,7 +3051,7 @@ Optional argument GROUP is the sub-group of slots to display.
 
 ;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic
 ;;;;;;  eieio-describe-constructor eieio-describe-class eieio-browse)
-;;;;;;  "eieio-opt" "eieio-opt.el" "1bed0a56310f402683419139ebc18d7f")
+;;;;;;  "eieio-opt" "eieio-opt.el" "4fb6625c3a007438aab4e8e77b6c73c2")
 ;;; Generated autoloads from eieio-opt.el
 
 (autoload 'eieio-browse "eieio-opt" "\