From 54c7276771c16f19ae9b077402a32333271ef06b Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 6 Jan 2019 17:01:34 +0000
Subject: [PATCH] Teach cref and sf about separate source and object
 directories.

---
 src/cref/cref.pkg   |  4 +++-
 src/cref/object.scm |  5 ++++-
 src/cref/redpkg.scm | 23 +++++++++++++++--------
 src/cref/toplev.scm | 31 ++++++++++++++++++++++++-------
 src/sf/butils.scm   | 30 ++++++++++++++++++++----------
 src/sf/sf.pkg       |  2 ++
 src/sf/toplev.scm   | 35 ++++++++++++++++++++++++-----------
 7 files changed, 92 insertions(+), 38 deletions(-)

diff --git a/src/cref/cref.pkg b/src/cref/cref.pkg
index 0e6883acd..eba212f28 100644
--- 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 c8b5f1381..d37996f49 100644
--- 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 71841fa37..4514329cf 100644
--- a/src/cref/redpkg.scm
+++ b/src/cref/redpkg.scm
@@ -30,7 +30,7 @@ USA.
 	 (integrate-external "object"))
 
 (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 f62da70e9..400dc1bbe 100644
--- a/src/cref/toplev.scm
+++ b/src/cref/toplev.scm
@@ -28,10 +28,22 @@ USA.
 
 (declare (usual-integrations))
 
+(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 1cc1103a1..ebfad1137 100644
--- a/src/sf/butils.scm
+++ b/src/sf/butils.scm
@@ -29,7 +29,8 @@ USA.
 
 (declare (usual-integrations))
 
-(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 682306104..d029166c2 100644
--- 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 2781d6862..5125c87c5 100644
--- 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)
 
 ;;;; 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))
 
 (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))
-- 
2.25.1