From 36f410ec7f2ca6aa327f2ffa799e50c9516b833f Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 17 Oct 1990 19:14:19 +0000
Subject: [PATCH] Changed top-level component hackery to deal with components
 that had both normal XEPs and top-level lambdas.  In addition to being
 included in the normal components list, these components are also returned as
 a list in the third value.

---
 compiler/dfo.lisp | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/compiler/dfo.lisp b/compiler/dfo.lisp
index 022cebca2..acb15de6c 100644
--- a/compiler/dfo.lisp
+++ b/compiler/dfo.lisp
@@ -251,25 +251,30 @@
 ;;; 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.
+;;; components.  We find components that contain a :Top-Level lambda.  If there
+;;; is no normal XEP, then we mark the component as :Top-Level.  If there is a
+;;; :Top-Level lambda, and also a normal XEP, then we treat the component as
+;;; normal, but also return such components in a list as the third value.
 ;;;
 (defun find-top-level-components (components)
   (declare (list components))
   (collect ((real)
-	    (top))
+	    (top)
+	    (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)))
+	(let* ((funs (component-lambdas com))
+	       (has-top (find :top-level funs :key #'functional-kind)))
+	  (cond ((and has-top
+		      (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))))
+		 (real com)
+		 (when has-top (real-top com)))))))
+    (values (real) (top) (real-top))))
 	    
 
 ;;; Find-Initial-DFO  --  Interface
-- 
GitLab