mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-08 23:40:24 -08:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'savannah/master' into native-comp

Browse source
This commit is contained in:
Andrea Corallo 2021-03-25 16:29:07 +01:00
commit c6c7b30e4b
180 changed files with 1982 additions and 1977 deletions
Download patch file Download diff file Expand all files Collapse all files

71
lisp/emacs-lisp/bytecomp.el
View file

@ -548,6 +548,10 @@ has the form (autoload . FILENAME).")
(defvar byte-compile-unresolved-functions nil
"Alist of undefined functions to which calls have been compiled.
Each element in the list has the form (FUNCTION POSITION . CALLS)
where CALLS is a list whose elements are integers (indicating the
number of arguments passed in the function call) or the constant `t'
if the function is called indirectly.
This variable is only significant whilst compiling an entire buffer.
Used for warnings when a function is not known to be defined or is later
defined with incorrect args.")
@ -1472,9 +1476,9 @@ when printing the error message."
;; Remember number of args in call.
(let ((cons (assq f byte-compile-unresolved-functions)))
(if cons
(or (memq nargs (cdr cons))
(push nargs (cdr cons)))
(push (list f nargs)
(or (memq nargs (cddr cons))
(push nargs (cddr cons)))
(push (list f byte-compile-last-position nargs)
byte-compile-unresolved-functions)))))
;; Warn if the form is calling a function with the wrong number of arguments.
@ -1574,14 +1578,14 @@ extra args."
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions))
(setq calls (delq t calls)) ;Ignore higher-order uses of the function.
(when (cdr calls)
(when (cddr calls)
(when (and (symbolp name)
(eq (function-get name 'byte-optimizer)
'byte-compile-inline-expand))
(byte-compile-warn "defsubst `%s' was used before it was defined"
name))
(setq sig (byte-compile-arglist-signature arglist)
nums (sort (copy-sequence (cdr calls)) (function <))
nums (sort (copy-sequence (cddr calls)) (function <))
min (car nums)
max (car (nreverse nums)))
(when (or (< min (car sig))
@ -1689,56 +1693,21 @@ It is too wide if it has any lines longer than the largest of
kind name col))))
form)
(defun byte-compile-print-syms (str1 strn syms)
(when syms
(byte-compile-set-symbol-position (car syms) t))
(cond ((and (cdr syms) (not noninteractive))
(let* ((str strn)
(L (length str))
s)
(while syms
(setq s (symbol-name (pop syms))
L (+ L (length s) 2))
(if (< L (1- (buffer-local-value 'fill-column
(or (get-buffer
byte-compile-log-buffer)
(current-buffer)))))
(setq str (concat str " " s (and syms ",")))
(setq str (concat str "\n " s (and syms ","))
L (+ (length s) 4))))
(byte-compile-warn "%s" str)))
((cdr syms)
(byte-compile-warn "%s %s"
strn
(mapconcat #'symbol-name syms ", ")))
(syms
(byte-compile-warn str1 (car syms)))))
;; If we have compiled any calls to functions which are not known to be
;; defined, issue a warning enumerating them.
;; `unresolved' in the list `byte-compile-warnings' disables this.
(defun byte-compile-warn-about-unresolved-functions ()
(when (byte-compile-warning-enabled-p 'unresolved)
(let ((byte-compile-current-form :end)
(noruntime nil)
(unresolved nil))
(let ((byte-compile-current-form :end))
;; Separate the functions that will not be available at runtime
;; from the truly unresolved ones.
(dolist (f byte-compile-unresolved-functions)
(setq f (car f))
(when (not (memq f byte-compile-new-defuns))
(if (fboundp f) (push f noruntime) (push f unresolved))))
;; Complain about the no-run-time functions
(byte-compile-print-syms
"the function `%s' might not be defined at runtime."
"the following functions might not be defined at runtime:"
noruntime)
;; Complain about the unresolved functions
(byte-compile-print-syms
"the function `%s' is not known to be defined."
"the following functions are not known to be defined:"
unresolved)))
(dolist (urf byte-compile-unresolved-functions)
(let ((f (car urf)))
(when (not (memq f byte-compile-new-defuns))
(let ((byte-compile-last-position (cadr urf)))
(byte-compile-warn
(if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.")
(car urf))))))))
nil)
@ -5006,10 +4975,10 @@ binding slots have been popped."
(byte-compile-push-constant op)
(byte-compile-form fun)
(byte-compile-form prop)
(let* ((fun (eval fun))
(prop (eval prop))
(let* ((fun (eval fun t))
(prop (eval prop t))
(val (if (macroexp-const-p val)
(eval val)
(eval val t)
(byte-compile-lambda (cadr val)))))
(push `(,fun
. (,prop ,val ,@(alist-get fun overriding-plist-environment)))

3
lisp/emacs-lisp/cl-macs.el
View file

@ -1976,7 +1976,8 @@ a `let' form, except that the list of symbols can be computed at run-time."
(,binds ()))
(while ,syms
(push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
(eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun))))))))
(eval (list 'let (nreverse ,binds)
(list 'funcall (list 'quote ,bodyfun))))))))
(defconst cl--labels-magic (make-symbol "cl--labels-magic"))

