1.0.44.1: more conservative CONCATENATE open-coding

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

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 7ec86bd..66b034d 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -40,7 +40,8 @@
 ;;; kind to associate with NAME.
 (defmacro def-ir1-translator (name (lambda-list start-var next-var result-var)
                               &body body)
-  (let ((fn-name (symbolicate "IR1-CONVERT-" name)))
+  (let ((fn-name (symbolicate "IR1-CONVERT-" name))
+        (guard-name (symbolicate name "-GUARD")))
     (with-unique-names (whole-var n-env)
       (multiple-value-bind (body decls doc)
           (parse-defmacro lambda-list whole-var body name "special form"
@@ -56,24 +57,28 @@
              ,@decls
              ,body
              (values))
-           ,@(when doc
-                   `((setf (fdocumentation ',name 'function) ,doc)))
+           #-sb-xc-host
+           ;; 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. These guard
+           ;; functions also provide the documentation for special forms.
+           (progn
+             (defun ,guard-name (&rest args)
+               ,@(when doc (list doc))
+               (declare (ignore args))
+               (error 'special-form-function :name ',name))
+             (let ((fun #',guard-name))
+               (setf (%simple-fun-arglist fun) ',lambda-list
+                     (%simple-fun-name fun) ',name
+                     (symbol-function ',name) fun)
+               (fmakunbound ',guard-name)))
            ;; 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)
            ;; 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
-           (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