mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-23 22:20:24 -08:00
Merge remote-tracking branch 'savannah/master' into native-comp
This commit is contained in:
Andrea Corallo
commit
a8b8d220b4
180 changed files with 2211 additions and 1237 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -2362,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
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
;;
|
||||
|
|
@ -245,7 +245,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 +268,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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -200,42 +200,54 @@
|
|||
res))
|
||||
|
||||
(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)
|
||||
|
|
@ -765,6 +775,7 @@ or to switch back to an existing one."
|
|||
(setq-local find-tag-default-function 'lisp-find-tag-default)
|
||||
(setq-local comment-start-skip
|
||||
"\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *")
|
||||
(setq-local comment-end "|#")
|
||||
(setq imenu-case-fold-search t))
|
||||
|
||||
(defun lisp-find-tag-default ()
|
||||
|
|
|
|||
|
|
@ -241,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
|
||||
|
|
@ -257,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
|
||||
|
|
@ -360,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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
(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))
|
||||
;; 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
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; FIXME: Convert to ERT and move to `test/'?
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'testcover)
|
||||
|
||||
(defvar ses-initial-global-parameters)
|
||||
(defvar ses-mode-map)
|
||||
|
||||
(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")
|
||||
|
||||
(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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue