mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-21 05:00:47 -08:00
Code Issues Projects Releases Wiki Activity

upstream

Browse source
This commit is contained in:
Joakim Verona 2012-10-16 17:14:35 +02:00
commit 017a270078
401 changed files with 33851 additions and 14870 deletions
Download patch file Download diff file Expand all files Collapse all files

18
lisp/emacs-lisp/bytecomp.el
View file

@ -846,7 +846,7 @@ CONST2 may be evaluated multiple times."
(defun byte-compile-cl-file-p (file)
"Return non-nil if FILE is one of the CL files."
(and (stringp file)
(string-match "^cl\\>" (file-name-nondirectory file))))
(string-match "^cl\\.el" (file-name-nondirectory file))))
(defun byte-compile-eval (form)
"Eval FORM and mark the functions defined therein.
@ -1005,13 +1005,20 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(defvar byte-compile-root-dir nil
"Directory relative to which file names in error messages are written.")
;; FIXME: We should maybe extend abbreviate-file-name with an optional DIR
;; argument to try and use a relative file-name.
(defun byte-compile-abbreviate-file (file &optional dir)
(let ((f1 (abbreviate-file-name file))
(f2 (file-relative-name file dir)))
(if (< (length f2) (length f1)) f2 f1)))
;; This is used as warning-prefix for the compiler.
;; It is always called with the warnings buffer current.
(defun byte-compile-warning-prefix (level entry)
(let* ((inhibit-read-only t)
(dir (or byte-compile-root-dir default-directory))
(file (cond ((stringp byte-compile-current-file)
(format "%s:" (file-relative-name
(format "%s:" (byte-compile-abbreviate-file
byte-compile-current-file dir)))
((bufferp byte-compile-current-file)
(format "Buffer %s:"
@ -1019,7 +1026,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; We might be simply loading a file that
;; contains explicit calls to byte-compile functions.
((stringp load-file-name)
(format "%s:" (file-relative-name load-file-name dir)))
(format "%s:" (byte-compile-abbreviate-file
load-file-name dir)))
(t "")))
(pos (if (and byte-compile-current-file
(integerp byte-compile-read-position))
@ -1746,11 +1754,11 @@ The value is non-nil if there were no errors, nil if errors."
(if (with-current-buffer input-buffer no-byte-compile)
(progn
;; (message "%s not compiled because of `no-byte-compile: %s'"
;; (file-relative-name filename)
;; (byte-compile-abbreviate-file filename)
;; (with-current-buffer input-buffer no-byte-compile))
(when (file-exists-p target-file)
(message "%s deleted because of `no-byte-compile: %s'"
(file-relative-name target-file)
(byte-compile-abbreviate-file target-file)
(buffer-local-value 'no-byte-compile input-buffer))
(condition-case nil (delete-file target-file) (error nil)))
;; We successfully didn't compile this file.

1
lisp/emacs-lisp/cl-extra.el
View file

@ -689,7 +689,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

1
lisp/emacs-lisp/cl-lib.el
View file

@ -745,7 +745,6 @@ If ALIST is non-nil, the new pairs are prepended to it."
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; End:
;;; cl-lib.el ends here

6
lisp/emacs-lisp/cl-loaddefs.el
View file

@ -11,7 +11,7 @@
;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively
;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan
;;;;;; cl-mapl cl-maplist cl-map cl--mapcar-many cl-equalp cl-coerce)
;;;;;; "cl-extra" "cl-extra.el" "535a24c1cff55a16e3d51219498a7858")
;;;;;; "cl-extra" "cl-extra.el" "1572ae52fa4fbd9c4bf89b49a068a865")
;;; Generated autoloads from cl-extra.el
(autoload 'cl-coerce "cl-extra" "\
@ -260,7 +260,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
;;;;;; "cl-macs" "cl-macs.el" "00526d56a1062b9c308cf37b59374f2b")
;;;;;; "cl-macs" "cl-macs.el" "8c5b0c97239c3e29cebbf1406534a6d3")
;;; Generated autoloads from cl-macs.el
(autoload 'cl--compiler-macro-list* "cl-macs" "\
@ -748,7 +748,7 @@ surrounded by (cl-block NAME ...).
;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if
;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not
;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove
;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "b444601641dcbd14a23ca5182bc80ffa")
;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "4c1e1191e82dc8d5449a5ec4d59efc10")
;;; Generated autoloads from cl-seq.el
(autoload 'cl-reduce "cl-seq" "\

1
lisp/emacs-lisp/cl-macs.el
View file

@ -2686,7 +2686,6 @@ surrounded by (cl-block NAME ...).
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

1
lisp/emacs-lisp/cl-seq.el
View file

@ -1010,7 +1010,6 @@ Atoms are compared by `eql'; cons cells are compared recursively.
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

2
lisp/emacs-lisp/cl.el
View file

@ -452,7 +452,7 @@ definitions, or lack thereof).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet)
(obsolete "Use either `cl-flet' or `cl-letf'." "24.3"))
(obsolete "use either `cl-flet' or `cl-letf'." "24.3"))
`(letf ,(mapcar
(lambda (x)
(if (or (and (fboundp (car x))

4
lisp/emacs-lisp/debug.el
View file

@ -273,7 +273,9 @@ first will be printed into the backtrace buffer."
(setq debugger-previous-window-height
(window-total-size debugger-window))
;; Unshow debugger-buffer.
(quit-restore-window debugger-window debugger-bury-or-kill))
(quit-restore-window debugger-window debugger-bury-or-kill)
;; Restore current buffer (Bug#12502).
(set-buffer debugger-old-buffer))
;; Restore previous state of debugger-buffer in case we were
;; in a recursive invocation of the debugger, otherwise just
;; erase the buffer and put it into fundamental mode.

177
lisp/emacs-lisp/eieio-base.el
View file

@ -4,7 +4,6 @@
;;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
;; Package: eieio
@ -225,8 +224,16 @@ a file. Optional argument NAME specifies a default file name."
))))
(oref this file))
(defun eieio-persistent-read (filename)
"Read a persistent object from FILENAME, and return it."
(defun eieio-persistent-read (filename &optional class allow-subclass)
"Read a persistent object from FILENAME, and return it.
Signal an error if the object in FILENAME is not a constructor
for CLASS. Optional ALLOW-SUBCLASS says that it is ok for
`eieio-peristent-read' to load in subclasses of class instead of
being pendantic."
(unless class
(message "Unsafe call to `eieio-persistent-read'."))
(when (and class (not (class-p class)))
(signal 'wrong-type-argument (list 'class-p class)))
(let ((ret nil)
(buffstr nil))
(unwind-protect
@ -239,13 +246,171 @@ a file. Optional argument NAME specifies a default file name."
;; so that any initialize-instance calls that depend on
;; the current buffer will work.
(setq ret (read buffstr))
(if (not (child-of-class-p (car ret) 'eieio-persistent))
(error "Corrupt object on disk"))
(setq ret (eval ret))
(when (not (child-of-class-p (car ret) 'eieio-persistent))
(error "Corrupt object on disk: Unknown saved object"))
(when (and class
(not (or (eq (car ret) class ) ; same class
(and allow-subclass
(child-of-class-p (car ret) class)) ; subclasses
)))
(error "Corrupt object on disk: Invalid saved class"))
(setq ret (eieio-persistent-convert-list-to-object ret))
(oset ret file filename))
(kill-buffer " *tmp eieio read*"))
ret))
(defun eieio-persistent-convert-list-to-object (inputlist)
"Convert the INPUTLIST, representing object creation to an object.
While it is possible to just `eval' the INPUTLIST, this code instead
validates the existing list, and explicitly creates objects instead of
calling eval. This avoids the possibility of accidentally running
malicious code.
Note: This function recurses when a slot of :type of some object is
identified, and needing more object creation."
(let ((objclass (nth 0 inputlist))
(objname (nth 1 inputlist))
(slots (nthcdr 2 inputlist))
(createslots nil))
;; If OBJCLASS is an eieio autoload object, then we need to load it.
(eieio-class-un-autoload objclass)
(while slots
(let ((name (car slots))
(value (car (cdr slots))))
;; Make sure that the value proposed for SLOT is valid.
;; In addition, strip out quotes, list functions, and update
;; object constructors as needed.
(setq value (eieio-persistent-validate/fix-slot-value
objclass name value))
(push name createslots)
(push value createslots)
)
(setq slots (cdr (cdr slots))))
(apply 'make-instance objclass objname (nreverse createslots))
;;(eval inputlist)
))
(defun eieio-persistent-validate/fix-slot-value (class slot proposed-value)
"Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix.
A limited number of functions, such as quote, list, and valid object
constructor functions are considered valid.
Secondarilly, any text properties will be stripped from strings."
(cond ((consp proposed-value)
;; Lists with something in them need special treatment.
(let ((slot-idx (eieio-slot-name-index class nil slot))
(type nil)
(classtype nil))
(setq slot-idx (- slot-idx 3))
(setq type (aref (aref (class-v class) class-public-type)
slot-idx))
(setq classtype (eieio-persistent-slot-type-is-class-p
type))
(cond ((eq (car proposed-value) 'quote)
(car (cdr proposed-value)))
;; An empty list sometimes shows up as (list), which is dumb, but
;; we need to support it for backward compat.
((and (eq (car proposed-value) 'list)
(= (length proposed-value) 1))
nil)
;; We have a slot with a single object that can be
;; saved here. Recurse and evaluate that
;; sub-object.
((and classtype (class-p classtype)
(child-of-class-p (car proposed-value) classtype))
(eieio-persistent-convert-list-to-object
proposed-value))
;; List of object constructors.
((and (eq (car proposed-value) 'list)
;; 2nd item is a list.
(consp (car (cdr proposed-value)))
;; 1st elt of 2nd item is a class name.
(class-p (car (car (cdr proposed-value))))
)
;; Check the value against the input class type.
;; If something goes wrong, issue a smart warning
;; about how a :type is needed for this to work.
(unless (and
;; Do we have a type?
(consp classtype) (class-p (car classtype)))
(error "In save file, list of object constructors found, but no :type specified for slot %S"
slot))
;; We have a predicate, but it doesn't satisfy the predicate?
(dolist (PV (cdr proposed-value))
(unless (child-of-class-p (car PV) (car classtype))
(error "Corrupt object on disk")))
;; We have a list of objects here. Lets load them
;; in.
(let ((objlist nil))
(dolist (subobj (cdr proposed-value))
(push (eieio-persistent-convert-list-to-object subobj)
objlist))
;; return the list of objects ... reversed.
(nreverse objlist)))
(t
proposed-value))))
((stringp proposed-value)
;; Else, check for strings, remove properties.
(substring-no-properties proposed-value))
(t
;; Else, just return whatever the constant was.
proposed-value))
)
(defun eieio-persistent-slot-type-is-class-p (type)
"Return the class refered to in TYPE.
If no class is referenced there, then return nil."
(cond ((class-p type)
;; If the type is a class, then return it.
type)
((and (symbolp type) (string-match "-child$" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 0
(match-beginning 0)))))
;; If it is the predicate ending with -child, then return
;; that class. Unfortunately, in EIEIO, typep of just the
;; class is the same as if we used -child, so no further work needed.
(intern-soft (substring (symbol-name type) 0
(match-beginning 0))))
((and (symbolp type) (string-match "-list$" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 0
(match-beginning 0)))))
;; If it is the predicate ending with -list, then return
;; that class and the predicate to use.
(cons (intern-soft (substring (symbol-name type) 0
(match-beginning 0)))
type))
((and (consp type) (eq (car type) 'or))
;; If type is a list, and is an or, it is possibly something
;; like (or null myclass), so check for that.
(let ((ans nil))
(dolist (subtype (cdr type))
(setq ans (eieio-persistent-slot-type-is-class-p
subtype)))
ans))
(t
;; No match, not a class.
nil)))
(defmethod object-write ((this eieio-persistent) &optional comment)
"Write persistent object THIS out to the current stream.
Optional argument COMMENT is a header line comment."

16
lisp/emacs-lisp/eieio-custom.el
View file

@ -332,6 +332,16 @@ Argument OBJ is the object that has been customized."
Optional argument GROUP is the sub-group of slots to display."
(eieio-customize-object obj group))
(defvar eieio-custom-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map widget-keymap)
map)
"Keymap for EIEIO Custom mode")
(define-derived-mode eieio-custom-mode fundamental-mode "EIEIO Custom"
"Major mode for customizing EIEIO objects.
\\{eieio-custom-mode-map}")
(defmethod eieio-customize-object ((obj eieio-default-superclass)
&optional group)
"Customize OBJ in a specialized custom buffer.
@ -347,6 +357,7 @@ These groups are specified with the `:group' slot flag."
(symbol-name g) "*")))
(setq buffer-read-only nil)
(kill-all-local-variables)
(eieio-custom-mode)
(erase-buffer)
(let ((all (overlay-lists)))
;; Delete all the overlays.
@ -363,7 +374,6 @@ These groups are specified with the `:group' slot flag."
(widget-insert "\n")
(eieio-custom-object-apply-reset obj)
;; Now initialize the buffer
(use-local-map widget-keymap)
(widget-setup)
;;(widget-minor-mode)
(goto-char (point-min))
@ -461,8 +471,4 @@ Return the symbol for the group, or nil"
(provide 'eieio-custom)
;; Local variables:
;; generated-autoload-file: "eieio.el"
;; End:
;;; eieio-custom.el ends here

7
lisp/emacs-lisp/eieio-datadebug.el
View file

@ -92,12 +92,11 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
"Class: ")
;; Loop over all the public slots
(let ((publa (aref cv class-public-a))
(publd (aref cv class-public-d))
)
(while publa
(if (slot-boundp obj (car publa))
(let ((i (class-slot-initarg cl (car publa)))
(v (eieio-oref obj (car publa))))
(let* ((i (class-slot-initarg cl (car publa)))
(v (eieio-oref obj (car publa))))
(data-debug-insert-thing
v prefix (concat
(if i (symbol-name i)
@ -112,7 +111,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
" ")
'font-lock-keyword-face))
)
(setq publa (cdr publa) publd (cdr publd))))))
(setq publa (cdr publa))))))
;;; Augment the Data debug thing display list.
(data-debug-add-specialized-thing (lambda (thing) (object-p thing))

139
lisp/emacs-lisp/eieio-opt.el
View file

@ -4,7 +4,6 @@
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
;; Package: eieio
@ -30,6 +29,9 @@
;;
(require 'eieio)
(require 'button)
(require 'help-mode)
(require 'find-func)
;;; Code:
;;;###autoload
@ -85,11 +87,16 @@ Optional HEADERFCN should be called to insert a few bits of info first."
(called-interactively-p 'interactive))
(when headerfcn (funcall headerfcn))
(if (class-option class :abstract)
(princ "Abstract "))
(princ "Class ")
(prin1 class)
(princ " is a")
(if (class-option class :abstract)
(princ "n abstract"))
(princ " class")
;; Print file location
(when (get class 'class-location)
(princ " in `")
(princ (file-name-nondirectory (get class 'class-location)))
(princ "'"))
(terpri)
;; Inheritance tree information
(let ((pl (class-parents class)))
@ -251,8 +258,13 @@ Uses `eieio-describe-class' to describe the class being constructed."
(eieio-describe-class
fcn (lambda ()
;; Describe the constructor part.
(princ "Object Constructor Function: ")
(prin1 fcn)
(princ " is an object constructor function")
;; Print file location
(when (get fcn 'class-location)
(princ " in `")
(princ (file-name-nondirectory (get fcn 'class-location)))
(princ "'"))
(terpri)
(princ "Creates an object of class ")
(prin1 fcn)
@ -262,6 +274,16 @@ Uses `eieio-describe-class' to describe the class being constructed."
))
)
(defun eieio-build-class-list (class)
"Return a list of all classes that inherit from CLASS."
(if (class-p class)
(apply #'append
(mapcar
(lambda (c)
(append (list c) (eieio-build-class-list c)))
(class-children-fast class)))
(list class)))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
"Return an alist of all currently active classes for completion purposes.
Optional argument CLASS is the class to start with.
@ -270,8 +292,9 @@ are not abstract, otherwise allow all classes.
Optional argument BUILDLIST is more list to attach and is used internally."
(let* ((cc (or class eieio-default-superclass))
(sublst (aref (class-v cc) class-children)))
(if (or (not instantiable-only) (not (class-abstract-p cc)))
(setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))
(unless (assoc (symbol-name cc) buildlist)
(when (or (not instantiable-only) (not (class-abstract-p cc)))
(setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
(while sublst
(setq buildlist (eieio-build-class-alist
(car sublst) instantiable-only buildlist))
@ -342,10 +365,10 @@ Also extracts information about all methods specific to this generic."
(princ "Implementations:")
(terpri)
(terpri)
(let ((i 3)
(let ((i 4)
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
;; Loop over fanciful generics
(while (< i 6)
(while (< i 7)
(let ((gm (aref (get generic 'eieio-method-tree) i)))
(when gm
(princ "Generic ")
@ -357,8 +380,9 @@ Also extracts information about all methods specific to this generic."
(setq i (1+ i)))
(setq i 0)
;; Loop over defined class-specific methods
(while (< i 3)
(let ((gm (reverse (aref (get generic 'eieio-method-tree) i))))
(while (< i 4)
(let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
location)
(while gm
(princ "`")
(prin1 (car (car gm)))
@ -375,6 +399,13 @@ Also extracts information about all methods specific to this generic."
;; 3 because of cdr
(princ (or (documentation (cdr (car gm)))
"Undocumented"))
;; Print file location if available
(when (and (setq location (get generic 'method-locations))
(setq location (assoc (caar gm) location)))
(setq location (cadr location))
(princ "\n\nDefined in `")
(princ (file-name-nondirectory location))
(princ "'\n"))
(setq gm (cdr gm))
(terpri)
(terpri)))
@ -554,7 +585,65 @@ Optional argument HISTORYVAR is the variable to use as history."
;;; HELP AUGMENTATION
;;
;;;###autoload
(define-button-type 'eieio-method-def
:supertype 'help-xref
'help-function (lambda (class method file)
(eieio-help-find-method-definition class method file))
'help-echo (purecopy "mouse-2, RET: find method's definition"))
(define-button-type 'eieio-class-def
:supertype 'help-xref
'help-function (lambda (class file)
(eieio-help-find-class-definition class file))
'help-echo (purecopy "mouse-2, RET: find class definition"))
(defun eieio-help-find-method-definition (class method file)
(let ((filename (find-library-name file))
location buf)
(when (null filename)
(error "Cannot find library %s" file))
(setq buf (find-file-noselect filename))
(with-current-buffer buf
(goto-char (point-min))
(when
(re-search-forward
;; Regexp for searching methods.
(concat "(defmethod[ \t\r\n]+" method
"\\([ \t\r\n]+:[a-zA-Z]+\\)?"
"[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+"
class
"\\s-*)")
nil t)
(setq location (match-beginning 0))))
(if (null location)
(message "Unable to find location in file")
(pop-to-buffer buf)
(goto-char location)
(recenter)
(beginning-of-line))))
(defun eieio-help-find-class-definition (class file)
(let ((filename (find-library-name file))
location buf)
(when (null filename)
(error "Cannot find library %s" file))
(setq buf (find-file-noselect filename))
(with-current-buffer buf
(goto-char (point-min))
(when
(re-search-forward
;; Regexp for searching a class.
(concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+")
nil t)
(setq location (match-beginning 0))))
(if (null location)
(message "Unable to find location in file")
(pop-to-buffer buf)
(goto-char location)
(recenter)
(beginning-of-line))))
(defun eieio-help-mode-augmentation-maybee (&rest unused)
"For buffers thrown into help mode, augment for EIEIO.
Arguments UNUSED are not used."
@ -597,6 +686,26 @@ Arguments UNUSED are not used."
(goto-char (point-min))
(while (re-search-forward "^\\(Private \\)?Slot:" nil t)
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
(goto-char (point-min))
(cond
((looking-at "\\(.+\\) is a generic function")
(let ((mname (match-string 1))
cname)
(while (re-search-forward "^`\\(.+\\)'[^\0]+?Defined in `\\(.+\\)'" nil t)
(setq cname (match-string-no-properties 1))
(help-xref-button 2 'eieio-method-def cname
mname
(cadr (assoc (intern cname)
(get (intern mname)
'method-locations)))))))
((looking-at "\\(.+\\) is an object constructor function in `\\(.+\\)'")
(let ((cname (match-string-no-properties 1)))
(help-xref-button 2 'eieio-class-def cname
(get (intern cname) 'class-location))))
((looking-at "\\(.+\\) is a\\(n abstract\\)? class in `\\(.+\\)'")
(let ((cname (match-string-no-properties 1)))
(help-xref-button 3 'eieio-class-def cname
(get (intern cname) 'class-location)))))
))))
;;; SPEEDBAR SUPPORT
@ -698,8 +807,4 @@ INDENT is the current indentation level."
(provide 'eieio-opt)
;; Local variables:
;; generated-autoload-file: "eieio.el"
;; End:
;;; eieio-opt.el ends here

18
lisp/emacs-lisp/eieio-speedbar.el
View file

@ -3,7 +3,6 @@
;; Copyright (C) 1999-2002, 2005, 2007-2012 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, tools
;; Package: eieio
@ -191,23 +190,24 @@ that path."
;;; DEFAULT SUPERCLASS baseline methods
;;
;; First, define methods onto the superclass so all classes
;; will have some minor support.
;; First, define methods with no class defined. These will work as if
;; on the default superclass. Specifying no class will allow these to be used
;; when no other methods are found, allowing multiple inheritance to work
;; reliably with eieio-speedbar.
(defmethod eieio-speedbar-description ((object eieio-default-superclass))
(defmethod eieio-speedbar-description (object)
"Return a string describing OBJECT."
(object-name-string object))
(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass))
(defmethod eieio-speedbar-derive-line-path (object)
"Return the path which OBJECT has something to do with."
nil)
(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass))
(defmethod eieio-speedbar-object-buttonname (object)
"Return a string to use as a speedbar button for OBJECT."
(object-name-string object))
(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass)
depth)
(defmethod eieio-speedbar-make-tag-line (object depth)
"Insert a tag line into speedbar at point for OBJECT.
By default, all objects appear as simple TAGS with no need to inherit from
the special `eieio-speedbar' classes. Child classes should redefine this
@ -220,7 +220,7 @@ Argument DEPTH is the depth at which the tag line is inserted."
'speedbar-tag-face
depth))
(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass))
(defmethod eieio-speedbar-handle-click (object)
"Handle a click action on OBJECT in speedbar.
Any object can be represented as a tag in SPEEDBAR without special
attributes. These default objects will be pulled up in a custom

74
lisp/emacs-lisp/eieio.el
View file

@ -94,21 +94,6 @@ default setting for optimization purposes.")
(defvar eieio-optimize-primary-methods-flag t
"Non-nil means to optimize the method dispatch on primary methods.")
;; State Variables
;; FIXME: These two constants below should have an `eieio-' prefix added!!
(defvar this nil
"Inside a method, this variable is the object in question.
DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots.
Note: Embedded methods are no longer supported. The variable THIS is
still set for CLOS methods for the sake of routines like
`call-next-method'.")
(defvar scoped-class nil
"This is set to a class when a method is running.
This is so we know we are allowed to check private parts or how to
execute a `call-next-method'. DO NOT SET THIS YOURSELF!")
(defvar eieio-initializing-object nil
"Set to non-nil while initializing an object.")
@ -410,6 +395,7 @@ It creates an autoload function for CNAME's constructor."
(autoload cname filename doc nil nil)
(autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil)
(autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil)
(autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil)
))))
@ -539,6 +525,23 @@ See `defclass' for more information."
(and (eieio-object-p obj)
(object-of-class-p obj ,cname))))
;; Create a handy list of the class test too
(let ((csym (intern (concat (symbol-name cname) "-list-p"))))
(fset csym
`(lambda (obj)
,(format
"Test OBJ to see if it a list of objects which are a child of type %s"
cname)
(when (listp obj)
(let ((ans t)) ;; nil is valid
;; Loop over all the elements of the input list, test
;; each to make sure it is a child of the desired object class.
(while (and obj ans)
(setq ans (and (eieio-object-p (car obj))
(object-of-class-p (car obj) ,cname)))
(setq obj (cdr obj)))
ans)))))
;; When using typep, (typep OBJ 'myclass) returns t for objects which
;; are subclasses of myclass. For our predicates, however, it is
;; important for EIEIO to be backwards compatible, where
@ -781,6 +784,16 @@ See `defclass' for more information."
(put cname 'variable-documentation
(class-option-assoc options :documentation))
;; Save the file location where this class is defined.
(let ((fname (if load-in-progress
load-file-name
buffer-file-name))
loc)
(when fname
(when (string-match "\\.elc$" fname)
(setq fname (substring fname 0 (1- (length fname)))))
(put cname 'class-location fname)))
;; We have a list of custom groups. Store them into the options.
(let ((g (class-option-assoc options :custom-groups)))
(mapc (lambda (cg) (add-to-list 'g cg)) groups)
@ -1254,8 +1267,10 @@ IMPL is the symbol holding the method implementation."
(eieio-generic-call-methodname ',method)
(eieio-generic-call-arglst local-args)
)
(apply #',impl local-args)
;;(,impl local-args)
,(if (< emacs-major-version 24)
`(apply ,(list 'quote impl) local-args)
`(apply #',impl local-args))
;(,impl local-args)
)))))))
(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
@ -2008,13 +2023,13 @@ reverse-lookup that name, and recurse with the associated slot value."
((not (get fsym 'protection))
(+ 3 fsi))
((and (eq (get fsym 'protection) 'protected)
scoped-class
(bound-and-true-p scoped-class)
(or (child-of-class-p class scoped-class)
(and (eieio-object-p obj)
(child-of-class-p class (object-class obj)))))
(+ 3 fsi))
((and (eq (get fsym 'protection) 'private)
(or (and scoped-class
(or (and (bound-and-true-p scoped-class)
(eieio-slot-originating-class-p scoped-class slot))
eieio-initializing-object))
(+ 3 fsi))
@ -2319,7 +2334,7 @@ If REPLACEMENT-ARGS is non-nil, then use them instead of
arguments passed in at the top level.
Use `next-method-p' to find out if there is a next method to call."
(if (not scoped-class)
(if (not (bound-and-true-p scoped-class))
(error "`call-next-method' not called within a class specific method"))
(if (and (/= eieio-generic-call-key method-primary)
(/= eieio-generic-call-key method-static))
@ -2403,6 +2418,18 @@ CLASS is the class this method is associated with."
(if (< key method-num-lists)
(let ((nsym (intern (symbol-name class) (aref emto key))))
(fset nsym method)))
;; Save the defmethod file location in a symbol property.
(let ((fname (if load-in-progress
load-file-name
buffer-file-name))
loc)
(when fname
(when (string-match "\\.elc$" fname)
(setq fname (substring fname 0 (1- (length fname)))))
(setq loc (get method-name 'method-locations))
(add-to-list 'loc
(list class fname))
(put method-name 'method-locations loc)))
;; Now optimize the entire obarray
(if (< key method-num-lists)
(let ((eieiomt-optimizing-obarray (aref emto key)))
@ -2807,9 +2834,9 @@ this object."
(princ (make-string (* eieio-print-depth 2) ? ))
(princ "(")
(princ (symbol-name (class-constructor (object-class this))))
(princ " \"")
(princ (object-name-string this))
(princ "\"\n")
(princ " ")
(prin1 (object-name-string this))
(princ "\n")
;; Loop over all the public slots
(let ((publa (aref cv class-public-a))
(publd (aref cv class-public-d))
@ -2876,7 +2903,6 @@ of `eq'."
)
;;; Obsolete backward compatibility functions.
;; Needed to run byte-code compiled with the EIEIO of Emacs-23.

14
lisp/emacs-lisp/pcase.el
View file

@ -517,6 +517,10 @@ MATCH is the pattern that needs to be matched, of the form:
(defun pcase--self-quoting-p (upat)
(or (keywordp upat) (numberp upat) (stringp upat)))
(defsubst pcase--mark-used (sym)
;; Exceptionally, `sym' may be a constant expression rather than a symbol.
(if (symbolp sym) (put sym 'pcase-used t)))
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
(defun pcase--u1 (matches code vars rest)
@ -581,7 +585,7 @@ Otherwise, it defers to REST which is a list of branches of the form
((memq upat '(t _)) (pcase--u1 matches code vars rest))
((eq upat 'pcase--dontcare) :pcase--dontcare)
((memq (car-safe upat) '(guard pred))
(if (eq (car upat) 'pred) (put sym 'pcase-used t))
(if (eq (car upat) 'pred) (pcase--mark-used sym))
(let* ((splitrest
(pcase--split-rest
sym (lambda (pat) (pcase--split-pred upat pat)) rest))
@ -614,10 +618,10 @@ Otherwise, it defers to REST which is a list of branches of the form
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
((pcase--self-quoting-p upat)
(put sym 'pcase-used t)
(pcase--mark-used sym)
(pcase--q1 sym upat matches code vars rest))
((symbolp upat)
(put sym 'pcase-used t)
(pcase--mark-used sym)
(if (not (assq upat vars))
(pcase--u1 matches code (cons (cons upat sym) vars) rest)
;; Non-linear pattern. Turn it into an `eq' test.
@ -640,7 +644,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
code vars rest)))
((eq (car-safe upat) '\`)
(put sym 'pcase-used t)
(pcase--mark-used sym)
(pcase--q1 sym (cadr upat) matches code vars rest))
((eq (car-safe upat) 'or)
(let ((all (> (length (cdr upat)) 1))
@ -662,7 +666,7 @@ Otherwise, it defers to REST which is a list of branches of the form
sym (lambda (pat) (pcase--split-member elems pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(put sym 'pcase-used t)
(pcase--mark-used sym)
(pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest)))