From: Taylor R Campbell <campbell@mumble.net> 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<? 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))