X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=94094825ea093629252a3a04ffedad5096a61f1d;hb=beddcfe1ea23d2cfdddde2fa7cde6436799715a2;hp=b0b2600d6526e7ed648f4f70b79f12d2d44ac745;hpb=92d1243a970f638b286c3689df16b32c3049cfe0;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index b0b2600..9409482 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -75,9 +75,14 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL."
       nil
       (labels ((sub (form)
                  (or (get-source-path form)
-                     (and (consp form)
-                          (some #'sub form)))))
-        (or (sub form)))))
+                     (when (consp form)
+                       (unless (eq 'quote (car form))
+                         (somesub form)))))
+               (somesub (forms)
+                 (when (consp forms)
+                   (or (sub (car forms))
+                       (somesub (cdr forms))))))
+        (sub form))))
 
 ;;;; BLOCK and TAGBODY
 
@@ -592,7 +597,7 @@ be a lambda expression."
 (def-ir1-translator %funcall ((function &rest args) start next result)
   ;; MACROEXPAND so that (LAMBDA ...) forms arriving here don't get an
   ;; extra cast inserted for them.
-  (let* ((function (sb!xc:macroexpand function *lexenv*))
+  (let* ((function (%macroexpand function *lexenv*))
          (op (when (consp function) (car function))))
     (cond ((eq op 'function)
            (compiler-destructuring-bind (thing) (cdr function)
@@ -911,6 +916,12 @@ is unable to derive from other declared types."
 ;;; whatever you tell it. It will never generate a type check, but
 ;;; will cause a warning if the compiler can prove the assertion is
 ;;; wrong.
+;;;
+;;; For the benefit of code-walkers we also add a macro-expansion. (Using INFO
+;;; directly to get around safeguards for adding a macro-expansion for special
+;;; operator.) Because :FUNCTION :KIND remains :SPECIAL-FORM, the compiler
+;;; never uses the macro -- but manually calling its MACRO-FUNCTION or
+;;; MACROEXPANDing TRULY-THE forms does.
 (def-ir1-translator truly-the ((value-type form) start next result)
   #!+sb-doc
   "Specifies that the values returned by FORM conform to the
@@ -921,6 +932,12 @@ Consequences are undefined if any result is not of the declared type
 -- typical symptoms including memory corruptions. Use with great
 care."
   (the-in-policy value-type form '((type-check . 0)) start next result))
+
+#-sb-xc-host
+(setf (info :function :macro-function 'truly-the)
+      (lambda (whole env)
+        (declare (ignore env))
+        `(the ,@(cdr whole))))
 
 ;;;; SETQ