6614c67d5463c715168d9447d48293129205653d
[sbcl.git] / src / compiler / target-main.lisp
1 ;;;; functions from classic CMU CL src/compiler/main.lisp which are
2 ;;;; needed only (and which may make sense only) on the
3 ;;;; cross-compilation target, not the cross-compilation host
4
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
13
14 (in-package "SB!C")
15 \f
16 ;;;; CL:COMPILE
17
18 (defun get-lambda-to-compile (definition-designator)
19   (if (consp definition-designator)
20       definition-designator
21       (multiple-value-bind (definition env-p)
22                            (function-lambda-expression definition-designator)
23         (when env-p
24           (error "~S was defined in a non-null environment."
25                  definition-designator))
26         (unless definition
27           (error "can't find a definition for ~S" definition-designator))
28         definition)))
29
30 ;;; Handle the nontrivial case of CL:COMPILE.
31 (defun actually-compile (name definition *lexenv* source-info tlf)
32   (let ((source-paths (when source-info *source-paths*)))
33     (with-compilation-values
34      (sb!xc:with-compilation-unit ()
35        ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
36        ;; few changes. Once things are stable, the shared bindings
37        ;; probably be merged back together into some shared utility
38        ;; macro, or perhaps both merged into one of the existing utility
39        ;; macros SB-C::WITH-COMPILATION-VALUES or
40        ;; CL:WITH-COMPILATION-UNIT.
41        (let* ((tlf (or tlf 0))
42               ;; If we have a source-info from LOAD, we will
43               ;; also have a source-paths already set up -- so drop
44               ;; the ones from WITH-COMPILATION-VALUES.
45               (*source-paths* (or source-paths *source-paths*))
46               ;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding
47               ;; here? It's a literal translation of the old CMU CL
48               ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT*
49               ;; *INFO-ENVIRONMENT*), and it's not obvious whether the
50               ;; rebinding to itself is needed now that SBCL doesn't
51               ;; need *BACKEND-INFO-ENVIRONMENT*.
52               (*info-environment* *info-environment*)
53               (form (get-lambda-to-compile definition))
54               (*source-info* (or source-info
55                                  (make-lisp-source-info
56                                   form :parent *source-info*)))
57               (*toplevel-lambdas* ())
58               (*block-compile* nil)
59               (*allow-instrumenting* nil)
60               (*code-coverage-records* nil)
61               (*code-coverage-blocks* nil)
62               (*compiler-error-bailout*
63                (lambda (&optional error)
64                  (declare (ignore error))
65                  (compiler-mumble
66                   "~2&fatal error, aborting compilation~%")
67                  (return-from actually-compile (values nil t nil))))
68               (*current-path* nil)
69               (*last-source-context* nil)
70               (*last-original-source* nil)
71               (*last-source-form* nil)
72               (*last-format-string* nil)
73               (*last-format-args* nil)
74               (*last-message-count* 0)
75               (*last-error-context* nil)
76               (*gensym-counter* 0)
77               ;; KLUDGE: This rebinding of policy is necessary so that
78               ;; forms such as LOCALLY at the REPL actually extend the
79               ;; compilation policy correctly.  However, there is an
80               ;; invariant that is potentially violated: future
81               ;; refactoring must not allow this to be done in the file
82               ;; compiler.  At the moment we're clearly alright, as we
83               ;; call %COMPILE with a core-object, not a fasl-stream,
84               ;; but caveat future maintainers. -- CSR, 2002-10-27
85               (*policy* (lexenv-policy *lexenv*))
86               ;; see above
87               (*handled-conditions* (lexenv-handled-conditions *lexenv*))
88               ;; ditto
89               (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))
90               ;; FIXME: ANSI doesn't say anything about CL:COMPILE
91               ;; interacting with these variables, so we shouldn't. As
92               ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
93               ;; binding these variables, so as a quick hack we do so
94               ;; too. But a proper implementation would have verbosity
95               ;; controlled by function arguments and lexical variables.
96               (*compile-verbose* nil)
97               (*compile-print* nil))
98          (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
99            (clear-stuff)
100            (unless source-paths
101              (find-source-paths form tlf))
102            (%compile form (make-core-object)
103                      :name name
104                      :path `(original-source-start 0 ,tlf))))))))
105
106 (defun compile-in-lexenv (name definition lexenv
107                           &optional source-info tlf)
108   (multiple-value-bind (compiled-definition warnings-p failure-p)
109       (cond
110         #!+sb-eval
111         ((sb!eval:interpreted-function-p definition)
112          (multiple-value-bind (definition lexenv)
113              (sb!eval:prepare-for-compile definition)
114            (actually-compile name definition lexenv source-info tlf)))
115         ((compiled-function-p definition)
116          (values definition nil nil))
117         (t
118          (actually-compile name definition lexenv source-info tlf)))
119     (cond (name
120            (if (and (symbolp name)
121                     (macro-function name))
122                (setf (macro-function name) compiled-definition)
123                (setf (fdefinition name) compiled-definition))
124            (values name warnings-p failure-p))
125           (t
126            (values compiled-definition warnings-p failure-p)))))
127
128 (defun compile (name &optional (definition (or (macro-function name)
129                                                (fdefinition name))))
130   #!+sb-doc
131   "Coerce DEFINITION (by default, the function whose name is NAME)
132   to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
133   where if NAME is NIL, THING is the result of compilation, and
134   otherwise THING is NAME. When NAME is not NIL, the compiled function
135   is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
136   (FDEFINITION NAME) otherwise."
137   (multiple-value-bind (function warnings-p failure-p)
138       (compile-in-lexenv name definition (make-null-lexenv))
139     (values (or function
140                 name
141                 (lambda (&rest arguments)
142                   (error 'simple-program-error
143                          :format-control
144                          "Called function compiled with errors. Original ~
145                           definition:~%  ~S~@[~%Arguments:~% ~{ ~S~}~]"
146                          :format-arguments (list definition arguments))))
147             warnings-p
148             failure-p)))