Add defknowns for TWO-ARG-CHAR-* functions.
[sbcl.git] / src / cold / shared.lisp
index ee3d1df..479b426 100644 (file)
 (defvar *host-obj-prefix*)
 (defvar *target-obj-prefix*)
 
-;;; suffixes for filename stems when cross-compiling
-(defvar *host-obj-suffix*
-  (or
-   ;; On some xc hosts, it's impossible to LOAD a fasl file unless it
-   ;; has the same extension that the host uses for COMPILE-FILE
-   ;; output, so we have to be careful to use the xc host's preferred
-   ;; extension.
-   ;;
-   ;; FIXME: This is a little ugly and annoying to maintain. And
-   ;; there's very likely some way to rearrange the build process so
-   ;; that we never explicitly refer to host object file suffixes,
-   ;; only to the result of CL:COMPILE-FILE-PATHNAME.
-   #+lispworks ".ufsl" ; as per Lieven Marchand sbcl-devel 2002-02-01
-   #+(and openmcl (not darwin)) ".pfsl"
-   #+(and openmcl darwin) ".dfsl"
-   ;; On most xc hosts, any old extension works, so we use an
-   ;; arbitrary one.
-   ".lisp-obj"))
 (defvar *target-obj-suffix*
   ;; Target fasl files are LOADed (actually only quasi-LOADed, in
   ;; GENESIS) only by SBCL code, and it doesn't care about particular
   ;; extensions, so we can use something arbitrary.
   ".lisp-obj")
+(defvar *target-assem-obj-suffix*
+  ;; Target fasl files from SB!C:ASSEMBLE-FILE are LOADed via GENESIS.
+  ;; The source files are compiled once as assembly files and once as
+  ;; normal lisp files.  In the past, they were kept separate by
+  ;; clever symlinking in the source tree, but that became less clean
+  ;; as ports to host environments without symlinks started appearing.
+  ;; In order to keep them separate, we have the assembled versions
+  ;; with a separate suffix.
+  ".assem-obj")
 
 ;;; a function of one functional argument, which calls its functional argument
 ;;; in an environment suitable for compiling the target. (This environment
 (setf *shebang-features*
       (let* ((default-features
                (append (read-from-file "base-target-features.lisp-expr")
-                       (read-from-file "local-target-features.lisp-expr")))
+                       (eval (read-from-file "local-target-features.lisp-expr"))))
              (customizer-file-name "customize-target-features.lisp")
              (customizer (if (probe-file customizer-file-name)
                              (compile nil
   (format t
           "target backend-subfeatures *SHEBANG-BACKEND-FEATURES*=~@<~S~:>~%"
           *shebang-backend-subfeatures*))
+
+;;; Some feature combinations simply don't work, and sometimes don't
+;;; fail until quite a ways into the build.  Pick off the more obvious
+;;; combinations now, and provide a description of what the actual
+;;; failure is (not always obvious from when the build fails).
+(let ((feature-compatability-tests
+       '(("(and sb-thread (not gencgc))"
+          ":SB-THREAD requires :GENCGC")
+         ("(and sb-thread (not (or ppc x86 x86-64)))"
+          ":SB-THREAD not supported on selected architecture")
+         ("(and gencgc cheneygc)"
+          ":GENCGC and :CHENEYGC are incompatible")
+         ("(and cheneygc (not (or alpha hppa mips ppc sparc)))"
+          ":CHENEYGC not supported on selected architecture")
+         ("(and gencgc (not (or sparc ppc x86 x86-64)))"
+          ":GENCGC not supported on selected architecture")
+         ("(not (or gencgc cheneygc))"
+          "One of :GENCGC or :CHENEYGC must be enabled")
+         ("(and win32 (not (and sb-thread
+                                sb-safepoint sb-thruption sb-wtimer
+                                sb-dynamic-core)))"
+          ":SB-WIN32 requires :SB-THREAD and related features")
+         ("(and sb-dynamic-core (not (and linkage-table sb-thread)))"
+          ;; Subtle memory corruption follows when sb-dynamic-core is
+          ;; active, and non-threaded allocation routines have not been
+          ;; updated to take the additional indirection into account.
+          ;; Let's avoid this unusual combination.
+          ":SB-DYNAMIC-CORE requires :LINKAGE-TABLE and :SB-THREAD")
+         ("(or (and alpha (or hppa mips ppc sparc x86 x86-64))
+               (and hppa (or mips ppc sparc x86 x86-64))
+               (and mips (or ppc sparc x86 x86-64))
+               (and ppc (or sparc x86 x86-64))
+               (and sparc (or x86 x86-64))
+               (and x86 x86-64))"
+          "More than one architecture selected")))
+      (failed-test-descriptions nil))
+  (dolist (test feature-compatability-tests)
+    (let ((*features* *shebang-features*))
+      (when (read-from-string (concatenate 'string "#+" (first test) "T NIL"))
+        (push (second test) failed-test-descriptions))))
+  (when failed-test-descriptions
+    (error "Feature compatibility check failed, ~S"
+           failed-test-descriptions)))
 \f
 ;;;; cold-init-related PACKAGE and SYMBOL tools
 
              (,flags (rest ,stem-and-flags)))
          ,@body))))
 
