suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

some code reformatting

Browse Source 
svn: r6929
This commit is contained in:
Eli Barzilay 2007-07-17 09:16:30 +00:00
parent 062da57e00
commit e198aa3c29
1 changed files with 104 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/mzlib/file.ss
View File

@ -25,17 +25,15 @@
(require "list.ss" "kw.ss")
(define build-relative-path
(lambda (p . args)
(define (build-relative-path p . args)
(if (relative-path? p)
(apply build-path p args)
(error 'build-relative-path "base path ~s is absolute" p))))
(error 'build-relative-path "base path ~s is absolute" p)))
(define build-absolute-path
(lambda (p . args)
(define (build-absolute-path p . args)
(if (relative-path? p)
(error 'build-absolute-path "base path ~s is relative" p)
(apply build-path p args))))
(apply build-path p args)))
;; Note that normalize-path does not normalize the case
(define normalize-path
@ -115,10 +113,9 @@
(if (directory-exists? n)
n
(error-not-a-dir n)))])]
[else
(cond
[(not base) (path->complete-path path)]
[else (let* ([base (if (eq? base 'relative)
[else
(let* ([base (if (eq? base 'relative)
(normalize wrt)
(normalize base))]
[path (if (directory-exists? base)
@ -130,46 +127,39 @@
(normalize (build-path base resolved))]
[(complete-path? resolved)
resolved]
[else (path->complete-path resolved base)]))])]))))])
[else (path->complete-path resolved base)]))]))))])
normalize-path))
;; Argument must be in normal form
(define do-explode-path
(lambda (who orig-path)
(define (do-explode-path who orig-path)
(let loop ([path orig-path][rest '()])
(let-values ([(base name dir?) (split-path path)])
(when (or (and base
(not (path? base)))
(when (or (and base (not (path? base)))
(not (path? name)))
(raise-type-error who "path in normal form" orig-path))
(if base
(loop base (cons name rest))
(cons name rest))))))
(cons name rest)))))
(define explode-path
(lambda (orig-path)
(define (explode-path orig-path)
(unless (path-string? orig-path)
(raise-type-error 'explode-path "path or string" orig-path))
(do-explode-path 'explode-path orig-path)))
(do-explode-path 'explode-path orig-path))
;; Arguments must be in normal form
(define find-relative-path
(lambda (directory filename)
(define (find-relative-path directory filename)
(let ([dir (do-explode-path 'find-relative-path directory)]
[file (do-explode-path 'find-relative-path filename)])
(if (equal? (car dir) (car file))
(let loop ([dir (cdr dir)]
[file (cdr file)])
(cond
[(null? dir) (if (null? file) filename (apply build-path file))]
(cond [(null? dir) (if (null? file) filename (apply build-path file))]
[(null? file) (apply build-path (map (lambda (x) 'up) dir))]
[(equal? (car dir) (car file))
(loop (cdr dir) (cdr file))]
[else
(apply build-path
(append (map (lambda (x) 'up) dir)
file))]))
filename))))
(apply build-path (append (map (lambda (x) 'up) dir) file))]))
filename)))
(define (file-name who name)
(unless (path-string? name)
@ -215,7 +205,8 @@
(copy-file src dest)]
[(directory-exists? src)
(make-directory dest)
(for-each (lambda (e) (copy-directory/files (build-path src e)
(for-each (lambda (e)
(copy-directory/files (build-path src e)
(build-path dest e)))
(directory-list src))]
[else (error 'copy-directory/files
@ -251,8 +242,7 @@
(let ([tmpdir (find-system-path 'temp-dir)])
(let loop ([s (current-seconds)][ms (current-milliseconds)])
(let ([name (let ([n (format template (format "~a~a" s ms))])
(cond
[base-dir (build-path base-dir n)]
(cond [base-dir (build-path base-dir n)]
[(relative-path? n) (build-path tmpdir n)]
[else n]))])
(with-handlers ([exn:fail:filesystem:exists?
@ -459,21 +449,19 @@
;; Release lock:
(delete-file lock-file))))))
(define call-with-input-file*
(lambda (file thunk . flags)
(define (call-with-input-file* file thunk . flags)
(let ([p (apply open-input-file file flags)])
(dynamic-wind
void
(lambda () (thunk p))
(lambda () (close-input-port p))))))
(lambda () (close-input-port p)))))
(define call-with-output-file*
(lambda (file thunk . flags)
(define (call-with-output-file* file thunk . flags)
(let ([p (apply open-output-file file flags)])
(dynamic-wind
void
(lambda () (thunk p))
(lambda () (close-output-port p))))))
(lambda () (close-output-port p)))))
;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
(define/kw (fold-files f init #:optional [path #f] [follow-links? #t])