0.pre7.86:

[sbcl.git] / src / pcl / macros.lisp

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index d028d8f..44b51bb 100644 (file)
--- 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.
-\f
+
 (in-package "SB-PCL")
+\f
+(/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))
-\f
 
+(/show "pcl/macros.lisp 299")
+\f
 (defun get-setf-fun-name (name)
   `(setf ,name))
 
 (defsetf slot-value set-slot-value)
+
+(/show "finished with pcl/macros.lisp")