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='#�#")) 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