From 3b47f87618047ebb8812788c64a44877a4f2e0dd Mon Sep 17 00:00:00 2001
From: Daniel Llorens <lloda@sarc.name>
Date: Thu, 23 Feb 2023 17:38:10 +0100
Subject: peval reduces some inlined case-lambda calls

* module/language/tree-il/peval.scm (peval): Reduce multiple case lambda
  in <call> trees according to the number of arguments. Do not try to
  reduce case-lambda using keyword arguments.
* test-suite/tests/peval.test: Tests.
---
 module/language/tree-il/peval.scm | 23 +++++++++++++
 test-suite/tests/peval.test       | 72 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 95 insertions(+)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 7945fd9b9..7c05e9a2e 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1668,6 +1668,29 @@ top-level bindings from ENV and return the resulting expression."
 
                   (log 'inline-end result exp)
                   result)))))
+           (($ <lambda> src-proc meta orig-body)
+            ;; If there are multiple cases and one matches nargs, omit all the others.
+            (or (and
+                 (lambda-case-alternate orig-body)
+                 (let ((nargs (length orig-args)))
+                   (let loop ((body orig-body))
+                     (match body
+                       (#f #f) ;; No matching case; an error.
+                       (($ <lambda-case> src-case req opt rest kw inits gensyms case-body alt)
+                        (cond (kw
+                               ;; FIXME: Not handling keyword cases.
+                               #f)
+                              ((let ((nreq (length req)))
+                                 (if rest
+                                   (<= nreq nargs)
+                                   (<= nreq nargs (+ nreq (if opt (length opt) 0)))))
+                               ;; Keep only this case.
+                               (revisit-proc
+                                (make-lambda
+                                 src-proc meta
+                                 (make-lambda-case src-case req opt rest kw inits gensyms case-body #f))))
+                              (else (loop alt))))))))
+                (make-call src (for-call orig-proc) (map for-value orig-args))))
            (($ <let> _ _ _ vals _)
             ;; Attempt to inline `let' in the operator position.
             ;;
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index a2e4975d9..8a8f0124a 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1456,6 +1456,78 @@
     ;; <https://bugs.gnu.org/60522>.
     (primcall make-vector)))
 
+(with-test-prefix "case-lambda"
+  ;; one case
+  (pass-if-peval
+   ((case-lambda (() 0)))
+   (const 0))
+
+  ;; middle
+  (pass-if-peval
+   ((case-lambda (() 0) ((a b) 1) ((a) 2)) 1 2)
+   (const 1))
+
+  ;; last
+  (pass-if-peval
+   ((case-lambda ((a b) 0) ((a) 1) (() 2)))
+   (const 2))
+
+  ;; first
+  (pass-if-peval
+   ((case-lambda ((a) 0) (() 1) ((a b) 2)) 1)
+   (const 0))
+
+  ;; rest arg
+  (pass-if-peval
+   ((case-lambda (args 0) ((a b) 1) ((a) 2)) 1 2)
+   (const 0))
+
+  ;; req before rest I
+  (pass-if-peval
+   ((case-lambda ((a b) 0) (args 1) ((a) 1)) 1 2)
+   (const 0))
+
+  ;; req before rest II
+  (pass-if-peval
+   ((case-lambda ((a) 0) (args 1) ((a b) 2)) 1 2)
+   (const 1))
+
+  ;; optional
+  (pass-if-peval
+   ((case-lambda* ((a #:optional x) 0) (args 1) ((a) 2)) 1 2)
+   (const 0))
+
+  ;; optional and rest, no match I
+  (pass-if-peval
+   ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)))
+   (const 1))
+
+  ;; optional and rest, match I
+  (pass-if-peval
+   ((case-lambda* (() 0) ((a #:optional x . rest) 1) ((a) 2)) 1)
+   (const 1))
+
+  ;; optional and rest, match II
+  (pass-if-peval
+   ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1)
+   (const 0))
+
+  ;; optional and rest, match III
+  (pass-if-peval
+   ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1 2)
+   (const 0))
+
+  ;; optional and rest, match IV
+  (pass-if-peval
+   ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1 2 3)
+   (const 0))
+
+  ;; keyword cases survive
+  (pass-if (= 1 ((case-lambda* ((a b) 0) ((a #:key x) 1)) 0 #:x 1)))
+  (pass-if (= 0 ((case-lambda* ((a b c) 0) ((a #:key x) 1)) 0 #:x 1)))
+  (pass-if (= 0 ((case-lambda* ((a #:key x) 0) ((a b) 0)) 0 #:x 1)))
+  (pass-if (= 1 ((case-lambda* ((a #:key x) 0) ((a b c) 1)) 0 1 2))))
+
 (with-test-prefix "eqv?"
   (pass-if-peval (eqv? x #f)
     (primcall eq? (toplevel x) (const #f)))
-- 
cgit v1.2.1