Warn when wrapping constants with THE of multiple value types
[sbcl.git] / src / compiler / ir1-translators.lisp
index e809bb3..7bd2bfb 100644 (file)
 
 (in-package "SB!C")
 \f
-;;;; control special forms
+;;;; special forms for control
 
-(def-ir1-translator progn ((&rest forms) start cont)
+(def-ir1-translator progn ((&rest forms) start next result)
   #!+sb-doc
-  "Progn Form*
-  Evaluates each Form in order, returning the values of the last form. With no
-  forms, returns NIL."
-  (ir1-convert-progn-body start cont forms))
+  "PROGN form*
 
-(def-ir1-translator if ((test then &optional else) start cont)
+Evaluates each FORM in order, returning the values of the last form. With no
+forms, returns NIL."
+  (ir1-convert-progn-body start next result forms))
+
+(def-ir1-translator if ((test then &optional else) start next result)
   #!+sb-doc
-  "If Predicate Then [Else]
-  If Predicate evaluates to non-null, evaluate Then and returns its values,
-  otherwise evaluate Else and return its values. Else defaults to NIL."
-  (let* ((pred (make-continuation))
-        (then-cont (make-continuation))
-        (then-block (continuation-starts-block then-cont))
-        (else-cont (make-continuation))
-        (else-block (continuation-starts-block else-cont))
-        (dummy-cont (make-continuation))
-        (node (make-if :test pred
-                       :consequent then-block
-                       :alternative else-block)))
-    (setf (continuation-dest pred) node)
-    (ir1-convert start pred test)
-    (link-node-to-previous-continuation node pred)
-    (use-continuation node dummy-cont)
-
-    (let ((start-block (continuation-block pred)))
+  "IF predicate then [else]
+
+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))
+         (then-ctran (make-ctran))
+         (then-block (ctran-starts-block then-ctran))
+         (else-ctran (make-ctran))
+         (else-block (ctran-starts-block else-ctran))
+         (maybe-instrument *instrument-if-for-code-coverage*)
+         (*instrument-if-for-code-coverage* t)
+         (node (make-if :test pred-lvar
+                        :consequent then-block
+                        :alternative else-block)))
+    ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
+    ;; order of the following two forms is important
+    (setf (lvar-dest pred-lvar) node)
+    (multiple-value-bind (context count) (possible-rest-arg-context test)
+      (if context
+          (ir1-convert start pred-ctran pred-lvar `(%rest-true ,test ,context ,count))
+          (ir1-convert start pred-ctran pred-lvar test)))
+    (link-node-to-previous-ctran node pred-ctran)
+
+    (let ((start-block (ctran-block pred-ctran)))
       (setf (block-last start-block) node)
-      (continuation-starts-block cont)
+      (ctran-starts-block next)
 
       (link-blocks start-block then-block)
       (link-blocks start-block else-block))
 
-    (ir1-convert then-cont cont then)
-    (ir1-convert else-cont cont else)))
+    (let ((path (best-sub-source-path test)))
+      (ir1-convert (if (and path maybe-instrument)
+                       (let ((*current-path* path))
+                         (instrument-coverage then-ctran :then test))
+                       then-ctran)
+                   next result then)
+      (ir1-convert (if (and path maybe-instrument)
+                       (let ((*current-path* path))
+                         (instrument-coverage else-ctran :else test))
+                       else-ctran)
+                   next result else))))
+
+;;; To get even remotely sensible results for branch coverage
+;;; tracking, we need good source paths. If the macroexpansions
+;;; interfere enough the TEST of the conditional doesn't actually have
+;;; an original source location (e.g. (UNLESS FOO ...) -> (IF (NOT
+;;; FOO) ...). Look through the form, and try to find some subform
+;;; that has one.
+(defun best-sub-source-path (form)
+  (if (policy *lexenv* (= store-coverage-data 0))
+      nil
+      (labels ((sub (form)
+                 (or (get-source-path 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
 
 ;;;; node.
 
 ;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
-;;; body in the modified environment. We make CONT start a block now,
+;;; body in the modified environment. We make NEXT start a block now,
 ;;; since if it was done later, the block would be in the wrong
 ;;; environment.
-(def-ir1-translator block ((name &rest forms) start cont)
+(def-ir1-translator block ((name &rest forms) start next result)
   #!+sb-doc
-  "Block Name Form*
-  Evaluate the Forms as a PROGN. Within the lexical scope of the body,
-  (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
-  result of Value-Form."
+  "BLOCK name form*
+
+Evaluate the FORMS as a PROGN. Within the lexical scope of the body,
+RETURN-FROM can be used to exit the form."
   (unless (symbolp name)
     (compiler-error "The block name ~S is not a symbol." name))
-  (continuation-starts-block cont)
-  (let* ((dummy (make-continuation))
-        (entry (make-entry))
-        (cleanup (make-cleanup :kind :block
-                               :mess-up entry)))
+  (start-block start)
+  (ctran-starts-block next)
+  (let* ((dummy (make-ctran))
+         (entry (make-entry))
+         (cleanup (make-cleanup :kind :block
+                                :mess-up entry)))
     (push entry (lambda-entries (lexenv-lambda *lexenv*)))
     (setf (entry-cleanup entry) cleanup)
-    (link-node-to-previous-continuation entry start)
-    (use-continuation entry dummy)
-    
-    (let* ((env-entry (list entry cont))
-           (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
-                                 :cleanup cleanup)))
-      (push env-entry (continuation-lexenv-uses cont))
-      (ir1-convert-progn-body dummy cont forms))))
+    (link-node-to-previous-ctran entry start)
+    (use-ctran entry dummy)
 
+    (let* ((env-entry (list entry next result))
+           (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
+                                  :cleanup cleanup)))
+      (ir1-convert-progn-body dummy next result forms))))
 
-(def-ir1-translator return-from ((name &optional value) start cont)
+(def-ir1-translator return-from ((name &optional value) start next result)
   #!+sb-doc
-  "Return-From Block-Name Value-Form
-  Evaluate the Value-Form, returning its values from the lexically enclosing
-  BLOCK Block-Name. This is constrained to be used only within the dynamic
-  extent of the BLOCK."
-  ;; CMU CL comment:
-  ;;   We make CONT start a block just so that it will have a block
-  ;;   assigned. People assume that when they pass a continuation into
-  ;;   IR1-CONVERT as CONT, it will have a block when it is done.
+  "RETURN-FROM block-name value-form
+
+Evaluate the VALUE-FORM, returning its values from the lexically enclosing
+block BLOCK-NAME. This is constrained to be used only within the dynamic
+extent of the block."
+  ;; old comment:
+  ;;   We make NEXT start a block just so that it will have a block
+  ;;   assigned. People assume that when they pass a ctran into
+  ;;   IR1-CONVERT as NEXT, it will have a block when it is done.
   ;; KLUDGE: Note that this block is basically fictitious. In the code
   ;;   (BLOCK B (RETURN-FROM B) (SETQ X 3))
   ;; it's the block which answers the question "which block is
   ;; BLOCK-HOME-LAMBDA-OR-NULL) more obscure, and it might be better
   ;; to get rid of it, perhaps using a special placeholder value
   ;; to indicate the orphanedness of the code.
-  (continuation-starts-block cont)
+  (declare (ignore result))
+  (ctran-starts-block next)
   (let* ((found (or (lexenv-find name blocks)
-                   (compiler-error "return for unknown block: ~S" name)))
-        (value-cont (make-continuation))
-        (entry (first found))
-        (exit (make-exit :entry entry
-                         :value value-cont)))
+                    (compiler-error "return for unknown block: ~S" name)))
+         (exit-ctran (second found))
+         (value-ctran (make-ctran))
+         (value-lvar (make-lvar))
+         (entry (first found))
+         (exit (make-exit :entry entry
+                          :value value-lvar)))
+    (when (ctran-deleted-p exit-ctran)
+      (throw 'locall-already-let-converted exit-ctran))
     (push exit (entry-exits entry))
-    (setf (continuation-dest value-cont) exit)
-    (ir1-convert start value-cont value)
-    (link-node-to-previous-continuation exit value-cont)
-    (let ((home-lambda (continuation-home-lambda-or-null start)))
+    (setf (lvar-dest value-lvar) exit)
+    (ir1-convert start value-ctran value-lvar value)
+    (link-node-to-previous-ctran exit value-ctran)
+    (let ((home-lambda (ctran-home-lambda-or-null start)))
       (when home-lambda
-       (push entry (lambda-calls-or-closes home-lambda))))
-    (use-continuation exit (second found))))
+        (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
+    (use-continuation exit exit-ctran (third found))))
 
 ;;; Return a list of the segments of a TAGBODY. Each segment looks
 ;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
 ;;; tagbody into segments of non-tag statements, and explicitly
 ;;; represent the drop-through with a GO. The first segment has a
-;;; dummy NIL tag, since it represents code before the first tag. The
+;;; dummy NIL tag, since it represents code before the first tag. Note
+;;; however that NIL may appear as the tag of an inner segment. The
 ;;; last segment (which may also be the first segment) ends in NIL
 ;;; rather than a GO.
 (defun parse-tagbody (body)
   (declare (list body))
-  (collect ((segments))
-    (let ((current (cons nil body)))
+  (collect ((tags)
+            (segments))
+    (let ((current body))
       (loop
-       (let ((tag-pos (position-if (complement #'listp) current :start 1)))
-         (unless tag-pos
-           (segments `(,@current nil))
-           (return))
-         (let ((tag (elt current tag-pos)))
-           (when (assoc tag (segments))
-             (compiler-error
-              "The tag ~S appears more than once in the tagbody."
-              tag))
-           (unless (or (symbolp tag) (integerp tag))
-             (compiler-error "~S is not a legal tagbody statement." tag))
-           (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
-         (setq current (nthcdr tag-pos current)))))
-    (segments)))
+       (let ((next-segment (member-if #'atom current)))
+         (unless next-segment
+           (segments `(,@current nil))
+           (return))
+         (let ((tag (car next-segment)))
+           (when (member tag (tags))
+             (compiler-error
+              "The tag ~S appears more than once in a tagbody."
+              tag))
+           (unless (or (symbolp tag) (integerp tag))
+             (compiler-error "~S is not a legal go tag." tag))
+           (tags tag)
+           (segments `(,@(ldiff current next-segment) (go ,tag))))
+         (setq current (rest next-segment))))
+      (mapcar #'cons (cons nil (tags)) (segments)))))
 
 ;;; Set up the cleanup, emitting the entry node. Then make a block for
 ;;; each tag, building up the tag list for LEXENV-TAGS as we go.
 ;;; Finally, convert each segment with the precomputed Start and Cont
 ;;; values.
-(def-ir1-translator tagbody ((&rest statements) start cont)
+(def-ir1-translator tagbody ((&rest statements) start next result)
   #!+sb-doc
-  "Tagbody {Tag | Statement}*
-  Define tags for used with GO. The Statements are evaluated in order
-  (skipping Tags) and NIL is returned. If a statement contains a GO to a
-  defined Tag within the lexical scope of the form, then control is transferred
-  to the next statement following that tag. A Tag must an integer or a
-  symbol. A statement must be a list. Other objects are illegal within the
-  body."
-  (continuation-starts-block cont)
-  (let* ((dummy (make-continuation))
-        (entry (make-entry))
-        (segments (parse-tagbody statements))
-        (cleanup (make-cleanup :kind :tagbody
-                               :mess-up entry)))
+  "TAGBODY {tag | statement}*
+
+Define tags for use with GO. The STATEMENTS are evaluated in order, skipping
+TAGS, and NIL is returned. If a statement contains a GO to a defined TAG
+within the lexical scope of the form, then control is transferred to the next
+statement following that tag. A TAG must be an integer or a symbol. A
+STATEMENT must be a list. Other objects are illegal within the body."
+  (start-block start)
+  (ctran-starts-block next)
+  (let* ((dummy (make-ctran))
+         (entry (make-entry))
+         (segments (parse-tagbody statements))
+         (cleanup (make-cleanup :kind :tagbody
+                                :mess-up entry)))
     (push entry (lambda-entries (lexenv-lambda *lexenv*)))
     (setf (entry-cleanup entry) cleanup)
-    (link-node-to-previous-continuation entry start)
-    (use-continuation entry dummy)
+    (link-node-to-previous-ctran entry start)
+    (use-ctran entry dummy)
 
     (collect ((tags)
-             (starts)
-             (conts))
+              (starts)
+              (ctrans))
       (starts dummy)
       (dolist (segment (rest segments))
-       (let* ((tag-cont (make-continuation))
-               (tag (list (car segment) entry tag-cont)))          
-         (conts tag-cont)
-         (starts tag-cont)
-         (continuation-starts-block tag-cont)
-          (tags tag)
-          (push (cdr tag) (continuation-lexenv-uses tag-cont))))
-      (conts cont)
+        (let* ((tag-ctran (make-ctran))
+               (tag (list (car segment) entry tag-ctran)))
+          (ctrans tag-ctran)
+          (starts tag-ctran)
+          (ctran-starts-block tag-ctran)
+          (tags tag)))
+      (ctrans next)
 
       (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
-       (mapc (lambda (segment start cont)
-               (ir1-convert-progn-body start cont (rest segment)))
-             segments (starts) (conts))))))
+        (mapc (lambda (segment start end)
+                (ir1-convert-progn-body start end
+                                        (when (eq end next) result)
+                                        (rest segment)))
+              segments (starts) (ctrans))))))
 
 ;;; Emit an EXIT node without any value.
