[Sbcl-commits] sbcl/src/compiler ir1-translators.lisp, 1.97, 1.98 macros.lisp, 1.65, 1.66

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory vz-cvs-3.sog:/tmp/cvs-serv26374/src/compiler

Modified Files:
	ir1-translators.lisp macros.lisp 
Log Message:
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.


Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/macros.lisp,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -d -r1.65 -r1.66
--- macros.lisp	21 Jun 2009 10:26:25 -0000	1.65
+++ macros.lisp	8 Apr 2011 13:11:56 -0000	1.66
@@ -983,3 +983,19 @@
         (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))))

Index: ir1-translators.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v
retrieving revision 1.97
retrieving revision 1.98
diff -u -d -r1.97 -r1.98
--- ir1-translators.lisp	8 Apr 2011 13:02:27 -0000	1.97
+++ ir1-translators.lisp	8 Apr 2011 13:11:56 -0000	1.98
@@ -595,11 +595,15 @@
   (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)))