+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>
* emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
;; coding: utf-8
;; End:
- Copyright (C) 2011-2014 Free Software Foundation, Inc.
+ Copyright (C) 2011-2015 Free Software Foundation, Inc.
This file is part of GNU Emacs.
+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>
* srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children.
;; coding: utf-8
;; End:
- Copyright (C) 2009-2014 Free Software Foundation, Inc.
+ Copyright (C) 2009-2015 Free Software Foundation, Inc.
This file is part of GNU Emacs.
;;; 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>
;; Keywords: project, make
(let ((obj ede-object))
(if (consp 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 ()
"Return non-nil if this buffer belongs to at least one project."
(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)
"Return non-nil if some member of `ede-object' is a child of CLASS."
;; First, collect the build items from the project
(setq newmenu (append newmenu (ede-menu-items-build obj t)))
;; 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
(setq newmenu (append newmenu
(ede-menu-items-build (car ede-obj) t))
(error "No project created to add to master list"))
(when (not (eieio-object-p proj))
(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"))
(add-to-list 'ede-projects proj)
proj)
(ede-delete-project-from-global-list D))
))
+(defvar ede--disable-inode) ;Defined in ede/files.el.
+
(defun ede-global-list-sanity-check ()
"Perform a sanity check to make sure there are no duplicate projects."
(interactive)
;;; 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>
;; Projects can also affect how EDE works, by changing what appears in
;; 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)
((subproj :initform nil
:type list
;;
(defmacro ede-with-projectfile (obj &rest forms)
"For the project in which OBJ resides, execute FORMS."
- `(save-window-excursion
- (let* ((pf (if (obj-of-class-p ,obj ede-target)
- (ede-target-parent ,obj)
- ,obj))
- (dbka (get-file-buffer (oref pf file))))
- (if (not dbka) (find-file (oref pf file))
- (switch-to-buffer dbka))
+ (declare (indent 1))
+ (unless (symbolp obj)
+ (message "Beware! ede-with-projectfile's first arg is copied: %S" obj))
+ `(let* ((pf (if (obj-of-class-p ,obj 'ede-target)
+ (ede-target-parent ,obj)
+ ,obj))
+ (dbka (get-file-buffer (oref pf file))))
+ (with-current-buffer
+ (if (not dbka) (find-file-noselect (oref pf file))
+ dbka)
,@forms
(if (not dbka) (kill-buffer (current-buffer))))))
-(put 'ede-with-projectfile 'lisp-indent-function 1)
;;; The EDE persistent cache.
;;
;;; 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>
"Edit fields of the current target through EIEIO & Custom."
(interactive)
(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"))
(ede-customize-target ede-object))
"Edit fields of the current target through EIEIO & Custom.
OBJ is the target object to customize."
(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"))
(ede-customize obj))
;;; 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>
;; Keywords: project, make
the PROJECT being read in is the root project."
(save-excursion
(let ((ret (eieio-persistent-read (concat project "Project.ede")
- ede-proj-project))
+ 'ede-proj-project))
(subdirs (directory-files project nil "[^.].*" nil)))
(if (not (object-of-class-p ret 'ede-proj-project))
(error "Corrupt project file"))
;;; 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.
;; Author: Eric M. Ludlam <zappo@gnu.org>
(defun project-am-preferred-target-type (file)
"For FILE, return the preferred type for that file."
(cond ((string-match "\\.texi?\\(nfo\\)$" file)
- project-am-texinfo)
+ 'project-am-texinfo)
((string-match "\\.[0-9]$" file)
- project-am-man)
+ 'project-am-man)
((string-match "\\.el$" file)
- project-am-lisp)
+ 'project-am-lisp)
(t
- project-am-program)))
+ 'project-am-program)))
(defmethod ede-buffer-header-file((this project-am-objectcode) buffer)
"There are no default header files."
;;; 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.
;; Author: Eric M. Ludlam <zappo@gnu.org>
(let ((obj (eieio-speedbar-find-nearest-object)))
(if (not (eieio-object-p obj))
nil
- (cond ((obj-of-class-p obj ede-project)
+ (cond ((obj-of-class-p obj 'ede-project)
(project-compile-project obj))
- ((obj-of-class-p obj ede-target)
+ ((obj-of-class-p obj 'ede-target)
(project-compile-target obj))
(t (error "Error in speedbar structure"))))))
(let ((obj (eieio-speedbar-find-nearest-object)))
(if (not (eieio-object-p obj))
(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)))
- (if (obj-of-class-p obj ede-project)
+ (if (obj-of-class-p obj 'ede-project)
obj
(error "Error in speedbar or ede structure")))))
;;; 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>
;; Keywords: syntax tools
;; The best way to call the parser from programs is via
;; `semantic-fetch-tags'. This, in turn, uses other internal
;; API functions which plug-in parsers can take advantage of.
+(defvar semantic-parser-warnings)
(defun semantic-fetch-tags ()
"Fetch semantic tags from the current buffer.
(garbage-collect)
(cond
-;;;; Try the incremental parser to do a fast update.
- ((semantic-parse-tree-needs-update-p)
- (setq res (semantic-parse-changes))
- (if (semantic-parse-tree-needs-rebuild-p)
- ;; If the partial reparse fails, jump to a full reparse.
- (semantic-fetch-tags)
- ;; Clear the cache of unmatched syntax tokens
- ;;
- ;; NOTE TO SELF:
- ;;
- ;; Move this into the incremental parser. This is a bug.
- ;;
- (semantic-clear-unmatched-syntax-cache)
- (run-hook-with-args ;; Let hooks know the updated tags
- 'semantic-after-partial-cache-change-hook res))
- (setq semantic--completion-cache nil))
-
-;;;; Parse the whole system.
- ((semantic-parse-tree-needs-rebuild-p)
- ;; Use Emacs's built-in progress-reporter (only interactive).
- (if noninteractive
- (setq res (semantic-parse-region (point-min) (point-max)))
- (let ((semantic--progress-reporter
- (and (>= (point-max) semantic-minimum-working-buffer-size)
- (eq semantic-working-type 'percent)
- (make-progress-reporter
- (semantic-parser-working-message (buffer-name))
- 0 100))))
- (setq res (semantic-parse-region (point-min) (point-max)))
- (if semantic--progress-reporter
- (progress-reporter-done semantic--progress-reporter))))
-
- ;; Clear the caches when we see there were no errors.
- ;; But preserve the unmatched syntax cache and warnings!
- (let (semantic-unmatched-syntax-cache
- semantic-unmatched-syntax-cache-check
- semantic-parser-warnings)
- (semantic-clear-toplevel-cache))
- ;; Set up the new overlays
- (semantic--tag-link-list-to-buffer res)
- ;; Set up the cache with the new results
- (semantic--set-buffer-cache res)
- ))))
+ ;; Try the incremental parser to do a fast update.
+ ((semantic-parse-tree-needs-update-p)
+ (setq res (semantic-parse-changes))
+ (if (semantic-parse-tree-needs-rebuild-p)
+ ;; If the partial reparse fails, jump to a full reparse.
+ (semantic-fetch-tags)
+ ;; Clear the cache of unmatched syntax tokens
+ ;;
+ ;; NOTE TO SELF:
+ ;;
+ ;; Move this into the incremental parser. This is a bug.
+ ;;
+ (semantic-clear-unmatched-syntax-cache)
+ (run-hook-with-args ;; Let hooks know the updated tags
+ 'semantic-after-partial-cache-change-hook res))
+ (setq semantic--completion-cache nil))
+
+ ;; Parse the whole system.
+ ((semantic-parse-tree-needs-rebuild-p)
+ ;; Use Emacs's built-in progress-reporter (only interactive).
+ (if noninteractive
+ (setq res (semantic-parse-region (point-min) (point-max)))
+ (let ((semantic--progress-reporter
+ (and (>= (point-max) semantic-minimum-working-buffer-size)
+ (eq semantic-working-type 'percent)
+ (make-progress-reporter
+ (semantic-parser-working-message (buffer-name))
+ 0 100))))
+ (setq res (semantic-parse-region (point-min) (point-max)))
+ (if semantic--progress-reporter
+ (progress-reporter-done semantic--progress-reporter))))
+
+ ;; Clear the caches when we see there were no errors.
+ ;; But preserve the unmatched syntax cache and warnings!
+ (let (semantic-unmatched-syntax-cache
+ semantic-unmatched-syntax-cache-check
+ semantic-parser-warnings)
+ (semantic-clear-toplevel-cache))
+ ;; Set up the new overlays
+ (semantic--tag-link-list-to-buffer res)
+ ;; Set up the cache with the new results
+ (semantic--set-buffer-cache res)
+ ))))
;; Always return the current parse tree.
semantic--buffer-cache)
;;; 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>
;;; 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>
makefile-mode (context)
"Return a list of possible completions in a Makefile.
Uses default implementation, and also gets a list of filenames."
- (save-excursion
- (require 'semantic/analyze/complete)
- (set-buffer (oref context buffer))
+ (require 'semantic/analyze/complete)
+ (with-current-buffer (oref context buffer)
(let* ((normal (semantic-analyze-possible-completions-default context))
(classes (oref context :prefixclass))
(filetags nil))
;;; 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>
;; Keywords: syntax
"Default history variable for any unhistoried prompt.
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
default-tag initial-input
(list 'const
:tag doc1
C)))
- (eieio-build-class-alist semantic-displayor-abstract t))
+ (eieio-build-class-alist 'semantic-displayor-abstract t))
)
"Possible options for inline completion displayors.
Use this to enable custom editing.")
;;; 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>
;; Joakim Verona
If DIRECTORY is found to be defunct, it won't load the DB, and will
warn instead."
(if (file-directory-p directory)
- (semanticdb-create-database semanticdb-project-database-ebrowse
+ (semanticdb-create-database 'semanticdb-project-database-ebrowse
directory)
(let* ((BF (semanticdb-ebrowse-file-for-directory directory))
(BFL (concat BF "-load.el"))
;;; 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>
;; Keywords: tags
(semantic-elisp-desymbolify
;; FIXME: This only gives the instance slots and ignores the
;; 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
))
((not toktype)
;;; 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>
;; Keywords: tags
(defun semanticdb-load-database (filename)
"Load the database FILENAME."
(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))
(tv (oref r semantic-tag-version))
(fv (oref r semanticdb-version))
;;; 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>
;; Keywords: tags
If optional argument BRUTISH is non-nil, then ignore include statements,
and search all tables in this project tree."
(let (found match)
- (save-excursion
+ (save-current-buffer
;; If path is a buffer, set ourselves up in that buffer
;; so that the override methods work correctly.
(when (bufferp path) (set-buffer path))
;; databases and not associated with a file.
(unless (and find-file-match
(obj-of-class-p
- (car tableandtags) semanticdb-search-results-table))
+ (car tableandtags) 'semanticdb-search-results-table))
(when (setq match (funcall function
(car tableandtags) (cdr tableandtags)))
(when find-file-match
;; `semanticdb-search-results-table', since those are system
;; databases and not associated with a file.
(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)))
(semanticdb-find-log-activity table match)
(when find-file-match
;;; 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>
(defmethod semanticdb-get-typecache ((db semanticdb-project-database))
"Retrieve the typecache from the semantic database DB.
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)
)
\f
;;; 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>
;; Keywords: tags
;;; 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)
((tracking-symbol :initform semanticdb-database-list)
(reference-directory :type string
;;; 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>
;; Keywords: project, make
;; "Target class for Emacs/Semantic grammar files." nil nil)
(ede-proj-register-target "semantic grammar"
- semantic-ede-proj-target-grammar)
+ 'semantic-ede-proj-target-grammar)
(provide 'semantic/ede-grammar)
;;; 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>
if a user presses any key during execution, this form macro
will exit with the value passed to `semantic-throw-on-input'.
If FORMS completes, then the return value is the same as `progn'."
+ (declare (indent 1))
`(let ((semantic-current-input-throw-symbol ,symbol)
(semantic--on-input-start-marker (point-marker)))
(catch ,symbol
,@forms)))
-(put 'semantic-exit-on-input 'lisp-indent-function 1)
(defmacro semantic-throw-on-input (from)
"Exit with `throw' when in `semantic-exit-on-input' on user input.
calling this one."
`(when (and semantic-current-input-throw-symbol
(or (input-pending-p)
- (save-excursion
- ;; Timers might run during accept-process-output.
- ;; If they redisplay, point must be where the user
- ;; expects. (Bug#15045)
- (set-buffer (marker-buffer
- semantic--on-input-start-marker))
- (goto-char (marker-position
- semantic--on-input-start-marker))
- (accept-process-output))))
+ (with-current-buffer
+ ;; Timers might run during accept-process-output.
+ ;; If they redisplay, point must be where the user
+ ;; expects. (Bug#15045)
+ (marker-buffer semantic--on-input-start-marker)
+ (save-excursion
+ (goto-char semantic--on-input-start-marker)
+ (accept-process-output)))))
(throw semantic-current-input-throw-symbol ,from)))
\f
;;; 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>
;; Maintainer: David Ponce <david@dponce.com>
(declare-function eldoc-get-fnsym-args-string "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)
"Return a one-line docstring for the given grammar MACRO.
EXPANDER is the name of the function that expands MACRO."
(require 'eldoc)
- (if (and (eq expander (aref eldoc-last-data 0))
- (eq 'function (aref eldoc-last-data 2)))
- (aref eldoc-last-data 1)
+ (if (eq expander (car semantic-grammar-eldoc-last-data))
+ (cdr semantic-grammar-eldoc-last-data)
(let ((doc (help-split-fundoc (documentation expander t) expander)))
(cond
(doc
(setq doc
(eldoc-docstring-format-sym-doc
macro (format "==> %s %s" expander doc) 'default))
- (eldoc-last-data-store expander doc 'function))
+ (setq semantic-grammar-eldoc-last-data (cons expander doc)))
doc)))
(define-mode-local-override semantic-idle-summary-current-symbol-info
;;; 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>
;; Keywords: syntax
;;; 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>
;; Keywords: syntax
;;; 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>
"Get the current cached scope, and reset it."
(when semanticdb-current-table
(let ((co (semanticdb-cache-get semanticdb-current-table
- semantic-scope-cache)))
+ 'semantic-scope-cache)))
(semantic-reset co))))
(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache)
(let* ((TAG (semantic-current-tag))
(scopecache
(semanticdb-cache-get semanticdb-current-table
- semantic-scope-cache))
+ 'semantic-scope-cache))
)
(when (not (semantic-equivalent-tag-p TAG (oref scopecache tag)))
(semantic-reset scopecache))
;;; 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>
;; Keywords: codegeneration
Useful if something goes wrong in SRecode, and the active template
stack is broken."
(interactive)
- (if (oref srecode-template active)
+ (if (oref-default 'srecode-template active)
(when (y-or-n-p (format "%d active templates. Flush? "
- (length (oref srecode-template active))))
- (oset-default srecode-template active nil))
+ (length (oref-default 'srecode-template active))))
+ (oset-default 'srecode-template active nil))
(message "No active templates to flush."))
)
;;(message "Compile: %s %S" name props)
(if (not key)
(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))
;; Loop over the various subclasses and
;; create the correct inserter.
;;; 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>
(defsubst srecode-active-template-region ()
"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 ()
"Srecode field handler in the post command hook."
;;; 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>
(propertize " (most recent at bottom)" 'face '(:slant italic))
":\n")
(data-debug-insert-stuff-list
- (reverse (oref srecode-template active)) "> ")
+ (reverse (oref-default 'srecode-template active)) "> ")
;; Show the current dictionary.
(insert (propertize "Dictionary" 'face '(:weight bold)) "\n")
(data-debug-insert-thing dictionary "" "> ")
(pm (point-marker)))
(when (and inbuff
;; 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)))
(indent-according-to-mode)
;; valid. Compare this to the actual template nesting depth and
;; maybe use the override function which is stored in the cdr.
(if (and srecode-template-inserter-point-override
- (<= (length (oref srecode-template active))
+ (<= (length (oref-default 'srecode-template active))
(car srecode-template-inserter-point-override)))
;; Disable the old override while we do this.
(let ((over (cdr srecode-template-inserter-point-override))
;; Calculate and store the discovered template
(let ((tmpl (srecode-template-get-table (srecode-table)
templatenamepart))
- (active (oref srecode-template active))
+ (active (oref-default 'srecode-template active))
ctxt)
(when (not tmpl)
;; If it isn't just available, scan back through
(lexical-let ((inserter1 sti))
(cons
;; DEPTH
- (+ (length (oref srecode-template active)) 1)
+ (+ (length (oref-default 'srecode-template active)) 1)
;; FUNCTION
(lambda (dict)
(let ((srecode-template-inserter-point-override nil))
;;; 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>
(when (not srecode-current-map)
(condition-case nil
(setq srecode-current-map
- (eieio-persistent-read srecode-map-save-file srecode-map))
+ (eieio-persistent-read srecode-map-save-file 'srecode-map))
(error
;; There was an error loading the old map. Create a new one.
(setq srecode-current-map
(if (stringp (car (oref seq data)))
(let ((labels (oref seq data)))
(if (not axis)
- (setq axis (make-instance chart-axis-names
+ (setq axis (make-instance 'chart-axis-names
:name (oref seq name)
:items labels
:chart c))
(let ((range (cons 0 1))
(l (oref seq data)))
(if (not axis)
- (setq axis (make-instance chart-axis-range
+ (setq axis (make-instance 'chart-axis-range
:name (oref seq name)
:chart c)))
(while l
Optional arguments:
Set the chart's max element display to MAX, and sort lists with
SORT-PRED if desired."
- (let ((nc (make-instance chart-bar
+ (let ((nc (make-instance 'chart-bar
:title title
:key-label "8-m" ; This is a text key pic
:direction dir
))
(iv (eq dir 'vertical)))
(chart-add-sequence nc
- (make-instance chart-sequece
+ (make-instance 'chart-sequece
:data namelst
:name nametitle)
(if iv 'x-axis 'y-axis))
(chart-add-sequence nc
- (make-instance chart-sequece
+ (make-instance 'chart-sequece
:data numlst
:name numtitle)
(if iv 'y-axis 'x-axis))
(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))
+ (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
+ slot classtype))
;; We have a predicate, but it doesn't satisfy the predicate?
(dolist (PV (cdr proposed-value))
(cond ((class-p type)
;; If the type is a class, then return it.
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!
((and (symbolp type) (string-match "-child\\'" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 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
;; that class. Unfortunately, in EIEIO, typep of just the
;; class is the same as if we used -child, so no further work needed.
((and (symbolp type) (string-match "-list\\'" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 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
;; 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))
+ ((eq (car-safe 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))
(defvar eieio-initializing-object nil
"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
(if (and (boundp 'eieio-unbound) (symbolp eieio-unbound))
eieio-unbound
(defsubst eieio--class-object (class)
"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)
"Return non-nil if CLASS is a valid class object."
(format "#<class %s>" (symbol-name class)))
(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)
"Return the symbol representing the constructor of CLASS."
(declare (debug t))
(push (eieio--class-v SC) (eieio--class-parent newc)))
;; 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
;; do this first so that we can call defmethod for the accessor.
(setf (eieio--class-parent newc) (list eieio-default-superclass))))
;; 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-
;; referencing classes. ei, a class whose slot can contain only
))
;; 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
`(lambda (obj)
,(format
(put cname 'cl-deftype-satisfies csym))
;; 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 eieio-backward-compatibility
+ (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))))))
;; Before adding new slots, let's add all the methods and classes
;; in from the parent class.
(if (and slots
(let ((x (car slots)))
(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))
(apply #'eieio-constructor ',cname slots)))
)
(if (not (or (eieio-eval-default-p value) ;FIXME: Why?
eieio-skip-typecheck
(and skipnil (null value))
- (eieio-perform-slot-validation spec value)))
+ (eieio--perform-slot-validation 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
(lambda (&rest local-args)
(eieio-generic-call method local-args)))
-(defsubst eieio-defgeneric-reset-generic-form (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)
+(defun eieio--defgeneric-form-primary-only (method)
"The lambda form that would be used as the function defined on METHOD.
All methods should call the same EIEIO function for dispatch.
DOC-STRING is the documentation attached to METHOD."
(lambda (&rest 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))))
+ (eieio--generic-call-primary-only method local-args)))
(declare-function no-applicable-method "eieio" (object method &rest args))
During executions, the list is first generated, then as each next method
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.
All methods should call the same EIEIO function for dispatch.
CLASS is the class symbol needed for private method access.
(eieio--with-scoped-class (eieio--class-v class)
(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)
"Make the generic method METHOD have no implementations.
It will leave the original generic function in place,
(put method 'eieio-method-tree 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)
"Work part of the `defmethod' macro defining METHOD with ARGS."
(let ((key
(eieiomt-add method code key argclass)
)
- (when eieio-optimize-primary-methods-flag
- ;; Optimizing step:
- ;;
- ;; If this method, after this setup, only has primary methods, then
- ;; we can setup the generic that way.
- (if (generic-primary-only-p method)
- ;; If there is only one primary method, then we can go one more
- ;; optimization step.
- (if (generic-primary-only-one-p method)
- (eieio-defgeneric-reset-generic-form-primary-only-one method)
- (eieio-defgeneric-reset-generic-form-primary-only method))
- (eieio-defgeneric-reset-generic-form method)))
+ (eieio--method-optimize-primary method)
method)
;; requiring the CL library at run-time. It can be eliminated if/when
;; `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."
(or (eq spec t) ; t always passes
(eq value eieio-unbound) ; unbound always passes
(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.
Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing
nil
;; Trim off object IDX junk added in for the object index.
(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)))
- (if (not (eieio-perform-slot-validation st value))
- (signal 'invalid-slot-type (list class slot st value))))))
+ (let ((st (aref (eieio--class-public-type class) slot-idx)))
+ (if (not (eieio--perform-slot-validation 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.
Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing
an error."
(if eieio-skip-typecheck
nil
- (let ((st (aref (eieio--class-class-allocation-type (eieio--class-v class))
+ (let ((st (aref (eieio--class-class-allocation-type class)
slot-idx)))
- (if (not (eieio-perform-slot-validation st value))
- (signal 'invalid-slot-type (list class slot st value))))))
+ (if (not (eieio--perform-slot-validation st value))
+ (signal 'invalid-slot-type
+ (list (eieio--class-symbol class) slot st value))))))
(defun eieio-barf-if-slot-unbound (value instance slotname fn)
"Throw a signal if VALUE is a representation of an UNBOUND slot.
(defun eieio-default-eval-maybe (val)
"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
;; Is it a function call? If so, evaluate it.
((eieio-eval-default-p val)
(eieio--class-slot-name-index class slot))
;; Oset that slot.
(progn
- (eieio-validate-class-slot-value (eieio--class-symbol class)
- c value slot)
+ (eieio--validate-class-slot-value class c value slot)
(aset (eieio--class-class-allocation-values class)
c value))
;; See oref for comment on `slot-missing'
(slot-missing obj slot 'oset value)
;;(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))))
(defun eieio-oset-default (class slot value)
"Do the work for the macro `oset-default'.
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--with-scoped-class (eieio--class-v class)
- (let* ((c (eieio--slot-name-index (eieio--class-v class) nil slot)))
+ (eieio--with-scoped-class class
+ (let* ((c (eieio--slot-name-index class nil slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
;; 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
;; Oref that slot.
- (eieio-validate-class-slot-value class c value slot)
- (aset (eieio--class-class-allocation-values (eieio--class-v class)) c
+ (eieio--validate-class-slot-value class c value slot)
+ (aset (eieio--class-class-allocation-values class) c
value))
- (signal 'invalid-slot-name (list (eieio-class-name class) slot)))
- (eieio-validate-slot-value class c value slot)
+ (signal 'invalid-slot-name (list (eieio--class-symbol class) slot)))
+ (eieio--validate-slot-value class c value slot)
;; Set this into the storage for defaults.
(setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots))
- (eieio--class-public-d (eieio--class-v class)))
+ (eieio--class-public-d class))
value)
;; 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)
))))
(list method args))))
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.
ARGS provides the context on which implementation to use.
This should only be called from a generic function.
key argclass))
)
- (when eieio-optimize-primary-methods-flag
- ;; Optimizing step:
- ;;
- ;; If this method, after this setup, only has primary methods, then
- ;; we can setup the generic that way.
- (if (generic-primary-only-p method)
- ;; If there is only one primary method, then we can go one more
- ;; optimization step.
- (if (generic-primary-only-one-p method)
- (eieio-defgeneric-reset-generic-form-primary-only-one method)
- (eieio-defgeneric-reset-generic-form-primary-only method))
- (eieio-defgeneric-reset-generic-form method)))
+ (eieio--method-optimize-primary method)
method)
(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")
(cl-mapcan
(lambda (c)
(append (list c) (eieio-build-class-list c)))
- (eieio-class-children-fast class))
+ (eieio--class-children (eieio--class-v class)))
(list class)))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
(defvar eieio-read-generic nil
"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)
"Read a generic function from the minibuffer with PROMPT.
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))))
;;; METHOD STATS
"Return child classes to CLASS.
The CLOS function `class-direct-subclasses' is aliased to this function."
(eieio--check-type class-p class)
- (eieio-class-children-fast class))
+ (eieio--class-children (eieio--class-v class)))
(define-obsolete-function-alias
'class-children #'eieio-class-children "24.4")
`(car (eieio-class-parents ,class)))
(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."
- (eieio--check-type class-p class)
+(defun same-class-p (obj 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)
- (same-class-fast-p obj class))
+ (eq (eieio--object-class-object obj) class))
(defun object-of-class-p (obj class)
"Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
(next (car eieio-generic-call-next-method-list))
)
(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
(cdr eieio-generic-call-next-method-list))
(eieio-generic-call-arglst newargs)
"Make a copy of OBJ, and then apply PARAMS."
(let ((nobj (copy-sequence obj)))
(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))
nobj))
\f
;;; Start of automatically extracted autoloads.
\f
-;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "a3f314e2a27e52444df4597c6ae51458")
+;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "7d3c0bca065713ae74af0c07778dd1f4")
;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\
;;;***
\f
-;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "2ff7d98da3f84c6af5c873ffb781930e")
+;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "6377e022e85d377b399f44c98b4eab4a")
;;; Generated autoloads from eieio-opt.el
(autoload 'eieio-browse "eieio-opt" "\
+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>
* registry.el (registry-db): Set default slot later.
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.
;;; 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>
;; Keywords: data
:type hash-table
:documentation "The data hashtable.")))
;; 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)
"Check whether a registry object needs to be upgraded."
+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>
* automated/eieio-tests.el (eieio-test-04-static-method)
;; coding: utf-8
;; End:
- Copyright (C) 2008-2014 Free Software Foundation, Inc.
+ Copyright (C) 2008-2015 Free Software Foundation, Inc.
This file is part of GNU Emacs.
(ert-deftest eieio-test-method-order-list-4 ()
;; Both of these situations should succeed.
- (should (eitest-H eitest-A))
+ (should (eitest-H 'eitest-A))
(should (eitest-H (eitest-A nil))))
;;; Return value from :PRIMARY
;; A slot that contains another object that isn't persistent
(defclass persistent-with-objs-list-slot (eieio-persistent)
((pnp :initarg :pnp
- :type persist-not-persistent-list
+ :type (list-of persist-not-persistent)
:initform nil))
"Class for testing the saving of slots with objects in them.")
(require 'eieio-base)
(require 'eieio-opt)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;; Code:
;; Set up some test classes
(ert-deftest eieio-test-04-static-method ()
;; Call static method on a class and see if it worked
- (static-method-class-method static-method-class 'class)
- (should (eq (oref-default static-method-class some-slot) 'class))
+ (static-method-class-method 'static-method-class 'class)
+ (should (eq (oref-default 'static-method-class some-slot) 'class))
(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 ()
(defclass static-method-class-2 (static-method-class)
(if (eieio-object-p c) (setq c (eieio-object-class c)))
(oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
- (static-method-class-method static-method-class-2 'class)
- (should (eq (oref-default static-method-class-2 some-slot) 'moose-class))
+ (static-method-class-method 'static-method-class-2 'class)
+ (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
(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)))
\f
;;; Perform method testing
;; Slot should be bound
(should (slot-boundp eitest-a 'classslot))
- (should (slot-boundp class-a 'classslot))
+ (should (slot-boundp 'class-a 'classslot))
(slot-makeunbound 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)
:type 'invalid-slot-type))
(ert-deftest eieio-test-23-inheritance-check ()
- (should (child-of-class-p class-ab class-a))
- (should (child-of-class-p class-ab class-b))
- (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-b))
- (should (object-of-class-p eitest-ab class-ab))
- (should (eq (eieio-class-parents class-a) nil))
+ (should (child-of-class-p 'class-ab 'class-a))
+ (should (child-of-class-p 'class-ab 'class-b))
+ (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-b))
+ (should (object-of-class-p eitest-ab 'class-ab))
+ (should (eq (eieio-class-parents 'class-a) nil))
;; 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))))
- (should (same-class-p eitest-a class-a))
+ (should (same-class-p eitest-a 'class-a))
(should (class-a-p eitest-a))
(should (not (class-a-p eitest-ab)))
(should (class-a-child-p eitest-a))
(ert-deftest eieio-test-24-object-predicates ()
(let ((listooa (list (class-ab) (class-a)))
(listoob (list (class-ab) (class-b))))
- (should (class-a-list-p listooa))
- (should (class-b-list-p listoob))
- (should-not (class-b-list-p listooa))
- (should-not (class-a-list-p listoob))))
+ (should (cl-typep listooa '(list-of class-a)))
+ (should (cl-typep listoob '(list-of class-b)))
+ (should-not (cl-typep listooa '(list-of class-b)))
+ (should-not (cl-typep listoob '(list-of class-a)))))
(defvar eitest-t1 nil)
(ert-deftest eieio-test-25-slot-tests ()
;; Pass string instead of symbol
(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 class-c) 'emu))
+ (should (eq (get-slot-3 'class-c) 'emu))
;; Check setf
(setf (get-slot-3 eitest-t1) 'setf-emu)
(should (eq (get-slot-3 eitest-t1) 'setf-emu))
((type :type string)
)
"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 ()
(let* ((cv (eieio--class-v 'slotattr-ok))
"Instantiable child")
(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 t)) 1)))
+ (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
+ (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
(provide 'eieio-tests)