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

.

Browse Source 
original commit: 8ce11627dc7aa32453bdc564d8134d6a2a242ee4
This commit is contained in:
Matthew Flatt 2004-02-19 20:35:34 +00:00
parent 261d99965d
commit 7e6ab530bb
4 changed files with 65 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/mzlib/cm.ss
View File

@ -6,8 +6,10 @@
managed-compile-zo
make-caching-managed-compile-zo
trust-existing-zos
manager-compile-notify-handler
(rename trace manager-trace-handler))
(define manager-compile-notify-handler (make-parameter void))
(define trace (make-parameter void))
(define indent (make-parameter ""))
(define trust-existing-zos (make-parameter #f))
@ -73,7 +75,8 @@
((trace) (format "~afailure" (indent))))
(define (compile-zo path)
((trace) (format "~acompiling: ~a" (indent) (path->bytes path)))
((manager-compile-notify-handler) path)
((trace) (format "~acompiling: ~a" (indent) path))
(parameterize ([indent (string-append " " (indent))])
(let ([zo-name (bytes->path (bytes-append (get-compilation-path path) #".zo"))])
(cond
@ -106,19 +109,21 @@
(lambda () (write code out))
(lambda () (close-output-port out)))))
(let ([ss-sec (file-or-directory-modify-seconds path)]
[zo-sec (file-or-directory-modify-seconds zo-name)])
[zo-sec (if (file-exists? zo-name)
(file-or-directory-modify-seconds zo-name)
+inf.0)])
(when (< zo-sec ss-sec)
(error 'compile-zo
"date for newly created .zo file (~a @ ~a) is before source-file date (~a @ ~a)~a"
(path->bytes zo-name)
zo-name
(format-date (seconds->date zo-sec))
(path->bytes path)
path
(format-date (seconds->date ss-sec))
(if (> ss-sec (current-seconds))
", which appears to be in the future"
""))))
(write-deps code path external-deps)))])))
((trace) (format "~aend compile: ~a" (indent) (path->bytes path))))
((trace) (format "~aend compile: ~a" (indent) path)))
(define (format-date date)
(format "~a:~a:~a:~a:~a:~a"
@ -142,7 +147,7 @@
(lambda () (build-path dir "native" (system-library-subpath) _loader-path))
(lambda () (build-path dir "native" (system-library-subpath) (append-object-suffix name)))
(lambda () (build-path dir (path-replace-suffix name #".zo")))
(and w/fail? (lambda () (build-path dir (path-replace-suffix name #".zo" #".fail")))))))
(and w/fail? (lambda () (build-path dir (path-replace-suffix name #".fail")))))))
(define first-date
(case-lambda
@ -162,12 +167,12 @@
(cond
(stamp stamp)
(else
((trace) (format "~achecking: ~a" (indent) (path->bytes path)))
((trace) (format "~achecking: ~a" (indent) path))
(let ((path-zo-time (get-compiled-time path #f))
(path-time
(with-handlers ((exn:i/o:filesystem?
(lambda (ex)
((trace) (format "~a~a does not exist" (indent) (path->bytes path)))
((trace) (format "~a~a does not exist" (indent) path))
#f)))
(file-or-directory-modify-seconds path))))
(cond
@ -228,29 +233,29 @@
(lambda (path mod-name)
(cond
[(not mod-name)
((trace) (format "~askipping: ~a mod-name ~s" (indent) (path->bytes path) mod-name))
((trace) (format "~askipping: ~a mod-name ~s" (indent) path mod-name))
(default-handler path mod-name)]
[(eq? 'none (use-compiled-file-kinds))
((trace) (format "~askipping: ~a file-kinds ~s" (indent) (path->bytes path) (use-compiled-file-kinds)))
((trace) (format "~askipping: ~a file-kinds ~s" (indent) path (use-compiled-file-kinds)))
(default-handler path mod-name)]
[(not (eq? compilation-manager-load-handler (current-load/use-compiled)))
((trace) (format "~askipping: ~a current-load/use-compiled changed ~s"
(indent) (path->bytes path) (current-load/use-compiled)))
(indent) path (current-load/use-compiled)))
(default-handler path mod-name)]
[(not (eq? orig-eval (current-eval)))
((trace) (format "~askipping: ~a orig-eval ~s current-eval ~s"
(indent) (path->bytes path) orig-eval (current-eval)))
(indent) path orig-eval (current-eval)))
(default-handler path mod-name)]
[(not (eq? orig-load (current-load)))
((trace) (format "~askipping: ~a orig-load ~s current-load ~s"
(indent) (path->bytes path) orig-load (current-load)))
(indent) path orig-load (current-load)))
(default-handler path mod-name)]
[(not (eq? orig-namespace (current-namespace)))
((trace) (format "~askipping: ~a orig-namespace ~s current-namespace ~s"
(indent) (path->bytes path) orig-namespace (current-namespace)))
(indent) path orig-namespace (current-namespace)))
(default-handler path mod-name)]
[else
((trace) (format "~aprocessing: ~a" (indent) (path->bytes path)))
((trace) (format "~aprocessing: ~a" (indent) path))
(compile-root path cache)
(default-handler path mod-name)]))])
compilation-manager-load-handler))))

16
collects/mzlib/cmdline.ss
View File

@ -212,13 +212,13 @@
[(program arguments table finish finish-help help)
(parse-command-line program arguments table finish finish-help help
(lambda (flag)
(error (string->symbol (bytes->string/locale program #\?)) "unknown flag: ~s" flag)))]
(error (string->symbol program) "unknown flag: ~s" flag)))]
[(program arguments table finish finish-help help unknown-flag)
(unless (or (string? program) (bytes? program))
(raise-type-error 'parse-command-line "program name string or byte string" program))
(unless (string? program)
(raise-type-error 'parse-command-line "program name string" program))
(unless (and (vector? arguments)
(andmap bytes? (vector->list arguments)))
(raise-type-error 'parse-command-line "argument vector of byte strings" arguments))
(andmap string? (vector->list arguments)))
(raise-type-error 'parse-command-line "argument vector of strings" arguments))
(unless (and (list? table)
(let ([bad-table
(lambda (reason)
@ -424,9 +424,7 @@
(let loop ([args args])
(if (null? args)
""
(string-append (bytes->string/locale (car args) #\?)
" "
(loop (cdr args))))))))))]
(string-append (car args) " " (loop (cdr args))))))))))]
[call-handler
(lambda (handler flag args r-acc k)
(let* ([a (procedure-arity handler)]
@ -487,7 +485,7 @@
(set-car! set #t))))
(call-handler (caddar table) flag args r-acc k)]
[else (loop (cdr table))])))])
(let loop ([args (map (lambda (s) (bytes->string/locale s #\?)) (vector->list arguments))][r-acc null])
(let loop ([args (vector->list arguments)][r-acc null])
(if (null? args)
(done args r-acc)
(let ([arg (car args)]

66
collects/mzlib/file.ss
View File

@ -46,7 +46,7 @@
path)])
(let loop ([full-path orig-path][seen-paths (list orig-path)])
(let ([resolved (resolve-path full-path)])
(if (string=? resolved full-path)
(if (equal? resolved full-path)
(do-normalize-path resolved #f)
(let ([path (if (relative-path? resolved)
(build-path
@ -67,7 +67,7 @@
(loop spath (cons path seen-paths))))))))))]
[resolve
(lambda (path)
(if (string=? path (resolve-path path))
(if (equal? path (resolve-path path))
path
(resolve-all path #f)))]
[normalize-path
@ -139,8 +139,8 @@
(let loop ([path orig-path][rest '()])
(let-values ([(base name dir?) (split-path path)])
(when (or (and base
(not (string? base)))
(not (string? name)))
(not (path? base)))
(not (path? name)))
(raise-type-error who "path in normal form" orig-path))
(if base
(loop base (cons name rest))
@ -155,13 +155,13 @@
(lambda (directory filename)
(let ([dir (do-explode-path 'find-relative-path directory)]
[file (do-explode-path 'find-relative-path filename)])
(if (string=? (car dir) (car file))
(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))]
[(null? file) (apply build-path (map (lambda (x) 'up) dir))]
[(string=? (car dir) (car file))
[(equal? (car dir) (car file))
(loop (cdr dir) (cdr file))]
[else
(apply build-path
@ -187,15 +187,12 @@
;; name can be any string; we just look for a dot
(define filename-extension
(lambda (name)
(let* ([len (string-length name)]
[extension
(let loop ([p (sub1 len)])
(cond
[(negative? p) #f]
[(char=? (string-ref name p) #\.)
(substring name (add1 p) len)]
[else (loop (sub1 p))]))])
extension)))
(let ([name (if (string? name)
name
(path->bytes name))])
(let ([m (regexp-match #rx#".(.?)$")])
(and m
(cadr m))))))
(define (delete-directory/files path)
(cond
@ -224,7 +221,7 @@
(define (make-directory* dir)
(let-values ([(base name dir?) (split-path dir)])
(when (and (string? base)
(when (and (path? base)
(not (directory-exists? base)))
(make-directory* base))
(unless (directory-exists? dir)
@ -232,19 +229,24 @@
(define make-temporary-file
(case-lambda
[(template copy-from)
[(template copy-from base-dir)
(with-handlers ([not-break-exn?
(lambda (x)
(raise-type-error 'make-temporary-file
"format string for 1 argument"
template))])
(format template void))
(unless (or (not copy-from) (path-string? copy-from))
(raise-type-error 'make-temporary-file "path, valid-path string, or #f" copy-from))
(unless (or (not base-dir) (path-string? base-dir))
(raise-type-error 'make-temporary-file "path, valid-path, string, or #f" base-dir))
(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))])
(if (relative-path? n)
(build-path tmpdir n)
n))])
(cond
[base-dir (build-path base-dir n)]
[(relative-path? n) (build-path tmpdir n)]
[else n]))])
(with-handlers ([exn:i/o:filesystem? (lambda (x)
(if (eq? (exn:i/o:filesystem-detail x)
'already-exists)
@ -257,8 +259,9 @@
(copy-file copy-from name)
(close-output-port (open-output-file name)))
name))))]
[(template) (make-temporary-file template #f)]
[() (make-temporary-file "mztmp~a" #f)]))
[(template copy-from) (make-temporary-file template copy-from #f)]
[(template) (make-temporary-file template #f #f)]
[() (make-temporary-file "mztmp~a" #f #f)]))
(define find-library
(case-lambda
@ -374,12 +377,16 @@
(let ([dir (if (symbol? base)
(current-directory)
base)])
(unless (directory-exists? dir)
(make-directory* dir))
(values filename
(build-path dir (format "~aLOCK~a"
(if (eq? 'windows (system-type))
"_"
".")
name))
(build-path dir (bytes->path
(bytes-append
(if (eq? 'windows (system-type))
#"_"
#".")
#"LOCK"
(path->bytes name))))
dir))))])
(with-handlers ([(lambda (x)
(and (exn:i/o:filesystem? x)
@ -405,8 +412,9 @@
;; (preserves permissions, etc), write to the temp file,
;; then move (atomicly) the temp file to the normal name.
(let* ([tmp-file (make-temporary-file
(build-path (regexp-replace "~" pref-dir "~~") "TMPPREF~a")
(and (file-exists? pref-file) pref-file))])
"TMPPREF~a"
(and (file-exists? pref-file) pref-file)
pref-dir)])
(with-output-to-file tmp-file
(lambda ()
(with-pref-params

2
collects/mzlib/process.ss
View File

@ -15,7 +15,7 @@
(define (shell-path/args who argstr)
(case (system-type)
((unix macosx) (append '(#"/bin/sh" #"-c") (list argstr)))
((unix macosx) (append '("/bin/sh" "-c") (list argstr)))
((windows) (let ([cmd
(let ([d (find-system-path 'sys-dir)])
(let ([cmd (build-path d "cmd.exe")])