2
lisp/emacs-lisp/lisp-mode.el
View file

@ -527,7 +527,7 @@ This will generate compile-time constants from BINDINGS."
;; This is too general -- rms.
;; A user complained that he has functions whose names start with `do'
;; and that they get the wrong color.
;; That user has violated the http://www.cliki.net/Naming+conventions:
;; That user has violated the https://www.cliki.net/Naming+conventions:
;; CL (but not EL!) `with-' (context) and `do-' (iteration)
(,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)")
(1 font-lock-keyword-face))

147
lisp/emacs-lisp/pcase.el
View file

@ -207,6 +207,7 @@ If EXP fails to match any of the patterns in CASES, an error is signaled."
(pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
(pcase--expand
;; FIXME: Could we add the FILE:LINE data in the error message?
;; FILE is available from `macroexp-file-name'.
exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
;;;###autoload
@ -320,34 +321,46 @@ of the elements of LIST is performed as if by `pcase-let'.
(defun pcase--trivial-upat-p (upat)
(and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
(defun pcase-compile-patterns (exp cases)
"Compile the set of patterns in CASES.
EXP is the expression that will be matched against the patterns.
CASES is a list of elements (PAT . CODEGEN)
where CODEGEN is a function that returns the code to use when
PAT matches. That code has to be in the form of a cons cell.
CODEGEN will be called with at least 2 arguments, VARVALS and COUNT.
VARVALS is a list of elements of the form (VAR VAL . RESERVED) where VAR
is a variable bound by the pattern and VAL is a duplicable expression
that returns the value this variable should be bound to.
If the pattern PAT uses `or', CODEGEN may be called multiple times,
in which case it may want to generate the code differently to avoid
a potential code explosion. For this reason the COUNT argument indicates
how many time this CODEGEN is called."
(macroexp-let2 macroexp-copyable-p val exp
(let* ((defs ())
(seen '())
(let* ((seen '())
(phcounter 0)
(main
(pcase--u
(mapcar
(lambda (case)
`(,(pcase--match val (pcase--macroexpand (car case)))
,(lambda (vars)
(let ((prev (assq case seen))
(code (cdr case)))
(let ((prev (assq case seen)))
(unless prev
;; Keep track of the cases that are used.
(push (setq prev (list case)) seen))
(if (member code '(nil (nil))) nil
;; Put `code' in the cdr just so that not all
;; branches look identical (to avoid things like
;; `macroexp--if' optimizing them too optimistically).
(let ((ph (list 'pcase--placeholder code)))
(setcdr prev (cons (cons vars ph) (cdr prev)))
ph))))))
;; Put a counter in the cdr just so that not
;; all branches look identical (to avoid things
;; like `macroexp--if' optimizing them too
;; optimistically).
(let ((ph (cons 'pcase--placeholder
(setq phcounter (1+ phcounter)))))
(setcdr prev (cons (cons vars ph) (cdr prev)))
ph)))))
cases))))
;; Take care of the place holders now.
(dolist (branch seen)
(let ((code (cdar branch))
(let ((codegen (cdar branch))
(uses (cdr branch)))
;; Find all the vars that are in scope (the union of the
;; vars provided in each use case).
@ -358,48 +371,74 @@ of the elements of LIST is performed as if by `pcase-let'.
(if vi
(if (cddr v) (setcdr vi 'used))
(push (cons (car v) (cddr v)) allvarinfo))))))
(allvars (mapcar #'car allvarinfo))
(ignores (mapcar (lambda (vi) (when (cdr vi) `(ignore ,(car vi))))
allvarinfo)))
;; Since we use a tree-based pattern matching
;; technique, the leaves (the places that contain the
;; code to run once a pattern is matched) can get
;; copied a very large number of times, so to avoid
;; code explosion, we need to keep track of how many
;; times we've used each leaf and move it
;; to a separate function if that number is too high.
(if (or (null (cdr uses)) (pcase--small-branch-p code))
(dolist (use uses)
(let ((vars (car use))
(placeholder (cdr use)))
;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
(setcar placeholder 'let)
(setcdr placeholder
`(,(mapcar (lambda (v) (list v (cadr (assq v vars))))
allvars)
;; Try and silence some of the most common
;; spurious "unused var" warnings.
,@ignores
,@code))))
;; Several occurrence of this non-small branch in the output.
(let ((bsym
(make-symbol (format "pcase-%d" (length defs)))))
(push `(,bsym (lambda ,allvars ,@ignores ,@code)) defs)
(dolist (use uses)
(let ((vars (car use))
(placeholder (cdr use)))
;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
(setcar placeholder 'funcall)
(setcdr placeholder
`(,bsym
,@(mapcar (lambda (v) (cadr (assq v vars)))
allvars))))))))))
(allvars (mapcar #'car allvarinfo)))
(dolist (use uses)
(let* ((vars (car use))
(varvals
(mapcar (lambda (v)
`(,v ,(cadr (assq v vars))
,(cdr (assq v allvarinfo))))
allvars))
(placeholder (cdr use))
(code (funcall codegen varvals (length uses))))
;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
(setcar placeholder (car code))
(setcdr placeholder (cdr code)))))))
(dolist (case cases)
(unless (or (assq case seen)
(memq (car case) pcase--dontwarn-upats))
(message "pcase pattern %S shadowed by previous pcase pattern"
(car case))))
(macroexp-let* defs main))))
(setq main
(macroexp-warn-and-return
(format "pcase pattern %S shadowed by previous pcase pattern"
(car case))
main))))
main)))
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
(let* ((defs ())
(codegen
(lambda (code)
(if (member code '(nil (nil) ('nil)))
(lambda (&rest _) ''nil)
(let ((bsym ()))
(lambda (varvals count &rest _)
(let* ((ignored-vars
(delq nil (mapcar (lambda (vv) (if (nth 2 vv) (car vv)))
varvals)))
(ignores (if ignored-vars
`((ignore . ,ignored-vars)))))
;; Since we use a tree-based pattern matching
;; technique, the leaves (the places that contain the
;; code to run once a pattern is matched) can get
;; copied a very large number of times, so to avoid
;; code explosion, we need to keep track of how many
;; times we've used each leaf and move it
;; to a separate function if that number is too high.
(if (or (< count 2) (pcase--small-branch-p code))
`(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv)))
varvals)
;; Try and silence some of the most common
;; spurious "unused var" warnings.
,@ignores
,@code)
;; Several occurrence of this non-small branch in
;; the output.
(unless bsym
(setq bsym (make-symbol
(format "pcase-%d" (length defs))))
(push `(,bsym (lambda ,(mapcar #'car varvals)
,@ignores ,@code))
defs))
`(funcall ,bsym ,@(mapcar #'cadr varvals)))))))))
(main
(pcase-compile-patterns
exp
(mapcar (lambda (case)
(cons (car case) (funcall codegen (cdr case))))
cases))))
(macroexp-let* defs main)))
(defun pcase--macroexpand (pat)
"Expands all macro-patterns in PAT."

3
lisp/emacs-lisp/shortdoc.el
View file

@ -168,15 +168,12 @@ There can be any number of :example/:result elements."
(replace-regexp-in-string
:eval (replace-regexp-in-string "[a-z]+" "_" "*foo*"))
(string-trim
:no-manual t
:args (string)
:doc "Trim STRING of leading and trailing white space."
:eval (string-trim " foo "))
(string-trim-left
:no-manual t
:eval (string-trim-left "oofoo" "o+"))
(string-trim-right
:no-manual t
:eval (string-trim-right "barkss" "s+"))
(string-truncate-left
:no-manual t

2
lisp/emacs-lisp/smie.el
View file

@ -63,7 +63,7 @@
;; building the 2D precedence tables and then computing the precedence levels
;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune
;; and Ceriel Jacobs (BookBody.pdf available at
;; http://dickgrune.com/Books/PTAPG_1st_Edition/).
;; https://dickgrune.com/Books/PTAPG_1st_Edition/).
;;
;; OTOH we had to kill many chickens, read many coffee grounds, and practice
;; untold numbers of black magic spells, to come up with the indentation code.

22
lisp/emacs-lisp/subr-x.el
View file

@ -215,28 +215,6 @@ The variable list SPEC is the same as in `if-let'."
(define-obsolete-function-alias 'string-reverse 'reverse "25.1")
(defsubst string-trim-left (string &optional regexp)
"Trim STRING of leading string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
(if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
(substring string (match-end 0))
string))
(defsubst string-trim-right (string &optional regexp)
"Trim STRING of trailing string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
(let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
string)))
(if i (substring string 0 i) string)))
(defsubst string-trim (string &optional trim-left trim-right)
"Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
(string-trim-left (string-trim-right string trim-right) trim-left))
;;;###autoload
(defun string-truncate-left (string length)
"Truncate STRING to LENGTH, replacing initial surplus with \"...\"."