-(def-ir1-translator go ((tag) start cont)
+(def-ir1-translator go ((tag) start next result)
   #!+sb-doc
-  "Go Tag
-  Transfer control to the named Tag in the lexically enclosing TAGBODY. This
-  is constrained to be used only within the dynamic extent of the TAGBODY."
-  (continuation-starts-block cont)
+  "GO tag
+
+Transfer control to the named TAG in the lexically enclosing TAGBODY. This is
+constrained to be used only within the dynamic extent of the TAGBODY."
+  (ctran-starts-block next)
   (let* ((found (or (lexenv-find tag tags :test #'eql)
-                   (compiler-error "attempt to GO to nonexistent tag: ~S"
-                                   tag)))
-        (entry (first found))
-        (exit (make-exit :entry entry)))
+                    (compiler-error "attempt to GO to nonexistent tag: ~S"
+                                    tag)))
+         (entry (first found))
+         (exit (make-exit :entry entry)))
     (push exit (entry-exits entry))
-    (link-node-to-previous-continuation exit start)
-    (let ((home-lambda (continuation-home-lambda-or-null start)))
+    (link-node-to-previous-ctran exit start)
+    (let ((home-lambda (ctran-home-lambda-or-null start)))
       (when home-lambda
-       (push entry (lambda-calls-or-closes home-lambda))))
-    (use-continuation exit (second found))))
+        (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
+    (use-ctran exit (second found))))
 \f
 ;;;; translators for compiler-magic special forms
 
 ;;;   are ignored for non-top-level forms. For non-top-level forms, an
 ;;;   eval-when specifying the :EXECUTE situation is treated as an
 ;;;   implicit PROGN including the forms in the body of the EVAL-WHEN
-;;;   form; otherwise, the forms in the body are ignored. 
-(def-ir1-translator eval-when ((situations &rest forms) start cont)
+;;;   form; otherwise, the forms in the body are ignored.
+(def-ir1-translator eval-when ((situations &rest forms) start next result)
   #!+sb-doc
-  "EVAL-WHEN (Situation*) Form*
-  Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
-  :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
+  "EVAL-WHEN (situation*) form*
+
+Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL,
+:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
   (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
     (declare (ignore ct lt))
-    (ir1-convert-progn-body start cont (and e forms)))
+    (ir1-convert-progn-body start next result (and e forms)))
   (values))
 
 ;;; common logic for MACROLET and SYMBOL-MACROLET
 ;;; in-lexenv representation, stuff the results into *LEXENV*, and
 ;;; call FUN (with no arguments).
 (defun %funcall-in-foomacrolet-lexenv (definitionize-fun
-                                      definitionize-keyword
-                                      definitions
-                                      fun)
+                                       definitionize-keyword
+                                       definitions
+                                       fun)
   (declare (type function definitionize-fun fun))
   (declare (type (member :vars :funs) definitionize-keyword))
   (declare (type list definitions))
     (compiler-style-warn "duplicate definitions in ~S" definitions))
   (let* ((processed-definitions (mapcar definitionize-fun definitions))
          (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
-    (funcall fun)))
+    ;; I wonder how much of an compiler performance penalty this
+    ;; non-constant keyword is.
+    (funcall fun definitionize-keyword processed-definitions)))
 
-;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
+;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then
 ;;; call FUN (with no arguments).
 ;;;
 ;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top level MACROLET processing code.
-(defun funcall-in-macrolet-lexenv (definitions fun)
+;;; shared by the special-case top level MACROLET processing code, and
+;;; further split so that the special-case MACROLET processing code in
+;;; EVAL can likewise make use of it.
+(defun macrolet-definitionize-fun (context lexenv)
+  (flet ((fail (control &rest args)
+           (ecase context
+             (:compile (apply #'compiler-error control args))
+             (:eval (error 'simple-program-error
+                           :format-control control
+                           :format-arguments args)))))
+    (lambda (definition)
+      (unless (list-of-length-at-least-p definition 2)
+        (fail "The list ~S is too short to be a legal local macro definition."
+              definition))
+      (destructuring-bind (name arglist &body body) definition
+        (unless (symbolp name)
+          (fail "The local macro name ~S is not a symbol." name))
+        (when (fboundp name)
+          (program-assert-symbol-home-package-unlocked
+           context name "binding ~A as a local macro"))
+        (unless (listp arglist)
+          (fail "The local macro argument list ~S is not a list."
+                arglist))
+        (with-unique-names (whole environment)
+          (multiple-value-bind (body local-decls)
+              (parse-defmacro arglist whole body name 'macrolet
+                              :environment environment)
+            `(,name macro .
+                    ,(compile-in-lexenv
+                      nil
+                      `(lambda (,whole ,environment)
+                         ,@local-decls
+                         ,body)
+                      lexenv))))))))
+
+(defun funcall-in-macrolet-lexenv (definitions fun context)
   (%funcall-in-foomacrolet-lexenv
-   (lambda (definition)
-     (unless (list-of-length-at-least-p definition 2)
-       (compiler-error
-       "The list ~S is too short to be a legal local macro definition."
-       definition))
-     (destructuring-bind (name arglist &body body) definition
-       (unless (symbolp name)
-        (compiler-error "The local macro name ~S is not a symbol." name))
-       (let ((whole (gensym "WHOLE"))
-            (environment (gensym "ENVIRONMENT")))
-        (multiple-value-bind (body local-decls)
-            (parse-defmacro arglist whole body name 'macrolet
-                            :environment environment)
-          `(,name macro .
-                  ,(compile nil
-                            `(lambda (,whole ,environment)
-                               ,@local-decls
-                               (block ,name ,body))))))))
+   (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*))
    :funs
    definitions
    fun))
 
