1
2;;----------------------------------------------------------------------
3;; #%misc : file utilities, etc. - remaining functions
4
5(module misc '#%kernel
6  (#%require "define-et-al.rkt" "qq-and-or.rkt" "cond.rkt" "define.rkt" "path.rkt" "old-path.rkt"
7             "path-list.rkt" "executable-path.rkt"
8             "reading-param.rkt" "../repl.rkt"
9             (for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt"))
10
11  ;; -------------------------------------------------------------------------
12
13  (define-for-syntax (pattern-failure user-stx pattern)
14    (let*-values ([(sexpr) (syntax->datum user-stx)]
15                  [(msg)
16                   (if (pair? sexpr)
17                       (format "use does not match pattern: ~.s"
18                               (cons (car sexpr) pattern))
19                       (if (symbol? sexpr)
20                           (format "use does not match pattern: ~.s"
21                                   (cons sexpr pattern))
22                           (error 'internal-error
23                                  "something bad happened")))])
24      (raise-syntax-error #f msg user-stx)))
25
26  (define-syntax define-syntax-rule
27    (lambda (stx)
28      (let-values ([(err) (lambda (what . xs)
29                            (apply raise-syntax-error
30                                   'define-syntax-rule what stx xs))])
31        (syntax-case stx ()
32          [(dr (name . pattern) template)
33           (identifier? #'name)
34           (syntax/loc stx
35             (define-syntax name
36               (lambda (user-stx)
37                 (syntax-case** dr #t user-stx () free-identifier=? #f
38                   [(_ . pattern) (syntax-protect (syntax/loc user-stx template))]
39                   [_ (pattern-failure user-stx 'pattern)]))))]
40          [(_ (name . ptrn) tmpl)         (err "expected an identifier" #'name)]
41          [(_ (name . ptrn))              (err "missing template")]
42          [(_ (name . ptrn) tmpl etc . _) (err "too many forms" #'etc)]
43          [(_ head . _)                   (err "invalid pattern" #'head)]))))
44
45  ;; -------------------------------------------------------------------------
46
47  (define rationalize
48    (letrec ([check (lambda (x)
49                      (unless (real? x) (raise-argument-error 'rationalize "real?" x)))]
50	     [find-between
51	      (lambda (lo hi)
52		(if (integer? lo)
53		    lo
54		    (let ([lo-int (floor lo)]
55			  [hi-int (floor hi)])
56		      (if (< lo-int hi-int)
57			  (add1 lo-int)
58			  (+ lo-int
59			     (/ (find-between (/ (- hi lo-int)) (/ (- lo lo-int)))))))))]
60             [do-find-between
61              (lambda (lo hi)
62                (cond
63                 [(negative? lo) (- (find-between (- hi) (- lo)))]
64                 [else (find-between lo hi)]))])
65      (lambda (x within)
66	(check x) (check within)
67        (let* ([delta (abs within)]
68               [lo (- x delta)]
69               [hi (+ x delta)])
70          (cond
71           [(not (= x x)) x]
72           [(or (equal? x +inf.0)
73                (equal? x -inf.0))
74            (if (equal? delta +inf.0) +nan.0 x)]
75           [(equal? delta +inf.0) 0.0]
76           [(not (= within within)) within]
77           [(<= lo 0 hi) (if (exact? x) 0 0.0)]
78           [(or (inexact? lo) (inexact? hi))
79            (exact->inexact (do-find-between (inexact->exact lo) (inexact->exact hi)))]
80           [else (do-find-between lo hi)])))))
81
82  ;; -------------------------------------------------------------------------
83
84
85
86  (define load/cd
87    (lambda (n)
88      (unless (path-string? n)
89	(raise-argument-error 'load/cd "path-string?" n))
90      (let-values ([(base name dir?) (split-path n)])
91	(if dir?
92	    (raise
93	     (exn:fail:filesystem
94	      (string->immutable-string
95	       (format "load/cd: cannot open a directory: ~s" n))
96	      (current-continuation-marks)))
97	    (if (not (path? base))
98		(load n)
99		(begin
100		  (if (not (directory-exists? base))
101		      (raise
102		       (exn:fail:filesystem
103			(string->immutable-string
104			 (format
105			  "load/cd: directory of ~s does not exist (current directory is ~s)"
106			  n (current-directory)))
107			(current-continuation-marks)))
108                      (void))
109		  (let ([orig (current-directory)])
110		    (dynamic-wind
111			(lambda () (current-directory base))
112			(lambda () (load name))
113			(lambda () (current-directory orig))))))))))
114
115  (define (-load load name path)
116    (unless (path-string? path)
117      (raise-argument-error name "path-string?" path))
118    (if (complete-path? path)
119	(load path)
120	(let ([dir (current-load-relative-directory)])
121	  (load (if dir (path->complete-path path dir) path)))))
122  (define (load-relative path) (-load load 'load-relative path))
123  (define (load-relative-extension path) (-load load-extension 'load-relative-extension path))
124
125  ;; -------------------------------------------------------------------------
126
127  (define-values (struct:guard make-guard guard? guard-ref guard-set!)
128    (make-struct-type 'evt #f 1 0 #f (list (cons prop:evt 0)) (current-inspector) #f '(0)))
129
130  (define (guard-evt proc)
131    (unless (and (procedure? proc)
132		 (procedure-arity-includes? proc 0))
133      (raise-argument-error 'guard-evt "(any/c . -> . evt?)" proc))
134    (make-guard (lambda (self) (proc))))
135
136  (define (channel-get ch)
137    (unless (channel? ch)
138      (raise-argument-error 'channel-get "channel?" ch))
139    (sync ch))
140
141  (define (channel-try-get ch)
142    (unless (channel? ch)
143      (raise-argument-error 'channel-try-get "channel?" ch))
144    (sync/timeout 0 ch))
145
146  (define (channel-put ch val)
147    (unless (channel? ch)
148      (raise-argument-error 'channel-put "channel?" ch))
149    (and (sync (channel-put-evt ch val)) (void)))
150
151  ;; -------------------------------------------------------------------------
152
153  (define (port? x) (or (input-port? x) (output-port? x)))
154
155  (define writeln
156    (case-lambda
157     [(v) (writeln v (current-output-port))]
158     [(v p)
159      (unless (output-port? p)
160        (raise-argument-error 'writeln "output-port?" 1 v p))
161      (write v p)
162      (newline p)]))
163
164  (define displayln
165    (case-lambda
166     [(v) (displayln v (current-output-port))]
167     [(v p)
168      (unless (output-port? p)
169        (raise-argument-error 'displayln "output-port?" 1 v p))
170      (display v p)
171      (newline p)]))
172
173  (define println
174    (case-lambda
175      [(v) (println v (current-output-port) 0)]
176      [(v p) (println v p 0)]
177      [(v p d)
178       (unless (output-port? p)
179         (raise-argument-error 'println "output-port?" 1 v p d))
180       (unless (and (number? d) (or (= 0 d) (= d 1)))
181         (raise-argument-error 'println "(or/c 0 1)" 2 v p d))
182       (print v p d)
183       (newline p)]))
184
185  ;; -------------------------------------------------------------------------
186
187  (define (string-no-nuls? s)
188    (and (string? s)
189         (not (regexp-match? #rx"\0" s))))
190
191  (define (bytes-environment-variable-name? s)
192    (and (bytes? s)
193         (if (eq? 'windows (system-type))
194             (regexp-match? #rx#"^[^\0=]+$" s)
195             (regexp-match? #rx#"^[^\0=]*$" s))))
196
197  (define (string-environment-variable-name? s)
198    (and (string? s)
199         (bytes-environment-variable-name?
200          (string->bytes/locale s (char->integer #\?)))))
201
202  (define (getenv s)
203    (unless (string-environment-variable-name? s)
204      (raise-argument-error 'getenv "string-environment-variable-name?" s))
205    (let ([v (environment-variables-ref (current-environment-variables)
206                                        (string->bytes/locale s (char->integer #\?)))])
207      (and v
208           (bytes->string/locale v #\?))))
209
210  (define (putenv s t)
211    (unless (string-no-nuls? s)
212      (raise-argument-error 'putenv "string-environment-variable-name?" 0 s t))
213    (unless (string-no-nuls? t)
214      (raise-argument-error 'putenv "string-no-nuls?" 1 s t))
215    (and
216     (environment-variables-set! (current-environment-variables)
217                                 (string->bytes/locale s (char->integer #\?))
218                                 (string->bytes/locale t (char->integer #\?))
219                                 (lambda () #f))
220     #t))
221
222  ;; -------------------------------------------------------------------------
223
224  (#%provide define-syntax-rule
225             rationalize
226             path-string?
227             path-replace-suffix path-add-suffix
228             path-replace-extension path-add-extension
229             normal-case-path reroot-path
230             read-eval-print-loop
231             load/cd
232             load-relative load-relative-extension
233             path-list-string->path-list find-executable-path
234             guard-evt channel-get channel-try-get channel-put
235             port? writeln displayln println
236             bytes-environment-variable-name?
237             string-environment-variable-name?
238             getenv putenv
239             call-with-default-reading-parameterization
240
241             ;; From '#%kernel, but re-exported for compatibility:
242             collection-path collection-file-path))
243