1106 lines
39 KiB
Scheme
1106 lines
39 KiB
Scheme
|
;;; Copyright (c) 2000-2018 Andrew W. Keep, R. Kent Dybvig
|
||
|
|
;;; See the accompanying file Copyright for details
|
||
|
|
|
||
|
|
(library (tests unit-tests)
|
||
|
|
(export run-unit-tests run-ensure-correct-identifiers run-maybe-tests
|
||
|
|
run-maybe-dots-tests run-language-dot-support run-maybe-unparse-tests
|
||
|
|
run-argument-name-matching run-error-messages run-pass-parser-unparser)
|
||
|
|
(import (rnrs)
|
||
|
|
(nanopass helpers)
|
||
|
|
(nanopass language)
|
||
|
|
(nanopass pass)
|
||
|
|
(nanopass parser)
|
||
|
|
(tests unit-test-helpers))
|
||
|
|
|
||
|
|
(define primitives '(car cdr cons + - =))
|
||
|
|
(define primitive? (lambda (x) (memq x primitives)))
|
||
|
|
(define variable? (lambda (x) (and (symbol? x) (not (primitive? x)))))
|
||
|
|
(define constant?
|
||
|
|
(lambda (x)
|
||
|
|
(or (number? x) (boolean? x) (string? x)
|
||
|
|
(and (pair? x) (constant? (car x)) (constant? (cdr x))))))
|
||
|
|
|
||
|
|
(define-language L0
|
||
|
|
(terminals
|
||
|
|
(variable (x))
|
||
|
|
(constant (c))
|
||
|
|
(primitive (pr)))
|
||
|
|
(Expr (e)
|
||
|
|
(var x)
|
||
|
|
(quote c)
|
||
|
|
(begin e0 ... e1)
|
||
|
|
(if e0 e1 e2)
|
||
|
|
(lambda (x ...) e0 ... e1)
|
||
|
|
(let ([x e] ...) e0 ... e1)
|
||
|
|
(letrec ([x e] ...) e0 ... e1)
|
||
|
|
(primapp pr e1 ...)
|
||
|
|
(app e0 e1 ...)))
|
||
|
|
|
||
|
|
(define-record-type var
|
||
|
|
(fields sym ref set mset)
|
||
|
|
(protocol
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (sym)
|
||
|
|
(new sym #f #f #f)))))
|
||
|
|
|
||
|
|
(define-language LUNPARSE
|
||
|
|
(terminals
|
||
|
|
(var (x)) => var-sym
|
||
|
|
(constant (c))
|
||
|
|
(primitive (pr)))
|
||
|
|
(Expr (e body)
|
||
|
|
(var x) => x
|
||
|
|
(quoted c) => (quote c)
|
||
|
|
(seq e0 e1) => (begin e0 e1)
|
||
|
|
(if e0 e1 e2)
|
||
|
|
(lambda (x ...) e0 ... e1)
|
||
|
|
(binding (x ...) (e ...) body0 ... body1) => (let ([x e] ...) body0 ... body1)
|
||
|
|
(recbinding (x ...) (e ...) body0 ... body1) => (letrec ([x e] ...) body0 ... body1)
|
||
|
|
(primapp pr e1 ...) => (pr e1 ...)
|
||
|
|
(app e0 e1 ...) => (e0 e1 ...)))
|
||
|
|
|
||
|
|
(define-language LBool
|
||
|
|
(terminals
|
||
|
|
(boolean (b)))
|
||
|
|
(Expr (e)
|
||
|
|
b))
|
||
|
|
|
||
|
|
(define-language LBoolLambda
|
||
|
|
(terminals
|
||
|
|
(boolean (b))
|
||
|
|
(symbol (x)))
|
||
|
|
(Expr (e)
|
||
|
|
v
|
||
|
|
x
|
||
|
|
(lambda (x) e)
|
||
|
|
(and e0 e1)
|
||
|
|
(or e0 e1)
|
||
|
|
(not e)
|
||
|
|
(e0 e1))
|
||
|
|
(Value (v)
|
||
|
|
b))
|
||
|
|
|
||
|
|
(test-suite unit-tests
|
||
|
|
(test with-output-language
|
||
|
|
(assert-equal?
|
||
|
|
'(var a)
|
||
|
|
(unparse-L0 (with-output-language L0 (in-context Expr `(var a)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(let ([x '1] [y '2]) (primapp + (var x) (var y)))
|
||
|
|
(unparse-L0
|
||
|
|
(with-output-language L0
|
||
|
|
(in-context Expr
|
||
|
|
`(let ([x (quote 1)] [y (quote 2)])
|
||
|
|
(primapp + (var x) (var y)))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(var a)
|
||
|
|
(unparse-L0 (with-output-language (L0 Expr) `(var a))))
|
||
|
|
(assert-equal?
|
||
|
|
'(let ([x '1] [y '2]) (primapp + (var x) (var y)))
|
||
|
|
(unparse-L0
|
||
|
|
(with-output-language (L0 Expr)
|
||
|
|
`(let ([x (quote 1)] [y (quote 2)])
|
||
|
|
(primapp + (var x) (var y)))))))
|
||
|
|
|
||
|
|
(test unparse-language
|
||
|
|
(assert-equal?
|
||
|
|
`(quoted 5)
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr) `(quoted 5))
|
||
|
|
#t))
|
||
|
|
|
||
|
|
(assert-equal?
|
||
|
|
`(seq (quoted 7) (quoted 8))
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr)
|
||
|
|
`(seq (quoted 7) (quoted 8)))
|
||
|
|
#t))
|
||
|
|
|
||
|
|
(let ([x.0 (make-var 'x.0)])
|
||
|
|
(assert-equal?
|
||
|
|
`(var ,x.0)
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr) `(var ,x.0))
|
||
|
|
#t)))
|
||
|
|
|
||
|
|
(let ([x.1 (make-var 'x.1)]
|
||
|
|
[x.2 (make-var 'x.2)]
|
||
|
|
[y.3 (make-var 'y.2)]
|
||
|
|
[x.4 (make-var 'x.4)]
|
||
|
|
[zero?.5 (make-var 'zero?.5)]
|
||
|
|
[*.6 (make-var '*.6)]
|
||
|
|
[f.7 (make-var 'f.7)])
|
||
|
|
(assert-equal?
|
||
|
|
`(recbinding (,zero?.5 ,*.6 ,f.7)
|
||
|
|
((lambda (,x.1) (primapp = (var ,x.1) (quoted 0)))
|
||
|
|
(lambda (,x.2 ,y.3)
|
||
|
|
(if (app (var ,zero?.5) (var ,x.2))
|
||
|
|
(quoted 0)
|
||
|
|
(if (primapp = (var ,x.2) (quoted 1))
|
||
|
|
(var ,y.3)
|
||
|
|
(primapp + (var ,y.3)
|
||
|
|
(app (var ,*.6)
|
||
|
|
(primapp - (var ,x.2) (quoted 1))
|
||
|
|
(var ,y.3))))))
|
||
|
|
(lambda (,x.4)
|
||
|
|
(if (app (var ,zero?.5) (var ,x.4))
|
||
|
|
(quoted 1)
|
||
|
|
(app (var ,*.6) (var ,x.4)
|
||
|
|
(app (var ,f.7)
|
||
|
|
(primapp - (var ,x.4) (quoted 1)))))))
|
||
|
|
(app (var ,f.7) (quoted 10)))
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr)
|
||
|
|
`(recbinding
|
||
|
|
(,zero?.5 ,*.6 ,f.7)
|
||
|
|
((lambda (,x.1) (primapp = (var ,x.1) (quoted 0)))
|
||
|
|
(lambda (,x.2 ,y.3)
|
||
|
|
(if (app (var ,zero?.5) (var ,x.2))
|
||
|
|
(quoted 0)
|
||
|
|
(if (primapp = (var ,x.2) (quoted 1))
|
||
|
|
(var ,y.3)
|
||
|
|
(primapp + (var ,y.3)
|
||
|
|
(app (var ,*.6)
|
||
|
|
(primapp - (var ,x.2) (quoted 1))
|
||
|
|
(var ,y.3))))))
|
||
|
|
(lambda (,x.4)
|
||
|
|
(if (app (var ,zero?.5) (var ,x.4))
|
||
|
|
(quoted 1)
|
||
|
|
(app (var ,*.6) (var ,x.4)
|
||
|
|
(app (var ,f.7)
|
||
|
|
(primapp - (var ,x.4) (quoted 1)))))))
|
||
|
|
(app (var ,f.7) (quoted 10)))) #t)))
|
||
|
|
|
||
|
|
(assert-equal?
|
||
|
|
'(quote 5)
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr) `(quoted 5))
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(assert-equal?
|
||
|
|
'(begin (quote 7) (quote 8))
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr)
|
||
|
|
`(seq (quoted 7) (quoted 8)))
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(let ([x.0 (make-var 'x.0)])
|
||
|
|
(assert-equal?
|
||
|
|
'x.0
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr) `(var ,x.0))
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(let ([x.1 (make-var 'x.1)]
|
||
|
|
[x.2 (make-var 'x.2)]
|
||
|
|
[y.3 (make-var 'y.3)]
|
||
|
|
[x.4 (make-var 'x.4)]
|
||
|
|
[zero?.5 (make-var 'zero?.5)]
|
||
|
|
[*.6 (make-var '*.6)]
|
||
|
|
[f.7 (make-var 'f.7)])
|
||
|
|
(assert-equal?
|
||
|
|
'(letrec ([zero?.5 (lambda (x.1) (= x.1 '0))]
|
||
|
|
[*.6 (lambda (x.2 y.3)
|
||
|
|
(if (zero?.5 x.2)
|
||
|
|
'0
|
||
|
|
(if (= x.2 '1)
|
||
|
|
y.3
|
||
|
|
(+ y.3 (*.6 (- x.2 '1) y.3)))))]
|
||
|
|
[f.7 (lambda (x.4)
|
||
|
|
(if (zero?.5 x.4)
|
||
|
|
'1
|
||
|
|
(*.6 x.4 (f.7 (- x.4 '1)))))])
|
||
|
|
(f.7 '10))
|
||
|
|
(unparse-LUNPARSE
|
||
|
|
(with-output-language (LUNPARSE Expr)
|
||
|
|
`(recbinding
|
||
|
|
(,zero?.5 ,*.6 ,f.7)
|
||
|
|
((lambda (,x.1) (primapp = (var ,x.1) (quoted 0)))
|
||
|
|
(lambda (,x.2 ,y.3)
|
||
|
|
(if (app (var ,zero?.5) (var ,x.2))
|
||
|
|
(quoted 0)
|
||
|
|
(if (primapp = (var ,x.2) (quoted 1))
|
||
|
|
(var ,y.3)
|
||
|
|
(primapp + (var ,y.3)
|
||
|
|
(app (var ,*.6)
|
||
|
|
(primapp - (var ,x.2) (quoted 1))
|
||
|
|
(var ,y.3))))))
|
||
|
|
(lambda (,x.4)
|
||
|
|
(if (app (var ,zero?.5) (var ,x.4))
|
||
|
|
(quoted 1)
|
||
|
|
(app (var ,*.6) (var ,x.4)
|
||
|
|
(app (var ,f.7)
|
||
|
|
(primapp - (var ,x.4) (quoted 1)))))))
|
||
|
|
(app (var ,f.7) (quoted 10)))) #f)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test boolean-terminals
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBool LBool)
|
||
|
|
(assert-equal? #t (parse-LBool #t)))
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBool LBool)
|
||
|
|
(assert-equal? #f (parse-LBool #f)))
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBool LBool)
|
||
|
|
(guard (c [else #t])
|
||
|
|
(assert-equal? 'a (parse-LBool 'a))))
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBoolLambda LBoolLambda)
|
||
|
|
(assert-equal? #t (parse-LBoolLambda #t)))
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBoolLambda LBoolLambda)
|
||
|
|
(assert-equal? #f (parse-LBoolLambda #f)))
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBoolLambda LBoolLambda)
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda (x) #f)
|
||
|
|
(unparse-LBoolLambda
|
||
|
|
(parse-LBoolLambda '(lambda (x) #f)))))
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBoolLambda LBoolLambda)
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda (f) (f #f))
|
||
|
|
(unparse-LBoolLambda
|
||
|
|
(parse-LBoolLambda '(lambda (f) (f #f))))))
|
||
|
|
(let ()
|
||
|
|
(define-parser parse-LBoolLambda LBoolLambda)
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda (f) (not (f #f)))
|
||
|
|
(unparse-LBoolLambda
|
||
|
|
(parse-LBoolLambda '(lambda (f) (not (f #f)))))))))
|
||
|
|
|
||
|
|
(define datum?
|
||
|
|
(lambda (x)
|
||
|
|
(or (number? x) (string? x) (symbol? x)
|
||
|
|
(and (pair? x) (datum? (car x)) (datum? (cdr x)))
|
||
|
|
(and (vector? x) (for-all datum? (vector->list x))))))
|
||
|
|
|
||
|
|
(define-language LVAR
|
||
|
|
(terminals
|
||
|
|
(var (x))
|
||
|
|
(primitive (pr))
|
||
|
|
(datum (d)))
|
||
|
|
(Expr (e)
|
||
|
|
(var x)
|
||
|
|
(quote d)
|
||
|
|
(if e0 e1 e2)
|
||
|
|
(begin e0 ... e1)
|
||
|
|
(let ([x e] ...) e1)
|
||
|
|
(letrec ([x e] ...) e1)
|
||
|
|
(app e0 e1 ...)
|
||
|
|
(primapp pr e ...)))
|
||
|
|
|
||
|
|
(define-pass break-variable : LVAR (ir) -> LVAR ()
|
||
|
|
(definitions
|
||
|
|
(define var? symbol?))
|
||
|
|
(Expr : Expr (ir) -> Expr ()
|
||
|
|
[(var ,x) (printf "found var: ~a\n" (var-sym x)) `(var ,x)]))
|
||
|
|
|
||
|
|
(test-suite ensure-correct-identifiers
|
||
|
|
(test accidental-variable?-capture
|
||
|
|
(assert-equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(break-variable
|
||
|
|
(with-output-language (LVAR Expr)
|
||
|
|
`(var ,(make-var 'x))))))
|
||
|
|
"found var: x\n")))
|
||
|
|
|
||
|
|
(define-language Lmaybe
|
||
|
|
(terminals
|
||
|
|
(boolean (b))
|
||
|
|
(integer (i)))
|
||
|
|
(Exp (e)
|
||
|
|
(Int i)
|
||
|
|
(Bool b)
|
||
|
|
(Bar (maybe i) e)
|
||
|
|
(Foo i (maybe e))))
|
||
|
|
|
||
|
|
(define-parser parse-Lmaybe Lmaybe)
|
||
|
|
|
||
|
|
(test-suite maybe-tests
|
||
|
|
(test maybe-parse/unparse
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 72)
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Int 72))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bool #t)
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Bool #t))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar 5 (Bool #t))
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Bar 5 (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar #f (Bool #t))
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Bar #f (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 #f)
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Foo 5 #f))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Foo 4 (Foo 3 #f)))
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Foo 5 (Foo 4 (Foo 3 #f))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Bar 3 (Foo 1 #f)))
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Foo 5 (Bar 3 (Foo 1 #f))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Int 3))
|
||
|
|
(unparse-Lmaybe (parse-Lmaybe '(Foo 5 (Int 3))))))
|
||
|
|
(test maybe-with-output-language/unparse
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 72)
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Int 72))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bool #t)
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Bool #t))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar 5 (Bool #t))
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Bar 5 (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar #f (Bool #t))
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Bar #f (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 #f)
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 #f))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Foo 4 (Foo 3 #f)))
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 (Foo 4 (Foo 3 #f))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Bar 3 (Foo 1 #f)))
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 (Bar 3 (Foo 1 #f))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Int 3))
|
||
|
|
(unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 (Int 3))))))
|
||
|
|
(test maybe-pass
|
||
|
|
(let ()
|
||
|
|
(define-pass add-one-int : Lmaybe (ir) -> Lmaybe ()
|
||
|
|
(Exp : Exp (ir) -> Exp ()
|
||
|
|
[(Int ,i) `(Int ,(fx+ i 1))]))
|
||
|
|
(and
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 4)
|
||
|
|
(unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Int 3)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Int 4))
|
||
|
|
(unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Foo 4 (Int 3))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Foo 5 (Int 3)))
|
||
|
|
(unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Foo 4 (Foo 5 (Int 2)))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 3 #f)
|
||
|
|
(unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Foo 3 #f)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar #f (Int 5))
|
||
|
|
(unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Bar #f (Int 4))))))))
|
||
|
|
(let ()
|
||
|
|
(define-pass add-one : Lmaybe (ir) -> Lmaybe ()
|
||
|
|
(Exp : Exp (ir) -> Exp ()
|
||
|
|
[(Foo ,i ,[e?]) `(Foo ,(fx+ i 1) ,e?)]
|
||
|
|
[(Bar ,i? ,[e]) `(Bar ,(and i? (fx+ i? 1)) ,e)]
|
||
|
|
[(Int ,i) `(Int ,(fx+ i 1))]))
|
||
|
|
(and
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 4)
|
||
|
|
(unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Int 3)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Int 4))
|
||
|
|
(unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 4 (Int 3))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Foo 6 (Int 3)))
|
||
|
|
(unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 4 (Foo 5 (Int 2)))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Bar 6 (Foo 7 #f)))
|
||
|
|
(unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 3 (Bar 5 (Foo 6 #f)))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Bar #f (Foo 7 #f)))
|
||
|
|
(unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 3 (Bar #f (Foo 6 #f)))))))))))
|
||
|
|
|
||
|
|
(define-language Lmaybe2
|
||
|
|
(terminals
|
||
|
|
(boolean (b))
|
||
|
|
(integer (i)))
|
||
|
|
(Exp (e)
|
||
|
|
(Int i)
|
||
|
|
(Bool b)
|
||
|
|
(Bar (maybe i) ... e)
|
||
|
|
(Foo i (maybe e) ...)))
|
||
|
|
|
||
|
|
(define-parser parse-Lmaybe2 Lmaybe2)
|
||
|
|
|
||
|
|
(test-suite maybe-dots-tests
|
||
|
|
(test maybe-parse/unparse
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 3)
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 3))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar (Int 72))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Bar (Int 72)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 72)
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Int 72))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bool #t)
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Bool #t))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar 5 (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Bar 5 (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar #f (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Bar #f (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar #f 1 #f 2 #f 3 (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Bar #f 1 #f 2 #f 3 (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar 1 #f 2 #f 3 #f (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Bar 1 #f 2 #f 3 #f (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 #f)
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 #f))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f)
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3))))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3)))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f)))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Int 3) (Bool #f))
|
||
|
|
(unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 (Int 3) (Bool #f))))))
|
||
|
|
(test maybe-with-output-language/unparse
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 3)
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 3))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar (Int 72))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar (Int 72)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 72)
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Int 72))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bool #t)
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bool #t))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar 5 (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar 5 (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar #f (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar #f (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar #f 1 #f 2 #f 3 (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar #f 1 #f 2 #f 3 (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar 1 #f 2 #f 3 #f (Bool #t))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar 1 #f 2 #f 3 #f (Bool #t)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 #f)
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 #f))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f)
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3))))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3)))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f)))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Int 3) (Bool #f))
|
||
|
|
(unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 (Int 3) (Bool #f))))))
|
||
|
|
(test maybe-pass
|
||
|
|
(let ()
|
||
|
|
(define-pass add-one-int : Lmaybe2 (ir) -> Lmaybe2 ()
|
||
|
|
(Exp : Exp (ir) -> Exp ()
|
||
|
|
[(Int ,i) `(Int ,(fx+ i 1))]))
|
||
|
|
(and
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 4)
|
||
|
|
(unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Int 3)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Int 4) (Int 5) (Int 7) #f #f (Int 8))
|
||
|
|
(unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Foo 4 (Int 3) (Int 4) (Int 6) #f #f (Int 7))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Foo 5 (Int 3) #f (Int 4) (Int 5)))
|
||
|
|
(unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Foo 4 (Foo 5 (Int 2) #f (Int 3) (Int 4)))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 3 #f (Int 4))
|
||
|
|
(unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Foo 3 #f (Int 3))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Bar 3 #f 4 #f (Int 4))
|
||
|
|
(unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Bar 3 #f 4 #f (Int 3))))))))
|
||
|
|
(let ()
|
||
|
|
(define-pass add-one : Lmaybe2 (ir) -> Lmaybe2 ()
|
||
|
|
(Exp : Exp (ir) -> Exp ()
|
||
|
|
[(Foo ,i ,[e?*] ...) `(Foo ,(fx+ i 1) ,e?* ...)]
|
||
|
|
[(Bar ,i?* ... ,[e]) `(Bar ,(map (lambda (i?) (and i? (fx+ i? 1))) i?*) ... ,e)]
|
||
|
|
[(Int ,i) `(Int ,(fx+ i 1))]))
|
||
|
|
(and
|
||
|
|
(assert-equal?
|
||
|
|
'(Int 4)
|
||
|
|
(unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Int 3)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Int 4) (Int 5) (Int 6) #f (Int 8))
|
||
|
|
(unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 4 (Int 3) (Int 4) (Int 5) #f (Int 7))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 5 (Foo 6 (Int 3) (Bar 4 3 2 #f 1 (Foo 3 (Int 8) (Int 9)))))
|
||
|
|
(unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 4 (Foo 5 (Int 2) (Bar 3 2 1 #f 0 (Foo 2 (Int 7) (Int 8)))))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Bar 6 #f 8 #f 9 (Foo 7 #f)) (Bool #t) #f)
|
||
|
|
(unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 3 (Bar 5 #f 7 #f 8 (Foo 6 #f)) (Bool #t) #f)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(Foo 4 (Bar #f (Foo 7 #f)) (Bool #t) #f)
|
||
|
|
(unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 3 (Bar #f (Foo 6 #f)) (Bool #t) #f)))))))))
|
||
|
|
|
||
|
|
(define-language LMaybeNoBool
|
||
|
|
(terminals
|
||
|
|
(symbol (x))
|
||
|
|
(number (n)))
|
||
|
|
(Expr (e)
|
||
|
|
(foo x (maybe n))
|
||
|
|
(bar (maybe e) x)
|
||
|
|
(num n)
|
||
|
|
(ref x)))
|
||
|
|
|
||
|
|
(define-language LMaybeListNoBool
|
||
|
|
(terminals
|
||
|
|
(symbol (x))
|
||
|
|
(number (n)))
|
||
|
|
(Expr (e)
|
||
|
|
(foo ([x (maybe n)] ...) e)
|
||
|
|
(bar (maybe e) ... x)
|
||
|
|
(num n)
|
||
|
|
(ref x)))
|
||
|
|
|
||
|
|
(test-suite maybe-unparse-tests
|
||
|
|
(test maybe-unparse
|
||
|
|
(assert-equal? '(foo x 10)
|
||
|
|
(unparse-LMaybeNoBool
|
||
|
|
(with-output-language (LMaybeNoBool Expr)
|
||
|
|
`(foo x 10))))
|
||
|
|
(assert-equal? '(bar (foo x #f) x)
|
||
|
|
(unparse-LMaybeNoBool
|
||
|
|
(with-output-language (LMaybeNoBool Expr)
|
||
|
|
`(bar (foo x #f) x))))
|
||
|
|
(assert-equal? '(bar (bar (foo y #f) y) z)
|
||
|
|
(unparse-LMaybeNoBool
|
||
|
|
(with-output-language (LMaybeNoBool Expr)
|
||
|
|
`(bar (bar (foo y #f) y) z))))
|
||
|
|
(assert-equal? '(bar (bar (bar #f x) y) z)
|
||
|
|
(unparse-LMaybeNoBool
|
||
|
|
(with-output-language (LMaybeNoBool Expr)
|
||
|
|
`(bar (bar (bar #f x) y) z)))))
|
||
|
|
|
||
|
|
(test maybe-unparse-dots
|
||
|
|
(assert-equal? '(foo ([x 10] [y 12]) (ref x))
|
||
|
|
(unparse-LMaybeListNoBool
|
||
|
|
(with-output-language (LMaybeListNoBool Expr)
|
||
|
|
`(foo ([x 10] [y 12]) (ref x)))))
|
||
|
|
(assert-equal? '(foo ([x #f] [y 12] [z #f]) (ref y))
|
||
|
|
(unparse-LMaybeListNoBool
|
||
|
|
(with-output-language (LMaybeListNoBool Expr)
|
||
|
|
`(foo ([x #f] [y 12] [z #f]) (ref y)))))
|
||
|
|
(assert-equal? '(bar #f #f (num 10) (ref x) #f (foo ([x #f] [y 10] [z 5] [w #f]) (bar #f z)) #f w)
|
||
|
|
(unparse-LMaybeListNoBool
|
||
|
|
(with-output-language (LMaybeListNoBool Expr)
|
||
|
|
`(bar #f #f (num 10) (ref x) #f (foo ([x #f] [y 10] [z 5] [w #f]) (bar #f z)) #f w))))))
|
||
|
|
|
||
|
|
;; tests related to issue #7 on github.com
|
||
|
|
(define-language LPairs
|
||
|
|
(terminals
|
||
|
|
(symbol (x))
|
||
|
|
(null (n)))
|
||
|
|
(Expr (e)
|
||
|
|
x
|
||
|
|
n
|
||
|
|
(e0 . e1)))
|
||
|
|
|
||
|
|
(define-parser parse-LPairs LPairs)
|
||
|
|
|
||
|
|
(define-pass reverse-pairs : LPairs (p) -> LPairs ()
|
||
|
|
(Expr : Expr (p) -> Expr ()
|
||
|
|
[(,[e0] . ,[e1]) `(,e1 . ,e0)]))
|
||
|
|
|
||
|
|
(define-language LList
|
||
|
|
(terminals
|
||
|
|
(symbol (x))
|
||
|
|
(null (n)))
|
||
|
|
(Expr (e)
|
||
|
|
x
|
||
|
|
n
|
||
|
|
(e0 ... . e1)))
|
||
|
|
|
||
|
|
(define-parser parse-LList LList)
|
||
|
|
|
||
|
|
(define-language LList2
|
||
|
|
(terminals
|
||
|
|
(symbol (x))
|
||
|
|
(null (n)))
|
||
|
|
(Expr (e)
|
||
|
|
x
|
||
|
|
n
|
||
|
|
(e0 ... e1)))
|
||
|
|
|
||
|
|
(define-pass swap-parts : LList (e) -> LList ()
|
||
|
|
(Expr : Expr (e) -> Expr ()
|
||
|
|
[(,[e*] ... . ,[e])
|
||
|
|
`(,e ,e* ... . ())]))
|
||
|
|
|
||
|
|
;; example provided by Simon Stapleton via bug #7
|
||
|
|
(define-language Lx
|
||
|
|
(terminals
|
||
|
|
(symbol (x)))
|
||
|
|
(Expr (e)
|
||
|
|
x
|
||
|
|
(lambda (x* ... . x) e)
|
||
|
|
(define (x x* ... . x1) e)
|
||
|
|
(define x e)))
|
||
|
|
|
||
|
|
(define-parser parse-Lx Lx)
|
||
|
|
|
||
|
|
(define-pass Px1 : Lx (ir) -> Lx ()
|
||
|
|
(Expr : Expr (ir) -> Expr()
|
||
|
|
[(define (,x ,x* ... . ,x1) ,[e])
|
||
|
|
`(define ,x (lambda (,x* ... . ,x1) ,e))]))
|
||
|
|
|
||
|
|
(test-suite language-dot-support
|
||
|
|
(test simple-dots
|
||
|
|
(assert-equal?
|
||
|
|
'()
|
||
|
|
(unparse-LPairs (parse-LPairs '())))
|
||
|
|
(assert-equal?
|
||
|
|
'a
|
||
|
|
(unparse-LPairs (parse-LPairs 'a)))
|
||
|
|
(assert-equal?
|
||
|
|
'(a)
|
||
|
|
(unparse-LPairs (parse-LPairs '(a))))
|
||
|
|
(assert-equal?
|
||
|
|
'(a . b)
|
||
|
|
(unparse-LPairs (parse-LPairs '(a . b))))
|
||
|
|
(assert-equal?
|
||
|
|
'(a b c . d)
|
||
|
|
(unparse-LPairs (parse-LPairs '(a b c . d))))
|
||
|
|
(assert-equal?
|
||
|
|
'(((a b . c) d e) f . g)
|
||
|
|
(unparse-LPairs (parse-LPairs '(((a b . c) d e) f . g))))
|
||
|
|
(assert-equal?
|
||
|
|
'()
|
||
|
|
(unparse-LPairs (with-output-language (LPairs Expr) `())))
|
||
|
|
(assert-equal?
|
||
|
|
'a
|
||
|
|
(unparse-LPairs (with-output-language (LPairs Expr) `a)))
|
||
|
|
(assert-equal?
|
||
|
|
'(a)
|
||
|
|
(unparse-LPairs (with-output-language (LPairs Expr) `(a))))
|
||
|
|
(assert-equal?
|
||
|
|
'(a . b)
|
||
|
|
(unparse-LPairs (with-output-language (LPairs Expr) `(a . b))))
|
||
|
|
(assert-equal?
|
||
|
|
'(a b c . d)
|
||
|
|
(unparse-LPairs (with-output-language (LPairs Expr) `(a b c . d))))
|
||
|
|
(assert-equal?
|
||
|
|
'(((a b . c) d e) f . g)
|
||
|
|
(unparse-LPairs (with-output-language (LPairs Expr) `(((a b . c) d e) f . g))))
|
||
|
|
(assert-equal?
|
||
|
|
'(() . a)
|
||
|
|
(unparse-LPairs (reverse-pairs (parse-LPairs '(a)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(b . a)
|
||
|
|
(unparse-LPairs (reverse-pairs (parse-LPairs '(a . b)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(((d . c) . b) . a)
|
||
|
|
(unparse-LPairs (reverse-pairs (parse-LPairs '(a b c . d)))))
|
||
|
|
(assert-equal?
|
||
|
|
'((g . f) ((() . e) . d) (c . b) . a)
|
||
|
|
(unparse-LPairs (reverse-pairs (parse-LPairs '(((a b . c) d e) f . g))))))
|
||
|
|
(test dot-after-ellipsis
|
||
|
|
(assert-equal?
|
||
|
|
'()
|
||
|
|
(unparse-LList (parse-LList '())))
|
||
|
|
(assert-equal?
|
||
|
|
'x
|
||
|
|
(unparse-LList (parse-LList 'x)))
|
||
|
|
(assert-equal?
|
||
|
|
'(a b c)
|
||
|
|
(unparse-LList (parse-LList '(a b c))))
|
||
|
|
(assert-equal?
|
||
|
|
'(a b c . d)
|
||
|
|
(unparse-LList (parse-LList '(a b c . d))))
|
||
|
|
(assert-equal?
|
||
|
|
'(((a b) (c d)) e . f)
|
||
|
|
(unparse-LList (parse-LList '(((a b) (c d)) e . f))))
|
||
|
|
(assert-equal?
|
||
|
|
'()
|
||
|
|
(unparse-LList (with-output-language (LList Expr) `())))
|
||
|
|
(assert-equal?
|
||
|
|
'x
|
||
|
|
(unparse-LList (with-output-language (LList Expr) `x)))
|
||
|
|
(assert-equal?
|
||
|
|
'(a b c)
|
||
|
|
(unparse-LList (with-output-language (LList Expr) `(a b c))))
|
||
|
|
(assert-equal?
|
||
|
|
'(a b c . d)
|
||
|
|
(unparse-LList (with-output-language (LList Expr) `(a b c . d))))
|
||
|
|
(assert-equal?
|
||
|
|
'(((a b) (c d)) e . f)
|
||
|
|
(unparse-LList (with-output-language (LList Expr) `(((a b) (c d)) e . f))))
|
||
|
|
(assert-equal?
|
||
|
|
'(() a b c)
|
||
|
|
(unparse-LList (swap-parts (with-output-language (LList Expr) `(a b c)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(d a b c)
|
||
|
|
(unparse-LList (swap-parts (with-output-language (LList Expr) `(a b c . d)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(f (() (() a b) (() c d)) e)
|
||
|
|
(unparse-LList (swap-parts (with-output-language (LList Expr) `(((a b) (c d)) e . f))))))
|
||
|
|
|
||
|
|
(test github-issue-7
|
||
|
|
(assert-equal?
|
||
|
|
'x
|
||
|
|
(unparse-Lx (parse-Lx 'x)))
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda (x . z) x)
|
||
|
|
(unparse-Lx (parse-Lx '(lambda (x . z) x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda (x y . z) x)
|
||
|
|
(unparse-Lx (parse-Lx '(lambda (x y . z) x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda x x)
|
||
|
|
(unparse-Lx (parse-Lx '(lambda x x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define (x y . z) z)
|
||
|
|
(unparse-Lx (parse-Lx '(define (x y . z) z))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define x x)
|
||
|
|
(unparse-Lx (parse-Lx '(define x x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define (l m . n)
|
||
|
|
(define g
|
||
|
|
(lambda (x . z)
|
||
|
|
(lambda (a . b)
|
||
|
|
(lambda (c . d)
|
||
|
|
l)))))
|
||
|
|
(unparse-Lx (parse-Lx '(define (l m . n)
|
||
|
|
(define g
|
||
|
|
(lambda (x . z)
|
||
|
|
(lambda (a . b)
|
||
|
|
(lambda (c . d)
|
||
|
|
l))))))))
|
||
|
|
(assert-equal?
|
||
|
|
'x
|
||
|
|
(unparse-Lx (with-output-language (Lx Expr) `x)))
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda (x . z) x)
|
||
|
|
(unparse-Lx (with-output-language (Lx Expr) `(lambda (x . z) x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda (x y . z) x)
|
||
|
|
(unparse-Lx (with-output-language (Lx Expr) `(lambda (x y . z) x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define (x y . z) z)
|
||
|
|
(unparse-Lx (with-output-language (Lx Expr) `(define (x y . z) z))))
|
||
|
|
(assert-equal?
|
||
|
|
'(lambda x x)
|
||
|
|
(unparse-Lx (with-output-language (Lx Expr) `(lambda x x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define x x)
|
||
|
|
(unparse-Lx (with-output-language (Lx Expr) `(define x x))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define (l m . n)
|
||
|
|
(define g
|
||
|
|
(lambda (x . z)
|
||
|
|
(lambda (a . b)
|
||
|
|
(lambda (c . d)
|
||
|
|
l)))))
|
||
|
|
(unparse-Lx (with-output-language (Lx Expr) `(define (l m . n)
|
||
|
|
(define g
|
||
|
|
(lambda (x . z)
|
||
|
|
(lambda (a . b)
|
||
|
|
(lambda (c . d)
|
||
|
|
l))))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define f (lambda (x . y) x))
|
||
|
|
(unparse-Lx (Px1 (parse-Lx '(define (f x . y) x)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define g (lambda (x y z . w) w))
|
||
|
|
(unparse-Lx (Px1 (parse-Lx '(define (g x y z . w) w)))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define h (lambda (x y . z) (define i (lambda (a b c . d) d))))
|
||
|
|
(unparse-Lx (Px1 (parse-Lx '(define (h x y . z) (define (i a b c . d) d))))))
|
||
|
|
(assert-equal?
|
||
|
|
'(define f (lambda x (define g (lambda y x))))
|
||
|
|
(unparse-Lx (Px1 (parse-Lx '(define (f . x) (define (g . y) x))))))))
|
||
|
|
|
||
|
|
(define-language LMULTI
|
||
|
|
(terminals
|
||
|
|
(var (x))
|
||
|
|
(primitive (pr))
|
||
|
|
(datum (d)))
|
||
|
|
(Expr (e)
|
||
|
|
(var x)
|
||
|
|
(primref pr)
|
||
|
|
(quote d)
|
||
|
|
(if e0 e1 e2)
|
||
|
|
(begin e0 ... e1)
|
||
|
|
(let ([x e] ...) e1)
|
||
|
|
(letrec ([x le] ...) e)
|
||
|
|
(app e0 e1 ...))
|
||
|
|
(LambdaExpr (le)
|
||
|
|
(lambda (x ...) e)
|
||
|
|
(case-lambda cl ...))
|
||
|
|
(CaseLambdaClause (cl)
|
||
|
|
(clause (x ...) e)))
|
||
|
|
|
||
|
|
(define-language L-error
|
||
|
|
(terminals
|
||
|
|
(symbol (x)))
|
||
|
|
(Expr (e body)
|
||
|
|
x
|
||
|
|
(lambda (x* ...) body* ... body)
|
||
|
|
(let ([x* e*] ...) body* ... body)
|
||
|
|
(let-values ([(x** ...) e*] ...) body* ... body)
|
||
|
|
(e e* ...)))
|
||
|
|
|
||
|
|
(define test-file
|
||
|
|
(let ()
|
||
|
|
(define-syntax foo (lambda (x) (syntax-violation 'foo "unexpected call to foo" x)))
|
||
|
|
(source-information-source-file (syntax->source-information #'foo))))
|
||
|
|
|
||
|
|
(test-suite error-messages
|
||
|
|
(test run-time-error-messages
|
||
|
|
(assert-error
|
||
|
|
(format-error-message "Exception in with-output-language: expected list of symbol but received x in field x* of (lambda (x* ...) body* ... body) from expression ~s at line 872, char 23 of ~a" ''x test-file)
|
||
|
|
(with-output-language (L-error Expr)
|
||
|
|
`(lambda (,'x ...) z)))
|
||
|
|
(assert-error
|
||
|
|
(format-error-message "Exception in with-output-language: expected list of list of symbol but received x** in field x** of ~s from expression ~s at line 876, char 29 of ~a" '(let-values (((x** ...) e*) ...) body* ... body) ''x** test-file)
|
||
|
|
(with-output-language (L-error Expr)
|
||
|
|
`(let-values ([(,'x** ...) ,'(y)] ...) z)))
|
||
|
|
))
|
||
|
|
|
||
|
|
;; regression test for error reported by R. Kent Dybvig:
|
||
|
|
|
||
|
|
(define-language L
|
||
|
|
(terminals
|
||
|
|
(symbol (x)))
|
||
|
|
(A (a) b)
|
||
|
|
(B (b) x))
|
||
|
|
|
||
|
|
(define-pass P1 : L (ir) -> L ()
|
||
|
|
(A : A (ir foo bar ignore) -> A ())
|
||
|
|
(B : B (ir foo bar) -> B ()
|
||
|
|
[else (printf "bar = ~s\n" bar) ir])
|
||
|
|
(A ir "I am not bar" "I am bar" "extra stuff"))
|
||
|
|
|
||
|
|
(define-pass P2 : L (ir) -> L ()
|
||
|
|
(A : A (ir foo bar ignore) -> A ())
|
||
|
|
(B : B (ir bar) -> B ()
|
||
|
|
[else (printf "bar = ~s\n" bar) ir])
|
||
|
|
(A ir "I am not bar" "I am bar" "extra stuff"))
|
||
|
|
|
||
|
|
(define-pass P3 : L (ir) -> L ()
|
||
|
|
(A : A (ir xxfoo xxbar ignore) -> A ())
|
||
|
|
(B : B (ir foo bar) -> B ()
|
||
|
|
[else (printf "bar = ~s\n" bar) ir])
|
||
|
|
(B2 : B (ir) -> B ()
|
||
|
|
[else (printf "calling B2\n") ir])
|
||
|
|
(A ir "I am not bar" "I am bar" "extra stuff"))
|
||
|
|
|
||
|
|
(define-pass P4 : L (ir) -> L ()
|
||
|
|
(A : A (ir) -> A ())
|
||
|
|
(B : B (ir [foo "I am not bar"] [bar "I am bar"]) -> B ()
|
||
|
|
[else (printf "bar = ~s\n" bar) ir])
|
||
|
|
(A ir))
|
||
|
|
|
||
|
|
(define-pass P5 : L (ir) -> L ()
|
||
|
|
(B : B (ir foo bar ignore) -> B ())
|
||
|
|
(symbol : symbol (ir foo bar) -> symbol ()
|
||
|
|
(printf "bar = ~s\n" bar)
|
||
|
|
ir)
|
||
|
|
(B ir "I am not bar" "I am bar" "extra stuff"))
|
||
|
|
|
||
|
|
(define-pass P6 : L (ir) -> L ()
|
||
|
|
(B : B (ir foo bar ignore) -> B ())
|
||
|
|
(symbol : symbol (ir bar) -> symbol ()
|
||
|
|
(printf "bar = ~s\n" bar)
|
||
|
|
ir)
|
||
|
|
(B ir "I am not bar" "I am bar" "extra stuff"))
|
||
|
|
|
||
|
|
(define-pass P7 : L (ir) -> L ()
|
||
|
|
(B : B (ir foo bar ignore) -> B ())
|
||
|
|
(symbol : symbol (ir xxfoo xxbar) -> symbol ()
|
||
|
|
(printf "bar = ~s\n" xxbar)
|
||
|
|
ir)
|
||
|
|
(symbol2 : symbol (ir) -> symbol ()
|
||
|
|
(printf "calling symbol2\n")
|
||
|
|
ir)
|
||
|
|
(B ir "I am not bar" "I am bar" "extra stuff"))
|
||
|
|
|
||
|
|
(define-pass P8 : L (ir) -> L ()
|
||
|
|
(B : B (ir) -> B ())
|
||
|
|
(symbol : symbol (ir [foo "I am not bar"] [bar "I am bar"]) -> symbol ()
|
||
|
|
(printf "bar = ~s\n" bar)
|
||
|
|
ir)
|
||
|
|
(B ir))
|
||
|
|
|
||
|
|
(define-pass P9 : L (ir foo bar ignore) -> L ()
|
||
|
|
(A : A (ir foo bar) -> A ()
|
||
|
|
[else (printf "bar = ~s\n" bar) ir]))
|
||
|
|
|
||
|
|
(define-pass P10 : L (ir foo bar ignore) -> L ()
|
||
|
|
(A : A (ir bar) -> A ()
|
||
|
|
[else (printf "bar = ~s\n" bar) ir]))
|
||
|
|
|
||
|
|
(define-pass P11 : L (ir foo bar ignore) -> L ()
|
||
|
|
(A : A (ir xxfoo xxbar) -> A ())
|
||
|
|
(A2 : A (ir) -> A ()
|
||
|
|
[else (printf "calling A2\n") ir]))
|
||
|
|
|
||
|
|
(define-pass P12 : L (ir) -> L ()
|
||
|
|
(A : A (ir [foo "I am not bar"] [bar "I am bar"]) -> A ()
|
||
|
|
[else (printf "bar = ~s\n" bar) ir]))
|
||
|
|
|
||
|
|
(test-suite argument-name-matching
|
||
|
|
(test sub-nonterminal-regression
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string (lambda () (P1 'q))))
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string (lambda () (P2 'q))))
|
||
|
|
(assert-equal?
|
||
|
|
"calling B2\n"
|
||
|
|
(with-output-to-string (lambda () (P3 'q))))
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string (lambda () (P4 'q)))))
|
||
|
|
(test sub-terminal-regression
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string (lambda () (P5 'q))))
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string (lambda () (P6 'q))))
|
||
|
|
(assert-equal?
|
||
|
|
"calling symbol2\n"
|
||
|
|
(with-output-to-string (lambda () (P7 'q))))
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string (lambda () (P8 'q)))))
|
||
|
|
(test sub-terminal-regression
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda () (P9 'q "I am not bar" "I am bar" "extra stuff"))))
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda () (P10 'q "I am not bar" "I am bar" "extra stuff"))))
|
||
|
|
(assert-equal?
|
||
|
|
"calling A2\n"
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda () (P11 'q "I am not bar" "I am bar" "extra stuff"))))
|
||
|
|
(assert-equal?
|
||
|
|
"bar = \"I am bar\"\n"
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda () (P12 'q))))))
|
||
|
|
|
||
|
|
(define (ski-combinator? x) (memq x '(S K I)))
|
||
|
|
|
||
|
|
(define-language Lski
|
||
|
|
(terminals
|
||
|
|
(ski-combinator (C)))
|
||
|
|
(Expr (e)
|
||
|
|
C
|
||
|
|
(e0 e1)))
|
||
|
|
|
||
|
|
(define-language Llc
|
||
|
|
(terminals
|
||
|
|
(symbol (x)))
|
||
|
|
(Expr (e)
|
||
|
|
x
|
||
|
|
(lambda (x) e)
|
||
|
|
(e0 e1)))
|
||
|
|
|
||
|
|
(define-pass ski->lc : Lski (ir) -> Llc ()
|
||
|
|
(definitions
|
||
|
|
(define-syntax with-variables
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ (x* ...) body0 body1 ...)
|
||
|
|
(let* ([x* (make-variable 'x*)] ...) body0 body1 ...)]))
|
||
|
|
(define counter 0)
|
||
|
|
(define inc-counter
|
||
|
|
(lambda ()
|
||
|
|
(let ([count counter])
|
||
|
|
(set! counter (fx+ count 1))
|
||
|
|
count)))
|
||
|
|
(define make-variable
|
||
|
|
(lambda (x)
|
||
|
|
(string->symbol
|
||
|
|
(format "~s.~s" x (inc-counter))))))
|
||
|
|
(Expr : Expr (e) -> Expr ()
|
||
|
|
[,C (case C
|
||
|
|
[(S) (with-variables (x y z)
|
||
|
|
`(lambda (,x)
|
||
|
|
(lambda (,y)
|
||
|
|
(lambda (,z)
|
||
|
|
((,x ,z) (,y ,z))))))]
|
||
|
|
[(K) (with-variables (x y)
|
||
|
|
`(lambda (,x)
|
||
|
|
(lambda (,y)
|
||
|
|
,x)))]
|
||
|
|
[(I) (with-variables (x)
|
||
|
|
`(lambda (,x) ,x))])]
|
||
|
|
[(,e0 ,e1)
|
||
|
|
(let* ([e0 (Expr e0)] [e1 (Expr e1)])
|
||
|
|
`(,e0 ,e1))]))
|
||
|
|
|
||
|
|
(define-pass ski-in : * (ir) -> Lski ()
|
||
|
|
(Expr : * (ir) -> Expr ()
|
||
|
|
(cond
|
||
|
|
[(memq ir '(S K I)) ir]
|
||
|
|
[(and (list? ir) (= (length ir) 2))
|
||
|
|
(let ([e0 (car ir)] [e1 (cdr ir)])
|
||
|
|
`(,(Expr e0) ,(Expr e1)))]
|
||
|
|
[else (errorf who "unrecognized ski input ~s" ir)]))
|
||
|
|
(Expr ir))
|
||
|
|
|
||
|
|
(define-pass lc-out : Llc (ir) -> * (sexpr)
|
||
|
|
(Expr : Expr (ir) -> * (sexpr)
|
||
|
|
[(lambda (,x) ,[sexpr]) `(lambda (,x) ,sexpr)]
|
||
|
|
[(,[sexpr0] ,[sexpr1]) `(,sexpr0 ,sexpr1)]
|
||
|
|
[,x x])
|
||
|
|
(Expr ir))
|
||
|
|
|
||
|
|
(test-suite pass-parser-unparser
|
||
|
|
(test pass-parsers
|
||
|
|
(assert-equal?
|
||
|
|
'((S K) I)
|
||
|
|
((pass-input-parser ski-in) '((S K) I)))
|
||
|
|
(assert-equal?
|
||
|
|
(with-output-language (Lski Expr)
|
||
|
|
`((S K) I))
|
||
|
|
((pass-input-parser ski->lc) '((S K) I)))
|
||
|
|
(assert-equal?
|
||
|
|
(with-output-language (Llc Expr)
|
||
|
|
`(lambda (x) (x x)))
|
||
|
|
((pass-input-parser lc-out) '(lambda (x) (x x)))))
|
||
|
|
(test pass-unparsers
|
||
|
|
(assert-equal?
|
||
|
|
'((S I) K)
|
||
|
|
((pass-output-unparser ski-in)
|
||
|
|
(with-output-language (Lski Expr)
|
||
|
|
`((S I) K))))
|
||
|
|
(assert-equal?
|
||
|
|
'((lambda (x) (x x)) (lambda (y) (y y)))
|
||
|
|
((pass-output-unparser ski->lc)
|
||
|
|
(with-output-language (Llc Expr)
|
||
|
|
`((lambda (x) (x x)) (lambda (y) (y y))))))
|
||
|
|
(assert-equal?
|
||
|
|
'bob
|
||
|
|
((pass-output-unparser lc-out) 'bob)))
|
||
|
|
(test pass-parser-unparser
|
||
|
|
(assert-equal?
|
||
|
|
'(((lambda (x.0) (lambda (y.1) x.0)) (lambda (x.2) x.2)) (lambda (x.3) x.3))
|
||
|
|
((pass-output-unparser ski->lc) (ski->lc ((pass-input-parser ski->lc) '((K I) I)))))))
|
||
|
|
|
||
|
|
)
|