From cf53854d42d4e260459896cb0c4b071608398b96 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 12 Jan 2020 21:11:09 +0100
Subject: Fix peval bug that ignored excess args

* module/language/tree-il/peval.scm (peval): Fix arity check for type
  confusion (empty value of "rest" in this context was (), not #f).  The
  effect was that we'd silently allow extra arguments to inlined calls.
  Thanks to Christopher Lam for the report!  Fixes #38617.
* test-suite/tests/peval.test ("partial evaluation"): Add a test.
---
 module/language/tree-il/peval.scm |  2 +-
 test-suite/tests/peval.test       | 21 +++++++++++++++++++--
 2 files changed, 20 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index f11640fa5..b400c71a7 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1457,7 +1457,7 @@ top-level bindings from ENV and return the resulting expression."
                                             opt-vals)))))
 
               (cond
-               ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
+               ((or (< nargs nreq) (and (null? rest) (> nargs (+ nreq nopt))))
                 ;; An error, or effecting arguments.
                 (make-call src (for-call orig-proc) (map for-value orig-args)))
                ((or (and=> (find-counter key counter) counter-recursive?)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 22b78f66f..2eecc8218 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; 	Copyright (C) 2009-2014, 2017 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009-2014, 2017, 2020 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1415,4 +1415,21 @@
                         (call (lexical lp _)
                               (lexical x* _))))))))
              (call (lexical lp _)
-                   (lexical x _))))))))
+                   (lexical x _)))))))
+
+  (pass-if-peval
+      (lambda ()
+        (define (add1 n) (+ 1 n))
+        (add1 1 2))
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ())
+        (fix (add1)
+             (_)
+             ((lambda ((name . add1))
+                (lambda-case
+                 (((n) #f #f #f () (_))
+                  (primcall + (const 1) (lexical n _))))))
+             (call (lexical add1 _)
+                   (const 1)
+                   (const 2))))))))
-- 
cgit v1.2.1