1;;; semantic/util.el --- Utilities for use with semantic tag tables 2 3;;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc. 4 5;; Author: Eric M. Ludlam <zappo@gnu.org> 6;; Keywords: syntax 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software: you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation, either version 3 of the License, or 13;; (at your option) any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 22 23;;; Commentary: 24;; 25;; Semantic utility API for use with semantic tag tables. 26;; 27 28(require 'semantic) 29 30(eval-when-compile 31 (require 'semantic/db-find) 32 ;; For semantic-find-tags-by-class, semantic--find-tags-by-function, 33 ;; and semantic-brute-find-tag-standard: 34 (require 'semantic/find)) 35 36(declare-function data-debug-insert-stuff-list "data-debug") 37(declare-function data-debug-insert-thing "data-debug") 38(declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt") 39 40;;; Code: 41 42(defvar semantic-type-relation-separator-character '(".") 43 "Character strings used to separate a parent/child relationship. 44This list of strings are used for displaying or finding separators 45in variable field dereferencing. The first character will be used for 46display. In C, a type field is separated like this: \"type.field\" 47thus, the character is a \".\". In C, and additional value of \"->\" 48would be in the list, so that \"type->field\" could be found.") 49(make-variable-buffer-local 'semantic-type-relation-separator-character) 50 51(defvar semantic-equivalent-major-modes nil 52 "List of major modes which are considered equivalent. 53Equivalent modes share a parser, and a set of override methods. 54A value of nil means that the current major mode is the only one.") 55(make-variable-buffer-local 'semantic-equivalent-major-modes) 56 57(declare-function semanticdb-file-stream "semantic/db" (file)) 58 59;; These semanticdb calls will throw warnings in the byte compiler. 60;; Doing the right thing to make them available at compile time 61;; really messes up the compilation sequence. 62(defun semantic-file-tag-table (file) 63 "Return a tag table for FILE. 64If it is loaded, return the stream after making sure it's ok. 65If FILE is not loaded, check to see if `semanticdb' feature exists, 66 and use it to get tags from files not in memory. 67If FILE is not loaded, and semanticdb is not available, find the file 68 and parse it." 69 (save-match-data 70 (if (find-buffer-visiting file) 71 (with-current-buffer (find-buffer-visiting file) 72 (semantic-fetch-tags)) 73 ;; File not loaded 74 (if (and (require 'semantic/db-mode) 75 (semanticdb-minor-mode-p)) 76 ;; semanticdb is around, use it. 77 (semanticdb-file-stream file) 78 ;; Get the stream ourselves. 79 (with-current-buffer (find-file-noselect file) 80 (semantic-fetch-tags)))))) 81 82(semantic-alias-obsolete 'semantic-file-token-stream 83 'semantic-file-tag-table "23.2") 84 85(declare-function semanticdb-abstract-table-child-p "semantic/db" (obj) t) 86(declare-function semanticdb-refresh-table "semantic/db") 87(declare-function semanticdb-get-tags "semantic/db" (arg &rest args) t) 88(declare-function semanticdb-find-results-p "semantic/db-find" (resultp)) 89 90(defun semantic-something-to-tag-table (something) 91 "Convert SOMETHING into a semantic tag table. 92Something can be a tag with a valid BUFFER property, a tag table, a 93buffer, or a filename. If SOMETHING is nil return nil." 94 (cond 95 ;; A list of tags 96 ((and (listp something) 97 (semantic-tag-p (car something))) 98 something) 99 ;; A buffer 100 ((bufferp something) 101 (with-current-buffer something 102 (semantic-fetch-tags))) 103 ;; A Tag: Get that tag's buffer 104 ((and (semantic-tag-with-position-p something) 105 (semantic-tag-in-buffer-p something)) 106 (with-current-buffer (semantic-tag-buffer something) 107 (semantic-fetch-tags))) 108 ;; Tag with a file name in it 109 ((and (semantic-tag-p something) 110 (semantic-tag-file-name something) 111 (file-exists-p (semantic-tag-file-name something))) 112 (semantic-file-tag-table 113 (semantic-tag-file-name something))) 114 ;; A file name 115 ((and (stringp something) 116 (file-exists-p something)) 117 (semantic-file-tag-table something)) 118 ;; A Semanticdb table 119 ((and (featurep 'semantic/db) 120 (require 'semantic/db-mode) 121 (semanticdb-minor-mode-p) 122 (cl-typep something 'semanticdb-abstract-table)) 123 (semanticdb-refresh-table something) 124 (semanticdb-get-tags something)) 125 ;; Semanticdb find-results 126 ((and (featurep 'semantic/db) 127 (require 'semantic/db-mode) 128 (semanticdb-minor-mode-p) 129 (require 'semantic/db-find) 130 (semanticdb-find-results-p something)) 131 (semanticdb-strip-find-results something)) 132 ;; NOTE: This commented out since if a search result returns 133 ;; empty, that empty would turn into everything on the next search. 134 ;; Use the current buffer for nil 135;; ((null something) 136;; (semantic-fetch-tags)) 137 ;; don't know what it is 138 (t nil))) 139 140(semantic-alias-obsolete 'semantic-something-to-stream 141 'semantic-something-to-tag-table "23.2") 142 143;;; Completion APIs 144;; 145;; These functions provide minibuffer reading/completion for lists of 146;; nonterminals. 147(defvar semantic-read-symbol-history nil 148 "History for a symbol read.") 149 150(declare-function semantic-brute-find-tag-by-function 151 "semantic/find" 152 (function streamorbuffer 153 &optional search-parts search-includes)) 154 155(defun semantic-read-symbol (prompt &optional default stream filter) 156 "Read a symbol name from the user for the current buffer. 157PROMPT is the prompt to use. 158Optional arguments: 159DEFAULT is the default choice. If no default is given, one is read 160from under point. 161STREAM is the list of tokens to complete from. 162FILTER is provides a filter on the types of things to complete. 163FILTER must be a function to call on each element." 164 (if (not default) (setq default (thing-at-point 'symbol))) 165 (if (not stream) (setq stream (semantic-fetch-tags))) 166 (setq stream 167 (if filter 168 (semantic--find-tags-by-function filter stream) 169 (require 'semantic/find) 170 (semantic-brute-find-tag-standard stream))) 171 (if (and default (string-match ":" prompt)) 172 (setq prompt 173 (concat (substring prompt 0 (match-end 0)) 174 " (default: " default ") "))) 175 (completing-read prompt stream nil t "" 176 'semantic-read-symbol-history 177 default)) 178 179(defun semantic-read-variable (prompt &optional default stream) 180 "Read a variable name from the user for the current buffer. 181PROMPT is the prompt to use. 182Optional arguments: 183DEFAULT is the default choice. If no default is given, one is read 184from under point. 185STREAM is the list of tokens to complete from." 186 (semantic-read-symbol 187 prompt default 188 (or (semantic-find-tags-by-class 189 'variable (or stream (current-buffer))) 190 (error "No local variables")))) 191 192(defun semantic-read-function (prompt &optional default stream) 193 "Read a function name from the user for the current buffer. 194PROMPT is the prompt to use. 195Optional arguments: 196DEFAULT is the default choice. If no default is given, one is read 197from under point. 198STREAM is the list of tags to complete from." 199 (semantic-read-symbol 200 prompt default 201 (or (semantic-find-tags-by-class 202 'function (or stream (current-buffer))) 203 (error "No local functions")))) 204 205(defun semantic-read-type (prompt &optional default stream) 206 "Read a type name from the user for the current buffer. 207PROMPT is the prompt to use. 208Optional arguments: 209DEFAULT is the default choice. If no default is given, one is read 210from under point. 211STREAM is the list of tags to complete from." 212 (semantic-read-symbol 213 prompt default 214 (or (semantic-find-tags-by-class 215 'type (or stream (current-buffer))) 216 (error "No local types")))) 217 218 219;;; Interactive Functions for 220;; 221(defun semantic-describe-tag (&optional tag) 222 "Describe TAG in the minibuffer. 223If TAG is nil, describe the tag under the cursor." 224 (interactive) 225 (if (not tag) (setq tag (semantic-current-tag))) 226 (semantic-fetch-tags) 227 (if tag (message (semantic-format-tag-summarize tag)))) 228 229 230;;; Putting keys on tags. 231;; 232(defun semantic-add-label (label value &optional tag) 233 "Add a LABEL with VALUE on TAG. 234If TAG is not specified, use the tag at point." 235 (interactive "sLabel: \nXValue (eval): ") 236 (if (not tag) 237 (progn 238 (semantic-fetch-tags) 239 (setq tag (semantic-current-tag)))) 240 (semantic--tag-put-property tag (intern label) value) 241 (message "Added label %s with value %S" label value)) 242 243(defun semantic-show-label (label &optional tag) 244 "Show the value of LABEL on TAG. 245If TAG is not specified, use the tag at point." 246 (interactive "sLabel: ") 247 (if (not tag) 248 (progn 249 (semantic-fetch-tags) 250 (setq tag (semantic-current-tag)))) 251 (message "%s: %S" label (semantic--tag-get-property tag (intern label)))) 252 253 254;;; Hacks 255;; 256;; Some hacks to help me test these functions 257(defun semantic-describe-buffer-var-helper (varsym buffer) 258 "Display to standard out the value of VARSYM in BUFFER." 259 (require 'data-debug) 260 (let ((value (with-current-buffer buffer 261 (symbol-value varsym)))) 262 (cond 263 ((and (consp value) 264 (< (length value) 10)) 265 ;; Draw the list of things in the list. 266 (princ (format " %s: #<list of %d items>\n" 267 varsym (length value))) 268 (data-debug-insert-stuff-list 269 value " " ) 270 ) 271 (t 272 ;; Else do a one-liner. 273 (data-debug-insert-thing 274 value " " (concat " " (symbol-name varsym) ": ")) 275 )))) 276 277(defun semantic-describe-buffer () 278 "Describe the semantic environment for the current buffer." 279 (interactive) 280 (let ((buff (current-buffer)) 281 ) 282 283 (with-output-to-temp-buffer (help-buffer) 284 (help-setup-xref (list #'semantic-describe-buffer) 285 (called-interactively-p 'interactive)) 286 (with-current-buffer standard-output 287 (princ "Semantic Configuration in ") 288 (princ (buffer-name buff)) 289 (princ "\n\n") 290 291 (princ "Buffer specific configuration items:\n") 292 (let ((vars '(major-mode 293 semantic-case-fold 294 semantic-tag-expand-function 295 semantic-parser-name 296 semantic-parse-tree-state 297 semantic-lex-analyzer 298 semantic-lex-reset-functions 299 semantic-lex-syntax-modifications 300 ))) 301 (dolist (V vars) 302 (semantic-describe-buffer-var-helper V buff))) 303 304 (princ "\nGeneral configuration items:\n") 305 (let ((vars '(semantic-inhibit-functions 306 semantic-init-hook 307 semantic-init-db-hook 308 semantic-unmatched-syntax-hook 309 semantic--before-fetch-tags-hook 310 semantic-after-toplevel-bovinate-hook 311 semantic-after-toplevel-cache-change-hook 312 semantic-before-toplevel-cache-flush-hook 313 semantic-dump-parse 314 semantic-type-relation-separator-character 315 semantic-command-separation-character 316 semantic-new-buffer-fcn-was-run 317 ))) 318 (dolist (V vars) 319 (semantic-describe-buffer-var-helper V buff))) 320 321 (princ "\n\n") 322 (mode-local-describe-bindings-2 buff) 323 ))) 324 ) 325 326(defun semantic-assert-valid-token (tok) 327 "Assert that TOK is a valid token." 328 (if (semantic-tag-p tok) 329 (if (semantic-tag-with-position-p tok) 330 (let ((o (semantic-tag-overlay tok))) 331 (if (and (overlayp o) 332 (not (overlay-buffer o))) 333 (let ((debug-on-error t)) 334 (error "Tag %s is invalid!" (semantic-tag-name tok))) 335 ;; else, tag is OK. 336 )) 337 ;; Positionless tags are also ok. 338 ) 339 (let ((debug-on-error t)) 340 (error "Not a semantic tag: %S" tok)))) 341 342(defun semantic-sanity-check (&optional cache over notfirst) 343 "Perform a sanity check on the current buffer. 344The buffer's set of overlays, and those overlays found via the cache 345are verified against each other. 346CACHE, and OVER are the semantic cache, and the overlay list. 347NOTFIRST indicates that this was not the first call in the recursive use." 348 (interactive) 349 (if (and (not cache) (not over) (not notfirst)) 350 (setq cache semantic--buffer-cache 351 over (overlays-in (point-min) (point-max)))) 352 (while cache 353 (let ((chil (semantic-tag-components-with-overlays (car cache)))) 354 (if (not (memq (semantic-tag-overlay (car cache)) over)) 355 (message "Tag %s not in buffer overlay list." 356 (semantic-format-tag-concise-prototype (car cache)))) 357 (setq over (delq (semantic-tag-overlay (car cache)) over)) 358 (setq over (semantic-sanity-check chil over t)) 359 (setq cache (cdr cache)))) 360 (if (not notfirst) 361 ;; Strip out all overlays which aren't semantic overlays 362 (let ((o nil)) 363 (while over 364 (when (and (overlay-get (car over) 'semantic) 365 (not (eq (overlay-get (car over) 'semantic) 366 'unmatched))) 367 (setq o (cons (car over) o))) 368 (setq over (cdr over))) 369 (when (called-interactively-p 'any) 370 (message "Remaining overlays: %S" o)))) 371 over) 372 373;;; Interactive commands (from Senator). 374 375;; The Senator library from upstream CEDET is not included in the 376;; built-in version of Emacs. The plan is to fold it into the 377;; different parts of CEDET and Emacs, so that it works 378;; "transparently". Here are some interactive commands based on 379;; Senator. 380 381;; Symbol completion 382 383(declare-function semanticdb-fast-strip-find-results 384 "semantic/db-find" (results)) 385(declare-function semanticdb-deep-find-tags-for-completion 386 "semantic/db-find" (prefix &optional path find-file-match)) 387 388(defun semantic-find-tag-for-completion (prefix) 389 "Find all tags with name starting with PREFIX. 390This uses `semanticdb' when available." 391 (let (result ctxt) 392 ;; Try the Semantic analyzer 393 (condition-case nil 394 (and (featurep 'semantic/analyze) 395 (setq ctxt (semantic-analyze-current-context)) 396 (setq result (semantic-analyze-possible-completions ctxt))) 397 (error nil)) 398 (or result 399 ;; If the analyzer fails, then go into boring completion. 400 (if (and (featurep 'semantic/db) 401 (semanticdb-minor-mode-p) 402 (require 'semantic/db-find)) 403 (semanticdb-fast-strip-find-results 404 (semanticdb-deep-find-tags-for-completion prefix)) 405 (semantic-deep-find-tags-for-completion prefix (current-buffer)))))) 406 407(defun semantic-complete-symbol (&optional predicate) 408 "Complete the symbol under point, using Semantic facilities. 409When called from a program, optional arg PREDICATE is a predicate 410determining which symbols are considered." 411 (interactive) 412 (require 'semantic/ctxt) 413 (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds 414 (point))))) 415 (pattern (regexp-quote (buffer-substring start (point)))) 416 collection completion) 417 (when start 418 (if (and semantic--completion-cache 419 (eq (nth 0 semantic--completion-cache) (current-buffer)) 420 (= (nth 1 semantic--completion-cache) start) 421 (save-excursion 422 (goto-char start) 423 (looking-at (nth 3 semantic--completion-cache)))) 424 ;; Use cached value. 425 (setq collection (nthcdr 4 semantic--completion-cache)) 426 ;; Perform new query. 427 (setq collection (semantic-find-tag-for-completion pattern)) 428 (setq semantic--completion-cache 429 (append (list (current-buffer) start 0 pattern) 430 collection)))) 431 (if (null collection) 432 (let ((str (if pattern (format " for \"%s\"" pattern) ""))) 433 (if (window-minibuffer-p (selected-window)) 434 (minibuffer-message (format " [No completions%s]" str)) 435 (message "Can't find completion%s" str))) 436 (setq completion (try-completion pattern collection predicate)) 437 (if (string= pattern completion) 438 (let ((list (all-completions pattern collection predicate))) 439 (setq list (sort list 'string<)) 440 (if (> (length list) 1) 441 (with-output-to-temp-buffer "*Completions*" 442 (display-completion-list 443 (completion-hilit-commonality list (length pattern) nil))) 444 ;; Bury any out-of-date completions buffer. 445 (let ((win (get-buffer-window "*Completions*" 0))) 446 (if win (with-selected-window win (bury-buffer)))))) 447 ;; Exact match 448 (delete-region start (point)) 449 (insert completion) 450 ;; Bury any out-of-date completions buffer. 451 (let ((win (get-buffer-window "*Completions*" 0))) 452 (if win (with-selected-window win (bury-buffer)))))))) 453 454(provide 'semantic/util) 455 456;;; Minor modes 457;; 458(require 'semantic/util-modes) 459 460;;; semantic/util.el ends here 461