-(def-ir1-translator macrolet ((definitions &rest body) start cont)
+(def-ir1-translator macrolet ((definitions &rest body) start next result)
   #!+sb-doc
-  "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
-  Evaluate the Body-Forms in an environment with the specified local macros
-  defined. Name is the local macro name, Lambda-List is the DEFMACRO style
-  destructuring lambda list, and the Forms evaluate to the expansion. The
-  Forms are evaluated in the null environment."
-  (funcall-in-macrolet-lexenv definitions
-                             (lambda ()
-                               (ir1-translate-locally body start cont))))
-
-(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+  "MACROLET ({(name lambda-list form*)}*) body-form*
+
+Evaluate the BODY-FORMS in an environment with the specified local macros
+defined. NAME is the local macro name, LAMBDA-LIST is a DEFMACRO style
+destructuring lambda list, and the FORMS evaluate to the expansion."
+  (funcall-in-macrolet-lexenv
+   definitions
+   (lambda (&key funs)
+     (declare (ignore funs))
+     (ir1-translate-locally body start next result))
+   :compile))
+
+(defun symbol-macrolet-definitionize-fun (context)
+  (flet ((fail (control &rest args)
+           (ecase context
+             (:compile (apply #'compiler-error control args))
+             (:eval (error 'simple-program-error
+                           :format-control control
+                           :format-arguments args)))))
+    (lambda (definition)
+      (unless (proper-list-of-length-p definition 2)
+        (fail "malformed symbol/expansion pair: ~S" definition))
+      (destructuring-bind (name expansion) definition
+        (unless (symbolp name)
+          (fail "The local symbol macro name ~S is not a symbol." name))
+        (when (or (boundp name) (eq (info :variable :kind name) :macro))
+          (program-assert-symbol-home-package-unlocked
+           context name "binding ~A as a local symbol-macro"))
+        (let ((kind (info :variable :kind name)))
+          (when (member kind '(:special :constant :global))
+            (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
+                  kind name)))
+        ;; A magical cons that MACROEXPAND-1 understands.
+        `(,name . (macro . ,expansion))))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
   (%funcall-in-foomacrolet-lexenv
-   (lambda (definition)
-     (unless (proper-list-of-length-p definition 2)
-       (compiler-error "malformed symbol/expansion pair: ~S" definition))
-     (destructuring-bind (name expansion) definition
-       (unless (symbolp name)
-         (compiler-error
-          "The local symbol macro name ~S is not a symbol."
-          name))
-       `(,name . (MACRO . ,expansion))))
+   (symbol-macrolet-definitionize-fun context)
    :vars
    definitions
    fun))
-  
-(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+
+(def-ir1-translator symbol-macrolet
+    ((macrobindings &body body) start next result)
   #!+sb-doc
-  "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
-  Define the Names as symbol macros with the given Expansions. Within the
-  body, references to a Name will effectively be replaced with the Expansion."
+  "SYMBOL-MACROLET ({(name expansion)}*) decl* form*
+
+Define the NAMES as symbol macros with the given EXPANSIONS. Within the
+body, references to a NAME will effectively be replaced with the EXPANSION."
   (funcall-in-symbol-macrolet-lexenv
    macrobindings
-   (lambda ()
-     (ir1-translate-locally body start cont))))
-
-;;; not really a special form, but..
-(def-ir1-translator declare ((&rest stuff) start cont)
-  (declare (ignore stuff))
-  ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
-  ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
-  ;; macro would put the DECLARE in the wrong place, so..
-  start cont
-  (compiler-error "misplaced declaration"))
+   (lambda (&key vars)
+     (ir1-translate-locally body start next result :vars vars))
+   :compile))
 \f
 ;;;; %PRIMITIVE
 ;;;;
   (handler-case (mapcar #'eval args)
     (error (condition)
       (compiler-error "Lisp error during evaluation of info args:~%~A"
-                     condition))))
+                      condition))))
 
 ;;; Convert to the %%PRIMITIVE funny function. The first argument is
 ;;; the template, the second is a list of the results of any
 ;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
 ;;; VOP or %VOP.. -- WHN 2001-06-11
 ;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
-(def-ir1-translator %primitive ((name &rest args) start cont)
-  (unless (symbolp name)
-    (compiler-error "internal error: Primitive name ~S is not a symbol." name))
+(def-ir1-translator %primitive ((name &rest args) start next result)
+  (declare (type symbol name))
   (let* ((template (or (gethash name *backend-template-names*)
-                      (compiler-error
-                       "internal error: Primitive name ~A is not defined."
-                       name)))
-        (required (length (template-arg-types template)))
-        (info (template-info-arg-count template))
-        (min (+ required info))
-        (nargs (length args)))
+                       (bug "undefined primitive ~A" name)))
+         (required (length (template-arg-types template)))
+         (info (template-info-arg-count template))
+         (min (+ required info))
+         (nargs (length args)))
     (if (template-more-args-type template)
-       (when (< nargs min)
-         (compiler-error "internal error: Primitive ~A was called ~
-                           with ~R argument~:P, ~
-                          but wants at least ~R."
-                         name
-                         nargs
-                         min))
-       (unless (= nargs min)
-         (compiler-error "internal error: Primitive ~A was called ~
-                           with ~R argument~:P, ~
-                          but wants exactly ~R."
-                         name
-                         nargs
-                         min)))
-
-    (when (eq (template-result-types template) :conditional)
-      (compiler-error
-       "%PRIMITIVE was used with a conditional template."))
+        (when (< nargs min)
+          (bug "Primitive ~A was called with ~R argument~:P, ~
+                but wants at least ~R."
+               name
+               nargs
+               min))
+        (unless (= nargs min)
+          (bug "Primitive ~A was called with ~R argument~:P, ~
+                but wants exactly ~R."
+               name
+               nargs
+               min)))
+
+    (when (template-conditional-p template)
+      (bug "%PRIMITIVE was used with a conditional template."))
 
     (when (template-more-results-type template)
-      (compiler-error
-       "%PRIMITIVE was used with an unknown values template."))
-
-    (ir1-convert start
-                cont
-                `(%%primitive ',template
-                              ',(eval-info-args
-                                 (subseq args required min))
-                              ,@(subseq args 0 required)
-                              ,@(subseq args min)))))
+      (bug "%PRIMITIVE was used with an unknown values template."))
+
+    (ir1-convert start next result
+                 `(%%primitive ',template
+                               ',(eval-info-args
+                                  (subseq args required min))
+                               ,@(subseq args 0 required)
+                               ,@(subseq args min)))))
 \f
 ;;;; QUOTE
 
-(def-ir1-translator quote ((thing) start cont)
+(def-ir1-translator quote ((thing) start next result)
   #!+sb-doc
-  "QUOTE Value
-  Return Value without evaluating it."
-  (reference-constant start cont thing))
+  "QUOTE value
+
+Return VALUE without evaluating it."
+  (reference-constant start next result thing))
 \f
