332 lines
14 KiB
Scheme
332 lines
14 KiB
Scheme
(require (for-syntax (lib "unit-compiletime.ss" "mzlib" "private")
|
|
(lib "unit-syntax.ss" "mzlib" "private")))
|
|
(require "test-harness.ss"
|
|
(lib "unit-compiletime.ss" "mzlib" "private")
|
|
(lib "unit-keywords.ss" "mzlib" "private")
|
|
(lib "unit-syntax.ss" "mzlib" "private"))
|
|
|
|
|
|
;; 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))
|
|
)
|