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)))
|