procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

lisp/emacs-lisp/eieio-core.el (eieio-backward-compatibility): New var.

Browse source 
* lisp/cedet/ede/speedbar.el (ede-speedbar-compile-line)
(ede-speedbar-get-top-project-for-line):
* lisp/cedet/ede.el (ede-buffer-belongs-to-target-p)
(ede-buffer-belongs-to-project-p, ede-build-forms-menu)
(ede-add-project-to-global-list):
* lisp/cedet/semantic/db-typecache.el (semanticdb-get-typecache):
* lisp/cedet/semantic/db-file.el (semanticdb-load-database):
* lisp/cedet/semantic/db-el.el (semanticdb-elisp-sym->tag):
* lisp/cedet/semantic/db-ebrowse.el (semanticdb-ebrowse-load-helper):
* lisp/cedet/ede/project-am.el (project-am-preferred-target-type):
* lisp/cedet/ede/proj.el (ede-proj-load):
* lisp/cedet/ede/custom.el (ede-customize-current-target, ede-customize-target):
* lisp/cedet/semantic/ede-grammar.el ("semantic grammar"):
* lisp/cedet/semantic/scope.el (semantic-scope-reset-cache)
(semantic-calculate-scope):
* lisp/cedet/srecode/map.el (srecode-map-update-map):
* lisp/cedet/srecode/insert.el (srecode-insert-show-error-report)
(srecode-insert-method, srecode-insert-include-lookup)
(srecode-insert-method):
* lisp/cedet/srecode/fields.el (srecode-active-template-region):
* lisp/cedet/srecode/compile.el (srecode-flush-active-templates)
(srecode-compile-inserter): Don't use <class> as a variable.
Use `oref-default' for class slots.

* lisp/cedet/semantic/grammar.el (semantic-grammar-eldoc-last-data): New var.
(semantic-grammar-eldoc-get-macro-docstring): Use it instead of
eldoc-last-data.
* lisp/cedet/semantic/fw.el (semantic-exit-on-input): Use `declare'.
(semantic-throw-on-input): Use `with-current-buffer'.
* lisp/cedet/semantic/db.el (semanticdb-abstract-table-list): Define if not
pre-defined.
* lisp/cedet/semantic/db-find.el (semanticdb-find-tags-collector):
Use save-current-buffer.
(semanticdb-find-tags-collector): Don't use <class> as a variable.
* lisp/cedet/semantic/complete.el (semantic-complete-active-default)
(semantic-complete-current-matched-tag): Declare.
(semantic-complete-inline-custom-type): Don't use <class> as a variable.
* lisp/cedet/semantic/bovine/make.el (semantic-analyze-possible-completions):
Use with-current-buffer.
* lisp/cedet/semantic.el (semantic-parser-warnings): Declare.
* lisp/cedet/ede/base.el (ede-target-list): Define if not pre-defined.
(ede-with-projectfile): Prefer find-file-noselect over
save-window-excursion.

* lisp/emacs-lisp/chart.el (chart-add-sequence, chart-bar-quickie):
Don't use <class> as a variable.

* lisp/emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
Improve error messages.
(eieio-persistent-slot-type-is-class-p): Handle `list-of' types, as
well as user-defined types.  Emit errors for legacy types like
<class>-child and <class>-list, if not eieio-backward-compatibility.

* lisp/emacs-lisp/eieio-core.el (eieio-backward-compatibility): New var.
(eieio-defclass-autoload): Obey it.
(eieio--class-object): Improve error behavior.
(eieio-class-children-fast, same-class-fast-p): Remove.  Inline at
every use site.
(eieio--defgeneric-form-primary-only): Rename from
eieio-defgeneric-form-primary-only; update all callers.
(eieio--defgeneric-form-primary-only-one): Rename from
eieio-defgeneric-form-primary-only-one; update all callers.
(eieio-defgeneric-reset-generic-form)
(eieio-defgeneric-reset-generic-form-primary-only)
(eieio-defgeneric-reset-generic-form-primary-only-one): Remove.
(eieio--method-optimize-primary): New function to replace them.
(eieio--defmethod, eieio-defmethod): Use it.
(eieio--perform-slot-validation): Rename from
eieio-perform-slot-validation; update all callers.
(eieio--validate-slot-value): Rename from eieio-validate-slot-value.
Change `class' to be a class object.  Update all callers.
(eieio--validate-class-slot-value): Rename from
eieio-validate-class-slot-value.  Change `class' to be a class object.
Update all callers.
(eieio-oset-default): Accept class object as well.
(eieio--generic-call-primary-only): Rename from
eieio-generic-call-primary-only.  Update all callers.

* lisp/emacs-lisp/eieio-opt.el (eieio-read-generic-p): Remove.
(eieio-read-generic): Use `generic-p' instead.

* lisp/emacs-lisp/eieio.el (same-class-p): Accept class object as well.
(call-next-method): Simplify.
(clone): Obey eieio-backward-compatibility.

* lisp/gnus/registry.el: Don't use <class> as a variable.

* test/automated/eieio-test-methodinvoke.el
(eieio-test-method-order-list-4):
Don't use <class> as a variable.

* test/automated/eieio-test-persist.el (persistent-with-objs-list-slot):
Don't use <class>-list type.

* test/automated/eieio-tests.el: Use cl-lib.  Don't use <class> as a variable.
Don't use <class>-list types and <class>-list-p predicates.
This commit is contained in:
Stefan Monnier 2015-01-07 23:11:58 -05:00
parent cb4db86319
commit 1599688e95
39 changed files with 414 additions and 290 deletions
Download patch file Download diff file Expand all files Collapse all files

45
lisp/ChangeLog
View file

@ -1,3 +1,46 @@
2015-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/chart.el (chart-add-sequence, chart-bar-quickie):
Don't use <class> as a variable.
* emacs-lisp/eieio.el (same-class-p): Accept class object as well.
(call-next-method): Simplify.
(clone): Obey eieio-backward-compatibility.
* emacs-lisp/eieio-opt.el (eieio-read-generic-p): Remove.
(eieio-read-generic): Use `generic-p' instead.
* emacs-lisp/eieio-core.el (eieio-backward-compatibility): New var.
(eieio-defclass-autoload): Obey it.
(eieio--class-object): Improve error behavior.
(eieio-class-children-fast, same-class-fast-p): Remove. Inline at
every use site.
(eieio--defgeneric-form-primary-only): Rename from
eieio-defgeneric-form-primary-only; update all callers.
(eieio--defgeneric-form-primary-only-one): Rename from
eieio-defgeneric-form-primary-only-one; update all callers.
(eieio-defgeneric-reset-generic-form)
(eieio-defgeneric-reset-generic-form-primary-only)
(eieio-defgeneric-reset-generic-form-primary-only-one): Remove.
(eieio--method-optimize-primary): New function to replace them.
(eieio--defmethod, eieio-defmethod): Use it.
(eieio--perform-slot-validation): Rename from
eieio-perform-slot-validation; update all callers.
(eieio--validate-slot-value): Rename from eieio-validate-slot-value.
Change `class' to be a class object. Update all callers.
(eieio--validate-class-slot-value): Rename from
eieio-validate-class-slot-value. Change `class' to be a class object.
Update all callers.
(eieio-oset-default): Accept class object as well.
(eieio--generic-call-primary-only): Rename from
eieio-generic-call-primary-only. Update all callers.
* emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
Improve error messages.
(eieio-persistent-slot-type-is-class-p): Handle `list-of' types, as
well as user-defined types. Emit errors for legacy types like
<class>-child and <class>-list, if not eieio-backward-compatibility.
2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca> 2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el (eieio-class-parents): Accept class objects. * emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
@ -22547,7 +22590,7 @@ See ChangeLog.16 for earlier changes.
;; coding: utf-8 ;; coding: utf-8
;; End: ;; End:
Copyright (C) 2011-2014 Free Software Foundation, Inc. Copyright (C) 2011-2015 Free Software Foundation, Inc.
This file is part of GNU Emacs. This file is part of GNU Emacs.

51
lisp/cedet/ChangeLog
View file

@ -1,3 +1,52 @@
2015-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
Don't use <class> as a variable and don't assume that <class>-list-p is
automatically defined.
* ede/speedbar.el (ede-speedbar-compile-line)
(ede-speedbar-get-top-project-for-line):
* ede.el (ede-buffer-belongs-to-target-p)
(ede-buffer-belongs-to-project-p, ede-build-forms-menu)
(ede-add-project-to-global-list):
* semantic/db-typecache.el (semanticdb-get-typecache):
* semantic/db-file.el (semanticdb-load-database):
* semantic/db-el.el (semanticdb-elisp-sym->tag):
* semantic/db-ebrowse.el (semanticdb-ebrowse-load-helper):
* ede/project-am.el (project-am-preferred-target-type):
* ede/proj.el (ede-proj-load):
* ede/custom.el (ede-customize-current-target, ede-customize-target):
* semantic/ede-grammar.el ("semantic grammar"):
* semantic/scope.el (semantic-scope-reset-cache)
(semantic-calculate-scope):
* srecode/map.el (srecode-map-update-map):
* srecode/insert.el (srecode-insert-show-error-report)
(srecode-insert-method, srecode-insert-include-lookup)
(srecode-insert-method):
* srecode/fields.el (srecode-active-template-region):
* srecode/compile.el (srecode-flush-active-templates)
(srecode-compile-inserter): Don't use <class> as a variable.
Use `oref-default' for class slots.
* semantic/grammar.el (semantic-grammar-eldoc-last-data): New var.
(semantic-grammar-eldoc-get-macro-docstring): Use it instead of
eldoc-last-data.
* semantic/fw.el (semantic-exit-on-input): Use `declare'.
(semantic-throw-on-input): Use `with-current-buffer'.
* semantic/db.el (semanticdb-abstract-table-list): Define if not
pre-defined.
* semantic/db-find.el (semanticdb-find-tags-collector):
Use save-current-buffer.
(semanticdb-find-tags-collector): Don't use <class> as a variable.
* semantic/complete.el (semantic-complete-active-default)
(semantic-complete-current-matched-tag): Declare.
(semantic-complete-inline-custom-type): Don't use <class> as a variable.
* semantic/bovine/make.el (semantic-analyze-possible-completions):
Use with-current-buffer.
* semantic.el (semantic-parser-warnings): Declare.
* ede/base.el (ede-target-list): Define if not pre-defined.
(ede-with-projectfile): Prefer find-file-noselect over
save-window-excursion.
2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca> 2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
* srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children. * srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children.
@ -3379,7 +3428,7 @@
;; coding: utf-8 ;; coding: utf-8
;; End: ;; End:
Copyright (C) 2009-2014 Free Software Foundation, Inc. Copyright (C) 2009-2015 Free Software Foundation, Inc.
This file is part of GNU Emacs. This file is part of GNU Emacs.

12
lisp/cedet/ede.el
View file

