bytecomp.el: Rewrite the way we print dynamic docstrings
We used to print dynamic docstrings "manually" for two reasons: - References should look like `(#$ . POS)` but `prin1` was unable to print just `#$` for an sexp. - `make-docfile` needed to find those docstrings and the object to which they belonged. The second point is moot now that we don't use `make-docfile` on `.elc` files. So this patch lifts the first restriction, using `print-number-table`. The rest of the patch then simplifies and regularises the bytecompiler's generation of dynamic docstrings, which can now also easily be done for "inner" defvars and other places. * src/print.c (print_preprocess, print_object): Handle strings in `print-number-table`. (Vprint_number_table): Improve docstring. * lisp/emacs-lisp/bytecomp.el: (byte-compile--list-with-n): New function. (byte-compile--docstring-style-warn): Rename from `byte-compile-docstring-style-warn` and change calling convention. (byte-compile--\#$, byte-compile--docstrings): New vars. (byte-compile-close-variables): Bind them. (byte-compile--docstring): New function. (byte-compile-from-buffer): Set `byte-compile--\#$`. (byte-compile-output-file-form): Use `byte-compile--\#$` instead of special casing specific forms. (byte-compile--output-docform-recurse, byte-compile-output-docform): Delete functions. (byte-compile-file-form-autoload, byte-compile-file-form-defalias) (byte-compile-file-form-defvar-function, byte-compile-lambda): Use `byte-compile--docstring` and `byte-compile--list-with-n`. (byte-compile--declare-var): Add optional `not-toplevel` arg. (byte-compile-defvar): Add `toplevel` arg. Use `byte-compile--docstring`. (byte-compile-file-form-defvar): Delegate to `byte-compile-defvar`. (byte-compile--custom-declare-face): New function. Use it for `custom-declare-face`. (byte-compile-file-form-defmumble): Use `byte-compile-output-file-form` * src/doc.c (Fdocumentation_stringp): New function. (syms_of_doc): Defsubr it. (store_function_docstring): Remove left-over code from when we used DOC for the docstring of some Lisp files. * lisp/cus-face.el (custom-declare-face): Accept dynamic docstrings. * lisp/faces.el (face-documentation): Handle dynamic docstrings. * lisp/help-fns.el (describe-face): Simplify accordingly.
This commit is contained in:
Stefan Monnier
parent
e2d1ac2f25
commit
e9a668274e
6 changed files with 217 additions and 335 deletions
|
|
@ -32,7 +32,7 @@
|
|||
(defun custom-declare-face (face spec doc &rest args)
|
||||
"Like `defface', but with FACE evaluated as a normal argument."
|
||||
(when (and doc
|
||||
(not (stringp doc)))
|
||||
(not (documentation-stringp doc)))
|
||||
(error "Invalid (or missing) doc string %S" doc))
|
||||
(unless (get face 'face-defface-spec)
|
||||
(face-spec-set face (purecopy spec) 'face-defface-spec)
|
||||
|
|
|
|||
|
|
@ -345,7 +345,7 @@ A value of `all' really means all."
|
|||
'(docstrings-non-ascii-quotes)
|
||||
"List of warning types that are only enabled during Emacs builds.
|
||||
This is typically either warning types that are being phased in
|
||||
(but shouldn't be enabled for packages yet), or that are only relevant
|
||||
\(but shouldn't be enabled for packages yet), or that are only relevant
|
||||
for the Emacs build itself.")
|
||||
|
||||
(defvar byte-compile--suppressed-warnings nil
|
||||
|
|
@ -1740,68 +1740,82 @@ Also ignore URLs."
|
|||
The byte-compiler will emit a warning for documentation strings
|
||||
containing lines wider than this. If `fill-column' has a larger
|
||||
value, it will override this variable."
|
||||
:group 'bytecomp
|
||||
:type 'natnum
|
||||
:safe #'natnump
|
||||
:version "28.1")
|
||||
|
||||
(define-obsolete-function-alias 'byte-compile-docstring-length-warn
|
||||
'byte-compile-docstring-style-warn "29.1")
|
||||
(defun byte-compile--list-with-n (list n elem)
|
||||
"Return LIST with its Nth element replaced by ELEM."
|
||||
(if (eq elem (nth n list))
|
||||
list
|
||||
(nconc (take n list)
|
||||
(list elem)
|
||||
(nthcdr (1+ n) list))))
|
||||
|
||||
(defun byte-compile-docstring-style-warn (form)
|
||||
"Warn if there are stylistic problems with the docstring in FORM.
|
||||
Warn if documentation string of FORM is too wide.
|
||||
(defun byte-compile--docstring-style-warn (docs kind name)
|
||||
"Warn if there are stylistic problems in the docstring DOCS.
|
||||
Warn if documentation string is too wide.
|
||||
It is too wide if it has any lines longer than the largest of
|
||||
`fill-column' and `byte-compile-docstring-max-column'."
|
||||
(when (byte-compile-warning-enabled-p 'docstrings)
|
||||
(let* ((kind nil) (name nil) (docs nil)
|
||||
(let* ((name (if (eq (car-safe name) 'quote) (cadr name) name))
|
||||
(prefix (lambda ()
|
||||
(format "%s%s"
|
||||
kind
|
||||
(if name (format-message " `%s' " name) "")))))
|
||||
(pcase (car form)
|
||||
((or 'autoload 'custom-declare-variable 'defalias
|
||||
'defconst 'define-abbrev-table
|
||||
'defvar 'defvaralias
|
||||
'custom-declare-face)
|
||||
(setq kind (nth 0 form))
|
||||
(setq name (nth 1 form))
|
||||
(when (and (consp name) (eq (car name) 'quote))
|
||||
(setq name (cadr name)))
|
||||
(setq docs (nth 3 form)))
|
||||
('lambda
|
||||
(setq kind "") ; can't be "function", unfortunately
|
||||
(setq docs (nth 2 form))))
|
||||
(when (and kind docs (stringp docs))
|
||||
(let ((col (max byte-compile-docstring-max-column fill-column)))
|
||||
(when (and (byte-compile-warning-enabled-p 'docstrings-wide)
|
||||
(byte-compile--wide-docstring-p docs col))
|
||||
(byte-compile-warn-x
|
||||
name
|
||||
"%sdocstring wider than %s characters" (funcall prefix) col)))
|
||||
;; There's a "naked" ' character before a symbol/list, so it
|
||||
;; should probably be quoted with \=.
|
||||
(when (string-match-p (rx (| (in " \t") bol)
|
||||
(? (in "\"#"))
|
||||
"'"
|
||||
(in "A-Za-z" "("))
|
||||
(if name (format-message " `%S' " name) "")))))
|
||||
(let ((col (max byte-compile-docstring-max-column fill-column)))
|
||||
(when (and (byte-compile-warning-enabled-p 'docstrings-wide)
|
||||
(byte-compile--wide-docstring-p docs col))
|
||||
(byte-compile-warn-x
|
||||
name
|
||||
"%sdocstring wider than %s characters" (funcall prefix) col)))
|
||||
;; There's a "naked" ' character before a symbol/list, so it
|
||||
;; should probably be quoted with \=.
|
||||
(when (string-match-p (rx (| (in " \t") bol)
|
||||
(? (in "\"#"))
|
||||
"'"
|
||||
(in "A-Za-z" "("))
|
||||
docs)
|
||||
(byte-compile-warn-x
|
||||
name
|
||||
(concat "%sdocstring has wrong usage of unescaped single quotes"
|
||||
" (use \\=%c or different quoting such as %c...%c)")
|
||||
(funcall prefix) ?' ?` ?'))
|
||||
;; There's a "Unicode quote" in the string -- it should probably
|
||||
;; be an ASCII one instead.
|
||||
(when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
|
||||
(when (string-match-p (rx (| " \"" (in " \t") bol)
|
||||
(in "‘’"))
|
||||
docs)
|
||||
(byte-compile-warn-x
|
||||
name
|
||||
(concat "%sdocstring has wrong usage of unescaped single quotes"
|
||||
" (use \\=%c or different quoting such as %c...%c)")
|
||||
(funcall prefix) ?' ?` ?'))
|
||||
;; There's a "Unicode quote" in the string -- it should probably
|
||||
;; be an ASCII one instead.
|
||||
(when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
|
||||
(when (string-match-p (rx (| " \"" (in " \t") bol)
|
||||
(in "‘’"))
|
||||
docs)
|
||||
(byte-compile-warn-x
|
||||
name
|
||||
"%sdocstring uses curved single quotes; use %s instead of ‘...’"
|
||||
(funcall prefix) "`...'"))))))
|
||||
form)
|
||||
"%sdocstring uses curved single quotes; use %s instead of ‘...’"
|
||||
(funcall prefix) "`...'"))))))
|
||||
|
||||
(defvar byte-compile--\#$) ; Special value that will print as `#$'.
|
||||
(defvar byte-compile--docstrings nil "Table of already compiled docstrings.")
|
||||
|
||||
(defun byte-compile--docstring (doc kind name &optional is-a-value)
|
||||
(byte-compile--docstring-style-warn doc kind name)
|
||||
;; Make docstrings dynamic, when applicable.
|
||||
(cond
|
||||
((and byte-compile-dynamic-docstrings
|
||||
;; The native compiler doesn't use those dynamic docstrings.
|
||||
(not byte-native-compiling)
|
||||
;; Docstrings can only be dynamic when compiling a file.
|
||||
byte-compile--\#$)
|
||||
(let* ((byte-pos (with-memoization
|
||||
;; Reuse a previously written identical docstring.
|
||||
;; This is not done out of thriftiness but to try and
|
||||
;; make sure that "equal" functions remain `equal'.
|
||||
;; (Often those identical docstrings come from
|
||||
;; `help-add-fundoc-usage').
|
||||
;; Needed e.g. for `advice-tests-nadvice'.
|
||||
(gethash doc byte-compile--docstrings)
|
||||
(byte-compile-output-as-comment doc nil)))
|
||||
(newdoc (cons byte-compile--\#$ byte-pos)))
|
||||
(if is-a-value newdoc (macroexp-quote newdoc))))
|
||||
(t doc)))
|
||||
|
||||
;; If we have compiled any calls to functions which are not known to be
|
||||
;; defined, issue a warning enumerating them.
|
||||
|
|
@ -1836,6 +1850,8 @@ It is too wide if it has any lines longer than the largest of
|
|||
;; macroenvironment.
|
||||
(copy-alist byte-compile-initial-macro-environment))
|
||||
(byte-compile--outbuffer nil)
|
||||
(byte-compile--\#$ nil)
|
||||
(byte-compile--docstrings (make-hash-table :test 'equal))
|
||||
(overriding-plist-environment nil)
|
||||
(byte-compile-function-environment nil)
|
||||
(byte-compile-bound-variables nil)
|
||||
|
|
@ -2363,7 +2379,12 @@ With argument ARG, insert value in current buffer after the form."
|
|||
(setq case-fold-search nil))
|
||||
(displaying-byte-compile-warnings
|
||||
(with-current-buffer inbuffer
|
||||
(when byte-compile-current-file
|
||||
(when byte-compile-dest-file
|
||||
(setq byte-compile--\#$
|
||||
(copy-sequence ;It needs to be a fresh new object.
|
||||
;; Also it stands for the `load-file-name' when the `.elc' will
|
||||
;; be loaded, so make it look like it.
|
||||
byte-compile-dest-file))
|
||||
(byte-compile-insert-header byte-compile-current-file
|
||||
byte-compile--outbuffer)
|
||||
;; Instruct native-comp to ignore this file.
|
||||
|
|
@ -2456,11 +2477,7 @@ Call from the source buffer."
|
|||
|
||||
(defun byte-compile-output-file-form (form)
|
||||
;; Write the given form to the output buffer, being careful of docstrings
|
||||
;; (for `byte-compile-dynamic-docstrings') in defvar, defvaralias,
|
||||
;; defconst, autoload, and custom-declare-variable.
|
||||
;; defalias calls are output directly by byte-compile-file-form-defmumble;
|
||||
;; it does not pay to first build the defalias in defmumble and then parse
|
||||
;; it here.
|
||||
;; (for `byte-compile-dynamic-docstrings').
|
||||
(when byte-native-compiling
|
||||
;; Spill output for the native compiler here
|
||||
(push (make-byte-to-native-top-level :form form :lexical lexical-binding)
|
||||
|
|
@ -2470,123 +2487,17 @@ Call from the source buffer."
|
|||
(print-level nil)
|
||||
(print-quoted t)
|
||||
(print-gensym t)
|
||||
(print-circle t)) ; Handle circular data structures.
|
||||
(if (memq (car-safe form) '(defvar defvaralias defconst
|
||||
autoload custom-declare-variable))
|
||||
(byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3
|
||||
(memq (car form)
|
||||
'(defvaralias autoload
|
||||
custom-declare-variable)))
|
||||
(princ "\n" byte-compile--outbuffer)
|
||||
(prin1 form byte-compile--outbuffer)
|
||||
nil)))
|
||||
(print-circle t)
|
||||
(print-continuous-numbering t)
|
||||
(print-number-table (make-hash-table :test #'eq)))
|
||||
(when byte-compile--\#$
|
||||
(puthash byte-compile--\#$ "#$" print-number-table))
|
||||
(princ "\n" byte-compile--outbuffer)
|
||||
(prin1 form byte-compile--outbuffer)
|
||||
nil))
|
||||
|
||||
(defvar byte-compile--for-effect)
|
||||
|
||||
(defun byte-compile--output-docform-recurse
|
||||
(info position form cvecindex docindex quoted)
|
||||
"Print a form with a doc string. INFO is (prefix postfix).
|
||||
POSITION is where the next doc string is to be inserted.
|
||||
CVECINDEX is the index in the FORM of the constant vector, or nil.
|
||||
DOCINDEX is the index of the doc string (or nil) in the FORM.
|
||||
QUOTED says that we have to put a quote before the
|
||||
list that represents a doc string reference.
|
||||
`defvaralias', `autoload' and `custom-declare-variable' need that.
|
||||
|
||||
Return the position after any inserted docstrings as comments."
|
||||
(let ((index 0)
|
||||
doc-string-position)
|
||||
;; Insert the doc string, and make it a comment with #@LENGTH.
|
||||
(when (and byte-compile-dynamic-docstrings
|
||||
(stringp (nth docindex form)))
|
||||
(goto-char position)
|
||||
(setq doc-string-position
|
||||
(byte-compile-output-as-comment
|
||||
(nth docindex form) nil)
|
||||
position (point))
|
||||
(goto-char (point-max)))
|
||||
|
||||
(insert (car info))
|
||||
(prin1 (car form) byte-compile--outbuffer)
|
||||
(while (setq form (cdr form))
|
||||
(setq index (1+ index))
|
||||
(insert " ")
|
||||
(cond ((eq index cvecindex)
|
||||
(let* ((cvec (car form))
|
||||
(len (length cvec))
|
||||
(index2 0)
|
||||
elt)
|
||||
(insert "[")
|
||||
(while (< index2 len)
|
||||
(setq elt (aref cvec index2))
|
||||
(if (byte-code-function-p elt)
|
||||
(setq position
|
||||
(byte-compile--output-docform-recurse
|
||||
'("#[" "]") position
|
||||
(append elt nil) ; Convert the vector to a list.
|
||||
2 4 nil))
|
||||
(prin1 elt byte-compile--outbuffer))
|
||||
(setq index2 (1+ index2))
|
||||
(unless (eq index2 len)
|
||||
(insert " ")))
|
||||
(insert "]")))
|
||||
((= index docindex)
|
||||
(cond
|
||||
(doc-string-position
|
||||
(princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
|
||||
doc-string-position)
|
||||
byte-compile--outbuffer))
|
||||
((stringp (car form))
|
||||
(let ((print-escape-newlines nil))
|
||||
(goto-char (prog1 (1+ (point))
|
||||
(prin1 (car form)
|
||||
byte-compile--outbuffer)))
|
||||
(insert "\\\n")
|
||||
(goto-char (point-max))))
|
||||
(t (prin1 (car form) byte-compile--outbuffer))))
|
||||
(t (prin1 (car form) byte-compile--outbuffer))))
|
||||
(insert (cadr info))
|
||||
position))
|
||||
|
||||
(defun byte-compile-output-docform (preface tailpiece name info form
|
||||
cvecindex docindex
|
||||
quoted)
|
||||
"Print a form with a doc string. INFO is (prefix postfix).
|
||||
If PREFACE, NAME, and TAILPIECE are non-nil, print them too,
|
||||
before/after INFO and the FORM but after the doc string itself.
|
||||
CVECINDEX is the index in the FORM of the constant vector, or nil.
|
||||
DOCINDEX is the index of the doc string (or nil) in the FORM.
|
||||
QUOTED says that we have to put a quote before the
|
||||
list that represents a doc string reference.
|
||||
`defvaralias', `autoload' and `custom-declare-variable' need that."
|
||||
;; We need to examine byte-compile-dynamic-docstrings
|
||||
;; in the input buffer (now current), not in the output buffer.
|
||||
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
|
||||
(with-current-buffer byte-compile--outbuffer
|
||||
(let ((byte-compile-dynamic-docstrings dynamic-docstrings)
|
||||
(position (point))
|
||||
(print-continuous-numbering t)
|
||||
print-number-table
|
||||
;; FIXME: The bindings below are only needed for when we're
|
||||
;; called from ...-defmumble.
|
||||
(print-escape-newlines t)
|
||||
(print-length nil)
|
||||
(print-level nil)
|
||||
(print-quoted t)
|
||||
(print-gensym t)
|
||||
(print-circle t)) ; Handle circular data structures.
|
||||
(when preface
|
||||
;; FIXME: We don't handle uninterned names correctly.
|
||||
;; E.g. if cl-define-compiler-macro uses uninterned name we get:
|
||||
;; (defalias '#1=#:foo--cmacro #[514 ...])
|
||||
;; (put 'foo 'compiler-macro '#:foo--cmacro)
|
||||
(insert preface)
|
||||
(prin1 name byte-compile--outbuffer))
|
||||
(byte-compile--output-docform-recurse
|
||||
info position form cvecindex docindex quoted)
|
||||
(when tailpiece
|
||||
(insert tailpiece))))))
|
||||
|
||||
(defun byte-compile-keep-pending (form &optional handler)
|
||||
(if (memq byte-optimize '(t source))
|
||||
(setq form (byte-optimize-one-form form t)))
|
||||
|
|
@ -2606,7 +2517,7 @@ list that represents a doc string reference.
|
|||
(if byte-compile-output
|
||||
(let ((form (byte-compile-out-toplevel t 'file)))
|
||||
(cond ((eq (car-safe form) 'progn)
|
||||
(mapc 'byte-compile-output-file-form (cdr form)))
|
||||
(mapc #'byte-compile-output-file-form (cdr form)))
|
||||
(form
|
||||
(byte-compile-output-file-form form)))
|
||||
(setq byte-compile-constants nil
|
||||
|
|
@ -2681,12 +2592,12 @@ list that represents a doc string reference.
|
|||
(setq byte-compile-unresolved-functions
|
||||
(delq (assq funsym byte-compile-unresolved-functions)
|
||||
byte-compile-unresolved-functions)))))
|
||||
(if (stringp (nth 3 form))
|
||||
(prog1
|
||||
form
|
||||
(byte-compile-docstring-style-warn form))
|
||||
;; No doc string, so we can compile this as a normal form.
|
||||
(byte-compile-keep-pending form 'byte-compile-normal-call)))
|
||||
(let* ((doc (nth 3 form))
|
||||
(newdoc (if (not (stringp doc)) doc
|
||||
(byte-compile--docstring
|
||||
doc 'autoload (nth 1 form)))))
|
||||
(byte-compile-keep-pending (byte-compile--list-with-n form 3 newdoc)
|
||||
#'byte-compile-normal-call)))
|
||||
|
||||
(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
|
||||
(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
|
||||
|
|
@ -2698,9 +2609,10 @@ list that represents a doc string reference.
|
|||
(byte-compile-warn-x
|
||||
sym "global/dynamic var `%s' lacks a prefix" sym)))
|
||||
|
||||
(defun byte-compile--declare-var (sym)
|
||||
(defun byte-compile--declare-var (sym &optional not-toplevel)
|
||||
(byte-compile--check-prefixed-var sym)
|
||||
(when (memq sym byte-compile-lexical-variables)
|
||||
(when (and (not not-toplevel)
|
||||
(memq sym byte-compile-lexical-variables))
|
||||
(setq byte-compile-lexical-variables
|
||||
(delq sym byte-compile-lexical-variables))
|
||||
(when (byte-compile-warning-enabled-p 'lexical sym)
|
||||
|
|
@ -2709,19 +2621,7 @@ list that represents a doc string reference.
|
|||
(push sym byte-compile--seen-defvars))
|
||||
|
||||
(defun byte-compile-file-form-defvar (form)
|
||||
(let ((sym (nth 1 form)))
|
||||
(byte-compile--declare-var sym)
|
||||
(if (eq (car form) 'defconst)
|
||||
(push sym byte-compile-const-variables)))
|
||||
(if (and (null (cddr form)) ;No `value' provided.
|
||||
(eq (car form) 'defvar)) ;Just a declaration.
|
||||
nil
|
||||
(byte-compile-docstring-style-warn form)
|
||||
(setq form (copy-sequence form))
|
||||
(when (consp (nth 2 form))
|
||||
(setcar (cdr (cdr form))
|
||||
(byte-compile-top-level (nth 2 form) nil 'file)))
|
||||
form))
|
||||
(byte-compile-defvar form 'toplevel))
|
||||
|
||||
(put 'define-abbrev-table 'byte-hunk-handler
|
||||
'byte-compile-file-form-defvar-function)
|
||||
|
|
@ -2729,26 +2629,37 @@ list that represents a doc string reference.
|
|||
|
||||
(defun byte-compile-file-form-defvar-function (form)
|
||||
(pcase-let (((or `',name (let name nil)) (nth 1 form)))
|
||||
(if name (byte-compile--declare-var name)))
|
||||
;; Variable aliases are better declared before the corresponding variable,
|
||||
;; since it makes it more likely that only one of the two vars has a value
|
||||
;; before the `defvaralias' gets executed, which avoids the need to
|
||||
;; merge values.
|
||||
(pcase form
|
||||
(`(defvaralias ,_ ',newname . ,_)
|
||||
(when (memq newname byte-compile-bound-variables)
|
||||
(if (byte-compile-warning-enabled-p 'suspicious)
|
||||
(byte-compile-warn-x
|
||||
newname
|
||||
"Alias for `%S' should be declared before its referent" newname)))))
|
||||
(byte-compile-docstring-style-warn form)
|
||||
(byte-compile-keep-pending form))
|
||||
(if name (byte-compile--declare-var name))
|
||||
;; Variable aliases are better declared before the corresponding variable,
|
||||
;; since it makes it more likely that only one of the two vars has a value
|
||||
;; before the `defvaralias' gets executed, which avoids the need to
|
||||
;; merge values.
|
||||
(pcase form
|
||||
(`(defvaralias ,_ ',newname . ,_)
|
||||
(when (memq newname byte-compile-bound-variables)
|
||||
(if (byte-compile-warning-enabled-p 'suspicious)
|
||||
(byte-compile-warn-x
|
||||
newname
|
||||
"Alias for `%S' should be declared before its referent"
|
||||
newname)))))
|
||||
(let ((doc (nth 3 form)))
|
||||
(when (stringp doc)
|
||||
(setcar (nthcdr 3 form)
|
||||
(byte-compile--docstring doc (nth 0 form) name))))
|
||||
(byte-compile-keep-pending form)))
|
||||
|
||||
(put 'custom-declare-variable 'byte-hunk-handler
|
||||
'byte-compile-file-form-defvar-function)
|
||||
|
||||
(put 'custom-declare-face 'byte-hunk-handler
|
||||
'byte-compile-docstring-style-warn)
|
||||
#'byte-compile--custom-declare-face)
|
||||
(defun byte-compile--custom-declare-face (form)
|
||||
(let ((kind (nth 0 form)) (name (nth 1 form)) (docs (nth 3 form)))
|
||||
(when (stringp docs)
|
||||
(let ((newdocs (byte-compile--docstring docs kind name)))
|
||||
(unless (eq docs newdocs)
|
||||
(setq form (byte-compile--list-with-n form 3 newdocs)))))
|
||||
form))
|
||||
|
||||
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
|
||||
(defun byte-compile-file-form-require (form)
|
||||
|
|
@ -2902,33 +2813,24 @@ not to take responsibility for the actual compilation of the code."
|
|||
(cons (cons bare-name code)
|
||||
(symbol-value this-kind))))
|
||||
|
||||
(if rest
|
||||
;; There are additional args to `defalias' (like maybe a docstring)
|
||||
;; that the code below can't handle: punt!
|
||||
nil
|
||||
;; Otherwise, we have a bona-fide defun/defmacro definition, and use
|
||||
;; special code to allow dynamic docstrings and byte-code.
|
||||
(byte-compile-flush-pending)
|
||||
(byte-compile-flush-pending)
|
||||
(let ((newform `(defalias ',bare-name
|
||||
,(if macro `'(macro . ,code) code) ,@rest)))
|
||||
(when byte-native-compiling
|
||||
;; Spill output for the native compiler here.
|
||||
;; Don't let `byte-compile-output-file-form' push the form to
|
||||
;; `byte-to-native-top-level-forms' because we want to use
|
||||
;; `make-byte-to-native-func-def' when possible.
|
||||
(push
|
||||
(if macro
|
||||
(if (or macro rest)
|
||||
(make-byte-to-native-top-level
|
||||
:form `(defalias ',name '(macro . ,code) nil)
|
||||
:form newform
|
||||
:lexical lexical-binding)
|
||||
(make-byte-to-native-func-def :name name
|
||||
:byte-func code))
|
||||
byte-to-native-top-level-forms))
|
||||
;; Output the form by hand, that's much simpler than having
|
||||
;; b-c-output-file-form analyze the defalias.
|
||||
(byte-compile-output-docform
|
||||
"\n(defalias '" ")"
|
||||
bare-name
|
||||
(if macro '(" '(macro . #[" "])") '(" #[" "]"))
|
||||
(append code nil) ; Turn byte-code-function-p into list.
|
||||
2 4
|
||||
nil)
|
||||
t)))))
|
||||
(let ((byte-native-compiling nil))
|
||||
(byte-compile-output-file-form newform)))
|
||||
t))))
|
||||
|
||||
(defun byte-compile-output-as-comment (exp quoted)
|
||||
"Print Lisp object EXP in the output file at point, inside a comment.
|
||||
|
|
@ -3129,9 +3031,9 @@ lambda-expression."
|
|||
(setq fun (cons 'lambda fun))
|
||||
(unless (eq 'lambda (car-safe fun))
|
||||
(error "Not a lambda list: %S" fun)))
|
||||
(byte-compile-docstring-style-warn fun)
|
||||
(byte-compile-check-lambda-list (nth 1 fun))
|
||||
(let* ((arglist (nth 1 fun))
|
||||
(bare-arglist (byte-run-strip-symbol-positions arglist)) ; for compile-defun.
|
||||
(arglistvars (byte-run-strip-symbol-positions
|
||||
(byte-compile-arglist-vars arglist)))
|
||||
(byte-compile-bound-variables
|
||||
|
|
@ -3140,16 +3042,22 @@ lambda-expression."
|
|||
(body (cdr (cdr fun)))
|
||||
(doc (if (stringp (car body))
|
||||
(prog1 (car body)
|
||||
;; Discard the doc string
|
||||
;; Discard the doc string from the body
|
||||
;; unless it is the last element of the body.
|
||||
(if (cdr body)
|
||||
(setq body (cdr body))))))
|
||||
(int (assq 'interactive body))
|
||||
command-modes)
|
||||
(when lexical-binding
|
||||
(when arglist
|
||||
;; byte-compile-make-args-desc lost the args's names,
|
||||
;; so preserve them in the docstring.
|
||||
(setq doc (help-add-fundoc-usage doc bare-arglist)))
|
||||
(dolist (var arglistvars)
|
||||
(when (assq var byte-compile--known-dynamic-vars)
|
||||
(byte-compile--warn-lexical-dynamic var 'lambda))))
|
||||
(when (stringp doc)
|
||||
(setq doc (byte-compile--docstring doc "" nil 'is-a-value)))
|
||||
;; Process the interactive spec.
|
||||
(when int
|
||||
;; Skip (interactive) if it is in front (the most usual location).
|
||||
|
|
@ -3193,8 +3101,7 @@ lambda-expression."
|
|||
(and lexical-binding
|
||||
(byte-compile-make-lambda-lexenv
|
||||
arglistvars))
|
||||
reserved-csts))
|
||||
(bare-arglist (byte-run-strip-symbol-positions arglist))) ; for compile-defun.
|
||||
reserved-csts)))
|
||||
;; Build the actual byte-coded function.
|
||||
(cl-assert (eq 'byte-code (car-safe compiled)))
|
||||
(let ((out
|
||||
|
|
@ -3206,12 +3113,7 @@ lambda-expression."
|
|||
;; byte-string, constants-vector, stack depth
|
||||
(cdr compiled)
|
||||
;; optionally, the doc string.
|
||||
(cond ((and lexical-binding arglist)
|
||||
;; byte-compile-make-args-desc lost the args's names,
|
||||
;; so preserve them in the docstring.
|
||||
(list (help-add-fundoc-usage doc bare-arglist)))
|
||||
((or doc int)
|
||||
(list doc)))
|
||||
(when (or doc int) (list doc))
|
||||
;; optionally, the interactive spec (and the modes the
|
||||
;; command applies to).
|
||||
(cond
|
||||
|
|
@ -5091,49 +4993,49 @@ binding slots have been popped."
|
|||
(push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars))
|
||||
(byte-compile-normal-call form))
|
||||
|
||||
(defun byte-compile-defvar (form)
|
||||
;; This is not used for file-level defvar/consts.
|
||||
(when (and (symbolp (nth 1 form))
|
||||
(not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
|
||||
(byte-compile-warning-enabled-p 'lexical (nth 1 form)))
|
||||
(byte-compile-warn-x
|
||||
(nth 1 form)
|
||||
"global/dynamic var `%s' lacks a prefix"
|
||||
(nth 1 form)))
|
||||
(byte-compile-docstring-style-warn form)
|
||||
(let ((fun (nth 0 form))
|
||||
(var (nth 1 form))
|
||||
(value (nth 2 form))
|
||||
(string (nth 3 form)))
|
||||
(when (or (> (length form) 4)
|
||||
(and (eq fun 'defconst) (null (cddr form))))
|
||||
(let ((ncall (length (cdr form))))
|
||||
(byte-compile-warn-x
|
||||
fun
|
||||
"`%s' called with %d argument%s, but %s %s"
|
||||
fun ncall
|
||||
(if (= 1 ncall) "" "s")
|
||||
(if (< ncall 2) "requires" "accepts only")
|
||||
"2-3")))
|
||||
(push var byte-compile-bound-variables)
|
||||
(defun byte-compile-defvar (form &optional toplevel)
|
||||
(let* ((fun (nth 0 form))
|
||||
(var (nth 1 form))
|
||||
(value (nth 2 form))
|
||||
(string (nth 3 form)))
|
||||
(byte-compile--declare-var var (not toplevel))
|
||||
(if (eq fun 'defconst)
|
||||
(push var byte-compile-const-variables))
|
||||
(when (and string (not (stringp string)))
|
||||
(cond
|
||||
((stringp string)
|
||||
(setq string (byte-compile--docstring string fun var 'is-a-value)))
|
||||
(string
|
||||
(byte-compile-warn-x
|
||||
string
|
||||
"third arg to `%s %s' is not a string: %s"
|
||||
fun var string))
|
||||
;; Delegate the actual work to the function version of the
|
||||
;; special form, named with a "-1" suffix.
|
||||
(byte-compile-form-do-effect
|
||||
(cond
|
||||
((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form)))
|
||||
((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
|
||||
(t `(defvar-1 ',var
|
||||
;; Don't eval `value' if `defvar' wouldn't eval it either.
|
||||
,(if (macroexp-const-p value) value
|
||||
`(if (boundp ',var) nil ,value))
|
||||
,@(nthcdr 3 form)))))))
|
||||
fun var string)))
|
||||
(if toplevel
|
||||
;; At top-level we emit calls to defvar/defconst.
|
||||
(if (and (null (cddr form)) ;No `value' provided.
|
||||
(eq (car form) 'defvar)) ;Just a declaration.
|
||||
nil
|
||||
(let ((tail (nthcdr 4 form)))
|
||||
(when (or tail string) (push string tail))
|
||||
(when (cddr form)
|
||||
(push (if (not (consp value)) value
|
||||
(byte-compile-top-level value nil 'file))
|
||||
tail))
|
||||
`(,fun ,var ,@tail)))
|
||||
;; At non-top-level, since there is no byte code for
|
||||
;; defvar/defconst, we delegate the actual work to the function
|
||||
;; version of the special form, named with a "-1" suffix.
|
||||
(byte-compile-form-do-effect
|
||||
(cond
|
||||
((eq fun 'defconst)
|
||||
`(defconst-1 ',var ,@(byte-compile--list-with-n
|
||||
(nthcdr 2 form) 1 (macroexp-quote string))))
|
||||
((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
|
||||
(t `(defvar-1 ',var
|
||||
;; Don't eval `value' if `defvar' wouldn't eval it either.
|
||||
,(if (macroexp-const-p value) value
|
||||
`(if (boundp ',var) nil ,value))
|
||||
,@(byte-compile--list-with-n
|
||||
(nthcdr 3 form) 0 (macroexp-quote string)))))))))
|
||||
|
||||
(defun byte-compile-autoload (form)
|
||||
(and (macroexp-const-p (nth 1 form))
|
||||
|
|
@ -5159,14 +5061,6 @@ binding slots have been popped."
|
|||
;; For the compilation itself, we could largely get rid of this hunk-handler,
|
||||
;; if it weren't for the fact that we need to figure out when a defalias
|
||||
;; defines a macro, so as to add it to byte-compile-macro-environment.
|
||||
;;
|
||||
;; FIXME: we also use this hunk-handler to implement the function's
|
||||
;; dynamic docstring feature (via byte-compile-file-form-defmumble).
|
||||
;; We should probably actually implement it (more elegantly) in
|
||||
;; byte-compile-lambda so it applies to all lambdas. We did it here
|
||||
;; so the resulting .elc format was recognizable by make-docfile,
|
||||
;; but since then we stopped using DOC for the docstrings of
|
||||
;; preloaded elc files so that obstacle is gone.
|
||||
(let ((byte-compile-free-references nil)
|
||||
(byte-compile-free-assignments nil))
|
||||
(pcase form
|
||||
|
|
@ -5175,7 +5069,11 @@ binding slots have been popped."
|
|||
;; - `arg' is the expression to which it is defined.
|
||||
;; - `rest' is the rest of the arguments.
|
||||
(`(,_ ',name ,arg . ,rest)
|
||||
(byte-compile-docstring-style-warn form)
|
||||
(let ((doc (car rest)))
|
||||
(when (stringp doc)
|
||||
(setq rest (byte-compile--list-with-n
|
||||
rest 0
|
||||
(byte-compile--docstring doc (nth 0 form) name)))))
|
||||
(pcase-let*
|
||||
;; `macro' is non-nil if it defines a macro.
|
||||
;; `fun' is the function part of `arg' (defaults to `arg').
|
||||
|
|
|
|||
|
|
@ -651,11 +651,11 @@ Optional argument INHERIT is passed to `face-attribute'."
|
|||
If FACE is a face-alias, get the documentation for the target face."
|
||||
(let ((alias (get face 'face-alias)))
|
||||
(if alias
|
||||
(let ((doc (get alias 'face-documentation)))
|
||||
(let ((doc (documentation-property alias 'face-documentation)))
|
||||
(format "%s is an alias for the face `%s'.%s" face alias
|
||||
(if doc (format "\n%s" doc)
|
||||
"")))
|
||||
(get face 'face-documentation))))
|
||||
(documentation-property face 'face-documentation))))
|
||||
|
||||
|
||||
(defun set-face-documentation (face string)
|
||||
|
|
|
|||
|
|
@ -1799,9 +1799,8 @@ If FRAME is omitted or nil, use the selected frame."
|
|||
alias)
|
||||
""))))
|
||||
(insert "\nDocumentation:\n"
|
||||
(substitute-command-keys
|
||||
(or (face-documentation face)
|
||||
"Not documented as a face."))
|
||||
(or (face-documentation face)
|
||||
"Not documented as a face.")
|
||||
"\n\n"))
|
||||
(with-current-buffer standard-output
|
||||
(save-excursion
|
||||
|
|
|
|||
58
src/doc.c
58
src/doc.c
|
|
@ -357,6 +357,20 @@ reread_doc_file (Lisp_Object file)
|
|||
return 1;
|
||||
}
|
||||
|
||||
DEFUN ("documentation-stringp", Fdocumentation_stringp, Sdocumentation_stringp,
|
||||
1, 1, 0,
|
||||
doc: /* Return non-nil if OBJECT is a well-formed docstring object.
|
||||
OBJECT can be either a string or a reference if it's kept externally. */)
|
||||
(Lisp_Object object)
|
||||
{
|
||||
return (STRINGP (object)
|
||||
|| FIXNUMP (object) /* Reference to DOC. */
|
||||
|| (CONSP (object) /* Reference to .elc. */
|
||||
&& STRINGP (XCAR (object))
|
||||
&& FIXNUMP (XCDR (object)))
|
||||
? Qt : Qnil);
|
||||
}
|
||||
|
||||
DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
|
||||
doc: /* Return the documentation string of FUNCTION.
|
||||
Unless a non-nil second argument RAW is given, the
|
||||
|
|
@ -502,46 +516,13 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
|
|||
/* If it's a lisp form, stick it in the form. */
|
||||
if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
|
||||
fun = XCDR (fun);
|
||||
if (CONSP (fun))
|
||||
{
|
||||
Lisp_Object tem = XCAR (fun);
|
||||
if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
|
||||
|| (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
|
||||
{
|
||||
tem = Fcdr (Fcdr (fun));
|
||||
if (CONSP (tem) && FIXNUMP (XCAR (tem)))
|
||||
/* FIXME: This modifies typically pure hash-cons'd data, so its
|
||||
correctness is quite delicate. */
|
||||
XSETCAR (tem, make_fixnum (offset));
|
||||
}
|
||||
}
|
||||
/* Lisp_Subrs have a slot for it. */
|
||||
else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
|
||||
if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
|
||||
XSUBR (fun)->doc = offset;
|
||||
else
|
||||
{
|
||||
XSUBR (fun)->doc = offset;
|
||||
}
|
||||
|
||||
/* Bytecode objects sometimes have slots for it. */
|
||||
else if (COMPILEDP (fun))
|
||||
{
|
||||
/* This bytecode object must have a slot for the
|
||||
docstring, since we've found a docstring for it. */
|
||||
if (PVSIZE (fun) > COMPILED_DOC_STRING
|
||||
/* Don't overwrite a non-docstring value placed there,
|
||||
* such as the symbols used for Oclosures. */
|
||||
&& VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING)))
|
||||
ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
|
||||
else
|
||||
{
|
||||
AUTO_STRING (format,
|
||||
(PVSIZE (fun) > COMPILED_DOC_STRING
|
||||
? "Docstring slot busy for %s"
|
||||
: "No docstring slot for %s"));
|
||||
CALLN (Fmessage, format,
|
||||
(SYMBOLP (obj)
|
||||
? SYMBOL_NAME (obj)
|
||||
: build_string ("<anonymous>")));
|
||||
}
|
||||
AUTO_STRING (format, "Ignoring DOC string on non-subr: %S");
|
||||
CALLN (Fmessage, format, obj);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -776,6 +757,7 @@ compute the correct value for the current terminal in the nil case. */);
|
|||
doc: /* If nil, a nil `text-quoting-style' is treated as `grave'. */);
|
||||
/* Initialized by ‘main’. */
|
||||
|
||||
defsubr (&Sdocumentation_stringp);
|
||||
defsubr (&Sdocumentation);
|
||||
defsubr (&Ssubr_documentation);
|
||||
defsubr (&Sdocumentation_property);
|
||||
|
|
|
|||
19
src/print.c
19
src/print.c
|
|
@ -1412,7 +1412,7 @@ print_preprocess (Lisp_Object obj)
|
|||
&& SYMBOLP (obj)
|
||||
&& !SYMBOL_INTERNED_P (obj)))
|
||||
{ /* OBJ appears more than once. Let's remember that. */
|
||||
if (!FIXNUMP (num))
|
||||
if (SYMBOLP (num)) /* In practice, nil or t. */
|
||||
{
|
||||
print_number_index++;
|
||||
/* Negative number indicates it hasn't been printed yet. */
|
||||
|
|
@ -2265,6 +2265,11 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|
|||
goto next_obj;
|
||||
}
|
||||
}
|
||||
else if (STRINGP (num))
|
||||
{
|
||||
strout (SDATA (num), SCHARS (num), SBYTES (num), printcharfun);
|
||||
goto next_obj;
|
||||
}
|
||||
}
|
||||
|
||||
print_depth++;
|
||||
|
|
@ -2554,11 +2559,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|
|||
goto next_obj;
|
||||
case PVEC_SUB_CHAR_TABLE:
|
||||
{
|
||||
/* Make each lowest sub_char_table start a new line.
|
||||
Otherwise we'll make a line extremely long, which
|
||||
results in slow redisplay. */
|
||||
if (XSUB_CHAR_TABLE (obj)->depth == 3)
|
||||
printchar ('\n', printcharfun);
|
||||
print_c_string ("#^^[", printcharfun);
|
||||
int n = sprintf (buf, "%d %d",
|
||||
XSUB_CHAR_TABLE (obj)->depth,
|
||||
|
|
@ -2664,7 +2664,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|
|||
/* With the print-circle feature. */
|
||||
Lisp_Object num = Fgethash (next, Vprint_number_table,
|
||||
Qnil);
|
||||
if (FIXNUMP (num))
|
||||
if (!(NILP (num) || EQ (num, Qt)))
|
||||
{
|
||||
print_c_string (" . ", printcharfun);
|
||||
obj = next;
|
||||
|
|
@ -2928,7 +2928,10 @@ This variable should not be set with `setq'; bind it with a `let' instead. */);
|
|||
DEFVAR_LISP ("print-number-table", Vprint_number_table,
|
||||
doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
|
||||
The Lisp printer uses this vector to detect Lisp objects referenced more
|
||||
than once.
|
||||
than once. If an entry contains a number, then the corresponding key is
|
||||
referenced more than once: a positive sign indicates that it's already been
|
||||
printed, and the absolute value indicates the number to use when printing.
|
||||
If an entry contains a string, that string is printed instead.
|
||||
|
||||
When you bind `print-continuous-numbering' to t, you should probably
|
||||
also bind `print-number-table' to nil. This ensures that the value of
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue