summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/benchmark.el98
-rw-r--r--lisp/emacs-lisp/bytecomp.el71
-rw-r--r--lisp/emacs-lisp/chart.el64
-rw-r--r--lisp/emacs-lisp/cl-macs.el27
-rw-r--r--lisp/emacs-lisp/generator.el2
-rw-r--r--lisp/emacs-lisp/memory-report.el2
-rw-r--r--lisp/emacs-lisp/package.el16
-rw-r--r--lisp/emacs-lisp/pcase.el147
8 files changed, 248 insertions, 179 deletions
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 2a3efbe5a1b..439d3bd363e 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -31,6 +31,8 @@
;;; Code:
+(eval-when-compile (require 'subr-x)) ;For `named-let'.
+
(defmacro benchmark-elapse (&rest forms)
"Return the time in seconds elapsed for execution of FORMS."
(declare (indent 0) (debug t))
@@ -41,6 +43,61 @@
(float-time (time-since ,t1)))))
;;;###autoload
+(defun benchmark-call (func &optional repetitions)
+ "Measure the run time of calling FUNC a number REPETITIONS of times.
+The result is a list (TIME GC GCTIME)
+where TIME is the total time it took, in seconds.
+GCTIME is the amount of time that was spent in the GC
+and GC is the number of times the GC was called.
+
+REPETITIONS can also be a floating point number, in which case it
+specifies a minimum number of seconds that the benchmark execution
+should take. In that case the return value is prepended with the
+number of repetitions actually used."
+ (if (floatp repetitions)
+ (benchmark--adaptive func repetitions)
+ (unless repetitions (setq repetitions 1))
+ (let ((gc gc-elapsed)
+ (gcs gcs-done)
+ (empty-func (lambda () 'empty-func)))
+ (list
+ (if (> repetitions 1)
+ (- (benchmark-elapse (dotimes (_ repetitions) (funcall func)))
+ (benchmark-elapse (dotimes (_ repetitions) (funcall empty-func))))
+ (- (benchmark-elapse (funcall func))
+ (benchmark-elapse (funcall empty-func))))
+ (- gcs-done gcs)
+ (- gc-elapsed gc)))))
+
+(defun benchmark--adaptive (func time)
+ "Measure the run time of FUNC, calling it enough times to last TIME seconds.
+Result is (REPETITIONS . DATA) where DATA is as returned by `branchmark-call'."
+ (named-let loop ((repetitions 1)
+ (data (let ((x (list 0))) (setcdr x x) x)))
+ ;; (message "Running %d iteration" repetitions)
+ (let ((newdata (benchmark-call func repetitions)))
+ (if (<= (car newdata) 0)
+ ;; This can happen if we're unlucky, e.g. the process got preempted
+ ;; (or the GC ran) just during the empty-func loop.
+ ;; Just try again, hopefully this won't repeat itself.
+ (progn
+ ;; (message "Ignoring the %d iterations" repetitions)
+ (loop (* 2 repetitions) data))
+ (let* ((sum (cl-mapcar #'+ data (cons repetitions newdata)))
+ (totaltime (nth 1 sum)))
+ (if (>= totaltime time)
+ sum
+ (let* ((iter-time (/ totaltime (car sum)))
+ (missing-time (- time totaltime))
+ (missing-iter (/ missing-time iter-time)))
+ ;; `iter-time' is approximate because of effects like the GC,
+ ;; so multiply at most by 10, in case we are wildly off the mark.
+ (loop (max repetitions
+ (min (ceiling missing-iter)
+ (* 10 repetitions)))
+ sum))))))))
+
+;;;###autoload
(defmacro benchmark-run (&optional repetitions &rest forms)
"Time execution of FORMS.
If REPETITIONS is supplied as a number, run FORMS that many times,
@@ -53,20 +110,7 @@ See also `benchmark-run-compiled'."
(unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
(setq forms (cons repetitions forms)
repetitions 1))
- (let ((i (make-symbol "i"))
- (gcs (make-symbol "gcs"))
- (gc (make-symbol "gc")))
- `(let ((,gc gc-elapsed)
- (,gcs gcs-done))
- (list ,(if (or (symbolp repetitions) (> repetitions 1))
- ;; Take account of the loop overhead.
- `(- (benchmark-elapse (dotimes (,i ,repetitions)
- ,@forms))
- (benchmark-elapse (dotimes (,i ,repetitions)
- nil)))
- `(benchmark-elapse ,@forms))
- (- gcs-done ,gcs)
- (- gc-elapsed ,gc)))))
+ `(benchmark-call (lambda () ,@forms) ,repetitions))
;;;###autoload
(defmacro benchmark-run-compiled (&optional repetitions &rest forms)
@@ -78,21 +122,7 @@ result. The overhead of the `lambda's is accounted for."
(unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
(setq forms (cons repetitions forms)
repetitions 1))
- (let ((i (make-symbol "i"))
- (gcs (make-symbol "gcs"))
- (gc (make-symbol "gc"))
- (code (byte-compile `(lambda () ,@forms)))
- (lambda-code (byte-compile '(lambda ()))))
- `(let ((,gc gc-elapsed)
- (,gcs gcs-done))
- (list ,(if (or (symbolp repetitions) (> repetitions 1))
- ;; Take account of the loop overhead.
- `(- (benchmark-elapse (dotimes (,i ,repetitions)
- (funcall ,code)))
- (benchmark-elapse (dotimes (,i ,repetitions)
- (funcall ,lambda-code))))
- `(benchmark-elapse (funcall ,code)))
- (- gcs-done ,gcs) (- gc-elapsed ,gc)))))
+ `(benchmark-call (byte-compile '(lambda () ,@forms)) ,repetitions))
;;;###autoload
(defun benchmark (repetitions form)
@@ -100,9 +130,15 @@ result. The overhead of the `lambda's is accounted for."
Interactively, REPETITIONS is taken from the prefix arg, and
the command prompts for the form to benchmark.
For non-interactive use see also `benchmark-run' and
-`benchmark-run-compiled'."
+`benchmark-run-compiled'.
+FORM can also be a function in which case we measure the time it takes
+to call it without any argument."
(interactive "p\nxForm: ")
- (let ((result (eval `(benchmark-run ,repetitions ,form) t)))
+ (let ((result (benchmark-call (eval (pcase form
+ ((or `#',_ `(lambda . ,_)) form)
+ (_ `(lambda () ,form)))
+ t)
+ repetitions)))
(if (zerop (nth 1 result))
(message "Elapsed time: %fs" (car result))
(message "Elapsed time: %fs (%fs in %d GCs)" (car result)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 74eb5b0377f..0babbbb978d 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.")
@@ -1423,9 +1427,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.
@@ -1525,14 +1529,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))
@@ -1640,56 +1644,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)
@@ -4912,10 +4881,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/chart.el b/lisp/emacs-lisp/chart.el
index 40c17b916f9..5afc6d3bde3 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -89,33 +89,39 @@ Useful if new Emacs is used on B&W display.")
(declare-function x-display-color-cells "xfns.c" (&optional terminal))
-(defvar chart-face-list
- (if (display-color-p)
- (let ((cl chart-face-color-list)
- (pl chart-face-pixmap-list)
- (faces ())
- nf)
- (while cl
- (setq nf (make-face
- (intern (concat "chart-" (car cl) "-" (car pl)))))
- (set-face-background nf (if (condition-case nil
- (> (x-display-color-cells) 4)
- (error t))
- (car cl)
- "white"))
- (set-face-foreground nf "black")
- (if (and chart-face-use-pixmaps pl)
- (condition-case nil
- (set-face-background-pixmap nf (car pl))
- (error (message "Cannot set background pixmap %s" (car pl)))))
- (push nf faces)
- (setq cl (cdr cl)
- pl (cdr pl)))
- faces))
+(defvar chart-face-list #'chart--face-list
"Faces used to colorize charts.
+This should either be a list of faces, or a function that returns
+a list of faces.
+
List is limited currently, which is ok since you really can't display
too much in text characters anyways.")
+(defun chart--face-list ()
+ (and
+ (display-color-p)
+ (let ((cl chart-face-color-list)
+ (pl chart-face-pixmap-list)
+ (faces ())
+ nf)
+ (while cl
+ (setq nf (make-face
+ (intern (concat "chart-" (car cl) "-" (car pl)))))
+ (set-face-background nf (if (condition-case nil
+ (> (x-display-color-cells) 4)
+ (error t))
+ (car cl)
+ "white"))
+ (set-face-foreground nf "black")
+ (if (and chart-face-use-pixmaps pl)
+ (condition-case nil
+ (set-face-background-pixmap nf (car pl))
+ (error (message "Cannot set background pixmap %s" (car pl)))))
+ (push nf faces)
+ (setq cl (cdr cl)
+ pl (cdr pl)))
+ faces)))
+
(define-derived-mode chart-mode special-mode "Chart"
"Define a mode in Emacs for displaying a chart."
(buffer-disable-undo)
@@ -374,7 +380,10 @@ of the drawing."
(let* ((data (oref c sequences))
(dir (oref c direction))
(odir (if (eq dir 'vertical) 'horizontal 'vertical))
- )
+ (faces
+ (if (functionp chart-face-list)
+ (funcall chart-face-list)
+ chart-face-list)))
(while data
(if (stringp (car (oref (car data) data)))
;; skip string lists...
@@ -390,10 +399,9 @@ of the drawing."
(zp (if (eq dir 'vertical)
(chart-translate-ypos c 0)
(chart-translate-xpos c 0)))
- (fc (if chart-face-list
- (nth (% i (length chart-face-list)) chart-face-list)
- 'default))
- )
+ (fc (if faces
+ (nth (% i (length faces)) faces)
+ 'default)))
(if (< dp zp)
(progn
(chart-draw-line dir (car rng) dp zp)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c38dc44ff60..27ed07b6673 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"))
@@ -2068,6 +2069,8 @@ Like `cl-flet' but the definitions can refer to previous ones.
;; even handle mutually recursive functions.
(letrec
((done nil) ;; Non-nil if some TCO happened.
+ ;; This var always holds the value `nil' until (just before) we
+ ;; exit the loop.
(retvar (make-symbol "retval"))
(ofargs (mapcar (lambda (s) (if (memq s cl--lambda-list-keywords) s
(make-symbol (symbol-name s))))
@@ -2100,6 +2103,12 @@ Like `cl-flet' but the definitions can refer to previous ones.
(`(progn . ,exps) `(progn . ,(funcall opt-exps exps)))
(`(if ,cond ,then . ,else)
`(if ,cond ,(funcall opt then) . ,(funcall opt-exps else)))
+ (`(and . ,exps) `(and . ,(funcall opt-exps exps)))
+ (`(or ,arg) (funcall opt arg))
+ (`(or ,arg . ,args)
+ (let ((val (make-symbol "val")))
+ `(let ((,val ,arg))
+ (if ,val ,(funcall opt val) ,(funcall opt `(or . ,args))))))
(`(cond . ,conds)
(let ((cs '()))
(while conds
@@ -2109,14 +2118,18 @@ Like `cl-flet' but the definitions can refer to previous ones.
;; This returns the value of `exp' but it's
;; only in tail position if it's the
;; last condition.
+ ;; Note: This may set the var before we
+ ;; actually exit the loop, but luckily it's
+ ;; only the case if we set the var to nil,
+ ;; so it does preserve the invariant that
+ ;; the var is nil until we exit the loop.
`((setq ,retvar ,exp) nil)
`(,(funcall opt exp)))
cs))
(exps
(push (funcall opt-exps exps) cs))))
- (if (eq t (caar cs))
- `(cond . ,(nreverse cs))
- `(cond ,@(nreverse cs) (t (setq ,retvar nil))))))
+ ;; No need to set `retvar' to return nil.
+ `(cond . ,(nreverse cs))))
((and `(,(or 'let 'let*) ,bindings . ,exps)
(guard
;; Note: it's OK for this `let' to shadow any
@@ -2128,8 +2141,8 @@ Like `cl-flet' but the definitions can refer to previous ones.
;; tail-called any more.
(not (memq var shadowings)))))
`(,(car exp) ,bindings . ,(funcall opt-exps exps)))
- (_
- `(progn (setq ,retvar ,exp) nil))))))
+ ('nil nil) ;No need to set `retvar' to return nil.
+ (_ `(progn (setq ,retvar ,exp) nil))))))
(let ((optimized-body (funcall opt-exps body)))
(if (not done)
@@ -2275,7 +2288,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros."
;; on this behavior (haven't found any yet).
;; Such code should explicitly use `cl-letf' instead, I think.
;;
- ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
+ ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare))
;; (let ((letf nil) (found nil) (nbs ()))
;; (dolist (binding bindings)
;; (let* ((var (if (symbolp binding) binding (car binding)))
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index e45260c32ac..4ae20ba4205 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -1,6 +1,6 @@
;;; generator.el --- generators -*- lexical-binding: t -*-
-;;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Author: Daniel Colascione <dancol@dancol.org>
;; Keywords: extensions, elisp
diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el
index 3d6ca957e63..ecbca280e59 100644
--- a/lisp/emacs-lisp/memory-report.el
+++ b/lisp/emacs-lisp/memory-report.el
@@ -295,7 +295,7 @@ by counted more than once."
(- (position-bytes (point-min)))
(gap-size)))
(seq-reduce #'+ (mapcar (lambda (elem)
- (if (cdr elem)
+ (if (and (consp elem) (cdr elem))
(memory-report--object-size
(make-hash-table :test #'eq)
(cdr elem))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 0973963af22..2ecd92cee9d 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2206,10 +2206,13 @@ directory."
(package-install-from-buffer)))
;;;###autoload
-(defun package-install-selected-packages ()
+(defun package-install-selected-packages (&optional noconfirm)
"Ensure packages in `package-selected-packages' are installed.
-If some packages are not installed propose to install them."
+If some packages are not installed, propose to install them.
+If optional argument NOCONFIRM is non-nil, don't ask for
+confirmation to install packages."
(interactive)
+ (package--archives-initialize)
;; We don't need to populate `package-selected-packages' before
;; using here, because the outcome is the same either way (nothing
;; gets installed).
@@ -2220,10 +2223,11 @@ If some packages are not installed propose to install them."
(difference (- (length not-installed) (length available))))
(cond
(available
- (when (y-or-n-p
- (format "Packages to install: %d (%s), proceed? "
- (length available)
- (mapconcat #'symbol-name available " ")))
+ (when (or noconfirm
+ (y-or-n-p
+ (format "Packages to install: %d (%s), proceed? "
+ (length available)
+ (mapconcat #'symbol-name available " "))))
(mapc (lambda (p) (package-install p 'dont-select)) available)))
((> difference 0)
(message "Packages that are not available: %d (the rest is already installed), maybe you need to `M-x package-refresh-contents'"
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."
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-24 07:49:56 +0000