From: Taylor R Campbell Date: Sun, 6 Jan 2019 17:01:34 +0000 (+0000) Subject: Teach cref and sf about separate source and object directories. X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~10 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=54c7276771c16f19ae9b077402a32333271ef06b;p=mit-scheme.git Teach cref and sf about separate source and object directories. --- 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 (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))