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

improve code, port to v4

Browse Source 
svn: r8853
This commit is contained in:
Eli Barzilay 2008-03-02 22:52:12 +00:00
parent 0d54a9816f
commit b4cca0ce2a
1 changed files with 54 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
collects/dynext/file-unit.ss
View File

@ -1,16 +1,10 @@
#lang scheme/base
(module file-unit mzscheme (require scheme/unit "file-sig.ss")
(require mzlib/unit
mzlib/include
mzlib/string)
(require "file-sig.ss")
(provide dynext:file@) (provide dynext:file@)
(define-unit dynext:file@ (define-unit dynext:file@ (import) (export dynext:file^)
(import)
(export dynext:file^)
(define (append-zo-suffix s) (define (append-zo-suffix s)
(path-add-suffix s #".zo")) (path-add-suffix s #".zo"))
@ -22,9 +16,7 @@
(path-add-suffix s #".kp")) (path-add-suffix s #".kp"))
(define (append-object-suffix s) (define (append-object-suffix s)
(path-add-suffix (path-add-suffix s (case (system-type)
s
(case (system-type)
[(unix beos macos macosx) #".o"] [(unix beos macos macosx) #".o"]
[(windows) #".obj"]))) [(windows) #".obj"])))
@ -32,9 +24,7 @@
(path-add-suffix s (system-type 'so-suffix))) (path-add-suffix s (system-type 'so-suffix)))
(define (extract-suffix appender) (define (extract-suffix appender)
(subbytes (subbytes (path->bytes (appender (bytes->path #"x"))) 1))
(path->bytes (appender (bytes->path #"x")))
1))
(define-values (extract-base-filename/ss (define-values (extract-base-filename/ss
extract-base-filename/c extract-base-filename/c
@ -43,39 +33,32 @@
extract-base-filename/ext) extract-base-filename/ext)
(let ([mk (let ([mk
(lambda (who pat kind simple) (lambda (who pat kind simple)
(let ([rx (byte-pregexp (define rx
(string->bytes/latin-1 (format "^(.*)\\.(~a)$" pat)))]) (byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$")))
(letrec ([extract-base-filename (define (extract-base-filename s [p #f])
(case-lambda
[(s p)
(unless (path-string? s) (unless (path-string? s)
(raise-type-error who "path or valid-path string" s)) (raise-type-error who "path or valid-path string" s))
(let ([m (regexp-match rx (path->bytes (if (path? s) (cond [(regexp-match
s rx (path->bytes (if (path? s) s (string->path s))))
(string->path s))))]) => (lambda (m) (bytes->path (cadr m)))]
(cond
[m (bytes->path (cadr m))]
[p (if simple [p (if simple
(error p "not a ~a filename (doesn't end with ~a): ~a" kind simple s) (error p "not a ~a filename (doesn't end with ~a): ~a"
kind simple s)
(path-replace-suffix s #""))] (path-replace-suffix s #""))]
[else #f]))] [else #f]))
[(s) (extract-base-filename s #f)])]) extract-base-filename)])
extract-base-filename)))])
(values (values
(mk 'extract-base-filename/ss (mk 'extract-base-filename/ss #"ss|scm" "Scheme" #f)
#"[sS][sS]|[sS][cC][mM]" "Scheme" #f)
(mk 'extract-base-filename/c (mk 'extract-base-filename/c
#"[cC]|[cC][cC]|[cC][xX][xX]|[cC][pP][pP]|[cC][+][+]|[mM]" "C" ".c, .cc, .cxx, .cpp, .c++, or .m") #"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m")
(mk 'extract-base-filename/kp (mk 'extract-base-filename/kp #"kp" "constant pool" ".kp")
#"[kK][pP]" "constant pool" ".kp")
(mk 'extract-base-filename/o (mk 'extract-base-filename/o
(case (system-type) (case (system-type)
[(unix beos macos macosx) #"[oO]"] [(unix beos macos macosx) #"o"]
[(windows) #"[oO][bB][jJ]"]) [(windows) #"obj"])
"compiled object" "compiled object"
(extract-suffix append-object-suffix)) (extract-suffix append-object-suffix))
(mk 'extract-base-filename/ext (mk 'extract-base-filename/ext
(regexp-quote (subbytes (system-type 'so-suffix) 1) #f) (regexp-quote (subbytes (system-type 'so-suffix) 1) #f)
"MzScheme extension" "MzScheme extension"
(extract-suffix append-extension-suffix))))))) (extract-suffix append-extension-suffix))))))