X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=7bd2bfbee4475b47a4801a5d0f5c97162a0bba86;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=f79a734017500a7935c6a570e643e0e1e1e8e05f;hpb=5efae2334933e0d8a998e8abbc12489cd5043b4d;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index f79a734..7bd2bfb 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -42,7 +42,10 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL." ;; 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) - (ir1-convert start pred-ctran pred-lvar test) + (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))) @@ -198,11 +201,11 @@ extent of the block." #!+sb-doc "TAGBODY {tag | statement}* -Define tags for use with GO. The STATEMENTS are evaluated in order ,skipping +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 an integer or a symbol. A STATEMENT -must be a list. Other objects are illegal within the body." +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)) @@ -352,7 +355,7 @@ Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL, "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 +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 @@ -476,15 +479,37 @@ body, references to a NAME will effectively be replaced with the EXPANSION." Return VALUE without evaluating it." (reference-constant start next result thing)) +(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)))) + ;;;; FUNCTION and NAMED-LAMBDA (defun name-lambdalike (thing) (case (car thing) ((named-lambda) (or (second thing) - `(lambda ,(third thing)))) + `(lambda ,(third thing) ,(name-context)))) ((lambda) - `(lambda ,(second thing))) + `(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" @@ -579,7 +604,7 @@ be a lambda expression." (cond (cname `(global-function ,cname)) (give-up - (give-up-ir1-transform give-up)) + (give-up-ir1-transform "not known to be a function")) (t `(%coerce-callable-to-fun ,lvar-name)))))) @@ -622,8 +647,9 @@ be a lambda expression." (define-source-transform funcall (function &rest args) `(%funcall ,(ensure-source-fun-form function) ,@args)) -(deftransform %coerce-callable-to-fun ((thing) * *) - (ensure-lvar-fun-form thing 'thing "optimize away possible call to FDEFINITION at runtime")) +(deftransform %coerce-callable-to-fun ((thing) * * :node node) + "optimize away possible call to FDEFINITION at runtime" + (ensure-lvar-fun-form thing 'thing t)) (define-source-transform %coerce-callable-to-fun (thing) (ensure-source-fun-form thing t)) @@ -814,10 +840,11 @@ lexically apparent function definition in the enclosing environment." (multiple-value-bind (names defs) (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))) + (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)))) @@ -852,7 +879,7 @@ other." (ir1-convert-lambda def :source-name name :maybe-add-debug-catch t - :debug-name (debug-name 'labels name))) + :debug-name (debug-name 'labels name t))) names defs)))) ;; Modify all the references to the dummy function leaves so @@ -885,6 +912,8 @@ other." (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))