[armedbear-cvs] r14067 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Thu Aug  9 02:19:40 2012
New Revision: 14067

Log:
Fix declarations being dropped on inline expansions.

Report by James M. Lawrence.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Wed Aug  8 14:49:40 2012	(r14066)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Thu Aug  9 02:19:40 2012	(r14067)
@@ -528,7 +528,8 @@
             ;; FIXME Need to support SETF functions too!
             (setf (inline-expansion name)
                   (jvm::generate-inline-expansion block-name
-                                                  lambda-list body))
+                                                  lambda-list
+                                                  (append decls body)))
             (output-form `(setf (inline-expansion ',name)
                                 ',(inline-expansion name))))))
     (push name jvm::*functions-defined-in-current-file*)

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Wed Aug  8 14:49:40 2012	(r14066)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Thu Aug  9 02:19:40 2012	(r14067)
@@ -48,17 +48,26 @@
   "Generates code that can be used to expand a named local function inline.
 It can work either per-function (no args provided) or per-call."
   (if args-p
-      (expand-function-call-inline nil lambda-list
-                                   (copy-tree `((block ,name , at body)))
-                                   args)
+      (multiple-value-bind
+            (body decls)
+          (parse-body body)
+        (expand-function-call-inline nil lambda-list
+                                     ;; the forms below get wrapped
+                                     ;; in a LET, making the decls
+                                     ;; part of the decls of the LET.
+                                     (copy-tree `(, at decls (block ,name , at body)))
+                                     args))
       (cond ((intersection lambda-list
                            '(&optional &rest &key &allow-other-keys &aux)
                            :test #'eq)
              nil)
             (t
-             (setf body (copy-tree body))
-             (list 'LAMBDA lambda-list
-                   (list* 'BLOCK name body))))))
+             (multiple-value-bind
+                   (body decls)
+                 (parse-body body)
+               (setf body (copy-tree body))
+               `(lambda ,lambda-list , at decls
+                        (block ,name , at body)))))))
 
 
 ;;; Pass 1.