[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/android 769d3e17c2b: Merge remote-tracking branch 'origin/master
|
From: |
Po Lu |
|
Subject: |
feature/android 769d3e17c2b: Merge remote-tracking branch 'origin/master' into feature/android |
|
Date: |
Tue, 23 May 2023 20:25:36 -0400 (EDT) |
branch: feature/android
commit 769d3e17c2bb76a8bb6c604ac1a88e373a1a1c8c
Merge: 1145572af27 9ad997cd689
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>
Merge remote-tracking branch 'origin/master' into feature/android
---
lisp/emacs-lisp/cl-macs.el | 1 +
lisp/emacs-lisp/cl-preloaded.el | 1 +
lisp/emacs-lisp/comp-cstr.el | 49 +++++++++++++++++++++++++++++++++++++++--
lisp/emacs-lisp/comp.el | 30 +++++++++++++++++++++----
lisp/emacs-lisp/package.el | 3 +--
lisp/loadup.el | 2 +-
lisp/net/tramp-sh.el | 9 ++++----
lisp/net/tramp.el | 15 ++++++-------
test/src/comp-tests.el | 36 +++++++++++++++++++++++++++++-
9 files changed, 123 insertions(+), 23 deletions(-)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 8fdafe18c50..6590b1baa1e 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -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 ())
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 5235be52996..f410270d340 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -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)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index d4200c16c19..e9132552506 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -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
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 2e07b0b0e60..8e59c06d40e 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -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."
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 78017b77677..3d3158111b2 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -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.
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 0a28c0592d0..e01a6d1d640 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -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.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index d4933ad7ba6..0b3ce07d275 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -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)
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index f986d65d944..b27465a98fa 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -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)))))
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 4682cac450e..673a9342f1f 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -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)) ()