X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=9658ac82084b908b6564d3cfd32fc0e9e0a5b01a;hb=2287399f246955badf9d61bf123145e76eaf884d;hp=7b68ff8f282bbf0a9b8e6f18d87ebe630e454c52;hpb=36a379d746b9eb74ba8c5afff40dc5dcb9f4557a;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 7b68ff8..9658ac8 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -611,7 +611,10 @@
            (destructuring-bind (name . thing) var
              (declare (ignore name))
              (etypecase thing
-               (leaf nil)
+               ;; The evaluator will mark lexicals with :BOGUS when it
+               ;; translates an interpreter lexenv to a compiler
+               ;; lexenv.
+               ((or leaf #!+sb-eval (member :bogus)) nil)
                (cons (aver (eq (car thing) 'macro))
                      t)
                (heap-alien-info nil)))))
@@ -1422,7 +1425,7 @@
 ;;; of arguments changes, the transform must be prepared to return a
 ;;; lambda with a new lambda-list with the correct number of
 ;;; arguments.
-(defun extract-fun-args (lvar fun num-args)
+(defun splice-fun-args (lvar fun num-args)
   #!+sb-doc
   "If LVAR is a call to FUN with NUM-ARGS args, change those arguments
    to feed directly to the LVAR-DEST of LVAR, which must be a
@@ -1459,6 +1462,22 @@
           (flush-dest lvar)
           (values))))))
 
+(defun extract-fun-args (lvar fun num-args)
+  (declare (type lvar lvar)
+           (type (or symbol list) fun)
+           (type index num-args))
+  (let ((fun (if (listp fun) fun (list fun))))
+    (let ((inside (lvar-uses lvar)))
+      (unless (combination-p inside)
+        (give-up-ir1-transform))
+      (let ((inside-fun (combination-fun inside)))
+        (unless (member (lvar-fun-name inside-fun) fun)
+          (give-up-ir1-transform))
+        (let ((inside-args (combination-args inside)))
+          (unless (= (length inside-args) num-args)
+            (give-up-ir1-transform))
+          (values (lvar-fun-name inside-fun) inside-args))))))
+
 (defun flush-combination (combination)
   (declare (type combination combination))
   (flush-dest (combination-fun combination))