From fa869ede20d2297b6dd48eb7f6911c4599793105 Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Sat, 3 Mar 2001 16:50:10 +0000
Subject: [PATCH] Fixes to make proclaim and declaim work as in ANSI spec.

---
 code/macros.lisp       |  6 +++---
 compiler/ir1tran.lisp  | 22 ++++++++++++----------
 compiler/proclaim.lisp | 36 +++++++++++++++++++++---------------
 3 files changed, 36 insertions(+), 28 deletions(-)

diff --git a/code/macros.lisp b/code/macros.lisp
index 53ff777ea..b30b1597e 100644
--- a/code/macros.lisp
+++ b/code/macros.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/macros.lisp,v 1.65 2000/10/06 15:19:59 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.66 2001/03/03 16:50:08 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -365,7 +365,7 @@
   value, the old value is not clobbered.  The third argument is an optional
   documentation string for the variable."
   `(progn
-    (proclaim '(special ,var))
+    (declaim (special ,var))
      ,@(when valp
 	 `((unless (boundp ',var)
 	     (setq ,var ,val))))
@@ -379,7 +379,7 @@
   variable special and sets its value to VAL.  The third argument is
   an optional documentation string for the parameter."
   `(progn
-    (proclaim '(special ,var))
+    (declaim (special ,var))
     (setq ,var ,val)
     ,@(when docp
 	`((setf (documentation ',var 'variable) ',doc)))
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 46f3bcb95..713de808f 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.121 2001/03/01 21:45:34 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.122 2001/03/03 16:50:10 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2219,7 +2219,8 @@
 ;;; 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.
 ;;;
-(defun do-eval-when-stuff (situations body fun toplevel-p)
+
+(defun do-eval-when-stuff (situations body fun &optional toplevel-p)
   (when (or (not (listp situations))
 	    (set-difference situations
 			    '(compile load eval
@@ -2227,7 +2228,7 @@
     (compiler-error "Bad Eval-When situation list: ~S." situations))
 
   (if toplevel-p
-      ;; Can only get here from compile-file.
+      ;; Can only get here from compile-file
       (progn
 	(when (intersection '(compile :compile-toplevel) situations)
 	  (eval `(progn ,@body)))
@@ -2246,9 +2247,9 @@
   "EVAL-WHEN (Situation*) Form*
   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-eval-when-stuff situations body
+		      #'(lambda (forms)
+			  (ir1-convert-progn-body start cont forms))))
 
 
 ;;; DO-MACROLET-STUFF  --  Interface
@@ -2619,8 +2620,9 @@
 	       (make-new-inlinep var
 				 (cdr (assoc kind inlinep-translations)))))))))
 
+(defknown %declaim (list) void)
 
-(def-ir1-translator proclaim ((what) start cont :kind :function)
+(def-ir1-translator %declaim ((what) start cont :kind :function)
   (if (constantp what)
       (let ((form (eval what)))
 	(unless (consp form)
@@ -2679,11 +2681,11 @@
 				      form)))))
 	  
 	  (unless ignore
-	    (%proclaim form))
+	    (proclaim form))
 	  (if ignore
 	      (ir1-convert start cont nil)
-	      (ir1-convert start cont `(%proclaim ,what)))))
-      (ir1-convert start cont `(%proclaim ,what))))
+	      (ir1-convert start cont `(proclaim ,what)))))
+      (ir1-convert start cont `(proclaim ,what))))
 
 
 ;;; %Compiler-Defstruct IR1 Convert  --  Internal
diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index 7405c22d2..fa660df2f 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.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/proclaim.lisp,v 1.33 2001/01/18 03:12:42 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.34 2001/03/03 16:50:09 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -307,22 +307,29 @@
 
 ;;; DECLAIM  --  Public
 ;;;
-;;;    For now, just PROCLAIM without any EVAL-WHEN.
-;;;
+
 (defmacro declaim (&rest specs)
   "DECLAIM Declaration*
   Do a declaration for the global environment."
-  `(progn ,@(mapcar #'(lambda (x)
-			`(proclaim ',x))
-		    specs)))
-  
+  `(progn
+     (eval-when (:load-toplevel :execute)
+       ,@(mapcar #'(lambda (x)
+		     `(proclaim ',x))
+		 specs))
+     (eval-when (:compile-toplevel)
+       ,@(mapcar #'(lambda (x)
+		     `(%declaim ',x))
+		 specs))))
 
-;;; %Proclaim  --  Interface
+(defun %declaim (x)
+  (proclaim x))
+
+;;; %declaim  --  Interface
 ;;;
 ;;;    This function is the guts of proclaim, since it does the global
 ;;; environment updating.
 ;;;
-(defun %proclaim (form)
+(defun proclaim (form)
   (unless (consp form)
     (error "Malformed PROCLAIM spec: ~S." form))
   
@@ -374,8 +381,8 @@
        ;; FTYPE.
        (when *type-system-initialized*
 	 (if (and (<= 2 (length args) 3) (listp (second args)))
-	     (%proclaim `(ftype (function . ,(rest args)) ,(first args)))
-	     (%proclaim `(type function . ,args)))))
+	     (proclaim `(ftype (function . ,(rest args)) ,(first args)))
+	     (proclaim `(type function . ,args)))))
       (optimize
        (setq *default-cookie*
 	     (process-optimize-declaration form *default-cookie*)))
@@ -405,15 +412,14 @@
       ((start-block end-block)) ; ignore.
       (t
        (cond ((member kind type-specifier-symbols)
-	      (%proclaim `(type . ,form)))
+	      (proclaim `(type . ,form)))
 	     ((or (info type kind kind)
 		  (and (consp kind) (info type translator (car kind))))
-	      (%proclaim `(type . ,form)))
+	      (proclaim `(type . ,form)))
 	     ((not (info declaration recognized kind))
 	      (warn "Unrecognized proclamation: ~S." form))))))
   (undefined-value))
-;;;
-(setf (symbol-function 'proclaim) #'%proclaim)
+
 
 ;;; %NOTE-TYPE-DEFINED  --  Interface
 ;;;
-- 
GitLab