[elpa] externals/compat be3a2d7: Handle further TCO edge-cases and add tests

[ELPA Syncer]

branch: externals/compat
commit be3a2d749027c7fdb5f20b75aad905a2ac006821
Author: Philip Kaludercic <philipk@posteo.net>
Commit: Philip Kaludercic <philipk@posteo.net>

    Handle further TCO edge-cases and add tests
    
    Thanks once more to Mattias Engdegård for recognizing these potential
    issues.
---
 compat-28.1.el  | 31 ++++++++++++++++---------------
 compat-tests.el | 14 ++++++++++++++
 2 files changed, 30 insertions(+), 15 deletions(-)

diff --git a/compat-28.1.el b/compat-28.1.el
index f251127..a722129 100644
--- a/compat-28.1.el
+++ b/compat-28.1.el
@@ -413,7 +413,7 @@ as the new values of the bound variables in the recursive 
invocation."
          (total-tco t)
          (macro (lambda (&rest args)
                   (setq total-tco nil)
-                  `(apply ,self (list ,@args))))
+                  `(funcall ,self . ,args)))
          ;; Based on `cl--self-tco':
          (tco-progn (lambda (exprs)
                       (append
@@ -427,18 +427,19 @@ as the new values of the bound variables in the recursive 
invocation."
                                 (funcall tco (caddr expr)))
                           (funcall tco-progn (cdddr expr))))
                  ((eq (car-safe expr) 'cond)
-                  (let ((last-branch (car (last expr))))
-                    (cons 'cond
-                          (mapcar
-                           (lambda (branch)
-                             (cond
-                              ((cdr branch)
-                               (funcall tco-progn branch))
-                              ((and (eq (car-safe (car branch)) name)
-                                    (eq last-branch branch))
-                               (list t (funcall tco (car branch))))
-                              (branch)))
-                           (cdr expr)))))
+                  (let ((conds (cdr expr)) body)
+                    (while conds
+                      (let ((branch (pop conds)))
+                        (push (cond
+                               ((cdr branch) ;has tail
+                                (funcall tco-progn branch))
+                               ((null conds) ;last element
+                                (list t (funcall tco (car branch))))
+                               ((progn
+                                  (message "=> %S" branch)
+                                  branch)))
+                              body)))
+                    (cons 'cond (nreverse body))))
                  ((eq (car-safe expr) 'or)
                   (if (cddr expr)
                       (let ((var (make-symbol "var")))
@@ -459,9 +460,9 @@ as the new values of the bound variables in the recursive 
invocation."
                   (append (list (car expr) (cadr expr))
                           (funcall tco-progn (cddr expr))))
                  ((eq (car-safe expr) name)
-                  (let (sets)
+                  (let (sets (args (cdr expr)))
                     (dolist (farg fargs)
-                      (push (list farg (pop (cdr expr)))
+                      (push (list farg (pop args))
                             sets))
                     (cons 'setq (apply #'nconc (nreverse sets)))))
                  (`(throw ',quit ,expr))))))
diff --git a/compat-tests.el b/compat-tests.el
index fea0a12..0f2b9a1 100644
--- a/compat-tests.el
+++ b/compat-tests.el
@@ -1230,6 +1230,20 @@ the compatibility function."
                  ((= x 0) 'ok)
                  ((loop -1))
                  ((loop (1- x)))))
+              'ok))
+  (should (eq (compat--named-let loop ((x 10000))
+                (cond ((= x 0) 'ok)
+                      ((and t (loop (1- x))))))
+              'ok))
+  (should (eq (eval
+               (let ((branch '((loop (and (setq b (not b)) (1+ i))))))
+                 `(let ((b t))
+                    (compat--named-let loop ((i 0))
+                      (cond ((null i) nil)
+                            ((= i 10000) 'ok)
+                            ,branch
+                            ,branch))))
+               t)
               'ok)))
 
 (ert-deftest compat-directory-name-p ()