@ -1,6 +1,6 @@
;;; ede.el --- Emacs Development Environment gloss ;;; ede.el --- Emacs Development Environment gloss
;; Copyright (C) 1998-2005, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 1998-2005, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make ;; Keywords: project, make
@ -248,12 +248,12 @@ Argument LIST-O-O is the list of objects to choose from."
(let ((obj ede-object)) (let ((obj ede-object))
(if (consp obj) (if (consp obj)
(setq obj (car obj))) (setq obj (car obj)))
(and obj (obj-of-class-p obj ede-target)))) (and obj (obj-of-class-p obj 'ede-target))))
(defun ede-buffer-belongs-to-project-p () (defun ede-buffer-belongs-to-project-p ()
"Return non-nil if this buffer belongs to at least one project." "Return non-nil if this buffer belongs to at least one project."
(if (or (null ede-object) (consp ede-object)) nil (if (or (null ede-object) (consp ede-object)) nil
(obj-of-class-p ede-object-project ede-project))) (obj-of-class-p ede-object-project 'ede-project)))
(defun ede-menu-obj-of-class-p (class) (defun ede-menu-obj-of-class-p (class)
"Return non-nil if some member of `ede-object' is a child of CLASS." "Return non-nil if some member of `ede-object' is a child of CLASS."
@ -281,7 +281,7 @@ Argument MENU-DEF is the menu definition to use."
;; First, collect the build items from the project ;; First, collect the build items from the project
(setq newmenu (append newmenu (ede-menu-items-build obj t))) (setq newmenu (append newmenu (ede-menu-items-build obj t)))
;; Second, declare the current target menu items ;; Second, declare the current target menu items
(if (and ede-obj (ede-menu-obj-of-class-p ede-target)) (if (and ede-obj (ede-menu-obj-of-class-p 'ede-target))
(while ede-obj (while ede-obj
(setq newmenu (append newmenu (setq newmenu (append newmenu
(ede-menu-items-build (car ede-obj) t)) (ede-menu-items-build (car ede-obj) t))
@ -1078,7 +1078,7 @@ On success, return the added project."
(error "No project created to add to master list")) (error "No project created to add to master list"))
(when (not (eieio-object-p proj)) (when (not (eieio-object-p proj))
(error "Attempt to add non-object to master project list")) (error "Attempt to add non-object to master project list"))
(when (not (obj-of-class-p proj ede-project-placeholder)) (when (not (obj-of-class-p proj 'ede-project-placeholder))
(error "Attempt to add a non-project to the ede projects list")) (error "Attempt to add a non-project to the ede projects list"))
(add-to-list 'ede-projects proj) (add-to-list 'ede-projects proj)
proj) proj)
@ -1099,6 +1099,8 @@ Flush the dead projects from the project cache."
(ede-delete-project-from-global-list D)) (ede-delete-project-from-global-list D))
)) ))
(defvar ede--disable-inode) ;Defined in ede/files.el.
(defun ede-global-list-sanity-check () (defun ede-global-list-sanity-check ()
"Perform a sanity check to make sure there are no duplicate projects." "Perform a sanity check to make sure there are no duplicate projects."
(interactive) (interactive)

23
lisp/cedet/ede/base.el
View file

@ -1,6 +1,6 @@
;;; ede/base.el --- Baseclasses for EDE. ;;; ede/base.el --- Baseclasses for EDE.
;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -159,6 +159,9 @@ and querying them will cause the actual project to get loaded.")
;; Projects can also affect how EDE works, by changing what appears in ;; Projects can also affect how EDE works, by changing what appears in
;; the EDE menu, or how some keys are bound. ;; the EDE menu, or how some keys are bound.
;; ;;
(unless (fboundp 'ede-target-list-p)
(cl-deftype ede-target-list () '(list-of ede-target)))
(defclass ede-project (ede-project-placeholder) (defclass ede-project (ede-project-placeholder)
((subproj :initform nil ((subproj :initform nil
:type list :type list
@ -287,16 +290,18 @@ All specific project types must derive from this project."
;; ;;
(defmacro ede-with-projectfile (obj &rest forms) (defmacro ede-with-projectfile (obj &rest forms)
"For the project in which OBJ resides, execute FORMS." "For the project in which OBJ resides, execute FORMS."
`(save-window-excursion (declare (indent 1))
(let* ((pf (if (obj-of-class-p ,obj ede-target) (unless (symbolp obj)
(ede-target-parent ,obj) (message "Beware! ede-with-projectfile's first arg is copied: %S" obj))
,obj)) `(let* ((pf (if (obj-of-class-p ,obj 'ede-target)
(dbka (get-file-buffer (oref pf file)))) (ede-target-parent ,obj)
(if (not dbka) (find-file (oref pf file)) ,obj))
(switch-to-buffer dbka)) (dbka (get-file-buffer (oref pf file))))
(with-current-buffer
(if (not dbka) (find-file-noselect (oref pf file))
dbka)
,@forms ,@forms
(if (not dbka) (kill-buffer (current-buffer)))))) (if (not dbka) (kill-buffer (current-buffer))))))
(put 'ede-with-projectfile 'lisp-indent-function 1)
;;; The EDE persistent cache. ;;; The EDE persistent cache.
;; ;;

6
lisp/cedet/ede/custom.el
View file

@ -1,6 +1,6 @@
;;; ede/custom.el --- customization of EDE projects. ;;; ede/custom.el --- customization of EDE projects.
;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -61,7 +61,7 @@
"Edit fields of the current target through EIEIO & Custom." "Edit fields of the current target through EIEIO & Custom."
(interactive) (interactive)
(require 'eieio-custom) (require 'eieio-custom)
(if (not (obj-of-class-p ede-object ede-target)) (if (not (obj-of-class-p ede-object 'ede-target))
(error "Current file is not part of a target")) (error "Current file is not part of a target"))
(ede-customize-target ede-object)) (ede-customize-target ede-object))
@ -72,7 +72,7 @@
"Edit fields of the current target through EIEIO & Custom. "Edit fields of the current target through EIEIO & Custom.
OBJ is the target object to customize." OBJ is the target object to customize."
(require 'eieio-custom) (require 'eieio-custom)
(if (and obj (not (obj-of-class-p obj ede-target))) (if (and obj (not (obj-of-class-p obj 'ede-target)))
(error "No logical target to customize")) (error "No logical target to customize"))
(ede-customize obj)) (ede-customize obj))

4
lisp/cedet/ede/proj.el
View file

@ -1,6 +1,6 @@
;;; ede/proj.el --- EDE Generic Project file driver ;;; ede/proj.el --- EDE Generic Project file driver
;; Copyright (C) 1998-2003, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 1998-2003, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make ;; Keywords: project, make
@ -297,7 +297,7 @@ for the tree being read in. If ROOTPROJ is nil, then assume that
the PROJECT being read in is the root project." the PROJECT being read in is the root project."
(save-excursion (save-excursion
(let ((ret (eieio-persistent-read (concat project "Project.ede") (let ((ret (eieio-persistent-read (concat project "Project.ede")
ede-proj-project)) 'ede-proj-project))
(subdirs (directory-files project nil "[^.].*" nil))) (subdirs (directory-files project nil "[^.].*" nil)))
(if (not (object-of-class-p ret 'ede-proj-project)) (if (not (object-of-class-p ret 'ede-proj-project))
(error "Corrupt project file")) (error "Corrupt project file"))

10
lisp/cedet/ede/project-am.el
View file

@ -1,6 +1,6 @@
;;; project-am.el --- A project management scheme based on automake files. ;;; project-am.el --- A project management scheme based on automake files.
;; Copyright (C) 1998-2000, 2003, 2005, 2007-2014 ;; Copyright (C) 1998-2000, 2003, 2005, 2007-2015
;; Free Software Foundation, Inc. ;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -853,13 +853,13 @@ Argument FILE is the file to extract the end directory name from."
(defun project-am-preferred-target-type (file) (defun project-am-preferred-target-type (file)
"For FILE, return the preferred type for that file." "For FILE, return the preferred type for that file."
(cond ((string-match "\\.texi?\\(nfo\\)$" file) (cond ((string-match "\\.texi?\\(nfo\\)$" file)
project-am-texinfo) 'project-am-texinfo)
((string-match "\\.[0-9]$" file) ((string-match "\\.[0-9]$" file)
project-am-man) 'project-am-man)
((string-match "\\.el$" file) ((string-match "\\.el$" file)
project-am-lisp) 'project-am-lisp)
(t (t
project-am-program))) 'project-am-program)))
(defmethod ede-buffer-header-file((this project-am-objectcode) buffer) (defmethod ede-buffer-header-file((this project-am-objectcode) buffer)
"There are no default header files." "There are no default header files."

10
lisp/cedet/ede/speedbar.el
View file

@ -1,6 +1,6 @@
;;; ede/speedbar.el --- Speedbar viewing of EDE projects ;;; ede/speedbar.el --- Speedbar viewing of EDE projects
;; Copyright (C) 1998-2001, 2003, 2005, 2007-2014 Free Software ;; Copyright (C) 1998-2001, 2003, 2005, 2007-2015 Free Software
;; Foundation, Inc. ;; Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -121,9 +121,9 @@ Argument DIR is the directory from which to derive the list of objects."
(let ((obj (eieio-speedbar-find-nearest-object))) (let ((obj (eieio-speedbar-find-nearest-object)))
(if (not (eieio-object-p obj)) (if (not (eieio-object-p obj))
nil nil
(cond ((obj-of-class-p obj ede-project) (cond ((obj-of-class-p obj 'ede-project)
(project-compile-project obj)) (project-compile-project obj))
((obj-of-class-p obj ede-target) ((obj-of-class-p obj 'ede-target)
(project-compile-target obj)) (project-compile-target obj))
(t (error "Error in speedbar structure")))))) (t (error "Error in speedbar structure"))))))
@ -133,9 +133,9 @@ Argument DIR is the directory from which to derive the list of objects."
(let ((obj (eieio-speedbar-find-nearest-object))) (let ((obj (eieio-speedbar-find-nearest-object)))
(if (not (eieio-object-p obj)) (if (not (eieio-object-p obj))
(error "Error in speedbar or ede structure") (error "Error in speedbar or ede structure")
(if (obj-of-class-p obj ede-target) (if (obj-of-class-p obj 'ede-target)
(setq obj (ede-target-parent obj))) (setq obj (ede-target-parent obj)))
(if (obj-of-class-p obj ede-project) (if (obj-of-class-p obj 'ede-project)
obj obj
(error "Error in speedbar or ede structure"))))) (error "Error in speedbar or ede structure")))))

85
lisp/cedet/semantic.el
View file

@ -1,6 +1,6 @@
;;; semantic.el --- Semantic buffer evaluator. ;;; semantic.el --- Semantic buffer evaluator.
;; Copyright (C) 1999-2014 Free Software Foundation, Inc. ;; Copyright (C) 1999-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax tools ;; Keywords: syntax tools
@ -573,6 +573,7 @@ string."
;; The best way to call the parser from programs is via ;; The best way to call the parser from programs is via
;; `semantic-fetch-tags'. This, in turn, uses other internal ;; `semantic-fetch-tags'. This, in turn, uses other internal
;; API functions which plug-in parsers can take advantage of. ;; API functions which plug-in parsers can take advantage of.
(defvar semantic-parser-warnings)
(defun semantic-fetch-tags () (defun semantic-fetch-tags ()
"Fetch semantic tags from the current buffer. "Fetch semantic tags from the current buffer.
@ -602,49 +603,49 @@ was marked unparseable, then do nothing, and return the cache."
(garbage-collect) (garbage-collect)
(cond (cond
;;;; Try the incremental parser to do a fast update. ;; Try the incremental parser to do a fast update.
((semantic-parse-tree-needs-update-p) ((semantic-parse-tree-needs-update-p)
(setq res (semantic-parse-changes)) (setq res (semantic-parse-changes))
(if (semantic-parse-tree-needs-rebuild-p) (if (semantic-parse-tree-needs-rebuild-p)
;; If the partial reparse fails, jump to a full reparse. ;; If the partial reparse fails, jump to a full reparse.
(semantic-fetch-tags) (semantic-fetch-tags)
;; Clear the cache of unmatched syntax tokens ;; Clear the cache of unmatched syntax tokens
;; ;;
;; NOTE TO SELF: ;; NOTE TO SELF:
;; ;;
;; Move this into the incremental parser. This is a bug. ;; Move this into the incremental parser. This is a bug.
;; ;;
(semantic-clear-unmatched-syntax-cache) (semantic-clear-unmatched-syntax-cache)
(run-hook-with-args ;; Let hooks know the updated tags (run-hook-with-args ;; Let hooks know the updated tags
'semantic-after-partial-cache-change-hook res)) 'semantic-after-partial-cache-change-hook res))
(setq semantic--completion-cache nil)) (setq semantic--completion-cache nil))
;;;; Parse the whole system. ;; Parse the whole system.
((semantic-parse-tree-needs-rebuild-p) ((semantic-parse-tree-needs-rebuild-p)
;; Use Emacs's built-in progress-reporter (only interactive). ;; Use Emacs's built-in progress-reporter (only interactive).
(if noninteractive (if noninteractive
(setq res (semantic-parse-region (point-min) (point-max))) (setq res (semantic-parse-region (point-min) (point-max)))
(let ((semantic--progress-reporter (let ((semantic--progress-reporter
(and (>= (point-max) semantic-minimum-working-buffer-size) (and (>= (point-max) semantic-minimum-working-buffer-size)
(eq semantic-working-type 'percent) (eq semantic-working-type 'percent)
(make-progress-reporter (make-progress-reporter
(semantic-parser-working-message (buffer-name)) (semantic-parser-working-message (buffer-name))
0 100)))) 0 100))))
(setq res (semantic-parse-region (point-min) (point-max))) (setq res (semantic-parse-region (point-min) (point-max)))
(if semantic--progress-reporter (if semantic--progress-reporter
(progress-reporter-done semantic--progress-reporter)))) (progress-reporter-done semantic--progress-reporter))))
;; Clear the caches when we see there were no errors. ;; Clear the caches when we see there were no errors.
;; But preserve the unmatched syntax cache and warnings! ;; But preserve the unmatched syntax cache and warnings!
(let (semantic-unmatched-syntax-cache (let (semantic-unmatched-syntax-cache
semantic-unmatched-syntax-cache-check semantic-unmatched-syntax-cache-check
semantic-parser-warnings) semantic-parser-warnings)
(semantic-clear-toplevel-cache)) (semantic-clear-toplevel-cache))
;; Set up the new overlays ;; Set up the new overlays
(semantic--tag-link-list-to-buffer res) (semantic--tag-link-list-to-buffer res)
;; Set up the cache with the new results ;; Set up the cache with the new results
(semantic--set-buffer-cache res) (semantic--set-buffer-cache res)
)))) ))))
;; Always return the current parse tree. ;; Always return the current parse tree.
semantic--buffer-cache) semantic--buffer-cache)

2
lisp/cedet/semantic/analyze.el
View file

@ -1,6 +1,6 @@
;;; semantic/analyze.el --- Analyze semantic tags against local context ;;; semantic/analyze.el --- Analyze semantic tags against local context
;; Copyright (C) 2000-2005, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2000-2005, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>

7
lisp/cedet/semantic/bovine/make.el
View file

@ -1,6 +1,6 @@
;;; semantic/bovine/make.el --- Makefile parsing rules. ;;; semantic/bovine/make.el --- Makefile parsing rules.
;; Copyright (C) 2000-2004, 2008-2014 Free Software Foundation, Inc. ;; Copyright (C) 2000-2004, 2008-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -178,9 +178,8 @@ This is the same as a regular prototype."
makefile-mode (context) makefile-mode (context)
"Return a list of possible completions in a Makefile. "Return a list of possible completions in a Makefile.
Uses default implementation, and also gets a list of filenames." Uses default implementation, and also gets a list of filenames."
(save-excursion (require 'semantic/analyze/complete)
(require 'semantic/analyze/complete) (with-current-buffer (oref context buffer)
(set-buffer (oref context buffer))
(let* ((normal (semantic-analyze-possible-completions-default context)) (let* ((normal (semantic-analyze-possible-completions-default context))
(classes (oref context :prefixclass)) (classes (oref context :prefixclass))
(filetags nil)) (filetags nil))

6
lisp/cedet/semantic/complete.el
View file

@ -1,6 +1,6 @@
;;; semantic/complete.el --- Routines for performing tag completion ;;; semantic/complete.el --- Routines for performing tag completion
;; Copyright (C) 2003-2005, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2003-2005, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax ;; Keywords: syntax
@ -188,6 +188,8 @@ Value should be a ... what?")
"Default history variable for any unhistoried prompt. "Default history variable for any unhistoried prompt.
Keeps STRINGS only in the history.") Keeps STRINGS only in the history.")
(defvar semantic-complete-active-default)
(defvar semantic-complete-current-matched-tag)
(defun semantic-complete-read-tag-engine (collector displayor prompt (defun semantic-complete-read-tag-engine (collector displayor prompt
default-tag initial-input default-tag initial-input
@ -1871,7 +1873,7 @@ completion text in ghost text."
(list 'const (list 'const
:tag doc1 :tag doc1
C))) C)))
(eieio-build-class-alist semantic-displayor-abstract t)) (eieio-build-class-alist 'semantic-displayor-abstract t))
) )
"Possible options for inline completion displayors. "Possible options for inline completion displayors.
Use this to enable custom editing.") Use this to enable custom editing.")

4
lisp/cedet/semantic/db-ebrowse.el
View file

@ -1,6 +1,6 @@
;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse. ;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse.
;; Copyright (C) 2005-2014 Free Software Foundation, Inc. ;; Copyright (C) 2005-2015 Free Software Foundation, Inc.
;; Authors: Eric M. Ludlam <zappo@gnu.org> ;; Authors: Eric M. Ludlam <zappo@gnu.org>
;; Joakim Verona ;; Joakim Verona
@ -192,7 +192,7 @@ is specified by `semanticdb-default-save-directory'."
If DIRECTORY is found to be defunct, it won't load the DB, and will If DIRECTORY is found to be defunct, it won't load the DB, and will
warn instead." warn instead."
(if (file-directory-p directory) (if (file-directory-p directory)
(semanticdb-create-database semanticdb-project-database-ebrowse (semanticdb-create-database 'semanticdb-project-database-ebrowse
directory) directory)
(let* ((BF (semanticdb-ebrowse-file-for-directory directory)) (let* ((BF (semanticdb-ebrowse-file-for-directory directory))
(BFL (concat BF "-load.el")) (BFL (concat BF "-load.el"))

4
lisp/cedet/semantic/db-el.el
View file

@ -1,6 +1,6 @@
;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp ;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp
;;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;;; Copyright (C) 2002-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags ;; Keywords: tags
@ -225,7 +225,7 @@ TOKTYPE is a hint to the type of tag desired."
(semantic-elisp-desymbolify (semantic-elisp-desymbolify
;; FIXME: This only gives the instance slots and ignores the ;; FIXME: This only gives the instance slots and ignores the
;; class-allocated slots. ;; class-allocated slots.
(eieio--class-public-a (find-class semanticdb-project-database))) ;; slots ;FIXME: eieio-- (eieio--class-public-a (find-class 'semanticdb-project-database))) ;; slots ;FIXME: eieio--
(semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents (semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents
)) ))
((not toktype) ((not toktype)

5
lisp/cedet/semantic/db-file.el
View file

@ -1,6 +1,6 @@
;;; semantic/db-file.el --- Save a semanticdb to a cache file. ;;; semantic/db-file.el --- Save a semanticdb to a cache file.
;;; Copyright (C) 2000-2005, 2007-2014 Free Software Foundation, Inc. ;;; Copyright (C) 2000-2005, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags ;; Keywords: tags
@ -158,7 +158,8 @@ If DIRECTORY doesn't exist, create a new one."
(defun semanticdb-load-database (filename) (defun semanticdb-load-database (filename)
"Load the database FILENAME." "Load the database FILENAME."
(condition-case foo (condition-case foo
(let* ((r (eieio-persistent-read filename semanticdb-project-database-file)) (let* ((r (eieio-persistent-read filename
'semanticdb-project-database-file))
(c (semanticdb-get-database-tables r)) (c (semanticdb-get-database-tables r))
(tv (oref r semantic-tag-version)) (tv (oref r semantic-tag-version))
(fv (oref r semanticdb-version)) (fv (oref r semanticdb-version))

8
lisp/cedet/semantic/db-find.el
View file

@ -1,6 +1,6 @@
;;; semantic/db-find.el --- Searching through semantic databases. ;;; semantic/db-find.el --- Searching through semantic databases.
;; Copyright (C) 2000-2014 Free Software Foundation, Inc. ;; Copyright (C) 2000-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags ;; Keywords: tags
@ -1114,7 +1114,7 @@ for backward compatibility.
If optional argument BRUTISH is non-nil, then ignore include statements, If optional argument BRUTISH is non-nil, then ignore include statements,
and search all tables in this project tree." and search all tables in this project tree."
(let (found match) (let (found match)
(save-excursion (save-current-buffer
;; If path is a buffer, set ourselves up in that buffer ;; If path is a buffer, set ourselves up in that buffer
;; so that the override methods work correctly. ;; so that the override methods work correctly.
(when (bufferp path) (set-buffer path)) (when (bufferp path) (set-buffer path))
@ -1127,7 +1127,7 @@ and search all tables in this project tree."
;; databases and not associated with a file. ;; databases and not associated with a file.
(unless (and find-file-match (unless (and find-file-match
(obj-of-class-p (obj-of-class-p
(car tableandtags) semanticdb-search-results-table)) (car tableandtags) 'semanticdb-search-results-table))
(when (setq match (funcall function (when (setq match (funcall function
(car tableandtags) (cdr tableandtags))) (car tableandtags) (cdr tableandtags)))
(when find-file-match (when find-file-match
@ -1144,7 +1144,7 @@ and search all tables in this project tree."
;; `semanticdb-search-results-table', since those are system ;; `semanticdb-search-results-table', since those are system
;; databases and not associated with a file. ;; databases and not associated with a file.
(unless (and find-file-match (unless (and find-file-match
(obj-of-class-p table semanticdb-search-results-table)) (obj-of-class-p table 'semanticdb-search-results-table))
(when (and table (setq match (funcall function table nil))) (when (and table (setq match (funcall function table nil)))
(semanticdb-find-log-activity table match) (semanticdb-find-log-activity table match)
(when find-file-match (when find-file-match

4
lisp/cedet/semantic/db-typecache.el
View file

@ -1,6 +1,6 @@
;;; semantic/db-typecache.el --- Manage Datatypes ;;; semantic/db-typecache.el --- Manage Datatypes
;; Copyright (C) 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com> ;; Author: Eric M. Ludlam <eric@siege-engine.com>
@ -180,7 +180,7 @@ If there is no table, create one, and fill it in."
(defmethod semanticdb-get-typecache ((db semanticdb-project-database)) (defmethod semanticdb-get-typecache ((db semanticdb-project-database))
"Retrieve the typecache from the semantic database DB. "Retrieve the typecache from the semantic database DB.
If there is no table, create one, and fill it in." If there is no table, create one, and fill it in."
(semanticdb-cache-get db semanticdb-database-typecache) (semanticdb-cache-get db 'semanticdb-database-typecache)
) )

6
lisp/cedet/semantic/db.el
View file

@ -1,6 +1,6 @@
;;; semantic/db.el --- Semantic tag database manager ;;; semantic/db.el --- Semantic tag database manager
;; Copyright (C) 2000-2014 Free Software Foundation, Inc. ;; Copyright (C) 2000-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags ;; Keywords: tags
@ -330,6 +330,10 @@ Adds the number of tags in this file to the object print name."
;;; DATABASE BASE CLASS ;;; DATABASE BASE CLASS
;; ;;
(unless (fboundp 'semanticdb-abstract-table-list-p)
(cl-deftype semanticdb-abstract-table-list ()
'(list-of semanticdb-abstract-table)))
(defclass semanticdb-project-database (eieio-instance-tracker) (defclass semanticdb-project-database (eieio-instance-tracker)
((tracking-symbol :initform semanticdb-database-list) ((tracking-symbol :initform semanticdb-database-list)
(reference-directory :type string (reference-directory :type string

4
lisp/cedet/semantic/ede-grammar.el
View file

@ -1,6 +1,6 @@
;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files ;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
;; Copyright (C) 2003-2004, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2003-2004, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make ;; Keywords: project, make
@ -213,7 +213,7 @@ Argument THIS is the target that should insert stuff."
;; "Target class for Emacs/Semantic grammar files." nil nil) ;; "Target class for Emacs/Semantic grammar files." nil nil)
(ede-proj-register-target "semantic grammar" (ede-proj-register-target "semantic grammar"
semantic-ede-proj-target-grammar) 'semantic-ede-proj-target-grammar)
(provide 'semantic/ede-grammar) (provide 'semantic/ede-grammar)

21
lisp/cedet/semantic/fw.el
View file

@ -1,6 +1,6 @@
;;; semantic/fw.el --- Framework for Semantic ;;; semantic/fw.el --- Framework for Semantic
;;; Copyright (C) 1999-2014 Free Software Foundation, Inc. ;;; Copyright (C) 1999-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -378,11 +378,11 @@ If FORMS includes a call to `semantic-throw-on-input', then
if a user presses any key during execution, this form macro if a user presses any key during execution, this form macro
will exit with the value passed to `semantic-throw-on-input'. will exit with the value passed to `semantic-throw-on-input'.
If FORMS completes, then the return value is the same as `progn'." If FORMS completes, then the return value is the same as `progn'."
(declare (indent 1))
`(let ((semantic-current-input-throw-symbol ,symbol) `(let ((semantic-current-input-throw-symbol ,symbol)
(semantic--on-input-start-marker (point-marker))) (semantic--on-input-start-marker (point-marker)))
(catch ,symbol (catch ,symbol
,@forms))) ,@forms)))
(put 'semantic-exit-on-input 'lisp-indent-function 1)
(defmacro semantic-throw-on-input (from) (defmacro semantic-throw-on-input (from)
"Exit with `throw' when in `semantic-exit-on-input' on user input. "Exit with `throw' when in `semantic-exit-on-input' on user input.
@ -391,15 +391,14 @@ to pass to `throw'. It is recommended to use the name of the function
calling this one." calling this one."
`(when (and semantic-current-input-throw-symbol `(when (and semantic-current-input-throw-symbol
(or (input-pending-p) (or (input-pending-p)
(save-excursion (with-current-buffer
;; Timers might run during accept-process-output. ;; Timers might run during accept-process-output.
;; If they redisplay, point must be where the user ;; If they redisplay, point must be where the user
;; expects. (Bug#15045) ;; expects. (Bug#15045)
(set-buffer (marker-buffer (marker-buffer semantic--on-input-start-marker)
semantic--on-input-start-marker)) (save-excursion
(goto-char (marker-position (goto-char semantic--on-input-start-marker)
semantic--on-input-start-marker)) (accept-process-output)))))
(accept-process-output))))
(throw semantic-current-input-throw-symbol ,from))) (throw semantic-current-input-throw-symbol ,from)))

11
lisp/cedet/semantic/grammar.el
View file

@ -1,6 +1,6 @@
;;; semantic/grammar.el --- Major mode framework for Semantic grammars ;;; semantic/grammar.el --- Major mode framework for Semantic grammars
;; Copyright (C) 2002-2005, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2002-2005, 2007-2015 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com> ;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com> ;; Maintainer: David Ponce <david@dponce.com>
@ -1665,13 +1665,14 @@ Select the buffer containing the tag's definition, and move point there."
(declare-function eldoc-get-fnsym-args-string "eldoc") (declare-function eldoc-get-fnsym-args-string "eldoc")
(declare-function eldoc-get-var-docstring "eldoc") (declare-function eldoc-get-var-docstring "eldoc")
(defvar semantic-grammar-eldoc-last-data (cons nil nil))
(defun semantic-grammar-eldoc-get-macro-docstring (macro expander) (defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
"Return a one-line docstring for the given grammar MACRO. "Return a one-line docstring for the given grammar MACRO.
EXPANDER is the name of the function that expands MACRO." EXPANDER is the name of the function that expands MACRO."
(require 'eldoc) (require 'eldoc)
(if (and (eq expander (aref eldoc-last-data 0)) (if (eq expander (car semantic-grammar-eldoc-last-data))
(eq 'function (aref eldoc-last-data 2))) (cdr semantic-grammar-eldoc-last-data)
(aref eldoc-last-data 1)
(let ((doc (help-split-fundoc (documentation expander t) expander))) (let ((doc (help-split-fundoc (documentation expander t) expander)))
(cond (cond
(doc (doc
@ -1684,7 +1685,7 @@ EXPANDER is the name of the function that expands MACRO."
(setq doc (setq doc
(eldoc-docstring-format-sym-doc (eldoc-docstring-format-sym-doc
macro (format "==> %s %s" expander doc) 'default)) macro (format "==> %s %s" expander doc) 'default))
(eldoc-last-data-store expander doc 'function)) (setq semantic-grammar-eldoc-last-data (cons expander doc)))
doc))) doc)))
(define-mode-local-override semantic-idle-summary-current-symbol-info (define-mode-local-override semantic-idle-summary-current-symbol-info

2
lisp/cedet/semantic/ia.el
View file

@ -1,6 +1,6 @@
;;; semantic/ia.el --- Interactive Analysis functions ;;; semantic/ia.el --- Interactive Analysis functions
;;; Copyright (C) 2000-2014 Free Software Foundation, Inc. ;;; Copyright (C) 2000-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax ;; Keywords: syntax

2
lisp/cedet/semantic/idle.el
View file

@ -1,6 +1,6 @@
;;; idle.el --- Schedule parsing tasks in idle time ;;; idle.el --- Schedule parsing tasks in idle time
;; Copyright (C) 2003-2006, 2008-2014 Free Software Foundation, Inc. ;; Copyright (C) 2003-2006, 2008-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax ;; Keywords: syntax

6
lisp/cedet/semantic/scope.el
View file

@ -1,6 +1,6 @@
;;; semantic/scope.el --- Analyzer Scope Calculations ;;; semantic/scope.el --- Analyzer Scope Calculations
;; Copyright (C) 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com> ;; Author: Eric M. Ludlam <eric@siege-engine.com>
@ -134,7 +134,7 @@ Saves scoping information between runs of the analyzer.")
"Get the current cached scope, and reset it." "Get the current cached scope, and reset it."
(when semanticdb-current-table (when semanticdb-current-table
(let ((co (semanticdb-cache-get semanticdb-current-table (let ((co (semanticdb-cache-get semanticdb-current-table
semantic-scope-cache))) 'semantic-scope-cache)))
(semantic-reset co)))) (semantic-reset co))))
(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache) (defmethod semantic-scope-set-typecache ((cache semantic-scope-cache)
@ -706,7 +706,7 @@ The class returned from the scope calculation is variable
(let* ((TAG (semantic-current-tag)) (let* ((TAG (semantic-current-tag))
(scopecache (scopecache
(semanticdb-cache-get semanticdb-current-table (semanticdb-cache-get semanticdb-current-table
semantic-scope-cache)) 'semantic-scope-cache))
) )
(when (not (semantic-equivalent-tag-p TAG (oref scopecache tag))) (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag)))
(semantic-reset scopecache)) (semantic-reset scopecache))

10
lisp/cedet/srecode/compile.el
View file

@ -1,6 +1,6 @@
;;; srecode/compile --- Compilation of srecode template files. ;;; srecode/compile --- Compilation of srecode template files.
;; Copyright (C) 2005, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2005, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: codegeneration ;; Keywords: codegeneration
@ -87,10 +87,10 @@ for push, pop, and peek for the active template.")
Useful if something goes wrong in SRecode, and the active template Useful if something goes wrong in SRecode, and the active template
stack is broken." stack is broken."
(interactive) (interactive)
(if (oref srecode-template active) (if (oref-default 'srecode-template active)
(when (y-or-n-p (format "%d active templates. Flush? " (when (y-or-n-p (format "%d active templates. Flush? "
(length (oref srecode-template active)))) (length (oref-default 'srecode-template active))))
(oset-default srecode-template active nil)) (oset-default 'srecode-template active nil))
(message "No active templates to flush.")) (message "No active templates to flush."))
) )
@ -514,7 +514,7 @@ to the inserter constructor."
;;(message "Compile: %s %S" name props) ;;(message "Compile: %s %S" name props)
(if (not key) (if (not key)
(apply 'srecode-template-inserter-variable name props) (apply 'srecode-template-inserter-variable name props)
(let ((classes (eieio-class-children srecode-template-inserter)) (let ((classes (eieio-class-children 'srecode-template-inserter))
(new nil)) (new nil))
;; Loop over the various subclasses and ;; Loop over the various subclasses and
;; create the correct inserter. ;; create the correct inserter.

4
lisp/cedet/srecode/fields.el
View file

@ -1,6 +1,6 @@
;;; srecode/fields.el --- Handling type-in fields in a buffer. ;;; srecode/fields.el --- Handling type-in fields in a buffer.
;; ;;
;; Copyright (C) 2009-2014 Free Software Foundation, Inc. ;; Copyright (C) 2009-2015 Free Software Foundation, Inc.
;; ;;
;; Author: Eric M. Ludlam <eric@siege-engine.com> ;; Author: Eric M. Ludlam <eric@siege-engine.com>
@ -237,7 +237,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
(defsubst srecode-active-template-region () (defsubst srecode-active-template-region ()
"Return the active region for template fields." "Return the active region for template fields."
(oref srecode-template-inserted-region active-region)) (oref-default 'srecode-template-inserted-region active-region))
(defun srecode-field-post-command () (defun srecode-field-post-command ()
"Srecode field handler in the post command hook." "Srecode field handler in the post command hook."

12
lisp/cedet/srecode/insert.el
View file

@ -1,6 +1,6 @@
;;; srecode/insert.el --- Insert srecode templates to an output stream. ;;; srecode/insert.el --- Insert srecode templates to an output stream.
;; Copyright (C) 2005, 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2005, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -211,7 +211,7 @@ insertions."
(propertize " (most recent at bottom)" 'face '(:slant italic)) (propertize " (most recent at bottom)" 'face '(:slant italic))
":\n") ":\n")
(data-debug-insert-stuff-list (data-debug-insert-stuff-list
(reverse (oref srecode-template active)) "> ") (reverse (oref-default 'srecode-template active)) "> ")
;; Show the current dictionary. ;; Show the current dictionary.
(insert (propertize "Dictionary" 'face '(:weight bold)) "\n") (insert (propertize "Dictionary" 'face '(:weight bold)) "\n")
(data-debug-insert-thing dictionary "" "> ") (data-debug-insert-thing dictionary "" "> ")
@ -396,7 +396,7 @@ Specify the :blank argument to enable this inserter.")
(pm (point-marker))) (pm (point-marker)))
(when (and inbuff (when (and inbuff
;; Don't do this if we are not the active template. ;; Don't do this if we are not the active template.
(= (length (oref srecode-template active)) 1)) (= (length (oref-default 'srecode-template active)) 1))
(when (and (eq i t) inbuff (not (eq (oref sti where) 'begin))) (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
(indent-according-to-mode) (indent-according-to-mode)
@ -773,7 +773,7 @@ generalized marker will do something else. See
;; valid. Compare this to the actual template nesting depth and ;; valid. Compare this to the actual template nesting depth and
;; maybe use the override function which is stored in the cdr. ;; maybe use the override function which is stored in the cdr.
(if (and srecode-template-inserter-point-override (if (and srecode-template-inserter-point-override
(<= (length (oref srecode-template active)) (<= (length (oref-default 'srecode-template active))
(car srecode-template-inserter-point-override))) (car srecode-template-inserter-point-override)))
;; Disable the old override while we do this. ;; Disable the old override while we do this.
(let ((over (cdr srecode-template-inserter-point-override)) (let ((over (cdr srecode-template-inserter-point-override))
@ -943,7 +943,7 @@ this template instance."
;; Calculate and store the discovered template ;; Calculate and store the discovered template
(let ((tmpl (srecode-template-get-table (srecode-table) (let ((tmpl (srecode-template-get-table (srecode-table)
templatenamepart)) templatenamepart))
(active (oref srecode-template active)) (active (oref-default 'srecode-template active))
ctxt) ctxt)
(when (not tmpl) (when (not tmpl)
;; If it isn't just available, scan back through ;; If it isn't just available, scan back through
@ -1053,7 +1053,7 @@ template where a ^ inserter occurs."
(lexical-let ((inserter1 sti)) (lexical-let ((inserter1 sti))
(cons (cons
;; DEPTH ;; DEPTH
(+ (length (oref srecode-template active)) 1) (+ (length (oref-default 'srecode-template active)) 1)
;; FUNCTION ;; FUNCTION
(lambda (dict) (lambda (dict)
(let ((srecode-template-inserter-point-override nil)) (let ((srecode-template-inserter-point-override nil))

4
lisp/cedet/srecode/map.el
View file

@ -1,6 +1,6 @@
;;; srecode/map.el --- Manage a template file map ;;; srecode/map.el --- Manage a template file map
;; Copyright (C) 2008-2014 Free Software Foundation, Inc. ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com> ;; Author: Eric M. Ludlam <eric@siege-engine.com>
@ -298,7 +298,7 @@ if that file is NEW, otherwise assume the mode has not changed."
(when (not srecode-current-map) (when (not srecode-current-map)
(condition-case nil (condition-case nil
(setq srecode-current-map (setq srecode-current-map
(eieio-persistent-read srecode-map-save-file srecode-map)) (eieio-persistent-read srecode-map-save-file 'srecode-map))
(error (error
;; There was an error loading the old map. Create a new one. ;; There was an error loading the old map. Create a new one.
(setq srecode-current-map (setq srecode-current-map

10
lisp/emacs-lisp/chart.el
View file

@ -422,7 +422,7 @@ or is created with the bounds of SEQ."
(if (stringp (car (oref seq data))) (if (stringp (car (oref seq data)))
(let ((labels (oref seq data))) (let ((labels (oref seq data)))
(if (not axis) (if (not axis)
(setq axis (make-instance chart-axis-names (setq axis (make-instance 'chart-axis-names
:name (oref seq name) :name (oref seq name)
:items labels :items labels
:chart c)) :chart c))
@ -430,7 +430,7 @@ or is created with the bounds of SEQ."
(let ((range (cons 0 1)) (let ((range (cons 0 1))
(l (oref seq data))) (l (oref seq data)))
(if (not axis) (if (not axis)
(setq axis (make-instance chart-axis-range (setq axis (make-instance 'chart-axis-range
:name (oref seq name) :name (oref seq name)
:chart c))) :chart c)))
(while l (while l
@ -577,19 +577,19 @@ labeled NUMTITLE.
Optional arguments: Optional arguments:
Set the chart's max element display to MAX, and sort lists with Set the chart's max element display to MAX, and sort lists with
SORT-PRED if desired." SORT-PRED if desired."
(let ((nc (make-instance chart-bar (let ((nc (make-instance 'chart-bar
:title title :title title
:key-label "8-m" ; This is a text key pic :key-label "8-m" ; This is a text key pic
:direction dir :direction dir
)) ))
(iv (eq dir 'vertical))) (iv (eq dir 'vertical)))
(chart-add-sequence nc (chart-add-sequence nc
(make-instance chart-sequece (make-instance 'chart-sequece
:data namelst :data namelst
:name nametitle) :name nametitle)
(if iv 'x-axis 'y-axis)) (if iv 'x-axis 'y-axis))
(chart-add-sequence nc (chart-add-sequence nc
(make-instance chart-sequece (make-instance 'chart-sequece
:data numlst :data numlst
:name numtitle) :name numtitle)
(if iv 'y-axis 'x-axis)) (if iv 'y-axis 'x-axis))

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

@ -333,8 +333,8 @@ Second, any text properties will be stripped from strings."
(unless (and (unless (and
;; Do we have a type? ;; Do we have a type?
(consp classtype) (class-p (car classtype))) (consp classtype) (class-p (car classtype)))
(error "In save file, list of object constructors found, but no :type specified for slot %S" (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
slot)) slot classtype))
;; We have a predicate, but it doesn't satisfy the predicate? ;; We have a predicate, but it doesn't satisfy the predicate?
(dolist (PV (cdr proposed-value)) (dolist (PV (cdr proposed-value))
@ -367,10 +367,24 @@ If no class is referenced there, then return nil."
(cond ((class-p type) (cond ((class-p type)
;; If the type is a class, then return it. ;; If the type is a class, then return it.
type) type)
((and (eq 'list-of (car-safe type)) (class-p (cadr type)))
;; If it is the type of a list of a class, then return that class and
;; the type.
(cons (cadr type) type))
((and (symbolp type) (get type 'cl-deftype-handler))
;; Macro-expand the type according to cl-deftype definitions.
(eieio-persistent-slot-type-is-class-p
(funcall (get type 'cl-deftype-handler))))
;; FIXME: foo-child should not be a valid type! ;; FIXME: foo-child should not be a valid type!
((and (symbolp type) (string-match "-child\\'" (symbol-name type)) ((and (symbolp type) (string-match "-child\\'" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 0 (class-p (intern-soft (substring (symbol-name type) 0
(match-beginning 0))))) (match-beginning 0)))))
(unless eieio-backward-compatibility
(error "Use of bogus %S type instead of %S"
type (intern-soft (substring (symbol-name type) 0
(match-beginning 0)))))
;; If it is the predicate ending with -child, then return ;; If it is the predicate ending with -child, then return
;; that class. Unfortunately, in EIEIO, typep of just the ;; that class. Unfortunately, in EIEIO, typep of just the
;; class is the same as if we used -child, so no further work needed. ;; class is the same as if we used -child, so no further work needed.
@ -380,13 +394,17 @@ If no class is referenced there, then return nil."
((and (symbolp type) (string-match "-list\\'" (symbol-name type)) ((and (symbolp type) (string-match "-list\\'" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 0 (class-p (intern-soft (substring (symbol-name type) 0
(match-beginning 0))))) (match-beginning 0)))))
(unless eieio-backward-compatibility
(error "Use of bogus %S type instead of (list-of %S)"
type (intern-soft (substring (symbol-name type) 0
(match-beginning 0)))))
;; If it is the predicate ending with -list, then return ;; If it is the predicate ending with -list, then return
;; that class and the predicate to use. ;; that class and the predicate to use.
(cons (intern-soft (substring (symbol-name type) 0 (cons (intern-soft (substring (symbol-name type) 0
(match-beginning 0))) (match-beginning 0)))
type)) type))
((and (consp type) (eq (car type) 'or)) ((eq (car-safe type) 'or)
;; If type is a list, and is an or, it is possibly something ;; If type is a list, and is an or, it is possibly something
;; like (or null myclass), so check for that. ;; like (or null myclass), so check for that.
(let ((ans nil)) (let ((ans nil))

193
lisp/emacs-lisp/eieio-core.el
View file

@ -77,6 +77,13 @@ default setting for optimization purposes.")
(defvar eieio-initializing-object nil (defvar eieio-initializing-object nil
"Set to non-nil while initializing an object.") "Set to non-nil while initializing an object.")
(defvar eieio-backward-compatibility t
"If nil, drop support for some behaviors of older versions of EIEIO.
Currently under control of this var:
- Define every class as a var whose value is the class symbol.
- Define <class>-child-p and <class>-list-p predicates.
- Allow object names in constructors.")
(defconst eieio-unbound (defconst eieio-unbound
(if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound))
eieio-unbound eieio-unbound
@ -217,7 +224,10 @@ Stored outright without modifications or stripping.")))
(defsubst eieio--class-object (class) (defsubst eieio--class-object (class)
"Return the class object." "Return the class object."
(if (symbolp class) (eieio--class-v class) class)) (if (symbolp class)
;; Keep the symbol if class-v is nil, for better error messages.
(or (eieio--class-v class) class)
class))
(defsubst eieio--class-p (class) (defsubst eieio--class-p (class)
"Return non-nil if CLASS is a valid class object." "Return non-nil if CLASS is a valid class object."
@ -251,16 +261,6 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
(format "#<class %s>" (symbol-name class))) (format "#<class %s>" (symbol-name class)))
(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check."
;; FIXME: Remove. And change `children' to contain class objects rather than
;; class names.
`(eieio--class-children (eieio--class-v ,class)))
(defsubst same-class-fast-p (obj class-name)
"Return t if OBJ is of class-type CLASS-NAME with no error checking."
;; (eq (eieio--object-class-name obj) class)
(eq (eieio--object-class-object obj) (eieio--class-object class-name)))
(defmacro class-constructor (class) (defmacro class-constructor (class)
"Return the symbol representing the constructor of CLASS." "Return the symbol representing the constructor of CLASS."
(declare (debug t)) (declare (debug t))
@ -388,7 +388,8 @@ It creates an autoload function for CNAME's constructor."
(push (eieio--class-v SC) (eieio--class-parent newc))) (push (eieio--class-v SC) (eieio--class-parent newc)))
;; turn this into a usable self-pointing symbol ;; turn this into a usable self-pointing symbol
(set cname cname) (when eieio-backward-compatibility
(set cname cname))
;; Store the new class vector definition into the symbol. We need to ;; Store the new class vector definition into the symbol. We need to
;; do this first so that we can call defmethod for the accessor. ;; do this first so that we can call defmethod for the accessor.
@ -499,7 +500,8 @@ See `defclass' for more information."
(setf (eieio--class-parent newc) (list eieio-default-superclass)))) (setf (eieio--class-parent newc) (list eieio-default-superclass))))
;; turn this into a usable self-pointing symbol; FIXME: Why? ;; turn this into a usable self-pointing symbol; FIXME: Why?
(set cname cname) (when eieio-backward-compatibility
(set cname cname))
;; These two tests must be created right away so we can have self- ;; These two tests must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only ;; referencing classes. ei, a class whose slot can contain only
@ -520,7 +522,9 @@ See `defclass' for more information."
)) ))
;; Create a handy child test too ;; Create a handy child test too
(let ((csym (intern (concat (symbol-name cname) "-child-p")))) (let ((csym (if eieio-backward-compatibility
(intern (concat (symbol-name cname) "-child-p"))
(make-symbol (concat (symbol-name cname) "-child-p")))))
(fset csym (fset csym
`(lambda (obj) `(lambda (obj)
,(format ,(format
@ -540,21 +544,22 @@ See `defclass' for more information."
(put cname 'cl-deftype-satisfies csym)) (put cname 'cl-deftype-satisfies csym))
;; Create a handy list of the class test too ;; Create a handy list of the class test too
(let ((csym (intern (concat (symbol-name cname) "-list-p")))) (when eieio-backward-compatibility
(fset csym (let ((csym (intern (concat (symbol-name cname) "-list-p"))))
`(lambda (obj) (fset csym
,(format `(lambda (obj)
"Test OBJ to see if it a list of objects which are a child of type %s" ,(format
cname) "Test OBJ to see if it a list of objects which are a child of type %s"
(when (listp obj) cname)
(let ((ans t)) ;; nil is valid (when (listp obj)
;; Loop over all the elements of the input list, test (let ((ans t)) ;; nil is valid
;; each to make sure it is a child of the desired object class. ;; Loop over all the elements of the input list, test
(while (and obj ans) ;; each to make sure it is a child of the desired object class.
(setq ans (and (eieio-object-p (car obj)) (while (and obj ans)
(object-of-class-p (car obj) ,cname))) (setq ans (and (eieio-object-p (car obj))
(setq obj (cdr obj))) (object-of-class-p (car obj) ,cname)))
ans))))) (setq obj (cdr obj)))
ans))))))
;; Before adding new slots, let's add all the methods and classes ;; Before adding new slots, let's add all the methods and classes
;; in from the parent class. ;; in from the parent class.
@ -767,7 +772,8 @@ See `defclass' for more information."
(if (and slots (if (and slots
(let ((x (car slots))) (let ((x (car slots)))
(or (stringp x) (null x)))) (or (stringp x) (null x))))
(message "Obsolete name %S passed to %S constructor" (funcall (if eieio-backward-compatibility #'ignore #'message)
"Obsolete name %S passed to %S constructor"
(pop slots) ',cname)) (pop slots) ',cname))
(apply #'eieio-constructor ',cname slots))) (apply #'eieio-constructor ',cname slots)))
) )
@ -833,7 +839,7 @@ If SKIPNIL is non-nil, then if VALUE is nil return t instead."
(if (not (or (eieio-eval-default-p value) ;FIXME: Why? (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
eieio-skip-typecheck eieio-skip-typecheck
(and skipnil (null value)) (and skipnil (null value))
(eieio-perform-slot-validation spec value))) (eieio--perform-slot-validation spec value)))
(signal 'invalid-slot-type (list slot spec value)))) (signal 'invalid-slot-type (list slot spec value))))
(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc (defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc
@ -1155,24 +1161,12 @@ DOC-STRING is the documentation attached to METHOD."
(lambda (&rest local-args) (lambda (&rest local-args)
(eieio-generic-call method local-args))) (eieio-generic-call method local-args)))
(defsubst eieio-defgeneric-reset-generic-form (method) (defun eieio--defgeneric-form-primary-only (method)
"Setup METHOD to call the generic form."
(let ((doc-string (documentation method 'raw)))
(put method 'function-documentation doc-string)
(fset method (eieio-defgeneric-form method))))
(defun eieio-defgeneric-form-primary-only (method)
"The lambda form that would be used as the function defined on METHOD. "The lambda form that would be used as the function defined on METHOD.
All methods should call the same EIEIO function for dispatch. All methods should call the same EIEIO function for dispatch.
DOC-STRING is the documentation attached to METHOD." DOC-STRING is the documentation attached to METHOD."
(lambda (&rest local-args) (lambda (&rest local-args)
(eieio-generic-call-primary-only method local-args))) (eieio--generic-call-primary-only method local-args)))
(defsubst eieio-defgeneric-reset-generic-form-primary-only (method)
"Setup METHOD to call the generic form."
(let ((doc-string (documentation method 'raw)))
(put method 'function-documentation doc-string)
(fset method (eieio-defgeneric-form-primary-only method))))
(declare-function no-applicable-method "eieio" (object method &rest args)) (declare-function no-applicable-method "eieio" (object method &rest args))
@ -1186,7 +1180,7 @@ Keys are a number representing :before, :primary, and :after methods.")
During executions, the list is first generated, then as each next method During executions, the list is first generated, then as each next method
is called, the next method is popped off the stack.") is called, the next method is popped off the stack.")
(defun eieio-defgeneric-form-primary-only-one (method class impl) (defun eieio--defgeneric-form-primary-only-one (method class impl)
"The lambda form that would be used as the function defined on METHOD. "The lambda form that would be used as the function defined on METHOD.
All methods should call the same EIEIO function for dispatch. All methods should call the same EIEIO function for dispatch.
CLASS is the class symbol needed for private method access. CLASS is the class symbol needed for private method access.
@ -1219,16 +1213,6 @@ IMPL is the symbol holding the method implementation."
(eieio--with-scoped-class (eieio--class-v class) (eieio--with-scoped-class (eieio--class-v class)
(apply impl local-args))))))) (apply impl local-args)))))))
(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
"Setup METHOD to call the generic form."
(let* ((doc-string (documentation method 'raw))
(M (get method 'eieio-method-tree))
(entry (car (aref M eieio--method-primary)))
)
(put method 'function-documentation doc-string)
(fset method (eieio-defgeneric-form-primary-only-one
method (car entry) (cdr entry)))))
(defun eieio-unbind-method-implementations (method) (defun eieio-unbind-method-implementations (method)
"Make the generic method METHOD have no implementations. "Make the generic method METHOD have no implementations.
It will leave the original generic function in place, It will leave the original generic function in place,
@ -1236,6 +1220,27 @@ but remove reference to all implementations of METHOD."
(put method 'eieio-method-tree nil) (put method 'eieio-method-tree nil)
(put method 'eieio-method-hashtable nil)) (put method 'eieio-method-hashtable nil))
(defun eieio--method-optimize-primary (method)
(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.
(let ((doc-string (documentation method 'raw)))
(put method 'function-documentation doc-string)
;; Use `defalias' so as to interact properly with nadvice.el.
(defalias method
(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)
(let* ((M (get method 'eieio-method-tree))
(entry (car (aref M eieio--method-primary))))
(eieio--defgeneric-form-primary-only-one
method (car entry) (cdr entry)))
(eieio--defgeneric-form-primary-only method))
(eieio-defgeneric-form method))))))
(defun eieio--defmethod (method kind argclass code) (defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS." "Work part of the `defmethod' macro defining METHOD with ARGS."
(let ((key (let ((key
@ -1272,18 +1277,7 @@ but remove reference to all implementations of METHOD."
(eieiomt-add method code key argclass) (eieiomt-add method code key argclass)
) )
(when eieio-optimize-primary-methods-flag (eieio--method-optimize-primary method)
;; 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) method)
@ -1293,13 +1287,13 @@ but remove reference to all implementations of METHOD."
;; requiring the CL library at run-time. It can be eliminated if/when ;; requiring the CL library at run-time. It can be eliminated if/when
;; `typep' is merged into Emacs core. ;; `typep' is merged into Emacs core.
(defun eieio-perform-slot-validation (spec value) (defun eieio--perform-slot-validation (spec value)
"Return non-nil if SPEC does not match VALUE." "Return non-nil if SPEC does not match VALUE."
(or (eq spec t) ; t always passes (or (eq spec t) ; t always passes
(eq value eieio-unbound) ; unbound always passes (eq value eieio-unbound) ; unbound always passes
(cl-typep value spec))) (cl-typep value spec)))
(defun eieio-validate-slot-value (class slot-idx value slot) (defun eieio--validate-slot-value (class slot-idx value slot)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
Checks the :type specifier. Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing SLOT is the slot that is being checked, and is only used when throwing
@ -1308,21 +1302,23 @@ an error."
nil nil
;; Trim off object IDX junk added in for the object index. ;; Trim off object IDX junk added in for the object index.
(setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
(let ((st (aref (eieio--class-public-type (eieio--class-v class)) slot-idx))) (let ((st (aref (eieio--class-public-type class) slot-idx)))
(if (not (eieio-perform-slot-validation st value)) (if (not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type (list class slot st value)))))) (signal 'invalid-slot-type
(list (eieio--class-symbol class) slot st value))))))
(defun eieio-validate-class-slot-value (class slot-idx value slot) (defun eieio--validate-class-slot-value (class slot-idx value slot)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
Checks the :type specifier. Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing SLOT is the slot that is being checked, and is only used when throwing
an error." an error."
(if eieio-skip-typecheck (if eieio-skip-typecheck
nil nil
(let ((st (aref (eieio--class-class-allocation-type (eieio--class-v class)) (let ((st (aref (eieio--class-class-allocation-type class)
slot-idx))) slot-idx)))
(if (not (eieio-perform-slot-validation st value)) (if (not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type (list class slot st value)))))) (signal 'invalid-slot-type
(list (eieio--class-symbol class) slot st value))))))
(defun eieio-barf-if-slot-unbound (value instance slotname fn) (defun eieio-barf-if-slot-unbound (value instance slotname fn)
"Throw a signal if VALUE is a representation of an UNBOUND slot. "Throw a signal if VALUE is a representation of an UNBOUND slot.
@ -1389,6 +1385,8 @@ Fills in OBJ's SLOT with its default value."
(defun eieio-default-eval-maybe (val) (defun eieio-default-eval-maybe (val)
"Check VAL, and return what `oref-default' would provide." "Check VAL, and return what `oref-default' would provide."
;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate
;; variables as well? Why not just always call `eval'?
(cond (cond
;; Is it a function call? If so, evaluate it. ;; Is it a function call? If so, evaluate it.
((eieio-eval-default-p val) ((eieio-eval-default-p val)
@ -1413,41 +1411,41 @@ Fills in OBJ's SLOT with VALUE."
(eieio--class-slot-name-index class slot)) (eieio--class-slot-name-index class slot))
;; Oset that slot. ;; Oset that slot.
(progn (progn
(eieio-validate-class-slot-value (eieio--class-symbol class) (eieio--validate-class-slot-value class c value slot)
c value slot)
(aset (eieio--class-class-allocation-values class) (aset (eieio--class-class-allocation-values class)
c value)) c value))
;; See oref for comment on `slot-missing' ;; See oref for comment on `slot-missing'
(slot-missing obj slot 'oset value) (slot-missing obj slot 'oset value)
;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot))
) )
(eieio-validate-slot-value (eieio--class-symbol class) c value slot) (eieio--validate-slot-value class c value slot)
(aset obj c value)))) (aset obj c value))))
(defun eieio-oset-default (class slot value) (defun eieio-oset-default (class slot value)
"Do the work for the macro `oset-default'. "Do the work for the macro `oset-default'.
Fills in the default value in CLASS' in SLOT with VALUE." Fills in the default value in CLASS' in SLOT with VALUE."
(eieio--check-type class-p class) (setq class (eieio--class-object class))
(eieio--check-type eieio--class-p class)
(eieio--check-type symbolp slot) (eieio--check-type symbolp slot)
(eieio--with-scoped-class (eieio--class-v class) (eieio--with-scoped-class class
(let* ((c (eieio--slot-name-index (eieio--class-v class) nil slot))) (let* ((c (eieio--slot-name-index class nil slot)))
(if (not c) (if (not c)
;; It might be missing because it is a :class allocated slot. ;; It might be missing because it is a :class allocated slot.
;; Let's check that info out. ;; Let's check that info out.
(if (setq c (eieio--class-slot-name-index (eieio--class-v class) slot)) (if (setq c (eieio--class-slot-name-index class slot))
(progn (progn
;; Oref that slot. ;; Oref that slot.
(eieio-validate-class-slot-value class c value slot) (eieio--validate-class-slot-value class c value slot)
(aset (eieio--class-class-allocation-values (eieio--class-v class)) c (aset (eieio--class-class-allocation-values class) c
value)) value))
(signal 'invalid-slot-name (list (eieio-class-name class) slot))) (signal 'invalid-slot-name (list (eieio--class-symbol class) slot)))
(eieio-validate-slot-value class c value slot) (eieio--validate-slot-value class c value slot)
;; Set this into the storage for defaults. ;; Set this into the storage for defaults.
(setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots))
(eieio--class-public-d (eieio--class-v class))) (eieio--class-public-d class))
value) value)
;; Take the value, and put it into our cache object. ;; Take the value, and put it into our cache object.
(eieio-oset (eieio--class-default-object-cache (eieio--class-v class)) (eieio-oset (eieio--class-default-object-cache class)
slot value) slot value)
)))) ))))
@ -1808,7 +1806,7 @@ This should only be called from a generic function."
(list method args)))) (list method args))))
rval))) rval)))
(defun eieio-generic-call-primary-only (method args) (defun eieio--generic-call-primary-only (method args)
"Call METHOD with ARGS for methods with only :PRIMARY implementations. "Call METHOD with ARGS for methods with only :PRIMARY implementations.
ARGS provides the context on which implementation to use. ARGS provides the context on which implementation to use.
This should only be called from a generic function. This should only be called from a generic function.
@ -2124,18 +2122,7 @@ is memorized for faster future use."
key argclass)) key argclass))
) )
(when eieio-optimize-primary-methods-flag (eieio--method-optimize-primary method)
;; 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) method)
(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") (make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")

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

@ -221,7 +221,7 @@ Outputs to the current buffer."
(cl-mapcan (cl-mapcan
(lambda (c) (lambda (c)
(append (list c) (eieio-build-class-list c))) (append (list c) (eieio-build-class-list c)))
(eieio-class-children-fast class)) (eieio--class-children (eieio--class-v class)))
(list class))) (list class)))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist) (defun eieio-build-class-alist (&optional class instantiable-only buildlist)
@ -423,16 +423,10 @@ function has no documentation, then return nil."
(defvar eieio-read-generic nil (defvar eieio-read-generic nil
"History of the `eieio-read-generic' prompt.") "History of the `eieio-read-generic' prompt.")
(defun eieio-read-generic-p (fn)
"Function used in function `eieio-read-generic'.
This is because `generic-p' is a macro.
Argument FN is the function to test."
(generic-p fn))
(defun eieio-read-generic (prompt &optional historyvar) (defun eieio-read-generic (prompt &optional historyvar)
"Read a generic function from the minibuffer with PROMPT. "Read a generic function from the minibuffer with PROMPT.
Optional argument HISTORYVAR is the variable to use as history." Optional argument HISTORYVAR is the variable to use as history."
(intern (completing-read prompt obarray 'eieio-read-generic-p (intern (completing-read prompt obarray #'generic-p
t nil (or historyvar 'eieio-read-generic)))) t nil (or historyvar 'eieio-read-generic))))
;;; METHOD STATS ;;; METHOD STATS

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

@ -328,7 +328,7 @@ The CLOS function `class-direct-superclasses' is aliased to this function."
"Return child classes to CLASS. "Return child classes to CLASS.
The CLOS function `class-direct-subclasses' is aliased to this function." The CLOS function `class-direct-subclasses' is aliased to this function."
(eieio--check-type class-p class) (eieio--check-type class-p class)
(eieio-class-children-fast class)) (eieio--class-children (eieio--class-v class)))
(define-obsolete-function-alias (define-obsolete-function-alias
'class-children #'eieio-class-children "24.4") 'class-children #'eieio-class-children "24.4")
@ -343,10 +343,12 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
`(car (eieio-class-parents ,class))) `(car (eieio-class-parents ,class)))
(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") (define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4")
(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." (defun same-class-p (obj class)
(eieio--check-type class-p class) "Return t if OBJ is of class-type CLASS."
(setq class (eieio--class-object class))
(eieio--check-type eieio--class-p class)
(eieio--check-type eieio-object-p obj) (eieio--check-type eieio-object-p obj)
(same-class-fast-p obj class)) (eq (eieio--object-class-object obj) class))
(defun object-of-class-p (obj class) (defun object-of-class-p (obj class)
"Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
@ -546,7 +548,7 @@ Use `next-method-p' to find out if there is a next method to call."
(next (car eieio-generic-call-next-method-list)) (next (car eieio-generic-call-next-method-list))
) )
(if (not (and next (car next))) (if (not (and next (car next)))
(apply #'no-next-method (car newargs) (cdr newargs)) (apply #'no-next-method newargs)
(let* ((eieio-generic-call-next-method-list (let* ((eieio-generic-call-next-method-list
(cdr eieio-generic-call-next-method-list)) (cdr eieio-generic-call-next-method-list))
(eieio-generic-call-arglst newargs) (eieio-generic-call-arglst newargs)
@ -723,7 +725,8 @@ first and modify the returned object.")
"Make a copy of OBJ, and then apply PARAMS." "Make a copy of OBJ, and then apply PARAMS."
(let ((nobj (copy-sequence obj))) (let ((nobj (copy-sequence obj)))
(if (stringp (car params)) (if (stringp (car params))
(message "Obsolete name %S passed to clone" (pop params))) (funcall (if eieio-backward-compatibility #'ignore #'message)
"Obsolete name %S passed to clone" (pop params)))
(if params (shared-initialize nobj params)) (if params (shared-initialize nobj params))
nobj)) nobj))
@ -889,7 +892,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
;;; Start of automatically extracted autoloads. ;;; Start of automatically extracted autoloads.
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "a3f314e2a27e52444df4597c6ae51458") ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "7d3c0bca065713ae74af0c07778dd1f4")
;;; Generated autoloads from eieio-custom.el ;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\ (autoload 'customize-object "eieio-custom" "\
@ -900,7 +903,7 @@ Optional argument GROUP is the sub-group of slots to display.
;;;*** ;;;***
;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "2ff7d98da3f84c6af5c873ffb781930e") ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "6377e022e85d377b399f44c98b4eab4a")
;;; Generated autoloads from eieio-opt.el ;;; Generated autoloads from eieio-opt.el
(autoload 'eieio-browse "eieio-opt" "\ (autoload 'eieio-browse "eieio-opt" "\

6
lisp/gnus/ChangeLog
View file

@ -1,3 +1,7 @@
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
* registry.el: Don't use <class> as a variable.
2014-12-18 Paul Eggert <eggert@cs.ucla.edu> 2014-12-18 Paul Eggert <eggert@cs.ucla.edu>
* registry.el (registry-db): Set default slot later. * registry.el (registry-db): Set default slot later.
@ -26011,7 +26015,7 @@
See ChangeLog.2 for earlier changes. See ChangeLog.2 for earlier changes.
Copyright (C) 2004-2014 Free Software Foundation, Inc. Copyright (C) 2004-2015 Free Software Foundation, Inc.
This file is part of GNU Emacs. This file is part of GNU Emacs.

4
lisp/gnus/registry.el
View file

@ -1,6 +1,6 @@
;;; registry.el --- Track and remember data items by various fields ;;; registry.el --- Track and remember data items by various fields
;; Copyright (C) 2011-2014 Free Software Foundation, Inc. ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
;; Author: Teodor Zlatanov <tzz@lifelogs.com> ;; Author: Teodor Zlatanov <tzz@lifelogs.com>
;; Keywords: data ;; Keywords: data
@ -124,7 +124,7 @@
:type hash-table :type hash-table
:documentation "The data hashtable."))) :documentation "The data hashtable.")))
;; Do this separately, since defclass doesn't allow expressions in :initform. ;; Do this separately, since defclass doesn't allow expressions in :initform.
(oset-default registry-db max-size most-positive-fixnum) (oset-default 'registry-db max-size most-positive-fixnum)
(defmethod initialize-instance :BEFORE ((this registry-db) slots) (defmethod initialize-instance :BEFORE ((this registry-db) slots)
"Check whether a registry object needs to be upgraded." "Check whether a registry object needs to be upgraded."

14
test/ChangeLog
View file

@ -1,3 +1,15 @@
2015-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/eieio-tests.el: Use cl-lib. Don't use <class> as a variable.
Don't use <class>-list types and <class>-list-p predicates.
* automated/eieio-test-persist.el (persistent-with-objs-list-slot):
Don't use <class>-list type.
* automated/eieio-test-methodinvoke.el
(eieio-test-method-order-list-4):
Don't use <class> as a variable.
2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca> 2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/eieio-tests.el (eieio-test-04-static-method) * automated/eieio-tests.el (eieio-test-04-static-method)
@ -2423,7 +2435,7 @@
;; coding: utf-8 ;; coding: utf-8
;; End: ;; End:
Copyright (C) 2008-2014 Free Software Foundation, Inc. Copyright (C) 2008-2015 Free Software Foundation, Inc.
This file is part of GNU Emacs. This file is part of GNU Emacs.

2
test/automated/eieio-test-methodinvoke.el
View file

@ -145,7 +145,7 @@
(ert-deftest eieio-test-method-order-list-4 () (ert-deftest eieio-test-method-order-list-4 ()
;; Both of these situations should succeed. ;; Both of these situations should succeed.
(should (eitest-H eitest-A)) (should (eitest-H 'eitest-A))
(should (eitest-H (eitest-A nil)))) (should (eitest-H (eitest-A nil))))
;;; Return value from :PRIMARY ;;; Return value from :PRIMARY

2
test/automated/eieio-test-persist.el
View file

@ -203,7 +203,7 @@ persistent class.")
;; A slot that contains another object that isn't persistent ;; A slot that contains another object that isn't persistent
(defclass persistent-with-objs-list-slot (eieio-persistent) (defclass persistent-with-objs-list-slot (eieio-persistent)
((pnp :initarg :pnp ((pnp :initarg :pnp
:type persist-not-persistent-list :type (list-of persist-not-persistent)
:initform nil)) :initform nil))
"Class for testing the saving of slots with objects in them.") "Class for testing the saving of slots with objects in them.")

52
test/automated/eieio-tests.el
View file

@ -28,7 +28,7 @@
(require 'eieio-base) (require 'eieio-base)
(require 'eieio-opt) (require 'eieio-opt)
(eval-when-compile (require 'cl)) (eval-when-compile (require 'cl-lib))
;;; Code: ;;; Code:
;; Set up some test classes ;; Set up some test classes
@ -198,10 +198,10 @@ Argument C is the class bound to this static method."
(ert-deftest eieio-test-04-static-method () (ert-deftest eieio-test-04-static-method ()
;; Call static method on a class and see if it worked ;; Call static method on a class and see if it worked
(static-method-class-method static-method-class 'class) (static-method-class-method 'static-method-class 'class)
(should (eq (oref-default static-method-class some-slot) 'class)) (should (eq (oref-default 'static-method-class some-slot) 'class))
(static-method-class-method (static-method-class) 'object) (static-method-class-method (static-method-class) 'object)
(should (eq (oref-default static-method-class some-slot) 'object))) (should (eq (oref-default 'static-method-class some-slot) 'object)))
(ert-deftest eieio-test-05-static-method-2 () (ert-deftest eieio-test-05-static-method-2 ()
(defclass static-method-class-2 (static-method-class) (defclass static-method-class-2 (static-method-class)
@ -214,10 +214,10 @@ Argument C is the class bound to this static method."
(if (eieio-object-p c) (setq c (eieio-object-class c))) (if (eieio-object-p c) (setq c (eieio-object-class c)))
(oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
(static-method-class-method static-method-class-2 'class) (static-method-class-method 'static-method-class-2 'class)
(should (eq (oref-default static-method-class-2 some-slot) 'moose-class)) (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
(static-method-class-method (static-method-class-2) 'object) (static-method-class-method (static-method-class-2) 'object)
(should (eq (oref-default static-method-class-2 some-slot) 'moose-object))) (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object)))
;;; Perform method testing ;;; Perform method testing
@ -473,12 +473,12 @@ METHOD is the method that was attempting to be called."
;; Slot should be bound ;; Slot should be bound
(should (slot-boundp eitest-a 'classslot)) (should (slot-boundp eitest-a 'classslot))
(should (slot-boundp class-a 'classslot)) (should (slot-boundp 'class-a 'classslot))
(slot-makeunbound eitest-a 'classslot) (slot-makeunbound eitest-a 'classslot)
(should-not (slot-boundp eitest-a 'classslot)) (should-not (slot-boundp eitest-a 'classslot))
(should-not (slot-boundp class-a 'classslot))) (should-not (slot-boundp 'class-a 'classslot)))
(defvar eieio-test-permuting-value nil) (defvar eieio-test-permuting-value nil)
@ -529,17 +529,17 @@ METHOD is the method that was attempting to be called."
:type 'invalid-slot-type)) :type 'invalid-slot-type))
(ert-deftest eieio-test-23-inheritance-check () (ert-deftest eieio-test-23-inheritance-check ()
(should (child-of-class-p class-ab class-a)) (should (child-of-class-p 'class-ab 'class-a))
(should (child-of-class-p class-ab class-b)) (should (child-of-class-p 'class-ab 'class-b))
(should (object-of-class-p eitest-a class-a)) (should (object-of-class-p eitest-a 'class-a))
(should (object-of-class-p eitest-ab class-a)) (should (object-of-class-p eitest-ab 'class-a))
(should (object-of-class-p eitest-ab class-b)) (should (object-of-class-p eitest-ab 'class-b))
(should (object-of-class-p eitest-ab class-ab)) (should (object-of-class-p eitest-ab 'class-ab))
(should (eq (eieio-class-parents class-a) nil)) (should (eq (eieio-class-parents 'class-a) nil))
;; FIXME: eieio-class-parents now returns class objects! ;; FIXME: eieio-class-parents now returns class objects!
(should (equal (mapcar #'eieio-class-object (eieio-class-parents class-ab)) (should (equal (mapcar #'eieio-class-object (eieio-class-parents 'class-ab))
(mapcar #'eieio-class-object '(class-a class-b)))) (mapcar #'eieio-class-object '(class-a class-b))))
(should (same-class-p eitest-a class-a)) (should (same-class-p eitest-a 'class-a))
(should (class-a-p eitest-a)) (should (class-a-p eitest-a))
(should (not (class-a-p eitest-ab))) (should (not (class-a-p eitest-ab)))
(should (class-a-child-p eitest-a)) (should (class-a-child-p eitest-a))
@ -550,10 +550,10 @@ METHOD is the method that was attempting to be called."
(ert-deftest eieio-test-24-object-predicates () (ert-deftest eieio-test-24-object-predicates ()
(let ((listooa (list (class-ab) (class-a))) (let ((listooa (list (class-ab) (class-a)))
(listoob (list (class-ab) (class-b)))) (listoob (list (class-ab) (class-b))))
(should (class-a-list-p listooa)) (should (cl-typep listooa '(list-of class-a)))
(should (class-b-list-p listoob)) (should (cl-typep listoob '(list-of class-b)))
(should-not (class-b-list-p listooa)) (should-not (cl-typep listooa '(list-of class-b)))
(should-not (class-a-list-p listoob)))) (should-not (cl-typep listoob '(list-of class-a)))))
(defvar eitest-t1 nil) (defvar eitest-t1 nil)
(ert-deftest eieio-test-25-slot-tests () (ert-deftest eieio-test-25-slot-tests ()
@ -568,7 +568,7 @@ METHOD is the method that was attempting to be called."
;; Pass string instead of symbol ;; Pass string instead of symbol
(should-error (class-c :moose "not a symbol") :type 'invalid-slot-type) (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type)
(should (eq (get-slot-3 eitest-t1) 'emu)) (should (eq (get-slot-3 eitest-t1) 'emu))
(should (eq (get-slot-3 class-c) 'emu)) (should (eq (get-slot-3 'class-c) 'emu))
;; Check setf ;; Check setf
(setf (get-slot-3 eitest-t1) 'setf-emu) (setf (get-slot-3 eitest-t1) 'setf-emu)
(should (eq (get-slot-3 eitest-t1) 'setf-emu)) (should (eq (get-slot-3 eitest-t1) 'setf-emu))
@ -793,7 +793,7 @@ Subclasses to override slot attributes.")
((type :type string) ((type :type string)
) )
"This class should throw an error."))) "This class should throw an error.")))
(should (eq (oref-default slotattr-class-ok initform) 'no-init))) (should (eq (oref-default 'slotattr-class-ok initform) 'no-init)))
(ert-deftest eieio-test-32-slot-attribute-override-2 () (ert-deftest eieio-test-32-slot-attribute-override-2 ()
(let* ((cv (eieio--class-v 'slotattr-ok)) (let* ((cv (eieio--class-v 'slotattr-ok))
@ -883,8 +883,8 @@ Subclasses to override slot attributes.")
"Instantiable child") "Instantiable child")
(ert-deftest eieio-test-36-build-class-alist () (ert-deftest eieio-test-36-build-class-alist ()
(should (= (length (eieio-build-class-alist opt-test1 nil)) 2)) (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
(should (= (length (eieio-build-class-alist opt-test1 t)) 1))) (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
(provide 'eieio-tests) (provide 'eieio-tests)