1.0.47.8: No more INSTANCE-LAMBDA

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

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 7556b7e..238d04e 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))
@@ -473,20 +473,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))
@@ -636,7 +639,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)))
@@ -754,8 +758,9 @@ also processed as top level forms."
           (program-assert-symbol-home-package-unlocked
            :compile name "binding ~A as a local function"))
         (names name)
-        (multiple-value-bind (forms decls) (parse-body (cddr def))
+        (multiple-value-bind (forms decls doc) (parse-body (cddr def))
           (defs `(lambda ,(second def)
+                   ,@(when doc (list doc))
                    ,@decls
                    (block ,(fun-name-block-name name)
                      . ,forms))))))
@@ -1082,6 +1087,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