procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Andrea Corallo 2021-02-17 22:26:28 +01:00
commit f92bb788a0
255 changed files with 4837 additions and 3941 deletions
Download patch file Download diff file Expand all files Collapse all files

15
lisp/emacs-lisp/autoload.el
View file

@ -141,9 +141,12 @@ expression, in which case we want to handle forms differently."
((stringp (car-safe rest)) (car rest))))
;; Look for an interactive spec.
(interactive (pcase body
((or `((interactive . ,_) . ,_)
`(,_ (interactive . ,_) . ,_))
t))))
((or `((interactive . ,iargs) . ,_)
`(,_ (interactive . ,iargs) . ,_))
;; List of modes or just t.
(if (nthcdr 1 iargs)
(list 'quote (nthcdr 1 iargs))
t)))))
;; Add the usage form at the end where describe-function-1
;; can recover it.
(when (consp args) (setq doc (help-add-fundoc-usage doc args)))
@ -209,7 +212,11 @@ expression, in which case we want to handle forms differently."
easy-mmode-define-minor-mode
define-minor-mode))
t)
(eq (car-safe (car body)) 'interactive))
(and (eq (car-safe (car body)) 'interactive)
;; List of modes or just t.
(or (if (nthcdr 1 (car body))
(list 'quote (nthcdr 1 (car body)))
t))))
,(if macrop ''macro nil))))
;; For defclass forms, use `eieio-defclass-autoload'.

8
lisp/emacs-lisp/backtrace.el
View file

@ -190,7 +190,7 @@ This is commonly used to recompute `backtrace-frames'.")
(defvar-local backtrace-print-function #'cl-prin1
"Function used to print values in the current Backtrace buffer.")
(defvar-local backtrace-goto-source-functions nil
(defvar backtrace-goto-source-functions nil
"Abnormal hook used to jump to the source code for the current frame.
Each hook function is called with no argument, and should return
non-nil if it is able to switch to the buffer containing the
@ -638,10 +638,8 @@ content of the sexp."
(source-available (plist-get (backtrace-frame-flags frame)
:source-available)))
(unless (and source-available
(catch 'done
(dolist (func backtrace-goto-source-functions)
(when (funcall func)
(throw 'done t)))))
(run-hook-with-args-until-success
'backtrace-goto-source-functions))
(user-error "Source code location not known"))))
(defun backtrace-help-follow-symbol (&optional pos)

314
lisp/emacs-lisp/bindat.el
View file

@ -26,7 +26,7 @@
;; Packing and unpacking of (binary) data structures.
;;
;; The data formats used in binary files and network protocols are
;; often structed data which can be described by a C-style structure
;; often structured data which can be described by a C-style structure
;; such as the one shown below. Using the bindat package, decoding
;; and encoding binary data formats like these is made simple using a
;; structure specification which closely resembles the C style
@ -65,13 +65,15 @@
;; The corresponding Lisp bindat specification looks like this:
;;
;; (setq header-bindat-spec
;; '((dest-ip ip)
;; (bindat-spec
;; (dest-ip ip)
;; (src-ip ip)
;; (dest-port u16)
;; (src-port u16)))
;;
;; (setq data-bindat-spec
;; '((type u8)
;; (bindat-spec
;; (type u8)
;; (opcode u8)
;; (length u16r) ;; little endian order
;; (id strz 8)
@ -79,7 +81,8 @@
;; (align 4)))
;;
;; (setq packet-bindat-spec
;; '((header struct header-bindat-spec)
;; (bindat-spec
;; (header struct header-bindat-spec)
;; (items u8)
;; (fill 3)
;; (item repeat (items)
@ -126,28 +129,30 @@
;; SPEC ::= ( ITEM... )
;; ITEM ::= ( [FIELD] TYPE )
;; ITEM ::= ( FIELD TYPE )
;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only
;; | ( [FIELD] fill LEN ) -- skip LEN bytes
;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes
;; | ( [FIELD] struct SPEC_NAME )
;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] )
;; | ( [FIELD] repeat COUNT ITEM... )
;; | ( FIELD repeat ARG ITEM... )
;; -- In (eval EXPR), the value of the last field is available in
;; the dynamically bound variable `last'.
;; the dynamically bound variable `last' and all the previous
;; ones in the variable `struct'.
;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE
;; | u8 | byte -- length 1
;; | u16 | word | short -- length 2, network byte order
;; | u24 -- 3-byte value
;; | u32 | dword | long -- length 4, network byte order
;; | u16r | u24r | u32r -- little endian byte order.
;; | u64 -- length 8, network byte order
;; | u16r | u24r | u32r | u64r - little endian byte order.
;; | str LEN -- LEN byte string
;; | strz LEN -- LEN byte (zero-terminated) string
;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8)
;; | ip -- 4 byte vector
;; | bits LEN -- List with bits set in LEN bytes.
;; | bits LEN -- bit vector using LEN bytes.
;;
;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13)
;; and 0x1c 0x28 to (3 5 10 11 12).
@ -178,7 +183,7 @@
;; is interpreted by evalling TAG_VAL and then comparing that to
;; each TAG using equal; if a match is found, the corresponding SPEC
;; is used.
;; If TAG is a form (eval EXPR), EXPR is evalled with `tag' bound to the
;; If TAG is a form (eval EXPR), EXPR is eval'ed with `tag' bound to the
;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil.
;; Finally, if TAG is t, the corresponding SPEC is used unconditionally.
;;
@ -191,7 +196,7 @@
;;; Code:
;; Helper functions for structure unpacking.
;; Relies on dynamic binding of BINDAT-RAW and BINDAT-IDX
;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'.
(defvar bindat-raw)
(defvar bindat-idx)
@ -210,6 +215,9 @@
(defun bindat--unpack-u32 ()
(logior (ash (bindat--unpack-u16) 16) (bindat--unpack-u16)))
(defun bindat--unpack-u64 ()
(logior (ash (bindat--unpack-u32) 32) (bindat--unpack-u32)))
(defun bindat--unpack-u16r ()
(logior (bindat--unpack-u8) (ash (bindat--unpack-u8) 8)))
@ -219,25 +227,26 @@
(defun bindat--unpack-u32r ()
(logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16)))
(defun bindat--unpack-u64r ()
(logior (bindat--unpack-u32r) (ash (bindat--unpack-u32r) 32)))
(defun bindat--unpack-item (type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
(cond
((memq type '(u8 byte))
(pcase type
((or 'u8 'byte)
(bindat--unpack-u8))
((memq type '(u16 word short))
((or 'u16 'word 'short)
(bindat--unpack-u16))
((eq type 'u24)
(bindat--unpack-u24))
((memq type '(u32 dword long))
('u24 (bindat--unpack-u24))
((or 'u32 'dword 'long)
(bindat--unpack-u32))
((eq type 'u16r)
(bindat--unpack-u16r))
((eq type 'u24r)
(bindat--unpack-u24r))
((eq type 'u32r)
(bindat--unpack-u32r))
((eq type 'bits)
('u64 (bindat--unpack-u64))
('u16r (bindat--unpack-u16r))
('u24r (bindat--unpack-u24r))
('u32r (bindat--unpack-u32r))
('u64r (bindat--unpack-u64r))
('bits
(let ((bits nil) (bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(if (= (setq m (bindat--unpack-u8)) 0)
@ -249,12 +258,12 @@
(setq bnum (1- bnum)
j (ash j -1)))))
bits))
((eq type 'str)
('str
(let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(apply #'unibyte-string s))))
((eq type 'strz)
('strz
(let ((i 0) s)
(while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0))
(setq i (1+ i)))
@ -262,34 +271,29 @@
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(apply #'unibyte-string s))))
((eq type 'vec)
(let ((v (make-vector len 0)) (i 0) (vlen 1))
('vec
(let ((v (make-vector len 0)) (vlen 1))
(if (consp vectype)
(setq vlen (nth 1 vectype)
vectype (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))
(while (< i len)
(aset v i (bindat--unpack-item type vlen vectype))
(setq i (1+ i)))
(dotimes (i len)
(aset v i (bindat--unpack-item type vlen vectype)))
v))
(t nil)))
(_ nil)))
(defun bindat--unpack-group (spec)
(with-suppressed-warnings ((lexical last))
(defvar last))
(with-suppressed-warnings ((lexical struct last))
(defvar struct) (defvar last))
(let (struct last)
(while spec
(let* ((item (car spec))
(field (car item))
(dolist (item spec)
(let* ((field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3)
data)
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
@ -299,29 +303,29 @@
len type
type field
field nil))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)) t)))
(if (and (consp len) (not (eq type 'eval)))
(setq len (apply #'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(cond
((eq type 'eval)
(pcase type
('eval
(if field
(setq data (eval len t))
(eval len t)))
((eq type 'fill)
('fill
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
('align
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
('struct
(setq data (bindat--unpack-group (eval len t))))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
(push (bindat--unpack-group (nthcdr tail item)) data)
(setq index (1+ index)))
(setq data (nreverse data))))
((eq type 'union)
('repeat
(dotimes (_ len)
(push (bindat--unpack-group (nthcdr tail item)) data))
(setq data (nreverse data)))
('union
(with-suppressed-warnings ((lexical tag))
(defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
@ -333,7 +337,8 @@
(and (consp cc) (eval cc t)))
(setq data (bindat--unpack-group (cdr case))
cases nil)))))
(t
((pred integerp) (debug t))
(_
(setq data (bindat--unpack-item type len vectype)
last data)))
(if data
@ -367,30 +372,26 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq field (cdr field)))
struct)
;; Calculate bindat-raw length of structured data
;;;; Calculate bindat-raw length of structured data
(defvar bindat--fixed-length-alist
'((u8 . 1) (byte . 1)
(u16 . 2) (u16r . 2) (word . 2) (short . 2)
(u24 . 3) (u24r . 3)
(u32 . 4) (u32r . 4) (dword . 4) (long . 4)
(u64 . 8) (u64r . 8)
(ip . 4)))
(defun bindat--length-group (struct spec)
(with-suppressed-warnings ((lexical last))
(defvar last))
(let (last)
(while spec
(let* ((item (car spec))
(field (car item))
(with-suppressed-warnings ((lexical struct last))
(defvar struct) (defvar last))
(let ((struct struct) last)
(dolist (item spec)
(let* ((field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
@ -400,6 +401,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
len type
type field
field nil))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)) t)))
(if (and (consp len) (not (eq type 'eval)))
(setq len (apply #'bindat-get-field struct len)))
(if (not len)
@ -410,27 +413,25 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
type (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil)))
(cond
((eq type 'eval)
(pcase type
('eval
(if field
(setq struct (cons (cons field (eval len t)) struct))
(eval len t)))
((eq type 'fill)
('fill
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
('align
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
('struct
(bindat--length-group
(if field (bindat-get-field struct field) struct) (eval len t)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
(bindat--length-group
(nth index (bindat-get-field struct field))
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
('repeat
(dotimes (index len)
(bindat--length-group
(nth index (bindat-get-field struct field))
(nthcdr tail item))))
('union
(with-suppressed-warnings ((lexical tag))
(defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
@ -443,7 +444,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(progn
(bindat--length-group struct (cdr case))
(setq cases nil))))))
(t
(_
(if (setq type (assq type bindat--fixed-length-alist))
(setq len (* len (cdr type))))
(if field
@ -451,13 +452,13 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (+ bindat-idx len))))))))
(defun bindat-length (spec struct)
"Calculate bindat-raw length for STRUCT according to bindat SPEC."
"Calculate `bindat-raw' length for STRUCT according to bindat SPEC."
(let ((bindat-idx 0))
(bindat--length-group struct spec)
bindat-idx))
;; Pack structured data into bindat-raw
;;;; Pack structured data into bindat-raw
(defun bindat--pack-u8 (v)
(aset bindat-raw bindat-idx (logand v 255))
@ -476,6 +477,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(bindat--pack-u16 (ash v -16))
(bindat--pack-u16 v))
(defun bindat--pack-u64 (v)
(bindat--pack-u32 (ash v -32))
(bindat--pack-u32 v))
(defun bindat--pack-u16r (v)
(aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255))
(aset bindat-raw bindat-idx (logand v 255))
@ -489,27 +494,30 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(bindat--pack-u16r v)
(bindat--pack-u16r (ash v -16)))
(defun bindat--pack-u64r (v)
(bindat--pack-u32r v)
(bindat--pack-u32r (ash v -32)))
(defun bindat--pack-item (v type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
(cond
((null v)
(pcase type
((guard (null v))
(setq bindat-idx (+ bindat-idx len)))
((memq type '(u8 byte))
((or 'u8 'byte)
(bindat--pack-u8 v))
((memq type '(u16 word short))
((or 'u16 'word 'short)
(bindat--pack-u16 v))
((eq type 'u24)
('u24
(bindat--pack-u24 v))
((memq type '(u32 dword long))
((or 'u32 'dword 'long)
(bindat--pack-u32 v))
((eq type 'u16r)
(bindat--pack-u16r v))
((eq type 'u24r)
(bindat--pack-u24r v))
((eq type 'u32r)
(bindat--pack-u32r v))
((eq type 'bits)
('u64 (bindat--pack-u64 v))
('u16r (bindat--pack-u16r v))
('u24r (bindat--pack-u24r v))
('u32r (bindat--pack-u32r v))
('u64r (bindat--pack-u64r v))
('bits
(let ((bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(setq m 0)
@ -522,41 +530,33 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bnum (1- bnum)
j (ash j -1))))
(bindat--pack-u8 m))))
((memq type '(str strz))
(let ((l (length v)) (i 0))
(if (> l len) (setq l len))
(while (< i l)
(aset bindat-raw (+ bindat-idx i) (aref v i))
(setq i (1+ i)))
(setq bindat-idx (+ bindat-idx len))))
((eq type 'vec)
(let ((l (length v)) (i 0) (vlen 1))
((or 'str 'strz)
(dotimes (i (min len (length v)))
(aset bindat-raw (+ bindat-idx i) (aref v i)))
(setq bindat-idx (+ bindat-idx len)))
('vec
(let ((l (length v)) (vlen 1))
(if (consp vectype)
(setq vlen (nth 1 vectype)
vectype (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))
(if (> l len) (setq l len))
(while (< i l)
(bindat--pack-item (aref v i) type vlen vectype)
(setq i (1+ i)))))
(t
(dotimes (i l)
(bindat--pack-item (aref v i) type vlen vectype))))
(_
(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))
(field (car item))
(with-suppressed-warnings ((lexical struct last))
(defvar struct) (defvar last))
(let ((struct struct) last)
(dolist (item spec)
(let* ((field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
@ -566,31 +566,31 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
len type
type field
field nil))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)) t)))
(if (and (consp len) (not (eq type 'eval)))
(setq len (apply #'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(cond
((eq type 'eval)
(pcase type
('eval
(if field
(setq struct (cons (cons field (eval len t)) struct))
(eval len t)))
((eq type 'fill)
('fill
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
('align
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
('struct
(bindat--pack-group
(if field (bindat-get-field struct field) struct) (eval len t)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
(bindat--pack-group
(nth index (bindat-get-field struct field))
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
('repeat
(dotimes (index len)
(bindat--pack-group
(nth index (bindat-get-field struct field))
(nthcdr tail item))))
('union
(with-suppressed-warnings ((lexical tag))
(defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
@ -603,7 +603,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(progn
(bindat--pack-group struct (cdr case))
(setq cases nil))))))
(t
(_
(setq last (bindat-get-field struct field))
(bindat--pack-item last type len vectype)
))))))
@ -622,21 +622,61 @@ Optional fourth arg IDX is the starting offset into RAW."
(bindat--pack-group struct spec)
(if raw nil bindat-raw)))
;;;; Debugging support
;; Misc. format conversions
(def-edebug-elem-spec 'bindat-spec '(&rest bindat-item))
(def-edebug-elem-spec 'bindat--item-aux
;; Field types which can come without a field label.
'(&or ["eval" form]
["fill" bindat-len]
["align" bindat-len]
["struct" form] ;A reference to another bindat-spec.
["union" bindat-tag-val &rest (bindat-tag bindat-spec)]))
(def-edebug-elem-spec 'bindat-item
'((&or bindat--item-aux ;Without label..
[bindat-field ;..or with label
&or bindat--item-aux
["repeat" bindat-arg bindat-spec]
bindat-type])))
(def-edebug-elem-spec 'bindat-type
'(&or ("eval" form)
["str" bindat-len]
["strz" bindat-len]
["vec" bindat-len &optional bindat-type]
["bits" bindat-len]
symbolp))
(def-edebug-elem-spec 'bindat-field
'(&or ("eval" form) symbolp))
(def-edebug-elem-spec 'bindat-len '(&or [] "nil" bindat-arg))
(def-edebug-elem-spec 'bindat-tag-val '(bindat-arg))
(def-edebug-elem-spec 'bindat-tag '(&or ("eval" form) atom))
(def-edebug-elem-spec 'bindat-arg
'(&or ("eval" form) integerp (&rest symbolp integerp)))
(defmacro bindat-spec (&rest fields)
"Build the bindat spec described by FIELDS."
(declare (indent 0) (debug (bindat-spec)))
;; FIXME: We should really "compile" this to a triplet of functions!
`',fields)
;;;; Misc. format conversions
(defun bindat-format-vector (vect fmt sep &optional len)
"Format vector VECT using element format FMT and separator SEP.
Result is a string with each element of VECT formatted using FMT and
separated by the string SEP. If optional fourth arg LEN is given, use
only that many elements from VECT."
(unless len
(setq len (length vect)))
(let ((i len) (fmt2 (concat sep fmt)) (s nil))
(while (> i 0)
(setq i (1- i)
s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s)))
(apply #'concat s)))
(when len (setq vect (substring vect 0 len)))
(mapconcat (lambda (x) (format fmt x)) vect sep))
(defun bindat-vector-to-dec (vect &optional sep)
"Format vector VECT in decimal format separated by dots.

88
lisp/emacs-lisp/byte-opt.el
View file

@ -458,16 +458,22 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
(cons fn (byte-optimize-body exps for-effect)))
(`(if ,test ,then . ,else)
;; FIXME: We are conservative here: any variable changed in the
;; THEN branch will be barred from substitution in the ELSE
;; branch, despite the branches being mutually exclusive.
;; The test is always executed.
(let* ((test-opt (byte-optimize-form test nil))
;; The THEN and ELSE branches are executed conditionally.
;;
;; FIXME: We are conservative here: any variable changed in the
;; THEN branch will be barred from substitution in the ELSE
;; branch, despite the branches being mutually exclusive.
(byte-optimize--vars-outside-condition byte-optimize--lexvars)
(then-opt (byte-optimize-form then for-effect))
(else-opt (byte-optimize-body else for-effect)))
(const (macroexp-const-p test-opt))
;; The branches are traversed unconditionally when possible.
(byte-optimize--vars-outside-condition
(if const
byte-optimize--vars-outside-condition
byte-optimize--lexvars))
;; Avoid traversing dead branches.
(then-opt (and test-opt (byte-optimize-form then for-effect)))
(else-opt (and (not (and test-opt const))
(byte-optimize-body else for-effect))))
`(if ,test-opt ,then-opt . ,else-opt)))
(`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures.
@ -587,16 +593,15 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
(lexvar (assq var byte-optimize--lexvars))
(value (byte-optimize-form expr nil)))
(when lexvar
;; If it's bound outside conditional, invalidate.
(if (assq var byte-optimize--vars-outside-condition)
;; We are in conditional code and the variable was
;; bound outside: cancel substitutions.
(setcdr (cdr lexvar) nil)
;; Set a new value (if substitutable).
(setcdr (cdr lexvar)
(and (byte-optimize--substitutable-p value)
(list value))))
(setcar (cdr lexvar) t)) ; Mark variable to be kept.
;; Set a new value or inhibit further substitution.
(setcdr (cdr lexvar)
(and
;; Inhibit if bound outside conditional code.
(not (assq var byte-optimize--vars-outside-condition))
;; The new value must be substitutable.
(byte-optimize--substitutable-p value)
(list value)))
(setcar (cdr lexvar) t)) ; Mark variable to be kept.
(push var var-expr-list)
(push value var-expr-list))
(setq args (cddr args)))
@ -638,30 +643,24 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
(defun byte-optimize-form (form &optional for-effect)
"The source-level pass of the optimizer."
;;
;; First, optimize all sub-forms of this one.
(setq form (byte-optimize-form-code-walker form for-effect))
;;
;; after optimizing all subforms, optimize this form until it doesn't
;; optimize any further. This means that some forms will be passed through
;; the optimizer many times, but that's necessary to make the for-effect
;; processing do as much as possible.
;;
(let (opt new)
(if (and (consp form)
(symbolp (car form))
(or ;; (and for-effect
;; ;; We don't have any of these yet, but we might.
;; (setq opt (get (car form)
;; 'byte-for-effect-optimizer)))
(setq opt (function-get (car form) 'byte-optimizer)))
(not (eq form (setq new (funcall opt form)))))
(progn
;; (if (equal form new) (error "bogus optimizer -- %s" opt))
(byte-compile-log " %s\t==>\t%s" form new)
(setq new (byte-optimize-form new for-effect))
new)
form)))
(while
(progn
;; First, optimize all sub-forms of this one.
(setq form (byte-optimize-form-code-walker form for-effect))
;; If a form-specific optimiser is available, run it and start over
;; until a fixpoint has been reached.
(and (consp form)
(symbolp (car form))
(let ((opt (function-get (car form) 'byte-optimizer)))
(and opt
(let ((old form)
(new (funcall opt form)))
(byte-compile-log " %s\t==>\t%s" old new)
(setq form new)
(not (eq new old))))))))
;; Normalise (quote nil) to nil, for a single representation of constant nil.
(and (not (equal form '(quote nil))) form))
(defun byte-optimize-let-form (head form for-effect)
;; Recursively enter the optimizer for the bindings and body
@ -1563,10 +1562,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
;; so we create a copy of it, and replace the addresses with
;; TAGs.
(let ((orig-table last-constant))
(cl-loop for e across constvec
when (eq e last-constant)
do (setq last-constant (copy-hash-table e))
and return nil)
(setq last-constant (copy-hash-table last-constant))
;; Replace all addresses with TAGs.
(maphash #'(lambda (value offset)
(let ((match (assq offset tags)))

19
lisp/emacs-lisp/byte-run.el
View file

@ -113,6 +113,9 @@ The return value of this function is not used."
(list 'function-put (list 'quote f)
''side-effect-free (list 'quote val))))
(put 'compiler-macro 'edebug-declaration-spec
'(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)))
(defalias 'byte-run--set-compiler-macro
#'(lambda (f args compiler-function)
(if (not (eq (car-safe compiler-function) 'lambda))
@ -148,6 +151,18 @@ The return value of this function is not used."
(list 'function-put (list 'quote f)
''speed (list 'quote val))))
(defalias 'byte-run--set-completion
#'(lambda (f _args val)
(list 'function-put (list 'quote f)
''completion-predicate val)))
(defalias 'byte-run--set-modes
#'(lambda (f _args &rest val)
(list 'function-put (list 'quote f)
''completion-predicate
`(lambda (_ b)
(command-completion-with-modes-p ',val b)))))
;; Add any new entries to info node `(elisp)Declare Form'.
(defvar defun-declarations-alist
(list
@ -165,7 +180,9 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
(list 'compiler-macro #'byte-run--set-compiler-macro)
(list 'doc-string #'byte-run--set-doc-string)
(list 'indent #'byte-run--set-indent)
(list 'speed #'byte-run--set-speed))
(list 'speed #'byte-run--set-speed)
(list 'completion #'byte-run--set-completion)
(list 'modes #'byte-run--set-modes))
"List associating function properties to their macro expansion.
Each element of the list takes the form (PROP FUN) where FUN is
a function. For each (PROP . VALUES) in a function's declaration,

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

@ -3020,7 +3020,8 @@ for symbols generated by the byte compiler itself."
;; unless it is the last element of the body.
(if (cdr body)
(setq body (cdr body))))))
(int (assq 'interactive body)))
(int (assq 'interactive body))
command-modes)
(when lexical-binding
(dolist (var arglistvars)
(when (assq var byte-compile--known-dynamic-vars)
@ -3031,10 +3032,13 @@ for symbols generated by the byte compiler itself."
;; Skip (interactive) if it is in front (the most usual location).
(if (eq int (car body))
(setq body (cdr body)))
(cond ((consp (cdr int))
(if (cdr (cdr int))
(byte-compile-warn "malformed interactive spec: %s"
(prin1-to-string int)))
(cond ((consp (cdr int)) ; There is an `interactive' spec.
;; Check that the bit after the `interactive' spec is
;; just a list of symbols (i.e., modes).
(unless (seq-every-p #'symbolp (cdr (cdr int)))
(byte-compile-warn "malformed interactive specc: %s"
(prin1-to-string int)))
(setq command-modes (cdr (cdr int)))
;; If the interactive spec is a call to `list', don't
;; compile it, because `call-interactively' looks at the
;; args of `list'. Actually, compile it to get warnings,
@ -3045,15 +3049,14 @@ for symbols generated by the byte compiler itself."
(while (consp (cdr form))
(setq form (cdr form)))
(setq form (car form)))
(if (and (eq (car-safe form) 'list)
;; For code using lexical-binding, form is not
;; valid lisp, but rather an intermediate form
;; which may include "calls" to
;; internal-make-closure (Bug#29988).
(not lexical-binding))
nil
(setq int `(interactive ,newform)))))
((cdr int)
(when (or (not (eq (car-safe form) 'list))
;; For code using lexical-binding, form is not
;; valid lisp, but rather an intermediate form
;; which may include "calls" to
;; internal-make-closure (Bug#29988).
lexical-binding)
(setq int `(interactive ,newform)))))
((cdr int) ; Invalid (interactive . something).
(byte-compile-warn "malformed interactive spec: %s"
(prin1-to-string int)))))
;; Process the body.
@ -3070,29 +3073,36 @@ for symbols generated by the byte compiler itself."
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out
(apply #'make-byte-code
(if lexical-binding
(byte-compile-make-args-desc arglist)
arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
(cond ((and lexical-binding arglist)
;; byte-compile-make-args-desc lost the args's names,
;; so preserve them in the docstring.
(list (help-add-fundoc-usage doc arglist)))
((or doc int)
(list doc)))
;; optionally, the interactive spec.
(if int
(list (nth 1 int)))))))
(when byte-native-compiling
(apply #'make-byte-code
(if lexical-binding
(byte-compile-make-args-desc arglist)
arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
(cond ((and lexical-binding arglist)
;; byte-compile-make-args-desc lost the args's names,
;; so preserve them in the docstring.
(list (help-add-fundoc-usage doc arglist)))
((or doc int)
(list doc)))
;; optionally, the interactive spec (and the modes the
;; command applies to).
(cond
;; We have some command modes, so use the vector form.
(command-modes
(list (vector (nth 1 int) command-modes)))
;; No command modes, use the simple form with just the
;; interactive spec.
(int
(list (nth 1 int))))))))
(when byte-native-compiling
(setf (byte-to-native-lambda-byte-func
(gethash (cadr compiled)
byte-to-native-lambdas-h))
out))
out))))
out))))
(defvar byte-compile-reserved-constants 0)

74
lisp/emacs-lisp/cl-generic.el
View file

@ -189,6 +189,32 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
(setf (cl--generic name) (setq generic (cl--generic-make name))))
generic))
(defvar cl--generic-edebug-name nil)
(defun cl--generic-edebug-remember-name (name pf &rest specs)
;; Remember the name in `cl-defgeneric' so we can use it when building
;; the names of its `:methods'.
(let ((cl--generic-edebug-name (car name)))
(funcall pf specs)))
(defun cl--generic-edebug-make-name (in:method _oldname &rest quals-and-args)
;; The name to use in Edebug for a method: use the generic
;; function's name plus all its qualifiers and finish with
;; its specializers.
(pcase-let*
((basename (if in:method cl--generic-edebug-name (pop quals-and-args)))
(args (car (last quals-and-args)))
(`(,spec-args . ,_) (cl--generic-split-args args))
(specializers (mapcar (lambda (spec-arg)
(if (eq '&context (car-safe (car spec-arg)))
spec-arg (cdr spec-arg)))
spec-args)))
(format "%s %s"
(mapconcat (lambda (sexp) (format "%s" sexp))
(cons basename (butlast quals-and-args))
" ")
specializers)))
;;;###autoload
(defmacro cl-defgeneric (name args &rest options-and-methods)
"Create a generic function NAME.
@ -206,24 +232,22 @@ DEFAULT-BODY, if present, is used as the body of a default method.
\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)"
(declare (indent 2) (doc-string 3)
(debug
(&define [&or name ("setf" name :name setf)] listp
lambda-doc
[&rest [&or
("declare" &rest sexp)
(":argument-precedence-order" &rest sexp)
(&define ":method"
;; FIXME: The `:unique'
;; construct works around
;; Bug#42672. We'd rather want
;; names like those generated by
;; `cl-defmethod', but that
;; requires larger changes to
;; Edebug.
:unique "cl-generic-:method@"
[&rest cl-generic-method-qualifier]
cl-generic-method-args lambda-doc
def-body)]]
def-body)))
(&define
&interpose
[&name sexp] ;Allow (setf ...) additionally to symbols.
cl--generic-edebug-remember-name
listp lambda-doc
[&rest [&or
("declare" &rest sexp)
(":argument-precedence-order" &rest sexp)
(&define ":method"
[&name
[[&rest cl-generic--method-qualifier-p]
listp] ;Formal args
cl--generic-edebug-make-name in:method]
lambda-doc
def-body)]]
def-body)))
(let* ((doc (if (stringp (car-safe options-and-methods))
(pop options-and-methods)))
(declarations nil)
@ -398,6 +422,9 @@ the specializer used will be the one returned by BODY."
(let ((combined-doc (buffer-string)))
(if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
(defun cl-generic--method-qualifier-p (x)
(not (listp x)))
;;;###autoload
(defmacro cl-defmethod (name args &rest body)
"Define a new method for generic function NAME.
@ -440,15 +467,14 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(declare (doc-string 3) (indent defun)
(debug
(&define ; this means we are defining something
[&or name ("setf" name :name setf)]
;; ^^ This is the methods symbol
[ &rest cl-generic-method-qualifier ]
;; Multiple qualifiers are allowed.
cl-generic-method-args ; arguments
[&name [sexp ;Allow (setf ...) additionally to symbols.
[&rest cl-generic--method-qualifier-p] ;qualifiers
listp] ; arguments
cl--generic-edebug-make-name nil]
lambda-doc ; documentation string
def-body))) ; part to be debugged
(let ((qualifiers nil))
(while (not (listp args))
(while (cl-generic--method-qualifier-p args)
(push args qualifiers)
(setq args (pop body)))
(when (eq 'setf (car-safe name))

2
lisp/emacs-lisp/cl-lib.el
View file

@ -140,7 +140,7 @@ to an element already in the list stored in PLACE.
\n(fn X PLACE [KEYWORD VALUE]...)"
(declare (debug
(form place &rest
&or [[&or ":test" ":test-not" ":key"] function-form]
&or [[&or ":test" ":test-not" ":key"] form]
[keywordp form])))
(if (symbolp place)
(if (null keys)

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

@ -186,14 +186,14 @@ The name is made by appending a number to PREFIX, default \"T\"."
;;; Program structure.
(def-edebug-spec cl-declarations
(&rest ("cl-declare" &rest sexp)))
(def-edebug-elem-spec 'cl-declarations
'(&rest ("cl-declare" &rest sexp)))
(def-edebug-spec cl-declarations-or-string
(&or lambda-doc cl-declarations))
(def-edebug-elem-spec 'cl-declarations-or-string
'(lambda-doc &or ("declare" def-declarations) cl-declarations))
(def-edebug-spec cl-lambda-list
(([&rest cl-lambda-arg]
(def-edebug-elem-spec 'cl-lambda-list
'(([&rest cl-lambda-arg]
[&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
[&optional ["&rest" cl-lambda-arg]]
[&optional ["&key" [cl-&key-arg &rest cl-&key-arg]
@ -202,27 +202,27 @@ The name is made by appending a number to PREFIX, default \"T\"."
&or (cl-lambda-arg &optional def-form) arg]]
. [&or arg nil])))
(def-edebug-spec cl-&optional-arg
(&or (cl-lambda-arg &optional def-form arg) arg))
(def-edebug-elem-spec 'cl-&optional-arg
'(&or (cl-lambda-arg &optional def-form arg) arg))
(def-edebug-spec cl-&key-arg
(&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg))
(def-edebug-elem-spec 'cl-&key-arg
'(&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg))
(def-edebug-spec cl-lambda-arg
(&or arg cl-lambda-list1))
(def-edebug-elem-spec 'cl-lambda-arg
'(&or arg cl-lambda-list1))
(def-edebug-spec cl-lambda-list1
(([&optional ["&whole" arg]] ;; only allowed at lower levels
[&rest cl-lambda-arg]
[&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
[&optional ["&rest" cl-lambda-arg]]
[&optional ["&key" cl-&key-arg &rest cl-&key-arg
&optional "&allow-other-keys"]]
[&optional ["&aux" &rest
&or (cl-lambda-arg &optional def-form) arg]]
. [&or arg nil])))
(def-edebug-elem-spec 'cl-lambda-list1
'(([&optional ["&whole" arg]] ;; only allowed at lower levels
[&rest cl-lambda-arg]
[&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
[&optional ["&rest" cl-lambda-arg]]
[&optional ["&key" cl-&key-arg &rest cl-&key-arg
&optional "&allow-other-keys"]]
[&optional ["&aux" &rest
&or (cl-lambda-arg &optional def-form) arg]]
. [&or arg nil])))
(def-edebug-spec cl-type-spec sexp)
(def-edebug-elem-spec 'cl-type-spec '(sexp))
(defconst cl--lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
@ -358,7 +358,7 @@ more details.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as defun but use cl-lambda-list.
(&define [&or name ("setf" :name setf name)]
(&define [&name sexp] ;Allow (setf ...) additionally to symbols.
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
@ -376,7 +376,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as iter-defun but use cl-lambda-list.
(&define [&or name ("setf" :name setf name)]
(&define [&name sexp] ;Allow (setf ...) additionally to symbols.
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
@ -390,39 +390,39 @@ and BODY is implicitly surrounded by (cl-block NAME ...).
;; Note that &environment is only allowed as first or last items in the
;; top level list.
(def-edebug-spec cl-macro-list
(([&optional "&environment" arg]
[&rest cl-macro-arg]
[&optional ["&optional" &rest
&or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
[&optional [[&or "&rest" "&body"] cl-macro-arg]]
[&optional ["&key" [&rest
[&or ([&or (symbolp cl-macro-arg) arg]
&optional def-form cl-macro-arg)
arg]]
&optional "&allow-other-keys"]]
[&optional ["&aux" &rest
&or (cl-macro-arg &optional def-form) arg]]
[&optional "&environment" arg]
)))
(def-edebug-elem-spec 'cl-macro-list
'(([&optional "&environment" arg]
[&rest cl-macro-arg]
[&optional ["&optional" &rest
&or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
[&optional [[&or "&rest" "&body"] cl-macro-arg]]
[&optional ["&key" [&rest
[&or ([&or (symbolp cl-macro-arg) arg]
&optional def-form cl-macro-arg)
arg]]
&optional "&allow-other-keys"]]
[&optional ["&aux" &rest
&or (cl-macro-arg &optional def-form) arg]]
[&optional "&environment" arg]
)))
(def-edebug-spec cl-macro-arg
(&or arg cl-macro-list1))
(def-edebug-elem-spec 'cl-macro-arg
'(&or arg cl-macro-list1))
(def-edebug-spec cl-macro-list1
(([&optional "&whole" arg] ;; only allowed at lower levels
[&rest cl-macro-arg]
[&optional ["&optional" &rest
&or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
[&optional [[&or "&rest" "&body"] cl-macro-arg]]
[&optional ["&key" [&rest
[&or ([&or (symbolp cl-macro-arg) arg]
&optional def-form cl-macro-arg)
arg]]
&optional "&allow-other-keys"]]
[&optional ["&aux" &rest
&or (cl-macro-arg &optional def-form) arg]]
. [&or arg nil])))
(def-edebug-elem-spec 'cl-macro-list1
'(([&optional "&whole" arg] ;; only allowed at lower levels
[&rest cl-macro-arg]
[&optional ["&optional" &rest
&or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
[&optional [[&or "&rest" "&body"] cl-macro-arg]]
[&optional ["&key" [&rest
[&or ([&or (symbolp cl-macro-arg) arg]
&optional def-form cl-macro-arg)
arg]]
&optional "&allow-other-keys"]]
[&optional ["&aux" &rest
&or (cl-macro-arg &optional def-form) arg]]
. [&or arg nil])))
;;;###autoload
(defmacro cl-defmacro (name args &rest body)
@ -452,19 +452,19 @@ more details.
(indent 2))
`(defmacro ,name ,@(cl--transform-lambda (cons args body) name)))
(def-edebug-spec cl-lambda-expr
(&define ("lambda" cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
def-body)))
(def-edebug-elem-spec 'cl-lambda-expr
'(&define ("lambda" cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
def-body)))
;; Redefine function-form to also match cl-function
(def-edebug-spec function-form
(def-edebug-elem-spec 'function-form
;; form at the end could also handle "function",
;; but recognize it specially to avoid wrapping function forms.
(&or ([&or "quote" "function"] &or symbolp lambda-expr)
("cl-function" cl-function)
form))
'(&or ([&or "quote" "function"] &or symbolp lambda-expr)
("cl-function" cl-function)
form))
;;;###autoload
(defmacro cl-function (func)
@ -1051,20 +1051,20 @@ For more details, see Info node `(cl)Loop Facility'.
;; [&rest loop-clause]
;; ))
;; (def-edebug-spec loop-with
;; ("with" loop-var
;; (def-edebug-elem-spec 'loop-with
;; '("with" loop-var
;; loop-type-spec
;; [&optional ["=" form]]
;; &rest ["and" loop-var
;; loop-type-spec
;; [&optional ["=" form]]]))
;; (def-edebug-spec loop-for-as
;; ([&or "for" "as"] loop-for-as-subclause
;; (def-edebug-elem-spec 'loop-for-as
;; '([&or "for" "as"] loop-for-as-subclause
;; &rest ["and" loop-for-as-subclause]))
;; (def-edebug-spec loop-for-as-subclause
;; (loop-var
;; (def-edebug-elem-spec 'loop-for-as-subclause
;; '(loop-var
;; loop-type-spec
;; &or
;; [[&or "in" "on" "in-ref" "across-ref"]
@ -1124,19 +1124,19 @@ For more details, see Info node `(cl)Loop Facility'.
;; [&optional ["by" form]]
;; ]))
;; (def-edebug-spec loop-initial-final
;; (&or ["initially"
;; (def-edebug-elem-spec 'loop-initial-final
;; '(&or ["initially"
;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this.
;; &rest loop-non-atomic-expr]
;; ["finally" &or
;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr]
;; ["return" form]]))
;; (def-edebug-spec loop-and-clause
;; (loop-clause &rest ["and" loop-clause]))
;; (def-edebug-elem-spec 'loop-and-clause
;; '(loop-clause &rest ["and" loop-clause]))
;; (def-edebug-spec loop-clause
;; (&or
;; (def-edebug-elem-spec 'loop-clause
;; '(&or
;; [[&or "while" "until" "always" "never" "thereis"] form]
;; [[&or "collect" "collecting"
@ -1163,10 +1163,10 @@ For more details, see Info node `(cl)Loop Facility'.
;; loop-initial-final
;; ))
;; (def-edebug-spec loop-non-atomic-expr
;; ([&not atom] form))
;; (def-edebug-elem-spec 'loop-non-atomic-expr
;; '([&not atom] form))
;; (def-edebug-spec loop-var
;; (def-edebug-elem-spec 'loop-var
;; ;; The symbolp must be last alternative to recognize e.g. (a b . c)
;; ;; loop-var =>
;; ;; (loop-var . [&or nil loop-var])
@ -1175,13 +1175,13 @@ For more details, see Info node `(cl)Loop Facility'.
;; ;; (symbolp . (symbolp . [&or nil loop-var]))
;; ;; (symbolp . (symbolp . loop-var))
;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp)
;; (&or (loop-var . [&or nil loop-var]) [gate symbolp]))
;; '(&or (loop-var . [&or nil loop-var]) [gate symbolp]))
;; (def-edebug-spec loop-type-spec
;; (&optional ["of-type" loop-d-type-spec]))
;; (def-edebug-elem-spec 'loop-type-spec
;; '(&optional ["of-type" loop-d-type-spec]))
;; (def-edebug-spec loop-d-type-spec
;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec))
;; (def-edebug-elem-spec 'loop-d-type-spec
;; '(&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec))
(defun cl--parse-loop-clause () ; uses loop-*
(let ((word (pop cl--loop-args))
@ -2016,8 +2016,9 @@ info node `(cl) Function Bindings' for details.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
(debug ((&rest [&or (&define name :unique "cl-flet@" function-form)
(&define name :unique "cl-flet@"
(debug ((&rest [&or (symbolp form)
(&define [&name symbolp "@cl-flet@"]
[&name [] gensym] ;Make it unique!
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
@ -2192,6 +2193,20 @@ details.
(macroexp-progn body)
newenv)))))
(defvar edebug-lexical-macro-ctx)
(defun cl--edebug-macrolet-interposer (bindings pf &rest specs)
;; (cl-assert (null (cdr bindings)))
(setq bindings (car bindings))
(let ((edebug-lexical-macro-ctx
(nconc (mapcar (lambda (binding)
(cons (car binding)
(when (eq 'declare (car-safe (nth 2 binding)))
(nth 1 (assq 'debug (cdr (nth 2 binding)))))))
bindings)
edebug-lexical-macro-ctx)))
(funcall pf specs)))
;; The following ought to have a better definition for use with newer
;; byte compilers.
;;;###autoload
@ -2201,7 +2216,13 @@ This is like `cl-flet', but for macros instead of functions.
\(fn ((NAME ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
(debug (cl-macrolet-expr)))
(debug (&interpose (&rest (&define [&name symbolp "@cl-macrolet@"]
[&name [] gensym] ;Make it unique!
cl-macro-list
cl-declarations-or-string
def-body))
cl--edebug-macrolet-interposer
cl-declarations body)))
(if (cdr bindings)
`(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body))
(if (null bindings) (macroexp-progn body)

7
lisp/emacs-lisp/derived.el
View file

@ -141,6 +141,9 @@ KEYWORD-ARGS:
:after-hook FORM
A single lisp form which is evaluated after the mode
hooks have been run. It should not be quoted.
:interactive BOOLEAN
Whether the derived mode should be `interactive' or not.
The default is t.
BODY: forms to execute just before running the
hooks for the new mode. Do not use `interactive' here.
@ -194,6 +197,7 @@ See Info node `(elisp)Derived Modes' for more details.
(declare-syntax t)
(hook (derived-mode-hook-name child))
(group nil)
(interactive t)
(after-hook nil))
;; Process the keyword args.
@ -203,6 +207,7 @@ See Info node `(elisp)Derived Modes' for more details.
(:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
(:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
(:after-hook (setq after-hook (pop body)))
(:interactive (setq interactive (pop body)))
(_ (pop body))))
(setq docstring (derived-mode-make-docstring
@ -246,7 +251,7 @@ No problems result if this variable is not bound.
(defun ,child ()
,docstring
(interactive)
,(and interactive '(interactive))
; Run the parent.
(delay-mode-hooks

31
lisp/emacs-lisp/easy-mmode.el
View file

@ -172,6 +172,10 @@ BODY contains code to execute each time the mode is enabled or disabled.
:lighter SPEC Same as the LIGHTER argument.
:keymap MAP Same as the KEYMAP argument.
:require SYM Same as in `defcustom'.
:interactive VAL Whether this mode should be a command or not. The default
is to make it one; use nil to avoid that. If VAL is a list,
it's interpreted as a list of major modes this minor mode
is useful in.
:variable PLACE The location to use instead of the variable MODE to store
the state of the mode. This can be simply a different
named variable, or a generalized variable.
@ -226,6 +230,7 @@ For example, you could write
(hook (intern (concat mode-name "-hook")))
(hook-on (intern (concat mode-name "-on-hook")))
(hook-off (intern (concat mode-name "-off-hook")))
(interactive t)
keyw keymap-sym tmp)
;; Check keys.
@ -245,6 +250,7 @@ For example, you could write
(:type (setq type (list :type (pop body))))
(:require (setq require (pop body)))
(:keymap (setq keymap (pop body)))
(:interactive (setq interactive (pop body)))
(:variable (setq variable (pop body))
(if (not (and (setq tmp (cdr-safe variable))
(or (symbolp tmp)
@ -303,11 +309,18 @@ or call the function `%s'."))))
;; The actual function.
(defun ,modefun (&optional arg ,@extra-args)
,(easy-mmode--mode-docstring doc pretty-name keymap-sym)
;; Use `toggle' rather than (if ,mode 0 1) so that using
;; repeat-command still does the toggling correctly.
(interactive (list (if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
'toggle)))
,(when interactive
;; Use `toggle' rather than (if ,mode 0 1) so that using
;; repeat-command still does the toggling correctly.
(if (consp interactive)
`(interactive
(list (if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
'toggle))
,@interactive)
'(interactive (list (if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
'toggle)))))
(let ((,last-message (current-message)))
(,@setter
(cond ((eq arg 'toggle)
@ -317,6 +330,14 @@ or call the function `%s'."))))
nil)
(t
t)))
;; Keep minor modes list up to date.
,@(if globalp
`((setq global-minor-modes (delq ',modefun global-minor-modes))
(when ,getter
(push ',modefun global-minor-modes)))
`((setq local-minor-modes (delq ',modefun local-minor-modes))
(when ,getter
(push ',modefun local-minor-modes))))
,@body
;; The on/off hooks are here for backward compatibility only.
(run-hooks ',hook (if ,getter ',hook-on ',hook-off))

5
lisp/emacs-lisp/easymenu.el
View file

@ -183,7 +183,10 @@ This is expected to be bound to a mouse event."
:filter)
'identity)
(symbol-function symbol)))
symbol)))))
symbol))))
;; These symbols are commands, but not interesting for users
;; to `M-x TAB'.
(put symbol 'completion-predicate 'ignore))
(dolist (map (if (keymapp maps) (list maps) maps))
(define-key map
(vector 'menu-bar (easy-menu-intern (car menu)))

637
lisp/emacs-lisp/edebug.el
View file

@ -55,6 +55,7 @@
(require 'backtrace)
(require 'macroexp)
(require 'cl-lib)
(require 'seq)
(eval-when-compile (require 'pcase))
;;; Options
@ -244,19 +245,30 @@ If the result is non-nil, then break. Errors are ignored."
;;; Form spec utilities.
(defun get-edebug-spec (symbol)
(defun edebug-get-spec (symbol)
"Return the Edebug spec of a given Lisp expression's head SYMBOL.
The argument is usually a symbol, but it doesn't have to be."
;; Get the spec of symbol resolving all indirection.
(let ((spec nil)
(indirect symbol))
(while
(progn
(and (symbolp indirect)
(setq indirect
(function-get indirect 'edebug-form-spec 'macro))))
(and (symbolp indirect)
(setq indirect
(function-get indirect 'edebug-form-spec 'macro)))
;; (edebug-trace "indirection: %s" edebug-form-spec)
(setq spec indirect))
spec))
(define-obsolete-function-alias 'get-edebug-spec #'edebug-get-spec "28.1")
(defun edebug--get-elem-spec (elem)
"Return the specs of the Edebug element ELEM, if any.
ELEM has to be a symbol."
(or (get elem 'edebug-elem-spec)
;; For backward compatibility, we also allow the use of
;; a form's name as a shorthand to refer to its spec.
(edebug-get-spec elem)))
;;;###autoload
(defun edebug-basic-spec (spec)
"Return t if SPEC uses only extant spec symbols.
@ -961,6 +973,18 @@ circular objects. Let `read' read everything else."
;;; Cursors for traversal of list and vector elements with offsets.
;; Edebug's instrumentation is based on parsing the sexps, which come with
;; auxiliary position information. Instead of keeping the position
;; information together with the sexps, it is kept in a "parallel
;; tree" of offsets.
;;
;; An "edebug cursor" is a pair of a *list of sexps* (called the
;; "expressions") together with a matching list of offsets.
;; When we're parsing the content of a list, the
;; `edebug-cursor-expressions' is simply the list but when parsing
;; a vector, the `edebug-cursor-expressions' is a list formed of the
;; elements of the vector.
(defvar edebug-dotted-spec nil
"Set to t when matching after the dot in a dotted spec list.")
@ -1015,8 +1039,8 @@ circular objects. Let `read' read everything else."
;; The following test should always fail.
(if (edebug-empty-cursor cursor)
(edebug-no-match cursor "Not enough arguments."))
(setcar cursor (cdr (car cursor)))
(setcdr cursor (cdr (cdr cursor)))
(cl-callf cdr (car cursor))
(cl-callf cdr (cdr cursor))
cursor)
@ -1067,8 +1091,6 @@ circular objects. Let `read' read everything else."
;; This data is shared by all embedded definitions.
(defvar edebug-top-window-data)
(defvar edebug-&optional)
(defvar edebug-&rest)
(defvar edebug-gate nil) ;; whether no-match forces an error.
(defvar edebug-def-name nil) ; name of definition, used by interactive-form
@ -1119,8 +1141,6 @@ purpose by adding an entry to this alist, and setting
edebug-top-window-data
edebug-def-name;; make sure it is locally nil
;; I don't like these here!!
edebug-&optional
edebug-&rest
edebug-gate
edebug-best-error
edebug-error-point
@ -1153,7 +1173,7 @@ purpose by adding an entry to this alist, and setting
(eq 'symbol (progn (forward-char 1) (edebug-next-token-class))))
;; Find out if this is a defining form from first symbol
(setq def-kind (read (current-buffer))
spec (and (symbolp def-kind) (get-edebug-spec def-kind))
spec (and (symbolp def-kind) (edebug-get-spec def-kind))
defining-form-p (and (listp spec)
(eq '&define (car spec)))
;; This is incorrect in general!! But OK most of the time.
@ -1164,6 +1184,9 @@ purpose by adding an entry to this alist, and setting
;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms)
(let ((result
(cond
;; IIUC, `&define' is treated specially here so as to avoid
;; entering Edebug during the actual function's definition:
;; we only want to enter Edebug later when the thing is called.
(defining-form-p
(if (or edebug-all-defs edebug-all-forms)
;; If it is a defining form and we are edebugging defs,
@ -1211,26 +1234,12 @@ purpose by adding an entry to this alist, and setting
(funcall edebug-after-instrumentation-function result))))
(defvar edebug-def-args) ; args of defining form.
(defvar edebug-def-interactive) ; is it an emacs interactive function?
(defvar edebug-inside-func) ;; whether code is inside function context.
;; Currently def-form sets this to nil; def-body sets it to t.
(defvar edebug--cl-macrolet-defs) ;; Fully defined below.
(defun edebug-interactive-p-name ()
;; Return a unique symbol for the variable used to store the
;; status of interactive-p for this function.
(intern (format "edebug-%s-interactive-p" edebug-def-name)))
(defun edebug-wrap-def-body (forms)
"Wrap the FORMS of a definition body."
(if edebug-def-interactive
`(let ((,(edebug-interactive-p-name)
(called-interactively-p 'interactive)))
,(edebug-make-enter-wrapper forms))
(edebug-make-enter-wrapper forms)))
(defvar edebug-lexical-macro-ctx nil
"Alist mapping lexically scoped macro names to their debug spec.")
(defun edebug-make-enter-wrapper (forms)
;; Generate the enter wrapper for some forms of a definition.
@ -1380,7 +1389,6 @@ contains a circular object."
(edebug-old-def-name (edebug--form-data-name form-data-entry))
edebug-def-name
edebug-def-args
edebug-def-interactive
edebug-inside-func;; whether wrapped code executes inside a function.
)
@ -1500,9 +1508,12 @@ contains a circular object."
((consp form)
;; The first offset for a list form is for the list form itself.
(if (eq 'quote (car form))
;; This makes sure we don't instrument 'foo
;; which would cause the debugger to single-step
;; the trivial evaluation of a constant.
form
(let* ((head (car form))
(spec (and (symbolp head) (get-edebug-spec head)))
(spec (and (symbolp head) (edebug-get-spec head)))
(new-cursor (edebug-new-cursor form offset)))
;; Find out if this is a defining form from first symbol.
;; An indirect spec would not work here, yet.
@ -1542,13 +1553,10 @@ contains a circular object."
(defsubst edebug-list-form-args (head cursor)
;; Process the arguments of a list form given that head of form is a symbol.
;; Helper for edebug-list-form
(let ((spec (get-edebug-spec head)))
(let* ((lex-spec (assq head edebug-lexical-macro-ctx))
(spec (if lex-spec (cdr lex-spec)
(edebug-get-spec head))))
(cond
;; Treat cl-macrolet bindings like macros with no spec.
((member head edebug--cl-macrolet-defs)
(if edebug-eval-macro-args
(edebug-forms cursor)
(edebug-sexps cursor)))
(spec
(cond
((consp spec)
@ -1562,7 +1570,7 @@ contains a circular object."
; but leave it in for compatibility.
))
;; No edebug-form-spec provided.
((macrop head)
((or lex-spec (macrop head))
(if edebug-eval-macro-args
(edebug-forms cursor)
(edebug-sexps cursor)))
@ -1575,10 +1583,7 @@ contains a circular object."
;; The after offset will be left in the cursor after processing the form.
(let ((head (edebug-top-element-required cursor "Expected elements"))
;; Prevent backtracking whenever instrumenting.
(edebug-gate t)
;; A list form is never optional because it matches anything.
(edebug-&optional nil)
(edebug-&rest nil))
(edebug-gate t))
;; Skip the first offset.
(edebug-set-cursor cursor (edebug-cursor-expressions cursor)
(cdr (edebug-cursor-offsets cursor)))
@ -1586,11 +1591,6 @@ contains a circular object."
((symbolp head)
(cond
((null head) nil) ; () is valid.
((eq head 'interactive-p)
;; Special case: replace (interactive-p) with variable
(setq edebug-def-interactive 'check-it)
(edebug-move-cursor cursor)
(edebug-interactive-p-name))
(t
(cons head (edebug-list-form-args
head (edebug-move-cursor cursor))))))
@ -1628,7 +1628,7 @@ contains a circular object."
(setq edebug-error-point (or edebug-error-point
(edebug-before-offset cursor))
edebug-best-error (or edebug-best-error args))
(if (and edebug-gate (not edebug-&optional))
(if edebug-gate
(progn
(if edebug-error-point
(goto-char edebug-error-point))
@ -1639,13 +1639,11 @@ contains a circular object."
(defun edebug-match (cursor specs)
;; Top level spec matching function.
;; Used also at each lower level of specs.
(let (edebug-&optional
edebug-&rest
edebug-best-error
(let (edebug-best-error
edebug-error-point
(edebug-gate edebug-gate) ;; locally bound to limit effect
)
(edebug-match-specs cursor specs 'edebug-match-specs)))
(edebug-match-specs cursor specs #'edebug-match-specs)))
(defun edebug-match-one-spec (cursor spec)
@ -1687,7 +1685,7 @@ contains a circular object."
(first-char (and (symbolp spec) (aref (symbol-name spec) 0)))
(match (cond
((eq ?& first-char);; "&" symbols take all following specs.
(edebug--handle-&-spec-op spec cursor (cdr specs)))
(edebug--match-&-spec-op spec cursor (cdr specs)))
((eq ?: first-char);; ":" symbols take one following spec.
(setq rest (cdr (cdr specs)))
(edebug--handle-:-spec-op spec cursor (car (cdr specs))))
@ -1724,28 +1722,20 @@ contains a circular object."
(dolist (pair '((form . edebug-match-form)
(sexp . edebug-match-sexp)
(body . edebug-match-body)
(name . edebug-match-name)
(arg . edebug-match-arg)
(def-body . edebug-match-def-body)
(def-form . edebug-match-def-form)
;; Less frequently used:
;; (function . edebug-match-function)
(lambda-expr . edebug-match-lambda-expr)
(cl-generic-method-qualifier
. edebug-match-cl-generic-method-qualifier)
(cl-generic-method-args . edebug-match-cl-generic-method-args)
(cl-macrolet-expr . edebug-match-cl-macrolet-expr)
(cl-macrolet-name . edebug-match-cl-macrolet-name)
(cl-macrolet-body . edebug-match-cl-macrolet-body)
(place . edebug-match-place)
(gate . edebug-match-gate)
;; (nil . edebug-match-nil) not this one - special case it.
))
(put (car pair) 'edebug-form-spec (cdr pair)))
(put (car pair) 'edebug-elem-spec (cdr pair)))
(defun edebug-match-symbol (cursor symbol)
;; Match a symbol spec.
(let* ((spec (get-edebug-spec symbol)))
(let* ((spec (edebug--get-elem-spec symbol)))
(cond
(spec
(if (consp spec)
@ -1784,13 +1774,12 @@ contains a circular object."
(defsubst edebug-match-body (cursor) (edebug-forms cursor))
(cl-defmethod edebug--handle-&-spec-op ((_ (eql &optional)) cursor specs)
(cl-defmethod edebug--match-&-spec-op ((_ (eql &optional)) cursor specs)
;; Keep matching until one spec fails.
(edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper))
(edebug-&optional-wrapper cursor specs #'edebug-&optional-wrapper))
(defun edebug-&optional-wrapper (cursor specs remainder-handler)
(let (result
(edebug-&optional specs)
(edebug-gate nil)
(this-form (edebug-cursor-expressions cursor))
(this-offset (edebug-cursor-offsets cursor)))
@ -1805,24 +1794,24 @@ contains a circular object."
nil)))
(defun edebug-&rest-wrapper (cursor specs remainder-handler)
(if (null specs) (setq specs edebug-&rest))
;; Reuse the &optional handler with this as the remainder handler.
(edebug-&optional-wrapper cursor specs remainder-handler))
(cl-defgeneric edebug--handle-&-spec-op (op cursor specs)
(cl-defgeneric edebug--match-&-spec-op (op cursor specs)
"Handle &foo spec operators.
&foo spec operators operate on all the subsequent SPECS.")
(cl-defmethod edebug--handle-&-spec-op ((_ (eql &rest)) cursor specs)
(cl-defmethod edebug--match-&-spec-op ((_ (eql &rest)) cursor specs)
;; Repeatedly use specs until failure.
(let ((edebug-&rest specs) ;; remember these
edebug-best-error
(let (edebug-best-error
edebug-error-point)
(edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper)))
;; Reuse the &optional handler with this as the remainder handler.
(edebug-&optional-wrapper
cursor specs
(lambda (c s rh)
;; `s' is the remaining spec to match.
;; When it's nil, start over matching `specs'.
(edebug-&optional-wrapper c (or s specs) rh)))))
(cl-defmethod edebug--handle-&-spec-op ((_ (eql &or)) cursor specs)
(cl-defmethod edebug--match-&-spec-op ((_ (eql &or)) cursor specs)
;; Keep matching until one spec succeeds, and return its results.
;; If none match, fail.
;; This needs to be optimized since most specs spend time here.
@ -1846,24 +1835,48 @@ contains a circular object."
(apply #'edebug-no-match cursor "Expected one of" original-specs))
))
(cl-defmethod edebug--match-&-spec-op ((_ (eql &interpose)) cursor specs)
"Compute the specs for `&interpose SPEC FUN ARGS...'.
Extracts the head of the data by matching it against SPEC,
and then matches the rest by calling (FUN HEAD PF ARGS...)
where PF is the parsing function which FUN can call exactly once,
passing it the specs that it needs to match.
Note that HEAD will always be a list, since specs are defined to match
a sequence of elements."
(pcase-let*
((`(,spec ,fun . ,args) specs)
(exps (edebug-cursor-expressions cursor))
(instrumented-head (edebug-match-one-spec cursor spec))
(consumed (- (length exps)
(length (edebug-cursor-expressions cursor))))
(head (seq-subseq exps 0 consumed)))
(cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps)))
(apply fun `(,head
,(lambda (newspecs)
;; FIXME: What'd be the difference if we used
;; `edebug-match-sublist', which is what
;; `edebug-list-form-args' uses for the similar purpose
;; when matching "normal" forms?
(append instrumented-head (edebug-match cursor newspecs)))
,@args))))
(cl-defmethod edebug--handle-&-spec-op ((_ (eql &not)) cursor specs)
(cl-defmethod edebug--match-&-spec-op ((_ (eql &not)) cursor specs)
;; If any specs match, then fail
(if (null (catch 'no-match
(let ((edebug-gate nil))
(save-excursion
(edebug--handle-&-spec-op '&or cursor specs)))
(edebug--match-&-spec-op '&or cursor specs)))
nil))
;; This means something matched, so it is a no match.
(edebug-no-match cursor "Unexpected"))
;; This means nothing matched, so it is OK.
nil) ;; So, return nothing
(cl-defmethod edebug--handle-&-spec-op ((_ (eql &key)) cursor specs)
(cl-defmethod edebug--match-&-spec-op ((_ (eql &key)) cursor specs)
;; Following specs must look like (<name> <spec>) ...
;; where <name> is the name of a keyword, and spec is its spec.
;; This really doesn't save much over the expanded form and takes time.
(edebug--handle-&-spec-op
(edebug--match-&-spec-op
'&rest
cursor
(cons '&or
@ -1872,7 +1885,7 @@ contains a circular object."
(car (cdr pair))))
specs))))
(cl-defmethod edebug--handle-&-spec-op ((_ (eql &error)) cursor specs)
(cl-defmethod edebug--match-&-spec-op ((_ (eql &error)) cursor specs)
;; Signal an error, using the following string in the spec as argument.
(let ((error-string (car specs))
(edebug-error-point (edebug-before-offset cursor)))
@ -1941,19 +1954,15 @@ contains a circular object."
(defun edebug-match-sublist (cursor specs)
;; Match a sublist of specs.
(let (edebug-&optional
;;edebug-best-error
;;edebug-error-point
)
(prog1
;; match with edebug-match-specs so edebug-best-error is not bound.
(edebug-match-specs cursor specs 'edebug-match-specs)
(if (not (edebug-empty-cursor cursor))
(if edebug-best-error
(apply #'edebug-no-match cursor edebug-best-error)
;; A failed &rest or &optional spec may leave some args.
(edebug-no-match cursor "Failed matching" specs)
)))))
(prog1
;; match with edebug-match-specs so edebug-best-error is not bound.
(edebug-match-specs cursor specs 'edebug-match-specs)
(if (not (edebug-empty-cursor cursor))
(if edebug-best-error
(apply #'edebug-no-match cursor edebug-best-error)
;; A failed &rest or &optional spec may leave some args.
(edebug-no-match cursor "Failed matching" specs)
))))
(defun edebug-match-string (cursor spec)
@ -1976,7 +1985,7 @@ contains a circular object."
(defun edebug-match-function (_cursor)
(error "Use function-form instead of function in edebug spec"))
(cl-defmethod edebug--handle-&-spec-op ((_ (eql &define)) cursor specs)
(cl-defmethod edebug--match-&-spec-op ((_ (eql &define)) cursor specs)
;; Match a defining form.
;; Normally, &define is interpreted specially other places.
;; This should only be called inside of a spec list to match the remainder
@ -1990,45 +1999,61 @@ contains a circular object."
offsets)
specs))
(defun edebug-match-lambda-expr (cursor)
;; The expression must be a function.
;; This will match any list form that begins with a symbol
;; that has an edebug-form-spec beginning with &define. In
;; practice, only lambda expressions should be used.
;; I could add a &lambda specification to avoid confusion.
(let* ((sexp (edebug-top-element-required
cursor "Expected lambda expression"))
(offset (edebug-top-offset cursor))
(head (and (consp sexp) (car sexp)))
(spec (and (symbolp head) (get-edebug-spec head)))
(edebug-inside-func nil))
;; Find out if this is a defining form from first symbol.
(if (and (consp spec) (eq '&define (car spec)))
(prog1
(list
(edebug-defining-form
(edebug-new-cursor sexp offset)
(car offset);; before the sexp
(edebug-after-offset cursor)
(cons (symbol-name head) (cdr spec))))
(edebug-move-cursor cursor))
(edebug-no-match cursor "Expected lambda expression")
)))
(cl-defmethod edebug--match-&-spec-op ((_ (eql &name)) cursor specs)
"Compute the name for `&name SPEC FUN` spec operator.
The full syntax of that operator is:
&name [PRESTRING] SPEC [POSTSTRING] FUN ARGS...
(defun edebug-match-name (cursor)
;; Set the edebug-def-name bound in edebug-defining-form.
(let ((name (edebug-top-element-required cursor "Expected name")))
;; Maybe strings and numbers could be used.
(if (not (symbolp name))
(edebug-no-match cursor "Symbol expected for name of definition"))
(setq edebug-def-name
(if edebug-def-name
;; Construct a new name by appending to previous name.
(intern (format "%s@%s" edebug-def-name name))
name))
(edebug-move-cursor cursor)
(list name)))
Extracts the head of the data by matching it against SPEC,
and then get the new name to use by calling
(FUN ARGS... OLDNAME [PRESTRING] HEAD [POSTSTRING])
FUN should return either a string or a symbol.
FUN can be missing in which case it defaults to concatenating
the new name to the end of the old with an \"@\" char between the two.
PRESTRING and POSTSTRING are optional strings that get prepended
or appended to the actual name."
(pcase-let*
((`(,spec ,fun . ,args) specs)
(prestrings (when (stringp spec)
(prog1 (list spec) (setq spec fun fun (pop args)))))
(poststrings (when (stringp fun)
(prog1 (list fun) (setq fun (pop args)))))
(exps (edebug-cursor-expressions cursor))
(instrumented (edebug-match-one-spec cursor spec))
(consumed (- (length exps)
(length (edebug-cursor-expressions cursor))))
(newname (apply (or fun #'edebug--concat-name)
`(,@args ,edebug-def-name
,@prestrings
,@(seq-subseq exps 0 consumed)
,@poststrings))))
(cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps)))
(setq edebug-def-name (if (stringp newname) (intern newname) newname))
instrumented))
(defun edebug--concat-name (oldname &rest newnames)
(let ((newname (if (null (cdr newnames))
(car newnames)
;; Put spaces between each name, but not for the
;; leading and trailing strings, if any.
(let (beg mid end)
(dolist (name newnames)
(if (stringp name)
(push name (if mid end beg))
(when end (setq mid (nconc end mid) end nil))
(push name mid)))
(apply #'concat `(,@(nreverse beg)
,(mapconcat (lambda (x) (format "%s" x))
(nreverse mid) " ")
,@(nreverse end)))))))
(if (null oldname)
(if (or (stringp newname) (symbolp newname))
newname
(format "%s" newname))
(format "%s@%s" edebug-def-name newname))))
(def-edebug-elem-spec 'name '(&name symbolp))
(cl-defgeneric edebug--handle-:-spec-op (op cursor spec)
"Handle :foo spec operators.
@ -2054,63 +2079,6 @@ SPEC is the symbol name prefix for `gensym'."
suffix)))
nil)
(defun edebug-match-cl-generic-method-qualifier (cursor)
"Match a QUALIFIER for `cl-defmethod' at CURSOR."
(let ((args (edebug-top-element-required cursor "Expected qualifier")))
;; Like in CLOS spec, we support any non-list values.
(unless (atom args) (edebug-no-match cursor "Atom expected"))
;; Append the arguments to `edebug-def-name' (Bug#42671).
(setq edebug-def-name (intern (format "%s %s" edebug-def-name args)))
(edebug-move-cursor cursor)
(list args)))
(defun edebug-match-cl-generic-method-args (cursor)
(let ((args (edebug-top-element-required cursor "Expected arguments")))
(if (not (consp args))
(edebug-no-match cursor "List expected"))
;; Append the arguments to edebug-def-name.
(setq edebug-def-name
(intern (format "%s %s" edebug-def-name args)))
(edebug-move-cursor cursor)
(list args)))
(defvar edebug--cl-macrolet-defs nil
"List of symbols found within the bindings of enclosing `cl-macrolet' forms.")
(defvar edebug--current-cl-macrolet-defs nil
"List of symbols found within the bindings of the current `cl-macrolet' form.")
(defun edebug-match-cl-macrolet-expr (cursor)
"Match a `cl-macrolet' form at CURSOR."
(let (edebug--current-cl-macrolet-defs)
(edebug-match cursor
'((&rest (&define cl-macrolet-name cl-macro-list
cl-declarations-or-string
def-body))
cl-declarations cl-macrolet-body))))
(defun edebug-match-cl-macrolet-name (cursor)
"Match the name in a `cl-macrolet' binding at CURSOR.
Collect the names in `edebug--cl-macrolet-defs' where they
will be checked by `edebug-list-form-args' and treated as
macros without a spec."
(let ((name (edebug-top-element-required cursor "Expected name")))
(when (not (symbolp name))
(edebug-no-match cursor "Bad name:" name))
;; Change edebug-def-name to avoid conflicts with
;; names at global scope.
(setq edebug-def-name (gensym "edebug-anon"))
(edebug-move-cursor cursor)
(push name edebug--current-cl-macrolet-defs)
(list name)))
(defun edebug-match-cl-macrolet-body (cursor)
"Match the body of a `cl-macrolet' expression at CURSOR.
Put the definitions collected in `edebug--current-cl-macrolet-defs'
into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'."
(let ((edebug--cl-macrolet-defs (nconc edebug--current-cl-macrolet-defs
edebug--cl-macrolet-defs)))
(edebug-match-body cursor)))
(defun edebug-match-arg (cursor)
;; set the def-args bound in edebug-defining-form
(let ((edebug-arg (edebug-top-element-required cursor "Expected arg")))
@ -2139,151 +2107,135 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'."
;; This happens to handle bug#20281, tho maybe a better fix would be to
;; improve the `defun' spec.
(when forms
(list (edebug-wrap-def-body forms)))))
(list (edebug-make-enter-wrapper forms)))))
;;;; Edebug Form Specs
;;; ==========================================================
;;;;* Spec for def-edebug-spec
;;; Out of date.
(defun edebug-spec-p (object)
"Return non-nil if OBJECT is a symbol with an edebug-form-spec property."
(and (symbolp object)
(get object 'edebug-form-spec)))
(def-edebug-spec def-edebug-spec
;; Top level is different from lower levels.
(&define :name edebug-spec name
&or "nil" edebug-spec-p "t" "0" (&rest edebug-spec)))
(def-edebug-spec edebug-spec-list
;; A list must have something in it, or it is nil, a symbolp
((edebug-spec . [&or nil edebug-spec])))
(def-edebug-spec edebug-spec
(&or
edebug-spec-list
(vector &rest edebug-spec) ; matches a vector
("vector" &rest edebug-spec) ; matches a vector spec
("quote" symbolp)
stringp
[edebug-lambda-list-keywordp &rest edebug-spec]
[keywordp gate edebug-spec]
edebug-spec-p ;; Including all the special ones e.g. form.
symbolp;; a predicate
))
;;;* Emacs special forms and some functions.
;; quote expects only one argument, although it allows any number.
(def-edebug-spec quote sexp)
(pcase-dolist
(`(,name ,spec)
;; The standard defining forms.
(def-edebug-spec defconst defvar)
(def-edebug-spec defvar (symbolp &optional form stringp))
'((quote (sexp)) ;quote expects only one arg, tho it allows any number.
(def-edebug-spec defun
(&define name lambda-list lambda-doc
[&optional ("declare" &rest sexp)]
[&optional ("interactive" interactive)]
def-body))
(def-edebug-spec defmacro
;; FIXME: Improve `declare' so we can Edebug gv-expander and
;; gv-setter declarations.
(&define name lambda-list lambda-doc
[&optional ("declare" &rest sexp)] def-body))
;; The standard defining forms.
(defvar (symbolp &optional form stringp))
(defconst defvar)
(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list.
;; Contrary to macros, special forms default to assuming that all args
;; are normal forms, so we don't need to do anything about those
;; special forms:
;;(save-current-buffer t)
;;(save-excursion t)
;;...
;;(progn t)
(def-edebug-spec lambda-list
(([&rest arg]
[&optional ["&optional" arg &rest arg]]
&optional ["&rest" arg]
)))
;; `defun' and `defmacro' are not special forms (any more), but it's
;; more convenient to define their Edebug spec here.
(defun ( &define name lambda-list lambda-doc
[&optional ("declare" def-declarations)]
[&optional ("interactive" &optional [&or stringp def-form]
&rest symbolp)]
def-body))
(def-edebug-spec lambda-doc
(&optional [&or stringp
(&define ":documentation" def-form)]))
(defmacro ( &define name lambda-list lambda-doc
[&optional ("declare" def-declarations)]
def-body))
(def-edebug-spec interactive
(&optional &or stringp def-form))
;; function expects a symbol or a lambda or macro expression
;; A macro is allowed by Emacs.
(function (&or symbolp lambda-expr))
;; FIXME? The manual uses this form (maybe that's just
;; for illustration purposes?):
;; (let ((&rest &or symbolp (gate symbolp &optional form)) body))
(let ((&rest &or (symbolp &optional form) symbolp) body))
(let* let)
(setq (&rest symbolp form))
(cond (&rest (&rest form)))
(condition-case ( symbolp form
&rest ([&or symbolp (&rest symbolp)] body)))
(\` (backquote-form))
;; Assume immediate quote in unquotes mean backquote at next
;; higher level.
(\, (&or ("quote" edebug-\`) def-form))
(\,@ (&define ;; so (,@ form) is never wrapped.
&or ("quote" edebug-\`) def-form))
))
(put name 'edebug-form-spec spec))
(defun edebug--match-declare-arg (head pf)
(funcall pf (get (car head) 'edebug-declaration-spec)))
(def-edebug-elem-spec 'def-declarations
'(&rest &or (&interpose symbolp edebug--match-declare-arg) sexp))
(def-edebug-elem-spec 'lambda-list
'(([&rest arg]
[&optional ["&optional" arg &rest arg]]
&optional ["&rest" arg]
)))
(def-edebug-elem-spec 'lambda-expr
'(("lambda" &define lambda-list lambda-doc
[&optional ("interactive" interactive)]
def-body)))
(def-edebug-elem-spec 'arglist '(lambda-list)) ;; deprecated - use lambda-list.
(def-edebug-elem-spec 'lambda-doc
'(&optional [&or stringp
(&define ":documentation" def-form)]))
(def-edebug-elem-spec 'interactive '(&optional [&or stringp def-form]
&rest symbolp))
;; A function-form is for an argument that may be a function or a form.
;; This specially recognizes anonymous functions quoted with quote.
(def-edebug-spec function-form
(def-edebug-elem-spec 'function-form ;Deprecated, use `form'!
;; form at the end could also handle "function",
;; but recognize it specially to avoid wrapping function forms.
(&or ([&or "quote" "function"] &or symbolp lambda-expr) form))
;; function expects a symbol or a lambda or macro expression
;; A macro is allowed by Emacs.
(def-edebug-spec function (&or symbolp lambda-expr))
;; A macro expression is a lambda expression with "macro" prepended.
(def-edebug-spec macro (&define "lambda" lambda-list def-body))
;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro])))
;; Standard functions that take function-forms arguments.
;; FIXME? The manual uses this form (maybe that's just for illustration?):
;; (def-edebug-spec let
;; ((&rest &or symbolp (gate symbolp &optional form))
;; body))
(def-edebug-spec let
((&rest &or (symbolp &optional form) symbolp)
body))
(def-edebug-spec let* let)
(def-edebug-spec setq (&rest symbolp form))
(def-edebug-spec cond (&rest (&rest form)))
(def-edebug-spec condition-case
(symbolp
form
&rest ([&or symbolp (&rest symbolp)] body)))
(def-edebug-spec \` (backquote-form))
'(&or ([&or "quote" "function"] &or symbolp lambda-expr) form))
;; Supports quotes inside backquotes,
;; but only at the top level inside unquotes.
(def-edebug-spec backquote-form
(&or
;; Disallow instrumentation of , and ,@ inside a nested backquote, since
;; these are likely to be forms generated by a macro being debugged.
("`" nested-backquote-form)
([&or "," ",@"] &or ("quote" backquote-form) form)
;; The simple version:
;; (backquote-form &rest backquote-form)
;; doesn't handle (a . ,b). The straightforward fix:
;; (backquote-form . [&or nil backquote-form])
;; uses up too much stack space.
;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it.
(backquote-form [&rest [&not ","] backquote-form]
. [&or nil backquote-form])
;; If you use dotted forms in backquotes, replace the previous line
;; with the following. This takes quite a bit more stack space, however.
;; (backquote-form . [&or nil backquote-form])
(vector &rest backquote-form)
sexp))
(def-edebug-elem-spec 'backquote-form
'(&or
;; Disallow instrumentation of , and ,@ inside a nested backquote, since
;; these are likely to be forms generated by a macro being debugged.
("`" nested-backquote-form)
([&or "," ",@"] &or ("quote" backquote-form) form)
;; The simple version:
;; (backquote-form &rest backquote-form)
;; doesn't handle (a . ,b). The straightforward fix:
;; (backquote-form . [&or nil backquote-form])
;; uses up too much stack space.
;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it.
(backquote-form [&rest [&not ","] backquote-form]
. [&or nil backquote-form])
;; If you use dotted forms in backquotes, replace the previous line
;; with the following. This takes quite a bit more stack space, however.
;; (backquote-form . [&or nil backquote-form])
(vector &rest backquote-form)
sexp))
(def-edebug-spec nested-backquote-form
(&or
("`" &error "Triply nested backquotes (without commas \"between\" them) \
(def-edebug-elem-spec 'nested-backquote-form
'(&or
("`" &error "Triply nested backquotes (without commas \"between\" them) \
are too difficult to instrument")
;; Allow instrumentation of any , or ,@ contained within the (\, ...) or
;; (\,@ ...) matched on the next line.
([&or "," ",@"] backquote-form)
(nested-backquote-form [&rest [&not "," ",@"] nested-backquote-form]
. [&or nil nested-backquote-form])
(vector &rest nested-backquote-form)
sexp))
;; Allow instrumentation of any , or ,@ contained within the (\, ...) or
;; (\,@ ...) matched on the next line.
([&or "," ",@"] backquote-form)
(nested-backquote-form [&rest [&not "," ",@"] nested-backquote-form]
. [&or nil nested-backquote-form])
(vector &rest nested-backquote-form)
sexp))
;; Special version of backquote that instruments backquoted forms
;; destined to be evaluated, usually as the result of a
@ -2298,20 +2250,9 @@ are too difficult to instrument")
;; ,@ might have some problems.
(defalias 'edebug-\` '\`) ;; same macro as regular backquote.
(def-edebug-spec edebug-\` (def-form))
;; Assume immediate quote in unquotes mean backquote at next higher level.
(def-edebug-spec \, (&or ("quote" edebug-\`) def-form))
(def-edebug-spec \,@ (&define ;; so (,@ form) is never wrapped.
&or ("quote" edebug-\`) def-form))
;; New byte compiler.
(def-edebug-spec save-selected-window t)
(def-edebug-spec save-current-buffer t)
;; Anything else?
(defmacro edebug-\` (exp)
(declare (debug (def-form)))
(list '\` exp))
;;; The debugger itself
@ -2485,11 +2426,10 @@ STATUS should be a list returned by `edebug-var-status'."
(edebug-print-trace-after
(format "%s result: %s" function edebug-result)))))
(def-edebug-spec edebug-tracing (form body))
(defmacro edebug-tracing (msg &rest body)
"Print MSG in *edebug-trace* before and after evaluating BODY.
The result of BODY is also printed."
(declare (debug (form body)))
`(let ((edebug-stack-depth (1+ edebug-stack-depth))
edebug-result)
(edebug-print-trace-before ,msg)
@ -2921,7 +2861,6 @@ See `edebug-behavior-alist' for implementations.")
(defvar edebug-outside-match-data) ; match data outside of edebug
(defvar edebug-backtrace-buffer) ; each recursive edit gets its own
(defvar edebug-inside-windows)
(defvar edebug-interactive-p)
(defvar edebug-mode-map) ; will be defined fully later.
@ -2937,7 +2876,6 @@ See `edebug-behavior-alist' for implementations.")
;;(edebug-number-of-recursions (1+ edebug-number-of-recursions))
(edebug-recursion-depth (recursion-depth))
edebug-entered ; bind locally to nil
(edebug-interactive-p nil) ; again non-interactive
edebug-backtrace-buffer ; each recursive edit gets its own
;; The window configuration may be saved and restored
;; during a recursive-edit
@ -3601,7 +3539,10 @@ canceled the first time the function is entered."
;; Could store this in the edebug data instead.
(put function 'edebug-on-entry (if flag 'temp t)))
(defalias 'edebug-cancel-edebug-on-entry #'cancel-edebug-on-entry)
(define-obsolete-function-alias 'edebug-cancel-edebug-on-entry
#'edebug-cancel-on-entry "28.1")
(define-obsolete-function-alias 'cancel-edebug-on-entry
#'edebug-cancel-on-entry "28.1")
(defun edebug--edebug-on-entry-functions ()
(let ((functions nil))
@ -3613,7 +3554,7 @@ canceled the first time the function is entered."
obarray)
functions))
(defun cancel-edebug-on-entry (function)
(defun edebug-cancel-on-entry (function)
"Cause Edebug to not stop when FUNCTION is called.
The removes the effect of `edebug-on-entry'. If FUNCTION is is
nil, remove `edebug-on-entry' on all functions."
@ -3937,10 +3878,14 @@ be installed in `emacs-lisp-mode-map'.")
;; Autoloading these global bindings doesn't make sense because
;; they cannot be used anyway unless Edebug is already loaded and active.
(defvar global-edebug-prefix "\^XX"
(define-obsolete-variable-alias 'global-edebug-prefix
'edebug-global-prefix "28.1")
(defvar edebug-global-prefix "\^XX"
"Prefix key for global edebug commands, available from any buffer.")
(defvar global-edebug-map
(define-obsolete-variable-alias 'global-edebug-map
'edebug-global-map "28.1")
(defvar edebug-global-map
(let ((map (make-sparse-keymap)))
(define-key map " " 'edebug-step-mode)
@ -3973,9 +3918,9 @@ be installed in `emacs-lisp-mode-map'.")
map)
"Global map of edebug commands, available from any buffer.")
(when global-edebug-prefix
(global-unset-key global-edebug-prefix)
(global-set-key global-edebug-prefix global-edebug-map))
(when edebug-global-prefix
(global-unset-key edebug-global-prefix)
(global-set-key edebug-global-prefix edebug-global-map))
(defun edebug-help ()
@ -4237,7 +4182,8 @@ This should be a list of `edebug---frame' objects.")
(pop-to-buffer edebug-backtrace-buffer)
(unless (derived-mode-p 'backtrace-mode)
(backtrace-mode)
(add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source))
(add-hook 'backtrace-goto-source-functions
#'edebug--backtrace-goto-source nil t))
(setq edebug-instrumented-backtrace-frames
(backtrace-get-frames 'edebug-debugger
:constructor #'edebug--make-frame)
@ -4579,13 +4525,18 @@ With prefix argument, make it a temporary breakpoint."
(add-hook 'called-interactively-p-functions
#'edebug--called-interactively-skip)
(defun edebug--called-interactively-skip (i frame1 frame2)
(when (and (eq (car-safe (nth 1 frame1)) 'lambda)
(eq (nth 1 (nth 1 frame1)) '())
(eq (nth 1 frame2) 'edebug-enter))
(when (and (memq (car-safe (nth 1 frame1)) '(lambda closure))
;; Lambda value with no arguments.
(null (nth (if (eq (car-safe (nth 1 frame1)) 'lambda) 1 2)
(nth 1 frame1)))
(memq (nth 1 frame2) '(edebug-enter edebug-default-enter)))
;; `edebug-enter' calls itself on its first invocation.
(if (eq (nth 1 (backtrace-frame i 'called-interactively-p))
'edebug-enter)
2 1)))
(let ((s 1))
(while (memq (nth 1 (backtrace-frame i 'called-interactively-p))
'(edebug-enter edebug-default-enter))
(cl-incf s)
(cl-incf i))
s)))
;; Finally, hook edebug into the rest of Emacs.
;; There are probably some other things that could go here.

2
lisp/emacs-lisp/eieio-compat.el
View file

@ -105,7 +105,7 @@ Summary:
(declare (doc-string 3) (obsolete cl-defmethod "25.1")
(debug
(&define ; this means we are defining something
[&or name ("setf" name :name setf)]
[&name sexp] ;Allow (setf ...) additionally to symbols.
;; ^^ This is the methods symbol
[ &optional symbolp ] ; this is key :before etc
cl-generic-method-args ; arguments

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

@ -248,7 +248,8 @@ expression point is on." :lighter eldoc-minor-mode-string
#'elisp-eldoc-var-docstring nil t)
(add-hook 'eldoc-documentation-functions
#'elisp-eldoc-funcall nil t)
(setq eldoc-documentation-strategy 'eldoc-documentation-default)))
(setq-local eldoc-documentation-strategy
'eldoc-documentation-default)))
(eldoc-mode +1))
;;;###autoload

4
lisp/emacs-lisp/ert.el
View file

@ -196,8 +196,8 @@ it has to be wrapped in `(eval (quote ...))'.
\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
[:tags \\='(TAG...)] BODY...)"
(declare (debug (&define :name test
name sexp [&optional stringp]
(declare (debug (&define [&name "test@" symbolp]
sexp [&optional stringp]
[&rest keywordp sexp] def-body))
(doc-string 3)
(indent 2))

12
lisp/emacs-lisp/gv.el
View file

@ -187,6 +187,13 @@ arguments as NAME. DO is a function as defined in `gv-get'."
(push (list 'gv-setter #'gv--setter-defun-declaration)
defun-declarations-alist))
;;;###autoload
(let ((spec (get 'compiler-macro 'edebug-declaration-spec)))
;; It so happens that it's the same spec for gv-* as for compiler-macros.
;; '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body))
(put 'gv-expander 'edebug-declaration-spec spec)
(put 'gv-setter 'edebug-declaration-spec spec))
;; (defmacro gv-define-expand (name expander)
;; "Use EXPANDER to handle NAME as a generalized var.
;; NAME is a symbol: the name of a function, macro, or special form.
@ -224,7 +231,8 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression
which can do arbitrary things, whereas the other arguments are all guaranteed
to be pure and copyable. Example use:
(gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))"
(declare (indent 2) (debug (&define name :name gv-setter sexp def-body)))
(declare (indent 2)
(debug (&define [&name symbolp "@gv-setter"] sexp def-body)))
`(gv-define-expander ,name
(lambda (do &rest args)
(declare-function
@ -307,7 +315,7 @@ The return value is the last VAL in the list.
;; Autoload this `put' since a user might use C-u C-M-x on an expression
;; containing a non-trivial `push' even before gv.el was loaded.
;;;###autoload
(put 'gv-place 'edebug-form-spec 'edebug-match-form)
(put 'gv-place 'edebug-form-spec '(form)) ;So-called "indirect spec".
;; CL did the equivalent of:
;;(gv-define-macroexpand edebug-after (lambda (before index place) place))

50
lisp/emacs-lisp/macroexp.el
View file

@ -299,7 +299,12 @@ Assumes the caller has bound `macroexpand-all-environment'."
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare))
(macroexp--cons fun
(macroexp--cons (macroexp--all-clauses bindings 1)
(macroexp--all-forms body)
(if (null body)
(macroexp-unprogn
(macroexp--warn-and-return
(format "Empty %s body" fun)
nil t))
(macroexp--all-forms body))
(cdr form))
form))
(`(,(and fun `(lambda . ,_)) . ,args)
@ -572,20 +577,35 @@ test of free variables in the following ways:
- For the same reason it may cause the result to fail to include bindings
which will be used if SEXP is not yet fully macro-expanded and the
use of the binding will only be revealed by macro expansion."
(let ((res '()))
(while (and (consp sexp) bindings)
(dolist (binding (macroexp--fgrep bindings (pop sexp)))
(push binding res)
(setq bindings (remove binding bindings))))
(if (or (vectorp sexp) (byte-code-function-p sexp))
;; With backquote, code can appear within vectors as well.
;; This wouldn't be needed if we `macroexpand-all' before
;; calling macroexp--fgrep, OTOH.
(macroexp--fgrep bindings (mapcar #'identity sexp))
(let ((tmp (assq sexp bindings)))
(if tmp
(cons tmp res)
res)))))
(let ((res '())
;; Cyclic code should not happen, but code can contain cyclic data :-(
(seen (make-hash-table :test #'eq))
(sexpss (list (list sexp))))
;; Use a nested while loop to reduce the amount of heap allocations for
;; pushes to `sexpss' and the `gethash' overhead.
(while (and sexpss bindings)
(let ((sexps (pop sexpss)))
(unless (gethash sexps seen)
(puthash sexps t seen) ;; Using `setf' here causes bootstrap problems.
(if (vectorp sexps) (setq sexps (mapcar #'identity sexps)))
(let ((tortoise sexps) (skip t))
(while sexps
(let ((sexp (if (consp sexps) (pop sexps)
(prog1 sexps (setq sexps nil)))))
(if skip
(setq skip nil)
(setq tortoise (cdr tortoise))
(if (eq tortoise sexps)
(setq sexps nil) ;; Found a cycle: we're done!
(setq skip t)))
(cond
((or (consp sexp) (vectorp sexp)) (push sexp sexpss))
(t
(let ((tmp (assq sexp bindings)))
(when tmp
(push tmp res)
(setq bindings (remove tmp bindings))))))))))))
res))
;;; Load-time macro-expansion.

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

@ -27,19 +27,10 @@
;; Todo:
;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
;; use x, because x is bound separately for the equality constraint
;; (as well as any pred/guard) and for the body, so uses at one place don't
;; count for the other.
;; - provide ways to extend the set of primitives, with some kind of
;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
;; But better would be if we could define new ways to match by having the
;; extension provide its own `pcase--split-<foo>' thingy.
;; - along these lines, provide patterns to match CL structs.
;; - Allow to provide new `pcase--split-<foo>' thingy.
;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound.
;; - provide a way to fallthrough to subsequent cases
;; - provide a way to continue matching to subsequent cases
;; (e.g. Like Racket's (=> ID).
;; - try and be more clever to reduce the size of the decision tree, and
;; to reduce the number of leaves that need to be turned into functions:
@ -71,48 +62,37 @@
(defvar pcase--dontwarn-upats '(pcase--dontcare))
(def-edebug-spec
pcase-PAT
(&or symbolp
("or" &rest pcase-PAT)
("and" &rest pcase-PAT)
("guard" form)
("let" pcase-PAT form)
("pred" pcase-FUN)
("app" pcase-FUN pcase-PAT)
pcase-MACRO
sexp))
(def-edebug-elem-spec 'pcase-PAT
'(&or (&interpose symbolp pcase--edebug-match-pat-args) sexp))
(def-edebug-spec
pcase-FUN
(&or lambda-expr
;; Punt on macros/special forms.
(functionp &rest form)
sexp))
;; See bug#24717
(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro)
(def-edebug-elem-spec 'pcase-FUN
'(&or lambda-expr
;; Punt on macros/special forms.
(functionp &rest form)
sexp))
;; Only called from edebug.
(declare-function get-edebug-spec "edebug" (symbol))
(declare-function edebug-match "edebug" (cursor specs))
(declare-function edebug-get-spec "edebug" (symbol))
(defun pcase--edebug-match-pat-args (head pf)
;; (cl-assert (null (cdr head)))
(setq head (car head))
(or (alist-get head '((quote sexp)
(or &rest pcase-PAT)
(and &rest pcase-PAT)
(guard form)
(pred &or ("not" pcase-FUN) pcase-FUN)
(app pcase-FUN pcase-PAT)))
(let ((me (pcase--get-macroexpander head)))
(funcall pf (and me (symbolp me) (edebug-get-spec me))))))
(defun pcase--get-macroexpander (s)
"Return the macroexpander for pcase pattern head S, or nil"
(get s 'pcase-macroexpander))
(defun pcase--edebug-match-macro (cursor)
(let (specs)
(mapatoms
(lambda (s)
(let ((m (pcase--get-macroexpander s)))
(when (and m (get-edebug-spec m))
(push (cons (symbol-name s) (get-edebug-spec m))
specs)))))
(edebug-match cursor (cons '&or specs))))
;;;###autoload
(defmacro pcase (exp &rest cases)
;; FIXME: Add some "global pattern" to wrap every case?
;; Could be used to wrap all cases in a `
"Evaluate EXP to get EXPVAL; try passing control to one of CASES.
CASES is a list of elements of the form (PATTERN CODE...).
For the first CASE whose PATTERN \"matches\" EXPVAL,
@ -946,14 +926,13 @@ Otherwise, it defers to REST which is a list of branches of the form
(t (error "Unknown pattern `%S'" upat)))))
(t (error "Incorrect MATCH %S" (car matches)))))
(def-edebug-spec
pcase-QPAT
(def-edebug-elem-spec 'pcase-QPAT
;; Cf. edebug spec for `backquote-form' in edebug.el.
(&or ("," pcase-PAT)
(pcase-QPAT [&rest [&not ","] pcase-QPAT]
. [&or nil pcase-QPAT])
(vector &rest pcase-QPAT)
sexp))
'(&or ("," pcase-PAT)
(pcase-QPAT [&rest [&not ","] pcase-QPAT]
. [&or nil pcase-QPAT])
(vector &rest pcase-QPAT)
sexp))
(pcase-defmacro \` (qpat)
"Backquote-style pcase patterns: \\=`QPAT
@ -1002,7 +981,13 @@ The predicate is the logical-AND of:
(pcase-defmacro let (pat expr)
"Matches if EXPR matches PAT."
(declare (debug (pcase-PAT form)))
`(app (lambda (_) ,expr) ,pat))
;; (pcase-defmacro guard (expr)
;; "Matches if EXPR is non-nil."
;; (declare (debug (form)))
;; `(pred (lambda (_) ,expr)))
(provide 'pcase)
;;; pcase.el ends here

1
lisp/emacs-lisp/seq.el
View file

@ -455,6 +455,7 @@ negative integer or 0, nil is returned."
(setq sequence (seq-drop sequence n)))
(nreverse result))))
;;;###autoload
(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn)
"Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."