-;;;; FUNCTION and NAMED-LAMBDA
+(defun name-context ()
+  ;; Name of the outermost non-NIL BLOCK, or the source namestring
+  ;; of the source file.
+  (let ((context
+          (or (car (find-if (lambda (b)
+                              (let ((name (pop b)))
+                                (and name
+                                     ;; KLUDGE: High debug adds this block on
+                                     ;; some platforms.
+                                     #!-unwind-to-frame-and-call-vop
+                                     (neq 'return-value-tag name)
+                                     ;; KLUDGE: CATCH produces blocks whose
+                                     ;; cleanup is :CATCH.
+                                     (neq :catch (cleanup-kind (entry-cleanup (pop b)))))))
+                            (lexenv-blocks *lexenv*) :from-end t))
+              *source-namestring*
+              (let ((p (or *compile-file-truename* *load-truename*)))
+                (when p (namestring p))))))
+    (when context
+      (list :in context))))
 
-(def-ir1-translator function ((thing) start cont)
-  #!+sb-doc
-  "FUNCTION Name
-  Return the lexically apparent definition of the function Name. Name may also
-  be a lambda expression."
+;;;; FUNCTION and NAMED-LAMBDA
+(defun name-lambdalike (thing)
+  (case (car thing)
+    ((named-lambda)
+     (or (second thing)
+         `(lambda ,(third thing) ,(name-context))))
+    ((lambda)
+     `(lambda ,(second thing) ,@(name-context)))
+    ((lambda-with-lexenv)
+     ;; FIXME: Get the original DEFUN name here.
+     `(lambda ,(fifth thing)))
+    (otherwise
+     (compiler-error "Not a valid lambda expression:~%  ~S"
+                     thing))))
+
+(defun fun-name-leaf (thing)
   (if (consp thing)
-      (case (car thing)
-       ((lambda)
-        (reference-leaf start
-                        cont
-                        (ir1-convert-lambda thing
-                                            :debug-name (debug-namify
-                                                         "#'~S" thing))))
-       ((setf)
-        (let ((var (find-lexically-apparent-fun
-                    thing "as the argument to FUNCTION")))
-          (reference-leaf start cont var)))
-       ((instance-lambda)
-        (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
-                                       :debug-name (debug-namify "#'~S"
-                                                                 thing))))
-          (setf (getf (functional-plist res) :fin-function) t)
-          (reference-leaf start cont res)))
-       (t
-        (compiler-error "~S is not a legal function name." thing)))
-      (let ((var (find-lexically-apparent-fun
-                 thing "as the argument to FUNCTION")))
-       (reference-leaf start cont var))))
-
-;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)),
-;;; except that the value of NAME is passed to the compiler for use in
-;;; creation of debug information for the resulting function.
-;;;
-;;; NAME can be a legal function name or some arbitrary other thing.
-;;;
-;;; If NAME is a legal function name, then the caller should be
-;;; planning to set (FDEFINITION NAME) to the created function.
-;;; (Otherwise the debug names will be inconsistent and thus
-;;; unnecessarily confusing.)
-;;;
-;;; Arbitrary other things are appropriate for naming things which are
-;;; not the FDEFINITION of NAME. E.g.
-;;;   NAME = (:FLET FOO BAR)
-;;; for the FLET function in
-;;;   (DEFUN BAR (X)
-;;;     (FLET ((FOO (Y) (+ X Y)))
-;;;       FOO))
-;;; or
-;;;   NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T))
-;;; for the function used to implement
-;;;   (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
-(def-ir1-translator named-lambda ((name &rest rest) start cont)
-  (reference-leaf start
-                 cont
-                 (if (legal-fun-name-p name)
-                     (ir1-convert-lambda `(lambda ,@rest)
-                                         :source-name name)
-                     (ir1-convert-lambda `(lambda ,@rest)
-                                         :debug-name name))))
+      (cond
+        ((member (car thing)
+                 '(lambda named-lambda lambda-with-lexenv))
+         (values (ir1-convert-lambdalike
+                  thing
+                  :debug-name (name-lambdalike thing))
+                 t))
+        ((legal-fun-name-p thing)
+         (values (find-lexically-apparent-fun
+                  thing "as the argument to FUNCTION")
+                 nil))
+        (t
+         (compiler-error "~S is not a legal function name." thing)))
+      (values (find-lexically-apparent-fun
+               thing "as the argument to FUNCTION")
+              nil)))
+
+(def-ir1-translator %%allocate-closures ((&rest leaves) start next result)
+  (aver (eq result 'nil))
+  (let ((lambdas leaves))
+    (ir1-convert start next result `(%allocate-closures ',lambdas))
+    (let ((allocator (node-dest (ctran-next start))))
+      (dolist (lambda lambdas)
+        (setf (functional-allocator lambda) allocator)))))
+
+(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body)
+  `(multiple-value-bind (,leaf allocate-p)
+       (if ,global-function
+           (find-global-fun ,thing t)
+           (fun-name-leaf ,thing))
+     (if allocate-p
+         (let ((.new-start. (make-ctran)))
+           (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
+           (let ((,start .new-start.))
+             ,@body))
+         (locally
+             ,@body))))
+
+(def-ir1-translator function ((thing) start next result)
+  #!+sb-doc
+  "FUNCTION name
+
+Return the lexically apparent definition of the function NAME. NAME may also
+be a lambda expression."
+  (with-fun-name-leaf (leaf thing start)
+    (reference-leaf start next result leaf)))
+
+;;; Like FUNCTION, but ignores local definitions and inline
+;;; expansions, and doesn't nag about undefined functions.
+;;; Used for optimizing things like (FUNCALL 'FOO).
+(def-ir1-translator global-function ((thing) start next result)
+  (with-fun-name-leaf (leaf thing start :global-function t)
+    (reference-leaf start next result leaf)))
+
+(defun constant-global-fun-name (thing)
+  (let ((constantp (sb!xc:constantp thing)))
+    (when constantp
+      (let ((name (constant-form-value thing)))
+        (when (legal-fun-name-p name)
+          name)))))
+
+(defun lvar-constant-global-fun-name (lvar)
+  (when (constant-lvar-p lvar)
+    (let ((name (lvar-value lvar)))
+      (when (legal-fun-name-p name)
+        name))))
+
+(defun ensure-source-fun-form (source &optional give-up)
+  (let ((op (when (consp source) (car source))))
+    (cond ((eq op '%coerce-callable-to-fun)
+           (ensure-source-fun-form (second source)))
+          ((member op '(function global-function lambda named-lambda))
+           (values source nil))
+          (t
+           (let ((cname (constant-global-fun-name source)))
+             (if cname
+                 (values `(global-function ,cname) nil)
+                 (values `(%coerce-callable-to-fun ,source) give-up)))))))
+
+(defun ensure-lvar-fun-form (lvar lvar-name &optional give-up)
+  (aver (and lvar-name (symbolp lvar-name)))
+  (if (csubtypep (lvar-type lvar) (specifier-type 'function))
+      lvar-name
+      (let ((cname (lvar-constant-global-fun-name lvar)))
+        (cond (cname
+               `(global-function ,cname))
+              (give-up
+               (give-up-ir1-transform "not known to be a function"))
+              (t
+               `(%coerce-callable-to-fun ,lvar-name))))))
 \f
 ;;;; FUNCALL
 
 ;;; FUNCALL is implemented on %FUNCALL, which can only call functions
 ;;; (not symbols). %FUNCALL is used directly in some places where the
 ;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
-(deftransform funcall ((function &rest args) * * :when :both)
+(deftransform funcall ((function &rest args) * *)
   (let ((arg-names (make-gensym-list (length args))))
     `(lambda (function ,@arg-names)
-       (%funcall ,(if (csubtypep (continuation-type function)
-                                (specifier-type 'function))
-                     'function
-                     '(%coerce-callable-to-fun function))
-                ,@arg-names))))
-
-(def-ir1-translator %funcall ((function &rest args) start cont)
-  (let ((fun-cont (make-continuation)))
-    (ir1-convert start fun-cont function)
-    (assert-continuation-type fun-cont (specifier-type 'function))
-    (ir1-convert-combination-args fun-cont cont args)))
+       (declare (ignorable function))
+       `(%funcall ,(ensure-lvar-fun-form function 'function) ,@arg-names))))
+
+(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 (%macroexpand function *lexenv*))
+         (op (when (consp function) (car function))))
+    (cond ((eq op 'function)
+           (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)
+           (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)))
+             (ir1-convert start ctran fun-lvar `(the function ,function))
+             (ir1-convert-combination-args fun-lvar ctran next result args))))))
 
 ;;; This source transform exists to reduce the amount of work for the
 ;;; compiler. If the called function is a FUNCTION form, then convert
 ;;; directly to %FUNCALL, instead of waiting around for type
 ;;; inference.
 (define-source-transform funcall (function &rest args)
-  (if (and (consp function) (eq (car function) 'function))
-      `(%funcall ,function ,@args)
-      (values nil t)))
+  `(%funcall ,(ensure-source-fun-form function) ,@args))
 
-(deftransform %coerce-callable-to-fun ((thing) (function) *
-                                      :when :both
-                                      :important t)
+(deftransform %coerce-callable-to-fun ((thing) * * :node node)
   "optimize away possible call to FDEFINITION at runtime"
-  'thing)
+  (ensure-lvar-fun-form thing 'thing t))
+
+(define-source-transform %coerce-callable-to-fun (thing)
+  (ensure-source-fun-form thing t))
 \f
 ;;;; LET and LET*
 ;;;;
 ;;;; any pervasive declarations also affect the evaluation of the
 ;;;; arguments.)
 
-;;; Given a list of binding specifiers in the style of Let, return:
+;;; Given a list of binding specifiers in the style of LET, return:
 ;;;  1. The list of var structures for the variables bound.
 ;;;  2. The initial value form for each variable.
 ;;;
 ;;; The variable names are checked for legality and globally special
 ;;; variables are marked as such. Context is the name of the form, for
 ;;; error reporting purposes.
-(declaim (ftype (function (list symbol) (values list list list))
-               extract-let-vars))
+(declaim (ftype (function (list symbol) (values list list))
+                extract-let-vars))
 (defun extract-let-vars (bindings context)
   (collect ((vars)
-           (vals)
-           (names))
+            (vals)
+            (names))
     (flet ((get-var (name)
-            (varify-lambda-arg name
-                               (if (eq context 'let*)
-                                   nil
-                                   (names)))))
+             (varify-lambda-arg name
+                                (if (eq context 'let*)
+                                    nil
+                                    (names))
+                                context)))
       (dolist (spec bindings)
-       (cond ((atom spec)
-              (let ((var (get-var spec)))
-                (vars var)
-                (names (cons spec var))
-                (vals nil)))
-             (t
-              (unless (proper-list-of-length-p spec 1 2)
-                (compiler-error "The ~S binding spec ~S is malformed."
-                                context
-                                spec))
-              (let* ((name (first spec))
-                     (var (get-var name)))
-                (vars var)
-                (names name)
-                (vals (second spec)))))))
-
-    (values (vars) (vals) (names))))
-
-(def-ir1-translator let ((bindings &body body)
-                        start cont)
+        (cond ((atom spec)
+               (let ((var (get-var spec)))
+                 (vars var)
+                 (names spec)
+                 (vals nil)))
+              (t
+               (unless (proper-list-of-length-p spec 1 2)
+                 (compiler-error "The ~S binding spec ~S is malformed."
+                                 context
+                                 spec))
+               (let* ((name (first spec))
+                      (var (get-var name)))
+                 (vars var)
+                 (names name)
+                 (vals (second spec)))))))
+    (dolist (name (names))
+      (when (eq (info :variable :kind name) :macro)
+        (program-assert-symbol-home-package-unlocked
+         :compile name "lexically binding symbol-macro ~A")))
+    (values (vars) (vals))))
+
+(def-ir1-translator let ((bindings &body body) start next result)
   #!+sb-doc
-  "LET ({(Var [Value]) | Var}*) Declaration* Form*
-  During evaluation of the Forms, bind the Vars to the result of evaluating the
-  Value forms. The variables are bound in parallel after all of the Values are
-  evaluated."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
-      (let* ((*lexenv* (process-decls decls vars nil cont))
-            (fun-cont (make-continuation))
-            (fun (ir1-convert-lambda-body
-                  forms vars :debug-name (debug-namify "LET ~S" bindings))))
-       (reference-leaf start fun-cont fun)
-       (ir1-convert-combination-args fun-cont cont values)))))
+  "LET ({(var [value]) | var}*) declaration* form*
+
+During evaluation of the FORMS, bind the VARS to the result of evaluating the
+VALUE forms. The variables are bound in parallel after all of the VALUES forms
+have been evaluated."
+  (cond ((null bindings)
+         (ir1-translate-locally body start next result))
+        ((listp bindings)
+         (multiple-value-bind (forms decls)
+             (parse-body body :doc-string-allowed nil)
+           (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+             (binding* ((ctran (make-ctran))
+                        (fun-lvar (make-lvar))
+                        ((next result)
+                         (processing-decls (decls vars nil next result
+                                                  post-binding-lexenv)
+                           (let ((fun (ir1-convert-lambda-body
+                                       forms
+                                       vars
+                                       :post-binding-lexenv post-binding-lexenv
+                                       :debug-name (debug-name 'let bindings))))
+                             (reference-leaf start ctran fun-lvar fun))
+                           (values next result))))
+               (ir1-convert-combination-args fun-lvar ctran next result values)))))
+        (t
+         (compiler-error "Malformed LET bindings: ~S." bindings))))
 
 (def-ir1-translator let* ((bindings &body body)
-                         start cont)
+                          start next result)
   #!+sb-doc
-  "LET* ({(Var [Value]) | Var}*) Declaration* Form*
-  Similar to LET, but the variables are bound sequentially, allowing each Value
-  form to reference any of the previous Vars."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
-      (let ((*lexenv* (process-decls decls vars nil cont)))
-       (ir1-convert-aux-bindings start cont forms vars values)))))
+  "LET* ({(var [value]) | var}*) declaration* form*
+
+Similar to LET, but the variables are bound sequentially, allowing each VALUE
+form to reference any of the previous VARS."
+  (if (listp bindings)
+      (multiple-value-bind (forms decls)
+          (parse-body body :doc-string-allowed nil)
+        (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
+          (processing-decls (decls vars nil next result post-binding-lexenv)
+            (ir1-convert-aux-bindings start
+                                      next
+                                      result
+                                      forms
+                                      vars
+                                      values
+                                      post-binding-lexenv))))
+      (compiler-error "Malformed LET* bindings: ~S." bindings)))
 
 ;;; logic shared between IR1 translators for LOCALLY, MACROLET,
 ;;; and SYMBOL-MACROLET
 ;;; but we don't need to worry about that within an IR1 translator,
 ;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO
 ;;; forms before we hit the IR1 transform level.
