Teach cref and sf about separate source and object directories.

diff --git a/src/cref/cref.pkg b/src/cref/cref.pkg
index 0e6883acd12f1285c8fe802cdef6e566c6847744..eba212f28b73dc786ba0011eff26fde852e4b8f1 100644 (file)
--- a/src/cref/cref.pkg
+++ b/src/cref/cref.pkg
@@ -39,7 +39,9 @@ USA.
          cref/generate-cref
          cref/generate-cref-unusual
          cref/generate-trivial-constructor
-         cref/package-files))
+         cref/object-root
+         cref/package-files
+         cref/source-root))
 
 (define-package (cross-reference analyze-file)
   (files "anfile")

diff --git a/src/cref/object.scm b/src/cref/object.scm
index c8b5f13813e2e987a9079303b1c742ab0f2ca50a..d37996f49bcab8f3e5ca23092c3a26aabaeb4602 100644 (file)
--- a/src/cref/object.scm
+++ b/src/cref/object.scm
@@ -45,7 +45,10 @@ USA.
   (packages #f read-only #t)
   (extra-packages #f read-only #t)
   (loads #f read-only #t)
-  (pathname #f read-only #t))
+  (source-pathname #f read-only #t))
+
+(define (pmodel/object-pathname pmodel)
+  (cref/object-pathname (pmodel/source-pathname pmodel)))
 
 (define-structure (package
                   (constructor make-package (name parent))

diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm
index 71841fa3713e13c51b93e397792719b3e61a5c87..4514329cf2c1cc41cf98802269c2de38dcc3b946 100644 (file)
--- a/src/cref/redpkg.scm
+++ b/src/cref/redpkg.scm
@@ -30,7 +30,7 @@ USA.
         (integrate-external "object"))
 \f
 (define (read-package-model filename os-type)
-  (let ((model-pathname (merge-pathnames filename)))
+  (let ((model-pathname (cref/source-pathname filename)))
     (receive (packages extensions loads globals)
        (sort-descriptions (read-and-parse-model model-pathname os-type))
       (descriptions->pmodel
@@ -65,9 +65,16 @@ USA.
                            (system-library-pathname pkd)))))
           (and (not (condition? pathname))
                pathname))
-        (let ((pathname (merge-pathnames pkd model-pathname)))
-          (and (file-exists? pathname)
-               pathname)))
+        (or (let* ((object-model-pathname
+                    (merge-pathnames
+                     (enough-pathname model-pathname cref/source-root)
+                     cref/object-root))
+                   (pathname (merge-pathnames pkd object-model-pathname)))
+              (and (file-exists? pathname)
+                   pathname))
+            (let ((pathname (merge-pathnames pkd model-pathname)))
+              (and (file-exists? pathname)
+                   pathname))))
      (begin
        (warn "Could not find global definitions:" pkd)
        #f))))
@@ -146,9 +153,9 @@ USA.
 
 (define (cache-file-analyses! pmodel os-type)
   (let ((pathname
-        (pathname-new-type (package-set-pathname (pmodel/pathname pmodel)
-                                                 os-type)
-                           "fre"))
+        (pathname-new-type
+         (package-set-pathname (pmodel/object-pathname pmodel) os-type)
+         "fre"))
        (changes? (list #f)))
     (let ((result
           (let ((caches
@@ -176,7 +183,7 @@ USA.
        (full-pathname
         (merge-pathnames
          (pathname-new-type pathname (if sf/cross-compiling? "nib" "bin"))
-         (pmodel/pathname pmodel))))
+         (pmodel/object-pathname pmodel))))
     (let ((time (file-modification-time full-pathname)))
       (if (not time)
          (error "unable to open file" full-pathname))

diff --git a/src/cref/toplev.scm b/src/cref/toplev.scm
index f62da70e9a48800e772b5748567b14f07db221c3..400dc1bbe89895bba7653aa82e93777e21c7a031 100644 (file)
--- a/src/cref/toplev.scm
+++ b/src/cref/toplev.scm
@@ -28,10 +28,22 @@ USA.
 
 (declare (usual-integrations))
 \f
+(define cref/source-root #!default)
+(define cref/object-root #!default)
+
+(define (cref/source-pathname pathname)
+  ;; This assumes we're sitting in the source directory.
+  (merge-pathnames pathname))
+
+(define (cref/object-pathname pathname)
+  ;; This assumes we're sitting in the source directory.
+  (merge-pathnames (enough-pathname pathname cref/source-root)
+                  cref/object-root))
+
 (define (generate/common kernel)
   (lambda (filename #!optional os-type)
     (for-each-os-type os-type
-      (let ((pathname (merge-pathnames filename)))
+      (let ((pathname (cref/source-pathname filename)))
        (lambda (os-type)
          (let ((pmodel (read-package-model pathname os-type)))
            (let ((changes? (read-file-analyses! pmodel os-type)))
@@ -40,7 +52,7 @@ USA.
 
 (define (cref/generate-trivial-constructor filename #!optional os-type)
   (for-each-os-type os-type
-    (let ((pathname (merge-pathnames filename)))
+    (let ((pathname (cref/source-pathname filename)))
       (lambda (os-type)
        (write-external-descriptions pathname
                                     (read-package-model pathname os-type)
@@ -89,15 +101,18 @@ USA.
      (write-external-descriptions pathname pmodel changes? os-type))))
 
 (define (write-external-descriptions pathname pmodel changes? os-type)
-  (let ((package-set (package-set-pathname pathname os-type)))
+  (let* ((object-pathname (cref/object-pathname pathname))
+        (package-set (package-set-pathname object-pathname os-type)))
     (if (or changes?
            (file-modification-time<? package-set
                                      (pathname-default-type pathname "pkg")))
        (fasdump (construct-external-descriptions pmodel) package-set))))
 
 (define (write-cref pathname pmodel changes? os-type)
-  (let ((cref-pathname
-        (pathname-new-type (package-set-pathname pathname os-type) "crf")))
+  (let* ((object-pathname (cref/object-pathname pathname))
+        (cref-pathname
+         (pathname-new-type (package-set-pathname object-pathname os-type)
+                            "crf")))
     (if (or changes?
            (file-modification-time<? cref-pathname
                                      (pathname-default-type pathname "pkg")))
@@ -106,8 +121,10 @@ USA.
            (format-packages pmodel port))))))
 
 (define (write-cref-unusual pathname pmodel changes? os-type)
-  (let ((cref-pathname
-        (pathname-new-type (package-set-pathname pathname os-type) "crf")))
+  (let* ((object-pathname (cref/object-pathname pathname))
+        (cref-pathname
+         (pathname-new-type (package-set-pathname object-pathname os-type)
+                            "crf")))
     (if (or changes?
            (file-modification-time<? cref-pathname
                                      (pathname-default-type pathname "pkg")))

diff --git a/src/sf/butils.scm b/src/sf/butils.scm
index 1cc1103a1d182957b7233ad3c446bf266e1ffedf..ebfad1137683a75bf96d109318c9bd485a45f94c 100644 (file)
--- a/src/sf/butils.scm
+++ b/src/sf/butils.scm
@@ -29,7 +29,8 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (directory-processor input-type output-type process-file)
+(define (directory-processor input-type output-type process-file
+                            #!optional map-pathname)
   (let ((directory-read
         (let ((input-pattern
                (make-pathname #f #f #f 'wild input-type 'newest)))
@@ -37,7 +38,11 @@ USA.
             (directory-read
              (merge-pathnames
               (pathname-as-directory (merge-pathnames directory))
-              input-pattern))))))
+              input-pattern)))))
+       (map-pathname
+        (if (default-object? map-pathname)
+            (lambda (pathname) pathname)
+            map-pathname)))
     (lambda (input-directory #!optional output-directory force?)
       (let ((output-directory
             (if (default-object? output-directory) #f output-directory))
@@ -47,13 +52,14 @@ USA.
                    (if (or force?
                            (not (file-modification-time<=?
                                  (pathname-default-type pathname input-type)
-                                 (let ((output-pathname
-                                        (pathname-new-type pathname
-                                                           output-type)))
-                                   (if output-directory
-                                       (merge-pathnames output-directory
-                                                        output-pathname)
-                                       output-pathname)))))
+                                 (map-pathname
+                                  (let ((output-pathname
+                                         (pathname-new-type pathname
+                                                            output-type)))
+                                    (if output-directory
+                                        (merge-pathnames output-directory
+                                                         output-pathname)
+                                        output-pathname))))))
                        (process-file pathname output-directory)))
                  (if (pair? input-directory)
                      (append-map! directory-read input-directory)
@@ -64,7 +70,11 @@ USA.
    "scm"
    (lambda () (if sf/cross-compiling? "nib" "bin"))
    (lambda (pathname output-directory)
-     (sf pathname output-directory))))
+     (sf pathname output-directory))
+   (lambda (pathname)
+     (merge-pathnames
+      (enough-pathname (merge-pathnames pathname) sf/source-root)
+      sf/object-root))))
 
 (define (sf-conditionally filename #!optional echo-up-to-date?)
   (let ((kernel

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index 682306104b3dde184524e4e28a8d13b0cd8c97c5..d029166c24b32311ee6b0129ac0cf43b7a54e69b 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -61,8 +61,10 @@ USA.
           sf/cross-compiling?
           sf/default-declarations
           sf/default-syntax-table
+          sf/object-root
           sf/pathname-defaulting
           sf/set-usual-integrations-default-deletions!
+          sf/source-root
           sf/top-level-definitions
           sf/usual-integrations-default-deletions
           sf:noisy?

diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index 2781d68620eec61d9882e1c668f1ea138dcdbb70..5125c87c53266c7296fcd4d29515f2fa00b8f8f3 100644 (file)
--- a/src/sf/toplev.scm
+++ b/src/sf/toplev.scm
@@ -71,8 +71,12 @@ USA.
   unspecific)
 
 (define (pathname/normalize pathname)
+  ;; This assumes we're sitting in the source directory.
   (pathname-default-type (merge-pathnames pathname) "scm"))
 
+(define (sf/object-pathname pathname)
+  (merge-pathnames (enough-pathname pathname sf/source-root) sf/object-root))
+
 (define sf/default-syntax-table
   system-global-environment)
 
@@ -87,6 +91,12 @@ USA.
 
 (define sf/cross-compiling?
   #f)
+
+(define sf/source-root
+  #!default)
+
+(define sf/object-root
+  #!default)
 \f
 ;;;; File Syntaxer
 
@@ -108,16 +118,17 @@ USA.
   (let ((input-path (pathname/normalize input-string)))
     (values input-path
            (let ((bin-path
-                  (pathname-new-type
-                   input-path
-                   (let ((input-type (pathname-type input-path)))
-                     (if (and (string? input-type)
-                              (not (string=? "scm" input-type)))
-                         (string-append "b"
-                                        (if (> (string-length input-type) 2)
-                                            (string-head input-type 2)
-                                            input-type))
-                         (bin-pathname-type))))))
+                  (sf/object-pathname
+                   (pathname-new-type
+                    input-path
+                    (let ((input-type (pathname-type input-path)))
+                      (if (and (string? input-type)
+                               (not (string=? "scm" input-type)))
+                          (string-append "b"
+                                         (if (> (string-length input-type) 2)
+                                             (string-head input-type 2)
+                                             input-type))
+                          (bin-pathname-type)))))))
              (if bin-string
                  (merge-pathnames bin-string bin-path)
                  bin-path))
@@ -182,7 +193,9 @@ USA.
   (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
+        (sf/object-pathname
+         (merge-pathnames pathname (sf/default-externs-pathname)))))
     (let ((namestring (->namestring pathname)))
       (if (file-exists? pathname)
          (let ((object (fasload pathname #t))