From 2d12df39267b4fca13a9739e6354985e807e1dd9 Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Sat, 13 Mar 2021 16:12:47 -0300 Subject: Init archive and add noconfirm to 'package-install-selected-packages' * lisp/emacs-lisp/package.el (package-install-selected-packages): Add call to 'package--archives-initialize' and add optional argument NOCONFIRM to skip user confirmation when installing packages. (Bug#47124) --- lisp/emacs-lisp/package.el | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') 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'" -- cgit v1.2.3 From 82c3bd1e4a58f6fefcb7d69b6e04013bd86f54be Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 17 Mar 2021 19:04:28 -0400 Subject: * lisp/emacs-lisp/benchmark.el (benchmark-call): New function (benchmark-run, benchmark-run-compiled, benchmark): Use it. (benchmark--adaptive): New internal function. --- doc/lispref/debugging.texi | 3 +- etc/NEWS | 5 +++ lisp/emacs-lisp/benchmark.el | 98 ++++++++++++++++++++++++++++++-------------- 3 files changed, 74 insertions(+), 32 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index 8e4b0ebfe96..de98d2206e2 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -1041,7 +1041,8 @@ functions written in Lisp, it cannot profile Emacs primitives. @cindex @file{benchmark.el} @cindex benchmarking You can measure the time it takes to evaluate individual Emacs Lisp -forms using the @file{benchmark} library. See the macros +forms using the @file{benchmark} library. See the function +@code{benchmark-call} as well as the macros @code{benchmark-run}, @code{benchmark-run-compiled} and @code{benchmark-progn} in @file{benchmark.el}. You can also use the @code{benchmark} command for timing forms interactively. diff --git a/etc/NEWS b/etc/NEWS index 6fe98dbc123..27a4766a402 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -389,6 +389,11 @@ major mode. * Changes in Specialized Modes and Packages in Emacs 28.1 +** Benchmark +*** New function 'benchmark-call' to measure the execution time of a function. +Additionally, the number of repetitions can be expressed as a minimal duration +in seconds. + ** Macroexp --- *** New function 'macroexp-file-name' to know the name of the current file. 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)) @@ -40,6 +42,61 @@ ,@forms (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. @@ -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) -- cgit v1.2.3 From 21e1a126b54390b5a22e5af836d14ae8f4e423fb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 18 Mar 2021 08:33:40 +0100 Subject: Make memory-report work with buffer-local unbound vars * lisp/emacs-lisp/memory-report.el (memory-report--buffer-data): Protect against buffer-local unbound variables (bug#47057). --- lisp/emacs-lisp/memory-report.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') 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)) -- cgit v1.2.3 From 4eb030319725cfe7fe17049e91fdbed2e222a3c9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 18 Mar 2021 11:15:50 +0100 Subject: Compute chart-face-list dynamically * lisp/emacs-lisp/chart.el (chart-face-list): Allow a function as the value (bug#47133) so that we can compute the faces dynamically on different displays. (chart--face-list): New function. (chart-draw-data): Use it. --- lisp/emacs-lisp/chart.el | 64 +++++++++++++++++++++++++++--------------------- 1 file changed, 36 insertions(+), 28 deletions(-) (limited to 'lisp/emacs-lisp') 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) -- cgit v1.2.3 From 52270aa0dc3313f42986a07413bf5b600d9fecbe Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Thu, 18 Mar 2021 13:33:09 +0100 Subject: Optimise tail calls in `and` and `or` forms in `cl-labels` functions * lisp/emacs-lisp/cl-macs.el (cl--self-tco): Handle `and` and `or`. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--labels): Add test cases. --- lisp/emacs-lisp/cl-macs.el | 6 ++++++ test/lisp/emacs-lisp/cl-macs-tests.el | 25 ++++++++++++++++++++----- 2 files changed, 26 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c38dc44ff60..73ff4e6fd09 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2100,6 +2100,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 diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 2e5f3020b41..df1d26a074e 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -617,11 +617,26 @@ collection clause." (cl-labels ((len (xs) (if xs (1+ (len (cdr xs))) 0))) (should (equal (len (make-list 42 t)) 42))) - ;; Simple tail-recursive function. - (cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) - (should (equal (len (make-list 42 t) 0) 42)) - ;; Should not bump into stack depth limits. - (should (equal (len (make-list 42000 t) 0) 42000))) + (let ((list-42 (make-list 42 t)) + (list-42k (make-list 42000 t))) + + (cl-labels + ;; Simple tail-recursive function. + ((len (xs n) (if xs (len (cdr xs) (1+ n)) n)) + ;; Slightly obfuscated version to exercise tail calls from + ;; `let', `progn', `and' and `or'. + (len2 (xs n) (or (and (not xs) n) + (let (n1) + (and xs + (progn (setq n1 (1+ n)) + (len2 (cdr xs) n1))))))) + (should (equal (len nil 0) 0)) + (should (equal (len2 nil 0) 0)) + (should (equal (len list-42 0) 42)) + (should (equal (len2 list-42 0) 42)) + ;; Should not bump into stack depth limits. + (should (equal (len list-42k 0) 42000)) + (should (equal (len2 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) -- cgit v1.2.3 From 236aad4f8c7cbf1f4455a0f034576d48a8d13f53 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 18 Mar 2021 17:54:43 -0400 Subject: * lisp/emacs-lisp/cl-macs.el (cl--self-tco): Optimize the "return nil" case --- lisp/emacs-lisp/cl-macs.el | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 73ff4e6fd09..9eabfc63b4a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2068,6 +2068,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)))) @@ -2115,14 +2117,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 @@ -2134,8 +2140,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) @@ -2281,7 +2287,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))) -- cgit v1.2.3 From b815445cea741a61cdab7f90bdf7a0ddc487fc5b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 18 Mar 2021 23:32:57 -0400 Subject: Fix copyright lines mistakenly treated as outline headers * lisp/emacs-lisp/generator.el: * test/lisp/cedet/semantic-utest.el: * test/lisp/cedet/semantic/format-tests.el: * test/lisp/cedet/semantic/fw-tests.el: * test/lisp/cedet/semantic/bovine/gcc-tests.el: * test/lisp/cedet/semantic/format-resources/test-fmt.el: * test/manual/cedet/semantic-tests.el: * lisp/obsolete/inversion.el: Use only 2 semi-colons before "Copyright". --- lisp/emacs-lisp/generator.el | 2 +- lisp/obsolete/inversion.el | 2 +- test/lisp/cedet/semantic-utest.el | 2 +- test/lisp/cedet/semantic/bovine/gcc-tests.el | 2 +- test/lisp/cedet/semantic/format-resources/test-fmt.el | 2 +- test/lisp/cedet/semantic/format-tests.el | 2 +- test/lisp/cedet/semantic/fw-tests.el | 2 +- test/manual/cedet/semantic-tests.el | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') 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 ;; Keywords: extensions, elisp diff --git a/lisp/obsolete/inversion.el b/lisp/obsolete/inversion.el index 192186ee3b2..e61b36cd88b 100644 --- a/lisp/obsolete/inversion.el +++ b/lisp/obsolete/inversion.el @@ -1,6 +1,6 @@ ;;; inversion.el --- When you need something in version XX.XX -*- lexical-binding: t; -*- -;;; Copyright (C) 2002-2003, 2005-2021 Free Software Foundation, Inc. +;; Copyright (C) 2002-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam ;; Version: 1.3 diff --git a/test/lisp/cedet/semantic-utest.el b/test/lisp/cedet/semantic-utest.el index 67de4a5b02d..172ab62f895 100644 --- a/test/lisp/cedet/semantic-utest.el +++ b/test/lisp/cedet/semantic-utest.el @@ -1,6 +1,6 @@ ;;; semantic-utest.el --- Tests for semantic's parsing system. -*- lexical-binding:t -*- -;;; Copyright (C) 2003-2004, 2007-2021 Free Software Foundation, Inc. +;; Copyright (C) 2003-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el index e1a18c6c64c..93677d6c871 100644 --- a/test/lisp/cedet/semantic/bovine/gcc-tests.el +++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el @@ -1,6 +1,6 @@ ;;; gcc-tests.el --- Tests for semantic/bovine/gcc.el -*- lexical-binding:t -*- -;;; Copyright (C) 2003-2004, 2007-2021 Free Software Foundation, Inc. +;; Copyright (C) 2003-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam diff --git a/test/lisp/cedet/semantic/format-resources/test-fmt.el b/test/lisp/cedet/semantic/format-resources/test-fmt.el index 941aaae8595..8458a8e6510 100644 --- a/test/lisp/cedet/semantic/format-resources/test-fmt.el +++ b/test/lisp/cedet/semantic/format-resources/test-fmt.el @@ -1,6 +1,6 @@ ;;; test-fmt.el --- test semantic tag formatting -*- lexical-binding: t -*- -;;; Copyright (C) 2012, 2019-2021 Free Software Foundation, Inc. +;; Copyright (C) 2012-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam diff --git a/test/lisp/cedet/semantic/format-tests.el b/test/lisp/cedet/semantic/format-tests.el index e82c97b4c43..149f408af15 100644 --- a/test/lisp/cedet/semantic/format-tests.el +++ b/test/lisp/cedet/semantic/format-tests.el @@ -1,6 +1,6 @@ ;;; semantic/format-tests.el --- Parsing / Formatting tests -*- lexical-binding:t -*- -;;; Copyright (C) 2003-2004, 2007-2021 Free Software Foundation, Inc. +;; Copyright (C) 2003-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam diff --git a/test/lisp/cedet/semantic/fw-tests.el b/test/lisp/cedet/semantic/fw-tests.el index 62d665dbb6e..7b1cd21bd1b 100644 --- a/test/lisp/cedet/semantic/fw-tests.el +++ b/test/lisp/cedet/semantic/fw-tests.el @@ -1,6 +1,6 @@ ;;; fw-tests.el --- Tests for semantic/fw.el -*- lexical-binding:t -*- -;;; Copyright (C) 2003-2004, 2007-2021 Free Software Foundation, Inc. +;; Copyright (C) 2003-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam diff --git a/test/manual/cedet/semantic-tests.el b/test/manual/cedet/semantic-tests.el index 61f1d118fd2..7169c78bea0 100644 --- a/test/manual/cedet/semantic-tests.el +++ b/test/manual/cedet/semantic-tests.el @@ -1,6 +1,6 @@ ;;; semantic-utest.el --- Miscellaneous Semantic tests. -*- lexical-binding: t; -*- -;;; Copyright (C) 2003-2004, 2007-2021 Free Software Foundation, Inc. +;; Copyright (C) 2003-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam -- cgit v1.2.3 From 937b6c18bd6c4806eb1e4c8764db56b314c09056 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 19 Mar 2021 17:42:22 -0400 Subject: * lisp/emacs-lisp/pcase.el (pcase-compile-patterns): New function (bug#47261) Extracted from `pcase--expand`. (pcase--expand): Use it. --- etc/NEWS | 3 + lisp/emacs-lisp/pcase.el | 147 ++++++++++++++++++++++++++++++----------------- 2 files changed, 96 insertions(+), 54 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 6dda3423c17..fb8fa322a12 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -433,6 +433,9 @@ to nil. This was already sometimes the case, but it is now guaranteed. This is like '(pred (lambda (x) (not (FUN x))))' but results in better code. +--- +*** New function 'pcase-compile-patterns' to write other macros. + +++ ** profiler.el The results displayed by 'profiler-report' now have the usage figures 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." -- cgit v1.2.3 From bf210251eadafafd1bf4176127b872030405baa3 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 19 Mar 2021 18:33:38 -0400 Subject: * lisp/emacs-lisp/bytecomp.el: Remember location of unresolved calls I've gotten tired of seeing the "function foo not known to be defined" warning without any line number information. So this patch adds as line number the position of the first use of that function in the file (well, approximately, as usual). (byte-compile-unresolved-functions): Add POSITIONs in the alist. (byte-compile-function-warn): Store the current position in `byte-compile-unresolved-functions`. (byte-compile-arglist-warn): Adjust accordingly. (byte-compile-print-syms): Delete unused function. (byte-compile-warn-about-unresolved-functions): Use the stored position to give more precise warnings. --- lisp/emacs-lisp/bytecomp.el | 71 +++++++++++++-------------------------------- 1 file changed, 20 insertions(+), 51 deletions(-) (limited to 'lisp/emacs-lisp') 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))) -- cgit v1.2.3 From e33c2bfbf3f62449a9b62de423a1bbe3a39a3dca Mon Sep 17 00:00:00 2001 From: Toby Cubitt Date: Sat, 20 Mar 2021 10:01:13 +0100 Subject: Fix cl-progv binding order * lisp/emacs-lisp/cl-macs.el (cl-progv): Bind variables in the correct order (bug#47272). --- lisp/emacs-lisp/cl-macs.el | 3 ++- test/lisp/emacs-lisp/cl-macs-tests.el | 5 +++++ 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 9eabfc63b4a..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")) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index df1d26a074e..dd6487603d3 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -648,4 +648,9 @@ collection clause." #'len)) (`(function (lambda (,_ ,_) . ,_)) t)))) +(ert-deftest cl-macs--progv () + (should (= (cl-progv '(test test) '(1 2) test) 2)) + (should (equal (cl-progv '(test1 test2) '(1 2) (list test1 test2)) + '(1 2)))) + ;;; cl-macs-tests.el ends here -- cgit v1.2.3