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