;;;; files for more information.
(in-package "SB!C")
-
-(file-comment
- "$Header$")
\f
-;;;; COMPILE and UNCOMPILE
-
-(defun get-lambda-to-compile (definition)
- (if (consp definition)
- definition
- (multiple-value-bind (def env-p)
- (function-lambda-expression definition)
- (when env-p
- (error "~S was defined in a non-null environment." definition))
- (unless def
- (error "Can't find a definition for ~S." definition))
- def)))
+;;;; CL:COMPILE
-;;; Find the function that is being compiled by COMPILE and bash its name to
-;;; NAME. We also substitute for any references to name so that recursive
-;;; calls will be compiled direct. Lambda is the top-level lambda for the
-;;; compilation. A REF for the real function is the only thing in the
-;;; top-level lambda other than the bind and return, so it isn't too hard to
-;;; find.
-(defun compile-fix-function-name (lambda name)
- (declare (type clambda lambda) (type (or symbol cons) name))
- (when name
- (let ((fun (ref-leaf
- (continuation-next
- (node-cont (lambda-bind lambda))))))
- (setf (leaf-name fun) name)
- (let ((old (gethash name *free-functions*)))
- (when old (substitute-leaf fun old)))
- name)))
+(defun get-lambda-to-compile (definition-designator)
+ (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)))
-(defun compile (name &optional (definition (fdefinition name)))
- #!+sb-doc
- "Compiles the function whose name is Name. If Definition is supplied,
- it should be a lambda expression that is compiled and then placed in the
- function cell of Name. If Name is Nil, the compiled code object is
- returned."
+;;; Handle the nontrivial case of CL:COMPILE.
+(defun actually-compile (name definition *lexenv*)
(with-compilation-values
(sb!xc:with-compilation-unit ()
- (let* ((*info-environment* (or *backend-info-environment*
- *info-environment*))
- (*lexenv* (make-null-lexenv))
- (form `#',(get-lambda-to-compile definition))
- (*source-info* (make-lisp-source-info form))
- (*top-level-lambdas* ())
- (*converting-for-interpreter* nil)
- (*block-compile* nil)
- (*compiler-error-bailout*
- #'(lambda ()
- (compiler-mumble
- "~2&fatal error, aborting compilation~%")
- (return-from 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)
- (*compile-object* (make-core-object))
- (*gensym-counter* 0)
- ;; 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))
- (clear-stuff)
- (find-source-paths form 0)
- (let ((lambda (ir1-top-level form '(original-source-start 0 0) t)))
+ ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
+ ;; few changes. Once things are stable, the shared bindings
+ ;; probably be merged back together into some shared utility
+ ;; macro, or perhaps both merged into one of the existing utility
+ ;; 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)
+ (*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)))))))
- (compile-fix-function-name lambda name)
- (let* ((component
- (block-component (node-block (lambda-bind lambda))))
- (*all-components* (list component)))
- (local-call-analyze component))
+(defun compile-in-lexenv (name definition lexenv)
+ (multiple-value-bind (compiled-definition warnings-p failure-p)
+ (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)
+ (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)))))
- (multiple-value-bind (components top-components)
- (find-initial-dfo (list lambda))
- (let ((*all-components* (append components top-components)))
- (dolist (component *all-components*)
- (compile-component component))))
-
- (let* ((res1 (core-call-top-level-lambda lambda *compile-object*))
- (result (or name res1)))
- (fix-core-source-info *source-info* *compile-object* res1)
- (when name
- (setf (fdefinition name) res1))
- result))))))
+(defun compile (name &optional (definition (or (macro-function 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),
+ where if NAME is NIL, THING is the result of compilation, and
+ 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."
+ (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)))
projects / sbcl.git / blobdiff