#!+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))
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
(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)
(or (second thing)
`(lambda ,(third thing))))
- ((lambda instance-lambda)
+ ((lambda)
`(lambda ,(second thing)))
((lambda-with-lexenv)
- `(lambda ,(fifth thing)))))
+ `(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)
`(%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 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)))
(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))))))
;;; 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
(compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
- (if (and (global-var-p leaf) (eq :global (global-var-kind leaf)))
+ (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))
;; ,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
projects / sbcl.git / blobdiff