nil
(labels ((sub (form)
(or (get-source-path form)
- (and (consp form)
- (some #'sub form)))))
- (or (sub form)))))
+ (when (consp form)
+ (unless (eq 'quote (car form))
+ (somesub form)))))
+ (somesub (forms)
+ (when (consp forms)
+ (or (sub (car forms))
+ (somesub (cdr forms))))))
+ (sub form))))
\f
;;;; BLOCK and TAGBODY
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)
- (ecase (car thing)
+ (case (car thing)
((named-lambda)
(or (second thing)
- `(lambda ,(third thing))))
- ((lambda instance-lambda)
- `(lambda ,(second thing)))
+ `(lambda ,(third thing) ,(name-context))))
+ ((lambda)
+ `(lambda ,(second thing) ,@(name-context)))
((lambda-with-lexenv)
- `(lambda ,(fifth thing)))))
+ ;; 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)
(cond
((member (car thing)
- '(lambda named-lambda instance-lambda lambda-with-lexenv))
+ '(lambda named-lambda lambda-with-lexenv))
(values (ir1-convert-lambdalike
thing
:debug-name (name-lambdalike thing))
`(%funcall ,(ensure-lvar-fun-form function 'function) ,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start next result)
- (let ((op (when (consp function) (car function))))
+ ;; MACROEXPAND so that (LAMBDA ...) forms arriving here don't get an
+ ;; extra cast inserted for them.
+ (let* ((function (%macroexpand function *lexenv*))
+ (op (when (consp function) (car function))))
(cond ((eq op 'function)
- (with-fun-name-leaf (leaf (second function) start)
- (ir1-convert start next result `(,leaf ,@args))))
+ (compiler-destructuring-bind (thing) (cdr function)
+ function
+ (with-fun-name-leaf (leaf thing start)
+ (ir1-convert start next result `(,leaf ,@args)))))
((eq op 'global-function)
- (with-fun-name-leaf (leaf (second function) start :global-function t)
- (ir1-convert start next result `(,leaf ,@args))))
+ (compiler-destructuring-bind (thing) (cdr function)
+ global-function
+ (with-fun-name-leaf (leaf thing start :global-function t)
+ (ir1-convert start next result `(,leaf ,@args)))))
(t
(let ((ctran (make-ctran))
(fun-lvar (make-lvar)))
(varify-lambda-arg name
(if (eq context 'let*)
nil
- (names)))))
+ (names))
+ context)))
(dolist (spec bindings)
(cond ((atom spec)
(let ((var (get-var spec)))
(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
;;; whatever you tell it. It will never generate a type check, but
;;; will cause a warning if the compiler can prove the assertion is
;;; wrong.
+;;;
+;;; For the benefit of code-walkers we also add a macro-expansion. (Using INFO
+;;; directly to get around safeguards for adding a macro-expansion for special
+;;; operator.) Because :FUNCTION :KIND remains :SPECIAL-FORM, the compiler
+;;; never uses the macro -- but manually calling its MACRO-FUNCTION or
+;;; MACROEXPANDing TRULY-THE forms does.
(def-ir1-translator truly-the ((value-type form) start next result)
#!+sb-doc
"Specifies that the values returned by FORM conform to the
-- 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
(dest-lvar (make-lvar))
(type (or (lexenv-find var type-restrictions)
(leaf-type var))))
- (ir1-convert start dest-ctran dest-lvar `(the ,type ,value))
+ (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)