+;;; Given a STEM, remap the path component "/target/" to a suitable
+;;; target directory.
+(defun stem-remap-target (stem)
+  (let ((position (search "/target/" stem)))
+    (if position
+      (concatenate 'string
+                   (subseq stem 0 (1+ position))
+                   #!+x86 "x86"
+                   #!+x86-64 "x86-64"
+                   #!+sparc "sparc"
+                   #!+ppc "ppc"
+                   #!+mips "mips"
+                   #!+alpha "alpha"
+                   #!+hppa "hppa"
+                   (subseq stem (+ position 7)))
+      stem)))
+(compile 'stem-remap-target)
+
 ;;; Determine the source path for a stem.
 (defun stem-source-path (stem)
-  (concatenate 'string "" stem ".lisp"))
+  (concatenate 'string "" (stem-remap-target stem) ".lisp"))
 (compile 'stem-source-path)
 
-;;; Determine the object path for a stem/mode combination.
-(defun stem-object-path (stem mode)
+;;; Determine the object path for a stem/flags/mode combination.
+(defun stem-object-path (stem flags mode)
   (multiple-value-bind
         (obj-prefix obj-suffix)
       (ecase mode
-        (:host-compile (values *host-obj-prefix* *host-obj-suffix*))
-        (:target-compile (values *target-obj-prefix* *target-obj-suffix*)))
-    (concatenate 'string obj-prefix stem obj-suffix)))
+        (:host-compile
+         ;; On some xc hosts, it's impossible to LOAD a fasl file unless it
+         ;; has the same extension that the host uses for COMPILE-FILE
+         ;; output, so we have to be careful to use the xc host's preferred
+         ;; extension.
+         (values *host-obj-prefix*
+                 (concatenate 'string "."
+                              (pathname-type (compile-file-pathname stem)))))
+        (:target-compile (values *target-obj-prefix*
+                                 (if (find :assem flags)
+                                     *target-assem-obj-suffix*
+                                     *target-obj-suffix*))))
+    (concatenate 'string obj-prefix (stem-remap-target stem) obj-suffix)))
 (compile 'stem-object-path)
 
 ;;; Check for stupid typos in FLAGS list keywords.
 (let ((stems (make-hash-table :test 'equal)))
   (do-stems-and-flags (stem flags)
-    (if (gethash stem stems)
-      (error "duplicate stem ~S in *STEMS-AND-FLAGS*" stem)
-      (setf (gethash stem stems) t))
+    ;; We do duplicate stem comparison based on the object path in
+    ;; order to cover the case of stems with an :assem flag, which
+    ;; have two entries but separate object paths for each.  KLUDGE:
+    ;; We have to bind *target-obj-prefix* here because it's normally
+    ;; set up later in the build process and we don't actually care
+    ;; what it is so long as it doesn't change while we're checking
+    ;; for duplicate stems.
+    (let* ((*target-obj-prefix* "")
+           (object-path (stem-object-path stem flags :target-compile)))
+      (if (gethash object-path stems)
+          (error "duplicate stem ~S in *STEMS-AND-FLAGS*" stem)
+          (setf (gethash object-path stems) t)))
+    ;; FIXME: We should make sure that the :assem flag is only used
+    ;; when paired with :not-host.
     (let ((set-difference (set-difference flags *expected-stem-flags*)))
       (when set-difference
         (error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S"
          ;; port, it might or might be a good idea to do the rewrite.
          ;; -- WHN 19990815
          (src (stem-source-path stem))
-         (obj (stem-object-path stem mode))
+         (obj (stem-object-path stem flags mode))
          (tmp-obj (concatenate 'string obj "-tmp"))
 
          (compile-file (ecase mode
          (multiple-value-bind (output-truename warnings-p failure-p)
             (if trace-file
                 (funcall compile-file src :output-file tmp-obj
-                         :trace-file t)
-                (funcall compile-file src :output-file tmp-obj ))
+                         :trace-file t :allow-other-keys t)
+                (funcall compile-file src :output-file tmp-obj))
            (declare (ignore warnings-p))
            (cond ((not output-truename)
                   (error "couldn't compile ~S" src))
 
 ;;; like HOST-CLOAD-STEM, except that we don't bother to compile
 (defun host-load-stem (stem flags)
-  (declare (ignore flags)) ; (It's only relevant when compiling.)
-  (load (stem-object-path stem :host-compile)))
+  (load (stem-object-path stem flags :host-compile)))
 (compile 'host-load-stem)
 \f
 ;;;; tools to compile SBCL sources to create object files which will