108 lines
3.6 KiB
Scheme
108 lines
3.6 KiB
Scheme
|
|
; Test MzScheme's name inference
|
|
|
|
(load-relative "loadtest.ss")
|
|
|
|
(require scheme/class)
|
|
(require scheme/unit)
|
|
|
|
(Section 'names)
|
|
|
|
(arity-test object-name 1 1)
|
|
(test #f object-name 0)
|
|
(test #f object-name 'hello)
|
|
(test #f object-name "hi")
|
|
|
|
(define (src-name? s)
|
|
(and (symbol? s)
|
|
(regexp-match ":[0-9]+.[0-9]+$" (symbol->string s))
|
|
#t))
|
|
|
|
; Test ok when no name for proc
|
|
(test #t src-name? (object-name (lambda () 0)))
|
|
(test #t src-name? (object-name (case-lambda)))
|
|
(test #t src-name? (object-name (case-lambda [(x) 9])))
|
|
(test #t src-name? (object-name (case-lambda [(x) 9][(y z) 12])))
|
|
|
|
; Test constructs that don't provide a name
|
|
(test #t src-name? (object-name (let ([x (cons (lambda () 10) 0)]) (car x))))
|
|
(test #t src-name? (object-name (let ([x (let ([y (lambda (x) x)]) (y (lambda () 10)))]) x)))
|
|
|
|
; Test ok when name for proc
|
|
(define f (lambda () 0))
|
|
(define f2 (lambda (a) 0))
|
|
(define f3 (case-lambda))
|
|
(define f4 (case-lambda [(x) 9]))
|
|
(define f5 (case-lambda [(x) 9][(y z) 10]))
|
|
|
|
(test 'f object-name f)
|
|
(test 'f2 object-name f2)
|
|
(test 'f3 object-name f3)
|
|
(test 'f4 object-name f4)
|
|
(test 'f5 object-name f5)
|
|
|
|
; Test constructs that do provide a name
|
|
(test 'a object-name (let ([a (lambda () 0)]) a))
|
|
(test 'a object-name (let ([a (lambda () 0)]) (let ([b a]) b)))
|
|
(test 'b object-name (let* ([b (lambda () 0)]) b))
|
|
(test 'c object-name (letrec ([c (lambda () 0)]) c))
|
|
(test 'loop object-name (let loop () loop))
|
|
|
|
(test 'd object-name (let ([d (begin (lambda () x))]) d))
|
|
(test 'e object-name (let ([e (begin0 (lambda () x))]) e))
|
|
|
|
(test 'd2 object-name (let ([d2 (begin 7 (lambda () x))]) d2))
|
|
(test 'e2 object-name (let ([e2 (begin0 (lambda () x) 7)]) e2))
|
|
|
|
(test 'd3 object-name (let ([d3 (begin (cons 1 2) (lambda () x))]) d3))
|
|
(test 'e3 object-name (let ([e3 (begin0 (lambda () x) (cons 1 2))]) e3))
|
|
|
|
(test 'f object-name (let ([f (begin0 (begin (cons 1 2) (lambda () x)) (cons 1 2))]) f))
|
|
|
|
(test 'g1 object-name (let ([g1 (if (cons 1 2) (lambda () x) #f)]) g1))
|
|
(test 'g2 object-name (let ([g2 (if (negative? (car (cons 1 2))) #t (lambda () x))]) g2))
|
|
|
|
(test 'w object-name (let ([w (let ([x 5]) (lambda () x))]) w))
|
|
(test 'z object-name (let ([z (let ([x 5]) (cons 1 2) (lambda () x))]) z))
|
|
|
|
(set! f (lambda () 10))
|
|
(test 'f object-name f)
|
|
|
|
; Test class stuff ok when no name
|
|
(test #t src-name? (object-name (class object% (super-make-object))))
|
|
(test #t src-name? (object-name (interface ())))
|
|
|
|
; Test class stuff ok when name
|
|
(test 'class:c1 object-name (let ([c1 (class object% (super-make-object))]) c1))
|
|
(test 'interface:i1 object-name (let ([i1 (interface ())]) i1))
|
|
|
|
; Test unit stuff ok when no name
|
|
(test #t src-name? (object-name (unit (import) (export))))
|
|
(test #t src-name? (object-name (compound-unit (import) (link) (export))))
|
|
|
|
; Test unit stuff ok when name
|
|
(test 'unit:u1 object-name (let ([u1 (unit (import) (export))]) u1))
|
|
(test 'unit:u2 object-name (let ([u2 (compound-unit (import) (export) (link))]) u2))
|
|
|
|
(test 'x object-name (invoke-unit
|
|
(unit (import) (export) (define x (lambda () 0)) x)))
|
|
(define-signature x2^ (x2))
|
|
(test 'x2 object-name (invoke-unit
|
|
(unit (import) (export x2^) (define x2 (lambda () 0)) x2)))
|
|
|
|
;; Use external name instead?:
|
|
(define-signature x3^ (x3))
|
|
(test 'x object-name (invoke-unit
|
|
(unit (import) (export (rename x3^ [x x3])) (define x (lambda () 0)) x)))
|
|
|
|
; Test case sensitivity
|
|
(parameterize ([read-case-sensitive #t])
|
|
(test (string->symbol "Capital")
|
|
object-name
|
|
(eval (read (open-input-string "(let ([Capital (lambda () 10)]) Capital)"))))
|
|
(test (string->symbol "make-CP")
|
|
object-name
|
|
(eval (read (open-input-string "(let () (define-struct CP (a)) make-CP)")))))
|
|
|
|
(report-errs)
|