master 48bd17923a: (apropos-documentation): Don't try to parse .elc files

[Stefan Monnier]

branch: master
commit 48bd17923a98f49a30bdce2f3a52e03fe45d63f0
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    (apropos-documentation): Don't try to parse .elc files
    
    The old code scanned for #@ in .elc files, assuming they're
    docstrings and then looking around them to try and guess to which
    definition that docstring belongs, making many assumptions about how
    the code happens to be layed out by bytecomp.
    Replace that with code which relies on the (FILE . POS) info to
    extract the docstring knowing already where they are and what def they
    belong to.
    
    * lisp/apropos.el (apropos-documentation-check-elc-file): Delete function.
    (apropos--documentation-add-from-elc): New function to replace it.
    (apropos--documentation-add): New function, extracted from
    `apropos-documentation`.
    (apropos-documentation): Use them.  Let-bind `apropos-accumulator` and
    `apropos-files-scanned`.
    (apropos-documentation-internal): Don't handle the `cons` case any more.
    (apropos-item): Don't declare as global var.
    (apropos-documentation-check-doc-file): Use `apropos-item` as a local
    var rather than a global var.
    (apropos-print-doc): Receive `apropos-item` as arg rather than refer to
    it as a global variable.
    (apropos-print): Adjust calls accordingly.
---
 lisp/apropos.el | 221 +++++++++++++++++++++++---------------------------------
 1 file changed, 92 insertions(+), 129 deletions(-)

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 459dc72b47..e95f45f180 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