From b298a0f12990865eef974ec23a67a17849374f53 Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Thu, 1 Mar 2001 21:45:36 +0000
Subject: [PATCH] This set of changes fixes EVAL-WHEN to work according to the
 ANSI spec.

---
 code/eval.lisp        | 17 +++---------
 compiler/eval.lisp    | 15 +++--------
 compiler/ir1tran.lisp | 60 ++++++++++++++++---------------------------
 compiler/main.lisp    |  5 ++--
 4 files changed, 31 insertions(+), 66 deletions(-)

diff --git a/code/eval.lisp b/code/eval.lisp
index 553daf452..8a0da779a 100644
--- a/code/eval.lisp
+++ b/code/eval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.31 2000/08/10 10:55:23 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.32 2001/03/01 21:45:33 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -127,12 +127,6 @@
 ;;;; EVAL and friends.
 (in-package "LISP")
 
-;;;
-;;; This flag is used by EVAL-WHEN to keep track of when code has already been
-;;; evaluated so that it can avoid multiple evaluation of nested EVAL-WHEN
-;;; (COMPILE)s.
-(defvar *already-evaled-this* nil)
-
 ;;;
 ;;; This needs to be initialized in the cold load, since the top-level catcher
 ;;; will always restore the initial value.
@@ -151,9 +145,7 @@
 
 ;;; EVAL  --  Public
 ;;;
-;;;    Pick off a few easy cases, and call INTERNAL-EVAL for the rest.  If
-;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing a call
-;;; so that the effect is confined to the lexical scope of the EVAL-WHEN.
+;;;    Pick off a few easy cases, and call INTERNAL-EVAL for the rest.
 ;;;
 (defun eval (original-exp)
   "Evaluates its single arg in a null lexical environment, returns the
@@ -249,10 +241,7 @@
 		(collect ((args))
 		  (dolist (arg (rest exp))
 		    (args (eval arg)))
-		  (if *already-evaled-this*
-		      (let ((*already-evaled-this* nil))
-			(apply (symbol-function name) (args)))
-		      (apply (symbol-function name) (args))))
+		  (apply (symbol-function name) (args)))
 		(eval:internal-eval original-exp))))))
       (t
        exp))))
diff --git a/compiler/eval.lisp b/compiler/eval.lisp
index d77d98dd2..cd1afc2e0 100644
--- a/compiler/eval.lisp
+++ b/compiler/eval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.33 2000/09/26 16:38:57 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.34 2001/03/01 21:45:34 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -625,23 +625,14 @@
   (setf *internal-apply-node-trace* on))
 
 
