summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/bindat.el112
-rw-r--r--lisp/emacs-lisp/byte-opt.el1050
-rw-r--r--lisp/emacs-lisp/byte-run.el16
-rw-r--r--lisp/emacs-lisp/bytecomp.el3
-rw-r--r--lisp/emacs-lisp/chart.el3
-rw-r--r--lisp/emacs-lisp/checkdoc.el11
-rw-r--r--lisp/emacs-lisp/crm.el2
-rw-r--r--lisp/emacs-lisp/derived.el2
-rw-r--r--lisp/emacs-lisp/easy-mmode.el8
-rw-r--r--lisp/emacs-lisp/edebug.el3
-rw-r--r--lisp/emacs-lisp/eieio-opt.el2
-rw-r--r--lisp/emacs-lisp/generic.el12
-rw-r--r--lisp/emacs-lisp/helper.el29
-rw-r--r--lisp/emacs-lisp/lisp-mode.el80
-rw-r--r--lisp/emacs-lisp/macroexp.el53
-rw-r--r--lisp/emacs-lisp/package-x.el2
-rw-r--r--lisp/emacs-lisp/package.el2
-rw-r--r--lisp/emacs-lisp/pcase.el44
-rw-r--r--lisp/emacs-lisp/re-builder.el10
-rw-r--r--lisp/emacs-lisp/regi.el55
-rw-r--r--lisp/emacs-lisp/shadow.el22
-rw-r--r--lisp/emacs-lisp/subr-x.el22
-rw-r--r--lisp/emacs-lisp/syntax.el3
-rw-r--r--lisp/emacs-lisp/tcover-ses.el28
-rw-r--r--lisp/emacs-lisp/unsafep.el9
25 files changed, 847 insertions, 736 deletions
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 5f432b80bc2..0d9ba57d663 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -1,4 +1,4 @@
-;;; bindat.el --- binary data structure packing and unpacking.
+;;; bindat.el --- binary data structure packing and unpacking. -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -198,7 +198,7 @@
(defun bindat--unpack-u8 ()
(prog1
- (aref bindat-raw bindat-idx)
+ (aref bindat-raw bindat-idx)
(setq bindat-idx (1+ bindat-idx))))
(defun bindat--unpack-u16 ()
@@ -276,6 +276,8 @@
(t nil)))
(defun bindat--unpack-group (spec)
+ (with-suppressed-warnings ((lexical last))
+ (defvar last))
(let (struct last)
(while spec
(let* ((item (car spec))
@@ -287,11 +289,11 @@
data)
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
- (setq field (eval (car (cdr field)))))
+ (setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
- (setq type (eval (car (cdr type)))))
+ (setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
- (setq len (eval (car (cdr len)))))
+ (setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
@@ -304,48 +306,51 @@
(cond
((eq type 'eval)
(if field
- (setq data (eval len))
- (eval len)))
+ (setq data (eval len t))
+ (eval len t)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
- (setq data (bindat--unpack-group (eval len))))
+ (setq data (bindat--unpack-group (eval len t))))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
- (setq data (cons (bindat--unpack-group (nthcdr tail item)) data))
+ (push (bindat--unpack-group (nthcdr tail item)) data)
(setq index (1+ index)))
(setq data (nreverse data))))
((eq type 'union)
+ (with-suppressed-warnings ((lexical tag))
+ (defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
- (and (consp cc) (eval cc)))
+ (and (consp cc) (eval cc t)))
(setq data (bindat--unpack-group (cdr case))
cases nil)))))
(t
(setq data (bindat--unpack-item type len vectype)
last data)))
(if data
- (if field
- (setq struct (cons (cons field data) struct))
- (setq struct (append data struct))))))
+ (setq struct (if field
+ (cons (cons field data) struct)
+ (append data struct))))))
struct))
-(defun bindat-unpack (spec bindat-raw &optional bindat-idx)
- "Return structured data according to SPEC for binary data in BINDAT-RAW.
-BINDAT-RAW is a unibyte string or vector.
-Optional third arg BINDAT-IDX specifies the starting offset in BINDAT-RAW."
- (when (multibyte-string-p bindat-raw)
+(defun bindat-unpack (spec raw &optional idx)
+ "Return structured data according to SPEC for binary data in RAW.
+RAW is a unibyte string or vector.
+Optional third arg IDX specifies the starting offset in RAW."
+ (when (multibyte-string-p raw)
(error "String is multibyte"))
- (unless bindat-idx (setq bindat-idx 0))
- (bindat--unpack-group spec))
+ (let ((bindat-idx (or idx 0))
+ (bindat-raw raw))
+ (bindat--unpack-group spec)))
(defun bindat-get-field (struct &rest field)
"In structured data STRUCT, return value of field named FIELD.
@@ -373,6 +378,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(ip . 4)))
(defun bindat--length-group (struct spec)
+ (with-suppressed-warnings ((lexical last))
+ (defvar last))
(let (last)
(while spec
(let* ((item (car spec))
@@ -383,32 +390,31 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
- (setq field (eval (car (cdr field)))))
+ (setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
- (setq type (eval (car (cdr type)))))
+ (setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
- (setq len (eval (car (cdr len)))))
+ (setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
(if (and (consp len) (not (eq type 'eval)))
- (setq len (apply 'bindat-get-field struct len)))
+ (setq len (apply #'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(while (eq type 'vec)
- (let ((vlen 1))
- (if (consp vectype)
- (setq len (* len (nth 1 vectype))
- type (nth 2 vectype))
- (setq type (or vectype 'u8)
- vectype nil))))
+ (if (consp vectype)
+ (setq len (* len (nth 1 vectype))
+ type (nth 2 vectype))
+ (setq type (or vectype 'u8)
+ vectype nil)))
(cond
((eq type 'eval)
(if field
- (setq struct (cons (cons field (eval len)) struct))
- (eval len)))
+ (setq struct (cons (cons field (eval len t)) struct))
+ (eval len t)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
@@ -416,7 +422,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(bindat--length-group
- (if field (bindat-get-field struct field) struct) (eval len)))
+ (if field (bindat-get-field struct field) struct) (eval len t)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
@@ -425,13 +431,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
+ (with-suppressed-warnings ((lexical tag))
+ (defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
- (and (consp cc) (eval cc)))
+ (and (consp cc) (eval cc t)))
(progn
(bindat--length-group struct (cdr case))
(setq cases nil))))))
@@ -536,6 +544,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (+ bindat-idx len)))))
(defun bindat--pack-group (struct spec)
+ (with-suppressed-warnings ((lexical last))
+ (defvar last))
(let (last)
(while spec
(let* ((item (car spec))
@@ -546,11 +556,11 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
- (setq field (eval (car (cdr field)))))
+ (setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
- (setq type (eval (car (cdr type)))))
+ (setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
- (setq len (eval (car (cdr len)))))
+ (setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
@@ -563,8 +573,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(cond
((eq type 'eval)
(if field
- (setq struct (cons (cons field (eval len)) struct))
- (eval len)))
+ (setq struct (cons (cons field (eval len t)) struct))
+ (eval len t)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
@@ -572,7 +582,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(bindat--pack-group
- (if field (bindat-get-field struct field) struct) (eval len)))
+ (if field (bindat-get-field struct field) struct) (eval len t)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
@@ -581,13 +591,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
+ (with-suppressed-warnings ((lexical tag))
+ (defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
- (and (consp cc) (eval cc)))
+ (and (consp cc) (eval cc t)))
(progn
(bindat--pack-group struct (cdr case))
(setq cases nil))))))
@@ -596,19 +608,19 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(bindat--pack-item last type len vectype)
))))))
-(defun bindat-pack (spec struct &optional bindat-raw bindat-idx)
+(defun bindat-pack (spec struct &optional raw idx)
"Return binary data packed according to SPEC for structured data STRUCT.
-Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to
+Optional third arg RAW is a pre-allocated unibyte string or vector to
pack into.
-Optional fourth arg BINDAT-IDX is the starting offset into BINDAT-RAW."
- (when (multibyte-string-p bindat-raw)
+Optional fourth arg IDX is the starting offset into RAW."
+ (when (multibyte-string-p raw)
(error "Pre-allocated string is multibyte"))
- (let ((no-return bindat-raw))
- (unless bindat-idx (setq bindat-idx 0))
- (unless bindat-raw
- (setq bindat-raw (make-string (+ bindat-idx (bindat-length spec struct)) 0)))
+ (let* ((bindat-idx (or idx 0))
+ (bindat-raw
+ (or raw
+ (make-string (+ bindat-idx (bindat-length spec struct)) 0))))
(bindat--pack-group struct spec)
- (if no-return nil bindat-raw)))
+ (if raw nil bindat-raw)))
;; Misc. format conversions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index f29f85b9650..66a117fccc8 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -284,8 +284,10 @@
;; If `fn' is from the same file, it has already
;; been preprocessed!
`(function ,fn)
- (byte-compile-preprocess
- (byte-compile--reify-function fn)))))
+ ;; Try and process it "in its original environment".
+ (let ((byte-compile-bound-variables nil))
+ (byte-compile-preprocess
+ (byte-compile--reify-function fn))))))
(if (eq (car-safe newfn) 'function)
(byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
;; This can happen because of macroexp-warn-and-return &co.
@@ -1561,467 +1563,548 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; You may notice that sequences like "dup varset discard" are
;; optimized but sequences like "dup varset TAG1: discard" are not.
;; You may be tempted to change this; resist that temptation.
- (cond ;;
- ;; <side-effect-free> pop --> <deleted>
- ;; ...including:
- ;; const-X pop --> <deleted>
- ;; varref-X pop --> <deleted>
- ;; dup pop --> <deleted>
- ;;
- ((and (eq 'byte-discard (car lap1))
- (memq (car lap0) side-effect-free))
- (setq keep-going t)
- (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
- (setq rest (cdr rest))
- (cond ((= tmp 1)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted>" lap0)
- (setq lap (delq lap0 (delq lap1 lap))))
- ((= tmp 0)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted> discard" lap0)
- (setq lap (delq lap0 lap)))
- ((= tmp -1)
- (byte-compile-log-lap
- " %s discard\t-->\tdiscard discard" lap0)
- (setcar lap0 'byte-discard)
- (setcdr lap0 0))
- ((error "Optimizer error: too much on the stack"))))
- ;;
- ;; goto*-X X: --> X:
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (eq (cdr lap0) lap1))
- (cond ((eq (car lap0) 'byte-goto)
- (setq lap (delq lap0 lap))
- (setq tmp "<deleted>"))
- ((memq (car lap0) byte-goto-always-pop-ops)
- (setcar lap0 (setq tmp 'byte-discard))
- (setcdr lap0 0))
- ((error "Depth conflict at tag %d" (nth 2 lap0))))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
- (nth 1 lap1) (nth 1 lap1)
- tmp (nth 1 lap1)))
- (setq keep-going t))
- ;;
- ;; varset-X varref-X --> dup varset-X
- ;; varbind-X varref-X --> dup varbind-X
- ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
- ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
- ;; The latter two can enable other optimizations.
- ;;
- ;; For lexical variables, we could do the same
- ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
- ;; but this is a very minor gain, since dup is stack-ref-0,
- ;; i.e. it's only better if X>5, and even then it comes
- ;; at the cost of an extra stack slot. Let's not bother.
- ((and (eq 'byte-varref (car lap2))
- (eq (cdr lap1) (cdr lap2))
- (memq (car lap1) '(byte-varset byte-varbind)))
- (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
- (not (eq (car lap0) 'byte-constant)))
- nil
- (setq keep-going t)
- (if (memq (car lap0) '(byte-constant byte-dup))
- (progn
- (setq tmp (if (or (not tmp)
- (macroexp--const-symbol-p
- (car (cdr lap0))))
- (cdr lap0)
- (byte-compile-get-constant t)))
- (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
- lap0 lap1 lap2 lap0 lap1
- (cons (car lap0) tmp))
- (setcar lap2 (car lap0))
- (setcdr lap2 tmp))
- (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
- (setcar lap2 (car lap1))
- (setcar lap1 'byte-dup)
- (setcdr lap1 0)
- ;; The stack depth gets locally increased, so we will
- ;; increase maxdepth in case depth = maxdepth here.
- ;; This can cause the third argument to byte-code to
- ;; be larger than necessary.
- (setq add-depth 1))))
- ;;
- ;; dup varset-X discard --> varset-X
- ;; dup varbind-X discard --> varbind-X
- ;; dup stack-set-X discard --> stack-set-X-1
- ;; (the varbind variant can emerge from other optimizations)
- ;;
- ((and (eq 'byte-dup (car lap0))
- (eq 'byte-discard (car lap2))
- (memq (car lap1) '(byte-varset byte-varbind
- byte-stack-set)))
- (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
- (setq keep-going t
- rest (cdr rest))
- (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
- (setq lap (delq lap0 (delq lap2 lap))))
- ;;
- ;; not goto-X-if-nil --> goto-X-if-non-nil
- ;; not goto-X-if-non-nil --> goto-X-if-nil
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (eq 'byte-not (car lap0))
- (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
- (byte-compile-log-lap " not %s\t-->\t%s"
- lap1
- (cons
- (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil)
- (cdr lap1)))
- (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil))
- (setq lap (delq lap0 lap))
- (setq keep-going t))
- ;;
- ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
- ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (memq (car lap0)
- '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
- (eq 'byte-goto (car lap1)) ; gotoY
- (eq (cdr lap0) lap2)) ; TAG X
- (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
- 'byte-goto-if-not-nil 'byte-goto-if-nil)))
- (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
- lap0 lap1 lap2
- (cons inverse (cdr lap1)) lap2)
- (setq lap (delq lap0 lap))
- (setcar lap1 inverse)
- (setq keep-going t)))
- ;;
- ;; const goto-if-* --> whatever
- ;;
- ((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops)
- ;; If the `byte-constant's cdr is not a cons cell, it has
- ;; to be an index into the constant pool); even though
- ;; it'll be a constant, that constant is not known yet
- ;; (it's typically a free variable of a closure, so will
- ;; only be known when the closure will be built at
- ;; run-time).
- (consp (cdr lap0)))
- (cond ((if (memq (car lap1) '(byte-goto-if-nil
- byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
- (byte-compile-log-lap " %s %s\t-->\t<deleted>"
- lap0 lap1)
- (setq rest (cdr rest)
- lap (delq lap0 (delq lap1 lap))))
- (t
- (byte-compile-log-lap " %s %s\t-->\t%s"
- lap0 lap1
- (cons 'byte-goto (cdr lap1)))
- (when (memq (car lap1) byte-goto-always-pop-ops)
- (setq lap (delq lap0 lap)))
- (setcar lap1 'byte-goto)))
- (setq keep-going t))
- ;;
- ;; varref-X varref-X --> varref-X dup
- ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
- ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
- ;; We don't optimize the const-X variations on this here,
- ;; because that would inhibit some goto optimizations; we
- ;; optimize the const-X case after all other optimizations.
- ;;
- ((and (memq (car lap0) '(byte-varref byte-stack-ref))
- (progn
- (setq tmp (cdr rest))
- (setq tmp2 0)
- (while (eq (car (car tmp)) 'byte-dup)
- (setq tmp2 (1+ tmp2))
- (setq tmp (cdr tmp)))
- t)
- (eq (if (eq 'byte-stack-ref (car lap0))
- (+ tmp2 1 (cdr lap0))
- (cdr lap0))
- (cdr (car tmp)))
- (eq (car lap0) (car (car tmp))))
- (if (memq byte-optimize-log '(t byte))
- (let ((str ""))
- (setq tmp2 (cdr rest))
- (while (not (eq tmp tmp2))
- (setq tmp2 (cdr tmp2)
- str (concat str " dup")))
- (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
- lap0 str lap0 lap0 str)))
- (setq keep-going t)
- (setcar (car tmp) 'byte-dup)
- (setcdr (car tmp) 0)
- (setq rest tmp))
- ;;
- ;; TAG1: TAG2: --> TAG1: <deleted>
- ;; (and other references to TAG2 are replaced with TAG1)
- ;;
- ((and (eq (car lap0) 'TAG)
- (eq (car lap1) 'TAG))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " adjacent tags %d and %d merged"
- (nth 1 lap1) (nth 1 lap0)))
- (setq tmp3 lap)
- (while (setq tmp2 (rassq lap0 tmp3))
- (setcdr tmp2 lap1)
- (setq tmp3 (cdr (memq tmp2 tmp3))))
- (setq lap (delq lap0 lap)
- keep-going t)
- ;; replace references to tag in jump tables, if any
- (dolist (table byte-compile-jump-tables)
- (maphash #'(lambda (value tag)
- (when (equal tag lap0)
- (puthash value lap1 table)))
- table)))
- ;;
- ;; unused-TAG: --> <deleted>
- ;;
- ((and (eq 'TAG (car lap0))
- (not (rassq lap0 lap))
- ;; make sure this tag isn't used in a jump-table
- (cl-loop for table in byte-compile-jump-tables
- when (member lap0 (hash-table-values table))
- return nil finally return t))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
- (setq lap (delq lap0 lap)
- keep-going t))
- ;;
- ;; goto ... --> goto <delete until TAG or end>
- ;; return ... --> return <delete until TAG or end>
- ;; (unless a jump-table is being used, where deleting may affect
- ;; other valid case bodies)
- ;;
- ((and (memq (car lap0) '(byte-goto byte-return))
- (not (memq (car lap1) '(TAG nil)))
- ;; FIXME: Instead of deferring simply when jump-tables are
- ;; being used, keep a list of tags used for switch tags and
- ;; use them instead (see `byte-compile-inline-lapcode').
- (not byte-compile-jump-tables))
- (setq tmp rest)
- (let ((i 0)
- (opt-p (memq byte-optimize-log '(t lap)))
- str deleted)
- (while (and (setq tmp (cdr tmp))
- (not (eq 'TAG (car (car tmp)))))
- (if opt-p (setq deleted (cons (car tmp) deleted)
- str (concat str " %s")
- i (1+ i))))
- (if opt-p
- (let ((tagstr
- (if (eq 'TAG (car (car tmp)))
- (format "%d:" (car (cdr (car tmp))))
- (or (car tmp) ""))))
- (if (< i 6)
- (apply 'byte-compile-log-lap-1
- (concat " %s" str
- " %s\t-->\t%s <deleted> %s")
- lap0
- (nconc (nreverse deleted)
- (list tagstr lap0 tagstr)))
- (byte-compile-log-lap
- " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
- lap0 i (if (= i 1) "" "s")
- tagstr lap0 tagstr))))
- (rplacd rest tmp))
- (setq keep-going t))
- ;;
- ;; <safe-op> unbind --> unbind <safe-op>
- ;; (this may enable other optimizations.)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) byte-after-unbind-ops))
- (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
- (setcar rest lap1)
- (setcar (cdr rest) lap0)
- (setq keep-going t))
- ;;
- ;; varbind-X unbind-N --> discard unbind-(N-1)
- ;; save-excursion unbind-N --> unbind-(N-1)
- ;; save-restriction unbind-N --> unbind-(N-1)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) '(byte-varbind byte-save-excursion
- byte-save-restriction))
- (< 0 (cdr lap1)))
- (if (zerop (setcdr lap1 (1- (cdr lap1))))
- (delq lap1 rest))
- (if (eq (car lap0) 'byte-varbind)
- (setcar rest (cons 'byte-discard 0))
+ (cond
+ ;; <side-effect-free> pop --> <deleted>
+ ;; ...including:
+ ;; const-X pop --> <deleted>
+ ;; varref-X pop --> <deleted>
+ ;; dup pop --> <deleted>
+ ;;
+ ((and (eq 'byte-discard (car lap1))
+ (memq (car lap0) side-effect-free))
+ (setq keep-going t)
+ (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
+ (setq rest (cdr rest))
+ (cond ((= tmp 1)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted>" lap0)
+ (setq lap (delq lap0 (delq lap1 lap))))
+ ((= tmp 0)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted> discard" lap0)
(setq lap (delq lap0 lap)))
- (byte-compile-log-lap " %s %s\t-->\t%s %s"
- lap0 (cons (car lap1) (1+ (cdr lap1)))
- (if (eq (car lap0) 'byte-varbind)
- (car rest)
- (car (cdr rest)))
- (if (and (/= 0 (cdr lap1))
- (eq (car lap0) 'byte-varbind))
- (car (cdr rest))
- ""))
- (setq keep-going t))
- ;;
- ;; goto*-X ... X: goto-Y --> goto*-Y
- ;; goto-X ... X: return --> return
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
- '(byte-goto byte-return)))
- (cond ((and (not (eq tmp lap0))
- (or (eq (car lap0) 'byte-goto)
- (eq (car tmp) 'byte-goto)))
- (byte-compile-log-lap " %s [%s]\t-->\t%s"
- (car lap0) tmp tmp)
- (if (eq (car tmp) 'byte-return)
- (setcar lap0 'byte-return))
- (setcdr lap0 (cdr tmp))
- (setq keep-going t))))
- ;;
- ;; goto-*-else-pop X ... X: goto-if-* --> whatever
- ;; goto-*-else-pop X ... X: discard --> whatever
- ;;
- ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil-else-pop))
- (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap0 (car tmp))))
- (setq tmp2 (car tmp))
- (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
- byte-goto-if-nil)
- (byte-goto-if-not-nil-else-pop
- byte-goto-if-not-nil))))
- (if (memq (car tmp2) tmp3)
- (progn (setcar lap0 (car tmp2))
- (setcdr lap0 (cdr tmp2))
- (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
- (car lap0) tmp2 lap0))
- ;; Get rid of the -else-pop's and jump one step further.
+ ((= tmp -1)
+ (byte-compile-log-lap
+ " %s discard\t-->\tdiscard discard" lap0)
+ (setcar lap0 'byte-discard)
+ (setcdr lap0 0))
+ ((error "Optimizer error: too much on the stack"))))
+ ;;
+ ;; goto*-X X: --> X:
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (eq (cdr lap0) lap1))
+ (cond ((eq (car lap0) 'byte-goto)
+ (setq lap (delq lap0 lap))
+ (setq tmp "<deleted>"))
+ ((memq (car lap0) byte-goto-always-pop-ops)
+ (setcar lap0 (setq tmp 'byte-discard))
+ (setcdr lap0 0))
+ ((error "Depth conflict at tag %d" (nth 2 lap0))))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
+ (nth 1 lap1) (nth 1 lap1)
+ tmp (nth 1 lap1)))
+ (setq keep-going t))
+ ;;
+ ;; varset-X varref-X --> dup varset-X
+ ;; varbind-X varref-X --> dup varbind-X
+ ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
+ ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
+ ;; The latter two can enable other optimizations.
+ ;;
+ ;; For lexical variables, we could do the same
+ ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
+ ;; but this is a very minor gain, since dup is stack-ref-0,
+ ;; i.e. it's only better if X>5, and even then it comes
+ ;; at the cost of an extra stack slot. Let's not bother.
+ ((and (eq 'byte-varref (car lap2))
+ (eq (cdr lap1) (cdr lap2))
+ (memq (car lap1) '(byte-varset byte-varbind)))
+ (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
+ (not (eq (car lap0) 'byte-constant)))
+ nil
+ (setq keep-going t)
+ (if (memq (car lap0) '(byte-constant byte-dup))
+ (progn
+ (setq tmp (if (or (not tmp)
+ (macroexp--const-symbol-p
+ (car (cdr lap0))))
+ (cdr lap0)
+ (byte-compile-get-constant t)))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
+ lap0 lap1 lap2 lap0 lap1
+ (cons (car lap0) tmp))
+ (setcar lap2 (car lap0))
+ (setcdr lap2 tmp))
+ (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
+ (setcar lap2 (car lap1))
+ (setcar lap1 'byte-dup)
+ (setcdr lap1 0)
+ ;; The stack depth gets locally increased, so we will
+ ;; increase maxdepth in case depth = maxdepth here.
+ ;; This can cause the third argument to byte-code to
+ ;; be larger than necessary.
+ (setq add-depth 1))))
+ ;;
+ ;; dup varset-X discard --> varset-X
+ ;; dup varbind-X discard --> varbind-X
+ ;; dup stack-set-X discard --> stack-set-X-1
+ ;; (the varbind variant can emerge from other optimizations)
+ ;;
+ ((and (eq 'byte-dup (car lap0))
+ (eq 'byte-discard (car lap2))
+ (memq (car lap1) '(byte-varset byte-varbind
+ byte-stack-set)))
+ (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
+ (setq keep-going t
+ rest (cdr rest))
+ (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
+ (setq lap (delq lap0 (delq lap2 lap))))
+ ;;
+ ;; not goto-X-if-nil --> goto-X-if-non-nil
+ ;; not goto-X-if-non-nil --> goto-X-if-nil
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (eq 'byte-not (car lap0))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
+ (byte-compile-log-lap " not %s\t-->\t%s"
+ lap1
+ (cons
+ (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil)
+ (cdr lap1)))
+ (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))
+ ;;
+ ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
+ ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (memq (car lap0)
+ '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
+ (eq 'byte-goto (car lap1)) ; gotoY
+ (eq (cdr lap0) lap2)) ; TAG X
+ (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
+ 'byte-goto-if-not-nil 'byte-goto-if-nil)))
+ (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
+ lap0 lap1 lap2
+ (cons inverse (cdr lap1)) lap2)
+ (setq lap (delq lap0 lap))
+ (setcar lap1 inverse)
+ (setq keep-going t)))
+ ;;
+ ;; const goto-if-* --> whatever
+ ;;
+ ((and (eq 'byte-constant (car lap0))
+ (memq (car lap1) byte-conditional-ops)
+ ;; If the `byte-constant's cdr is not a cons cell, it has
+ ;; to be an index into the constant pool); even though
+ ;; it'll be a constant, that constant is not known yet
+ ;; (it's typically a free variable of a closure, so will
+ ;; only be known when the closure will be built at
+ ;; run-time).
+ (consp (cdr lap0)))
+ (cond ((if (memq (car lap1) '(byte-goto-if-nil
+ byte-goto-if-nil-else-pop))
+ (car (cdr lap0))
+ (not (car (cdr lap0))))
+ (byte-compile-log-lap " %s %s\t-->\t<deleted>"
+ lap0 lap1)
+ (setq rest (cdr rest)
+ lap (delq lap0 (delq lap1 lap))))
+ (t
+ (byte-compile-log-lap " %s %s\t-->\t%s"
+ lap0 lap1
+ (cons 'byte-goto (cdr lap1)))
+ (when (memq (car lap1) byte-goto-always-pop-ops)
+ (setq lap (delq lap0 lap)))
+ (setcar lap1 'byte-goto)))
+ (setq keep-going t))
+ ;;
+ ;; varref-X varref-X --> varref-X dup
+ ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
+ ;; We don't optimize the const-X variations on this here,
+ ;; because that would inhibit some goto optimizations; we
+ ;; optimize the const-X case after all other optimizations.
+ ;;
+ ((and (memq (car lap0) '(byte-varref byte-stack-ref))
+ (progn
+ (setq tmp (cdr rest))
+ (setq tmp2 0)
+ (while (eq (car (car tmp)) 'byte-dup)
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
+ t)
+ (eq (if (eq 'byte-stack-ref (car lap0))
+ (+ tmp2 1 (cdr lap0))
+ (cdr lap0))
+ (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp))))
+ (if (memq byte-optimize-log '(t byte))
+ (let ((str ""))
+ (setq tmp2 (cdr rest))
+ (while (not (eq tmp tmp2))
+ (setq tmp2 (cdr tmp2)
+ str (concat str " dup")))
+ (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
+ lap0 str lap0 lap0 str)))
+ (setq keep-going t)
+ (setcar (car tmp) 'byte-dup)
+ (setcdr (car tmp) 0)
+ (setq rest tmp))
+ ;;
+ ;; TAG1: TAG2: --> TAG1: <deleted>
+ ;; (and other references to TAG2 are replaced with TAG1)
+ ;;
+ ((and (eq (car lap0) 'TAG)
+ (eq (car lap1) 'TAG))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " adjacent tags %d and %d merged"
+ (nth 1 lap1) (nth 1 lap0)))
+ (setq tmp3 lap)
+ (while (setq tmp2 (rassq lap0 tmp3))
+ (setcdr tmp2 lap1)
+ (setq tmp3 (cdr (memq tmp2 tmp3))))
+ (setq lap (delq lap0 lap)
+ keep-going t)
+ ;; replace references to tag in jump tables, if any
+ (dolist (table byte-compile-jump-tables)
+ (maphash #'(lambda (value tag)
+ (when (equal tag lap0)
+ (puthash value lap1 table)))
+ table)))
+ ;;
+ ;; unused-TAG: --> <deleted>
+ ;;
+ ((and (eq 'TAG (car lap0))
+ (not (rassq lap0 lap))
+ ;; make sure this tag isn't used in a jump-table
+ (cl-loop for table in byte-compile-jump-tables
+ when (member lap0 (hash-table-values table))
+ return nil finally return t))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
+ (setq lap (delq lap0 lap)
+ keep-going t))
+ ;;
+ ;; goto ... --> goto <delete until TAG or end>
+ ;; return ... --> return <delete until TAG or end>
+ ;; (unless a jump-table is being used, where deleting may affect
+ ;; other valid case bodies)
+ ;;
+ ((and (memq (car lap0) '(byte-goto byte-return))
+ (not (memq (car lap1) '(TAG nil)))
+ ;; FIXME: Instead of deferring simply when jump-tables are
+ ;; being used, keep a list of tags used for switch tags and
+ ;; use them instead (see `byte-compile-inline-lapcode').
+ (not byte-compile-jump-tables))
+ (setq tmp rest)
+ (let ((i 0)
+ (opt-p (memq byte-optimize-log '(t lap)))
+ str deleted)
+ (while (and (setq tmp (cdr tmp))
+ (not (eq 'TAG (car (car tmp)))))
+ (if opt-p (setq deleted (cons (car tmp) deleted)
+ str (concat str " %s")
+ i (1+ i))))
+ (if opt-p
+ (let ((tagstr
+ (if (eq 'TAG (car (car tmp)))
+ (format "%d:" (car (cdr (car tmp))))
+ (or (car tmp) ""))))
+ (if (< i 6)
+ (apply 'byte-compile-log-lap-1
+ (concat " %s" str
+ " %s\t-->\t%s <deleted> %s")
+ lap0
+ (nconc (nreverse deleted)
+ (list tagstr lap0 tagstr)))
+ (byte-compile-log-lap
+ " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
+ lap0 i (if (= i 1) "" "s")
+ tagstr lap0 tagstr))))
+ (rplacd rest tmp))
+ (setq keep-going t))
+ ;;
+ ;; <safe-op> unbind --> unbind <safe-op>
+ ;; (this may enable other optimizations.)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) byte-after-unbind-ops))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+ (setcar rest lap1)
+ (setcar (cdr rest) lap0)
+ (setq keep-going t))
+ ;;
+ ;; varbind-X unbind-N --> discard unbind-(N-1)
+ ;; save-excursion unbind-N --> unbind-(N-1)
+ ;; save-restriction unbind-N --> unbind-(N-1)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) '(byte-varbind byte-save-excursion
+ byte-save-restriction))
+ (< 0 (cdr lap1)))
+ (if (zerop (setcdr lap1 (1- (cdr lap1))))
+ (delq lap1 rest))
+ (if (eq (car lap0) 'byte-varbind)
+ (setcar rest (cons 'byte-discard 0))
+ (setq lap (delq lap0 lap)))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 (cons (car lap1) (1+ (cdr lap1)))
+ (if (eq (car lap0) 'byte-varbind)
+ (car rest)
+ (car (cdr rest)))
+ (if (and (/= 0 (cdr lap1))
+ (eq (car lap0) 'byte-varbind))
+ (car (cdr rest))
+ ""))
+ (setq keep-going t))
+ ;;
+ ;; goto*-X ... X: goto-Y --> goto*-Y
+ ;; goto-X ... X: return --> return
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
+ '(byte-goto byte-return)))
+ (cond ((and (not (eq tmp lap0))
+ (or (eq (car lap0) 'byte-goto)
+ (eq (car tmp) 'byte-goto)))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s"
+ (car lap0) tmp tmp)
+ (if (eq (car tmp) 'byte-return)
+ (setcar lap0 'byte-return))
+ (setcdr lap0 (cdr tmp))
+ (setq keep-going t))))
+ ;;
+ ;; goto-*-else-pop X ... X: goto-if-* --> whatever
+ ;; goto-*-else-pop X ... X: discard --> whatever
+ ;;
+ ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop))
+ (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap0 (car tmp))))
+ (setq tmp2 (car tmp))
+ (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
+ byte-goto-if-nil)
+ (byte-goto-if-not-nil-else-pop
+ byte-goto-if-not-nil))))
+ (if (memq (car tmp2) tmp3)
+ (progn (setcar lap0 (car tmp2))
+ (setcdr lap0 (cdr tmp2))
+ (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
+ (car lap0) tmp2 lap0))
+ ;; Get rid of the -else-pop's and jump one step further.
+ (or (eq 'TAG (car (nth 1 tmp)))
+ (setcdr tmp (cons (byte-compile-make-tag)
+ (cdr tmp))))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
+ (car lap0) tmp2 (nth 1 tmp3))
+ (setcar lap0 (nth 1 tmp3))
+ (setcdr lap0 (nth 1 tmp)))
+ (setq keep-going t))
+ ;;
+ ;; const goto-X ... X: goto-if-* --> whatever
+ ;; const goto-X ... X: discard --> whatever
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-goto)
+ (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap1 (car tmp))))
+ (setq tmp2 (car tmp))
+ (cond ((when (consp (cdr lap0))
+ (memq (car tmp2)
+ (if (null (car (cdr lap0)))
+ '(byte-goto-if-nil byte-goto-if-nil-else-pop)
+ '(byte-goto-if-not-nil
+ byte-goto-if-not-nil-else-pop))))
+ (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
+ lap0 tmp2 lap0 tmp2)
+ (setcar lap1 (car tmp2))
+ (setcdr lap1 (cdr tmp2))
+ ;; Let next step fix the (const,goto-if*) sequence.
+ (setq rest (cons nil rest))
+ (setq keep-going t))
+ ((or (consp (cdr lap0))
+ (eq (car tmp2) 'byte-discard))
+ ;; Jump one step further
+ (byte-compile-log-lap
+ " %s goto [%s]\t-->\t<deleted> goto <skip>"
+ lap0 tmp2)
(or (eq 'TAG (car (nth 1 tmp)))
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
- (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
- (car lap0) tmp2 (nth 1 tmp3))
- (setcar lap0 (nth 1 tmp3))
- (setcdr lap0 (nth 1 tmp)))
- (setq keep-going t))
- ;;
- ;; const goto-X ... X: goto-if-* --> whatever
- ;; const goto-X ... X: discard --> whatever
- ;;
- ((and (eq (car lap0) 'byte-constant)
- (eq (car lap1) 'byte-goto)
- (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap1 (car tmp))))
- (setq tmp2 (car tmp))
- (cond ((when (consp (cdr lap0))
- (memq (car tmp2)
- (if (null (car (cdr lap0)))
- '(byte-goto-if-nil byte-goto-if-nil-else-pop)
- '(byte-goto-if-not-nil
- byte-goto-if-not-nil-else-pop))))
- (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
- lap0 tmp2 lap0 tmp2)
- (setcar lap1 (car tmp2))
- (setcdr lap1 (cdr tmp2))
- ;; Let next step fix the (const,goto-if*) sequence.
- (setq rest (cons nil rest))
- (setq keep-going t))
- ((or (consp (cdr lap0))
- (eq (car tmp2) 'byte-discard))
- ;; Jump one step further
- (byte-compile-log-lap
- " %s goto [%s]\t-->\t<deleted> goto <skip>"
- lap0 tmp2)
- (or (eq 'TAG (car (nth 1 tmp)))
- (setcdr tmp (cons (byte-compile-make-tag)
- (cdr tmp))))
- (setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))
- (setq keep-going t))))
- ;;
- ;; X: varref-Y ... varset-Y goto-X -->
- ;; X: varref-Y Z: ... dup varset-Y goto-Z
- ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
- ;; (This is so usual for while loops that it is worth handling).
- ;;
- ;; Here again, we could do it for stack-ref/stack-set, but
- ;; that's replacing a stack-ref-Y with a stack-ref-0, which
- ;; is a very minor improvement (if any), at the cost of
- ;; more stack use and more byte-code. Let's not do it.
- ;;
- ((and (eq (car lap1) 'byte-varset)
- (eq (car lap2) 'byte-goto)
- (not (memq (cdr lap2) rest)) ;Backwards jump
- (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
- 'byte-varref)
- (eq (cdr (car tmp)) (cdr lap1))
- (not (memq (car (cdr lap1)) byte-boolean-vars)))
- ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
- (nth 1 (cdr lap2)) (car tmp)
- lap1 lap2
- (nth 1 (cdr lap2)) (car tmp)
- (nth 1 newtag) 'byte-dup lap1
- (cons 'byte-goto newtag)
- )
- (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
- (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
- (setq add-depth 1)
- (setq keep-going t))
- ;;
- ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
- ;; (This can pull the loop test to the end of the loop)
- ;;
- ((and (eq (car lap0) 'byte-goto)
- (eq (car lap1) 'TAG)
- (eq lap1
- (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
- (memq (car (car tmp))
- '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
- byte-goto-if-nil-else-pop)))
-;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
-;; lap0 lap1 (cdr lap0) (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- "%s %s: ... %s: %s\t-->\t%s ... %s:"
- lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
- (cons (cdr (assq (car (car tmp))
- '((byte-goto-if-nil . byte-goto-if-not-nil)
- (byte-goto-if-not-nil . byte-goto-if-nil)
- (byte-goto-if-nil-else-pop .
- byte-goto-if-not-nil-else-pop)
- (byte-goto-if-not-nil-else-pop .
- byte-goto-if-nil-else-pop))))
- newtag)
-
- (nth 1 newtag)
- )
- (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
- (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
- ;; We can handle this case but not the -if-not-nil case,
- ;; because we won't know which non-nil constant to push.
- (setcdr rest (cons (cons 'byte-constant
- (byte-compile-get-constant nil))
- (cdr rest))))
- (setcar lap0 (nth 1 (memq (car (car tmp))
- '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil
- byte-goto-if-nil
- byte-goto-if-not-nil
- byte-goto byte-goto))))
- )
- (setq keep-going t))
- )
+ (setcdr lap1 (car (cdr tmp)))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))))
+ ;;
+ ;; X: varref-Y ... varset-Y goto-X -->
+ ;; X: varref-Y Z: ... dup varset-Y goto-Z
+ ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
+ ;; (This is so usual for while loops that it is worth handling).
+ ;;
+ ;; Here again, we could do it for stack-ref/stack-set, but
+ ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+ ;; is a very minor improvement (if any), at the cost of
+ ;; more stack use and more byte-code. Let's not do it.
+ ;;
+ ((and (eq (car lap1) 'byte-varset)
+ (eq (car lap2) 'byte-goto)
+ (not (memq (cdr lap2) rest)) ;Backwards jump
+ (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
+ 'byte-varref)
+ (eq (cdr (car tmp)) (cdr lap1))
+ (not (memq (car (cdr lap1)) byte-boolean-vars)))
+ ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
+ (nth 1 (cdr lap2)) (car tmp)
+ lap1 lap2
+ (nth 1 (cdr lap2)) (car tmp)
+ (nth 1 newtag) 'byte-dup lap1
+ (cons 'byte-goto newtag)
+ )
+ (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
+ (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
+ (setq add-depth 1)
+ (setq keep-going t))
+ ;;
+ ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
+ ;; (This can pull the loop test to the end of the loop)
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (eq (car lap1) 'TAG)
+ (eq lap1
+ (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
+ (memq (car (car tmp))
+ '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
+ byte-goto-if-nil-else-pop)))
+ ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
+ ;; lap0 lap1 (cdr lap0) (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ "%s %s: ... %s: %s\t-->\t%s ... %s:"
+ lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
+ (cons (cdr (assq (car (car tmp))
+ '((byte-goto-if-nil . byte-goto-if-not-nil)
+ (byte-goto-if-not-nil . byte-goto-if-nil)
+ (byte-goto-if-nil-else-pop .
+ byte-goto-if-not-nil-else-pop)
+ (byte-goto-if-not-nil-else-pop .
+ byte-goto-if-nil-else-pop))))
+ newtag)
+
+ (nth 1 newtag)
+ )
+ (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
+ (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
+ ;; We can handle this case but not the -if-not-nil case,
+ ;; because we won't know which non-nil constant to push.
+ (setcdr rest (cons (cons 'byte-constant
+ (byte-compile-get-constant nil))
+ (cdr rest))))
+ (setcar lap0 (nth 1 (memq (car (car tmp))
+ '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil
+ byte-goto-if-nil
+ byte-goto-if-not-nil
+ byte-goto byte-goto))))
+ )
+ (setq keep-going t))
+
+ ;;
+ ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
+ ;; stack-set-M [discard/discardN ...] --> discardN
+ ;;
+ ((and (eq (car lap0) 'byte-stack-set)
+ (memq (car lap1) '(byte-discard byte-discardN))
+ (progn
+ ;; See if enough discard operations follow to expose or
+ ;; destroy the value stored by the stack-set.
+ (setq tmp (cdr rest))
+ (setq tmp2 (1- (cdr lap0)))
+ (setq tmp3 0)
+ (while (memq (car (car tmp)) '(byte-discard byte-discardN))
+ (setq tmp3
+ (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
+ 1
+ (cdr (car tmp)))))
+ (setq tmp (cdr tmp)))
+ (>= tmp3 tmp2)))
+ ;; Do the optimization.
+ (setq lap (delq lap0 lap))
+ (setcar lap1
+ (if (= tmp2 tmp3)
+ ;; The value stored is the new TOS, so pop one more
+ ;; value (to get rid of the old value) using the
+ ;; TOS-preserving discard operator.
+ 'byte-discardN-preserve-tos
+ ;; Otherwise, the value stored is lost, so just use a
+ ;; normal discard.
+ 'byte-discardN))
+ (setcdr lap1 (1+ tmp3))
+ (setcdr (cdr rest) tmp)
+ (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
+ lap0 lap1))
+
+ ;;
+ ;; discardN-preserve-tos return --> return
+ ;; dup return --> return
+ ;; stack-set-N return --> return ; where N is TOS-1
+ ;;
+ ((and (eq (car lap1) 'byte-return)
+ (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
+ (and (eq (car lap0) 'byte-stack-set)
+ (= (cdr lap0) 1))))
+ (setq keep-going t)
+ ;; The byte-code interpreter will pop the stack for us, so
+ ;; we can just leave stuff on it.
+ (setq lap (delq lap0 lap))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
+
+ ;;
+ ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y:
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (setq tmp (cdr (memq (cdr lap0) lap)))
+ (memq (caar tmp) '(byte-discard byte-discardN
+ byte-discardN-preserve-tos)))
+ (byte-compile-log-lap
+ " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
+ (car tmp) (car tmp))
+ (setq keep-going t)
+ (let* ((newtag (byte-compile-make-tag))
+ ;; Make a copy, since we sometimes modify insts in-place!
+ (newdiscard (cons (caar tmp) (cdar tmp)))
+ (newjmp (cons (car lap0) newtag)))
+ (push newtag (cdr tmp)) ;Push new tag after the discard.
+ (setcar rest newdiscard)
+ (push newjmp (cdr rest))))
+
+ ;;
+ ;; const discardN-preserve-tos ==> discardN const
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-discardN-preserve-tos))
+ (setq keep-going t)
+ (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
+ (byte-compile-log-lap
+ " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
+ (setf (car rest) newdiscard)
+ (setf (cadr rest) lap0)))
+ )
(setq rest (cdr rest)))
)
;; Cleanup stage:
@@ -2085,41 +2168,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
;;
- ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
- ;; stack-set-M [discard/discardN ...] --> discardN
- ;;
- ((and (eq (car lap0) 'byte-stack-set)
- (memq (car lap1) '(byte-discard byte-discardN))
- (progn
- ;; See if enough discard operations follow to expose or
- ;; destroy the value stored by the stack-set.
- (setq tmp (cdr rest))
- (setq tmp2 (1- (cdr lap0)))
- (setq tmp3 0)
- (while (memq (car (car tmp)) '(byte-discard byte-discardN))
- (setq tmp3
- (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
- 1
- (cdr (car tmp)))))
- (setq tmp (cdr tmp)))
- (>= tmp3 tmp2)))
- ;; Do the optimization.
- (setq lap (delq lap0 lap))
- (setcar lap1
- (if (= tmp2 tmp3)
- ;; The value stored is the new TOS, so pop one more
- ;; value (to get rid of the old value) using the
- ;; TOS-preserving discard operator.
- 'byte-discardN-preserve-tos
- ;; Otherwise, the value stored is lost, so just use a
- ;; normal discard.
- 'byte-discardN))
- (setcdr lap1 (1+ tmp3))
- (setcdr (cdr rest) tmp)
- (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
- lap0 lap1))
-
- ;;
;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
;; discardN-(X+Y)
;;
@@ -2146,20 +2194,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap0) (cdr lap1)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
-
- ;;
- ;; discardN-preserve-tos return --> return
- ;; dup return --> return
- ;; stack-set-N return --> return ; where N is TOS-1
- ;;
- ((and (eq (car lap1) 'byte-return)
- (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
- (and (eq (car lap0) 'byte-stack-set)
- (= (cdr lap0) 1))))
- ;; The byte-code interpreter will pop the stack for us, so
- ;; we can just leave stuff on it.
- (setq lap (delq lap0 lap))
- (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
)
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 0f8dd5a2842..88f362d24f0 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -232,8 +232,11 @@ The return value is undefined.
#'(lambda (x)
(let ((f (cdr (assq (car x) macro-declarations-alist))))
(if f (apply (car f) name arglist (cdr x))
- (message "Warning: Unknown macro property %S in %S"
- (car x) name))))
+ (macroexp--warn-and-return
+ (format-message
+ "Unknown macro property %S in %S"
+ (car x) name)
+ nil))))
decls)))
;; Refresh font-lock if this is a new macro, or it is an
;; existing macro whose 'no-font-lock-keyword declaration
@@ -301,9 +304,12 @@ The return value is undefined.
(cdr body)
body)))
nil)
- (t (message "Warning: Unknown defun property `%S' in %S"
- (car x) name)))))
- decls))
+ (t
+ (macroexp--warn-and-return
+ (format-message "Unknown defun property `%S' in %S"
+ (car x) name)
+ nil)))))
+ decls))
(def (list 'defalias
(list 'quote name)
(list 'function
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 360da6b6ba6..9429d6a0d5d 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2505,7 +2505,8 @@ list that represents a doc string reference.
(when (memq sym byte-compile-lexical-variables)
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
- (byte-compile-warn "Variable `%S' declared after its first use" sym))
+ (when (byte-compile-warning-enabled-p 'lexical sym)
+ (byte-compile-warn "Variable `%S' declared after its first use" sym)))
(push sym byte-compile-bound-variables)
(push sym byte-compile--seen-defvars))
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 2cd73225ff3..7d760ffc57f 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -67,9 +67,8 @@
(define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1")
(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.")
-(defvar chart-local-object nil
+(defvar-local chart-local-object nil
"Local variable containing the locally displayed chart object.")
-(make-variable-buffer-local 'chart-local-object)
(defvar chart-face-color-list '("red" "green" "blue"
"cyan" "yellow" "purple")
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 2e204ff7aea..9722792a5a5 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -241,7 +241,12 @@ system. Possible values are:
defun - Spell-check when style checking a single defun.
buffer - Spell-check when style checking the whole buffer.
interactive - Spell-check during any interactive check.
- t - Always spell-check."
+ t - Always spell-check.
+
+There is a list of Lisp-specific words which checkdoc will
+install into Ispell on the fly, but only if Ispell is not already
+running. Use `ispell-kill-ispell' to make checkdoc restart it
+with these words enabled."
:type '(choice (const nil)
(const defun)
(const buffer)
@@ -2357,7 +2362,9 @@ Code:, and others referenced in the style guide."
(checkdoc-create-error
(format "The footer should be: (provide '%s)\\n;;; %s%s ends here"
fn fn fe)
- (1- (point-max)) (point-max)))))
+ ;; The buffer may be empty.
+ (max (point-min) (1- (point-max)))
+ (point-max)))))
err))
;; The below checks will not return errors if the user says NO
diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index eb3193c8213..e106815817e 100644
--- a/lisp/emacs-lisp/crm.el
+++ b/lisp/emacs-lisp/crm.el
@@ -1,4 +1,4 @@
-;;; crm.el --- read multiple strings with completion
+;;; crm.el --- read multiple strings with completion -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1993-2021 Free Software Foundation, Inc.
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index 42528429aaf..54528b2fb91 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -1,4 +1,4 @@
-;;; derived.el --- allow inheritance of major modes
+;;; derived.el --- allow inheritance of major modes -*- lexical-binding: t; -*-
;; (formerly mode-clone.el)
;; Copyright (C) 1993-1994, 1999, 2001-2021 Free Software Foundation,
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index f4dbcee4d69..54c0cf08b78 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -278,11 +278,10 @@ For example, you could write
((not globalp)
`(progn
:autoload-end
- (defvar ,mode ,init-value
+ (defvar-local ,mode ,init-value
,(concat (format "Non-nil if %s is enabled.\n" pretty-name)
(internal--format-docstring-line
- "Use the command `%s' to change this variable." mode)))
- (make-variable-buffer-local ',mode)))
+ "Use the command `%s' to change this variable." mode)))))
(t
(let ((base-doc-string
(concat "Non-nil if %s is enabled.
@@ -453,8 +452,7 @@ on if the hook has explicitly disabled it.
(progn
(put ',global-mode 'globalized-minor-mode t)
:autoload-end
- (defvar ,MODE-major-mode nil)
- (make-variable-buffer-local ',MODE-major-mode))
+ (defvar-local ,MODE-major-mode nil))
;; The actual global minor-mode
(define-minor-mode ,global-mode
,(concat (format "Toggle %s in all buffers.\n" pretty-name)
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 1ded0e7b097..84191af88cc 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -2641,12 +2641,11 @@ See `edebug-behavior-alist' for implementations.")
;; window-start now stored with each function.
-;;(defvar edebug-window-start nil)
+;;(defvar-local edebug-window-start nil)
;; Remember where each buffers' window starts between edebug calls.
;; This is to avoid spurious recentering.
;; Does this still need to be buffer-local??
;;(setq-default edebug-window-start nil)
-;;(make-variable-buffer-local 'edebug-window-start)
;; Dynamically declared unbound vars
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index edf4d34b649..e65f424cbab 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -1,4 +1,4 @@
-;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
+;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software
;; Foundation, Inc.
diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el
index 93f780eac2f..294aba66c3a 100644
--- a/lisp/emacs-lisp/generic.el
+++ b/lisp/emacs-lisp/generic.el
@@ -1,4 +1,4 @@
-;;; generic.el --- defining simple major modes with comment and font-lock
+;;; generic.el --- defining simple major modes with comment and font-lock -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
;;
@@ -96,9 +96,8 @@
;; Internal Variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar generic-font-lock-keywords nil
+(defvar-local generic-font-lock-keywords nil
"Keywords for `font-lock-defaults' in a generic mode.")
-(make-variable-buffer-local 'generic-font-lock-keywords)
;;;###autoload
(defvar generic-mode-list nil
@@ -245,7 +244,6 @@ Some generic modes are defined in `generic-x.el'."
"Set up comment functionality for generic mode."
(let ((chars nil)
(comstyles)
- (comstyle "")
(comment-start nil))
;; Go through all the comments.
@@ -269,14 +267,16 @@ Some generic modes are defined in `generic-x.el'."
;; Store the relevant info but don't update yet.
(push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars)
(push (cons c1 (concat (cdr (assoc c1 chars))
- (concat "2" comstyle))) chars)))
+ (concat "2" comstyle)))
+ chars)))
(if (= (length end) 1)
(modify-syntax-entry (aref end 0)
(concat ">" comstyle) st)
(let ((c0 (aref end 0)) (c1 (aref end 1)))
;; Store the relevant info but don't update yet.
(push (cons c0 (concat (cdr (assoc c0 chars))
- (concat "3" comstyle))) chars)
+ (concat "3" comstyle)))
+ chars)
(push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars)))))
;; Process the chars that were part of a 2-char comment marker
diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el
index 737f3ec2f33..a5f21a55924 100644
--- a/lisp/emacs-lisp/helper.el
+++ b/lisp/emacs-lisp/helper.el
@@ -1,4 +1,4 @@
-;;; helper.el --- utility help package supporting help in electric modes
+;;; helper.el --- utility help package supporting help in electric modes -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -39,20 +39,19 @@
;; keymap either.
-(defvar Helper-help-map nil)
-(if Helper-help-map
- nil
- (setq Helper-help-map (make-keymap))
- ;(fillarray Helper-help-map 'undefined)
- (define-key Helper-help-map "m" 'Helper-describe-mode)
- (define-key Helper-help-map "b" 'Helper-describe-bindings)
- (define-key Helper-help-map "c" 'Helper-describe-key-briefly)
- (define-key Helper-help-map "k" 'Helper-describe-key)
- ;(define-key Helper-help-map "f" 'Helper-describe-function)
- ;(define-key Helper-help-map "v" 'Helper-describe-variable)
- (define-key Helper-help-map "?" 'Helper-help-options)
- (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options)
- (fset 'Helper-help-map Helper-help-map))
+(defvar Helper-help-map
+ (let ((map (make-sparse-keymap)))
+ ;(fillarray map 'undefined)
+ (define-key map "m" 'Helper-describe-mode)
+ (define-key map "b" 'Helper-describe-bindings)
+ (define-key map "c" 'Helper-describe-key-briefly)
+ (define-key map "k" 'Helper-describe-key)
+ ;(define-key map "f" 'Helper-describe-function)
+ ;(define-key map "v" 'Helper-describe-variable)
+ (define-key map "?" 'Helper-help-options)
+ (define-key map (char-to-string help-char) 'Helper-help-options)
+ (fset 'Helper-help-map map)
+ map))
(defun Helper-help-scroller ()
(let ((blurb (or (and (boundp 'Helper-return-blurb)
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 8780c5dcd30..c96d849d442 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -201,41 +201,53 @@
(defun lisp--el-non-funcall-position-p (pos)
"Heuristically determine whether POS is an evaluated position."
+ (declare (obsolete lisp--el-funcall-position-p "28.1"))
+ (not (lisp--el-funcall-position-p pos)))
+
+(defun lisp--el-funcall-position-p (pos)
+ "Heuristically determine whether POS is an evaluated position."
(save-match-data
(save-excursion
(ignore-errors
(goto-char pos)
;; '(lambda ..) is not a funcall position, but #'(lambda ...) is.
- (or (and (eql (char-before) ?\')
- (not (eql (char-before (1- (point))) ?#)))
- (let* ((ppss (syntax-ppss))
- (paren-posns (nth 9 ppss))
- (parent
- (when paren-posns
- (goto-char (car (last paren-posns))) ;(up-list -1)
- (cond
- ((ignore-errors
- (and (eql (char-after) ?\()
- (when (cdr paren-posns)
- (goto-char (car (last paren-posns 2)))
- (looking-at "(\\_<let\\*?\\_>"))))
- (goto-char (match-end 0))
- 'let)
- ((looking-at
- (rx "("
- (group-n 1 (+ (or (syntax w) (syntax _))))
- symbol-end))
- (prog1 (intern-soft (match-string-no-properties 1))
- (goto-char (match-end 1))))))))
- (or (eq parent 'declare)
- (and (eq parent 'let)
- (progn
- (forward-sexp 1)
- (< pos (point))))
- (and (eq parent 'condition-case)
- (progn
- (forward-sexp 2)
- (< (point) pos))))))))))
+ (if (eql (char-before) ?\')
+ (eql (char-before (1- (point))) ?#)
+ (let* ((ppss (syntax-ppss))
+ (paren-posns (nth 9 ppss))
+ (parent
+ (when paren-posns
+ (goto-char (car (last paren-posns))) ;(up-list -1)
+ (cond
+ ((ignore-errors
+ (and (eql (char-after) ?\()
+ (when (cdr paren-posns)
+ (goto-char (car (last paren-posns 2)))
+ (looking-at "(\\_<let\\*?\\_>"))))
+ (goto-char (match-end 0))
+ 'let)
+ ((looking-at
+ (rx "("
+ (group-n 1 (+ (or (syntax w) (syntax _))))
+ symbol-end))
+ (prog1 (intern-soft (match-string-no-properties 1))
+ (goto-char (match-end 1))))))))
+ (pcase parent
+ ('declare nil)
+ ('let
+ (forward-sexp 1)
+ (>= pos (point)))
+ ('condition-case
+ ;; If (cdr paren-posns), then we're in the BODY
+ ;; of HANDLERS.
+ (or (cdr paren-posns)
+ (progn
+ (forward-sexp 1)
+ ;; If we're in the second form, then we're in
+ ;; a funcall position.
+ (< (point) pos (progn (forward-sexp 1)
+ (point))))))
+ (_ t))))))))
(defun lisp--el-match-keyword (limit)
;; FIXME: Move to elisp-mode.el.
@@ -245,11 +257,9 @@
(concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>"))
limit t)
(let ((sym (intern-soft (match-string 1))))
- (when (or (special-form-p sym)
- (and (macrop sym)
- (not (get sym 'no-font-lock-keyword))
- (not (lisp--el-non-funcall-position-p
- (match-beginning 0)))))
+ (when (and (or (special-form-p sym) (macrop sym))
+ (not (get sym 'no-font-lock-keyword))
+ (lisp--el-funcall-position-p (match-beginning 0)))
(throw 'found t))))))
(defmacro let-when-compile (bindings &rest body)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 37844977f8f..e842222b7c3 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution."
(cond
((null msg) form)
((macroexp--compiling-p)
- (if (gethash form macroexp--warned)
+ (if (and (consp form) (gethash form macroexp--warned))
;; Already wrapped this exp with a warning: avoid inf-looping
;; where we keep adding the same warning onto `form' because
;; macroexpand-all gets right back to macroexpanding `form'.
@@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution."
,form)))
(t
(unless compile-only
- (message "%s%s" (if (stringp load-file-name)
- (concat (file-relative-name load-file-name) ": ")
- "")
+ (message "%sWarning: %s"
+ (if (stringp load-file-name)
+ (concat (file-relative-name load-file-name) ": ")
+ "")
msg))
form))))
@@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution."
(defun macroexp-macroexpand (form env)
"Like `macroexpand' but checking obsolescence."
- (let ((new-form
- (macroexpand form env)))
+ (let* ((macroexpand-all-environment env)
+ (new-form
+ (macroexpand form env)))
(if (and (not (eq form new-form)) ;It was a macro call.
(car-safe form)
(symbolp (car form))
@@ -239,9 +241,22 @@ Assumes the caller has bound `macroexpand-all-environment'."
form))
(`(,(and fun `(lambda . ,_)) . ,args)
;; Embedded lambda in function position.
- (macroexp--cons (macroexp--all-forms fun 2)
- (macroexp--all-forms args)
- form))
+ ;; If the byte-optimizer is loaded, try to unfold this,
+ ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer
+ ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
+ ;; creation of a closure, thus resulting in much better code.
+ (let ((newform (if (not (fboundp 'byte-compile-unfold-lambda))
+ 'macroexp--not-unfolded
+ ;; Don't unfold if byte-opt is not yet loaded.
+ (byte-compile-unfold-lambda form))))
+ (if (or (eq newform 'macroexp--not-unfolded)
+ (eq newform form))
+ ;; Unfolding failed for some reason, avoid infinite recursion.
+ (macroexp--cons (macroexp--all-forms fun 2)
+ (macroexp--all-forms args)
+ form)
+ (macroexp--expand-all newform))))
+
;; The following few cases are for normal function calls that
;; are known to funcall one of their arguments. The byte
;; compiler has traditionally handled these functions specially
@@ -255,17 +270,21 @@ Assumes the caller has bound `macroexpand-all-environment'."
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
- (macroexp--expand-all `(,fun ,f . ,args))))
+ (macroexp--expand-all `(,fun #',f . ,args))))
;; Second arg is a function:
(`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
- (macroexp--expand-all `(,fun ,arg1 ,f . ,args))))
- (`(funcall #',(and f (pred symbolp)) . ,args)
- ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
- ;; has a compiler-macro.
- (macroexp--expand-all `(,f . ,args)))
+ (macroexp--expand-all `(,fun ,arg1 #',f . ,args))))
+ (`(funcall ,exp . ,args)
+ (let ((eexp (macroexp--expand-all exp))
+ (eargs (macroexp--all-forms args)))
+ ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
+ ;; has a compiler-macro, or to unfold it.
+ (pcase eexp
+ (`#',f (macroexp--expand-all `(,f . ,eargs)))
+ (_ `(funcall ,eexp . ,eargs)))))
(`(,func . ,_)
;; Macro expand compiler macros. This cannot be delayed to
;; byte-optimize-form because the output of the compiler-macro can
@@ -358,12 +377,12 @@ Never returns an empty list."
(t
`(cond (,test ,@(macroexp-unprogn then))
(,(nth 1 else) ,@(macroexp-unprogn (nth 2 else)))
- (t ,@(nthcdr 3 else))))))
+ ,@(let ((def (nthcdr 3 else))) (if def `((t ,@def))))))))
((eq (car-safe else) 'cond)
`(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else)))
;; Invert the test if that lets us reduce the depth of the tree.
((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
- (t `(if ,test ,then ,@(macroexp-unprogn else)))))
+ (t `(if ,test ,then ,@(if else (macroexp-unprogn else))))))
(defmacro macroexp-let2 (test sym exp &rest body)
"Evaluate BODY with SYM bound to an expression for EXP's value.
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
index 8a0853ce445..b723643ffb9 100644
--- a/lisp/emacs-lisp/package-x.el
+++ b/lisp/emacs-lisp/package-x.el
@@ -1,4 +1,4 @@
-;;; package-x.el --- Package extras
+;;; package-x.el --- Package extras -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index ffde396e94a..ccd52aa7b33 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -3261,9 +3261,9 @@ To unhide a package, type
`\\[customize-variable] RET package-hidden-regexps'.
Type \\[package-menu-toggle-hiding] to toggle package hiding."
+ (declare (interactive-only "change `package-hidden-regexps' instead."))
(interactive)
(package--ensure-package-menu-mode)
- (declare (interactive-only "change `package-hidden-regexps' instead."))
(let* ((name (when (derived-mode-p 'package-menu-mode)
(concat "\\`" (regexp-quote (symbol-name (package-desc-name
(tabulated-list-get-id))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index bfd577c5d14..cf129c453ec 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -683,11 +683,6 @@ A and B can be one of:
;; and catch at least the easy cases such as (bug#14773).
(not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
'(:pcase--succeed . :pcase--fail))
- ;; In case UPAT is of the form (pred (not PRED))
- ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
- (let* ((test (cadr (cadr upat)))
- (res (pcase--split-pred vars `(pred ,test) pat)))
- (cons (cdr res) (car res))))
;; In case PAT is of the form (pred (not PRED))
((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
(let* ((test (cadr (cadr pat)))
@@ -696,19 +691,34 @@ A and B can be one of:
((eq x :pcase--fail) :pcase--succeed)))))
(cons (funcall reverse (car res))
(funcall reverse (cdr res)))))
- ((and (eq 'pred (car upat))
- (let ((otherpred
- (cond ((eq 'pred (car-safe pat)) (cadr pat))
- ((not (eq 'quote (car-safe pat))) nil)
- ((consp (cadr pat)) #'consp)
- ((stringp (cadr pat)) #'stringp)
- ((vectorp (cadr pat)) #'vectorp)
- ((byte-code-function-p (cadr pat))
- #'byte-code-function-p))))
- (pcase--mutually-exclusive-p (cadr upat) otherpred)))
+ ;; All the rest below presumes UPAT is of the form (pred ...).
+ ((not (eq 'pred (car upat))) nil)
+ ;; In case UPAT is of the form (pred (not PRED))
+ ((eq 'not (car-safe (cadr upat)))
+ (let* ((test (cadr (cadr upat)))
+ (res (pcase--split-pred vars `(pred ,test) pat)))
+ (cons (cdr res) (car res))))
+ ((let ((otherpred
+ (cond ((eq 'pred (car-safe pat)) (cadr pat))
+ ((not (eq 'quote (car-safe pat))) nil)
+ ((consp (cadr pat)) #'consp)
+ ((stringp (cadr pat)) #'stringp)
+ ((vectorp (cadr pat)) #'vectorp)
+ ((byte-code-function-p (cadr pat))
+ #'byte-code-function-p))))
+ (pcase--mutually-exclusive-p (cadr upat) otherpred))
'(:pcase--fail . nil))
- ((and (eq 'pred (car upat))
- (eq 'quote (car-safe pat))
+ ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
+ ;; try and preserve the info we get from that memq test.
+ ((and (eq 'pcase--flip (car-safe (cadr upat)))
+ (memq (cadr (cadr upat)) '(memq member memql))
+ (eq 'quote (car-safe (nth 2 (cadr upat))))
+ (eq 'quote (car-safe pat)))
+ (let ((set (cadr (nth 2 (cadr upat)))))
+ (if (member (cadr pat) set)
+ '(nil . :pcase--fail)
+ '(:pcase--fail . nil))))
+ ((and (eq 'quote (car-safe pat))
(symbolp (cadr upat))
(or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
(get (cadr upat) 'side-effect-free)
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index 23221a2a00d..ce8d98df807 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -187,14 +187,14 @@ Set it to nil if you don't want limits here."
(defvar reb-target-window nil
"Window to which the RE is applied to.")
-(defvar reb-regexp nil
+(defvar-local reb-regexp nil
"Last regexp used by RE Builder.")
-(defvar reb-regexp-src nil
+(defvar-local reb-regexp-src nil
"Last regexp used by RE Builder before processing it.
Except for Lisp syntax this is the same as `reb-regexp'.")
-(defvar reb-overlays nil
+(defvar-local reb-overlays nil
"List of overlays of the RE Builder.")
(defvar reb-window-config nil
@@ -212,10 +212,6 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(defvar reb-valid-string ""
"String in mode line showing validity of RE.")
-(make-variable-buffer-local 'reb-overlays)
-(make-variable-buffer-local 'reb-regexp)
-(make-variable-buffer-local 'reb-regexp-src)
-
(defconst reb-buffer "*RE-Builder*"
"Buffer to use for the RE Builder.")
diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el
index 38b202fa101..527af1ddf24 100644
--- a/lisp/emacs-lisp/regi.el
+++ b/lisp/emacs-lisp/regi.el
@@ -1,4 +1,4 @@
-;;; regi.el --- REGular expression Interpreting engine
+;;; regi.el --- REGular expression Interpreting engine -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
@@ -153,7 +153,7 @@ useful information:
;; set up the narrowed region
(and start
end
- (let* ((tstart start)
+ (let* (;; (tstart start)
(start (min start end))
(end (max start end)))
(narrow-to-region
@@ -206,30 +206,33 @@ useful information:
;; if the line matched, package up the argument list and
;; funcall the FUNC
(if match-p
- (let* ((curline (buffer-substring
- (regi-pos 'bol)
- (regi-pos 'eol)))
- (curframe current-frame)
- (curentry entry)
- (result (eval func))
- (step (or (cdr (assq 'step result)) 1))
- )
- ;; changing frame on the fly?
- (if (assq 'frame result)
- (setq working-frame (cdr (assq 'frame result))))
-
- ;; continue processing current frame?
- (if (memq 'continue result)
- (setq current-frame (cdr current-frame))
- (forward-line step)
- (setq current-frame working-frame))
-
- ;; abort current frame?
- (if (memq 'abort result)
- (progn
- (setq donep t)
- (throw 'regi-throw-top t)))
- ) ; end-let
+ (with-suppressed-warnings
+ ((lexical curframe curentry curline))
+ (defvar curframe) (defvar curentry) (defvar curline)
+ (let* ((curline (buffer-substring
+ (regi-pos 'bol)
+ (regi-pos 'eol)))
+ (curframe current-frame)
+ (curentry entry)
+ (result (eval func))
+ (step (or (cdr (assq 'step result)) 1))
+ )
+ ;; changing frame on the fly?
+ (if (assq 'frame result)
+ (setq working-frame (cdr (assq 'frame result))))
+
+ ;; continue processing current frame?
+ (if (memq 'continue result)
+ (setq current-frame (cdr current-frame))
+ (forward-line step)
+ (setq current-frame working-frame))
+
+ ;; abort current frame?
+ (if (memq 'abort result)
+ (progn
+ (setq donep t)
+ (throw 'regi-throw-top t)))
+ )) ; end-let
;; else if no match occurred, then process the next
;; frame-entry on the current line
diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el
index 168e5e46f37..c1d05941239 100644
--- a/lisp/emacs-lisp/shadow.el
+++ b/lisp/emacs-lisp/shadow.el
@@ -1,4 +1,4 @@
-;;; shadow.el --- locate Emacs Lisp file shadowings
+;;; shadow.el --- locate Emacs Lisp file shadowings -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -58,8 +58,7 @@
(defcustom load-path-shadows-compare-text nil
"If non-nil, then shadowing files are reported only if their text differs.
This is slower, but filters out some innocuous shadowing."
- :type 'boolean
- :group 'lisp-shadow)
+ :type 'boolean)
(defun load-path-shadows-find (&optional path)
"Return a list of Emacs Lisp files that create shadows.
@@ -78,8 +77,7 @@ See the documentation for `list-load-path-shadows' for further information."
dir-case-insensitive ; `file-name-case-insensitive-p' of dir.
curr-files ; This dir's Emacs Lisp files.
orig-dir ; Where the file was first seen.
- files-seen-this-dir ; Files seen so far in this dir.
- file) ; The current file.
+ files-seen-this-dir) ; Files seen so far in this dir.
(dolist (pp (or path load-path))
(setq dir (directory-file-name (file-truename (or pp "."))))
(if (member dir true-names)
@@ -109,7 +107,7 @@ See the documentation for `list-load-path-shadows' for further information."
(dolist (file curr-files)
- (if (string-match "\\.gz$" file)
+ (if (string-match "\\.gz\\'" file)
(setq file (substring file 0 -3)))
(setq file (substring
file 0 (if (string= (substring file -1) "c") -4 -3)))
@@ -125,9 +123,13 @@ See the documentation for `list-load-path-shadows' for further information."
;; XXX.elc (or vice-versa) when they are in the same directory.
(setq files-seen-this-dir (cons file files-seen-this-dir))
- (if (setq orig-dir (assoc file files
- (when dir-case-insensitive
- (lambda (f1 f2) (eq (compare-strings f1 nil nil f2 nil nil t) t)))))
+ (if (setq orig-dir
+ (assoc file files
+ (when dir-case-insensitive
+ (lambda (f1 f2)
+ (eq (compare-strings f1 nil nil
+ f2 nil nil t)
+ t)))))
;; This file was seen before, we have a shadowing.
;; Report it unless the files are identical.
(let ((base1 (concat (cdr orig-dir) "/" (car orig-dir)))
@@ -142,7 +144,7 @@ See the documentation for `list-load-path-shadows' for further information."
(append shadows (list base1 base2)))))
;; Not seen before, add it to the list of seen files.
- (setq files (cons (cons file dir) files)))))))
+ (push (cons file dir) files))))))
;; Return the list of shadowings.
shadows))
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index b90227da42f..a4514454c0b 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -389,6 +389,28 @@ it makes no sense to convert it to a string using
(set-buffer source-buffer)
(replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
+(defmacro named-let (name bindings &rest body)
+ "Looping construct taken from Scheme.
+Like `let', bind variables in BINDINGS and then evaluate BODY,
+but with the twist that BODY can evaluate itself recursively by
+calling NAME, where the arguments passed to NAME are used
+as the new values of the bound variables in the recursive invocation."
+ (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
+ (require 'cl-lib)
+ (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))
+ (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)))
+ ;; According to the Scheme semantics of named let, `name' is not in scope
+ ;; while evaluating the expressions in `bindings', and for this reason, the
+ ;; "initial" function call below needs to be outside of the `cl-labels'.
+ ;; When the "self-tco" eliminates all recursive calls, the `cl-labels'
+ ;; expands to a lambda which the byte-compiler then combines with the
+ ;; funcall to make a `let' so we end up with a plain `while' loop and no
+ ;; remaining `lambda' at all.
+ `(funcall
+ (cl-labels ((,name ,fargs . ,body)) #',name)
+ . ,aargs)))
+
+
(provide 'subr-x)
;;; subr-x.el ends here
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index 62f213c57f7..bee2f9639e7 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -75,7 +75,7 @@ properties won't work properly.")
(defvar syntax-propertize-chunk-size 500)
-(defvar syntax-propertize-extend-region-functions
+(defvar-local syntax-propertize-extend-region-functions
'(syntax-propertize-wholelines)
"Special hook run just before proceeding to propertize a region.
This is used to allow major modes to help `syntax-propertize' find safe buffer
@@ -89,7 +89,6 @@ These functions are run in turn repeatedly until they all return nil.
Put first the functions more likely to cause a change and cheaper to compute.")
;; Mark it as a special hook which doesn't use any global setting
;; (i.e. doesn't obey the element t in the buffer-local value).
-(make-variable-buffer-local 'syntax-propertize-extend-region-functions)
(cl-defstruct (ppss
(:constructor make-ppss)
diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el
index 7de9d547ce4..fb9cd8f47df 100644
--- a/lisp/emacs-lisp/tcover-ses.el
+++ b/lisp/emacs-lisp/tcover-ses.el
@@ -1,4 +1,4 @@
-;;;; testcover-ses.el -- Example use of `testcover' to test "SES"
+;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -19,21 +19,14 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-(require 'testcover)
+;;; Commentary:
-(defvar ses-initial-global-parameters)
-(defvar ses-mode-map)
+;; FIXME: Convert to ERT and move to `test/'?
-(declare-function ses-set-curcell "ses")
-(declare-function ses-update-cells "ses")
-(declare-function ses-load "ses")
-(declare-function ses-vector-delete "ses")
-(declare-function ses-create-header-string "ses")
-(declare-function ses-read-cell "ses")
-(declare-function ses-read-symbol "ses")
-(declare-function ses-command-hook "ses")
-(declare-function ses-jump "ses")
+;;; Code:
+(require 'testcover)
+(require 'ses)
;;;Here are some macros that exercise SES. Set `pause' to t if you want the
;;;macros to pause after each step.
@@ -652,6 +645,7 @@ spreadsheet files with invalid formatting."
(testcover-start "ses.el" t))
(require 'unsafep)) ;In case user has safe-functions = t!
+(defvar ses--curcell-overlay)
;;;#########################################################################
(defun ses-exercise ()
@@ -674,8 +668,8 @@ spreadsheet files with invalid formatting."
(ses-load))
;;ses-vector-delete is always called from buffer-undo-list with the same
;;symbol as argument. We'll give it a different one here.
- (let ((x [1 2 3]))
- (ses-vector-delete 'x 0 0))
+ (dlet ((tcover-ses--x [1 2 3]))
+ (ses-vector-delete 'tcover-ses--x 0 0))
;;ses-create-header-string behaves differently in a non-window environment
;;but we always test under windows.
(let ((window-system (not window-system)))
@@ -704,7 +698,7 @@ spreadsheet files with invalid formatting."
(ses-mode)))))
;;Test error-handling in command hook, outside a macro.
;;This will ring the bell.
- (let (curcell-overlay)
+ (let (ses--curcell-overlay)
(ses-command-hook))
;;Due to use of run-with-timer, ses-command-hook sometimes gets called
;;after we switch to another buffer.
@@ -720,4 +714,4 @@ spreadsheet files with invalid formatting."
;;Could do this here: (testcover-end "ses.el")
(message "Done"))
-;; testcover-ses.el ends here.
+;;; testcover-ses.el ends here.
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
index f46d9c77eae..d52a6c796db 100644
--- a/lisp/emacs-lisp/unsafep.el
+++ b/lisp/emacs-lisp/unsafep.el
@@ -1,4 +1,4 @@
-;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate
+;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -129,15 +129,16 @@ in the parse.")
(put x 'safe-function t))
;;;###autoload
-(defun unsafep (form &optional unsafep-vars)
+(defun unsafep (form &optional vars)
"Return nil if evaluating FORM couldn't possibly do any harm.
Otherwise result is a reason why FORM is unsafe.
-UNSAFEP-VARS is a list of symbols with local bindings."
+VARS is a list of symbols with local bindings like `unsafep-vars'."
(catch 'unsafep
(if (or (eq safe-functions t) ;User turned off safety-checking
(atom form)) ;Atoms are never unsafe
(throw 'unsafep nil))
- (let* ((fun (car form))
+ (let* ((unsafep-vars vars)
+ (fun (car form))
(reason (unsafep-function fun))
arg)
(cond
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-03 06:45:14 +0000