(if (policy *lexenv* (= store-coverage-data 0))
nil
(labels ((sub (form)
- (or (gethash form *source-paths*)
+ (or (get-source-path form)
(and (consp form)
(some #'sub form)))))
(or (sub form)))))
(defun name-lambdalike (thing)
(ecase (car thing)
((named-lambda)
- (second thing))
+ (or (second thing)
+ `(lambda ,(third thing))))
((lambda instance-lambda)
`(lambda ,(second thing)))
- ((lambda-with-lexenv)'
+ ((lambda-with-lexenv)
`(lambda ,(fifth thing)))))
(defun fun-name-leaf (thing)
;;; 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))
+ (if (and (consp function) (member (car function) '(function lambda)))
`(%funcall ,function ,@args)
(let ((name (constant-global-fun-name function)))
(if name
(deftransform %coerce-callable-to-fun ((thing) (function) *)
"optimize away possible call to FDEFINITION at runtime"
'thing)
+
+(define-source-transform %coerce-callable-to-fun (thing)
+ (if (and (consp thing) (member (car thing) '(function lambda)))
+ thing
+ (values nil t)))
\f
;;;; LET and LET*
;;;;
#!+sb-doc
"LOCALLY declaration* form*
-Sequentially evaluate the FORMS in a lexical environment where the the
+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))
;;; Assert that FORM evaluates to the specified type (which may be a
;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
-(def-ir1-translator the ((type value) start next result)
- (the-in-policy type value (lexenv-policy *lexenv*) start next result))
+(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.
-(def-ir1-translator truly-the ((type value) start next result)
+(def-ir1-translator truly-the ((value-type form) start next result)
#!+sb-doc
- ""
- #-nil
- (let ((type (coerce-to-values (compiler-values-specifier-type type)))
- (old (when result (find-uses result))))
- (ir1-convert start next result value)
- (when result
- (do-uses (use result)
- (unless (memq use old)
- (derive-node-type use type)))))
- #+nil
- (the-in-policy type value '((type-check . 0)) start cont))
+ "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))
\f
;;;; SETQ
(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))))
+ (value-form (second things))
+ (leaf (or (lexenv-find name vars) (find-free-var name))))
(etypecase leaf
(leaf
(when (constant-p leaf)
(compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
- (setq-var start next result leaf (second things)))
+ (if (and (global-var-p leaf) (eq :global (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