diff options
| -rw-r--r-- | lisp/apropos.el | 221 |
1 files changed, 92 insertions, 129 deletions
diff --git a/lisp/apropos.el b/lisp/apropos.el index 459dc72b475..e95f45f1804 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -54,6 +54,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup apropos nil "Apropos commands for users and programmers." :group 'help @@ -193,9 +195,6 @@ property list, WIDGET-DOC is the widget docstring, FACE-DOC is the face docstring, and CUS-GROUP-DOC is the custom group docstring. Each docstring is either nil or a string.") -(defvar apropos-item () - "Current item in or for `apropos-accumulator'.") - (defvar apropos-synonyms '( ("find" "open" "edit") ("kill" "cut") @@ -906,6 +905,18 @@ Optional arg BUFFER (default: current buffer) is the buffer to check." ((symbolp def) (funcall f def)) ((eq 'defun (car-safe def)) (funcall f (cdr def))))))))) +(defun apropos--documentation-add (symbol doc pos) + (when (setq doc (apropos-documentation-internal doc)) + (let ((score (apropos-score-doc doc)) + (item (cdr (assq symbol apropos-accumulator)))) + (unless item + (push (cons symbol + (setq item (list (apropos-score-symbol symbol 2) + nil nil))) + apropos-accumulator)) + (setf (nth pos item) doc) + (setcar item (+ (car item) score))))) + ;;;###autoload (defun apropos-documentation (pattern &optional do-all) "Show symbols whose documentation contains matches for PATTERN. @@ -928,40 +939,28 @@ Returns list of symbols and documentation found." (setq apropos--current (list #'apropos-documentation pattern do-all)) (apropos-parse-pattern pattern t) (or do-all (setq do-all apropos-do-all)) - (setq apropos-accumulator () apropos-files-scanned ()) - (with-temp-buffer - (let ((standard-input (current-buffer)) - (apropos-sort-by-scores apropos-documentation-sort-by-scores) - f v sf sv) - (apropos-documentation-check-doc-file) - (funcall - (if do-all #'mapatoms #'apropos--map-preloaded-atoms) - (lambda (symbol) - (setq f (apropos-safe-documentation symbol) - v (get symbol 'variable-documentation)) - (if (integerp v) (setq v nil)) - (setq f (apropos-documentation-internal f) - v (apropos-documentation-internal v)) - (setq sf (apropos-score-doc f) - sv (apropos-score-doc v)) - (if (or f v) - (if (setq apropos-item - (cdr (assq symbol apropos-accumulator))) - (progn - (if f - (progn - (setcar (nthcdr 1 apropos-item) f) - (setcar apropos-item (+ (car apropos-item) sf)))) - (if v - (progn - (setcar (nthcdr 2 apropos-item) v) - (setcar apropos-item (+ (car apropos-item) sv))))) - (setq apropos-accumulator - (cons (list symbol - (+ (apropos-score-symbol symbol 2) sf sv) - f v) - apropos-accumulator)))))) - (apropos-print nil "\n----------------\n" nil t)))) + (let ((apropos-accumulator ()) + (apropos-files-scanned ()) + (delayed (make-hash-table :test #'equal))) + (with-temp-buffer + (let ((standard-input (current-buffer)) + (apropos-sort-by-scores apropos-documentation-sort-by-scores) + f v) + (apropos-documentation-check-doc-file) + (funcall + (if do-all #'mapatoms #'apropos--map-preloaded-atoms) + (lambda (symbol) + (setq f (apropos-safe-documentation symbol) + v (get symbol 'variable-documentation)) + (if (integerp v) (setq v nil)) + (if (consp f) + (push (list symbol (cdr f) 1) (gethash (car f) delayed)) + (apropos--documentation-add symbol f 1)) + (if (consp v) + (push (list symbol (cdr v) 2) (gethash (car v) delayed)) + (apropos--documentation-add symbol v 2)))) + (maphash #'apropos--documentation-add-from-elc delayed) + (apropos-print nil "\n----------------\n" nil t))))) (defun apropos-value-internal (predicate symbol function) @@ -982,11 +981,11 @@ Returns list of symbols and documentation found." symbol))) (defun apropos-documentation-internal (doc) + ;; By the time we get here, refs to DOC or to .elc files should have + ;; been converted into actual strings. + (cl-assert (not (or (consp doc) (integerp doc)))) (cond - ((consp doc) - (apropos-documentation-check-elc-file (car doc))) - ((and doc - ;; Sanity check in case bad data sneaked into the + ((and ;; Sanity check in case bad data sneaked into the ;; documentation slot. (stringp doc) (string-match apropos-all-words-regexp doc) @@ -1053,89 +1052,51 @@ non-nil." ;; So we exclude them. (cond ((= 3 type) (boundp symbol)) ((= 2 type) (fboundp symbol)))) - (or (and (setq apropos-item (assq symbol apropos-accumulator)) - (setcar (cdr apropos-item) - (apropos-score-doc doc))) - (setq apropos-item (list symbol - (+ (apropos-score-symbol symbol 2) - (apropos-score-doc doc)) - nil nil) - apropos-accumulator (cons apropos-item - apropos-accumulator))) - (when apropos-match-face - (setq doc (substitute-command-keys doc)) - (if (or (string-match apropos-pattern-quoted doc) - (string-match apropos-all-words-regexp doc)) - (put-text-property (match-beginning 0) - (match-end 0) - 'face apropos-match-face doc))) - (setcar (nthcdr type apropos-item) doc)))) + (let ((apropos-item (assq symbol apropos-accumulator))) + (or (and apropos-item + (setcar (cdr apropos-item) + (apropos-score-doc doc))) + (setq apropos-item (list symbol + (+ (apropos-score-symbol symbol 2) + (apropos-score-doc doc)) + nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (when apropos-match-face + (setq doc (substitute-command-keys doc)) + (if (or (string-match apropos-pattern-quoted doc) + (string-match apropos-all-words-regexp doc)) + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face doc))) + (setcar (nthcdr type apropos-item) doc))))) (setq sepa (goto-char sepb))))) -(defun apropos-documentation-check-elc-file (file) - ;; .elc files have the location of the file specified as #$, but for - ;; built-in files, that's a relative name (while for the rest, it's - ;; absolute). So expand the name in the former case. - (unless (file-name-absolute-p file) - (setq file (expand-file-name file lisp-directory))) - (if (or (member file apropos-files-scanned) - (not (file-exists-p file))) - nil - (let (symbol doc beg end this-is-a-variable) - (setq apropos-files-scanned (cons file apropos-files-scanned)) - (erase-buffer) - (insert-file-contents file) - (while (search-forward "#@" nil t) - ;; Read the comment length, and advance over it. - ;; This #@ may be a false positive, so don't get upset if - ;; it's not followed by the expected number of bytes to skip. - (when (and (setq end (ignore-errors (read))) (natnump end)) - (setq beg (1+ (point)) - end (+ (point) end -1)) - (forward-char) - (if (save-restriction - ;; match ^ and $ relative to doc string - (narrow-to-region beg end) - (re-search-forward apropos-all-words-regexp nil t)) - (progn - (goto-char (+ end 2)) - (setq doc (buffer-substring beg end) - end (- (match-end 0) beg) - beg (- (match-beginning 0) beg)) - (when (apropos-true-hit-doc doc) - (setq this-is-a-variable (looking-at "(def\\(var\\|const\\) ") - symbol (progn - (skip-chars-forward "(a-z") - (forward-char) - (read)) - symbol (if (consp symbol) - (nth 1 symbol) - symbol)) - (if (if this-is-a-variable - (get symbol 'variable-documentation) - (and (fboundp symbol) (apropos-safe-documentation symbol))) - (progn - (or (and (setq apropos-item (assq symbol apropos-accumulator)) - (setcar (cdr apropos-item) - (+ (cadr apropos-item) (apropos-score-doc doc)))) - (setq apropos-item (list symbol - (+ (apropos-score-symbol symbol 2) - (apropos-score-doc doc)) - nil nil) - apropos-accumulator (cons apropos-item - apropos-accumulator))) - (when apropos-match-face - (setq doc (substitute-command-keys doc)) - (if (or (string-match apropos-pattern-quoted doc) - (string-match apropos-all-words-regexp doc)) - (put-text-property (match-beginning 0) - (match-end 0) - 'face apropos-match-face doc))) - (setcar (nthcdr (if this-is-a-variable 3 2) - apropos-item) - doc))))))))))) - - +(defun apropos--documentation-add-from-elc (file defs) + (erase-buffer) + (insert-file-contents + (if (file-name-absolute-p file) file + (expand-file-name file lisp-directory))) + (pcase-dolist (`(,symbol ,begbyte ,pos) defs) + ;; We presume the file-bytes are the same as the buffer bytes, + ;; which should indeed be the case because .elc files use the + ;; `emacs-internal' encoding. + (let* ((beg (byte-to-position (+ (point-min) begbyte))) + (sizeend (1- beg)) + (size (save-excursion + (goto-char beg) + (skip-chars-backward " 0-9") + (cl-assert (looking-back "#@" (- (point) 2))) + (string-to-number (buffer-substring (point) sizeend)))) + (end (byte-to-position (+ begbyte size -1)))) + (when (save-restriction + ;; match ^ and $ relative to doc string + (narrow-to-region beg end) + (goto-char (point-min)) + (re-search-forward apropos-all-words-regexp nil t)) + (let ((doc (buffer-substring beg end))) + (when (apropos-true-hit-doc doc) + (apropos--documentation-add symbol doc pos))))))) (defun apropos-safe-documentation (function) "Like `documentation', except it avoids calling `get_doc_string'. @@ -1252,14 +1213,16 @@ as a heading." (put-text-property (- (point) 3) (point) 'face 'apropos-keybinding))) (terpri)) - (apropos-print-doc 2 + (apropos-print-doc apropos-item + 2 (if (commandp symbol) 'apropos-command (if (macrop symbol) 'apropos-macro 'apropos-function)) (not nosubst)) - (apropos-print-doc 3 + (apropos-print-doc apropos-item + 3 (if (custom-variable-p symbol) 'apropos-user-option 'apropos-variable) @@ -1277,10 +1240,10 @@ as a heading." (lambda (_) (message "Value: %s" value)))) (insert "\n"))) - (apropos-print-doc 7 'apropos-group t) - (apropos-print-doc 6 'apropos-face t) - (apropos-print-doc 5 'apropos-widget t) - (apropos-print-doc 4 'apropos-plist nil)) + (apropos-print-doc apropos-item 7 'apropos-group t) + (apropos-print-doc apropos-item 6 'apropos-face t) + (apropos-print-doc apropos-item 5 'apropos-widget t) + (apropos-print-doc apropos-item 4 'apropos-plist nil)) (setq-local truncate-partial-width-windows t) (setq-local truncate-lines t))) (when help-window-select @@ -1288,7 +1251,7 @@ as a heading." (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc -(defun apropos-print-doc (i type do-keys) +(defun apropos-print-doc (apropos-item i type do-keys) (let ((doc (nth i apropos-item))) (when (stringp doc) (if apropos-compact-layout |