X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=dd15d8c2144fab06bdd1c4294122733675e64523;hb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;hp=9fce92e0283d93a2667a36f60fe00c99e46b4a2c;hpb=12bd68a3ff68b4e06cfb8c441383b6e898d2ed78;p=sbcl.git

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 9fce92e..dd15d8c 100644
--- 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))
@@ -100,30 +101,25 @@
 ;;; If the desirability of the transformation depends on the current
 ;;; OPTIMIZE parameters, then the POLICY macro should be used to
 ;;; determine when to pass.
-(defmacro define-source-transform (name lambda-list &body body)
-  (let ((fn-name
-	 (if (listp name)
-	     (collect ((pieces))
-	       (dolist (piece name)
-		 (pieces "-")
-		 (pieces piece))
-	       (apply #'symbolicate "SOURCE-TRANSFORM" (pieces)))
-	     (symbolicate "SOURCE-TRANSFORM-" name)))
-	(n-form (gensym))
-	(n-env (gensym)))
+(defmacro source-transform-lambda (lambda-list &body body)
+  (let ((n-form (gensym))
+	(n-env (gensym))
+	(name (gensym)))
     (multiple-value-bind (body decls)
-	(parse-defmacro lambda-list n-form body name "form"
+	(parse-defmacro lambda-list n-form body "source transform" "form"
 			:environment n-env
 			:error-fun `(lambda (&rest stuff)
 				      (declare (ignore stuff))
-				      (return-from ,fn-name
-					(values nil t))))
-      `(progn
-	 (defun ,fn-name (,n-form)
-	   (let ((,n-env *lexenv*))
-	     ,@decls
-	     ,body))
-	 (setf (info :function :source-transform ',name) #',fn-name)))))
+				      (return-from ,name
+					(values nil t)))
+                        :wrap-block nil)
+      `(lambda (,n-form &aux (,n-env *lexenv*))
+         ,@decls
+         (block ,name
+           ,body)))))
+(defmacro define-source-transform (name lambda-list &body body)
+  `(setf (info :function :source-transform ',name)
+         (source-transform-lambda ,lambda-list ,@body)))
 
 ;;;; boolean attribute utilities
 ;;;;
@@ -133,7 +129,7 @@
 
 (deftype attributes () 'fixnum)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 
 ;;; Given a list of attribute names and an alist that translates them
 ;;; to masks, return the OR of the masks.
@@ -160,12 +156,13 @@
 ;;;
 ;;;    NAME-attributes attribute-name*
 ;;;      Return a set of the named attributes.
-#+sb-xc-host
-(progn 
+#-sb-xc
+(progn
   (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)))
@@ -190,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
@@ -263,7 +264,7 @@
 ;;;; to parse the IR1 representation of a function call using a
 ;;;; standard function lambda-list.
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 
 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
 ;;; the arguments of a combination with respect to that lambda-list.
@@ -462,21 +463,21 @@
 ;;; keywords specify the initial values for various optimizers that
 ;;; the function might have.
 (defmacro defknown (name arg-types result-type &optional (attributes '(any))
-			 &rest keys)
+                    &rest keys)
   (when (and (intersection attributes '(any call unwind))
 	     (intersection attributes '(movable)))
     (error "function cannot have both good and bad attributes: ~S" attributes))
 
   (when (member 'any attributes)
-    (setf attributes (union '(call unsafe unwind) attributes)))
+    (setq attributes (union '(call unsafe unwind) attributes)))
   (when (member 'flushable attributes)
     (pushnew 'unsafely-flushable attributes))
 
   `(%defknown ',(if (and (consp name)
-			 (not (eq (car name) 'setf)))
+			 (not (legal-fun-name-p name)))
 		    name
 		    (list name))
-	      '(function ,arg-types ,result-type)
+	      '(sfunction ,arg-types ,result-type)
 	      (ir1-attributes ,@attributes)
 	      ,@keys))
 
@@ -619,9 +620,11 @@
 			     `(continuation-next ,cont-var)))
 	     (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
 	    (())
+         (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
@@ -641,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.
@@ -683,10 +696,18 @@
 	 (values (cdr ,n-res) t)
 	 (values nil nil))))
 
-;;;
-(defmacro with-continuation-type-assertion ((cont ctype context) &body body)
-  `(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context)))
-     ,@body))
+(defmacro with-component-last-block ((component block) &body body)
+  (with-unique-names (old-last-block)
+    (once-only ((component component)
+                (block block))
+      `(let ((,old-last-block (component-last-block ,component)))
+         (unwind-protect
+              (progn (setf (component-last-block ,component)
+                           ,block)
+                     ,@body)
+           (setf (component-last-block ,component)
+                 ,old-last-block))))))
+
 
 ;;;; the EVENT statistics/trace utility
 
@@ -694,7 +715,7 @@
 ;;; experimentation, not for ordinary use, so it should probably
 ;;; become conditional on SB-SHOW.
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 
 (defstruct (event-info (:copier nil))
   ;; The name of this event.