1#lang racket/base
2(require "bootstrap-main.rkt"
3         (only-in racket/base
4                  [string->bytes/utf-8 host:string->bytes/utf-8]
5                  [bytes->string/utf-8 host:bytes->string/utf-8]
6                  [open-input-file host:open-input-file]
7                  [close-input-port host:close-input-port]
8                  [read-line host:read-line]
9                  [read-byte host:read-byte]
10                  [file-stream-buffer-mode host:file-stream-buffer-mode]
11                  [port-count-lines! host:port-count-lines!]
12                  [current-directory host:current-directory]
13                  [path->string host:path->string]))
14
15(path->string (current-directory))
16(set-string->number?! string->number)
17
18(get-machine-info)
19
20(let ()
21  (define-values (i o) (make-pipe 4096))
22
23  (define done? #f)
24
25  (thread (lambda ()
26            (sync (system-idle-evt))
27            (set! done? #t)
28            (close-input-port i)))
29
30  ;; Should error:
31  (let loop ()
32    (write-bytes #"hello" o)
33    (unless done?
34      (loop))))
35
36(define-syntax-rule (test expect rhs)
37  (let ([e expect]
38        [v rhs])
39    (unless (equal? e v)
40      (error 'failed "~s: ~e not ~e" 'rhs v e))))
41
42(test #f (bytes-utf-8-ref #"\364\220\200\200" 0))
43
44(test #"\205\327\305\377@:\276r\337[\212'\b\202\36\343<\320\274\316" (sha1-bytes #"abcdefghijklmn"))
45(test #"\340\373\262\1m\341\6V\352$IR\311}\350x7\337d\263\320\243\247\350\342\31R " (sha224-bytes #"abcdefghijklmn"))
46(test #"\6S\307\351\222\327\252\324\f\262cW8\270p\344\301T\257\263F4\r\2\307\227\324\220\335R\325\371" (sha256-bytes #"abcdefghijklmn"))
47(test #"\205\327\305\377@:\276r\337[\212'\b\202\36\343<\320\274\316" (sha1-bytes (open-input-bytes #"abcdefghijklmn")))
48(test #"\205\327\305\377@:\276r\337[\212'\b\202\36\343<\320\274\316" (sha1-bytes (open-input-bytes #"__abcdefghijklmn__") 2 16))
49
50(test #t (file-exists? "demo.rkt"))
51(test #f (file-exists? "compiled"))
52(test #f (file-exists? "compiled/demo-file"))
53
54(test #t (directory-exists? "compiled"))
55(test #f (directory-exists? "compiled/demo-dir"))
56
57(test #f (link-exists? "compiled"))
58(test #f (link-exists? "compiled/demo-dir"))
59
60(call-with-output-file "compiled/demo-file" void)
61(call-with-output-file "compiled/demo-file" void 'replace)
62(let ([now (current-seconds)]
63      [f-now (file-or-directory-modify-seconds "compiled/demo-file")])
64  (test #t (<= (- now 10) f-now now))
65  (file-or-directory-modify-seconds "compiled/demo-file" (- now 5))
66  (test (- now 5) (file-or-directory-modify-seconds "compiled/demo-file")))
67(rename-file-or-directory "compiled/demo-file" "compiled/demo-file2")
68(delete-file "compiled/demo-file2")
69
70(test 88 (file-or-directory-modify-seconds "compiled/bad" #f (lambda () 88)))
71(test 89 (file-or-directory-modify-seconds "compiled/bad" (current-seconds) (lambda () 89)))
72
73(test #t (and (memq 'read (file-or-directory-permissions "demo.rkt")) #t))
74(test #t (and (memq 'read (file-or-directory-permissions "compiled")) #t))
75
76(printf "~s\n" (filesystem-root-list))
77(printf "~s\n" (directory-list))
78(make-directory "compiled/demo-dir")
79(delete-directory "compiled/demo-dir")
80
81(printf "demo.rkt = ~s\n" (file-or-directory-identity "demo.rkt"))
82(test (file-or-directory-identity "demo.rkt") (file-or-directory-identity "demo.rkt"))
83(test #f (= (file-or-directory-identity "compiled") (file-or-directory-identity "demo.rkt")))
84
85(test (call-with-input-file "demo.rkt"
86        (lambda (i)
87          (let loop ([n 0])
88            (if (eof-object? (read-byte i))
89                n
90                (loop (add1 n))))))
91      (file-size "demo.rkt"))
92
93(copy-file "demo.rkt" "compiled/demo-copy" #t)
94(test (file-size "demo.rkt")
95      (file-size "compiled/demo-copy"))
96(test (file-or-directory-permissions "demo.rkt" 'bits)
97      (file-or-directory-permissions "compiled/demo-copy" 'bits))
98(delete-file "compiled/demo-copy")
99
100(make-file-or-directory-link "../demo.rkt" "compiled/also-demo.rkt")
101(test #t (link-exists? "compiled/also-demo.rkt"))
102(test (string->path "../demo.rkt") (resolve-path "compiled/also-demo.rkt"))
103(delete-file "compiled/also-demo.rkt")
104(test #f (link-exists? "compiled/also-demo.rkt"))
105
106(printf "~s\n" (expand-user-path "~/at-home"))
107
108(struct animal (name weight)
109  #:property prop:custom-write (lambda (v o mode)
110                                 (fprintf o "<~a>" (animal-name v))))
111
112(test "apple" (format "~a" 'apple))
113(test "apple" (format "~a" "apple"))
114(test "apple" (format "~a" #"apple"))
115(test "#:apple" (format "~a" '#:apple))
116(test "17.5" (format "~a" 17.5))
117
118(test "apple" (format "~s" 'apple))
119(test "\"apple\"" (format "~s" "apple"))
120(test "#\"apple\"" (format "~s" #"apple"))
121(test "#:apple" (format "~s" '#:apple))
122(test "17.5" (format "~s" 17.5))
123
124(test "1\n\rx0!\"hi\"" (format "1~%~  \n  \rx~ ~o~c~s" 0 #\! "hi"))
125
126(test "*(1 2 3 apple\t\u0001 end <spot> file 1\"2\"3 #hash((a . 1) (b . 2)))*"
127      (format "*~a*" `(1 2 3 "apple\t\001" end ,(animal 'spot 155) ,(string->path "file") #"1\"2\"3" #hash((b . 2) (a . 1)))))
128(test "*'(1 2 3 \"apple\\t\\u0001\" end <spot> #\"1\\\"2\\\"3\\t\\0010\")*"
129      (format "*~.v*" `(1 2 3 "apple\t\001" end ,(animal 'spot 155) #"1\"2\"3\t\0010")))
130
131(fprintf (current-output-port) "*~v*" '!!!)
132(newline)
133
134(parameterize ([error-print-width 5])
135  (test "abc" (format "~.a" "abc"))
136  (test "abcde" (format "~.a" "abcde"))
137  (test "ab..." (format "~.a" "abcdef"))
138  (test "abc" (format "~.a" #"abc"))
139  (test "abcde" (format "~.a" #"abcde"))
140  (test "ab..." (format "~.a" #"abcdef"))
141  (test "ab..." (format "~.a" 'abcdef))
142  (test "\"ab\"" (format "~.s" "ab"))
143  (test "\"abc\"" (format "~.s" "abc"))
144  (test "\"a..." (format "~.s" "abcde"))
145  (test "#\"a\"" (format "~.s" #"a"))
146  (test "#\"ab\"" (format "~.s" #"ab"))
147  (test "#\"..." (format "~.s" #"abc"))
148  (test "#\"..." (format "~.s" #"abcdef"))
149  (test "|a b|" (format "~.s" '|a b|))
150  (test "|a..." (format "~.s" '|a bx|))
151  (test "(1 2)" (format "~.a" '(1 2)))
152  (test "(1..." (format "~.a" '(10 2))))
153
154(test "no: hi 10"
155      (with-handlers ([exn:fail? exn-message])
156        (error 'no "hi ~s" 10)))
157
158(test "error: format string requires 1 arguments, given 3; arguments were: 1 2 3"
159      (with-handlers ([exn:fail? exn-message])
160        (error 'no "hi ~s" 1 2 3)))
161(test "error: format string requires 2 arguments, given 1; arguments were: 8"
162      (with-handlers ([exn:fail? exn-message])
163        (error 'no "hi ~s ~s" 8)))
164(test "error: format string requires 2 arguments, given 100"
165      (with-handlers ([exn:fail? exn-message])
166        (apply error 'no "hi ~s ~s" (for/list ([i 100]) i))))
167(test "error: format string requires 2 arguments, given 51"
168      (with-handlers ([exn:fail? exn-message])
169        (apply error 'no "hi ~s ~s" (for/list ([i 51]) i))))
170(test (apply string-append
171             "error: format string requires 2 arguments, given 50; arguments were:"
172             (for/list ([i 50]) (string-append " " (number->string i))))
173      (with-handlers ([exn:fail? exn-message])
174        (apply error 'no "hi ~s ~s" (for/list ([i 50]) i))))
175
176(define infinite-ones
177  (make-input-port 'ones
178                   (lambda (s)
179                     (bytes-set! s 0 (char->integer #\1))
180                     1)
181                   #f
182                   void))
183
184(test 49 (read-byte infinite-ones))
185(test #\1 (read-char infinite-ones))
186(test #"11111" (read-bytes 5 infinite-ones))
187(test #"11111" (peek-bytes 5 3 infinite-ones))
188(test #"11111" (read-bytes 5 infinite-ones))
189(test "11111" (read-string 5 infinite-ones))
190
191(define fancy-infinite-ones
192  (make-input-port 'fancy-ones
193                   (lambda (s)
194                     (bytes-set! s 0 (char->integer #\1))
195                     1)
196                   (lambda (s skip progress-evt)
197                     (bytes-set! s 0 (char->integer #\1))
198                     1)
199                   (lambda () (void))
200                   (lambda () (make-semaphore))
201                   (lambda (amt evt ext-evt) (make-bytes amt (char->integer #\1)))
202                   (lambda () (values 7 42 1024))
203                   (lambda () (void))
204                   (lambda () 99)
205                   (case-lambda
206                     [() 'block]
207                     [(m) (void)])))
208(test #"11111" (read-bytes 5 fancy-infinite-ones))
209(test #t (evt? (port-progress-evt fancy-infinite-ones)))
210(test #t (port-commit-peeked 5 (port-progress-evt fancy-infinite-ones) always-evt fancy-infinite-ones))
211(test '(#f #f 99) (call-with-values (lambda () (port-next-location fancy-infinite-ones)) list))
212(port-count-lines! fancy-infinite-ones)
213(test '(7 42 1024) (call-with-values (lambda () (port-next-location fancy-infinite-ones)) list))
214(test 98 (file-position fancy-infinite-ones))
215(test 'block (file-stream-buffer-mode fancy-infinite-ones))
216(test (void) (file-stream-buffer-mode fancy-infinite-ones 'none))
217
218(define mod3-peeked? #f)
219(define mod3-cycle/one-thread
220  (let* ([n 2]
221	 [mod! (lambda (s delta)
222		 (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3)))
223                 1)])
224    (make-input-port
225     'mod3-cycle/not-thread-safe
226     (lambda (s)
227       (set! n (modulo (add1 n) 3))
228       (mod! s 0))
229     (lambda (s skip progress-evt)
230       (set! mod3-peeked? #t)
231       (mod! s (add1 skip)))
232     void)))
233(test "01201" (read-string 5 mod3-cycle/one-thread))
234(test #f mod3-peeked?)
235(test "01201" (peek-string 5 (expt 2 5000) mod3-cycle/one-thread))
236
237(let-values ([(r w) (make-pipe)])
238  (write-byte 200 w)
239  (test #t (byte-ready? r))
240  (test #f (char-ready? r)))
241
242(let ()
243  (define-values (r w) (make-pipe))
244  (define ch (make-channel))
245  (display "hi" w)
246  (peek-byte r)
247  (let ([t (thread (lambda ()
248		     (port-commit-peeked 1 (port-progress-evt r) ch r)))])
249    (sync (system-idle-evt))
250    (let ([t2
251	   (thread (lambda ()
252		     (port-commit-peeked 1 (port-progress-evt r) ch r)))])
253      (sync (system-idle-evt))
254      (test #t (thread-running? t))
255      (test #t (thread-running? t2))
256      (thread-suspend t2)
257      (break-thread t2)
258      (kill-thread t)
259      (thread-resume t2)
260      (sleep)))
261  (test (char->integer #\h) (peek-byte r)))
262
263(let ()
264  (define i (open-input-bytes #"apple"))
265  (test (char->integer #\a) (peek-byte i))
266  (define threads
267    (for/list ([n (in-range 100)])
268      (thread (lambda () (test #f (port-commit-peeked 1 (port-progress-evt i) (make-semaphore) i))))))
269  (sync (system-idle-evt))
270  (test #t (andmap thread-running? threads))
271  (test (char->integer #\a) (read-byte i))
272  (sync (system-idle-evt))
273  (test #f (andmap thread-running? threads)))
274
275(define accum-list '())
276(define accum-sema (make-semaphore 1))
277(define (accum-ready?) (and (sync/timeout 0 (semaphore-peek-evt accum-sema)) #t))
278(define (maybe-accum-evt)
279  (if (zero? (random 2))
280      (wrap-evt (semaphore-peek-evt accum-sema) (lambda (v) #f))
281      #f))
282(define accum-o
283  (make-output-port 'accum
284                    (semaphore-peek-evt accum-sema)
285                    (lambda (bstr start end no-buffer/block? enable-break?)
286                      (cond
287                        [(accum-ready?)
288                         (set! accum-list (cons (subbytes bstr start end) accum-list))
289                         (- end start)]
290                        [else
291                         (maybe-accum-evt)]))
292                    void
293                    (lambda (v no-buffer/block? enable-break?)
294                      (cond
295                        [(accum-ready?)
296                         (set! accum-list (cons v accum-list))
297                         #t]
298                        [else
299                         (maybe-accum-evt)]))
300                    (lambda (bstr start end)
301                      (wrap-evt (semaphore-peek-evt accum-sema)
302                                (lambda (a)
303                                  (set! accum-list (cons (subbytes bstr start end) accum-list))
304                                  (- end start))))
305                    (lambda (v)
306                      (wrap-evt (semaphore-peek-evt accum-sema)
307                                (lambda (a)
308                                  (set! accum-list (cons v accum-list))
309                                  #t)))))
310
311(test 5 (write-bytes #"hello" accum-o))
312(test '(#"hello") accum-list)
313(test 0 (write-bytes #"" accum-o))
314(test '(#"hello") accum-list)
315(test (void) (flush-output accum-o))
316(test '(#"" #"hello") accum-list)
317(test 4 (sync (write-bytes-avail-evt #"hola!!" accum-o 0 4)))
318(test '(#"hola" #"" #"hello") accum-list)
319(test #t (port-writes-special? accum-o))
320(test #t (write-special 'howdy accum-o))
321(test '(howdy #"hola" #"" #"hello") accum-list)
322
323(set! accum-list '())
324(semaphore-wait accum-sema)
325(test #f (sync/timeout 0 accum-o))
326(test 0 (write-bytes-avail* #"hello" accum-o))
327(test accum-list '())
328(semaphore-post accum-sema)
329(test accum-o (sync/timeout 0 accum-o))
330(test 5 (write-bytes-avail* #"hello" accum-o))
331(test accum-list '(#"hello"))
332
333(define specialist
334  (let ([special
335          (lambda (source line col pos)
336            (list 'special source line col pos))])
337    (make-input-port 'ones
338                     (lambda (s) special)
339                     (lambda (bstr skip-k p-evt) special)
340                     void)))
341(port-count-lines! specialist)
342
343(test '(special #f 1 0 1) (read-byte-or-special specialist))
344(test '#&(special src 1 1 2) (read-byte-or-special specialist box 'src))
345(test '(special #f 1 2 3) (peek-byte-or-special specialist))
346(test '#&(special src 1 2 3) (peek-byte-or-special specialist 0 #f box 'src))
347(test 'special (peek-byte-or-special specialist 0 #f 'special 'src))
348(test 'special (peek-char-or-special specialist 0 'special 'src))
349
350(let-values ([(i o) (make-pipe)])
351  (struct my-i (i) #:property prop:input-port 0)
352  (struct my-o (o) #:property prop:output-port 0)
353  (define c-i (let ([i (my-i i)])
354                (make-input-port 'c-i i i void)))
355  (define c-o (let ([o (my-o o)])
356                (make-output-port 'c-o o o void)))
357  (write-bytes #"hello" c-o)
358  (test #"hello" (read-bytes 5 c-i)))
359
360(test "apλple" (bytes->string/utf-8 (string->bytes/utf-8 "!!ap\u3BBple__" #f 2) #f 0 7))
361(test "ap?ple" (bytes->string/latin-1 (string->bytes/latin-1 "ap\u3BBple" (char->integer #\?))))
362(test "apλp\uF7F8\U00101234le" (bytes->string/utf-8 (string->bytes/utf-8 "ap\u3BBp\uF7F8\U101234le")))
363(test (string (integer->char #x10400)) (bytes->string/utf-8 #"\360\220\220\200"))
364
365(define apple (string->bytes/utf-8 "ap\u3BBple"))
366(define elppa (list->bytes (reverse (bytes->list (string->bytes/utf-8 "ap\u3BBple")))))
367
368(let ()
369  (define-values (i o) (make-pipe))
370  (for ([n 3])
371    (test 4096 (write-bytes (make-bytes 4096 (char->integer #\a)) o))
372    (for ([j (in-range 4096)])
373      (read-byte i))
374    (unless (zero? (pipe-content-length i))
375      (error "pipe loop failed\n"))))
376
377(define p (open-input-bytes apple))
378(define-values (i o) (make-pipe))
379
380(void (write-bytes #"x" o))
381(test
382 256
383 (let loop ([x 1] [content '(#"x")] [accum null])
384   (cond
385     [(= x 256) x]
386     [(null? content)
387      (loop x (reverse accum) null)]
388     [else
389      (define bstr (list->bytes
390                    (for/list ([j (in-range x)])
391                      (modulo j 256))))
392      (write-bytes bstr o)
393      (write-bytes bstr o)
394      (unless (equal? (read-bytes (bytes-length (car content)) i)
395                      (car content))
396        (error))
397      (loop (add1 x) (cdr content) (list* bstr bstr accum))])))
398
399(let ()
400  (define path (build-path "compiled" "demo-out"))
401  (define o (open-output-file path 'truncate))
402  ;; We expect this to be buffered:
403  (test 12 (write-bytes #"abcdefghijkl" o))
404  (test 12 (file-position o))
405  (test (void) (file-position o 6))
406  (test 3 (write-bytes #"xyz" o))
407  (test (void) (file-position o eof))
408  (test 1 (write-bytes #"!" o))
409  (close-output-port o)
410
411  (test 13 (file-size path))
412
413  (define i (open-input-file path))
414  (test #"abcdefxyzjkl!" (read-bytes 20 i))
415  (test (void) (file-position i 0))
416  (test #"abcdef" (read-bytes 6 i))
417  (test (void) (file-position i 9))
418  (test #"jkl!" (read-bytes 6 i))
419  (close-input-port i))
420
421(let ()
422  (define in (open-input-bytes #"hello"))
423  (test 0 (file-position in))
424  (test #"hel" (read-bytes 3 in))
425  (test 3 (file-position in))
426  (test (void) (file-position in 2))
427  (test #"llo" (read-bytes 3 in))
428  (test 5 (file-position in))
429  (test eof (read-bytes 3 in))
430  (test 5 (file-position in))
431  (test (void) (file-position in eof))
432  (test 5 (file-position in))
433  (test (void) (file-position in 100))
434  (test 100 (file-position in)))
435
436(let ()
437  (define out (open-output-bytes))
438  (test 0 (file-position out))
439  (write-bytes #"hello" out)
440  (test 5 (file-position out))
441  (test (void) (file-position out 1))
442  (test 1 (file-position out))
443  (write-bytes #"ola" out)
444  (test 4 (file-position out))
445  (test #"holao" (get-output-bytes out))
446  (write-bytes #"!!" out)
447  (test 6 (file-position out))
448  (test #"hola!!" (get-output-bytes out))
449  (test (void) (file-position out 10))
450  (test #"hola!!\0\0\0\0" (get-output-bytes out)))
451
452(let ()
453  (define-values (i o) (make-pipe))
454  (port-count-lines! i)
455  (port-count-lines! o)
456  (define (next-location p)
457    (define-values (line col pos) (port-next-location p))
458    (list line col pos))
459  (test '(1 0 1) (next-location i))
460  (test '(1 0 1) (next-location o))
461
462  (write-bytes #"a\n b" o)
463  (test '(2 2 5) (next-location o))
464
465  (test #"a" (read-bytes 1 i))
466  (test '(1 1 2) (next-location i))
467  (test #"\n" (read-bytes 1 i))
468  (test '(2 0 3) (next-location i))
469  (test #" b" (read-bytes 2 i))
470  (test '(2 2 5) (next-location i))
471
472  (write-bytes #"x\r" o)
473  (test '(3 0 7) (next-location o))
474  (write-bytes #"\n" o)
475  (test '(3 0 7) (next-location o))
476  (write-bytes #"!" o)
477  (test '(3 1 8) (next-location o))
478
479  (test #"x\r" (read-bytes 2 i))
480  (test '(3 0 7) (next-location i))
481  (test #"\n!" (read-bytes 2 i))
482  (test '(3 1 8) (next-location i)))
483
484;; ----------------------------------------
485
486(let ([c (bytes-open-converter "latin1" "UTF-8")])
487  (test '(#"A\302\200" 2 complete)
488        (call-with-values (lambda () (bytes-convert c #"A\200")) list))
489  (define bstr (make-bytes 3))
490  (test '(3 2 complete)
491        (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 bstr)) list))
492  (test #"A\302\200" bstr)
493  (test '(#"A" 1 continues)
494        (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 #f 0 2)) list))
495  (test '(#"A\302\200" 2 complete)
496        (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 #f 0 3)) list))
497  (test '(#"A" 1 complete)
498        (call-with-values (lambda () (bytes-convert c #"A\200" 0 1 #f 0 2)) list))
499  (test (void) (bytes-close-converter c)))
500
501(let ([c (bytes-open-converter "UTF-8" "latin1")])
502  (test '(#"A\200" 3 complete)
503        (call-with-values (lambda () (bytes-convert c #"A\302\200")) list))
504  (test '(#"A" 1 continues)
505        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list))
506  (test '(#"A\200" 3 complete)
507        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 2)) list))
508  (test '(#"A" 1 complete)
509        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list))
510  (test '(#"A" 1 aborts)
511        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list))
512  (test (void) (bytes-close-converter c)))
513
514(let ([c (bytes-open-converter "UTF-8" "UTF-8")])
515  (test '(#"A\302\200" 3 complete)
516        (call-with-values (lambda () (bytes-convert c #"A\302\200")) list))
517  (test '(#"A" 1 continues)
518        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list))
519  (test '(#"A\302\200" 3 complete)
520        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 3)) list))
521  (test '(#"A" 1 complete)
522        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list))
523  (test '(#"A" 1 aborts)
524        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list))
525  (test '(#"A" 1 error)
526        (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 3)) list))
527  (test '(#"A" 1 error)
528        (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 2)) list))
529  (test '(#"A" 1 continues)
530        (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 1)) list))
531  (test '(#"\360\220\220\200" 4 complete)
532        (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list))
533  (test (void) (bytes-close-converter c)))
534
535(let ([c (bytes-open-converter "UTF-8-permissive" "UTF-8")])
536  (test '(#"A\302\200" 3 complete)
537        (call-with-values (lambda () (bytes-convert c #"A\302\200")) list))
538  (test '(#"A" 1 continues)
539        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list))
540  (test '(#"A\302\200" 3 complete)
541        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 3)) list))
542  (test '(#"A" 1 complete)
543        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list))
544  (test '(#"A" 1 aborts)
545        (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list))
546  (test '(#"A" 1 continues)
547        (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 3)) list))
548  (test '(#"A\357\277\275" 2 continues)
549        (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 4)) list))
550  (test '(#"A\357\277\275" 2 aborts)
551        (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 5)) list))
552  (test '(#"A\357\277\275" 2 continues)
553        (call-with-values (lambda () (bytes-convert c #"A\302x" 0 3 #f 0 4)) list))
554  (test (void) (bytes-close-converter c)))
555
556(define (reorder little)
557  (if (system-big-endian?)
558      (let* ([len (bytes-length little)]
559             [bstr (make-bytes len)])
560        (for ([i (in-range len)])
561          (bytes-set! bstr i (bytes-ref little (bitwise-xor i 1)))))
562      little))
563
564(let ([c (bytes-open-converter "platform-UTF-8" "platform-UTF-16")])
565  (test `(,(reorder #"A\0\200\0") 3 complete)
566        (call-with-values (lambda () (bytes-convert c #"A\302\200")) list))
567  (test `(,(reorder #"A\0") 1 error)
568        (call-with-values (lambda () (bytes-convert c #"A\200")) list))
569  ;; unpaired high surrogate
570  (test `(#"" 0 error)
571        (call-with-values (lambda () (bytes-convert c #"\355\240\200")) list))
572  ;; unpaired low surrogate
573  (test `(#"" 0 error)
574        (call-with-values (lambda () (bytes-convert c #"\355\260\201")) list))
575  (test `(,(reorder #"\1\330\0\334") 4 complete)
576        (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list))
577  (test (void) (bytes-close-converter c)))
578
579(let ([c (bytes-open-converter "WTF-8" "WTF-16")])
580  (test `(,(reorder #"A\0\200\0") 3 complete)
581        (call-with-values (lambda () (bytes-convert c #"A\302\200")) list))
582  (test `(,(reorder #"A\0") 1 error)
583        (call-with-values (lambda () (bytes-convert c #"A\200")) list))
584  ;; unpaired high surrogate - incomplete because we have to watch for a low surrogate after
585  (test `(,(reorder #"") 0 aborts)
586        (call-with-values (lambda () (bytes-convert c #"\355\240\200")) list))
587  ;; unpaired low surrogate
588  (test `(,(reorder #"\1\334") 3 complete)
589        (call-with-values (lambda () (bytes-convert c #"\355\260\201")) list))
590  ;; surrogate pair where each is separately encoded, high before low
591  (test `(,(reorder #"") 0 error)
592        (call-with-values (lambda () (bytes-convert c #"\355\240\200\355\260\201")) list))
593  ;; surrogate pair where each is separately encoded, low before high
594  (test `(,(reorder #"\1\334") 3 aborts)
595        (call-with-values (lambda () (bytes-convert c #"\355\260\201\355\240\200")) list))
596  (test `(,(reorder #"\1\334\0\330x\0") 7 complete)
597        (call-with-values (lambda () (bytes-convert c #"\355\260\201\355\240\200x")) list))
598  ;; correctly encoded surrogate pair
599  (test `(,(reorder #"\1\330\0\334") 4 complete)
600        (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list))
601  (test (void) (bytes-close-converter c)))
602
603(let ([c (bytes-open-converter "WTF-16" "WTF-8")])
604  (test `(#"A\302\200" 4 complete)
605        (call-with-values (lambda () (bytes-convert c (reorder #"A\0\200\0"))) list))
606  ;; unpaired high surrogate
607  (test `(#"" 0 aborts)
608        (call-with-values (lambda () (bytes-convert c (reorder #"\0\330"))) list))
609  (test `(#"\355\240\200X" 4 complete)
610        (call-with-values (lambda () (bytes-convert c (reorder #"\0\330X\0"))) list))
611  ;; unpaired low surrogate
612  (test `(#"\355\260\201" 2 complete)
613        (call-with-values (lambda () (bytes-convert c (reorder #"\1\334"))) list))
614  (test `(#"\355\260\201X" 4 complete)
615        (call-with-values (lambda () (bytes-convert c (reorder #"\1\334X\0"))) list))
616  ;; surrogate pair
617  (test `(#"\360\220\200\201" 4 complete)
618        (call-with-values (lambda () (bytes-convert c (reorder #"\0\330\1\334"))) list))
619  (test (void) (bytes-close-converter c)))
620
621;; ----------------------------------------
622
623(parameterize ([current-locale "C"])
624  (test #"A*Z" (string->bytes/locale "A\u3BBZ" 42)))
625
626;; Latin-1
627(parameterize ([current-locale "en_US.ISO8859-1"])
628  (test #"!\xD6!" (string->bytes/locale "!\uD6!"))
629  (test "!\uD6!" (bytes->string/locale #"!\xD6!")))
630
631(parameterize ([current-locale "en_US.UTF-8"])
632  (test #f (string<? "Éric" "Dric")))
633(when (eq? 'unix (system-type))
634  (parameterize ([current-locale "fr_FR.ISO8859-1"])
635    (test #t (string-locale<? "Éric" "Dric"))))
636
637(test #t (string-locale<? "apple" "applex"))
638(test #f (string-locale=? "apple" "applex"))
639(test #f (string-locale>? "apple" "applex"))
640
641(test #t (string-locale<? "apple\0x" "apple\0y"))
642(test #f (string-locale=? "apple\0x" "apple\0y"))
643(test #f (string-locale>? "apple\0x" "apple\0y"))
644
645(test #t (string-locale-ci=? "apple" "AppLE"))
646(test #f (string-locale-ci=? "apple" "AppLEx"))
647
648(test #t (boolean? (string-locale<? "Apple" "apple")))
649(test #f (string-locale-ci<? "Apple" "apple"))
650
651(test #t (and (member (string-locale-downcase "Éric")
652                      '("éric" "Éric"))
653              #t))
654(when (eq? 'unix (system-type))
655  (parameterize ([current-locale "en_US.ISO8859-1"])
656    (test "Éric" (string-locale-downcase "Éric"))))
657
658(when (eq? 'macosx (system-type))
659  (test "\U1F600" (string-locale-downcase "\U1F600")))
660
661;; ----------------------------------------
662
663(define (print-test v expect #:print [print print])
664  (define o (open-output-string))
665  (parameterize ([current-output-port o])
666    (print v))
667  (test expect (get-output-string o)))
668
669(let ([b (box #f)])
670  (set-box! b b)
671  (print-test b "#0='#&#0#"))
672
673(let ([b (vector #f #f)])
674  (struct p (x y) #:transparent)
675  (struct c (x y) #:prefab)
676  (vector-set! b 0 b)
677  (vector-set! b 1 b)
678  (print-test b "#0='#(#0# #0#)")
679  (print-test '(1) "'(1)")
680  (print-test (cons 1 (cons 2 3)) "'(1 2 . 3)")
681  (print-test (cons 1 (mcons 3 4)) "(cons 1 (mcons 3 4))")
682  (print-test (cons 1 (cons 2 (mcons 3 4))) "(list* 1 2 (mcons 3 4))")
683  (print-test (cons 1 (cons (mcons 3 4) null)) "(list 1 (mcons 3 4))")
684  (print-test '('a) "'('a)")
685  (print-test '(4 . 'a) "'(4 . 'a)")
686  (print-test '(4 unquote a) "'(4 . ,a)")
687  (print-test '(4 unquote @a) "'(4 . , @a)")
688  (print-test '#(4 unquote a) "'#(4 unquote a)")
689  (print-test '((quote a b)) "'((quote a b))")
690  (print-test (p 1 2) "(p 1 2)")
691  (print-test (box (p 1 2)) "(box (p 1 2))")
692  (print-test (hasheq 1 (p 1 2) 2 'other) "(hasheq 1 (p 1 2) 2 'other)")
693  (print-test (arity-at-least 1) "(arity-at-least 1)")
694  (let ([v (make-placeholder #f)])
695    (placeholder-set! v (list (p 1 2) v))
696    (print-test (make-reader-graph v) "#0=(list (p 1 2) #0#)"))
697  (let ([v (make-placeholder #f)])
698    (placeholder-set! v (c (p 1 2) v))
699    (print-test (make-reader-graph v) "#0=(c (p 1 2) #0#)")))
700
701(let ([b (make-hash)])
702  (hash-set! b 'self b)
703  (print-test b "#0='#hash((self . #0#))"))
704
705(let ()
706  (struct a (x) #:mutable #:transparent)
707  (let ([an-a (a #f)])
708    (set-a-x! an-a an-a)
709    (print-test an-a "#0=(a #0#)")))
710
711(let ()
712  (struct a (x) #:mutable #:prefab)
713  (let ([an-a (a #f)])
714    (set-a-x! an-a an-a)
715    (print-test an-a "#0='#s((a #(0)) #0#)")))
716
717(let ()
718  (define p1 (cons 1 2))
719  (define p2 (cons p1 p1))
720  (print-test p2 "'((1 . 2) 1 . 2)")
721  (parameterize ([print-graph #t])
722    (print-test p2 "'(#0=(1 . 2) . #0#)")))
723
724(let ()
725  (define p1 (mcons 1 2))
726  (define p2 (mcons p1 p1))
727  (print-test p2 "(mcons (mcons 1 2) (mcons 1 2))")
728  (print-test p2 #:print write "{{1 . 2} 1 . 2}")
729  (parameterize ([print-graph #t])
730    (print-test p2 "(mcons #0=(mcons 1 2) #0#)"))
731  (print-test (mcons 1 null) "(mcons 1 '())")
732  (print-test (mcons 1 (mcons 2 null)) "(mcons 1 (mcons 2 '()))")
733  (print-test (mcons 1 null) "{1}" #:print write)
734  (print-test (mcons 1 (mcons 2 null)) "{1 2}" #:print write))
735
736(print-test '|hello world| "'|hello world|")
737(print-test '|1.0| "'|1.0|")
738(print-test '1\|2 "'1\\|2")
739(print-test '#:apple "'#:apple")
740(print-test '#:|apple pie| "'#:|apple pie|")
741(print-test '#:1.0 "'#:1.0")
742(print-test 1.0 "1.0")
743
744;; ----------------------------------------
745
746(define l (tcp-listen 59078 5 #t))
747(test #t (tcp-listener? l))
748(test #t (evt? l))
749
750(define-values (ti to) (tcp-connect "localhost" 59078))
751(test l (sync l))
752(define-values (tai tao) (tcp-accept l))
753
754(test #f (file-stream-port? ti))
755(test #f (file-stream-port? to))
756
757(test 6 (write-string "hello\n" to))
758(flush-output to)
759(test "hello" (read-line tai))
760
761(test 9 (write-string "goodbyte\n" tao))
762(flush-output tao)
763(test "goodbyte" (read-line ti))
764
765(close-output-port to)
766(close-output-port tao)
767(close-input-port ti)
768(close-input-port tai)
769
770(tcp-close l)
771
772;; ----------------------------------------
773
774(define u1 (udp-open-socket))
775(test (void) (udp-bind! u1 #f 10768))
776
777(define u2 (udp-open-socket))
778(test (void) (udp-send-to u2 "localhost" 10768 #"hello"))
779(let* ([bstr (make-bytes 10)]
780       [l (call-with-values (lambda () (udp-receive! u1 bstr)) list)])
781  (test 5 (car l))
782  (test #"hello" (subbytes bstr 0 5)))
783(test '(#f #f #f) (call-with-values (lambda () (udp-receive!* u1 (make-bytes 1))) list))
784
785;; ----------------------------------------
786
787(let ()
788  (define-values (sp o i e)
789    (subprocess (current-output-port)
790                (current-input-port)
791                (current-error-port)
792                "/bin/cat"))
793  (sleep 0.1)
794  (subprocess-kill sp #f)
795  (test sp (sync sp))
796  (test #t (positive? (subprocess-status sp))))
797
798(let ()
799  (define-values (sp o i e)
800    (subprocess (current-output-port)
801                (current-input-port)
802                (current-error-port)
803                "/bin/ls"))
804  (test sp (sync sp))
805  (test #t (zero? (subprocess-status sp))))
806
807(let ()
808  (define-values (sp o i e)
809    (subprocess #f
810                #f
811                (current-error-port)
812                "/bin/cat"))
813  (display "hello\n" i)
814  (flush-output i)
815  (test "hello" (read-line o))
816  (close-output-port i)
817  (test eof (read-line o))
818  (test (void) (subprocess-wait sp))
819  (test #t (zero? (subprocess-status sp))))
820
821;; ----------------------------------------
822
823(call-with-output-file "compiled/demo-file3" void 'replace)
824(define e (filesystem-change-evt "compiled/demo-file3" (lambda () 'no)))
825(unless (eq? e 'no)
826  (test #t (evt? e))
827  ;; (test #f (sync/timeout 0.01 e)) ; bootstrap doesn't handle this
828  (call-with-output-file "compiled/demo-file3" (lambda (o) (write-char #\x o)) 'append)
829  (test e (sync/timeout 0.01 e))
830  (test e (sync/timeout 0.01 e))
831  (filesystem-change-evt-cancel e))
832(delete-file "compiled/demo-file3")
833
834;; ----------------------------------------
835
836'read-string
837(time
838 (let loop ([j 10])
839   (unless (zero? j)
840     (let ()
841       (define p (open-input-file "../cs/schemified/io.scm"))
842       (port-count-lines! p)
843       (let loop ()
844         (define s (read-string 100 p))
845         (unless (eof-object? s)
846           (loop)))
847       (close-input-port p)
848       (loop (sub1 j))))))
849
850(define read-byte-buffer-mode 'block)
851(define count-lines? #t)
852
853'read-byte/host
854(time
855 (let loop ([j 10])
856   (unless (zero? j)
857     (let ()
858       (define p (host:open-input-file "../cs/schemified/io.scm"))
859       (host:file-stream-buffer-mode p read-byte-buffer-mode)
860       (when count-lines? (host:port-count-lines! p))
861       (let loop ()
862         (unless (eof-object? (host:read-byte p))
863           (loop)))
864       (host:close-input-port p)
865       (loop (sub1 j))))))
866
867'read-byte
868(time
869 (let loop ([j 10])
870   (unless (zero? j)
871     (let ()
872       (define p (open-input-file "../cs/schemified/io.scm"))
873       (file-stream-buffer-mode p read-byte-buffer-mode)
874       (when count-lines? (port-count-lines! p))
875       (let loop ()
876         (unless (eof-object? (read-byte p))
877           (loop)))
878       (close-input-port p)
879       (loop (sub1 j))))))
880
881'read-line/host
882(time
883 (let loop ([j 10])
884   (unless (zero? j)
885     (let ()
886       (define p (host:open-input-file "../cs/schemified/io.scm"))
887       (let loop ()
888         (unless (eof-object? (host:read-line p))
889           (loop)))
890       (host:close-input-port p)
891       (loop (sub1 j))))))
892
893'read-line
894(time
895 (let loop ([j 10])
896   (unless (zero? j)
897     (let ()
898       (define p (open-input-file "../cs/schemified/io.scm"))
899       (let loop ()
900         (unless (eof-object? (read-line p))
901           (loop)))
902       (close-input-port p)
903       (loop (sub1 j))))))
904
905'encoding
906(time
907 (for/fold ([v #f]) ([i (in-range 1000000)])
908   (bytes->string/utf-8 (string->bytes/utf-8 "ap\u3BBple"))))
909(time
910 (for/fold ([v #f]) ([i (in-range 1000000)])
911   (host:bytes->string/utf-8 (host:string->bytes/utf-8 "ap\u3BBple"))))
912
913(test "a" (read-line (open-input-string "a")))
914(test "a" (read-line (open-input-string "a\nb")))
915(test "a" (read-line (open-input-string "a\r\nb") 'any))
916(test "a" (read-line (open-input-string "a\rb") 'any))
917
918(test #\l (bytes-utf-8-ref #"apple" 3))
919(test #\λ (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 2))
920(test #\p (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 3))
921(test #\l (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 3 #\? 1))
922(test #f (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 6))
923
924(test 3 (bytes-utf-8-index #"apple" 3))
925(test 4 (bytes-utf-8-index (string->bytes/utf-8 "apλple") 3))
926
927(test 1969 (date-year (seconds->date (- (* 24 60 60)))))
928
929(let* ([s (current-seconds)]
930       [d1 (seconds->date s)]
931       [d2 (seconds->date (+ s 1/100000000))])
932  (test 0 (date*-nanosecond d1))
933  (test 10 (date*-nanosecond d2))
934  (test (date*-time-zone-name d1) (date*-time-zone-name d2))
935  (test (struct-copy date d1) (struct-copy date d2)))
936
937(test (seconds->date 0 #f)
938      (seconds->date 0.1e-16 #f))
939(test (date* 59 59 23 31 12 1969 3 364 #f 0 999999999 "UTC")
940      (seconds->date -0.1e-16 #f))
941
942(let ([out-of-range (lambda (exn) (regexp-match? #rx"out-of-range" (exn-message exn)))])
943  (test #t (with-handlers ([exn:fail? out-of-range])
944             (seconds->date (expt 2 60))))
945  (test #t (with-handlers ([exn:fail? out-of-range])
946             (seconds->date (expt 2 80)))))
947