-;;;; INTERNAL-EVAL:
-
-(proclaim '(special lisp::*already-evaled-this*))
-
 ;;; INTERNAL-EVAL  --  Interface
 ;;;
 ;;;    Evaluate an arbitary form.  We convert the form, then call internal
-;;; apply on it.  If *ALREADY-EVALED-THIS* is true, then we bind it to NIL
-;;; around the apply to limit the inhibition to the lexical scope of the
-;;; EVAL-WHEN.
+;;; apply on it.
 ;;;
 (defun internal-eval (form &optional quietly)
   (let ((res (c:compile-for-eval form quietly)))
-    (if lisp::*already-evaled-this*
-	(let ((lisp::*already-evaled-this* nil))
-	  (internal-apply res nil '#()))
-	(internal-apply res nil '#()))))
+    (internal-apply res nil '#())))
 
 
 ;;; VALUE -- Internal.
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index ec1ae259f..46f3bcb95 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.120 2000/10/06 15:10:15 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.121 2001/03/01 21:45:34 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2212,12 +2212,6 @@
       (ir1-convert-progn-body start cont body))))
 
 
-;;; This flag is used by Eval-When to keep track of when code has already been
-;;; evaluated so that it can avoid multiple evaluation of nested Eval-When
-;;; (Compile)s.
-;;;
-(proclaim '(special lisp::*already-evaled-this*))
-
 ;;; DO-EVAL-WHEN-STUFF  --  Interface
 ;;;
 ;;;    Do stuff to do an EVAL-WHEN.  This is split off from the IR1 convert
@@ -2225,46 +2219,36 @@
 ;;; processing code.  We play with the dynamic environment and eval stuff, then
 ;;; call Fun with a list of forms to be processed at load time.
 ;;;
-;;; Note: the EVAL situation is always ignored: this is conceptually a
-;;; compile-only implementation.
-;;;
-;;; We have to interact with the interpreter to ensure that the forms get
-;;; eval'ed exactly once.  We bind *already-evaled-this* to true to inhibit
-;;; evaluation of any enclosed EVAL-WHENs, either by IR1 conversion done by
-;;; EVAL, or by conversion of the body for load-time processing.  If
-;;; *already-evaled-this* is true then we *do not* eval since some enclosing
-;;; eval-when already did.
-;;;
-;;;    We know we are eval'ing for load since we wouldn't get called otherwise.
-;;; If LOAD is a situation we call Fun on body. If we aren't evaluating for
-;;; load, then we call Fun on NIL for the result of the EVAL-WHEN.
-;;;
-(defun do-eval-when-stuff (situations body fun)
+(defun do-eval-when-stuff (situations body fun toplevel-p)
   (when (or (not (listp situations))
 	    (set-difference situations
 			    '(compile load eval
 			      :compile-toplevel :load-toplevel :execute)))
     (compiler-error "Bad Eval-When situation list: ~S." situations))
 
-  (let* ((do-eval (and (intersection '(compile :compile-toplevel) situations)
-		       (not lisp::*already-evaled-this*)))
-	 (lisp::*already-evaled-this* t))
-    (when do-eval
-      (eval `(progn ,@body)))
-    (if (or (intersection '(:load-toplevel load) situations)
-	    (and *converting-for-interpreter*
-		 (intersection '(:execute eval) situations)))
-	(funcall fun body)
-	(funcall fun '(nil)))))
-
+  (if toplevel-p
+      ;; Can only get here from compile-file.
+      (progn
+	(when (intersection '(compile :compile-toplevel) situations)
+	  (eval `(progn ,@body)))
+	;; Maybe generate code for load-time or run-time eval
+	(if (or (intersection '(:load-toplevel load) situations)
+		(and *converting-for-interpreter*
+		     (intersection '(:execute eval) situations)))
+	    (funcall fun body)
+	    (funcall fun '(nil))))
+      ;; Not toplevel, only :execute counts.
+      (if (intersection '(eval :execute) situations)
+	  (funcall fun body)
+	  (funcall fun '(nil)))))
   
 (def-ir1-translator eval-when ((situations &rest body) start cont)
   "EVAL-WHEN (Situation*) Form*
-  Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL.
-  This is conceptually a compile-only implementation, so EVAL is a no-op."
-  (do-eval-when-stuff situations body
-		      #'(lambda (forms)
-			  (ir1-convert-progn-body start cont forms))))
+  Evaluate the Forms in the specified Situations, any of :COMPILE-TOPLEVEL,
+  :LOAD-TOPLEVEL, :EXECUTE."
+  (do-eval-when-stuff
+   situations body #'(lambda (forms) (ir1-convert-progn-body start cont forms))
+   nil))
 
 
 ;;; DO-MACROLET-STUFF  --  Interface
diff --git a/compiler/main.lisp b/compiler/main.lisp
index 5d67d5666..9360611d6 100644
--- a/compiler/main.lisp
+++ b/compiler/main.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.119 2000/08/09 13:23:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.120 2001/03/01 21:45:36 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1104,7 +1104,8 @@
 	     (do-eval-when-stuff
 	      (cadr form) (cddr form)
 	      #'(lambda (forms)
-		  (process-progn forms path))))
+		  (process-progn forms path))
+	      t))
 	    ((macrolet)
 	     (unless (>= (length form) 2)
 	       (compiler-error "MACROLET form is too short: ~S." form))
-- 
GitLab