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)) ()