feature/native-comp 5376563 17/19: Fix `comp-add-call-cstr' and add a test

[Andrea Corallo]

branch: feature/native-comp
commit 5376563517f2235b8b79f661c213fd74dd62b654
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>

    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.
---
 lisp/emacs-lisp/comp.el     | 13 ++++++++-----
 test/src/comp-test-funcs.el | 12 ++++++++++++
 test/src/comp-tests.el      |  4 ++++
 3 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 895e1ac..5345e20 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 7f70fc2..a2663ea 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 eeff599..0594a4e 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."