fix SEARCH vector vector transform

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 9b04e0f..9409482 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -26,7 +26,7 @@ forms, returns NIL."
   #!+sb-doc
   "IF predicate then [else]
 
-If PREDICATE evaluates to false, evaluate THEN and return its values,
+If PREDICATE evaluates to true, evaluate THEN and return its values,
 otherwise evaluate ELSE and return its values. ELSE defaults to NIL."
   (let* ((pred-ctran (make-ctran))
          (pred-lvar (make-lvar))
@@ -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))))
 \f
 ;;;; BLOCK and TAGBODY
 
@@ -473,20 +478,23 @@ Return VALUE without evaluating it."
 \f
 ;;;; FUNCTION and NAMED-LAMBDA
 (defun name-lambdalike (thing)
-  (ecase (car thing)
+  (case (car thing)
     ((named-lambda)
      (or (second thing)
          `(lambda ,(third thing))))
-    ((lambda instance-lambda)
+    ((lambda)
      `(lambda ,(second thing)))
     ((lambda-with-lexenv)
-     `(lambda ,(fifth thing)))))
+     `(lambda ,(fifth thing)))
+    (otherwise
+     (compiler-error "Not a valid lambda expression:~%  ~S"
+                     thing))))
 
 (defun fun-name-leaf (thing)
   (if (consp thing)
       (cond
         ((member (car thing)
-                 '(lambda named-lambda instance-lambda lambda-with-lexenv))
+                 '(lambda named-lambda lambda-with-lexenv))
          (values (ir1-convert-lambdalike
                   thing
                   :debug-name (name-lambdalike thing))
@@ -587,13 +595,20 @@ be a lambda expression."
        `(%funcall ,(ensure-lvar-fun-form function 'function) ,@arg-names))))
 
 (def-ir1-translator %funcall ((function &rest args) start next result)
-  (let ((op (when (consp function) (car function))))
+  ;; MACROEXPAND so that (LAMBDA ...) forms arriving here don't get an
+  ;; extra cast inserted for them.
+  (let* ((function (%macroexpand function *lexenv*))
+         (op (when (consp function) (car function))))
     (cond ((eq op 'function)
-           (with-fun-name-leaf (leaf (second function) start)
-             (ir1-convert start next result `(,leaf ,@args))))
+           (compiler-destructuring-bind (thing) (cdr function)
+               function
+             (with-fun-name-leaf (leaf thing start)
+               (ir1-convert start next result `(,leaf ,@args)))))
           ((eq op 'global-function)
-           (with-fun-name-leaf (leaf (second function) start :global-function t)
-             (ir1-convert start next result `(,leaf ,@args))))
+           (compiler-destructuring-bind (thing) (cdr function)
+               global-function
+             (with-fun-name-leaf (leaf thing start :global-function t)
+               (ir1-convert start next result `(,leaf ,@args)))))
           (t
            (let ((ctran (make-ctran))
                  (fun-lvar (make-lvar)))
@@ -636,7 +651,8 @@ be a lambda expression."
              (varify-lambda-arg name
                                 (if (eq context 'let*)
                                     nil
-                                    (names)))))
+                                    (names))
+                                context)))
       (dolist (spec bindings)
         (cond ((atom spec)
                (let ((var (get-var spec)))
@@ -900,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
@@ -910,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))))
 \f
 ;;;; SETQ
 
@@ -1083,6 +1111,7 @@ due to normal completion or a non-local exit such as THROW)."
         ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
         ;; and something can be done to make %ESCAPE-FUN have
         ;; dynamic extent too.
+        (declare (dynamic-extent #',cleanup-fun))
         (block ,drop-thru-tag
           (multiple-value-bind (,next ,start ,count)
               (block ,exit-tag