;;; -*- Mode: Scheme; scheme48-package: package-filenames -*-

;;;; Compiled Code Storage for Scheme48
;;;; Filenames

;;; This code is written by Taylor R. Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define $bundle-file-extension (make-fluid (make-cell 'BUNDLE)))

(define (bundle-file-name filespec)
  (translate (namestring filespec
                         #f
                         (fluid-cell-ref $bundle-file-extension))))

(define $package-bindings-file-extension (make-fluid (make-cell 'SCB)))
(define $package-template-file-extension (make-fluid (make-cell 'SCT)))
(define $package-debug-data-file-extension
  (make-fluid (make-cell 'SCD)))

(define $package-bindings-file-locator (make-fluid (make-cell #f)))
(define $package-template-file-locator (make-fluid (make-cell #f)))
(define $package-debug-data-file-locator (make-fluid (make-cell #f)))
(define $package-default-file-locator (make-fluid (make-cell #f)))

(define (package-file-name-locator locator-fluid extension-fluid)
  (define (process-filespec filespec)
    (translate (namestring filespec
                           #f
                           (fluid-cell-ref extension-fluid))))
  (lambda (package)
    ;++ What about per-package overrides?  Hmmm.
    (let ((try (lambda (locator-fluid)
                 (and-let* ((locator (fluid-cell-ref locator-fluid))
                            (filespec (locator package)))
                   (translate
                    (namestring filespec
                                #f
                                (fluid-cell-ref extension-fluid)))))))
      (or (try locator-fluid)
          (try $package-default-file-locator)
          (package-default-file-name package extension-fluid)))))

(define package-bindings-file-name
  (package-file-name-locator $package-bindings-file-locator
                             $package-bindings-file-extension))

(define package-template-file-name
  (package-file-name-locator $package-template-file-locator
                             $package-template-file-extension))

(define package-debug-data-file-name
  (package-file-name-locator $package-debug-data-file-locator
                             $package-debug-data-file-extension))

(define (package-default-file-name package extension-fluid)
  (cond ((package-file-name package)
         => (lambda (file-name)
              (translate
               (namestring (package-name package)
                           (file-name-directory file-name)
                           (fluid-cell-ref extension-fluid)))))
        (else #f)))