summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/bytecomp.el71
-rw-r--r--lisp/emacs-lisp/cl-macs.el3
-rw-r--r--lisp/emacs-lisp/lisp-mode.el2
-rw-r--r--lisp/emacs-lisp/pcase.el147
-rw-r--r--lisp/emacs-lisp/shortdoc.el3
-rw-r--r--lisp/emacs-lisp/smie.el2
-rw-r--r--lisp/emacs-lisp/subr-x.el22
7 files changed, 117 insertions, 133 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index b04286c34ae..30d59137482 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -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)))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 55c7e67daa6..7f8f7105f33 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -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"))
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 4aa8ddcfa11..67b75460941 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -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))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 5342a0179d9..006517db759 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -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."
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 789d6325e9a..86d5130bbed 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -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
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index 44be9afbfae..994433063ce 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -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.
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index a4514454c0b..9c8c967ee9c 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -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 \"...\"."
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-02 05:28:10 +0000