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 ;;; Find the function that is being compiled by COMPILE and bash its
  31 ;;; name to NAME. We also substitute for any references to name so
  32 ;;; that recursive calls will be compiled direct. LAMBDA is the
  33 ;;; top-level lambda for the compilation. A REF for the real function
  34 ;;; is the only thing in the top-level lambda other than the bind and
  35 ;;; return, so it isn't too hard to find.
  36 (defun compile-fix-fun-name (lambda name)
  37   (declare (type clambda lambda) (type (or symbol cons) name))
  38   (when name
  39     (let ((fun (ref-leaf
  40                 (continuation-next
  41                  (node-cont (lambda-bind lambda))))))
  42       (setf (leaf-name fun) name)
  43       (let ((old (gethash name *free-functions*)))
  44         (when old (substitute-leaf fun old)))
  45       name)))
  46
  47 ;;; Handle the nontrivial case of CL:COMPILE.
  48 (defun actually-compile (name definition)
  49   (with-compilation-values
  50     (sb!xc:with-compilation-unit ()
  51       ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
  52       ;; few changes. Once things are stable, the shared bindings
  53       ;; probably be merged back together into some shared utility
  54       ;; macro, or perhaps both merged into one of the existing utility
  55       ;; macros SB-C::WITH-COMPILATION-VALUES or
  56       ;; CL:WITH-COMPILATION-UNIT.
  57       (let* (;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding
  58              ;; here? It's a literal translation of the old CMU CL
  59              ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT*
  60              ;; *INFO-ENVIRONMENT*), and it's not obvious whether the
  61              ;; rebinding to itself is needed now that SBCL doesn't
  62              ;; need *BACKEND-INFO-ENVIRONMENT*.
  63              (*info-environment* *info-environment*)
  64              (*lexenv* (make-null-lexenv))
  65              (form (get-lambda-to-compile definition))
  66              (*source-info* (make-lisp-source-info form))
  67              (*top-level-lambdas* ())
  68              (*block-compile* nil)
  69              (*compiler-error-bailout*
  70               #'(lambda ()
  71                   (compiler-mumble
  72                    "~2&fatal error, aborting compilation~%")
  73                   (return-from actually-compile (values nil t nil))))
  74              (*current-path* nil)
  75              (*last-source-context* nil)
  76              (*last-original-source* nil)
  77              (*last-source-form* nil)
  78              (*last-format-string* nil)
  79              (*last-format-args* nil)
  80              (*last-message-count* 0)
  81              (*gensym-counter* 0)
  82              ;; FIXME: ANSI doesn't say anything about CL:COMPILE
  83              ;; interacting with these variables, so we shouldn't. As
  84              ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
  85              ;; binding these variables, so as a quick hack we do so
  86              ;; too. But a proper implementation would have verbosity
  87              ;; controlled by function arguments and lexical variables.
  88              (*compile-verbose* nil)
  89              (*compile-print* nil))
  90         (clear-stuff)
  91         (find-source-paths form 0)
  92         (%compile form (make-core-object)
  93                   :name name
  94                   :path '(original-source-start 0 0))))))
  95
  96 (defun compile (name &optional (definition (fdefinition name)))
  97   #!+sb-doc
  98   "Coerce DEFINITION (by default, the function whose name is NAME)
  99   to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
 100   where if NAME is NIL, THING is the result of compilation, and
 101   otherwise THING is NAME. When NAME is not NIL, the compiled function
 102   is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
 103   (FDEFINITION NAME) otherwise."
 104   (multiple-value-bind (compiled-definition warnings-p failure-p)
 105       (if (compiled-function-p definition)
 106           (values definition nil nil)
 107           (actually-compile name definition))
 108     (cond (name
 109            (if (macro-function name)
 110                (setf (macro-function name) compiled-definition)
 111                (setf (fdefinition name) compiled-definition))
 112            (values name warnings-p failure-p))
 113           (t
 114            (values compiled-definition warnings-p failure-p)))))