/usr/share/scheme48-1.9/big/filename.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; 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 (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)
(let-fluid $translations (make-cell '()) thunk))
(define (current-translations) (cell-ref (fluid $translations)))
(define (set-translations! new)
(cell-set! (fluid $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))))))))
|