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