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

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

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)

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

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."

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))
+          (load (package--autoloads-file-name pkg-desc) nil t)))
-        (add-to-list 'load-path (directory-file-name pkg-dir)))
       ;; Add info node.
       (when (file-exists-p (expand-file-name "dir" pkg-dir))
         ;; FIXME: not the friendliest, but simple.

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.

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.
+	   ;; be leading ANSI control escape sequences, which must be
-	   ;; Busyboxes built with the EDITING_ASK_TERMINAL config
+	   ;; ignored.  Busyboxes built with the EDITING_ASK_TERMINAL
-	   ;; option send also escape sequences, which must be
+	   ;; config option send also ANSI control escape sequences,
-	   ;; ignored.
+	   ;; which must be ignored.
 	   (regexp (rx
 		    (* (not (any "#$\n")))
 		    (literal tramp-end-of-output)

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

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