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 895e1ac33e4d6c80a57204e48cccbccc68c3d486..5345e20bfc0458602503434dd5b8ae0cb36ee2ca 100644 (file)
--- 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 7f70fc2460c70ab91f710b2be84f3c11efefe421..a2663eaf9cfc53feab3bee95696fae32685dc950 100644 (file)
--- 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))
+
 \f
 ;;;;;;;;;;;;;;;;;;;;
 ;; Tromey's tests ;;

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index eeff599de4c491f32b37619154b470c23cc3b011..0594a4e086c585fc7cac79e9231e8ef997b6198d 100644 (file)
--- 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."