-(defun ir1-translate-locally (body start cont)
-  (declare (type list body) (type continuation start cont))
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (let ((*lexenv* (process-decls decls nil nil cont)))
-      (ir1-convert-aux-bindings start cont forms nil nil))))
-
-(def-ir1-translator locally ((&body body) start cont)
+(defun ir1-translate-locally (body start next result &key vars funs)
+  (declare (type ctran start next) (type (or lvar null) result)
+           (type list body))
+  (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+    (processing-decls (decls vars funs next result)
+      (ir1-convert-progn-body start next result forms))))
+
+(def-ir1-translator locally ((&body body) start next result)
   #!+sb-doc
-  "LOCALLY Declaration* Form*
-  Sequentially evaluate the Forms in a lexical environment where the
-  the Declarations have effect. If LOCALLY is a top level form, then
-  the Forms are also processed as top level forms."
-  (ir1-translate-locally body start cont))
+  "LOCALLY declaration* form*
+
+Sequentially evaluate the FORMS in a lexical environment where the
+DECLARATIONS have effect. If LOCALLY is a top level form, then the FORMS are
+also processed as top level forms."
+  (ir1-translate-locally body start next result))
 \f
 ;;;; FLET and LABELS
 
 (declaim (ftype (function (list symbol) (values list list)) extract-flet-vars))
 (defun extract-flet-vars (definitions context)
   (collect ((names)
-           (defs))
+            (defs))
     (dolist (def definitions)
       (when (or (atom def) (< (length def) 2))
-       (compiler-error "The ~S definition spec ~S is malformed." context def))
+        (compiler-error "The ~S definition spec ~S is malformed." context def))
 
       (let ((name (first def)))
-       (check-fun-name name)
-       (names name)
-       (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
-         (defs `(lambda ,(second def)
-                  ,@decls
-                  (block ,(fun-name-block-name name)
-                    . ,forms))))))
+        (check-fun-name name)
+        (when (fboundp name)
+          (program-assert-symbol-home-package-unlocked
+           :compile name "binding ~A as a local function"))
+        (names name)
+        (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))))))
     (values (names) (defs))))
 
+(defun ir1-convert-fbindings (start next result funs body)
+  (let ((ctran (make-ctran))
+        (dx-p (find-if #'leaf-dynamic-extent funs)))
+    (when dx-p
+      (ctran-starts-block ctran)
+      (ctran-starts-block next))
+    (ir1-convert start ctran nil `(%%allocate-closures ,@funs))
+    (cond (dx-p
+           (let* ((dummy (make-ctran))
+                  (entry (make-entry))
+                  (cleanup (make-cleanup :kind :dynamic-extent
+                                         :mess-up entry
+                                         :info (list (node-dest
+                                                      (ctran-next start))))))
+             (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+             (setf (entry-cleanup entry) cleanup)
+             (link-node-to-previous-ctran entry ctran)
+             (use-ctran entry dummy)
+
+             (let ((*lexenv* (make-lexenv :cleanup cleanup)))
+               (ir1-convert-progn-body dummy next result body))))
+          (t (ir1-convert-progn-body ctran next result body)))))
+
 (def-ir1-translator flet ((definitions &body body)
-                         start cont)
+                          start next result)
   #!+sb-doc
-  "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
-  Evaluate the Body-Forms with some local function definitions. The bindings
-  do not enclose the definitions; any use of Name in the Forms will refer to
-  the lexically apparent function definition in the enclosing environment."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+  "FLET ({(name lambda-list declaration* form*)}*) declaration* body-form*
+
+Evaluate the BODY-FORMS with local function definitions. The bindings do
+not enclose the definitions; any use of NAME in the FORMS will refer to the
+lexically apparent function definition in the enclosing environment."
+  (multiple-value-bind (forms decls)
+      (parse-body body :doc-string-allowed nil)
     (multiple-value-bind (names defs)
-       (extract-flet-vars definitions 'flet)
-      (let* ((fvars (mapcar (lambda (n d)
-                             (ir1-convert-lambda d
-                                                 :source-name n
-                                                 :debug-name (debug-namify
-                                                              "FLET ~S" n)))
-                           names defs))
-            (*lexenv* (make-lexenv
-                       :default (process-decls decls nil fvars cont)
-                       :funs (pairlis names fvars))))
-       (ir1-convert-progn-body start cont forms)))))
-
-(def-ir1-translator labels ((definitions &body body) start cont)
+        (extract-flet-vars definitions 'flet)
+      (let ((fvars (mapcar (lambda (n d)
+                             (ir1-convert-lambda
+                              d :source-name n
+                                :maybe-add-debug-catch t
+                                :debug-name
+                                (debug-name 'flet n t)))
+                           names defs)))
+        (processing-decls (decls nil fvars next result)
+          (let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
+            (ir1-convert-fbindings start next result fvars forms)))))))
+
+(def-ir1-translator labels ((definitions &body body) start next result)
   #!+sb-doc
-  "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
-  Evaluate the Body-Forms with some local function definitions. The bindings
-  enclose the new definitions, so the defined functions can call themselves or
-  each other."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+  "LABELS ({(name lambda-list declaration* form*)}*) declaration* body-form*
+
+Evaluate the BODY-FORMS with local function definitions. The bindings enclose
+the new definitions, so the defined functions can call themselves or each
+other."
+  (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
     (multiple-value-bind (names defs)
-       (extract-flet-vars definitions 'labels)
+        (extract-flet-vars definitions 'labels)
       (let* (;; dummy LABELS functions, to be used as placeholders
              ;; during construction of real LABELS functions
-            (placeholder-funs (mapcar (lambda (name)
-                                        (make-functional
-                                         :%source-name name
-                                         :%debug-name (debug-namify
-                                                       "LABELS placeholder ~S"
-                                                       name)))
-                                      names))
-            ;; (like PAIRLIS but guaranteed to preserve ordering:)
-            (placeholder-fenv (mapcar #'cons names placeholder-funs))
+             (placeholder-funs (mapcar (lambda (name)
+                                         (make-functional
+                                          :%source-name name
+                                          :%debug-name (debug-name
+                                                        'labels-placeholder
+                                                        name)))
+                                       names))
+             ;; (like PAIRLIS but guaranteed to preserve ordering:)
+             (placeholder-fenv (mapcar #'cons names placeholder-funs))
              ;; the real LABELS functions, compiled in a LEXENV which
              ;; includes the dummy LABELS functions
-            (real-funs
-             (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
-               (mapcar (lambda (name def)
-                         (ir1-convert-lambda def
-                                             :source-name name
-                                             :debug-name (debug-namify
-                                                          "LABELS ~S" name)))
-                       names defs))))
+             (real-funs
+              (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
+                (mapcar (lambda (name def)
+                          (ir1-convert-lambda def
+                                              :source-name name
+                                              :maybe-add-debug-catch t
+                                              :debug-name (debug-name 'labels name t)))
+                        names defs))))
 
         ;; Modify all the references to the dummy function leaves so
         ;; that they point to the real function leaves.
-       (loop for real-fun in real-funs and
-             placeholder-cons in placeholder-fenv do
-             (substitute-leaf real-fun (cdr placeholder-cons))
-             (setf (cdr placeholder-cons) real-fun))
+        (loop for real-fun in real-funs and
+              placeholder-cons in placeholder-fenv do
+              (substitute-leaf real-fun (cdr placeholder-cons))
+              (setf (cdr placeholder-cons) real-fun))
 
         ;; Voila.
-       (let ((*lexenv* (make-lexenv
-                        :default (process-decls decls nil real-funs cont)
-                         ;; Use a proper FENV here (not the
-                         ;; placeholder used earlier) so that if the
-                         ;; lexical environment is used for inline
-                         ;; expansion we'll get the right functions.
-                         :funs (pairlis names real-funs))))
-         (ir1-convert-progn-body start cont forms))))))
+        (processing-decls (decls nil real-funs next result)
+          (let ((*lexenv* (make-lexenv
+                           ;; Use a proper FENV here (not the
+                           ;; placeholder used earlier) so that if the
+                           ;; lexical environment is used for inline
+                           ;; expansion we'll get the right functions.
+                           :funs (pairlis names real-funs))))
+            (ir1-convert-fbindings start next result real-funs forms)))))))
+
 \f
 ;;;; the THE special operator, and friends
 
-;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
-;;; continuation that the assertion applies to, TYPE is the type
-;;; specifier and LEXENV is the current lexical environment. NAME is
-;;; the name of the declaration we are doing, for use in error
-;;; messages.
-;;;
-;;; This is somewhat involved, since a type assertion may only be made
-;;; on a continuation, not on a node. We can't just set the
-;;; continuation asserted type and let it go at that, since there may
-;;; be parallel THE's for the same continuation, i.e.
-;;;     (if ...
-;;;     (the foo ...)
-;;;     (the bar ...))
-;;;
-;;; In this case, our representation can do no better than the union
-;;; of these assertions. And if there is a branch with no assertion,
-;;; we have nothing at all. We really need to recognize scoping, since
-;;; we need to be able to discern between parallel assertions (which
-;;; we union) and nested ones (which we intersect).
-;;;
-;;; We represent the scoping by throwing our innermost (intersected)
-;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If CONT has no uses yet, we
-;;; have not yet bottomed out on the first COND branch; in this case
-;;; we optimistically assume that this type will be the one we end up
-;;; with, and set the ASSERTED-TYPE to it. We can never get better
-;;; than the type that we have the first time we bottom out. Later
-;;; THE's (or the absence thereof) can only weaken this result.
-;;;
-;;; We make this work by getting USE-CONTINUATION to do the unioning
-;;; across COND branches. We can't do it here, since we don't know how
-;;; many branches there are going to be.
-(defun ir1ize-the-or-values (type cont lexenv name)
-  (declare (type continuation cont) (type lexenv lexenv))
-  (let* ((ctype (values-specifier-type type))
-        (old-type (or (lexenv-find cont type-restrictions)
-                      *wild-type*))
-        (intersects (values-types-equal-or-intersect old-type ctype))
-        (int (values-type-intersection old-type ctype))
-        (new (if intersects int old-type)))
-    (when (null (find-uses cont))
-      (setf (continuation-asserted-type cont) new))
-    (when (and (not intersects)
-              (not (policy *lexenv*
-                           (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
-      (compiler-warn
-       "The type ~S in ~S declaration conflicts with an ~
-        enclosing assertion:~%   ~S"
-       (type-specifier ctype)
-       name
-       (type-specifier old-type)))
-    (make-lexenv :type-restrictions `((,cont . ,new))
-                :default lexenv)))
+;;; A logic shared among THE and TRULY-THE.
+(defun the-in-policy (type value policy start next result)
+  (let ((type (if (ctype-p type) type
+                   (compiler-values-specifier-type type))))
+    (cond ((or (eq type *wild-type*)
+               (eq type *universal-type*)
+               (and (leaf-p value)
+                    (values-subtypep (make-single-value-type (leaf-type value))
+                                     type))
+               (and (sb!xc:constantp value)
+                    (or (not (values-type-p type))
+                        (values-type-may-be-single-value-p type))
+                    (ctypep (constant-form-value value)
+                            (single-value-type type))))
+           (ir1-convert start next result value))
+          (t (let ((value-ctran (make-ctran))
+                   (value-lvar (make-lvar)))
+               (ir1-convert start value-ctran value-lvar value)
+               (let ((cast (make-cast value-lvar type policy)))
+                 (link-node-to-previous-ctran cast value-ctran)
+                 (setf (lvar-dest value-lvar) cast)
+                 (use-continuation cast next result)))))))
 
 ;;; Assert that FORM evaluates to the specified type (which may be a
-;;; VALUES type).
-;;;
-;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
-;;; this didn't seem to expand into an assertion, at least for ALIEN
-;;; values. Check that SBCL doesn't have this problem.
-(def-ir1-translator the ((type value) start cont)
-  (let ((*lexenv* (ir1ize-the-or-values type cont *lexenv* 'the)))
-    (ir1-convert start cont value)))
+;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
+(def-ir1-translator the ((value-type form) start next result)
+  #!+sb-doc
+  "Specifies that the values returned by FORM conform to the VALUE-TYPE.
+
+CLHS specifies that the consequences are undefined if any result is
+not of the declared type, but SBCL treats declarations as assertions
+as long as SAFETY is at least 2, in which case incorrect type
+information will result in a runtime type-error instead of leading to
+eg. heap corruption. This is however expressly non-portable: use
+CHECK-TYPE instead of THE to catch type-errors at runtime. THE is best
+considered an optimization tool to inform the compiler about types it
+is unable to derive from other declared types."
+  (the-in-policy value-type form (lexenv-policy *lexenv*) start next result))
 
 ;;; This is like the THE special form, except that it believes
 ;;; 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.
 ;;;
-;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
-;;; its uses's types, setting it won't work. Instead we must intersect
-;;; the type with the uses's DERIVED-TYPE.
-(def-ir1-translator truly-the ((type value) start cont)
+;;; 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
-  (declare (inline member))
-  (let ((type (values-specifier-type type))
-       (old (find-uses cont)))
-    (ir1-convert start cont value)
-    (do-uses (use cont)
-      (unless (member use old :test #'eq)
-       (derive-node-type use type)))))
+  "Specifies that the values returned by FORM conform to the
+VALUE-TYPE, and causes the compiler to trust this information
+unconditionally.
+
+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
 
 ;;; If there is a definition in LEXENV-VARS, just set that, otherwise
 ;;; look at the global information. If the name is for a constant,
 ;;; then error out.
-(def-ir1-translator setq ((&whole source &rest things) start cont)
+(def-ir1-translator setq ((&whole source &rest things) start next result)
   (let ((len (length things)))
     (when (oddp len)
       (compiler-error "odd number of args to SETQ: ~S" source))
     (if (= len 2)
-       (let* ((name (first things))
-              (leaf (or (lexenv-find name vars)
-                        (find-free-var name))))
-         (etypecase leaf
-           (leaf
-            (when (constant-p leaf)
-              (compiler-error "~S is a constant and thus can't be set." name))
-            (when (lambda-var-p leaf)
-              (let ((home-lambda (continuation-home-lambda-or-null start)))
-                (when home-lambda
-                  (pushnew leaf (lambda-calls-or-closes home-lambda))))
-              (when (lambda-var-ignorep leaf)
-                ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
-                ;; requires that this be a STYLE-WARNING, not a full warning.
-                (compiler-style-warn
-                 "~S is being set even though it was declared to be ignored."
-                 name)))
-            (setq-var start cont leaf (second things)))
-           (cons
-            (aver (eq (car leaf) 'MACRO))
-            (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
-           (heap-alien-info
-            (ir1-convert start cont
-                         `(%set-heap-alien ',leaf ,(second things))))))
-       (collect ((sets))
-         (do ((thing things (cddr thing)))
-             ((endp thing)
-              (ir1-convert-progn-body start cont (sets)))
-           (sets `(setq ,(first thing) ,(second thing))))))))
+        (let* ((name (first things))
+               (value-form (second things))
+               (leaf (or (lexenv-find name vars) (find-free-var name))))
+          (etypecase leaf
+            (leaf
+             (when (constant-p leaf)
+               (compiler-error "~S is a constant and thus can't be set." name))
+             (when (lambda-var-p leaf)
+               (let ((home-lambda (ctran-home-lambda-or-null start)))
+                 (when home-lambda
+                   (sset-adjoin leaf (lambda-calls-or-closes home-lambda))))
+               (when (lambda-var-ignorep leaf)
+                 ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+                 ;; requires that this be a STYLE-WARNING, not a full warning.
+                 (compiler-style-warn
+                  "~S is being set even though it was declared to be ignored."
+                  name)))
+             (if (and (global-var-p leaf) (eq :unknown (global-var-kind leaf)))
+                 ;; For undefined variables go through SET, so that we can catch
+                 ;; constant modifications.
+                 (ir1-convert start next result `(set ',name ,value-form))
+                 (setq-var start next result leaf value-form)))
+            (cons
+             (aver (eq (car leaf) 'macro))
+             ;; FIXME: [Free] type declaration. -- APD, 2002-01-26
+             (ir1-convert start next result
+                          `(setf ,(cdr leaf) ,(second things))))
+            (heap-alien-info
+             (ir1-convert start next result
+                          `(%set-heap-alien ',leaf ,(second things))))))
+        (collect ((sets))
+          (do ((thing things (cddr thing)))
+              ((endp thing)
+               (ir1-convert-progn-body start next result (sets)))
+            (sets `(setq ,(first thing) ,(second thing))))))))
 
 ;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
 ;;; This should only need to be called in SETQ.
-(defun setq-var (start cont var value)
-  (declare (type continuation start cont) (type basic-var var))
-  (let ((dest (make-continuation)))
-    (setf (continuation-asserted-type dest) (leaf-type var))
-    (ir1-convert start dest value)
-    (let ((res (make-set :var var :value dest)))
-      (setf (continuation-dest dest) res)
+(defun setq-var (start next result var value)
+  (declare (type ctran start next) (type (or lvar null) result)
+           (type basic-var var))
+  (let ((dest-ctran (make-ctran))
+        (dest-lvar (make-lvar))
+        (type (or (lexenv-find var type-restrictions)
+                  (leaf-type var))))
+    (ir1-convert start dest-ctran dest-lvar `(the ,(type-specifier type)
+                                                  ,value))
+    (let ((res (make-set :var var :value dest-lvar)))
+      (setf (lvar-dest dest-lvar) res)
       (setf (leaf-ever-used var) t)
       (push res (basic-var-sets var))
-      (link-node-to-previous-continuation res dest)
-      (use-continuation res cont))))
+      (link-node-to-previous-ctran res dest-ctran)
+      (use-continuation res next result))))
 \f
 ;;;; CATCH, THROW and UNWIND-PROTECT
 
-;;; We turn THROW into a multiple-value-call of a magical function,
+;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function,
 ;;; since as as far as IR1 is concerned, it has no interesting
 ;;; properties other than receiving multiple-values.
-(def-ir1-translator throw ((tag result) start cont)
+(def-ir1-translator throw ((tag result) start next result-lvar)
   #!+sb-doc
-  "Throw Tag Form
-  Do a non-local exit, return the values of Form from the CATCH whose tag
-  evaluates to the same thing as Tag."
-  (ir1-convert start cont
-              `(multiple-value-call #'%throw ,tag ,result)))
+  "THROW tag form
+
+Do a non-local exit, return the values of FORM from the CATCH whose tag is EQ
+to TAG."
+  (ir1-convert start next result-lvar
+               `(multiple-value-call #'%throw ,tag ,result)))
 
 ;;; This is a special special form used to instantiate a cleanup as
 ;;; the current cleanup within the body. KIND is the kind of cleanup
 ;;; and introduce the cleanup into the lexical environment. We
 ;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
 ;;; cleanup, since this inner cleanup is the interesting one.
-(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
-  (let ((dummy (make-continuation))
-       (dummy2 (make-continuation)))
-    (ir1-convert start dummy mess-up)
-    (let* ((mess-node (continuation-use dummy))
-          (cleanup (make-cleanup :kind kind
-                                 :mess-up mess-node))
-          (old-cup (lexenv-cleanup *lexenv*))
-          (*lexenv* (make-lexenv :cleanup cleanup)))
+(def-ir1-translator %within-cleanup
+    ((kind mess-up &body body) start next result)
+  (let ((dummy (make-ctran))
+        (dummy2 (make-ctran)))
+    (ir1-convert start dummy nil mess-up)
+    (let* ((mess-node (ctran-use dummy))
+           (cleanup (make-cleanup :kind kind
+                                  :mess-up mess-node))
+           (old-cup (lexenv-cleanup *lexenv*))
+           (*lexenv* (make-lexenv :cleanup cleanup)))
       (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
-      (ir1-convert dummy dummy2 '(%cleanup-point))
-      (ir1-convert-progn-body dummy2 cont body))))
+      (ir1-convert dummy dummy2 nil '(%cleanup-point))
+      (ir1-convert-progn-body dummy2 next result body))))
 
 ;;; This is a special special form that makes an "escape function"
 ;;; which returns unknown values from named block. We convert the
 ;;;
 ;;; Note that environment analysis replaces references to escape
 ;;; functions with references to the corresponding NLX-INFO structure.
-(def-ir1-translator %escape-fun ((tag) start cont)
-  (let ((fun (ir1-convert-lambda
-             `(lambda ()
-                (return-from ,tag (%unknown-values)))
-             :debug-name (debug-namify "escape function for ~S" tag))))
+(def-ir1-translator %escape-fun ((tag) start next result)
+  (let ((fun (let ((*allow-instrumenting* nil))
+               (ir1-convert-lambda
+                `(lambda ()
+                   (return-from ,tag (%unknown-values)))
+                :debug-name (debug-name 'escape-fun tag))))
+        (ctran (make-ctran)))
     (setf (functional-kind fun) :escape)
-    (reference-leaf start cont fun)))
+    (ir1-convert start ctran nil `(%%allocate-closures ,fun))
+    (reference-leaf ctran next result fun)))
 
 ;;; Yet another special special form. This one looks up a local
 ;;; function and smashes it to a :CLEANUP function, as well as
 ;;; referencing it.
-(def-ir1-translator %cleanup-fun ((name) start cont)
+(def-ir1-translator %cleanup-fun ((name) start next result)
+  ;; FIXME: Should this not be :TEST #'EQUAL? What happens to
+  ;; (SETF FOO) here?
   (let ((fun (lexenv-find name funs)))
     (aver (lambda-p fun))
     (setf (functional-kind fun) :cleanup)
-    (reference-leaf start cont fun)))
+    (reference-leaf start next result fun)))
 
-;;; We represent the possibility of the control transfer by making an
-;;; "escape function" that does a lexical exit, and instantiate the
-;;; cleanup using %WITHIN-CLEANUP.
-(def-ir1-translator catch ((tag &body body) start cont)
+(def-ir1-translator catch ((tag &body body) start next result)
   #!+sb-doc
-  "Catch Tag Form*
-  Evaluates Tag and instantiates it as a catcher while the body forms are
-  evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
-  scope of the body, then control will be transferred to the end of the body
-  and the thrown values will be returned."
+  "CATCH tag form*
+
+Evaluate TAG and instantiate it as a catcher while the body forms are
+evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic
+scope of the body, then control will be transferred to the end of the body and
+the thrown values will be returned."
+  ;; We represent the possibility of the control transfer by making an
+  ;; "escape function" that does a lexical exit, and instantiate the
+  ;; cleanup using %WITHIN-CLEANUP.
   (ir1-convert
-   start cont
-   (let ((exit-block (gensym "EXIT-BLOCK-")))
+   start next result
+   (with-unique-names (exit-block)
      `(block ,exit-block
-       (%within-cleanup
-           :catch
-           (%catch (%escape-fun ,exit-block) ,tag)
-         ,@body)))))
-
-;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
-;;; cleanup forms into a local function so that they can be referenced
-;;; both in the case where we are unwound and in any local exits. We
-;;; use %CLEANUP-FUN on this to indicate that reference by
-;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
-;;; an XEP.
-(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
+        (%within-cleanup
+         :catch (%catch (%escape-fun ,exit-block) ,tag)
+         ,@body)))))
+
+(def-ir1-translator unwind-protect
+    ((protected &body cleanup) start next result)
   #!+sb-doc
-  "Unwind-Protect Protected Cleanup*
-  Evaluate the form Protected, returning its values. The cleanup forms are
-  evaluated whenever the dynamic scope of the Protected form is exited (either
-  due to normal completion or a non-local exit such as THROW)."
+  "UNWIND-PROTECT protected cleanup*
+
+Evaluate the form PROTECTED, returning its values. The CLEANUP forms are
+evaluated whenever the dynamic scope of the PROTECTED form is exited (either
+due to normal completion or a non-local exit such as THROW)."
+  ;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
+  ;; cleanup forms into a local function so that they can be referenced
+  ;; both in the case where we are unwound and in any local exits. We
+  ;; use %CLEANUP-FUN on this to indicate that reference by
+  ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
+  ;; an XEP.
   (ir1-convert
-   start cont
-   (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
-        (drop-thru-tag (gensym "DROP-THRU-TAG-"))
-        (exit-tag (gensym "EXIT-TAG-"))
-        (next (gensym "NEXT"))
-        (start (gensym "START"))
-        (count (gensym "COUNT")))
-     `(flet ((,cleanup-fun () ,@cleanup nil))
-       ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
-       ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
-       ;; and something can be done to make %ESCAPE-FUN have
-       ;; dynamic extent too.
-       (block ,drop-thru-tag
-         (multiple-value-bind (,next ,start ,count)
-             (block ,exit-tag
-               (%within-cleanup
-                   :unwind-protect
-                   (%unwind-protect (%escape-fun ,exit-tag)
-                                    (%cleanup-fun ,cleanup-fun))
-                 (return-from ,drop-thru-tag ,protected)))
-           (,cleanup-fun)
-           (%continue-unwind ,next ,start ,count)))))))
+   start next result
+   (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)
+     `(flet ((,cleanup-fun ()
+               ,@cleanup
+               nil))
+        ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
+        ;; ,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
+                (%within-cleanup
+                    :unwind-protect
+                    (%unwind-protect (%escape-fun ,exit-tag)
+                                     (%cleanup-fun ,cleanup-fun))
+                  (return-from ,drop-thru-tag ,protected)))
+            (declare (optimize (insert-debug-catch 0)))
+            (,cleanup-fun)
+            (%continue-unwind ,next ,start ,count)))))))
 \f
 ;;;; multiple-value stuff
 
-;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-COMBINATION.
-;;;
-;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-COMBINATION always has at least
-;;; one argument. This can be regarded as an optimization, but it is
-;;; more important for simplifying compilation of MV-COMBINATIONS.
-(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
+(def-ir1-translator multiple-value-call ((fun &rest args) start next result)
   #!+sb-doc
-  "MULTIPLE-VALUE-CALL Function Values-Form*
-  Call Function, passing all the values of each Values-Form as arguments,
-  values from the first Values-Form making up the first argument, etc."
-  (let* ((fun-cont (make-continuation))
-        (node (if args
-                  (make-mv-combination fun-cont)
-                  (make-combination fun-cont))))
-    (ir1-convert start fun-cont
-                (if (and (consp fun) (eq (car fun) 'function))
-                    fun
-                    `(%coerce-callable-to-fun ,fun)))
-    (setf (continuation-dest fun-cont) node)
-    (assert-continuation-type fun-cont
-                             (specifier-type '(or function symbol)))
-    (collect ((arg-conts))
-      (let ((this-start fun-cont))
-       (dolist (arg args)
-         (let ((this-cont (make-continuation node)))
-           (ir1-convert this-start this-cont arg)
-           (setq this-start this-cont)
-           (arg-conts this-cont)))
-       (link-node-to-previous-continuation node this-start)
-       (use-continuation node cont)
-       (setf (basic-combination-args node) (arg-conts))))))
-
-;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
-;;; the result code use result continuation (CONT), but transfer
-;;; control to the evaluation of the body. In other words, the result
-;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
-;;; the result.
-;;;
-;;; In order to get the control flow right, we convert the result with
-;;; a dummy result continuation, then convert all the uses of the
-;;; dummy to be uses of CONT. If a use is an EXIT, then we also
-;;; substitute CONT for the dummy in the corresponding ENTRY node so
-;;; that they are consistent. Note that this doesn't amount to
-;;; changing the exit target, since the control destination of an exit
-;;; is determined by the block successor; we are just indicating the
-;;; continuation that the result is delivered to.
-;;;
-;;; We then convert the body, using another dummy continuation in its
-;;; own block as the result. After we are done converting the body, we
-;;; move all predecessors of the dummy end block to CONT's block.
-;;;
-;;; Note that we both exploit and maintain the invariant that the CONT
-;;; to an IR1 convert method either has no block or starts the block
-;;; that control should transfer to after completion for the form.
-;;; Nested MV-PROG1's work because during conversion of the result
-;;; form, we use dummy continuation whose block is the true control
-;;; destination.
-(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
+  "MULTIPLE-VALUE-CALL function values-form*
+
+Call FUNCTION, passing all the values of each VALUES-FORM as arguments,
+values from the first VALUES-FORM making up the first argument, etc."
+  (let* ((ctran (make-ctran))
+         (fun-lvar (make-lvar))
+         (node (if args
+                   ;; If there are arguments, MULTIPLE-VALUE-CALL
+                   ;; turns into an MV-COMBINATION.
+                   (make-mv-combination fun-lvar)
+                   ;; If there are no arguments, then we convert to a
+                   ;; normal combination, ensuring that a MV-COMBINATION
+                   ;; always has at least one argument. This can be
+                   ;; regarded as an optimization, but it is more
+                   ;; important for simplifying compilation of
+                   ;; MV-COMBINATIONS.
+                   (make-combination fun-lvar))))
+    (ir1-convert start ctran fun-lvar (ensure-source-fun-form fun))
+    (setf (lvar-dest fun-lvar) node)
+    (collect ((arg-lvars))
+      (let ((this-start ctran))
+        (dolist (arg args)
+          (let ((this-ctran (make-ctran))
+                (this-lvar (make-lvar node)))
+            (ir1-convert this-start this-ctran this-lvar arg)
+            (setq this-start this-ctran)
+            (arg-lvars this-lvar)))
+        (link-node-to-previous-ctran node this-start)
+        (use-continuation node next result)
+        (setf (basic-combination-args node) (arg-lvars))))))
+
+(def-ir1-translator multiple-value-prog1
+    ((values-form &rest forms) start next result)
   #!+sb-doc
-  "MULTIPLE-VALUE-PROG1 Values-Form Form*
-  Evaluate Values-Form and then the Forms, but return all the values of
-  Values-Form."
-  (continuation-starts-block cont)
-  (let* ((dummy-result (make-continuation))
-        (dummy-start (make-continuation))
-        (cont-block (continuation-block cont)))
-    (continuation-starts-block dummy-start)
-    (ir1-convert start dummy-start result)
-
-    (substitute-continuation-uses cont dummy-start)
-
-    (continuation-starts-block dummy-result)
-    (ir1-convert-progn-body dummy-start dummy-result forms)
-    (let ((end-block (continuation-block dummy-result)))
-      (dolist (pred (block-pred end-block))
-       (unlink-blocks pred end-block)
-       (link-blocks pred cont-block))
-      (aver (not (continuation-dest dummy-result)))
-      (delete-continuation dummy-result)
-      (remove-from-dfo end-block))))
+  "MULTIPLE-VALUE-PROG1 values-form form*
+
+Evaluate VALUES-FORM and then the FORMS, but return all the values of
+VALUES-FORM."
+  (let ((dummy (make-ctran)))
+    (ctran-starts-block dummy)
+    (ir1-convert start dummy result values-form)
+    (ir1-convert-progn-body dummy next nil forms)))
 \f
 ;;;; interface to defining macros
 
-;;;; FIXME:
-;;;;   classic CMU CL comment:
-;;;;     DEFMACRO and DEFUN expand into calls to %DEFxxx functions
-;;;;     so that we get a chance to see what is going on. We define
-;;;;     IR1 translators for these functions which look at the
-;;;;     definition and then generate a call to the %%DEFxxx function.
-;;;; Alas, this implementation doesn't do the right thing for
-;;;; non-toplevel uses of these forms, so this should probably
-;;;; be changed to use EVAL-WHEN instead.
-
-;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with NAME stripped off.
-;;; This is used to hide the guts of DEFmumble macros to prevent
-;;; annoying error messages.
+;;; Old CMUCL comment:
+;;;
+;;;   Return a new source path with any stuff intervening between the
+;;;   current path and the first form beginning with NAME stripped
+;;;   off.  This is used to hide the guts of DEFmumble macros to
+;;;   prevent annoying error messages.
+;;;
+;;; Now that we have implementations of DEFmumble macros in terms of
+;;; EVAL-WHEN, this function is no longer used.  However, it might be
+;;; worth figuring out why it was used, and maybe doing analogous
+;;; munging to the functions created in the expanders for the macros.
 (defun revert-source-path (name)
   (do ((path *current-path* (cdr path)))
       ((null path) *current-path*)
     (let ((first (first path)))
       (when (or (eq first name)
-               (eq first 'original-source-start))
-       (return path)))))
-
-;;; Warn about incompatible or illegal definitions and add the macro
-;;; to the compiler environment.
-;;;
-;;; Someday we could check for macro arguments being incompatibly
-;;; redefined. Doing this right will involve finding the old macro
-;;; lambda-list and comparing it with the new one.
-(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
-                              :kind :function)
-  (let (;; QNAME is typically a quoted name. I think the idea is to
-       ;; let %DEFMACRO work as an ordinary function when
-       ;; interpreting. Whatever the reason the quote is there, we
-       ;; don't want it any more. -- WHN 19990603
-       (name (eval qname))
-       ;; QDEF should be a sharp-quoted definition. We don't want to
-       ;; make a function of it just yet, so we just drop the
-       ;; sharp-quote.
-       (def (progn
-              (aver (eq 'function (first qdef)))
-              (aver (proper-list-of-length-p qdef 2))
-              (second qdef))))
-
-    (/show "doing IR1 translator for %DEFMACRO" name)
-
-    (unless (symbolp name)
-      (compiler-error "The macro name ~S is not a symbol." name))
-
-    (ecase (info :function :kind name)
-      ((nil))
-      (:function
-       (remhash name *free-funs*)
-       (undefine-fun-name name)
-       (compiler-warn
-       "~S is being redefined as a macro when it was ~
-         previously ~(~A~) to be a function."
-       name
-       (info :function :where-from name)))
-      (:macro)
-      (:special-form
-       (compiler-error "The special form ~S can't be redefined as a macro."
-                      name)))
-
-    (setf (info :function :kind name) :macro
-         (info :function :where-from name) :defined
-         (info :function :macro-function name) (coerce def 'function))
-
-    (let* ((*current-path* (revert-source-path 'defmacro))
-          (fun (ir1-convert-lambda def 
-                                   :debug-name (debug-namify "DEFMACRO ~S"
-                                                             name))))
-      (setf (functional-arg-documentation fun) (eval lambda-list))
-
-      (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
-
-    (when sb!xc:*compile-print*
-      ;; FIXME: It would be nice to convert this, and the other places
-      ;; which create compiler diagnostic output prefixed by
-      ;; semicolons, to use some common utility which automatically
-      ;; prefixes all its output with semicolons. (The addition of
-      ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
-      ;; "MNA compiler message patch", and implemented by modifying a
-      ;; bunch of output statements on a case-by-case basis, which
-      ;; seems unnecessarily error-prone and unclear, scattering
-      ;; implicit information about output style throughout the
-      ;; system.) Starting by rewriting COMPILER-MUMBLE to add
-      ;; semicolon prefixes would be a good start, and perhaps also:
-      ;;   * Add semicolon prefixes for "FOO assembled" messages emitted 
-      ;;     when e.g. src/assembly/x86/assem-rtns.lisp is processed.
-      ;;   * At least some debugger output messages deserve semicolon
-      ;;     prefixes too:
-      ;;     ** restarts table
-      ;;     ** "Within the debugger, you can type HELP for help."
-      (compiler-mumble "~&; converted ~S~%" name))))
-
-(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
-                                           start cont
-                                           :kind :function)
-  (let ((name (eval name))
-       (def (second def))) ; We don't want to make a function just yet...
-
-    (when (eq (info :function :kind name) :special-form)
-      (compiler-error "attempt to define a compiler-macro for special form ~S"
-                     name))
-
-    (setf (info :function :compiler-macro-function name)
-         (coerce def 'function))
-
-    (let* ((*current-path* (revert-source-path 'define-compiler-macro))
-          (fun (ir1-convert-lambda def 
-                                   :debug-name (debug-namify
-                                                "DEFINE-COMPILER-MACRO ~S"
-                                                name))))
-      (setf (functional-arg-documentation fun) (eval lambda-list))
-
-      (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
-
-    (when sb!xc:*compile-print*
-      (compiler-mumble "~&; converted ~S~%" name))))
+                (eq first 'original-source-start))
+        (return path)))))