65 lines
2.3 KiB
Scheme
65 lines
2.3 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/unit "file-sig.ss")
|
|
|
|
(provide dynext:file@)
|
|
|
|
(define-unit dynext:file@ (import) (export dynext:file^)
|
|
|
|
(define (append-zo-suffix s)
|
|
(path-add-suffix s #".zo"))
|
|
|
|
(define (append-c-suffix s)
|
|
(path-add-suffix s #".c"))
|
|
|
|
(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-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)
|
|
(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))))))
|