From 4983ccfd9857b5f82578578ff16eb54e65a8d2ac Mon Sep 17 00:00:00 2001
From: Sean Maher <spvw@google.com>
Date: Tue, 25 May 2021 19:32:16 +0000
Subject: [PATCH] Fix over-eager check for proper-list in IR1-CONVERT

Instead of a single check in IR1-CONVERT, define
CHOKE-ON-NON-PROPER-LIST and call it in the cases where we do not have
a macro (a combination, transform, srctran). This allows definition of
macros which take improper lists.
---
 src/compiler/ir1tran.lisp     | 25 +++++++++++++++++++------
 tests/compiler.pure.lisp      | 11 +++++++++--
 tests/macroexpand.impure.lisp |  6 ++++++
 3 files changed, 34 insertions(+), 8 deletions(-)

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index c5b38bb8b..137191da0 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -63,11 +63,20 @@
             form))
       form))
 
+
 (defun note-source-path (form &rest arguments)
   (when (source-form-has-path-p form)
     (setf (gethash form *source-paths*)
           (apply #'list* 'original-source-start *current-form-number* arguments))))
 
+;;; CHOKE-ON-NON-PROPER-LIST is called in certain cases of
+;;; ir1-convert-* to make sure a non-proper list is not passed to a
+;;; non-macro
+(defun choke-on-non-proper-list (form)
+  (if (not (proper-list-p form))
+      (compiler-error "~@<~S is not a proper list.~@:>" form)
+      form))
+
 ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link
 ;;; blocks into as we generate them. This just serves to glue the
 ;;; emitted blocks together until local call analysis and flow graph
@@ -633,8 +642,6 @@
                       (reference-leaf start next result form))
                      (t
                       (reference-constant start next result form))))
-              ((not (proper-list-p form))
-               (compiler-error "~@<~S is not a proper list.~@:>" form))
               (t
                (ir1-convert-functoid start next result form)))))
     (values))
@@ -823,7 +830,8 @@
   (let* ((op (car form))
          (translator (and (symbolp op) (info :function :ir1-convert op))))
     (if translator
-        (funcall translator start next result form)
+        (funcall translator start next result
+                 (choke-on-non-proper-list form))
         (multiple-value-bind (res cmacro-fun-name)
                (expand-compiler-macro form)
              (cond ((eq res form)
@@ -1042,7 +1050,7 @@
     (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun))
     (let ((combination
            (ir1-convert-combination-args fun-lvar ctran next result
-                                         (cdr form))))
+                                         (cdr (choke-on-non-proper-list form)))))
       (when (step-form-p form)
         ;; Store a string representation of the form in the
         ;; combination node. This will let the IR2 translator know
@@ -1113,7 +1121,9 @@
                       (struct-fun-transform transform form name))
                 ;; Note that "pass" means fail. Gotta love it.
                 (cond (pass
-                       (ir1-convert-maybe-predicate start next result form var))
+                       (ir1-convert-maybe-predicate start next result
+                                                    (choke-on-non-proper-list form)
+                                                    var))
                       (t
                        (unless (policy *lexenv* (zerop store-xref-data))
                          (record-call name (ctran-block start) *current-path*))
@@ -1121,7 +1131,10 @@
                          (show-transform "src" name transformed))
                        (let ((*transforming* t))
                          (ir1-convert start next result transformed)))))
-              (ir1-convert-maybe-predicate start next result form var))))))
+              (ir1-convert-maybe-predicate start next result
+                                           (choke-on-non-proper-list form)
+                                           var))))))
+
 
 ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE
 ;;; attribute, don't generate any branch coverage instrumentation for it.
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 9bdbc591f..6292c45d6 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -6171,8 +6171,15 @@
              (assert (search "is not a proper list."
                              (princ-to-string (first compiler-errors)))))))
     (test '(cons 1 . 2))
-    (test '((lambda (x) x) . 1))
-    (test '(let () . 1))))
+    (test '((lambda (x) x) . 3))
+    (test '(let () . 4))))
+(with-test (:name (compile :macro-dotted-list))
+  (checked-compile-and-assert ()
+      `(lambda (i j)
+         (macrolet ((k (a . b)
+                      `(+ ,a ,b)))
+           (k i . j)))
+    ((1 2) 3)))
 
 (with-test (:name (ldb :rlwinm))
   (checked-compile-and-assert ()
diff --git a/tests/macroexpand.impure.lisp b/tests/macroexpand.impure.lisp
index e034e691d..8edc4adea 100644
--- a/tests/macroexpand.impure.lisp
+++ b/tests/macroexpand.impure.lisp
@@ -385,3 +385,9 @@
     (assert (and (vectorp constant1) (vectorp constant2)))
     (assert (equal (funcall f 'o) '(o p)))
     (assert (eql (funcall f 42) -1))))
+
+(defmacro macro-with-dotted-list (&rest args)
+  args)
+(with-test (:name :macro-with-dotted-list)
+  (let ((expansion (macroexpand '(macro-with-dotted-list . 1))))
+    (assert (equal expansion 1))))
-- 
2.31.1.818.g46aad6cb9e-goog