From 702172bf0b9ab9b0c865f7a1a9dace6262cc013b Mon Sep 17 00:00:00 2001
From: pmai <pmai>
Date: Mon, 26 Aug 2002 16:09:34 +0000
Subject: [PATCH] Slightly frobbed patch from Gerd Moellmann that eliminates
 the function EXTRACT-DECLARATIONS in favour of SYSTEM:PARSE-BODY.  This also
 removes the ability for macros to expand into declarations, which isn't
 allowed anymore by ANSI CL.

---
 pcl/boot.lisp      | 26 ++++++++++++++------------
 pcl/defcombin.lisp |  7 ++++---
 pcl/macros.lisp    | 36 +++---------------------------------
 3 files changed, 21 insertions(+), 48 deletions(-)

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index b0819bc93..39537417f 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.28 2002/08/26 02:23:10 pmai Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.29 2002/08/26 16:09:33 pmai Exp $")
 
 (in-package :pcl)
 
@@ -421,8 +421,8 @@ work during bootstrapping.
   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
       (parse-specialized-lambda-list lambda-list)
     (declare (ignore parameters))
-    (multiple-value-bind (documentation declarations real-body)
-	(extract-declarations body env)
+    (multiple-value-bind (real-body declarations documentation)
+	(system:parse-body body env)
       (values `(lambda ,unspecialized-lambda-list
 		 ,@(when documentation `(,documentation))
 		 (declare (method-name ,(list name qualifiers specializers)))
@@ -451,8 +451,8 @@ work during bootstrapping.
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
     (error "The method-lambda argument to make-method-lambda, ~S,~
             is not a lambda form" method-lambda))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations (cddr method-lambda) env)
+  (multiple-value-bind (real-body declarations documentation)
+      (system:parse-body (cddr method-lambda) env)
     (let* ((name-decl (get-declaration 'method-name declarations))
 	   (sll-decl (get-declaration 'method-lambda-list declarations))
 	   (method-name (when (consp name-decl) (car name-decl)))
@@ -515,9 +515,10 @@ work during bootstrapping.
 						next-method-p-p)
 		(walk-method-lambda method-lambda required-parameters env 
 				    slots calls)
-	      (multiple-value-bind (ignore walked-declarations walked-lambda-body)
-		  (extract-declarations (cddr walked-lambda))
-		(declare (ignore ignore))
+	      (multiple-value-bind (walked-lambda-body walked-declarations
+						       walked-documentation)
+		  (system:parse-body (cddr walked-lambda) env)
+		(declare (ignore walked-documentation))
 		(when (or next-method-p-p call-next-method-p)
 		  (setq plist (list* :needs-next-methods-p t plist)))
 		(when (some #'cdr slots)
@@ -1012,10 +1013,11 @@ work during bootstrapping.
 				  method-name
 				  specializers)
   (flet ((ignoredp (symbol)
-	   (dolist (decl (cdar declarations))
-	     (when (and (eq (car decl) 'ignore)
-			(memq symbol (cdr decl)))
-	       (return t)))))
+	   (dolist (form declarations)
+	     (dolist (decl (cdr form))
+	       (when (and (eq (car decl) 'ignore)
+			  (memq symbol (cdr decl)))
+	         (return-from ignoredp t))))))
     (loop for s in specialized-lambda-list
 	  and p in required-parameters
 	  when (listp s)
diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp
index adaf1b7d2..c7cb789c3 100644
--- a/pcl/defcombin.lisp
+++ b/pcl/defcombin.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.14 2002/08/26 02:23:12 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.15 2002/08/26 16:09:34 pmai Exp $")
 ;;;
 
 (in-package :pcl)
@@ -287,8 +287,9 @@
        (type ll method-group-specifiers arguments-option gf-var body)
   ;;(declare (values documentation function))
   (declare (ignore type))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations body)
+  (multiple-value-bind (real-body declarations documentation)
+      ;; Note that PARSE-BODY ignores its second arg ENVIRONMENT.
+      (system:parse-body body nil)
 
     (let ((wrapped-body
 	    (wrap-method-group-specifier-bindings method-group-specifiers
diff --git a/pcl/macros.lisp b/pcl/macros.lisp
index 4424a059d..1fdee60e2 100644
--- a/pcl/macros.lisp
+++ b/pcl/macros.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.18 2002/08/26 02:23:14 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.19 2002/08/26 16:09:34 pmai Exp $")
 ;;;
 ;;; Macros global variable definitions, and other random support stuff used
 ;;; by the rest of the system.
@@ -98,36 +98,6 @@
 (defun remtail (list tail)
   (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
 
-(eval-when (compile load eval)
-(defun extract-declarations (body &optional environment)
-  ;;(declare (values documentation declarations body))
-  (let (documentation declarations form)
-    (when (and (stringp (car body))
-	       (cdr body))
-      (setq documentation (pop body)))
-    (block outer
-      (loop
-	(when (null body) (return-from outer nil))
-	(setq form (car body))
-	(when (block inner
-		(loop (cond ((not (listp form))
-			     (return-from outer nil))
-			    ((eq (car form) 'declare)
-			     (return-from inner t))
-			    (t
-			     (multiple-value-bind (newform macrop)
-				  (macroexpand-1 form environment)
-			       (if (or (not (eq newform form)) macrop)
-				   (setq form newform)
-				 (return-from outer nil)))))))
-	  (pop body)
-	  (dolist (declaration (cdr form))
-	    (push declaration declarations)))))
-    (values documentation
-	    (and declarations `((declare ,.(nreverse declarations))))
-	    body)))
-)
-
 (defun get-declaration (name declarations &optional default)
   (dolist (d declarations default)
     (dolist (form (cdr d))
@@ -167,8 +137,8 @@
 		(car ,alist)))))
 
 (defmacro doplist ((key val) plist &body body &environment env)
-  (multiple-value-bind (doc decls bod)
-      (extract-declarations body env)
+  (multiple-value-bind (bod decls doc)
+      (system:parse-body body env)
     (declare (ignore doc))
     `(let ((.plist-tail. ,plist) ,key ,val)
        ,@decls
-- 
GitLab