X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-main.lisp;h=08fdba6f320428efd20ba754e05a09472756cbf8;hb=970dd272dc84f7420252eadb4829cc193f795716;hp=8a1cffb07d3986f7952bbc7f04d72754e5a4366d;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 8a1cffb..08fdba6 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -19,13 +19,13 @@ (if (consp definition-designator) definition-designator (multiple-value-bind (definition env-p) - (function-lambda-expression definition-designator) - (when env-p - (error "~S was defined in a non-null environment." - definition-designator)) - (unless definition - (error "can't find a definition for ~S" definition-designator)) - definition))) + (function-lambda-expression definition-designator) + (when env-p + (error "~S was defined in a non-null environment." + definition-designator)) + (unless definition + (error "can't find a definition for ~S" definition-designator)) + definition))) ;;; Handle the nontrivial case of CL:COMPILE. (defun actually-compile (name definition *lexenv*) @@ -38,73 +38,82 @@ ;; macros SB-C::WITH-COMPILATION-VALUES or ;; CL:WITH-COMPILATION-UNIT. (let* (;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding - ;; here? It's a literal translation of the old CMU CL - ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT* - ;; *INFO-ENVIRONMENT*), and it's not obvious whether the - ;; rebinding to itself is needed now that SBCL doesn't - ;; need *BACKEND-INFO-ENVIRONMENT*. - (*info-environment* *info-environment*) - (form (get-lambda-to-compile definition)) - (*source-info* (make-lisp-source-info form)) - (*toplevel-lambdas* ()) - (*block-compile* nil) - (*compiler-error-bailout* - (lambda () - (compiler-mumble - "~2&fatal error, aborting compilation~%") - (return-from actually-compile (values nil t nil)))) - (*current-path* nil) - (*last-source-context* nil) - (*last-original-source* nil) - (*last-source-form* nil) - (*last-format-string* nil) - (*last-format-args* nil) - (*last-message-count* 0) - (*gensym-counter* 0) - ;; KLUDGE: This rebinding of policy is necessary so that - ;; forms such as LOCALLY at the REPL actually extend the - ;; compilation policy correctly. However, there is an - ;; invariant that is potentially violated: future - ;; refactoring must not allow this to be done in the file - ;; compiler. At the moment we're clearly alright, as we - ;; call %COMPILE with a core-object, not a fasl-stream, - ;; but caveat future maintainers. -- CSR, 2002-10-27 - (*policy* (lexenv-policy *lexenv*)) - ;; see above - (*handled-conditions* (lexenv-handled-conditions *lexenv*)) - ;; ditto - (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) - ;; FIXME: ANSI doesn't say anything about CL:COMPILE - ;; interacting with these variables, so we shouldn't. As - ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by - ;; binding these variables, so as a quick hack we do so - ;; too. But a proper implementation would have verbosity - ;; controlled by function arguments and lexical variables. - (*compile-verbose* nil) - (*compile-print* nil)) - (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) - (clear-stuff) - (find-source-paths form 0) - (%compile form (make-core-object) - :name name - :path '(original-source-start 0 0))))))) + ;; here? It's a literal translation of the old CMU CL + ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT* + ;; *INFO-ENVIRONMENT*), and it's not obvious whether the + ;; rebinding to itself is needed now that SBCL doesn't + ;; need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*) + (form (get-lambda-to-compile definition)) + (*source-info* (make-lisp-source-info form)) + (*toplevel-lambdas* ()) + (*block-compile* nil) + (*allow-instrumenting* nil) + (*compiler-error-bailout* + (lambda (&optional error) + (declare (ignore error)) + (compiler-mumble + "~2&fatal error, aborting compilation~%") + (return-from actually-compile (values nil t nil)))) + (*current-path* nil) + (*last-source-context* nil) + (*last-original-source* nil) + (*last-source-form* nil) + (*last-format-string* nil) + (*last-format-args* nil) + (*last-message-count* 0) + (*last-error-context* nil) + (*gensym-counter* 0) + ;; KLUDGE: This rebinding of policy is necessary so that + ;; forms such as LOCALLY at the REPL actually extend the + ;; compilation policy correctly. However, there is an + ;; invariant that is potentially violated: future + ;; refactoring must not allow this to be done in the file + ;; compiler. At the moment we're clearly alright, as we + ;; call %COMPILE with a core-object, not a fasl-stream, + ;; but caveat future maintainers. -- CSR, 2002-10-27 + (*policy* (lexenv-policy *lexenv*)) + ;; see above + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) + ;; FIXME: ANSI doesn't say anything about CL:COMPILE + ;; interacting with these variables, so we shouldn't. As + ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by + ;; binding these variables, so as a quick hack we do so + ;; too. But a proper implementation would have verbosity + ;; controlled by function arguments and lexical variables. + (*compile-verbose* nil) + (*compile-print* nil)) + (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) + (clear-stuff) + (find-source-paths form 0) + (%compile form (make-core-object) + :name name + :path '(original-source-start 0 0))))))) (defun compile-in-lexenv (name definition lexenv) (multiple-value-bind (compiled-definition warnings-p failure-p) - (if (compiled-function-p definition) - (values definition nil nil) - (actually-compile name definition lexenv)) + (cond + #!+sb-eval + ((sb!eval:interpreted-function-p definition) + (multiple-value-bind (definition lexenv) + (sb!eval:prepare-for-compile definition) + (actually-compile name definition lexenv))) + ((compiled-function-p definition) + (values definition nil nil)) + (t (actually-compile name definition lexenv))) (cond (name - (if (and (symbolp name) + (if (and (symbolp name) (macro-function name)) - (setf (macro-function name) compiled-definition) - (setf (fdefinition name) compiled-definition)) - (values name warnings-p failure-p)) - (t - (values compiled-definition warnings-p failure-p))))) + (setf (macro-function name) compiled-definition) + (setf (fdefinition name) compiled-definition)) + (values name warnings-p failure-p)) + (t + (values compiled-definition warnings-p failure-p))))) (defun compile (name &optional (definition (or (macro-function name) - (fdefinition name)))) + (fdefinition name)))) #!+sb-doc "Coerce DEFINITION (by default, the function whose name is NAME) to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P), @@ -112,4 +121,15 @@ otherwise THING is NAME. When NAME is not NIL, the compiled function is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into (FDEFINITION NAME) otherwise." - (compile-in-lexenv name definition (make-null-lexenv))) + (multiple-value-bind (function warnings-p failure-p) + (compile-in-lexenv name definition (make-null-lexenv)) + (values (or function + name + (lambda (&rest arguments) + (error 'simple-program-error + :format-control + "Called function compiled with errors. Original ~ + definition:~% ~S~@[~%Arguments:~% ~{ ~S~}~]" + :format-arguments (list definition arguments)))) + warnings-p + failure-p)))