Teach cross-SF/CREF to dump/load in .nib, .txe, .dkp.

These correspond to .bin, .ext, .pkd.  LOAD-OPTION still loads from
.bin, .ext, .pkd (and .com) for libraries that are installed and are
not macro definitions of subsystems being cross-compiled.

This backwards suffix business is getting a little out of hand.
Possible partial alternatives:

- .xbin/.xext/.xpkd

- invent a static linker in the toolchain that can run on the cross
  host rather than using make.scm and disk-save in the cross target

- devise a portable fasload that sf/cref can use in the cross host

- use a machine-independent file format for .bin/.ext/.pkd

diff --git a/src/Makefile.in b/src/Makefile.in
index 9d16487a6e9e00e285aa3c44d7670972d54f3982..6f428af8aab82c74267965fc1ad10a95818ec530 100644 (file)
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -72,10 +72,14 @@ AUXDIR_NAME = @AUXDIR_NAME@
 AUXDIR = @AUXDIR@
 
 @IF_CROSS@COMPILER_SETTINGS_CROSS = (set! compiler:cross-compiling? true)
+@IF_CROSS@SF_SETTINGS_CROSS = \
+@IF_CROSS@     (set! sf/cross-compiling? true) \
+@IF_CROSS@     (set! package/cross-compiling? true)
 @IF_LIARC@COMPILER_SETTINGS_LIARC = (set! compiler:invoke-c-compiler? false)
 HOST_COMPILER_HEAP = @HOST_COMPILER_HEAP@
 
 HOST_COMPILER_SETTINGS = \
+       $(SF_SETTINGS_CROSS) \
        $(COMPILER_SETTINGS_CROSS) \
        $(COMPILER_SETTINGS_LIARC)
 
@@ -242,8 +246,10 @@ all-compiler: compile-compiler
 syntax-compiler: compile-sf
 @IF_SVM_COMPILER@syntax-compiler: compiler/machines/svm/svm1-defns.h
        (echo '(with-working-directory-pathname "compiler"' && \
-        echo '  (lambda () (load "compiler.sf")))') \
-       | $(HOST_RUNTIME_ONLY)
+        echo '  (lambda ()' && \
+        echo '    $(SF_SETTINGS_CROSS)' && \
+        echo '    (load "compiler.sf")))') \
+       | $(HOST_RUNTIME_ONLY) --eval '(load-option (quote SF))'
 
 .PHONY: compile-compiler
 compile-compiler: compile-compiler-back

diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm
index 81bd2e749b55bd22d99ed6802e6e669d00071ced..23b293f88c93f069da6e5690f144757458fcf672 100644 (file)
--- a/src/compiler/base/toplev.scm
+++ b/src/compiler/base/toplev.scm
@@ -38,7 +38,9 @@ USA.
 (define compiler:compile-data-files-as-expressions? #t)
 (define compile-file)
 (let ((scm-pathname (lambda (path) (pathname-new-type path "scm")))
-      (bin-pathname (lambda (path) (pathname-new-type path "bin")))
+      (bin-pathname
+       (lambda (path)
+        (pathname-new-type path (if sf/cross-compiling? "nib" "bin"))))
       (ext-pathname (lambda (path) (pathname-default-type path "ext")))
       (ext-pathname? (lambda (path) (equal? (pathname-type path) "ext")))
       (com-pathname
@@ -133,7 +135,7 @@ USA.
   (compiler-pathnames
    input-string
    (and (not (default-object? output-string)) output-string)
-   (make-pathname #f #f #f #f "bin" 'NEWEST)
+   (make-pathname #f #f #f #f (if sf/cross-compiling? "nib" "bin") 'NEWEST)
    (lambda (input-pathname output-pathname)
      (fluid-let ((*compiler-input-pathname*
                  (merge-pathnames input-pathname))
@@ -277,13 +279,14 @@ USA.
 \f
 ;;;; Alternate Entry Points
 
-(define compile-directory
-  (directory-processor
-   "bin"
-   (lambda ()
-     (compiler:compiled-code-pathname-type))
-   (lambda (pathname output-directory)
-     (compile-bin-file pathname output-directory))))
+(define (compile-directory input-directory #!optional output-directory force?)
+  ((directory-processor
+    (if sf/cross-compiling? "nib" "bin")
+    (lambda ()
+      (compiler:compiled-code-pathname-type))
+    (lambda (pathname output-directory)
+      (compile-bin-file pathname output-directory)))
+   input-directory output-directory force?))
 
 (define (compile-scode scode #!optional keep-debugging-info?)
   (compiler-output->compiled-expression

diff --git a/src/compiler/machines/C/compiler.sf b/src/compiler/machines/C/compiler.sf
index 5503a4e107f1efe595103d448f0379f3d9fb5311..e4c187227d8c7347499e6d2b66052277a52d81c2 100644 (file)
--- a/src/compiler/machines/C/compiler.sf
+++ b/src/compiler/machines/C/compiler.sf
@@ -44,7 +44,10 @@ USA.
             (fluid-let ((sf/default-syntax-table (->environment package)))
               (sf-conditionally files))
             (for-each (lambda (file)
-                        (load (string-append file ".bin") package))
+                        (receive (scm bin spec)
+                                 (sf/pathname-defaulting file #f #f)
+                          scm spec
+                          (load bin package)))
                       files))))
       (load-option 'hash-table)
       (fresh-line)

diff --git a/src/compiler/machines/C/decls.scm b/src/compiler/machines/C/decls.scm
index d699401c1bd14cc59cdeed4bf72d0c08cfdd89cf..06c561345b54d53fe8a8b392f8d631d40be96cbc 100644 (file)
--- a/src/compiler/machines/C/decls.scm
+++ b/src/compiler/machines/C/decls.scm
@@ -194,11 +194,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-           (let ((source (modification-time node "scm"))
-                 (binary (modification-time node "bin")))
-             (if (not source)
-                 (error "Missing source file" (source-node/filename node)))
-             (and binary (< source binary) binary))))
+           (receive (scm bin spec)
+                    (sf/pathname-defaulting (source-node/pathname node) #f #f)
+             spec
+             (let ((source (file-modification-time scm))
+                    (binary (file-modification-time bin)))
+                (if (not source)
+                    (error "Missing source file" (source-node/filename node)))
+                (and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
         (write-notification-line
@@ -320,10 +323,6 @@ USA.
          (lambda (declarations)
            (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 \f
 ;;;; Syntax dependencies
 

diff --git a/src/compiler/machines/i386/decls.scm b/src/compiler/machines/i386/decls.scm
index e836b358966b984efa1f37cc32f13e2796dbe064..4542dfa99f1a5e590fec18368edc2c6f79119e83 100644 (file)
--- a/src/compiler/machines/i386/decls.scm
+++ b/src/compiler/machines/i386/decls.scm
@@ -190,11 +190,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-           (let ((source (modification-time node "scm"))
-                 (binary (modification-time node "bin")))
-             (if (not source)
-                 (error "Missing source file" (source-node/filename node)))
-             (and binary (< source binary) binary))))
+           (receive (scm bin spec)
+                    (sf/pathname-defaulting (source-node/pathname node) #f #f)
+             spec
+             (let ((source (file-modification-time scm))
+                   (binary (file-modification-time bin)))
+               (if (not source)
+                   (error "Missing source file" (source-node/filename node)))
+               (and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
         (write-notification-line
@@ -316,10 +319,6 @@ USA.
          (lambda (declarations)
            (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 \f
 ;;;; Syntax dependencies
 

diff --git a/src/compiler/machines/svm/compiler.sf b/src/compiler/machines/svm/compiler.sf
index 4c5db39af74a25d9800a577b9cc77ac0fdb84525..c79ac6152ab67b40dc0b06bb586e5481770e1be3 100644 (file)
--- a/src/compiler/machines/svm/compiler.sf
+++ b/src/compiler/machines/svm/compiler.sf
@@ -61,7 +61,10 @@ USA.
                            (sf-conditionally file)))
                        files)
              (for-each (lambda (file)
-                         (load (pathname-new-type file "bin") (env file)))
+                         (receive (scm bin spec)
+                                  (sf/pathname-defaulting file #f #f)
+                           scm spec
+                           (load bin (env file))))
                        files))))
 
       (fresh-line)

diff --git a/src/compiler/machines/svm/decls.scm b/src/compiler/machines/svm/decls.scm
index df6c9f5d17ab5e9a9f669df108a719d39652522d..670d707e48466157f2671396fb67c5079a74fc76 100644 (file)
--- a/src/compiler/machines/svm/decls.scm
+++ b/src/compiler/machines/svm/decls.scm
@@ -198,11 +198,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-           (let ((source (modification-time node "scm"))
-                 (binary (modification-time node "bin")))
-             (if (not source)
-                 (error "Missing source file" (source-node/filename node)))
-             (and binary (< source binary) binary))))
+           (receive (scm bin spec)
+                    (sf/pathname-defaulting (source-node/pathname node) #f #f)
+             spec
+             (let ((source (file-modification-time scm))
+                   (binary (file-modification-time bin)))
+               (if (not source)
+                   (error "Missing source file" (source-node/filename node)))
+               (and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
         (write-notification-line
@@ -324,10 +327,6 @@ USA.
          (lambda (declarations)
            (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 \f
 ;;;; Integration Dependencies
 

diff --git a/src/compiler/machines/x86-64/decls.scm b/src/compiler/machines/x86-64/decls.scm
index 0c7f8f937eebc6db344d1c0cc88c62881696f9a7..b867c9a906e6aff6c455b45af3c5d72c29aac29a 100644 (file)
--- a/src/compiler/machines/x86-64/decls.scm
+++ b/src/compiler/machines/x86-64/decls.scm
@@ -190,11 +190,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-           (let ((source (modification-time node "scm"))
-                 (binary (modification-time node "bin")))
-             (if (not source)
-                 (error "Missing source file" (source-node/filename node)))
-             (and binary (< source binary) binary))))
+           (receive (scm bin spec)
+                    (sf/pathname-defaulting (source-node/pathname node) #f #f)
+             spec
+             (let ((source (file-modification-time scm))
+                   (binary (file-modification-time bin)))
+               (if (not source)
+                   (error "Missing source file" (source-node/filename node)))
+               (and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
         (write-notification-line
@@ -316,10 +319,6 @@ USA.
          (lambda (declarations)
            (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 \f
 ;;;; Syntax dependencies
 

diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm
index 33aaa83695a785d7f80b751fa787406832b96762..aab90a81d1ab7e27cedcda690ed1822b4ac1118d 100644 (file)
--- a/src/cref/redpkg.scm
+++ b/src/cref/redpkg.scm
@@ -174,8 +174,9 @@ USA.
 (define (cache-file-analysis! pmodel caches pathname changes?)
   (let ((cache (analysis-cache/lookup caches pathname))
        (full-pathname
-        (merge-pathnames (pathname-new-type pathname "bin")
-                         (pmodel/pathname pmodel))))
+        (merge-pathnames
+         (pathname-new-type pathname (if sf/cross-compiling? "nib" "bin"))
+         (pmodel/pathname pmodel))))
     (let ((time (file-modification-time full-pathname)))
       (if (not time)
          (error "unable to open file" full-pathname))

diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index 280954cde8463e370f6d82fd34b23f16a943cd90..4df8cf428a35563beb1bb7181d0d2ed598304ac3 100644 (file)
--- a/src/runtime/load.scm
+++ b/src/runtime/load.scm
@@ -184,7 +184,8 @@ USA.
              (or (try-fasl-file pathname)
                  (try-fasl-file (pathname-new-type pathname "com"))
                  (try-object-file (pathname-new-type pathname "so"))
-                 (try-fasl-file (pathname-new-type pathname "bin"))))))
+                 (let ((bin-type (if package/cross-compiling? "nib" "bin")))
+                   (try-fasl-file (pathname-new-type pathname bin-type)))))))
     (if thunk
        (receive (pathname loader notifier) (thunk)
          (values pathname

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 7a09f410e44da0d7cc3263b3dbeba15171b55c50..88c508c7bd3cae17eaeb28ab728eb86724ce8309 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -331,6 +331,7 @@ USA.
   (export 'package-set-pathname)
   (export 'package/add-child!)
   (export 'package/children)
+  (export 'package/cross-compiling?)
   (export 'package/environment)
   (export 'package/name)
   (export 'package/parent)

diff --git a/src/runtime/option.scm b/src/runtime/option.scm
index a43011bb1277182095a1e4b895babe063635cdd7..bb364b634316c13f85af2e4c36e8eb1fdbe17e93 100644 (file)
--- a/src/runtime/option.scm
+++ b/src/runtime/option.scm
@@ -40,7 +40,8 @@ USA.
            (else #f)))
 
     (define (load-entry entry)
-      (for-each (lambda (thunk) (thunk)) (cdr entry))
+      (fluid-let ((package/cross-compiling? #f))
+       (for-each (lambda (thunk) (thunk)) (cdr entry)))
       (set! loaded-options (cons name loaded-options))
       name)
 

diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 308f688c3fa6ef7c83fd1951f6c62e58fdab23f4..cb69ee20e04d702ab043a3317471288d6d93a3eb 100644 (file)
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -179,6 +179,9 @@ USA.
 ;; Obsolete and ignored:
 (define system-loader/enable-query? #f)
 
+(define package/cross-compiling?
+  #f)
+
 (define (package-set-pathname pathname #!optional os-type)
   (let ((p (->pathname pathname)))
     (pathname-new-type
@@ -195,7 +198,9 @@ USA.
                                   "")))
                         "-"
                         (microcode-id/operating-system-suffix os-type)))
-     "pkd")))
+     (if package/cross-compiling?
+        "dkp"
+        "pkd"))))
 \f
 (define-integrable (make-package-file tag version descriptions loads)
   (vector tag version descriptions loads))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index aa93612e394ef1f65cef30ccf4936790744ca1f8..efd7d106c663831df4d0a6139e637e6727eceb8f 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -46,6 +46,7 @@ USA.
          package/add-child!
          package/create
          package/children
+         package/cross-compiling?
          package/environment
          package/name
          package/parent

diff --git a/src/sf/butils.scm b/src/sf/butils.scm
index 0ce836337375e943fe789ede23f7d7e371ff36dc..e2e1000bb31a32d80910f409bc74449064b01a41 100644 (file)
--- a/src/sf/butils.scm
+++ b/src/sf/butils.scm
@@ -62,7 +62,7 @@ USA.
 (define sf-directory
   (directory-processor
    "scm"
-   (lambda () "bin")
+   (lambda () (if sf/cross-compiling? "nib" "bin"))
    (lambda (pathname output-directory)
      (sf pathname output-directory))))
 

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index a838fd116c16b08dba791ffe5f64739140e8a35a..2701cee6354c0f93ccdec05c9bd7ea7b2f580bfd 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -58,6 +58,7 @@ USA.
   (parent (scode-optimizer))
   (export ()
           sf
+          sf/cross-compiling?
           sf/default-declarations
           sf/default-syntax-table
           sf/pathname-defaulting

diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index 85300ea570c541bf1af54d6b4843d927d0887b9d..d1134f8f4f5b42640f29588ad7b31f61c4e46516 100644 (file)
--- a/src/sf/toplev.scm
+++ b/src/sf/toplev.scm
@@ -31,7 +31,8 @@ USA.
 \f
 ;;;; User Interface
 
-(define bin-pathname-type "bin")
+(define (bin-pathname-type)
+  (if sf/cross-compiling? "nib" "bin"))
 
 (define (integrate/procedure procedure)
   (procedure-components procedure
@@ -83,6 +84,9 @@ USA.
 
 (define sf/usual-integrations-default-deletions
   '())
+
+(define sf/cross-compiling?
+  #f)
 \f
 ;;;; File Syntaxer
 
@@ -113,7 +117,7 @@ USA.
                                         (if (> (string-length input-type) 2)
                                             (string-head input-type 2)
                                             input-type))
-                         bin-pathname-type)))))
+                         (bin-pathname-type))))))
              (if bin-string
                  (merge-pathnames bin-string bin-path)
                  bin-path))
@@ -155,29 +159,30 @@ USA.
 (define (sf/file->scode input-pathname output-pathname
                        environment declarations)
   (fluid-let ((sf/default-externs-pathname
-              (make-pathname (pathname-host input-pathname)
-                             (pathname-device input-pathname)
-                             (pathname-directory input-pathname)
-                             #f
-                             externs-pathname-type
-                             'newest)))
+              (lambda ()
+                (make-pathname (pathname-host input-pathname)
+                               (pathname-device input-pathname)
+                               (pathname-directory input-pathname)
+                               #f
+                               (externs-pathname-type)
+                               'newest))))
     (receive (expression externs-block externs)
        (integrate/file input-pathname environment declarations)
       (if output-pathname
          (write-externs-file (pathname-new-type output-pathname
-                                                externs-pathname-type)
+                                                (externs-pathname-type))
                              externs-block
                              externs))
       expression)))
 
-(define externs-pathname-type
-  "ext")
+(define (externs-pathname-type)
+  (if sf/cross-compiling? "txe" "ext"))
 
-(define sf/default-externs-pathname
-  (make-pathname #f #f #f #f externs-pathname-type 'newest))
+(define (sf/default-externs-pathname)
+  (make-pathname #f #f #f #f (externs-pathname-type) 'newest))
 \f
 (define (read-externs-file pathname)
-  (let ((pathname (merge-pathnames pathname sf/default-externs-pathname)))
+  (let ((pathname (merge-pathnames pathname (sf/default-externs-pathname))))
     (let ((namestring (->namestring pathname)))
       (if (file-exists? pathname)
          (let ((object (fasload pathname #t))

diff --git a/src/win32/win32.sf b/src/win32/win32.sf
index 46cac8dd429e51f03bc9552646441487a7976055..44fbe0f98fddd9966499a833daa8c3f3426c6a90 100644 (file)
--- a/src/win32/win32.sf
+++ b/src/win32/win32.sf
@@ -34,7 +34,9 @@ USA.
 
 (fluid-let ((sf/default-syntax-table (->environment '(win32))))
   (sf-conditionally "ffimacro")
-  (load "ffimacro.bin" '(win32 ffi-macro))
+  (receive (scm bin spec) (sf/pathname-defaulting "ffimacro" #f #f)
+    scm spec
+    (load bin '(win32 ffi-macro)))
 
   (sf-conditionally "winuser")
   (sf-conditionally "wingdi")