110 lines
3.0 KiB
Racket
110 lines
3.0 KiB
Racket
#lang racket/base
|
|
(require syntax/parse
|
|
syntax/parse/debug
|
|
rackunit
|
|
"setup.rkt")
|
|
|
|
(define-literal-set lits0 #:phase 0
|
|
(define lambda))
|
|
|
|
(tcerr "litset unbound"
|
|
(let ()
|
|
(define-literal-set lits #:phase 0
|
|
(none-such))
|
|
(void)))
|
|
|
|
(tcerr "litset unbound, phase"
|
|
(let ()
|
|
(define-literal-set lits #:for-template
|
|
(lambda))
|
|
(void)))
|
|
|
|
(tcerr "litset ok, use fails"
|
|
(let ()
|
|
(define-literal-set lits #:phase 0
|
|
(define lambda))
|
|
(syntax-parse #'foo #:literal-sets (lits)
|
|
[lambda (void)])))
|
|
|
|
(define-literal-set lits #:phase 0
|
|
(define lambda))
|
|
(require (prefix-in mz: racket/base))
|
|
|
|
(test-case "litset ok, use ok"
|
|
(syntax-parse #'lambda #:literal-sets (lits)
|
|
[lambda (void)]))
|
|
|
|
(test-case "litset ok, use ok prefix"
|
|
(syntax-parse #'mz:lambda #:literal-sets (lits)
|
|
[lambda (void)]))
|
|
|
|
(require (for-meta 2 (only-in '#%kernel #%app)))
|
|
(define-literal-set litsk #:phase 2
|
|
(#%app))
|
|
|
|
(test-case "litset, phase"
|
|
(syntax-parse #'#%plain-app #:literal-sets (litsk)
|
|
[#%app (void)]))
|
|
|
|
(tcerr "litset, phase fail"
|
|
(syntax-parse #'#%app #:literal-sets (litsk)
|
|
[#%app (void)]))
|
|
|
|
;; ----
|
|
|
|
|
|
(tcerr "litset, #:at"
|
|
(let ()
|
|
(define-literal-set lits #:phase 0
|
|
(define lambda))
|
|
(define-syntax-rule (getvar var stx)
|
|
(syntax-parse stx #:literal-sets ([lits #:at here])
|
|
[(lambda var _) #'var]))
|
|
;; check that introduced lambda is a literal:
|
|
(check-exn exn:fail? (lambda () (getvar x #'(a b c))))
|
|
(check-equal? (syntax->datum (getvar x #'(lambda b c)))
|
|
'(b))
|
|
;; check that passed lambda is not a literal, but a pattern variable:
|
|
(check-equal? (syntax->datum (getvar lambda #'(lambda b c))))))
|
|
|
|
;; Litset extension
|
|
|
|
(tcerr "litset ext, dup 1"
|
|
(let ()
|
|
(define-literal-set lits1 (define))
|
|
(define-literal-set lits2 #:literal-sets (lits1) (define))
|
|
(void)))
|
|
|
|
(tcerr "litset ext, dup 2"
|
|
(let ()
|
|
(define-literal-set lits1 (define))
|
|
(define-literal-set lits2 (define))
|
|
(define-literal-set lits3 #:literal-sets (lits1 lits2) ())
|
|
(void)))
|
|
|
|
(test-case "litset ext, works"
|
|
(let ()
|
|
(define-literal-set lits1 (define))
|
|
(define-literal-set lits2 #:literal-sets (lits1) (lambda))
|
|
(define (go x exp)
|
|
(check-equal? (syntax-parse x #:literal-sets (lits2)
|
|
[lambda 'lambda]
|
|
[define 'define]
|
|
[_ #f])
|
|
exp))
|
|
(go #'lambda 'lambda)
|
|
(go #'define 'define)
|
|
(go #'begin #f)
|
|
(void)))
|
|
|
|
(require (for-label '#%kernel))
|
|
|
|
(test-case "litset->pred"
|
|
(let ([kernel? (literal-set->predicate kernel-literals)])
|
|
(check-equal? (kernel? #'#%plain-lambda) #t)
|
|
(check-equal? (kernel? #'define-values) #t)
|
|
(check-equal? (kernel? #'define-values #f) #t)
|
|
(check-equal? (kernel? #'define-values 4) #f)
|
|
(check-equal? (kernel? #'foo) #f)
|
|
(void)))
|