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

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

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