X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=94094825ea093629252a3a04ffedad5096a61f1d;hb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;hp=acff2a9232a838ce036b50920602af12c96ef0f9;hpb=9264b512a21d1200fb9ab21874206c4bf436ed27;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index acff2a9..9409482 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -26,7 +26,7 @@ forms, returns NIL." #!+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)) @@ -75,9 +75,14 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL." 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)))) ;;;; BLOCK and TAGBODY @@ -373,7 +378,7 @@ destructuring lambda list, and the FORMS evaluate to the expansion." (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. @@ -449,7 +454,7 @@ body, references to a NAME will effectively be replaced with the EXPANSION." 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) @@ -473,20 +478,23 @@ Return VALUE without evaluating it." ;;;; 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)) @@ -509,9 +517,9 @@ Return VALUE without evaluating it." (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 @@ -535,7 +543,7 @@ be a lambda expression." ;;; 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) @@ -587,13 +595,20 @@ be a lambda expression." `(%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))) @@ -636,7 +651,8 @@ be a lambda expression." (varify-lambda-arg name (if (eq context 'let*) nil - (names))))) + (names)) + context))) (dolist (spec bindings) (cond ((atom spec) (let ((var (get-var spec))) @@ -754,8 +770,9 @@ also processed as top level forms." (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)))))) @@ -899,6 +916,12 @@ is unable to derive from other declared types." ;;; 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 @@ -909,6 +932,12 @@ 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)) + +#-sb-xc-host +(setf (info :function :macro-function 'truly-the) + (lambda (whole env) + (declare (ignore env)) + `(the ,@(cdr whole)))) ;;;; SETQ @@ -937,7 +966,7 @@ care." (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)) @@ -1082,6 +1111,7 @@ due to normal completion or a non-local exit such as THROW)." ;; ,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