From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 8 Apr 2011 13:11:56 +0000 (+0000)
Subject: 1.0.47.17: %FUNCALL IR1 translator was careless about FUNCTION argcount
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=92d1243a970f638b286c3689df16b32c3049cfe0;p=sbcl.git

1.0.47.17: %FUNCALL IR1 translator was careless about FUNCTION argcount

  This allowed forms such as (FUNCALL (FUNCTION FOO OOPS) ...) to
  compile without complaint.

  Fix line-wrapping in NEWS for the last couple of commits.
---

diff --git a/NEWS b/NEWS
index 17e3c94..c524c5d 100644
--- a/NEWS
+++ b/NEWS
@@ -9,10 +9,12 @@ changes relative to sbcl-1.0.47:
   * optimization: slightly faster ISQRT. (lp#713343)
   * bug fix: TRACE behaves better when attempting to trace undefined
     functions. (lp#740717)
-  * bug fix: missed optimizations for (FUNCALL (LAMBDA ...) ...) in
-    comparison to (FUNCALL #'(LAMBDA ...) ...).
-  * bug fix: ((LAMBDA ...) ...) forms with invalid argument counts
-    resulted in a compile-time error. (lp#720382)
+  * bug fix: missed optimizations for (FUNCALL (LAMBDA ...) ...) in comparison
+    to (FUNCALL #'(LAMBDA ...) ...).
+  * bug fix: ((LAMBDA ...) ...) forms with invalid argument counts resulted in
+    a compile-time error. (lp#720382)
+  * bug fix: forms such as (FUNCALL (FUNCTION NAME OOPS) ...) were compiled
+    without complaints.
 
 changes in sbcl-1.0.47 relative to sbcl-1.0.46:
   * bug fix: fix mach port rights leaks in mach exception handling code on
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 79c2afc..b0b2600 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -595,11 +595,15 @@ be a lambda expression."
   (let* ((function (sb!xc:macroexpand function *lexenv*))
          (op (when (consp function) (car function))))
     (cond ((eq op 'function)
-           (with-fun-name-leaf (leaf (second function) start)
-             (ir1-convert start next result `(,leaf ,@args))))
+           (compiler-destructuring-bind (thing) (cdr function)
+               function
+             (with-fun-name-leaf (leaf thing start)
+               (ir1-convert start next result `(,leaf ,@args)))))
           ((eq op 'global-function)
-           (with-fun-name-leaf (leaf (second function) start :global-function t)
-             (ir1-convert start next result `(,leaf ,@args))))
+           (compiler-destructuring-bind (thing) (cdr function)
+               global-function
+             (with-fun-name-leaf (leaf thing start :global-function t)
+               (ir1-convert start next result `(,leaf ,@args)))))
           (t
            (let ((ctran (make-ctran))
                  (fun-lvar (make-lvar)))
diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 66b034d..48af2fb 100644
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -983,3 +983,19 @@ specify bindings for printer control variables.")
         (nreverse (mapcar #'car *compiler-print-variable-alist*))
         (nreverse (mapcar #'cdr *compiler-print-variable-alist*))
       ,@forms)))
+
+;;; Like DESTRUCTURING-BIND, but generates a COMPILER-ERROR on failure
+(defmacro compiler-destructuring-bind (lambda-list thing context
+                                       &body body)
+  (let ((whole-name (gensym "WHOLE")))
+    (multiple-value-bind (body local-decls)
+        (parse-defmacro lambda-list whole-name body nil
+                        context
+                        :anonymousp t
+                        :doc-string-allowed nil
+                        :wrap-block nil
+                        :error-fun 'compiler-error)
+      `(let ((,whole-name ,thing))
+         (declare (type list ,whole-name))
+         ,@local-decls
+         ,body))))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index ba8d33f..51068be 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3811,6 +3811,20 @@
                   (handler-case (funcall f 0)
                     (error () :error)))))))
 
+(with-test (:name :multiple-args-to-function)
+  (let ((form `(flet ((foo (&optional (x 13)) x))
+                 (funcall (function foo 42))))
+        (*evaluator-mode* :interpret))
+    (assert (eq :error
+                (handler-case (eval form)
+                  (error () :error))))
+    (multiple-value-bind (fun warn fail)
+        (compile nil `(lambda () ,form))
+      (assert (and warn fail))
+          (assert (eq :error
+                      (handler-case (funcall fun)
+                        (error () :error)))))))
+
 ;;; This doesn't test LVAR-FUN-IS directly, but captures it
 ;;; pretty accurately anyways.
 (with-test (:name :lvar-fun-is)
diff --git a/version.lisp-expr b/version.lisp-expr
index a7909c4..b2b3147 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.47.16"
+"1.0.47.17"