Merge branch 'cedet-object-name'

This commit is contained in:
Stefan Monnier 2025-04-07 00:58:32 -04:00
commit fb5da5035a
33 changed files with 92 additions and 95 deletions

View file

@ -149,7 +149,6 @@ HOSTS can be a string or a list of strings."
(defvar auth-source-pass-backend
(auth-source-backend
(when (<= emacs-major-version 25) "password-store")
:source "." ;; not used
:type 'password-store
:search-function #'auth-source-pass-search)

View file

@ -627,14 +627,14 @@ instead of the current project."
"Fills :directory or :file slots if they're missing in project THIS.
The other slot will be used to calculate values.
PROJECT-FILE-NAME is a name of project file (short name, like `pom.xml', etc."
(when (and (or (not (slot-boundp this :file))
(not (oref this file)))
(slot-boundp this :directory)
(when (and (not (and (slot-boundp this 'file)
(oref this file)))
(slot-boundp this 'directory)
(oref this directory))
(oset this file (expand-file-name project-file-name (oref this directory))))
(when (and (or (not (slot-boundp this :directory))
(not (oref this directory)))
(slot-boundp this :file)
(when (and (not (and (slot-boundp this 'directory)
(oref this directory)))
(slot-boundp this 'file)
(oref this file))
(oset this directory (file-name-directory (oref this file))))
)

View file

@ -154,14 +154,9 @@ the directory isn't on the `safe' list, ask to add it to the safe list."
(when (file-exists-p fname)
(message "Ignoring EDE config file for now and creating a new one. Use C-c . g to load it.")
;; Set how it was ignored.
(if loadask
(setq ignore-type 'manual)
(setq ignore-type 'auto))
)
(setq ignore-type (if loadask 'manual 'auto)))
;; Create a new one.
(setq config (make-instance class
"Configuration"
:file fname))
(setq config (make-instance class :file fname))
(oset config ignored-file ignore-type)
;; Set initial values based on project.

View file

@ -327,7 +327,7 @@ If one doesn't exist, create a new one for this directory."
(ans (object-assoc dir :path targets))
)
(when (not ans)
(setq ans (ede-cpp-root-target dir
(setq ans (ede-cpp-root-target
:name (file-name-nondirectory
(directory-file-name dir))
:path dir

View file

@ -118,7 +118,7 @@ All directories need at least one target.")
"Make sure the targets slot is bound."
(cl-call-next-method)
(unless (slot-boundp this 'targets)
(oset this :targets nil)))
(oset this targets nil)))
;;; File Stuff
;;

View file

@ -153,7 +153,7 @@ The class allocated value is replace by different sub classes.")
"Make sure the targets slot is bound."
(cl-call-next-method)
(unless (slot-boundp this 'targets)
(oset this :targets nil))
(oset this targets nil))
)
(cl-defmethod ede-project-root ((this ede-generic-project))

View file

@ -227,7 +227,7 @@ All directories need at least one target.")
"Make sure the targets slot is bound."
(cl-call-next-method)
(unless (slot-boundp this 'targets)
(oset this :targets nil)))
(oset this targets nil)))
;;; File Stuff
;;
@ -377,9 +377,9 @@ Argument COMMAND is the command to use for compiling the target."
(inc (ede-linux--include-path dir bdir arch))
(ver (ede-linux-version dir)))
(oset this version ver)
(oset this :build-directory bdir)
(oset this :architecture arch)
(oset this :include-path inc)
(oset this build-directory bdir)
(oset this architecture arch)
(oset this include-path inc)
))
(provide 'ede/linux)

View file

@ -89,7 +89,7 @@ based on `ede-locate-setup-options'."
(when (called-interactively-p 'interactive)
(message "Setting locator to ede-locate-base"))
(setq ans 'ede-locate-base))
(oset proj locate-obj (make-instance ans "Loc" :root root))
(oset proj locate-obj (make-instance ans :root root))
(when (called-interactively-p 'interactive)
(message "Setting locator to %s" ans))
))

View file

@ -480,7 +480,7 @@ This is used when subprojects are made in named subdirectories."
(bug (nth 2 pi))
(cof (nth 3 pi))
(ampf (project-am-makefile
pn :name pn
:name pn
:version ver
:mailinglist (or bug "")
:file fn)))

View file

@ -86,7 +86,7 @@ ROOTPROJ is nil, since we will only create a single EDE project here."
(obj nil))
(when pf
(setq obj (eieio-persistent-read pf))
(oset obj :directory dir)
(oset obj directory dir)
)
obj))

View file

@ -89,8 +89,7 @@ Use `semantic-analyze-current-tag' to debug this fcn."
(setq allhits (semantic--analyze-refs-full-lookup tag scope t))
(semantic-analyze-references (semantic-tag-name tag)
:tag tag
(semantic-analyze-references :tag tag
:tagdb db
:scope scope
:rawsearchdata allhits)

View file

@ -1256,8 +1256,7 @@ Use `semantic-analyze-current-tag' to debug this fcn."
(setq allhits (semantic--analyze-refs-full-lookup tag scope t)))
;; (setq refs
(semantic-analyze-references (semantic-tag-name tag)
:tag tag
(semantic-analyze-references :tag tag
:tagdb db
:scope scope
:rawsearchdata allhits)))) ;;)

View file

@ -1899,7 +1899,7 @@ completion text in ghost text."
(mapcar
(lambda (class)
(let* ((C (intern (car class)))
(doc (documentation-property C 'variable-documentation))
(doc (cl--class-docstring (cl--find-class C)))
(doc1 (car (split-string doc "\n")))
)
(list 'const
@ -1930,7 +1930,7 @@ DEFAULT-TAG is a semantic tag or string to use as the default value.
If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
HISTORY is a symbol representing a variable to store the history in."
(semantic-complete-read-tag-engine
(semantic-collector-buffer-deep prompt :buffer (current-buffer))
(semantic-collector-buffer-deep :buffer (current-buffer))
(semantic-displayer-traditional-with-focus-highlight)
;;(semantic-displayer-tooltip)
prompt
@ -1952,7 +1952,7 @@ DEFAULT-TAG is a semantic tag or string to use as the default value.
If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
HISTORY is a symbol representing a variable to store the history in."
(semantic-complete-read-tag-engine
(semantic-collector-local-members prompt :buffer (current-buffer))
(semantic-collector-local-members :buffer (current-buffer))
(semantic-displayer-traditional-with-focus-highlight)
;;(semantic-displayer-tooltip)
prompt
@ -1974,8 +1974,7 @@ DEFAULT-TAG is a semantic tag or string to use as the default value.
If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
HISTORY is a symbol representing a variable to store the history in."
(semantic-complete-read-tag-engine
(semantic-collector-project-brutish prompt
:buffer (current-buffer)
(semantic-collector-project-brutish :buffer (current-buffer)
:path (current-buffer)
)
(semantic-displayer-traditional-with-focus-highlight)
@ -2049,7 +2048,6 @@ prompts. these are calculated from the CONTEXT variable passed in."
(setq syms (nreverse (cdr (nreverse syms))))
(semantic-complete-read-tag-engine
(semantic-collector-analyze-completions
prompt
:buffer (oref context buffer)
:context context)
(semantic-displayer-traditional-with-focus-highlight)

View file

@ -309,11 +309,7 @@ If there is no database for DIRECTORY available, then
)
(if found
(setq db found)
(setq db (make-instance
dbeC
directory
:ebrowse-struct ebd
))
(setq db (make-instance dbeC :ebrowse-struct ebd))
(oset db reference-directory directory))
;; Once we recycle or make a new DB, refresh the

View file

@ -138,10 +138,6 @@ If DIRECTORY doesn't exist, create a new one."
(unless db
(setq db (make-instance
dbc ; Create the database requested. Perhaps
(concat (file-name-nondirectory
(directory-file-name
directory))
"/")
:file fn :tables nil
:semantic-tag-version semantic-tag-version
:semanticdb-version semanticdb-file-version)))

View file

@ -136,7 +136,7 @@ If there is no table, create one, and fill it in."
;; Make sure we have a cache object in the DB index.
(when (not cache)
;; The object won't change as we fill it with stuff.
(setq cache (semanticdb-typecache (semanticdb-full-filename table)))
(setq cache (semanticdb-typecache))
(oset idx type-cache cache))
cache))

View file

@ -188,7 +188,6 @@ If one doesn't exist, create it."
(oref obj index)
(let ((idx nil))
(setq idx (funcall semanticdb-default-find-index-class
(concat (eieio-object-name obj) " index")
;; Fill in the defaults
:table obj
))
@ -413,7 +412,6 @@ If the table for FILE does not exist, create one."
;; This implementation will satisfy autoloaded classes
;; for tables.
(setq newtab (funcall (oref db new-table-class)
(file-name-nondirectory file)
:file (file-name-nondirectory file)
))
(setf (slot-value newtab 'parent-db) db)
@ -486,7 +484,7 @@ other than :table."
(if obj
obj ;; Just return it.
;; No object, let's create a new one and return that.
(setq obj (funcall desired-class "Cache" :table table))
(setq obj (make-instance desired-class :table table))
(object-add-to-list table 'cache obj)
obj)))

View file

@ -197,7 +197,7 @@ The resulting bookmark is then sorted within the ring."
(ring-remove ring idx))
(setq idx (1+ idx)))
;; Create a new mark
(let ((sbm (semantic-bookmark (semantic-tag-name tag)
(let ((sbm (semantic-bookmark :object-name (semantic-tag-name tag)
:tag tag)))
;; Take the mark, and update it for the current state.
(ring-insert ring sbm)

View file

@ -199,8 +199,7 @@ STATE is the current compilation state."
(tag nil)
(class nil)
(table nil)
(STATE (srecode-compile-state (file-name-nondirectory
(buffer-file-name))))
(STATE (srecode-compile-state))
(mode nil)
(application nil)
(framework nil)
@ -263,7 +262,7 @@ STATE is the current compilation state."
;; Create a compound dictionary value from "value".
(require 'srecode/dictionary)
(let ((cv (srecode-dictionary-compound-variable
name :value value)))
:value value)))
(setq vars (cons (cons name cv) vars)))
))
)
@ -361,7 +360,7 @@ STATE is the current compile state as an object of class
:where 'end)))))))
;; Construct and return the template object.
(srecode-template (semantic-tag-name tag)
(srecode-template :object-name (semantic-tag-name tag)
:context context
:args (nreverse addargs)
:dictionary root-dict
@ -504,7 +503,8 @@ PROPS are additional properties that might need to be passed
to the inserter constructor."
;;(message "Compile: %s %S" name props)
(if (not key)
(apply #'make-instance 'srecode-template-inserter-variable name props)
(apply #'make-instance 'srecode-template-inserter-variable
:object-name name props)
(let ((classes (eieio-class-children 'srecode-template-inserter))
(new nil))
;; Loop over the various subclasses and
@ -515,7 +515,8 @@ to the inserter constructor."
(when (and (not (class-abstract-p (car classes)))
(equal (oref-default (car classes) key) key))
;; Create the new class, and apply state.
(setq new (apply #'make-instance (car classes) name props))
(setq new (apply #'make-instance (car classes)
:object-name name props))
(srecode-inserter-apply-state new STATE)
)
(setq classes (cdr classes)))
@ -589,7 +590,7 @@ A list of defined variables VARS provides a variable table."
(cl-defmethod srecode-dump ((tmp srecode-template))
"Dump the contents of the SRecode template tmp."
(princ "== Template \"")
(princ (eieio-object-name-string tmp))
(princ (slot-value tmp 'object-name))
(princ "\" in context ")
(princ (oref tmp context))
(princ "\n")
@ -635,7 +636,7 @@ Argument INDENT specifies the indentation level for the list."
(cl-defmethod srecode-dump ((ins srecode-template-inserter) _indent)
"Dump the state of the SRecode template inserter INS."
(princ "INS: \"")
(princ (eieio-object-name-string ins))
(princ (slot-value ins 'object-name))
(when (oref ins secondname)
(princ "\" : \"")
(princ (oref ins secondname)))

View file

@ -146,8 +146,7 @@ specified in a C file."
(value-dict (srecode-dictionary-add-section-dictionary
dict "VALUE")))
(srecode-semantic-apply-tag-to-dict
(srecode-semantic-tag (semantic-tag-name value-tag)
:prime value-tag)
(srecode-semantic-tag :prime value-tag)
value-dict))
;; Discriminate using statements referring to namespaces and
@ -224,8 +223,7 @@ specified in a C file."
(let ((template-dict (srecode-dictionary-add-section-dictionary
templates-dict "ARGS")))
(srecode-semantic-apply-tag-to-dict
(srecode-semantic-tag (semantic-tag-name template)
:prime template)
(srecode-semantic-tag :prime template)
template-dict)))))
)

View file

@ -369,7 +369,7 @@ values but STATE is nil."
(srecode-dictionary-set-value
dict name
(srecode-dictionary-compound-variable
name :value value :state state)))))
:value value :state state)))))
(setq entries (nthcdr 2 entries)))
dict)
@ -536,7 +536,7 @@ inserted with a new editable field.")
(error "Unknown default value for value %S" name)))
;; Create a field from the inserter.
(srecode-field name :name name
(srecode-field :name name
:start start
:end (point)
:prompt (oref sti prompt)

View file

@ -648,8 +648,7 @@ Use DICTIONARY to resolve values."
Use DICTIONARY to resolve values."
(let* ((default (srecode-insert-ask-default sti dictionary))
(compound-value
(srecode-field-value (oref sti object-name)
:firstinserter sti
(srecode-field-value :firstinserter sti
:defaultvalue default))
)
;; Return this special compound value as the thing to insert.
@ -806,7 +805,7 @@ Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(srecode-insert-report-error
dict
"Only section dictionaries allowed for `%s'"
(eieio-object-name-string sti)))
(slot-value sti 'object-name)))
;; Output the code from the sub-template.
(srecode-insert-method (slot-value sti slot) dict))
@ -860,10 +859,10 @@ applied to the text between the section start and the
"For the section inserter INS, parse INPUT.
Shorten input until the END token is found.
Return the remains of INPUT."
(let* ((out (srecode-compile-split-code tag input STATE
(oref ins object-name))))
(let* ((name (oref ins object-name))
(out (srecode-compile-split-code tag input STATE name)))
(oset ins template (srecode-template
(eieio-object-name-string ins)
:object-name name
:context nil
:args nil
:code (cdr out)))

View file

@ -338,7 +338,7 @@ if that file is NEW, otherwise assume the mode has not changed."
;; Only do the save if we are dirty, or if we are in an interactive
;; Emacs.
(when (and dirty (not noninteractive)
(slot-boundp srecode-current-map :file))
(slot-boundp srecode-current-map 'file))
(eieio-persistent-save srecode-current-map))
))

View file

@ -207,7 +207,7 @@ MENU-DEF is the menu to bind this into."
(ctxtcons (assoc ctxt alltabs))
(bind (if (slot-boundp temp 'binding)
(oref temp binding)))
(name (eieio-object-name-string temp)))
(name (slot-value temp 'object-name)))
(when (not ctxtcons)
(if (string= context ctxt)

View file

@ -129,8 +129,7 @@ variable default values, and other things."
larg nil nil)))
;; Apply the sub-argument to the subdictionary.
(srecode-semantic-apply-tag-to-dict
(srecode-semantic-tag (semantic-tag-name larg)
:prime larg)
(srecode-semantic-tag :prime larg)
subdict)
)
;; Next!
@ -203,8 +202,7 @@ variable default values, and other things."
(when (not tag)
(error "No tag for current template. Use the semantic kill-ring"))
(srecode-semantic-apply-tag-to-dict
(srecode-semantic-tag (semantic-tag-name tag)
:prime tag)
(srecode-semantic-tag :prime tag)
dict)))
;;; :tagtype ARGUMENT HANDLING
@ -394,7 +392,7 @@ as `function' will leave point where code might be inserted."
;; Resolve TAG into the dictionary. We may have a :tag arg
;; from the macro such that we don't need to do this.
(when (not (srecode-dictionary-lookup-name dict "TAG"))
(let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag))
(let ((tagobj (srecode-semantic-tag :prime tag))
)
(srecode-semantic-apply-tag-to-dict tagobj dict)))

View file

@ -276,7 +276,7 @@ we can tell font lock about them.")
(prin1 (format "%c" key))
)))
(terpri)
(princ (documentation-property C 'variable-documentation))
(princ (cl--class-docstring (cl--find-class C)))
(terpri)
(when showexample
(princ "Example:")
@ -503,7 +503,7 @@ section or ? for an ask variable."
(when inserter
(let ((base
(cons (oref inserter object-name)
(if (and (slot-boundp inserter :secondname)
(if (and (slot-boundp inserter 'secondname)
(oref inserter secondname))
(split-string (oref inserter secondname)
":")

View file

@ -180,7 +180,6 @@ INIT are the initialization parameters for the new template table."
(old (srecode-mode-table-find mt file))
(attr (file-attributes file))
(new (apply #'srecode-template-table
(file-name-nondirectory file)
:file file
:filesize (file-attribute-size attr)
:filedate (file-attribute-modification-time attr)

View file

@ -740,18 +740,19 @@ Argument FN is the function calling this verifier."
;;; Get/Set slots in an object.
(eval-and-compile
(defun eieio--check-slot-name (exp _obj slot &rest _)
(pcase slot
((and (or `',name (and name (pred keywordp)))
(guard (not (eieio--known-slot-name-p name))))
(macroexp-warn-and-return
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only name))
(_ exp))))
(defun eieio-oref (obj slot)
"Return the value in OBJ at SLOT in the object vector."
(declare (compiler-macro
(lambda (exp)
(ignore obj)
(pcase slot
((and (or `',name (and name (pred keywordp)))
(guard (not (eieio--known-slot-name-p name))))
(macroexp-warn-and-return
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only name))
(_ exp))))
(declare (compiler-macro eieio--check-slot-name)
;; FIXME: Make it a gv-expander such that the hash-table lookup is
;; only performed once when used in `push' and friends?
(gv-setter eieio-oset))
@ -822,6 +823,7 @@ Fills in CLASS's SLOT with its default value."
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
Fills in OBJ's SLOT with VALUE."
(declare (compiler-macro eieio--check-slot-name))
(cl-check-type slot symbol)
(cond
((cl-typep obj '(or eieio-object cl-structure-object))

View file

@ -31,6 +31,7 @@
;; `:custom'.
(require 'eieio)
(require 'eieio-base) ;; For `eieio-named's slot.
(require 'widget)
(require 'wid-edit)

View file

@ -304,7 +304,7 @@ and reference them using the function `class-option'."
;; but hide it so we don't trigger indefinitely.
`(,(car whole) (identity ,(car slots))
,@(cdr slots))
nil nil (car slots))))
'(obsolete eieio-constructor-name-arg) nil (car slots))))
;;; Get/Set slots in an object.
;;
@ -554,6 +554,7 @@ after they are created."
Setting a slot's value makes it bound. Calling `slot-makeunbound' will
make a slot unbound.
OBJECT can be an instance or a class."
(declare (compiler-macro eieio--check-slot-name))
;; Skip typechecking while retrieving this value.
(let ((eieio-skip-typecheck t))
;; Return nil if the magic symbol is in there.
@ -700,6 +701,20 @@ for each slot. For example:
(make-instance \\='foo :slot1 value1 :slotN valueN)")
(put 'make-instance 'compiler-macro
(lambda (whole class &rest slots)
(if (or (null slots) (keywordp (car slots))
;; Detect the second pass!
(eq 'identity (car-safe (car slots))))
whole
(macroexp-warn-and-return
(format "Obsolete name arg %S to `make-instance'" (car slots))
;; Keep the name arg, for backward compatibility,
;; but hide it so we don't trigger indefinitely.
`(,(car whole) ,class (identity ,(car slots))
,@(cdr slots))
'(obsolete eieio-constructor-name-arg) nil (car slots)))))
(define-obsolete-function-alias 'constructor #'make-instance "25.1")
(cl-defmethod make-instance

View file

@ -138,7 +138,7 @@
(:AFTER eitest-B-base1)
(:AFTER eitest-B)
)))
(eitest-F (eitest-B nil))
(eitest-F (eitest-B))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
@ -153,7 +153,9 @@
(ert-deftest eieio-test-method-order-list-4 ()
;; Both of these situations should succeed.
(should (eitest-H 'eitest-A))
(should (eitest-H (eitest-A nil))))
(let ((eieio-backward-compatibility t))
(with-suppressed-warnings ((obsolete eieio-constructor-name-arg))
(should (eitest-H (eitest-A nil))))))
;;; Return value from :PRIMARY
;;
@ -213,7 +215,7 @@
(:STATIC C-base1)
(:STATIC C-base2)
)))
(C nil)
(C)
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
@ -262,7 +264,7 @@
(:PRIMARY D-base2)
(:PRIMARY D-base0)
)))
(eitest-F (D nil))
(eitest-F (D))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
@ -304,7 +306,7 @@
(:PRIMARY E-base2)
(:PRIMARY E-base0)
)))
(eitest-F (E nil))
(eitest-F (E))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))

View file

@ -430,6 +430,9 @@ METHOD is the method that was attempting to be called."
(defclass virtual-slot-class ()
((base-value :initarg :base-value))
"Class has real slot :base-value and simulated slot :derived-value.")
(eieio-declare-slots derived-value)
(with-suppressed-warnings ((obsolete defmethod)
(obsolete defgeneric))
(defmethod slot-missing ((vsc virtual-slot-class)

View file

@ -76,7 +76,6 @@
(setq endpoint
(make-instance
'jsonrpc--test-client
"Emacs RPC client"
:process
(open-network-stream "JSONRPC test tcp endpoint"
nil "localhost"