0.8.3.5:

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

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 1dd4bbc..dd15d8c 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -54,7 +54,8 @@
     (multiple-value-bind (body decls doc)
        (parse-defmacro lambda-list n-form body name "special form"
                        :environment n-env
-                       :error-fun 'convert-condition-into-compiler-error)
+                       :error-fun 'convert-condition-into-compiler-error
+                        :wrap-block nil)
       `(progn
         (declaim (ftype (function (continuation continuation t) (values))
                         ,fn-name))
@@ -110,7 +111,8 @@
                        :error-fun `(lambda (&rest stuff)
                                      (declare (ignore stuff))
                                      (return-from ,name
-                                       (values nil t))))
+                                       (values nil t)))
+                        :wrap-block nil)
       `(lambda (,n-form &aux (,n-env *lexenv*))
          ,@decls
          (block ,name
@@ -159,7 +161,8 @@
   (def!macro !def-boolean-attribute (name &rest attribute-names)
 
     (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
-         (test-name (symbolicate name "-ATTRIBUTEP")))
+         (test-name (symbolicate name "-ATTRIBUTEP"))
+          (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES")))
       (collect ((alist))
         (do ((mask 1 (ash mask 1))
             (names attribute-names (cdr names)))
@@ -184,7 +187,11 @@
           ;; building the xc and when building the target compiler.
           (!def-boolean-attribute-setter ,test-name
                                          ,translations-name
-                                         ,@attribute-names)))))
+                                         ,@attribute-names)
+           (defun ,decoder-name (attributes)
+             (loop for (name . mask) in ,translations-name
+                   when (logtest mask attributes)
+                     collect name))))))
 
   ;; It seems to be difficult to express in DEF!MACRO machinery what
   ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just
@@ -616,7 +623,8 @@
          (declare (type node ,node-var))
         ,@body
         (when ,(if restart-p
-                   `(eq ,node-var (block-last ,n-block))
+                   `(or (eq ,node-var (block-last ,n-block))
+                         (block-delete-p ,n-block))
                    `(eq ,cont-var ,n-last-cont))
           (return nil))))))
 ;;; like DO-NODES, only iterating in reverse order
@@ -636,6 +644,16 @@
         (when (eq ,n-next ,n-start)
           (return nil))))))
 
+(defmacro do-nodes-carefully ((node-var cont-var block) &body body)
+  (with-unique-names (n-block n-last)
+    `(loop with ,n-block = ,block
+           with ,n-last = (block-last ,n-block)
+           for ,cont-var = (block-start ,n-block) then (node-cont ,node-var)
+           for ,node-var = (and ,cont-var (continuation-next ,cont-var))
+           while ,node-var
+           do (progn ,@body)
+           until (eq ,node-var ,n-last))))
+
 ;;; Bind the IR1 context variables to the values associated with NODE,
 ;;; so that new, extra IR1 conversion related to NODE can be done
 ;;; after the original conversion pass has finished.