mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-05 22:20:24 -08:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into feature/android

Browse source
This commit is contained in:
Po Lu 2023-05-24 08:25:20 +08:00
commit 769d3e17c2
9 changed files with 123 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -3249,6 +3249,7 @@ To see the documentation for a defined struct type, use
;;; Add cl-struct support to pcase
;;In use by comp.el
(defun cl--struct-all-parents (class)
(when (cl--struct-class-p class)
(let ((res ())

1
lisp/emacs-lisp/cl-preloaded.el
View file

@ -113,6 +113,7 @@ supertypes from the most specific to least specific.")
(record 'cl-slot-descriptor
name initform type props)))
;; In use by comp.el
(defun cl--struct-get-class (name)
(or (if (not (symbolp name)) name)
(cl--find-class name)

49
lisp/emacs-lisp/comp-cstr.el
View file

@ -86,7 +86,35 @@ Integer values are handled in the `range' slot.")
(ret nil :type (or comp-cstr comp-cstr-f)
:documentation "Returned value."))
(defun comp--cl-class-hierarchy (x)
"Given a class name `x' return its hierarchy."
`(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents
(cl--struct-get-class x)))
atom
t))
(defun comp--all-classes ()
"Return all non built-in type names currently defined."
(let (res)
(mapatoms (lambda (x)
(when (cl-find-class x)
(push x res)))
obarray)
res))
(cl-defstruct comp-cstr-ctxt
(typeof-types (append comp--typeof-builtin-types
(mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
:type list
:documentation "Type hierarchy.")
(pred-type-h (cl-loop with h = (make-hash-table :test #'eq)
for class-name in (comp--all-classes)
for pred = (get class-name 'cl-deftype-satisfies)
when pred
do (puthash pred class-name h)
finally return h)
:type hash-table
:documentation "Hash pred -> type.")
(union-typesets-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
`comp-union-typesets'.")
@ -230,7 +258,7 @@ Return them as multiple value."
(cl-loop
named outer
with found = nil
for l in comp--typeof-builtin-types
for l in (comp-cstr-ctxt-typeof-types comp-ctxt)
do (cl-loop
for x in l
for i from (length l) downto 0
@ -273,7 +301,7 @@ Return them as multiple value."
(cl-loop
with types = (apply #'append typesets)
with res = '()
for lane in comp--typeof-builtin-types
for lane in (comp-cstr-ctxt-typeof-types comp-ctxt)
do (cl-loop
with last = nil
for x in lane
@ -867,6 +895,23 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
(null (neg cstr))
(equal (typeset cstr) '(cons)))))
;; Move to comp.el?
(defsubst comp-cstr-cl-tag-p (cstr)
"Return non-nil if CSTR is a CL tag."
(with-comp-cstr-accessors
(and (null (range cstr))
(null (neg cstr))
(null (typeset cstr))
(length= (valset cstr) 1)
(string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags")
(symbol-name (car (valset cstr)))))))
(defsubst comp-cstr-cl-tag (cstr)
"If CSTR is a CL tag return its tag name."
(with-comp-cstr-accessors
(and (comp-cstr-cl-tag-p cstr)
(intern (match-string 1 (symbol-name (car (valset cstr))))))))
(defun comp-cstr-= (dst op1 op2)
"Constraint OP1 being = OP2 setting the result into DST."
(with-comp-cstr-accessors

30
lisp/emacs-lisp/comp.el
View file

@ -641,11 +641,14 @@ Useful to hook into pass checkers.")
(defun comp-known-predicate-p (predicate)
"Return t if PREDICATE is known."
(when (gethash predicate comp-known-predicates-h) t))
(when (or (gethash predicate comp-known-predicates-h)
(gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))
t))
(defun comp-pred-to-cstr (predicate)
"Given PREDICATE, return the corresponding constraint."
(gethash predicate comp-known-predicates-h))
(or (gethash predicate comp-known-predicates-h)
(gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
(defconst comp-symbol-values-optimizable '(most-positive-fixnum
most-negative-fixnum)
@ -1540,7 +1543,7 @@ STACK-OFF is the index of the first slot frame involved."
for sp from stack-off
collect (comp-slot-n sp))))
(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg)
"`comp-mvar' initializer."
(let ((mvar (make--comp-mvar :slot slot)))
(when const-vld
@ -1548,6 +1551,8 @@ STACK-OFF is the index of the first slot frame involved."
(setf (comp-cstr-imm mvar) constant))
(when type
(setf (comp-mvar-typeset mvar) (list type)))
(when neg
(setf (comp-mvar-neg mvar) t))
mvar))
(defun comp-new-frame (size vsize &optional ssa)
@ -2543,6 +2548,19 @@ TARGET-BB-SYM is the symbol name of the target block."
for insns-seq on (comp-block-insns b)
do
(pcase insns-seq
(`((set ,(and (pred comp-mvar-p) mvar-tested-copy)
,(and (pred comp-mvar-p) mvar-tested))
(set ,(and (pred comp-mvar-p) mvar-1)
(call type-of ,(and (pred comp-mvar-p) mvar-tested-copy)))
(set ,(and (pred comp-mvar-p) mvar-2)
(call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
(set ,(and (pred comp-mvar-p) mvar-3)
(call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
(cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
(push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)))
(comp-block-insns (comp-add-cond-cstrs-target-block b bb2)))
(push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t))
(comp-block-insns (comp-add-cond-cstrs-target-block b bb1))))
(`((set ,(and (pred comp-mvar-p) cmp-res)
(,(pred comp-call-op-p)
,(and (or (pred comp-equality-fun-p)
@ -3198,7 +3216,11 @@ Fold the call in case."
(+ (comp-cstr-add lval args))
(- (comp-cstr-sub lval args))
(1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one)))
(1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))))))
(1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))
(record (when (comp-cstr-imm-vld-p (car args))
(comp-cstr-shallow-copy lval
(comp-type-spec-to-cstr
(comp-cstr-imm (car args)))))))))
(defun comp-fwprop-insn (insn)
"Propagate within INSN."

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

@ -901,8 +901,7 @@ correspond to previously loaded files."
(when reload
(package--reload-previously-loaded pkg-desc))
(with-demoted-errors "Error loading autoloads: %s"
(load (package--autoloads-file-name pkg-desc) nil t))
(add-to-list 'load-path (directory-file-name pkg-dir)))
(load (package--autoloads-file-name pkg-desc) nil t)))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.

2
lisp/loadup.el
View file

@ -103,7 +103,7 @@
;; During bootstrapping the byte-compiler is run interpreted
;; when compiling itself, which uses a lot more stack
;; than usual.
(setq max-lisp-eval-depth 2200)))
(setq max-lisp-eval-depth 3400)))
(if (eq t purify-flag)
;; Hash consing saved around 11% of pure space in my tests.

9
lisp/net/tramp-sh.el
View file

@ -4316,7 +4316,6 @@ seconds. If not, it produces an error message with the given ERROR-ARGS."
proc timeout
(rx
(| (regexp shell-prompt-pattern) (regexp tramp-shell-prompt-pattern))
(? (regexp ansi-color-control-seq-regexp))
eos))
(error
(delete-process proc)
@ -5294,10 +5293,10 @@ function waits for output unless NOOUTPUT is set."
(tramp-error proc 'file-error "Process `%s' not available, try again" proc))
(with-current-buffer (process-buffer proc)
(let* (;; Initially, `tramp-end-of-output' is "#$ ". There might
;; be leading escape sequences, which must be ignored.
;; Busyboxes built with the EDITING_ASK_TERMINAL config
;; option send also escape sequences, which must be
;; ignored.
;; be leading ANSI control escape sequences, which must be
;; ignored. Busyboxes built with the EDITING_ASK_TERMINAL
;; config option send also ANSI control escape sequences,
;; which must be ignored.
(regexp (rx
(* (not (any "#$\n")))
(literal tramp-end-of-output)

15
lisp/net/tramp.el
View file

@ -697,7 +697,7 @@ See also `tramp-yesno-prompt-regexp'."
(defcustom tramp-terminal-type "dumb"
"Value of TERM environment variable for logging in to remote host.
Because Tramp wants to parse the output of the remote shell, it is easily
confused by ANSI color escape sequences and suchlike. Often, shell init
confused by ANSI control escape sequences and suchlike. Often, shell init
files conditionalize this setup based on the TERM environment variable."
:group 'tramp
:type 'string)
@ -5709,18 +5709,17 @@ Wait, until the connection buffer changes."
"Wait for output from the shell and perform one action.
See `tramp-process-actions' for the format of ACTIONS."
(let ((case-fold-search t)
(shell-prompt-pattern
(rx (regexp shell-prompt-pattern)
(? (regexp ansi-color-control-seq-regexp))))
(tramp-shell-prompt-pattern
(rx (regexp tramp-shell-prompt-pattern)
(? (regexp ansi-color-control-seq-regexp))))
tramp-process-action-regexp
found todo item pattern action)
(while (not found)
;; Reread output once all actions have been performed.
;; Obviously, the output was not complete.
(while (tramp-accept-process-output proc))
;; Remove ANSI control escape sequences.
(with-current-buffer (tramp-get-connection-buffer vec)
(goto-char (point-min))
(while (re-search-forward ansi-color-control-seq-regexp nil t)
(replace-match "")))
(setq todo actions)
(while todo
(setq item (pop todo)
@ -6280,7 +6279,7 @@ to cache the result. Return the modified ATTR."
(with-tramp-file-property ,vec ,localname "file-attributes"
(when-let ((attr ,attr))
(save-match-data
;; Remove color escape sequences from symlink.
;; Remove ANSI control escape sequences from symlink.
(when (stringp (car attr))
(while (string-match ansi-color-control-seq-regexp (car attr))
(setcar attr (replace-match "" nil nil (car attr)))))

36
test/src/comp-tests.el
View file

@ -875,6 +875,8 @@ Return a list of results."
ret-type))))
(cl-eval-when (compile eval load)
(cl-defstruct comp-foo a b)
(cl-defstruct (comp-bar (:include comp-foo)) c)
(defconst comp-tests-type-spec-tests
;; Why we quote everything here, you ask? So that values of
;; `most-positive-fixnum' and `most-negative-fixnum', which can be
@ -1404,7 +1406,39 @@ Return a list of results."
(if (eq x 0)
(error "")
(1+ x)))
'number)))
'number)
;; 75
((defun comp-tests-ret-type-spec-f ()
(make-comp-foo))
'comp-foo)
;; 76
((defun comp-tests-ret-type-spec-f ()
(make-comp-bar))
'comp-bar)
;; 77
((defun comp-tests-ret-type-spec-f (x)
(setf (comp-foo-a x) 2)
x)
'comp-foo)
;; 78
((defun comp-tests-ret-type-spec-f (x)
(if x
(if (> x 11)
x
(make-comp-foo))
(make-comp-bar)))
'(or comp-foo float (integer 12 *)))
;; 79
((defun comp-tests-ret-type-spec-f (x)
(if (comp-foo-p x)
x
(error "")))
'comp-foo)))
(defun comp-tests-define-type-spec-test (number x)
`(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()