1#lang racket/base 2(require racket/promise 3 compiler/module-suffix) 4 5(provide append-zo-suffix 6 append-c-suffix 7 append-constant-pool-suffix 8 append-object-suffix 9 append-extension-suffix 10 11 extract-base-filename/ss 12 extract-base-filename/c 13 extract-base-filename/kp 14 extract-base-filename/o 15 extract-base-filename/ext) 16 17(define (append-zo-suffix s) 18 (path-add-extension s #".zo")) 19 20(define (append-c-suffix s) 21 (path-add-extension s #".c")) 22 23(define (append-constant-pool-suffix s) 24 (path-add-extension s #".kp")) 25 26(define (append-object-suffix s) 27 (path-add-extension s (case (system-type) 28 [(unix macosx) #".o"] 29 [(windows) #".obj"]))) 30 31(define (append-extension-suffix s) 32 (path-add-extension s (system-type 'so-suffix))) 33 34(define (extract-suffix appender) 35 (subbytes (path->bytes (appender (bytes->path #"x"))) 1)) 36 37(define (extract-rx pat) 38 (byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$"))) 39 40(define (extract who s program rx kind simple) 41 (unless (path-string? s) 42 (raise-argument-error who "path-string?" s)) 43 (cond 44 [(regexp-match rx (if (path? s) s (string->path s))) 45 => (lambda (m) (bytes->path (cadr m)))] 46 [program 47 (if simple 48 (error program "not a ~a filename (doesn't end with ~a): ~a" 49 kind simple s) 50 (path-replace-extension s #""))] 51 [else #f])) 52 53(define module-suffix-regexp 54 (delay (get-module-suffix-regexp #:group 'libs))) 55 56(define (extract-base-filename/ss s [program #f] 57 #:module-pattern [module-pattern 58 (force module-suffix-regexp)]) 59 (extract 'extract-base-filename/ss 60 s program 61 module-pattern 62 "Racket" 63 #f)) 64 65(define (extract-base-filename/c s [program #f]) 66 (extract 'extract-base-filename/c 67 s program 68 (extract-rx #"c|cc|cxx|cpp|c[+][+]|m") 69 "C" 70 ".c, .cc, .cxx, .cpp, .c++, or .m")) 71 72(define (extract-base-filename/kp s [program #f]) 73 (extract 'extract-base-filename/kp 74 s 75 program 76 (extract-rx #"kp") 77 "constant pool" 78 ".kp")) 79 80(define (extract-base-filename/o s [program #f]) 81 (extract 'extract-base-filename/o 82 s program 83 (extract-rx (case (system-type) 84 [(unix beos macos macosx) #"o"] 85 [(windows) #"obj"])) 86 "compiled object" 87 (extract-suffix append-object-suffix))) 88 89(define (extract-base-filename/ext s [program #f]) 90 (extract 'extract-base-filename/ext 91 s 92 program 93 (extract-rx (regexp-quote (subbytes (system-type 'so-suffix) 1) #f)) 94 "Racket extension" 95 (extract-suffix append-extension-suffix))) 96