guile-prescheme/prescheme/filename.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
;;;
;;;   scheme48-1.9.2/scheme/big/filename.scm
;;;
;;; Silly file name utilities
;;; These try to be operating-system independent, but fail, of course.
;;;
;;; Namelist = ((dir ...) basename type)
;;;         or ((dir ...) basename)
;;;       or (dir basename type)
;;;       or (dir basename)
;;;       or basename

(define-module (prescheme filename)
  #:use-module (prescheme scheme48)
  #:export (namestring *scheme-file-type* *load-file-type*
            file-name-directory
            file-name-nondirectory
            translate
            set-global-translation!
            set-translation!
            make-translations with-translations
            current-translations))

(define (namestring namelist dir default-type)
  (let* ((namelist (if (list? namelist) namelist (list '() namelist)))
         (subdirs (if (list? (car namelist))
                      (car namelist)
                      (list (car namelist))))
         (basename (cadr namelist))
         (type (if (null? (cddr namelist))
                   (if (string? basename)
                       #f
                       default-type)
                   (caddr namelist))))
    (string-append (or dir "")
                   (apply string-append
                          (map (lambda (subdir)
                                 (string-append
                                  (namestring-component subdir)
                                  directory-component-separator))
                               subdirs))
                   (namestring-component basename)
                   (if type
                       (string-append type-component-separator
                                      (namestring-component type))
                       ""))))

(define directory-component-separator "/") ;;unix sux
(define type-component-separator ".")

(define (namestring-component x)
  (cond ((string? x) x)
        ((symbol? x)
         (list->string (map file-name-preferred-case
                            (string->list (symbol->string x)))))
        (else (assertion-violation 'namestring-component
                                   "bogus namelist component" x))))

(define file-name-preferred-case char-downcase)

(define *scheme-file-type* 'scm)
(define *load-file-type* *scheme-file-type*)  ;;#F for Pseudoscheme or T



;; Interface copied from gnu emacs:

;;file-name-directory
;;  Function: Return the directory component in file name NAME.
;;file-name-nondirectory
;;  Function: Return file name NAME sans its directory.
;;file-name-absolute-p
;;  Function: Return t if file FILENAME specifies an absolute path name.
;;substitute-in-file-name
;;  Function: Substitute environment variables referred to in STRING.
;;expand-file-name
;;  Function: Convert FILENAME to absolute, and canonicalize it.

(define (file-name-directory filename)
  (substring filename 0 (file-nondirectory-position filename)))

(define (file-name-nondirectory filename)
  (substring filename
             (file-nondirectory-position filename)
             (string-length filename)))

(define (file-nondirectory-position filename)
  (let loop ((i (- (string-length filename) 1)))
    (cond ((< i 0) 0)
          ;; Heuristic.  Should work for DOS, Unix, VMS, MacOS.
          ((string-posq (string-ref filename i) "/:>]\\") (+ i 1))
          (else (loop (- i 1))))))

(define (string-posq thing s)
  (let loop ((i 0))
    (cond ((>= i (string-length s)) #f)
          ((eq? thing (string-ref s i)) i)
          (else (loop (+ i 1))))))



;; Directory translations.
;; E.g. (set-translation! "foo;" "/usr/mumble/foo/")

(define *global-translations* '())

(define $translations (make-fluid (make-cell '())))

(define (make-translations)
  (make-cell '()))

(define (with-translations translations thunk)
  (with-fluids (($translations (make-cell '()))) (thunk)))

(define (current-translations) (cell-ref (fluid-ref $translations)))
(define (set-translations! new)
  (cell-set! (fluid-ref $translations) new))

(define (set-global-translation! from to)
  (set! *global-translations*
        (amend-alist! from to *global-translations*)))

(define (set-translation! from to)
  (set-translations! (amend-alist! from to (current-translations))))

(define (amend-alist! from to alist)
  (let ((probe (assoc from alist)))
    (if probe
        (begin
          (set-cdr! probe to)
          alist)
        (cons (cons from to) alist))))

(define (translate name)
  (let ((len (string-length name)))
    (let loop ((ts (append *global-translations* (current-translations))))
      (if (null? ts)
          name
          (let* ((from (caar ts))
                 (to (cdar ts))
                 (k (string-length from)))
            (if (and to
                     (<= k len)
                     (string=? (substring name 0 k) from))
                (string-append to (substring name k len))
                (loop (cdr ts))))))))