;; 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)))
#!+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))
"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
Return VALUE without evaluating it."
(reference-constant start next result thing))
\f
+(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"
(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))))))
\f
(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))
(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))))
(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