#!+sb-doc
"IF predicate then [else]
-If PREDICATE evaluates to false, evaluate THEN and return its values,
+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))
(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)))))
(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))
+ (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.
nargs
min)))
- (when (eq (template-result-types template) :conditional)
+ (when (template-conditional-p template)
(bug "%PRIMITIVE was used with a conditional template."))
(when (template-more-results-type template)
\f
;;;; FUNCTION and NAMED-LAMBDA
(defun name-lambdalike (thing)
- (ecase (car thing)
+ (case (car thing)
((named-lambda)
- (second thing))
- ((lambda instance-lambda)
+ (or (second thing)
+ `(lambda ,(third thing))))
+ ((lambda)
`(lambda ,(second thing)))
- ((lambda-with-lexenv)'
- `(lambda ,(fifth thing)))))
+ ((lambda-with-lexenv)
+ `(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))
(dolist (lambda lambdas)
(setf (functional-allocator lambda) allocator)))))
-(defmacro with-fun-name-leaf ((leaf thing start &key global) &body body)
+(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body)
`(multiple-value-bind (,leaf allocate-p)
- (if ,global
+ (if ,global-function
(find-global-fun ,thing t)
(fun-name-leaf ,thing))
(if allocate-p
;;; 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 t)
+ (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)))
- (and constantp
- (let ((name (constant-form-value thing)))
- (and (legal-fun-name-p name) name)))))
+ (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 give-up))
+ (t
+ `(%coerce-callable-to-fun ,lvar-name))))))
\f
;;;; FUNCALL
(deftransform funcall ((function &rest args) * *)
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
- (%funcall ,(if (csubtypep (lvar-type function)
- (specifier-type 'function))
- 'function
- '(%coerce-callable-to-fun function))
- ,@arg-names))))
+ (declare (ignorable function))
+ `(%funcall ,(ensure-lvar-fun-form function 'function) ,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start next result)
- (cond ((and (consp function) (eq (car function) 'function))
- (with-fun-name-leaf (leaf (second function) start)
- (ir1-convert start next result `(,leaf ,@args))))
- ((and (consp function) (eq (car function) 'global-function))
- (with-fun-name-leaf (leaf (second function) start :global 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)))))
+ (let ((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))))
+ ((eq op 'global-function)
+ (with-fun-name-leaf (leaf (second function) 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)
- (let ((name (constant-global-fun-name function)))
- (if name
- `(%funcall (global-function ,name) ,@args)
- (values nil t)))))
-
-(deftransform %coerce-callable-to-fun ((thing) (function) *)
- "optimize away possible call to FDEFINITION at runtime"
- 'thing)
+ `(%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"))
+
+(define-source-transform %coerce-callable-to-fun (thing)
+ (ensure-source-fun-form thing t))
\f
;;;; LET and LET*
;;;;
(varify-lambda-arg name
(if (eq context 'let*)
nil
- (names)))))
+ (names))
+ context)))
(dolist (spec bindings)
(cond ((atom spec)
(let ((var (get-var spec)))
#!+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))
(program-assert-symbol-home-package-unlocked
:compile name "binding ~A as a local function"))
(names name)
- (multiple-value-bind (forms decls) (parse-body (cddr def))
+ (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))))))
;;; 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 :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
;; ,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
;; important for simplifying compilation of
;; MV-COMBINATIONS.
(make-combination fun-lvar))))
- (ir1-convert start ctran fun-lvar
- (if (and (consp fun) (eq (car fun) 'function))
- fun
- (let ((name (constant-global-fun-name fun)))
- (if name
- `(global-function ,name)
- `(%coerce-callable-to-fun ,fun)))))
+ (ir1-convert start ctran fun-lvar (ensure-source-fun-form fun))
(setf (lvar-dest fun-lvar) node)
(collect ((arg-lvars))
(let ((this-start ctran))