From: Andrea Corallo <akrl@sdf.org>
Date: Sat, 19 Dec 2020 10:56:15 +0000 (+0100)
Subject: Fix `comp-add-call-cstr' and add a test
X-Git-Tag: emacs-28.0.90~2727^2~238
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5376563517f2235b8b79f661c213fd74dd62b654;p=emacs.git

Fix `comp-add-call-cstr' and add a test

	* lisp/emacs-lisp/comp.el (comp-add-call-cstr): Fix it.
	* test/src/comp-tests.el (assume-in-loop-1): New test.
	* test/src/comp-test-funcs.el (comp-test-assume-in-loop-1-f): New
	function.
---

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 895e1ac33e4..5345e20bfc0 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -2017,21 +2017,24 @@ TARGET-BB-SYM is the symbol name of the target block."
                  (pcase insn
                    (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args))
                     (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
-                      (cl-values cstr-f lhs args)))
+                      (cl-values f cstr-f lhs args)))
                    (`(,(pred comp-call-op-p) ,f . ,args)
                     (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
-                      (cl-values cstr-f nil args))))))
-       (cl-multiple-value-bind (cstr-f lhs args) match
+                      (cl-values f cstr-f nil args))))))
+       (cl-multiple-value-bind (f cstr-f lhs args) match
          (cl-loop
+          with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f))
           for arg in args
-          for gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f))
           for cstr = (funcall gen)
           for target = (comp-cond-cstrs-target-mvar arg insn bb)
+          unless (comp-cstr-p cstr)
+            do (signal 'native-ice
+                       (list "Incoherent type specifier for function" f))
           when (and target
                     (or (null lhs)
                         (not (eql (comp-mvar-slot lhs)
                                   (comp-mvar-slot target)))))
-          do (comp-emit-call-cstr target insn-cell cstr)))))))
+            do (comp-emit-call-cstr target insn-cell cstr)))))))
 
 (defun comp-add-cstrs (_)
   "Rewrite conditional branches adding appropriate 'assume' insns.
diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el
index 7f70fc2460c..a2663eaf9cf 100644
--- a/test/src/comp-test-funcs.el
+++ b/test/src/comp-test-funcs.el
@@ -405,6 +405,18 @@
       ;; collection is t, not (member t)!
       (member value collection)))
 
+(defun comp-test-assume-in-loop-1-f (arg)
+  ;; Reduced from `comint-delim-arg'.
+  (let ((args nil)
+	(pos 0)
+	(len (length arg)))
+    (while (< pos len)
+      (let ((start pos))
+	(while (< pos len)
+	  (setq pos (1+ pos)))
+	(setq args (cons (substring arg start pos) args))))
+    args))
+
 
 ;;;;;;;;;;;;;;;;;;;;
 ;; Tromey's tests ;;
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index eeff599de4c..0594a4e086c 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -405,6 +405,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
   "In fwprop assumtions (not (not (member x))) /= (member x)."
   (should-not (comp-test-assume-double-neg-f "bar" "foo")))
 
+(comp-deftest assume-in-loop-1 ()
+  "Broken call args assumptions lead to infinite loop."
+  (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd"))))
+
 (defvar comp-test-primitive-advice)
 (comp-deftest primitive-advice ()
   "Test effectiveness of primitive advicing."