These tests are so outdated, that if they ever get put back, they'll have
to change almost completely anyway. Jettison the whole mess. svn: r16454
This commit is contained in:
Stevie Strickland
parent
653d0ccd66
commit
cf78f9173c
|
|
@ -1,331 +0,0 @@
|
|||
(require (for-syntax mzlib/private/unit-compiletime
|
||||
mzlib/private/unit-syntax))
|
||||
(require "test-harness.ss"
|
||||
mzlib/private/unit-compiletime
|
||||
mzlib/private/unit-keywords
|
||||
mzlib/private/unit-syntax)
|
||||
|
||||
|
||||
;; split-requires
|
||||
;; UNTESTED
|
||||
|
||||
;; build-siginfo + siginfo-subtype
|
||||
(test #t (siginfo-subtype (make-siginfo '(n1 n2 n3) '(c1 c2 c3) (syntax->list #'(r1 r2 r3)))
|
||||
(make-siginfo '(n1 n2 n3) '(c1 c2 c3) (syntax->list #'(r1 r2 r3)))))
|
||||
(test #t (siginfo-subtype (make-siginfo '(n1 n2 n3) '(c1 c2 c3) (syntax->list #'(r1 r2 r3)))
|
||||
(make-siginfo '(n2 n3) '(c2 c3) (syntax->list #'(r2 r3)))))
|
||||
(test #f (siginfo-subtype (make-siginfo '(n2 n3) '(c2 c3) (syntax->list #'(r2 r3)))
|
||||
(make-siginfo '(n1 n2 n3) '(c1 c2 c3) (syntax->list #'(r1 r2 r3)))))
|
||||
|
||||
|
||||
;; signature-proc
|
||||
(test-syntax-error "illegal use of signature name"
|
||||
(let ()
|
||||
(define-syntax x (make-signature 1 2 3 4))
|
||||
x))
|
||||
(test-syntax-error "illegal use of signature name"
|
||||
(let ()
|
||||
(define-syntax x (make-signature 1 2 3 4))
|
||||
(x 1)))
|
||||
|
||||
;; signature-form-proc
|
||||
(test-syntax-error "illegal use of signature form"
|
||||
(let ()
|
||||
(define-syntax x (make-signature-form 1))
|
||||
x))
|
||||
(test-syntax-error "illegal use of signature form"
|
||||
(let ()
|
||||
(define-syntax x (make-signature-form 1))
|
||||
(x 1)))
|
||||
|
||||
;; unit-info-proc
|
||||
(test '1
|
||||
(let ()
|
||||
(define x 1)
|
||||
(define-syntax y (make-unit-info #'x null null null))
|
||||
y))
|
||||
(test 2
|
||||
(let ()
|
||||
(define x +)
|
||||
(define-syntax y (make-unit-info #'x null null null))
|
||||
(y 1 1)))
|
||||
(test-runtime-error exn:fail:contract? "not a unit"
|
||||
(let ()
|
||||
(define x +)
|
||||
(define-syntax y (make-set!-transformer (make-unit-info #'x null null null)))
|
||||
(set! y 1)))
|
||||
|
||||
;; lookup-signature
|
||||
(define-syntax (lookup-sig-mac stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
((_ id)
|
||||
#`#,(signature-siginfo (lookup-signature #'id))))))
|
||||
(test-syntax-error "lookup-signature: not id"
|
||||
(lookup-sig-mac 1))
|
||||
(test-syntax-error "lookup-signature: unbound id"
|
||||
(lookup-sig-mac s))
|
||||
(test-syntax-error "lookup-signature: not a sig"
|
||||
(lookup-sig-mac lookup-sig-mac))
|
||||
(let ()
|
||||
(define-syntax x (make-signature 1 2 3 4))
|
||||
(test 1 (lookup-sig-mac x)))
|
||||
|
||||
;; process-import
|
||||
(define-syntax (process-import-mac-sig stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
((_ x)
|
||||
#`#'#,(caddr (process-tagged-import #'x))))))
|
||||
(define-for-syntax si (make-siginfo '(test-sig) '(ct) (list #'rt)))
|
||||
(define-syntax test-sig (make-signature si
|
||||
(list #'x #'y)
|
||||
(list (cons (list #'v1 #'v2) #'body1)
|
||||
(cons (list #'v3 #'v4) #'body2))
|
||||
(list (cons (list #'s1 #'s2) #'body3)
|
||||
(cons (list #'s3 #'s4) #'body4))))
|
||||
|
||||
(test stx-bound-id=? #'(((x . x) (y . y))
|
||||
((((v1 . v1) (v2 . v2)) . body1)
|
||||
(((v3 . v3) (v4 . v4)) . body2))
|
||||
((((s1 . s1) (s2 . s2)) . body3)
|
||||
(((s3 . s3) (s4 . s4)) . body4)))
|
||||
(process-import-mac-sig test-sig))
|
||||
(let ()
|
||||
(define-syntax ts (make-signature 1 (list #'x) null null))
|
||||
(define x-stx #'x)
|
||||
(let ((x 1))
|
||||
(test stx-bound-id=? #`(((x . #,x-stx)) () ())
|
||||
(process-import-mac-sig ts))))
|
||||
(let ()
|
||||
(define-syntax ts (make-signature 1 null (list (cons (list #'v1 #'v2) #'body1)) null))
|
||||
(define v2-stx #'v2)
|
||||
(let ((v2 1))
|
||||
(test stx-bound-id=? #`(() ((((v1 . v1) (v2 . #,v2-stx)) . body1)) ())
|
||||
(process-import-mac-sig ts))))
|
||||
(let ()
|
||||
(define-syntax ts (make-signature 1 null null (list (cons (list #'s1 #'s2) #'body3))))
|
||||
(define s1-stx #'s1)
|
||||
(let ((s1 1))
|
||||
(test stx-bound-id=? #`(() () ((((s1 . #,s1-stx) (s2 . s2)) . body3)))
|
||||
(process-import-mac-sig ts))))
|
||||
(let ((b 1))
|
||||
(define-syntax test-sig2 (make-signature 1 null (list (cons (list #'v5) #'b)) null))
|
||||
(test stx-bound-id=? #'(()
|
||||
((((v5 . v5)) . b))
|
||||
())
|
||||
(let ((b 1)) (process-import-mac-sig test-sig2))))
|
||||
(let ((b 2))
|
||||
(define-syntax test-sig2 (make-signature 1 null (list (cons (list #'v5) #'b)) null))
|
||||
(test stx-bound-id=? #'(()
|
||||
((((v5 . v5)) . b))
|
||||
())
|
||||
(let ((b 3)) (process-import-mac-sig test-sig2))))
|
||||
|
||||
(test-syntax-error "process-import: only, id not in spec"
|
||||
(process-import-mac (only test-sig x z)))
|
||||
(test stx-bound-id=? #'(((x . x) ((#f . y) . y))
|
||||
(((((#f . v1) . v1) (v2 . v2)) . body1)
|
||||
((((#f . v3) . v3) ((#f . v4) . v4)) . body2))
|
||||
((((s1 . s1) ((#f . s2) . s2)) . body3)
|
||||
((((#f . s3) . s3) ((#f . s4) . s4)) . body4)))
|
||||
(process-import-mac-sig (only test-sig x v2 s1)))
|
||||
|
||||
(test-syntax-error "process-import: except, id not in spec"
|
||||
(process-import-mac (except test-sig x z)))
|
||||
(test stx-bound-id=? #'(((x . x) ((#f . y) . y))
|
||||
(((((#f . v1) . v1) (v2 . v2)) . body1)
|
||||
((((#f . v3) . v3) ((#f . v4) . v4)) . body2))
|
||||
((((s1 . s1) ((#f . s2) . s2)) . body3)
|
||||
((((#f . s3) . s3) ((#f . s4) . s4)) . body4)))
|
||||
(process-import-mac-sig (except test-sig y v1 v3 v4 s2 s3 s4)))
|
||||
|
||||
(test stx-bound-id=? #'(((u:x . x) (u:y . y))
|
||||
((((u:v1 . v1) (u:v2 . v2)) . body1)
|
||||
(((u:v3 . v3) (u:v4 . v4)) . body2))
|
||||
((((u:s1 . s1) (u:s2 . s2)) . body3)
|
||||
(((u:s3 . s3) (u:s4 . s4)) . body4)))
|
||||
(process-import-mac-sig (prefix u: test-sig)))
|
||||
|
||||
(test-syntax-error "process-import: rename clause id not in spec"
|
||||
(process-import-mac (rename test-sig (z a))))
|
||||
(test-syntax-error "process-import-mac: rename clash"
|
||||
(process-import-mac (rename test-sig (y x))))
|
||||
(test-syntax-error "process-import-mac: rename clash"
|
||||
(process-import-mac (rename test-sig (s1 v1))))
|
||||
(test-syntax-error "process-import-mac: rename clash"
|
||||
(process-import-mac (rename test-sig (x v1))))
|
||||
(test-syntax-error "process-import-mac: rename clash"
|
||||
(process-import-mac (rename test-sig (v3 x))))
|
||||
(test-syntax-error "process-import-mac: rename clash"
|
||||
(process-import-mac (rename test-sig (s4 x))))
|
||||
(test-syntax-error "process-import-mac: rename clash"
|
||||
(process-import-mac (rename test-sig (y s3))))
|
||||
(test-syntax-error "process-import-mac: rename clash"
|
||||
(process-import-mac (rename test-sig (v2 s3))))
|
||||
(test-syntax-error "process-import-mac: rename, duplicate"
|
||||
(process-import-mac (rename test-sig (a x) (b x))))
|
||||
(test-syntax-error "process-import-mac: rename, duplicate"
|
||||
(process-import-mac (rename test-sig (a s1) (b s1))))
|
||||
(test-syntax-error "process-import-mac: rename, duplicate"
|
||||
(process-import-mac (rename test-sig (a v2) (b v2))))
|
||||
(test stx-bound-id=? #'(((x . x) (a . y))
|
||||
((((b . v1) (v2 . v2)) . body1)
|
||||
(((v3 . v3) (v4 . v4)) . body2))
|
||||
((((s1 . s1) (c . s2)) . body3)
|
||||
(((s3 . s3) (s4 . s4)) . body4)))
|
||||
(process-import-mac-sig (rename test-sig (a y) (b v1) (c s2))))
|
||||
|
||||
;; process-export
|
||||
(define-syntax (process-export-mac stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
((_ x)
|
||||
#`#'#,(caddr (process-tagged-export #'x))))))
|
||||
|
||||
(test-syntax-error "process-export: malformed"
|
||||
(process-export-mac (x y)))
|
||||
(test-syntax-error "process-export: dot"
|
||||
(process-export-mac (x . y)))
|
||||
(test-syntax-error "process-export: not id"
|
||||
(process-export-mac 1))
|
||||
(test stx-bound-id=? #'(((x . x) (y . y))
|
||||
((((v1 . v1) (v2 . v2)) . body1)
|
||||
(((v3 . v3) (v4 . v4)) . body2))
|
||||
((((s1 . s1) (s2 . s2)) . body3)
|
||||
(((s3 . s3) (s4 . s4)) . body4)))
|
||||
(process-export-mac test-sig))
|
||||
(let ()
|
||||
(define-syntax ts (make-signature 1 (list #'x) null null))
|
||||
(define x-stx #'x)
|
||||
(let ((x 1))
|
||||
(test stx-bound-id=? #`(((x . #,x-stx)) () ())
|
||||
(process-export-mac ts))))
|
||||
(let ()
|
||||
(define-syntax ts (make-signature 1 null (list (cons (list #'v1 #'v2) #'body1)) null))
|
||||
(define v2-stx #'v2)
|
||||
(let ((v2 1))
|
||||
(test stx-bound-id=? #`(() ((((v1 . v1) (v2 . #,v2-stx)) . body1)) ())
|
||||
(process-export-mac ts))))
|
||||
(let ()
|
||||
(define-syntax ts (make-signature 1 null null (list (cons (list #'s1 #'s2) #'body3))))
|
||||
(define s1-stx #'s1)
|
||||
(let ((s1 1))
|
||||
(test stx-bound-id=? #`(() () ((((s1 . #,s1-stx) (s2 . s2)) . body3)))
|
||||
(process-export-mac ts))))
|
||||
|
||||
(test stx-bound-id=? #'(((u:x . x) (u:y . y))
|
||||
((((u:v1 . v1) (u:v2 . v2)) . body1)
|
||||
(((u:v3 . v3) (u:v4 . v4)) . body2))
|
||||
((((u:s1 . s1) (u:s2 . s2)) . body3)
|
||||
(((u:s3 . s3) (u:s4 . s4)) . body4)))
|
||||
(process-export-mac (prefix u: test-sig)))
|
||||
|
||||
(test-syntax-error "process-export: rename clause id not in spec"
|
||||
(process-export-mac (rename test-sig (z a))))
|
||||
(test-syntax-error "process-export-mac: rename, duplicate"
|
||||
(process-export-mac (rename test-sig (a x) (b x))))
|
||||
(test stx-bound-id=? #'(((x . x) (a . y))
|
||||
((((b . v1) (v2 . v2)) . body1)
|
||||
(((v3 . v3) (v4 . v4)) . body2))
|
||||
((((s1 . s1) (c . s2)) . body3)
|
||||
(((s3 . s3) (s4 . s4)) . body4)))
|
||||
(process-export-mac (rename test-sig (a y) (b v1) (c s2))))
|
||||
|
||||
;;
|
||||
|
||||
|
||||
(define-syntax (extract-sig-runtime-macro stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
((_ x)
|
||||
#`#'#,(syntax-local-introduce (car (siginfo-rtime-ids (signature-siginfo (lookup-signature #'x)))))))))
|
||||
|
||||
(test bound-identifier=? #'rt
|
||||
(extract-sig-runtime-macro test-sig))
|
||||
|
||||
;; Complete-exports
|
||||
(define s1 (make-siginfo '(a1 a2) '(c1 c2) ()))
|
||||
(define s2 (make-siginfo '(b1 b2) '(c3 c2) ()))
|
||||
(define s3 (make-siginfo '(b1 b2) '(c3 c2) ()))
|
||||
(define s4 (make-siginfo '(c1 c2) '(c5 c4) ()))
|
||||
(define s5 (make-siginfo '(d) '(c4) ()))
|
||||
(define e1 (make-link-record #f #f #'a s1))
|
||||
(define e2 (make-link-record #f #f #'b s2))
|
||||
(define e3 (make-link-record 't #f #'b s3))
|
||||
(define e4 (make-link-record 't #f #'c s4))
|
||||
(define e5 (make-link-record 't #f #'d s5))
|
||||
(define unit-exports (list e1 e2 e3 e4))
|
||||
|
||||
(define (add-lnkid l lr)
|
||||
(make-link-record (link-record-tag lr) l (link-record-sigid lr) (link-record-siginfo lr)))
|
||||
|
||||
(define (lnk-comp lr1 lr2)
|
||||
(andmap
|
||||
(λ (lr1 lr2)
|
||||
(and (eq? (link-record-tag lr1) (link-record-tag lr2))
|
||||
(bound-identifier=? (link-record-sigid lr1) (link-record-sigid lr2))
|
||||
(eq? (link-record-siginfo lr1) (link-record-siginfo lr2))
|
||||
(if (and (link-record-linkid lr1) (link-record-linkid lr2))
|
||||
(equal? (link-record-linkid lr1) (link-record-linkid lr2))
|
||||
#t)))
|
||||
lr1
|
||||
lr2))
|
||||
|
||||
(test lnk-comp unit-exports
|
||||
(complete-exports unit-exports '()))
|
||||
|
||||
(test lnk-comp (map add-lnkid '(4 3 2 1) unit-exports)
|
||||
(complete-exports unit-exports (map add-lnkid '(1 2 3 4) (reverse unit-exports))))
|
||||
|
||||
(let ([r (complete-exports unit-exports (list (add-lnkid 1 e2) (add-lnkid 2 e3)))])
|
||||
(test lnk-comp unit-exports r))
|
||||
|
||||
(let ([r (complete-exports unit-exports (list (add-lnkid 1 e5)))])
|
||||
(test lnk-comp unit-exports r))
|
||||
|
||||
(parameterize ([error-syntax #'complete-exports])
|
||||
|
||||
(test-runtime-error exn:fail:syntax? "complete-exports: duplicate bindings"
|
||||
(complete-exports unit-exports (list (add-lnkid 1 e2) (add-lnkid 2 e3) (add-lnkid 3 e2))))
|
||||
|
||||
(test-runtime-error exn:fail:syntax? "complete-exports: duplicate bindings"
|
||||
(complete-exports unit-exports (list (add-lnkid 1 e4) (add-lnkid 2 e5))))
|
||||
|
||||
(test-runtime-error exn:fail:syntax? "complete-exports: invalid link"
|
||||
(complete-exports unit-exports (list (make-link-record #f 1 #'z (make-siginfo 'z '(c9) ())))))
|
||||
|
||||
(test-runtime-error exn:fail:syntax? "complete-exports: ambiguous links"
|
||||
(complete-exports unit-exports (list (make-link-record #f 1 #'z (make-siginfo 'z '(c2) ()))))))
|
||||
|
||||
|
||||
(define unit-imports (cons e5 unit-exports))
|
||||
|
||||
(define sig-table
|
||||
(make-immutable-hash-table `((c1 . duplicate)
|
||||
(c2 . 1)
|
||||
(c3 . 2))))
|
||||
|
||||
(test lnk-comp `(,(add-lnkid 3 e4) ,(add-lnkid 4 e1) ,(add-lnkid 2 e2) ,(add-lnkid 2 e3))
|
||||
(complete-imports sig-table `(,(add-lnkid 3 e4) ,(add-lnkid 4 e1)) unit-imports #'stx))
|
||||
|
||||
(test lnk-comp `(,(add-lnkid 3 e4) ,(add-lnkid 4 e1) ,(add-lnkid 5 e2) ,(add-lnkid 2 e3))
|
||||
(complete-imports sig-table `(,(add-lnkid 3 e4) ,(add-lnkid 4 e1) ,(add-lnkid 5 e2)) unit-imports #'stx))
|
||||
|
||||
(test lnk-comp `(,(add-lnkid 3 e4) ,(add-lnkid 4 e1) ,(add-lnkid 5 e3) ,(add-lnkid 2 e2))
|
||||
(complete-imports sig-table `(,(add-lnkid 3 e4) ,(add-lnkid 4 e1) ,(add-lnkid 5 e3)) unit-imports #'stx))
|
||||
|
||||
(parameterize ([error-syntax #'complete-imports])
|
||||
|
||||
(test-runtime-error exn:fail:syntax? "complete-imports: ambiguous"
|
||||
(complete-imports sig-table `(,(add-lnkid 3 e4)) unit-imports #'stx))
|
||||
|
||||
(test-runtime-error exn:fail:syntax? "complete-imports: missing"
|
||||
(complete-imports sig-table `(,(add-lnkid 4 e1)) unit-imports #'stx))
|
||||
|
||||
(test-runtime-error exn:fail:syntax? "complete-imports: duplicate"
|
||||
(complete-imports sig-table
|
||||
`(,(add-lnkid 4 e1) ,(add-lnkid 5 e2))
|
||||
`(,(make-link-record #f #f #'e (make-siginfo '(a2) '(c2) ())))
|
||||
#'stx))
|
||||
)
|
||||
|
|
@ -1,292 +0,0 @@
|
|||
(require "test-harness.ss"
|
||||
;unit-syntax
|
||||
mzlib/private/unit-syntax
|
||||
)
|
||||
|
||||
;; check-id
|
||||
(parameterize ([error-syntax #'check-id])
|
||||
(test-runtime-error exn:fail:syntax? "check-id: not id"
|
||||
(check-id #'1))
|
||||
(test-runtime-error exn:fail:syntax? "check-id: not id"
|
||||
(check-id #'(x y)))
|
||||
(test bound-identifier=? #'x (check-id #'x)))
|
||||
|
||||
;; checked-syntax->list
|
||||
(parameterize ([error-syntax #'checked-syntax->list])
|
||||
(test-runtime-error exn:fail:syntax? "checked-syntax->list: dot"
|
||||
(checked-syntax->list #'(a b . c)))
|
||||
(test-runtime-error exn:fail:syntax? "checked-syntax->list: not list"
|
||||
(checked-syntax->list #'a))
|
||||
(test lst-bound-id=? (list #'a #'b #'c)
|
||||
(checked-syntax->list #'(a b c)))
|
||||
(test '()
|
||||
(checked-syntax->list #'())))
|
||||
|
||||
;; checked-tag
|
||||
(parameterize([error-syntax #'check-tagged])
|
||||
(test-runtime-error exn:fail:syntax? "check-tagged: missing all"
|
||||
((check-tagged (λ (x) x)) #'(tag)))
|
||||
(test-runtime-error exn:fail:syntax? "check-tagged: missing syntax"
|
||||
((check-tagged (λ (x) x)) #'(tag a)))
|
||||
(test-runtime-error exn:fail:syntax? "check-tagged: too much"
|
||||
((check-tagged (λ (x) x)) #'(tag a b c)))
|
||||
(test-runtime-error exn:fail:syntax? "check-tagged: dot"
|
||||
((check-tagged (λ (x) x)) #'(tag a . c)))
|
||||
(test-runtime-error exn:fail:syntax? "check-tagged: bad id"
|
||||
((check-tagged (λ (x) x)) #'(tag 1 c)))
|
||||
(test stx-bound-identifier=? #'c
|
||||
(cdr ((check-tagged (λ (x) x)) #'(tag b c))))
|
||||
(test 'b
|
||||
(car ((check-tagged (λ (x) x)) #'(tag b c))))
|
||||
(test #f
|
||||
(car ((check-tagged (λ (x) x)) #'1)))
|
||||
(test 1
|
||||
(syntax-e (cdr ((check-tagged (λ (x) x)) #'1)))))
|
||||
|
||||
;; check-:-clause-syntax
|
||||
(parameterize ((error-syntax #'check-:-clause-syntax))
|
||||
(test-runtime-error exn:fail:syntax? "check-:-clause-syntax: malformed"
|
||||
(check-:-clause-syntax #'x))
|
||||
(test-runtime-error exn:fail:syntax? "check-:-clause-syntax: malformed"
|
||||
(check-:-clause-syntax #'(x y)))
|
||||
(test-runtime-error exn:fail:syntax? "check-:-clause-syntax: malformed"
|
||||
(check-:-clause-syntax #'(x y z)))
|
||||
(test-runtime-error exn:fail:syntax? "check-:-clause-syntax: dot"
|
||||
(check-:-clause-syntax #'(x : . z)))
|
||||
(test-runtime-error exn:fail:syntax? "check-:-clause-syntax: malformed"
|
||||
(check-:-clause-syntax #'(x : z a)))
|
||||
|
||||
(test lst-bound-id=? (list #'a #'b)
|
||||
(list (car (check-:-clause-syntax #'(a : b)))
|
||||
(cdr (check-:-clause-syntax #'(a : b)))))
|
||||
)
|
||||
|
||||
;; check-spec-syntax
|
||||
(parameterize ((error-syntax #'check-spec-syntax))
|
||||
(define (css x) (check-spec-syntax x #t identifier?))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: unknown keyword"
|
||||
(css #'(x y)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: dot"
|
||||
(css #'(x . y)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: not id"
|
||||
(css #'1))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: not id"
|
||||
(css #'(only 1)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: not id"
|
||||
(css #'(except 1)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: not id"
|
||||
(css #'(rename 1)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: not id"
|
||||
(css #'(prefix x 1)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: only, no args"
|
||||
(css #'(only)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: only, arg not id"
|
||||
(css #'(only test-sig 1)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: only, dot"
|
||||
(css #'(only . test-sig)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: only, dot"
|
||||
(css #'(only test-sig x . y)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: except, no args"
|
||||
(css #'(except)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: except, arg not id"
|
||||
(css #'(except test-sig 1)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: except, dot"
|
||||
(css #'(except . test-sig)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: except, dot"
|
||||
(css #'(except test-sig x . y)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: prefix, no args"
|
||||
(css #'(prefix)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: prefix, one arg"
|
||||
(css #'(prefix a)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: prefix, dot"
|
||||
(css #'(prefix a . b)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: prefix, too many args"
|
||||
(css #'(prefix a b c)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename, no args"
|
||||
(css #'(rename)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename, dot"
|
||||
(css #'(rename . test-sig)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename, dot"
|
||||
(css #'(rename test-sig . (a x))))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename clause, length"
|
||||
(css #'(rename test-sig (x))))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename clause, length"
|
||||
(css #'(rename test-sig (a b x))))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename clause, dot"
|
||||
(css #'(rename test-sig (a . x))))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename clause, dot"
|
||||
(css #'(rename test-sig (a x) (a . x))))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename clause, id"
|
||||
(css #'(rename test-sig (1 x))))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: rename clause, id"
|
||||
(css #'(rename test-sig (a 1))))
|
||||
(test (void)
|
||||
(css #'(prefix x (except (rename (only y))))))
|
||||
(test (void)
|
||||
(css #'(only (except (rename (prefix x y) (a b) (c d)) e f g) h i j)))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: bad keyword"
|
||||
(check-spec-syntax #'(only x) #f identifier?))
|
||||
(test-runtime-error exn:fail:syntax? "check-spec-syntax: bad keyword"
|
||||
(check-spec-syntax #'(except x) #f identifier?))
|
||||
)
|
||||
|
||||
;; check-unit-syntax
|
||||
(parameterize ((error-syntax #'check-unit-syntax))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: no import or export"
|
||||
(check-unit-syntax #'()))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: bad import"
|
||||
(check-unit-syntax #'((export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: bad import"
|
||||
(check-unit-syntax #'((impor) (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: bad import"
|
||||
(check-unit-syntax #'(import (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: no export"
|
||||
(check-unit-syntax #'((import))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: bad export"
|
||||
(check-unit-syntax #'((import) (expor))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: bad export"
|
||||
(check-unit-syntax #'((import) export)))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: malformed body (dot)"
|
||||
(check-unit-syntax #'((import) (export) 1 . 2)))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: malformed import (dot)"
|
||||
(check-unit-syntax #'((import . a) (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: malformed export (dot)"
|
||||
(check-unit-syntax #'((import) (export . a))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-syntax: malformed init-depend (dot)"
|
||||
(check-unit-syntax #'((import) (export) (init-depend . a))))
|
||||
(test stx-bound-id=? #'((import a b c) (export a b c) (init-depend) 1 2 3)
|
||||
(check-unit-syntax #'((import a b c) (export a b c) 1 2 3)))
|
||||
(test stx-bound-id=? #'((import a b c) (export a b c) (init-depend x y) 1 2 3)
|
||||
(check-unit-syntax #'((import a b c) (export a b c) (init-depend x y) 1 2 3)))
|
||||
(test bound-identifier=? #'init-depend
|
||||
(car (syntax-e (caddr (syntax->list (check-unit-syntax #'((import) (export))))))))
|
||||
)
|
||||
|
||||
;; check-unit-body-syntax
|
||||
(parameterize ((error-syntax #'check-unit-body-syntax))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: no exp or import or export"
|
||||
(check-unit-body-syntax #'()))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: no import or export"
|
||||
(check-unit-body-syntax #'(1)))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: bad import"
|
||||
(check-unit-body-syntax #'(1 (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: bad import"
|
||||
(check-unit-body-syntax #'(1 (impor) (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: bad import"
|
||||
(check-unit-body-syntax #'(1 import (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: no export"
|
||||
(check-unit-body-syntax #'(1 (import))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: bad export"
|
||||
(check-unit-body-syntax #'(1 (import) (expor))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: bad export"
|
||||
(check-unit-body-syntax #'(1 (import) export)))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: malformed import (dot)"
|
||||
(check-unit-body-syntax #'(1 (import . a) (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: malformed export (dot)"
|
||||
(check-unit-body-syntax #'(1 (import) (export . a))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: malformed init-depend (dot)"
|
||||
(check-unit-body-syntax #'(1 (import) (export) (init-depend . a))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: bad init-depend"
|
||||
(check-unit-body-syntax #'(1 (import) (export) (init-depen))))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: too many"
|
||||
(check-unit-body-syntax #'(1 (import) (export) (init-depend) x)))
|
||||
(test-runtime-error exn:fail:syntax? "check-unit-body-syntax: bad dot"
|
||||
(check-unit-body-syntax #'(1 (import) (export) . (init-depend))))
|
||||
(test stx-bound-id=? #'(1 (import a b c) (export a b c) (init-depend))
|
||||
(check-unit-body-syntax #'(1 (import a b c) (export a b c))))
|
||||
(test `(1 (import a b c) (export a b c) (init-depend x y))
|
||||
(syntax-object->datum (check-unit-body-syntax #'(1 (import a b c) (export a b c) (init-depend x y)))))
|
||||
(test bound-identifier=? #'init-depend
|
||||
(car (syntax-e (cadddr (syntax->list (check-unit-body-syntax #'(1 (import) (export))))))))
|
||||
)
|
||||
|
||||
;; check-link-line-syntax
|
||||
(parameterize ((error-syntax #'check-link-line-syntax))
|
||||
(test-runtime-error exn:fail:syntax? "check-link-line-syntax: malformed"
|
||||
(check-link-line-syntax #'1))
|
||||
(test-runtime-error exn:fail:syntax? "check-link-line-syntax: bad export list"
|
||||
(check-link-line-syntax #'(a b)))
|
||||
(test-runtime-error exn:fail:syntax? "check-link-line-syntax: missing unit expression"
|
||||
(check-link-line-syntax #'(())))
|
||||
(test-runtime-error exn:fail:syntax? "check-link-line-syntax: dot"
|
||||
(check-link-line-syntax #'((a . b) u)))
|
||||
(test-runtime-error exn:fail:syntax? "check-link-line-syntax: dot"
|
||||
(check-link-line-syntax #'((a b) u c . d)))
|
||||
(test (void)
|
||||
(check-link-line-syntax #'((a b c) u 1 2 3)))
|
||||
)
|
||||
|
||||
;; check-compound-syntax
|
||||
(parameterize ((error-syntax #'check-compound-syntax))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: no import, export, or link"
|
||||
(check-compound-syntax #'()))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: import malformed"
|
||||
(check-compound-syntax #'(import (export) (link))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: import malformed"
|
||||
(check-compound-syntax #'((impor) (export) (link))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: import dot"
|
||||
(check-compound-syntax #'((import a b . 3) (export) (link))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: missing link and export clause"
|
||||
(check-compound-syntax #'((import))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: bad export"
|
||||
(check-compound-syntax #'((import) export (link))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: bad export"
|
||||
(check-compound-syntax #'((import) (expor) (link))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: export dot"
|
||||
(check-compound-syntax #'((import) (export a . b) (link))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: missing link clause"
|
||||
(check-compound-syntax #'((import) (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: 2 link clauses"
|
||||
(check-compound-syntax #'((import) (export) (link) (link))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: 2 export clauses"
|
||||
(check-compound-syntax #'((import) (export) (link) (export))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: 2 import clauses"
|
||||
(check-compound-syntax #'((import) (export) (link) (import))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: link dot"
|
||||
(check-compound-syntax #'((import) (export) (link a b . 3))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: link clause malformed"
|
||||
(check-compound-syntax #'((import) (export) (lnk))))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: link clause malformed"
|
||||
(check-compound-syntax #'((import) (export) link)))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: after link clause"
|
||||
(check-compound-syntax #'((import) (export) (link) 3)))
|
||||
(test-runtime-error exn:fail:syntax? "check-compound-syntax: dot"
|
||||
(check-compound-syntax #'((import) (export) (link) . 3)))
|
||||
|
||||
(test stx-bound-id=? #'((a b)
|
||||
(c d)
|
||||
(((e f) g h i)
|
||||
(() x)))
|
||||
(check-compound-syntax #'((link ((e f) g h i)
|
||||
(() x))
|
||||
(export c d)
|
||||
(import a b))))
|
||||
)
|
||||
|
||||
;; check-def-syntax
|
||||
(parameterize ((error-syntax #'check-def-syntax))
|
||||
(test-runtime-error exn:fail:syntax? "define-values: missing ids and expr"
|
||||
(check-def-syntax #'(define-values)))
|
||||
(test-runtime-error exn:fail:syntax? "define-values: missing expr"
|
||||
(check-def-syntax #'(define-values (a))))
|
||||
(test-runtime-error exn:fail:syntax? "define-values: 2 expr"
|
||||
(check-def-syntax #'(define-values (a) 1 2)))
|
||||
(test-runtime-error exn:fail:syntax? "define-values: dot"
|
||||
(check-def-syntax #'(define-values (a) . 1)))
|
||||
(test-runtime-error exn:fail:syntax? "define-values: bad ids"
|
||||
(check-def-syntax #'(define-values x 1)))
|
||||
(test-runtime-error exn:fail:syntax? "define-values: bad id"
|
||||
(check-def-syntax #'(define-values (1) 1)))
|
||||
(test-runtime-error exn:fail:syntax? "define-values: bad id (dot)"
|
||||
(check-def-syntax #'(define-values (a . b) 1)))
|
||||
(test-runtime-error exn:fail:syntax? "define-syntaxes: bad id (dot)"
|
||||
(check-def-syntax #'(define-syntaxes (a . b) 1)))
|
||||
|
||||
(test (void)
|
||||
(check-def-syntax #'(define-values (a b c) 1)))
|
||||
(test (void)
|
||||
(check-def-syntax #'(define-values () 1)))
|
||||
(test (void)
|
||||
(check-def-syntax #'(define-syntaxes (a b c) 1)))
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user