diff --git a/compiler/dfo.lisp b/compiler/dfo.lisp
index 7f1846cabf99c69de01600d7667de9f04d811072..c0617d87b682bfae1c586cd09af935040d3079ed 100644
--- a/compiler/dfo.lisp
+++ b/compiler/dfo.lisp
@@ -246,14 +246,39 @@
 	     (funs calls (rest funs)))
 	    ((null funs) res)
 	  (declare (type component res))))))))
+
+
+;;; FIND-TOP-LEVEL-COMPONENTS  --  Internal
+;;;
+;;;    Compute the result of FIND-INITIAL-DFO given the list of all resulting
+;;; components.  We find components that contain a :Top-Level lambda, marking
+;;; them as :Top-Level.
+;;;
+(defun find-top-level-components (components)
+  (declare (list components))
+  (collect ((real)
+	    (top))
+    (dolist (com components)
+      (unless (eq (block-next (component-head com)) (component-tail com))
+	(let ((funs (component-lambdas com)))
+	  (cond ((find :top-level funs :key #'functional-kind)
+		 (assert (not (find :external funs :key #'functional-kind)))
+		 (setf (component-kind com) :top-level)
+		 (setf (component-name com) "Top-Level Form")
+		 (top com))
+		(t
+		 (setf (component-name com) (find-component-name com))
+		 (real com))))))
+    (values (real) (top))))
 	    
 
 ;;; Find-Initial-DFO  --  Interface
 ;;;
-;;;    Given a list of top-level lambdas, return a list of components
-;;; representing the actual component division.  We assign the DFO for each
-;;; component, and delete any unreachable blocks.  We assume that the Flags
-;;; have already been cleared.
+;;;    Given a list of top-level lambdas, return two lists of components
+;;; representing the actual component division.  The first value is the
+;;; non-top-level components, and the second is the top-level ones.  We assign
+;;; the DFO for each component, and delete any unreachable blocks.  We assume
+;;; that the Flags have already been cleared.
 ;;;
 ;;;     We iterate over the lambdas in each initial component, trying to put
 ;;; each function in its own component, but joining it to an existing component
@@ -266,11 +291,7 @@
 ;;; left will be in deleted functions or not reachable from the entry to the
 ;;; function.
 ;;;
-;;;   We also find components that contain a :Top-Level lambda and no :External
-;;; lambdas, marking them as :Top-Level.  Top-Level components are returned at
-;;; the end of the list so that we compile all real functions before we start
-;;; compiling any Top-Level references to them.  This allows DEFUN, etc., to
-;;; reference functions not in their component (which is normally forbidden).
+;;;    We then call FIND-TOP-LEVEL-COMPONENTS to pull out top-level code.
 ;;;
 (defun find-initial-dfo (lambdas)
   (declare (list lambdas))
@@ -289,22 +310,91 @@
       
 	  (do-blocks (block component)
 	    (delete-block block)))))
+
+    (dolist (com (components))
+      (let ((num 0))
+	(declare (fixnum num))
+	(do-blocks-backwards (block com :both)
+	  (setf (block-number block) (incf num)))))
+
+    (find-top-level-components (components))))
+
+
+;;; MERGE-TOP-LEVEL-LAMBDAS  --  Interface
+;;;
+;;;    Given a non-empty list of top-level lambdas, smash them into a top-level
+;;; lambda and component, returning these as values.  We use the first lambda
+;;; and its component, putting the other code in that component and deleting
+;;; the other lambdas.  We depend on there being at least a reference to NIL
+;;; preceding the RETURN node in each top-level lambda.
+;;;
+(defun merge-top-level-lambdas (lambdas)
+  (declare (cons lambdas))
+  (let* ((result-lambda (first lambdas))
+	 (result-component
+	  (block-component (node-block (lambda-bind result-lambda))))
+	 (result-return (lambda-return result-lambda)))
+    (let ((pnode (continuation-use
+		  (node-prev
+		   (continuation-use (return-result result-return)))))
+	  (new (make-continuation)))
+      (node-ends-block pnode)
+      (delete-continuation-use pnode)
+      (add-continuation-use pnode new))
+
+    (let ((result-return-block (node-block result-return)))
+      (dolist (lambda (rest lambdas))
+	(dolist (let (lambda-lets lambda))
+	  (setf (lambda-home let) result-lambda)
+	  (push let (lambda-lets result-lambda)))
+
+	(setf (lambda-entries result-lambda)
+	      (nconc (lambda-entries result-lambda)
+		     (lambda-entries lambda)))
+
+	(let* ((bind (lambda-bind lambda))
+	       (bind-block (node-block bind))
+	       (return (lambda-return lambda))
+	       (return-block (node-block return))
+	       (result (return-result return))
+	       (component (block-component bind-block)))
+
+	  (do-blocks (block component)
+	    (setf (block-component block) result-component)
+	    (macrolet ((frob (slot)
+			 `(when (eq (,slot block) lambda)
+			    (setf (,slot block) result-lambda))))
+	      (frob block-lambda)
+	      (frob block-start-cleanup)
+	      (frob block-end-cleanup)))
+
+	  (let* ((head (component-head component))
+		 (first (block-next head))
+		 (tail (component-tail component))
+		 (last (block-prev tail))
+		 (prev (block-prev result-return-block)))
+	    (setf (block-next prev) first)
+	    (setf (block-prev first) prev)
+	    (setf (block-next last) result-return-block)
+	    (setf (block-prev result-return-block) last)
+	    (dolist (succ (block-succ head))
+	      (unlink-blocks head succ))
+	    (dolist (pred (block-pred tail))
+	      (unlink-blocks pred tail)))
+
+	  (assert (every #'(lambda (x)
+			     (eq (functional-kind x) :top-level))
+			 (component-lambdas component)))
+
+	  (dolist (pred (block-pred result-return-block))
+	    (unlink-blocks pred result-return-block)
+	    (link-blocks pred bind-block))
+
+	  (setf (block-last return-block) (continuation-use result))
+	  (flush-dest result)
+	  (delete-continuation result)
+	  (link-blocks return-block result-return-block)
+
+	  (unlink-node bind))))
     
-    (collect ((real)
-	      (top))
-      (dolist (com (components))
-	(let ((num 0))
-	  (declare (fixnum num))
-	  (do-blocks-backwards (block com :both)
-	    (setf (block-number block) (incf num)))
-	  (unless (= num 2)
-	    (setf (component-name com) (find-component-name com))
-	    (let ((funs (component-lambdas com)))
-	      (cond ((find :top-level funs :key #'functional-kind)
-		     (unless (find :external funs :key #'functional-kind)
-		       (setf (component-kind com) :top-level)
-		       (setf (component-name com) "Top-Level Form"))
-		     (top com))
-		    (t
-		     (real com)))))))
-      (nconc (real) (top)))))
+    (values result-component result-lambda)))