sbcl-0.8.14.11:

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

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index fe19264..7d8bab0 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -26,17 +26,6 @@
 \f
 ;;;; 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,11 +503,13 @@
     (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))))
        ,@(when (consp what)
-           `((setf (,(symbolicate "FUN-INFO-" (second what))
+           `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info)))
+                        (symbolicate "FUN-INFO-" (second what)))
                     (fun-info-or-lose ',(first what)))
                    #',name)))))))
 \f
@@ -644,7 +637,9 @@
            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))))