X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=43786213c8a529eb3a9240c1477344280f16ddc8;hb=8375acd89ba695e2fc838fffd5211a5ddf9c3b0d;hp=e96a92bf134a903658a0a07ef2828f00a18e595a;hpb=ddc94b60746df2f6ace927af6be6046cdc1e8a1b;p=sbcl.git

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index e96a92b..4378621 100644
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -26,17 +26,6 @@
 
 ;;;; source-hacking defining forms
 
-;;; to be passed to PARSE-DEFMACRO when we want compiler errors
-;;; instead of real errors
-#!-sb-fluid (declaim (inline convert-condition-into-compiler-error))
-(defun convert-condition-into-compiler-error (datum &rest stuff)
-  (if (stringp datum)
-      (apply #'compiler-error datum stuff)
-      (compiler-error "~A"
-		      (if (symbolp datum)
-			  (apply #'make-condition datum stuff)
-			  datum))))
-
 ;;; Parse a DEFMACRO-style lambda-list, setting things up so that a
 ;;; compiler error happens if the syntax is invalid.
 ;;;
@@ -45,42 +34,44 @@
 ;;; list. START-VAR, NEXT-VAR and RESULT-VAR are bound to the start and
 ;;; result continuations for the resulting IR1. KIND is the function
 ;;; kind to associate with NAME.
-(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var
-						&key (kind :special-form))
-				   &body body)
+(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var)
+			      &body body)
   (let ((fn-name (symbolicate "IR1-CONVERT-" name))
 	(n-form (gensym))
 	(n-env (gensym)))
     (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 'compiler-error
                         :wrap-block nil)
       `(progn
 	 (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
 			 ,fn-name))
-	 (defun ,fn-name (,start-var ,next-var ,result-var ,n-form)
-	   (let ((,n-env *lexenv*))
-	     ,@decls
-	     ,body
-	     (values)))
+	 (defun ,fn-name (,start-var ,next-var ,result-var ,n-form
+			  &aux (,n-env *lexenv*))
+	   (declare (ignorable ,start-var ,next-var ,result-var))
+	   ,@decls
+	   ,body
+	   (values))
 	 ,@(when doc
 	     `((setf (fdocumentation ',name 'function) ,doc)))
 	 ;; FIXME: Evidently "there can only be one!" -- we overwrite any
 	 ;; other :IR1-CONVERT value. This deserves a warning, I think.
 	 (setf (info :function :ir1-convert ',name) #',fn-name)
-	 (setf (info :function :kind ',name) ,kind)
+	 ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to
+	 ;; the 1990s?
+	 (setf (info :function :kind ',name) :special-form)
 	 ;; It's nice to do this for error checking in the target
 	 ;; SBCL, but it's not nice to do this when we're running in
 	 ;; the cross-compilation host Lisp, which owns the
 	 ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
 	 #-sb-xc-host
-	 ,@(when (eq kind :special-form)
-	     `((setf (symbol-function ',name)
-		     (lambda (&rest rest)
-		       (declare (ignore rest))
-		       (error 'special-form-function
-			      :name ',name)))))))))
+	 (let ((fun (lambda (&rest rest)
+		      (declare (ignore rest))
+		      (error 'special-form-function :name ',name))))
+	   (setf (%simple-fun-arglist fun) ',lambda-list)
+	   (setf (symbol-function ',name) fun))
+	 ',name))))
 
 ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
 ;;; syntax is invalid.)
@@ -512,6 +503,7 @@
     (let ((n-args (gensym)))
       `(progn
 	(defun ,name (,n-node ,@vars)
+	  (declare (ignorable ,@vars))
 	  (let ((,n-args (basic-combination-args ,n-node)))
 	    ,(parse-deftransform lambda-list body n-args
 				 `(return-from ,name nil))))
@@ -631,15 +623,22 @@
 
 ;;; Like DO-NODES, only iterating in reverse order. Should be careful
 ;;; with block being split under us.
-(defmacro do-nodes-backwards ((node-var lvar block) &body body)
+(defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body)
   (let ((n-block (gensym))
 	(n-prev (gensym)))
     `(loop with ,n-block = ,block
-           for ,node-var = (block-last ,n-block) then (ctran-use ,n-prev)
+           for ,node-var = (block-last ,n-block) then
+                           ,(if restart-p
+                                `(if (eq ,n-block (ctran-block ,n-prev))
+                                     (ctran-use ,n-prev)
+                                     (block-last ,n-block))
+                                `(ctran-use ,n-prev))
            for ,n-prev = (when ,node-var (node-prev ,node-var))
            and ,lvar = (when (and ,node-var (valued-node-p ,node-var))
 			 (node-lvar ,node-var))
-           while ,node-var
+           while ,(if restart-p
+                      `(and ,node-var (not (block-to-be-deleted-p ,n-block)))
+                      node-var)
            do (progn
                 ,@body))))