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

(cherry picked from commit dc21a9094a5107ca7e2c8645cb5ebef8da70dd19)

diff --git a/src/Makefile.in b/src/Makefile.in
index b45fb9389be89034a0931555ac709161c3011c8e..be14dc7c7055ab626258a203b44d6e0a291fbb51 100644 (file)
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -73,10 +73,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)
 
@@ -227,8 +231,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: syntax-compiler

diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm
index 799f0fef81059dafa9f33bb9940a159a92711a0f..ff88f193df572fe5daa2f0f4275952a29a679260 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 cc0cbd7f1ec933fbcea5e57eb4f7f9a0cfc26119..62e0db5d83d1e6930cfb797ade171dedc105590c 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 66710585bc7f37b8709ffc1a202884580853d039..afb822eeb064fb50a7f0ca5c0aff92b79b38a982 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 7df1bfc5c6d2af5a4651490e2c1559d5349966f6..99229edf3c486ba29592ede9ebbca99c9bfc5574 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 9b252c7a65f2d38f24597e065c46ef4efbf35721..b1f87e65e7dfb9bb93ec9cd358e7af674442884e 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 8da8a882331abd1c5fa5bad073e00b80ceb57751..7af3bd17280648a9bd44740db668b36966eece3a 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 17b8892d48ddaf76b278bae87d1b9178200c8002..58aac485a24b050871f623d537bf29d13ee1c2ec 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 53029a31a49cb4a049bb7671567b5d3daca2b7ae..71841fa3713e13c51b93e397792719b3e61a5c87 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 8138c1ebf9679bc7d436fa527a36ce3e6dae70d4..32d353c69a19372c907f264b9c205a1d86cbc27f 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 c45d58918aaf5294c984c09513f0c9ca7891e333..6b8a486351f4785f25a07ec564ed3451837ad266 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 70795a5aa3ec0a88d23221792afde17050ecd0de..5fa934ec6c7e93e0dd95209325ca68a981efde43 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 a52020432d5d498497cb9315c5cb028159a9555b..c5cfb53c9df79396d91de5399a6fa9c9d4776ca6 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 6995779d6d4c9414e37005013acd14c02a7bf08c..d365fe38d7e7ba8445a8911b0e84dcdf0695fe92 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 fb1f35237994e60aeaf8ea7ab7c705c31e805360..1cc1103a1d182957b7233ad3c446bf266e1ffedf 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 6aa467fcc6ce5f8d5f059f8511159b8765d67c7a..682306104b3dde184524e4e28a8d13b0cd8c97c5 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 3472194e0c3717243325b2b09540eca789e61d32..2781d68620eec61d9882e1c668f1ea138dcdbb70 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 02bfd36e8a3fd7164b3b2e6cf3645c3f60d3afdc..311ee5e18cee1978cc836d158acf9fb0e3a167fb 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")