470 lines
12 KiB
Scheme
470 lines
12 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(SECTION 'parameters)
|
|
|
|
(let ([p (open-output-file "tmp5" 'replace)])
|
|
(display (compile '(cons 1 2)) p)
|
|
(close-output-port p))
|
|
|
|
(define-struct tester (x) (make-inspector))
|
|
(define a-tester (make-tester 5))
|
|
|
|
(define (check-write-string display v s)
|
|
(let ([p (open-output-string)])
|
|
(display v p)
|
|
(let ([s2 (get-output-string p)])
|
|
(or (string=? s s2)
|
|
(error 'check-string "strings didn't match: ~s vs. ~s"
|
|
s s2)))))
|
|
|
|
(define exn:check-string? exn:fail?)
|
|
|
|
(define called-break? #f)
|
|
|
|
(define erroring-set? #f)
|
|
|
|
(define erroring-port
|
|
(make-output-port 'errors
|
|
always-evt
|
|
(let ([orig (current-output-port)])
|
|
(lambda (s start end flush? breakable?)
|
|
(if erroring-set?
|
|
(begin
|
|
(set! erroring-set? #f)
|
|
(error 'output))
|
|
(display (subbytes s start end) orig))
|
|
(- end start)))
|
|
void))
|
|
|
|
(define erroring-eval
|
|
(let ([orig (current-eval)])
|
|
(lambda (x)
|
|
(if erroring-set?
|
|
(begin
|
|
(set! erroring-set? #f)
|
|
(error 'eval))
|
|
(orig x)))))
|
|
|
|
(define blocking-thread
|
|
(lambda (thunk)
|
|
(let ([x #f])
|
|
(thread-wait (thread (lambda () (set! x (thunk)))))
|
|
x)))
|
|
|
|
(define main-cust (current-custodian))
|
|
|
|
(define zero-arg-proc (lambda () #t))
|
|
(define one-arg-proc (lambda (x) #t))
|
|
(define two-arg-proc (lambda (x y) #t))
|
|
(define three-arg-proc (lambda (x y z) #t))
|
|
|
|
(define test-param1 (make-parameter 'one))
|
|
(define test-param2 (make-parameter
|
|
'two
|
|
; generates type error:
|
|
(lambda (x) (if (symbol? x)
|
|
x
|
|
(add1 'x)))))
|
|
(define test-param3 (make-parameter 'three list))
|
|
|
|
(test 'one test-param1)
|
|
(test 'two test-param2)
|
|
(test 'three test-param3)
|
|
|
|
(test-param2 'other-two)
|
|
(test 'other-two test-param2)
|
|
(test-param2 'two)
|
|
(test 'two test-param2)
|
|
(parameterize ([test-param2 'yet-another-two])
|
|
(test 'yet-another-two test-param2)
|
|
(parameterize ([test-param2 'yet-another-two!!])
|
|
(test 'yet-another-two!! test-param2))
|
|
(test-param2 'more-two?)
|
|
(test 'more-two? test-param2)
|
|
(parameterize ([test-param2 'yet-another-two!!!])
|
|
(test 'yet-another-two!!! test-param2)
|
|
(test-param2 'more-two??)
|
|
(test 'more-two?? test-param2))
|
|
(test 'more-two? test-param2))
|
|
(test 'two test-param2)
|
|
|
|
(test-param3 'other-three)
|
|
(test '(other-three) test-param3)
|
|
(test-param3 'three)
|
|
(test '(three) test-param3)
|
|
(parameterize ([test-param3 'yet-another-three])
|
|
(test '(yet-another-three) test-param3)
|
|
(parameterize ([test-param3 'yet-another-three!!])
|
|
(test '(yet-another-three!!) test-param3))
|
|
(test-param3 'more-three?)
|
|
(test '(more-three?) test-param3)
|
|
(parameterize ([test-param3 'yet-another-three!!!])
|
|
(test '(yet-another-three!!!) test-param3)
|
|
(test-param3 'more-three??)
|
|
(test '(more-three??) test-param3))
|
|
(test '(more-three?) test-param3))
|
|
(test '(three) test-param3)
|
|
|
|
(arity-test make-parameter 1 2)
|
|
(err/rt-test (make-parameter 0 zero-arg-proc))
|
|
(err/rt-test (make-parameter 0 two-arg-proc))
|
|
|
|
(define-struct bad-test (value exn?))
|
|
|
|
(define params (list
|
|
(list read-case-sensitive
|
|
(list #f #t)
|
|
'(if (eq? (read (open-input-string "HELLO")) (quote hello))
|
|
(void)
|
|
(error (quote hello)))
|
|
exn:fail?
|
|
#f)
|
|
(list read-square-bracket-as-paren
|
|
(list #t #f)
|
|
'(when (symbol? (read (open-input-string "[4]")))
|
|
(error 'read))
|
|
exn:fail?
|
|
#f)
|
|
(list read-curly-brace-as-paren
|
|
(list #t #f)
|
|
'(when (symbol? (read (open-input-string "{4}")))
|
|
(error 'read))
|
|
exn:fail?
|
|
#f)
|
|
(list read-accept-box
|
|
(list #t #f)
|
|
'(read (open-input-string "#&5"))
|
|
exn:fail:read?
|
|
#f)
|
|
(list read-accept-graph
|
|
(list #t #f)
|
|
'(read (open-input-string "#0=(1 . #0#)"))
|
|
exn:fail:read?
|
|
#f)
|
|
(list read-accept-compiled
|
|
(list #t #f)
|
|
'(let ([p (open-input-file "tmp5")])
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (void (read p)))
|
|
(lambda () (close-input-port p))))
|
|
exn:fail:read?
|
|
#f)
|
|
(list read-accept-bar-quote
|
|
(list #t #f)
|
|
'(let ([p (open-input-string "|hello #$ there| x")])
|
|
(read p)
|
|
(read p))
|
|
exn:fail:read?
|
|
#f)
|
|
(list read-accept-dot
|
|
(list #t #f)
|
|
'(let ([p (open-input-string "(1 . 2)")])
|
|
(read p))
|
|
exn:fail:read?
|
|
#f)
|
|
(list read-accept-quasiquote
|
|
(list #t #f)
|
|
'(let ([p (open-input-string "`1")])
|
|
(read p)
|
|
(read p))
|
|
exn:fail:read?
|
|
#f)
|
|
(list read-decimal-as-inexact
|
|
(list #f #t)
|
|
'(let ([p (open-input-string "1.0")])
|
|
(list-ref '(1 2) (read p)))
|
|
exn:application:type?
|
|
#f)
|
|
(list print-graph
|
|
(list #t #f)
|
|
'(check-write-string display (quote (#0=(1 2) . #0#)) "(#0=(1 2) . #0#)")
|
|
exn:check-string?
|
|
#f)
|
|
(list print-struct
|
|
(list #t #f)
|
|
'(check-write-string display a-tester "#(struct:tester 5)")
|
|
exn:check-string?
|
|
#f)
|
|
(list print-box
|
|
(list #t #f)
|
|
'(check-write-string display (box 5) "#&5")
|
|
exn:check-string?
|
|
#f)
|
|
(list print-vector-length
|
|
(list #t #f)
|
|
'(check-write-string write (vector 1 2 2) "#3(1 2)")
|
|
exn:check-string?
|
|
#f)
|
|
|
|
(list current-input-port
|
|
(list (make-input-port 'in (lambda (s) (bytes-set! s 0 (char->integer #\x)) 1) #f void)
|
|
(make-input-port 'in (lambda (s) (error 'bad)) #f void))
|
|
'(read-char)
|
|
exn:fail?
|
|
'("bad string"))
|
|
(list current-output-port
|
|
(list (current-output-port)
|
|
erroring-port)
|
|
'(begin
|
|
(set! erroring-set? #t)
|
|
(display 5)
|
|
(set! erroring-set? #f))
|
|
exn:fail?
|
|
'("bad string"))
|
|
|
|
#|
|
|
; Doesn't work since error-test sets the port!
|
|
(list current-error-port
|
|
(list (current-error-port)
|
|
erroring-port)
|
|
'(begin
|
|
(set! erroring-set? #t)
|
|
((error-display-handler) "hello")
|
|
(set! erroring-set? #f))
|
|
exn:fail?
|
|
"bad setting")
|
|
|#
|
|
|
|
(list compile-allow-set!-undefined
|
|
(list #t #f)
|
|
'(eval `(set! ,(gensym) 9))
|
|
exn:fail:contract:variable?
|
|
#f)
|
|
|
|
(list current-namespace
|
|
(list (make-namespace)
|
|
(make-namespace 'empty))
|
|
'(begin 0)
|
|
exn:fail:syntax?
|
|
'("bad setting"))
|
|
|
|
(list error-print-width
|
|
(list 10 50)
|
|
'(when (< 10 (error-print-width)) (error 'print-width))
|
|
exn:fail?
|
|
'("bad setting"))
|
|
(list error-value->string-handler
|
|
(list (error-value->string-handler) (lambda (x w) (error 'converter)))
|
|
'(format "~e" 10)
|
|
exn:fail?
|
|
(list "bad setting" zero-arg-proc one-arg-proc three-arg-proc))
|
|
|
|
(list current-print
|
|
(list (current-print)
|
|
(lambda (x) (display "frog")))
|
|
`(let ([i (open-input-string "5")]
|
|
[o (open-output-string)])
|
|
(parameterize ([current-input-port i]
|
|
[current-output-port o])
|
|
(read-eval-print-loop))
|
|
(let ([s (get-output-string o)])
|
|
(printf "**~a**~n" s)
|
|
(unless (char=? #\5 (string-ref s 2))
|
|
(error "print:" s))))
|
|
exn:fail?
|
|
(list "bad setting" zero-arg-proc two-arg-proc))
|
|
|
|
(list current-prompt-read
|
|
(list (current-prompt-read)
|
|
(let ([x #f])
|
|
(lambda ()
|
|
(set! x (not x))
|
|
(if x
|
|
'(quote hi)
|
|
eof))))
|
|
`(let ([i (open-input-string "5")]
|
|
[o (open-output-string)])
|
|
(parameterize ([current-input-port i]
|
|
[current-output-port o])
|
|
(read-eval-print-loop))
|
|
(let ([s (get-output-string o)])
|
|
(unless (and (char=? #\> (string-ref s 0))
|
|
(not (char=? #\h (string-ref s 0))))
|
|
(error 'prompt))))
|
|
exn:fail?
|
|
(list "bad setting" one-arg-proc two-arg-proc))
|
|
|
|
(list current-load
|
|
(list (current-load) (lambda (f e) (error "This won't do it")))
|
|
'(load "tmp5")
|
|
exn:fail?
|
|
(list "bad setting" zero-arg-proc one-arg-proc))
|
|
(list current-eval
|
|
(list (current-eval) erroring-eval)
|
|
'(begin
|
|
(set! erroring-set? #t)
|
|
(eval 5)
|
|
(set! erroring-set? #f))
|
|
exn:fail?
|
|
(list "bad setting" zero-arg-proc two-arg-proc))
|
|
|
|
(list current-load-relative-directory
|
|
(list (current-load-relative-directory)
|
|
(build-path (current-load-relative-directory) 'up))
|
|
'(load-relative "loadable.ss")
|
|
exn:fail:filesystem?
|
|
(append (list 0)
|
|
(map
|
|
(lambda (t)
|
|
(make-bad-test t exn:fail:contract?))
|
|
(list
|
|
"definitely a bad path"
|
|
(string #\a #\nul #\b)
|
|
"relative"
|
|
(build-path 'up))))
|
|
equal?)
|
|
|
|
(list global-port-print-handler
|
|
(list write display)
|
|
'(let ([s (open-output-string)])
|
|
(print "hi" s)
|
|
(unless (char=? #\" (string-ref (get-output-string s) 0))
|
|
(error 'global-port-print-handler)))
|
|
exn:fail?
|
|
(list "bad setting" zero-arg-proc one-arg-proc three-arg-proc))
|
|
|
|
(list current-custodian
|
|
(list main-cust (make-custodian))
|
|
'(let ([th (parameterize ([current-custodian main-cust])
|
|
(thread (lambda () (sleep 1))))])
|
|
(kill-thread th))
|
|
exn:application:mismatch?
|
|
(list "bad setting"))
|
|
|
|
(list exit-handler
|
|
(list void (lambda (x) (error 'exit-handler)))
|
|
'(exit)
|
|
exn:fail?
|
|
(list "bad setting" zero-arg-proc two-arg-proc))
|
|
|
|
(list test-param1
|
|
(list 'one 'bad-one)
|
|
'(when (eq? (test-param1) 'bad-one)
|
|
(error 'bad-one))
|
|
exn:fail?
|
|
#f)
|
|
(list test-param2
|
|
(list 'two 'bad-two)
|
|
'(when (eq? (test-param2) 'bad-two)
|
|
(error 'bad-two))
|
|
exn:fail?
|
|
'("bad string"))))
|
|
|
|
(for-each
|
|
(lambda (d)
|
|
(let ([param (car d)]
|
|
[alt1 (caadr d)]
|
|
[alt2 (cadadr d)]
|
|
[expr (caddr d)]
|
|
[exn? (cadddr d)])
|
|
(parameterize ([param alt1])
|
|
(test (void) void (teval expr)))
|
|
(parameterize ([param alt2])
|
|
(error-test (datum->syntax-object #f expr #f) exn?))))
|
|
params)
|
|
|
|
(define test-param3 (make-parameter 'hi))
|
|
(test 'hi test-param3)
|
|
(test 'hi 'thread-param
|
|
(let ([v #f])
|
|
(thread-wait (thread
|
|
(lambda ()
|
|
(set! v (test-param3)))))
|
|
v))
|
|
(test (void) test-param3 'bye)
|
|
(test 'bye test-param3)
|
|
(test 'bye 'thread-param
|
|
(let* ([v #f]
|
|
[r (make-semaphore)]
|
|
[s (make-semaphore)]
|
|
[t (thread
|
|
(lambda ()
|
|
(semaphore-post r)
|
|
(semaphore-wait s)
|
|
(set! v (test-param3))))])
|
|
(semaphore-wait r)
|
|
(test-param3 'bye-again)
|
|
(semaphore-post s)
|
|
(thread-wait t)
|
|
v))
|
|
(test 'bye-again test-param3)
|
|
|
|
(test #f parameter? add1)
|
|
|
|
(for-each
|
|
(lambda (d)
|
|
(let* ([param (car d)]
|
|
[alt1 (caadr d)]
|
|
[bads (cadddr (cdr d))])
|
|
(test #t parameter? param)
|
|
(arity-test param 0 1)
|
|
(when bads
|
|
(for-each
|
|
(lambda (bad)
|
|
(let-values ([(bad exn?)
|
|
(if (bad-test? bad)
|
|
(values (bad-test-value bad)
|
|
(bad-test-exn? bad))
|
|
(values bad
|
|
exn:application:type?))])
|
|
(err/rt-test (param bad) exn?)))
|
|
bads))))
|
|
params)
|
|
|
|
(test #t parameter-procedure=? read-accept-compiled read-accept-compiled)
|
|
(test #f parameter-procedure=? read-accept-compiled read-case-sensitive)
|
|
(err/rt-test (parameter-procedure=? read-accept-compiled 5))
|
|
(err/rt-test (parameter-procedure=? 5 read-accept-compiled))
|
|
(arity-test parameter-procedure=? 2 2)
|
|
(arity-test parameter? 1 1)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(let ([ch (make-channel)]
|
|
[k-ch (make-channel)]
|
|
[p1 (make-parameter 1)]
|
|
[p2 (make-parameter 2)])
|
|
(parameterize ([p1 0])
|
|
(thread (lambda ()
|
|
(channel-put ch (cons (p1) (p2))))))
|
|
(test '(0 . 2) channel-get ch)
|
|
|
|
(let ([send-k
|
|
(lambda ()
|
|
(parameterize ([p1 0])
|
|
(thread (lambda ()
|
|
(let/ec esc
|
|
(channel-put ch
|
|
((let/cc k
|
|
(channel-put k-ch k)
|
|
(esc)))))))))])
|
|
(send-k)
|
|
(thread (lambda () ((channel-get k-ch) (let ([v (p1)]) (lambda () v)))))
|
|
(test 1 channel-get ch)
|
|
(send-k)
|
|
(thread (lambda () ((channel-get k-ch) p1)))
|
|
(test 0 channel-get ch))
|
|
|
|
(let ([send-k-param-in-thread
|
|
(lambda ()
|
|
(thread (lambda ()
|
|
(parameterize ([p1 3])
|
|
(let/ec esc
|
|
(channel-put ch
|
|
((let/cc k
|
|
(channel-put k-ch k)
|
|
(esc)))))))))])
|
|
(send-k-param-in-thread)
|
|
(thread (lambda () ((channel-get k-ch) (let ([v (p1)]) (lambda () v)))))
|
|
(test 1 channel-get ch)
|
|
(send-k-param-in-thread)
|
|
(thread (lambda () ((channel-get k-ch) p1)))
|
|
(test 3 channel-get ch)))
|
|
|
|
; Test current-library-collection-paths?
|
|
; Test require-library-use-compiled?
|
|
|
|
(report-errs)
|