X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmacros.lisp;h=44b51bb758c2858cdbbd32e9a6f7f6a1f63de1d5;hb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;hp=d028d8f4b1e773005e4f2795adde13e23377dacb;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index d028d8f..44b51bb 100644
--- a/src/pcl/macros.lisp
+++ b/src/pcl/macros.lisp
@@ -23,8 +23,10 @@
 ;;;; This software is made available AS IS, and Xerox Corporation makes no
 ;;;; warranty about the software, its performance or its conformity to any
 ;;;; specification.
-
+
 (in-package "SB-PCL")
+
+(/show "starting pcl/macros.lisp")
 
 (declaim (declaration
 	  ;; These three nonstandard declarations seem to be used
@@ -37,45 +39,52 @@
 	  ;; information around, I'm not sure. -- WHN 2000-12-30
 	  %variable-rebinding))
 
+(/show "done with DECLAIM DECLARATION")
+
 ;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
 (eval-when (:compile-toplevel :load-toplevel :execute)
+
 (defun extract-declarations (body &optional environment)
   ;;(declare (values documentation declarations body))
   (let (documentation
-	declarations
-	form)
+        declarations
+        form)
     (when (and (stringp (car body))
-	       (cdr 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)))))
+        (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)))
+            (and declarations `((declare ,.(nreverse declarations))))
+            body)))
 ) ; EVAL-WHEN
 
+(/show "done with EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS")
+
 (defun get-declaration (name declarations &optional default)
   (dolist (d declarations default)
     (dolist (form (cdr d))
       (when (and (consp form) (eq (car form) name))
 	(return-from get-declaration (cdr form))))))
 
+(/show "pcl/macros.lisp 85")
+
 (defmacro collecting-once (&key initial-value)
    `(let* ((head ,initial-value)
 	   (tail ,(and initial-value `(last head))))
@@ -87,6 +96,8 @@
 				       (cdr (rplacd tail (list value)))))))
 		  #'(lambda nil head))))
 
+(/show "pcl/macros.lisp 98")
+
 (defmacro doplist ((key val) plist &body body &environment env)
   (multiple-value-bind (doc decls bod)
       (extract-declarations body env)
@@ -100,6 +111,8 @@
 	     (setq ,val (pop .plist-tail.))
 	     (progn ,@bod)))))
 
+(/show "pcl/macros.lisp 113")
+
 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
   `(let ((,var nil)
 	 (.dolist-carefully. ,list))
@@ -116,6 +129,8 @@
 ;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
 ;;;; PCL:FIND-CLASS, alas.
 
+(/show "pcl/macros.lisp 132")
+
 (defvar *find-class* (make-hash-table :test 'eq))
 
 (defmacro find-class-cell-class (cell)
@@ -138,6 +153,8 @@
 	  (error "~S is not a legal class name." symbol))
 	(setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
 
+(/show "pcl/macros.lisp 157")
+
 (defvar *create-classes-from-internal-structure-definitions-p* t)
 
 (defun find-class-from-cell (symbol cell &optional (errorp t))
@@ -180,6 +197,8 @@
 ;;;   (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
 (defvar *boot-state* nil)
 
+(/show "pcl/macros.lisp 199")
+
 ;;; Note that in SBCL as in CMU CL,
 ;;;   COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
 ;;; (Yes, this is a KLUDGE!)
@@ -221,6 +240,8 @@
 	new-value)
       (error "~S is not a legal class name." symbol)))
 
+(/show "pcl/macros.lisp 242")
+
 (defun (setf find-class-predicate)
        (new-value symbol)
   (if (legal-class-name-p symbol)
@@ -248,6 +269,8 @@
 		       value)))
 	     #'(lambda () result))))
 
+(/show "pcl/macros.lisp 271")
+
 ;;; These are augmented definitions of LIST-ELEMENTS and LIST-TAILS from
 ;;; iterate.lisp. These versions provide the extra :BY keyword which can
 ;;; be used to specify the step function through the list.
@@ -272,9 +295,12 @@
 
 (defmacro function-apply (form &rest args)
   `(apply (the function ,form) ,@args))
-
 
+(/show "pcl/macros.lisp 299")
+
 (defun get-setf-fun-name (name)
   `(setf ,name))
 
 (defsetf slot-value set-slot-value)
+
+(/show "finished with pcl/macros.lisp")