2121 lines
80 KiB
Racket
2121 lines
80 KiB
Racket
#lang racket/base
|
|
(require racket/match
|
|
redex/reduction-semantics
|
|
(for-syntax racket/base)
|
|
"test.ss"
|
|
"r6rs.ss")
|
|
|
|
;; ============================================================
|
|
;; TESTING APPARATUS
|
|
|
|
;; test : p (from the r6 grammar) [the test]
|
|
;; expected : (list-of p)
|
|
(define-struct r6test (test expected))
|
|
|
|
(define (make-r6test/v t expected)
|
|
(make-r6test `(store () ,t)
|
|
(list `(store () (values ,expected)))))
|
|
(define (make-r6test/e t err)
|
|
(make-r6test `(store () ,t)
|
|
(list `(uncaught-exception (make-cond ,err)))))
|
|
|
|
(define (run-a-test test verbose?)
|
|
(unless verbose?
|
|
(printf ".")
|
|
(flush-output))
|
|
(let ([t (r6test-test test)]
|
|
[expected (r6test-expected test)])
|
|
(set! test-count (+ test-count 1))
|
|
(when verbose? (printf "testing ~s ... " t))
|
|
(flush-output)
|
|
(with-handlers ([exn:fail:duplicate?
|
|
(lambda (e)
|
|
(set! failed-tests (+ failed-tests 1))
|
|
(unless verbose?
|
|
(printf "\ntesting ~s ... " t))
|
|
(raise e))])
|
|
(let* ([results (evaluate reductions
|
|
t
|
|
(or verbose? 'dots)
|
|
(verify-p* t))])
|
|
(let ([rewritten-results (remove-duplicates (map rewrite-actual results))])
|
|
(for-each (verify-a* t) results)
|
|
(unless (set-same? expected rewritten-results equal?)
|
|
(set! failed-tests (+ failed-tests 1))
|
|
(unless verbose?
|
|
(printf "\ntesting ~s ... " t))
|
|
(printf "TEST FAILED!\nexpected:~a\nrewritten-received:~a\nreceived:~a\n\n"
|
|
(combine-in-lines expected)
|
|
(combine-in-lines rewritten-results)
|
|
(combine-in-lines results))))))))
|
|
|
|
(define p*-pattern (redex-match lang p*))
|
|
(define a*-pattern (redex-match lang a*))
|
|
(define r*-pattern (redex-match lang r*))
|
|
(define verified-terms 0)
|
|
(define ((verify-p* orig) sexp)
|
|
(let ([m (p*-pattern sexp)])
|
|
(unless (and m
|
|
(= 1 (length m)))
|
|
(newline)
|
|
(error 'verify-p* "matched ~a times\n ~s\norig\n ~s"
|
|
(if m
|
|
(length m)
|
|
"0")
|
|
sexp orig))
|
|
(set! verified-terms (+ verified-terms 1))))
|
|
|
|
(define ((verify-a* orig-sexp) sexp)
|
|
(unless (a*-pattern sexp)
|
|
(newline)
|
|
(error 'verify-a* "didn't match ~s\noriginal term ~s" sexp orig-sexp))
|
|
|
|
;; verify that observable is defined for this value
|
|
(let ([candidate-r* (term-let ((sexp sexp))
|
|
(term (observable sexp)))])
|
|
(unless (r*-pattern candidate-r*)
|
|
(error 'verify-a* "observable of ~s is ~s, but isn't an r*\noriginal term ~s"
|
|
sexp
|
|
candidate-r*
|
|
orig-sexp))))
|
|
|
|
(define (remove-duplicates lst)
|
|
(let ([ht (make-hash)])
|
|
(for-each (λ (x) (hash-set! ht x #t)) lst)
|
|
(hash-map ht (λ (x y) x))))
|
|
|
|
(define (combine-in-lines strs) (apply string-append (map (λ (x) (format "\n ~s" x)) strs)))
|
|
|
|
(define (rewrite-actual actual)
|
|
(match actual
|
|
[`(unknown ,str) actual]
|
|
[`(uncaught-exception ,v) actual]
|
|
[`(store ,xs ...)
|
|
(let loop ([actual actual])
|
|
(subst-:-vars actual))]
|
|
[_
|
|
(error 'rewrite-actual "unknown actual ~s\n" actual)]))
|
|
|
|
(define (subst-:-vars exp)
|
|
(match exp
|
|
[`(store ,str ,exps ...)
|
|
(let* ([pp-var? (λ (x) (regexp-match #rx"^[qmi]p" (format "~a" (car x))))]
|
|
[pp-bindings (filter pp-var? str)]
|
|
[with-out-pp (fp-sub pp-bindings `(store ,(filter (λ (x) (not (pp-var? x))) str) ,@exps))]
|
|
[with-out-app-vars (remove-unassigned-app-vars with-out-pp)]
|
|
[without-ri-vars (remove-unused-ri-vars with-out-app-vars)])
|
|
without-ri-vars)]
|
|
[`(unknown ,string) string]
|
|
[_ (error 'subst-:-vars "unknown exp ~s" exp)]))
|
|
|
|
(define (is-ri-var? x) (regexp-match #rx"^ri" (symbol->string x)))
|
|
|
|
(define (remove-unused-ri-vars exp)
|
|
(match exp
|
|
[`(store ,str ,exps ...)
|
|
(let ([ri-vars (filter is-ri-var? (map car str))]
|
|
[str-without-ri-binders
|
|
(filter (λ (binding) (not (is-ri-var? (car binding)))) str)])
|
|
`(store ,(filter (λ (binding)
|
|
(cond
|
|
[(is-ri-var? (car binding))
|
|
(not (not-in (car binding) (cons str-without-ri-binders exps)))]
|
|
[else #t]))
|
|
str)
|
|
,@exps))]))
|
|
|
|
(define (remove-unassigned-app-vars term)
|
|
(match term
|
|
[`(store ,bindings ,body)
|
|
(let* ([binding-rhss (map cadr bindings)]
|
|
[bindings-to-sub
|
|
(filter (λ (binding) (not (appears-in-set? (car binding) body)))
|
|
(filter (λ (binding) (regexp-match #rx"^bp" (format "~a" (car binding)))) bindings))]
|
|
[vars-to-sub (map car bindings-to-sub)])
|
|
`(store ,(filter (λ (binding) (not (memq (car binding) vars-to-sub))) bindings)
|
|
,(r6-all bindings-to-sub body)))]))
|
|
|
|
(define (not-in var e)
|
|
(cond
|
|
[(pair? e) (and (not-in var (car e))
|
|
(not-in var (cdr e)))]
|
|
[else (not (eq? var e))]))
|
|
|
|
(define (appears-in-set? x e)
|
|
(let loop ([e e])
|
|
(match e
|
|
[`(set! ,x2 ,e2) (or (eq? x x2)
|
|
(loop e2))]
|
|
[else
|
|
(and (list? e)
|
|
(ormap loop e))])))
|
|
|
|
|
|
(define (fp-sub bindings term)
|
|
(let loop ([term term])
|
|
(let ([next (do-one-subst bindings term)])
|
|
(cond
|
|
[(equal? term next) next]
|
|
[else (loop next)]))))
|
|
|
|
(define (r6-all sub-vars body)
|
|
(term-let ([(sub-vars ...) sub-vars]
|
|
[body body])
|
|
(term (r6rs-subst-many (sub-vars ... body)))))
|
|
|
|
(define (do-one-subst sub-vars term)
|
|
(match term
|
|
[`(store ,str ,exps ...)
|
|
(let* ([keep-vars
|
|
(map (λ (pr)
|
|
`(,(car pr)
|
|
,(r6-all sub-vars (cadr pr))))
|
|
str)])
|
|
`(store ,keep-vars ,@(r6-all sub-vars exps)))]))
|
|
|
|
(define test-count 0)
|
|
(define failed-tests 0)
|
|
|
|
(define arithmetic-tests
|
|
(list
|
|
(make-r6test/v '(+) 0)
|
|
(make-r6test/v '(+ 1) 1)
|
|
(make-r6test/v '(+ 1 2) 3)
|
|
(make-r6test/v '(+ 1 2 3) 6)
|
|
|
|
(make-r6test/v '(- 1) -1)
|
|
(make-r6test/v '(- 1 2) -1)
|
|
(make-r6test/v '(- 1 2 3) -4)
|
|
|
|
(make-r6test/v '(*) 1)
|
|
(make-r6test/v '(* 2) 2)
|
|
(make-r6test/v '(* 2 3) 6)
|
|
(make-r6test/v '(* 2 3 4) 24)
|
|
|
|
(make-r6test/v '(/ 2) 1/2)
|
|
(make-r6test/v '(/ 1 2) 1/2)
|
|
(make-r6test/v '(/ 1 2 3) 1/6)
|
|
|
|
(make-r6test/e '(/ #f) "arith-op applied to non-number")
|
|
|
|
(make-r6test/e '(/ 1 2 3 4 5 0 6) "divison by zero")
|
|
(make-r6test/e '(/ 0) "divison by zero")
|
|
|
|
(make-r6test '(store () ((lambda (x) (+ x x)) #f))
|
|
(list '(uncaught-exception (make-cond "arith-op applied to non-number"))))))
|
|
|
|
(define assignment-results-tests
|
|
(list
|
|
;; begin
|
|
(make-r6test/v '((lambda (x) (begin x (set! x 2) x)) 3)
|
|
2)
|
|
(make-r6test '(store () (letrec ([x 1]) (begin 2 (set! x 2))))
|
|
(list '(unknown "unspecified result")))
|
|
|
|
;; begin0
|
|
(make-r6test/v '((lambda (x) (begin0 x (set! x 2))) 3)
|
|
3)
|
|
(make-r6test '(store () (letrec ([x 1]) (begin0 (set! x 2) 2 3)))
|
|
(list '(unknown "unspecified result")))
|
|
(make-r6test/v '((lambda (x) (begin (begin0 (set! x 1) (set! x 2)) x)) 3)
|
|
2)
|
|
|
|
|
|
;; application
|
|
(make-r6test '(store () (letrec ([x 1]) ((lambda (x) 1) (set! x 2))))
|
|
(list '(unknown "unspecified result")))
|
|
(make-r6test '(store () (letrec ([x 1]) ((set! x 2) 2)))
|
|
(list '(unknown "unspecified result")))
|
|
|
|
;; if
|
|
(make-r6test '(store () (letrec ([x 1]) (if (set! x 2) 2 3)))
|
|
(list '(unknown "unspecified result")))
|
|
|
|
;; set!
|
|
(make-r6test '(store () (letrec ([x 1]) (set! x (set! x 2))))
|
|
(list '(unknown "unspecified result")))
|
|
|
|
(make-r6test '(store () (letrec ([x '(1)]) (set! x (set-car! x 2))))
|
|
(list '(unknown "unspecified result")
|
|
'(uncaught-exception (make-cond "can't set-car! on a non-pair or an immutable pair"))))
|
|
|
|
;; handlers
|
|
(make-r6test '(store () (letrec ([x 1]) (with-exception-handler (lambda (e) (set! x 2)) (lambda () (car 'x)))))
|
|
(list '(uncaught-exception (make-cond "handler returned"))))
|
|
|
|
;; call with values
|
|
(make-r6test '(store () (letrec ([x 1]) (call-with-values (lambda () (set! x 2)) +)))
|
|
(list '(unknown "unspecified result")))
|
|
|
|
;; dynamic-wind
|
|
(make-r6test/v '((lambda (x) (dynamic-wind (lambda () (set! x 0)) (lambda () x) (lambda () (set! x 2)))) 1)
|
|
0)
|
|
(make-r6test '(store () (letrec ([x 1]) (dynamic-wind (lambda () 0) (lambda () (set! x 2)) (lambda () 1))))
|
|
(list '(unknown "unspecified result")))
|
|
(make-r6test '(store () (letrec ([x 1]) (begin (dynamic-wind (lambda () 0) (lambda () (set! x 2)) (lambda () 1)) 5)))
|
|
(list '(store ((lx-x 2)) (values 5))))))
|
|
|
|
(define basic-form-tests
|
|
(list
|
|
|
|
(make-r6test/e '((lambda (x y) x) (lambda (x) x))
|
|
"arity mismatch")
|
|
|
|
(make-r6test/v '(if #t 12 13) 12)
|
|
(make-r6test/v '(if #f 12 13) 13)
|
|
(make-r6test/v '(begin (if #f 12 14) 14) 14)
|
|
(make-r6test/v '((lambda (x) (if #t (set! x 45) 'x) x) 1) 45)
|
|
(make-r6test/v '((lambda (x) (if #f (set! x 45) 'z) x) 1) 1)
|
|
|
|
;; begin0 tests
|
|
(make-r6test/v '(begin0 (+ 1 1))
|
|
2)
|
|
(make-r6test/v '(begin0 (+ 1 1) (+ 2 3))
|
|
2)
|
|
(make-r6test/v '((lambda (x) (begin0 x (set! x 4))) 2)
|
|
2)
|
|
(make-r6test/v '(((lambda (x) (begin0 (lambda () x) (set! x (+ x 1)) (set! x (+ x 1)) (set! x (+ x 1))))
|
|
2))
|
|
5)))
|
|
|
|
(define pair-tests
|
|
(list
|
|
(make-r6test/v '(if (null? (cons 1 (cons 2 (cons (lambda (x) x) null)))) 0 1)
|
|
1)
|
|
(make-r6test/v '(null? (cons 1 (cons 2 (cons (lambda (x) x) null)))) #f)
|
|
(make-r6test/v '(null? (cons 1 2)) #f)
|
|
(make-r6test/v '(null? null) #t)
|
|
(make-r6test/v '(pair? null) #f)
|
|
(make-r6test/v '(pair? (cons 1 1)) #t)
|
|
(make-r6test/v '(null? (list 1 2)) #f)
|
|
(make-r6test/v '(pair? (list 1)) #t)
|
|
(make-r6test/v '(pair? (list)) #f)
|
|
(make-r6test/v '(null? (list)) #t)
|
|
|
|
(make-r6test/v '((lambda (x) ((lambda (y) (car (cdr x))) (begin (set-car! (cdr x) 400) 11)))
|
|
(cons 1 (cons 2 null)))
|
|
400)
|
|
(make-r6test/v '((lambda (x) ((lambda (y) (cdr (cdr x))) (begin (set-cdr! (cdr x) 400) 12)))
|
|
(cons 1 (cons 2 null)))
|
|
400)
|
|
(make-r6test '(store () ((lambda (x) (set-cdr! x 4) (cdr x)) '(3)))
|
|
(list '(store () (values 4))
|
|
'(uncaught-exception (make-cond "can't set-cdr! on a non-pair or an immutable pair"))))
|
|
(make-r6test '(store () ((lambda (x) (set-car! x 4) (car x)) '(3)))
|
|
(list '(store () (values 4))
|
|
'(uncaught-exception (make-cond "can't set-car! on a non-pair or an immutable pair"))))
|
|
|
|
(make-r6test '(store ()
|
|
(letrec ([first-time? #t]
|
|
[f (lambda y (if first-time?
|
|
(begin
|
|
(set! first-time? #f)
|
|
(set-car! y 2))
|
|
(car y)))]
|
|
[g (lambda () (apply f '(1)))])
|
|
(g)
|
|
(g)))
|
|
(list '(store ((lx-first-time? #f)
|
|
(lx-f (lambda y (if lx-first-time?
|
|
(begin
|
|
(set! lx-first-time? #f)
|
|
(set-car! y 2))
|
|
(car y))))
|
|
(lx-g (lambda () (apply lx-f (cons 1 null)))))
|
|
(values 1))))))
|
|
|
|
(define quote-tests
|
|
(list
|
|
(make-r6test/v ''#f #f)
|
|
(make-r6test/v ''#t #t)
|
|
(make-r6test/v ''1 1)
|
|
(make-r6test/v ''x ''x)
|
|
(make-r6test/v ''null ''null)
|
|
(make-r6test/v '(null? 'null) #f)
|
|
(make-r6test/v ''unspecified ''unspecified)
|
|
(make-r6test/v '((lambda (x) (eqv? 'x 1)) 1) #f)))
|
|
|
|
(define eqv-tests
|
|
(list
|
|
(make-r6test '(store () (eqv? (lambda (x) x) (lambda (x) x)))
|
|
(list '(unknown "equivalence of procedures")))
|
|
(make-r6test '(store () (eqv? (lambda (x) x) (lambda (x) x)))
|
|
(list '(unknown "equivalence of procedures")))
|
|
(make-r6test '(store () ((lambda (x) (eqv? x x)) (lambda (x) x)))
|
|
(list '(unknown "equivalence of procedures")))
|
|
|
|
(make-r6test/v '(eqv? (cons 1 2) (cons 1 2)) #f)
|
|
(make-r6test/v '((lambda (x) (eqv? x x)) (cons 1 2)) #t)
|
|
|
|
(make-r6test '(store () (apply apply values '(())))
|
|
(list '(store () (values))))
|
|
|
|
(make-r6test/v '(eqv? #t #t) #t)
|
|
(make-r6test/v '(eqv? #t #f) #f)
|
|
|
|
(make-r6test/v '(eqv? 'x 'y) #f)
|
|
(make-r6test/v '(eqv? 'y 'y) #t)
|
|
|
|
(make-r6test/v '(eqv? (lambda (x) x) #t) #f)
|
|
(make-r6test/v '(eqv? #t (lambda (x) x)) #f)
|
|
(make-r6test/v '(eqv? '() null) #t)
|
|
|
|
(make-r6test '(store () (eqv? '(a) '(a)))
|
|
(list '(store () (values #f))))
|
|
(make-r6test '(store () (eqv? '(a) '(b)))
|
|
(list '(store () (values #f))))
|
|
(make-r6test '(store () ((lambda (x) (eqv? x x)) '(a)))
|
|
(list '(store () (values #t))))
|
|
|
|
(make-r6test '(store ()
|
|
(eqv?
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
k
|
|
(lambda () (car 'x)))))
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
k
|
|
(lambda () (car)))))))
|
|
(list '(store () (values #f))
|
|
'(store () (values #t))))
|
|
(make-r6test '(store ()
|
|
((lambda (x) (eqv? x x))
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
k
|
|
(lambda () (car 'x)))))))
|
|
(list '(store () (values #f))
|
|
'(store () (values #t))))
|
|
|
|
(make-r6test/v '(eqv?
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
k
|
|
(lambda () (car 'x)))))
|
|
#f)
|
|
#f)
|
|
(make-r6test/v '(eqv?
|
|
#f
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
k
|
|
(lambda () (car 'x))))))
|
|
#f)
|
|
(make-r6test/v '(eqv?
|
|
(lambda (x) x)
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
k
|
|
(lambda () (car 'x))))))
|
|
#f)
|
|
(make-r6test/v '(eqv?
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
k
|
|
(lambda () (car 'x)))))
|
|
(lambda (x) x))
|
|
#f)))
|
|
|
|
(define err-tests
|
|
(list
|
|
|
|
(make-r6test/e '(call-with-values (lambda (x) x) (lambda (y) y))
|
|
"arity mismatch")
|
|
(make-r6test/e '(/) "arity mismatch")
|
|
(make-r6test/e '(-) "arity mismatch")
|
|
(make-r6test/e '(cons) "arity mismatch")
|
|
(make-r6test/e '(null?) "arity mismatch")
|
|
(make-r6test/e '(pair?) "arity mismatch")
|
|
(make-r6test/e '(car) "arity mismatch")
|
|
(make-r6test/e '(cdr) "arity mismatch")
|
|
(make-r6test/e '(set-car!) "arity mismatch")
|
|
(make-r6test/e '(set-cdr!) "arity mismatch")
|
|
(make-r6test/e '(call/cc) "arity mismatch")
|
|
(make-r6test/e '(eqv?) "arity mismatch")
|
|
(make-r6test/e '(apply) "arity mismatch")
|
|
(make-r6test/e '(apply values) "arity mismatch")
|
|
(make-r6test/e '(call-with-values) "arity mismatch")
|
|
|
|
(make-r6test/e '(dynamic-wind 1) "arity mismatch")
|
|
|
|
(make-r6test/e '(apply 1 2) "can't apply non-procedure")
|
|
(make-r6test/e '(apply 1 null) "can't apply non-procedure")
|
|
(make-r6test/e '(apply values 2) "apply's last argument non-list")
|
|
(make-r6test/e '(car 1) "can't take car of non-pair")
|
|
(make-r6test/e '(cdr 1) "can't take cdr of non-pair")
|
|
(make-r6test/e '(set-car! 2 1) "can't set-car! on a non-pair or an immutable pair")
|
|
(make-r6test/e '(set-cdr! 1 2) "can't set-cdr! on a non-pair or an immutable pair")
|
|
|
|
(make-r6test/e '(call/cc 1) "can't call non-procedure")
|
|
(make-r6test/e '(call-with-values 1 2) "can't call non-procedure")))
|
|
|
|
(define r5-tests
|
|
(list
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; tests from R5RS
|
|
;;
|
|
|
|
; ----
|
|
; 4.1.3
|
|
(make-r6test/v '(+ 3 4) 7)
|
|
(make-r6test/v '((if #f + *) 3 4) 12)
|
|
|
|
|
|
; ----
|
|
; 4.1.4
|
|
(make-r6test/v '(lambda (x) (+ x x)) '(lambda (x) (+ x x)))
|
|
(make-r6test/v '((lambda (x) (+ x x)) 4) 8)
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ([reverse-subtract
|
|
(lambda (x y) (- y x))])
|
|
(reverse-subtract 7 10)))
|
|
(list
|
|
'(store ((lx-reverse-subtract (lambda (x y) (- y x))))
|
|
(values 3))))
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ([add4
|
|
((lambda (x)
|
|
(lambda (y)
|
|
(+ x y)))
|
|
4)])
|
|
(add4 6)))
|
|
(list
|
|
'(store ((lx-add4 (lambda (y) (+ 4 y))))
|
|
(values 10))))
|
|
|
|
(make-r6test/v '((lambda x x) 3 4 5 6)
|
|
'(cons 3 (cons 4 (cons 5 (cons 6 null)))))
|
|
(make-r6test/v '((lambda (x y dot z) z) 3 4 5 6)
|
|
'(cons 5 (cons 6 null)))
|
|
|
|
; ----
|
|
; 4.2.2
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ([even?
|
|
(lambda (n)
|
|
(if (eqv? 0 n)
|
|
#t
|
|
(odd? (- n 1))))]
|
|
[odd?
|
|
(lambda (n)
|
|
(if (eqv? 0 n)
|
|
#f
|
|
(even? (- n 1))))])
|
|
;; using 88 here runs, but isn't really much more useful
|
|
;; for testing purposes (it also takes > 1000 reductions)
|
|
(even? 2)))
|
|
(list
|
|
'(store ((lx-even?
|
|
(lambda (n)
|
|
(if (eqv? 0 n)
|
|
#t
|
|
(lx-odd? (- n 1)))))
|
|
(lx-odd?
|
|
(lambda (n)
|
|
(if (eqv? 0 n)
|
|
#f
|
|
(lx-even? (- n 1))))))
|
|
|
|
(values #t))))
|
|
|
|
; ----
|
|
; 4.2.3
|
|
(make-r6test '(store () (letrec* ([x 0]) (begin (set! x 5) (+ x 1))))
|
|
(list '(store ((lx-x 5)) (values 6))))
|
|
|
|
|
|
; ----
|
|
; 5.2.1
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ([add3 (lambda (x) (+ x 3))])
|
|
(add3 3)))
|
|
(list '(store ((lx-add3 (lambda (x) (+ x 3)))) (values 6))))
|
|
(make-r6test '(store () (letrec* ((first car))
|
|
(first '(1 2))))
|
|
(list '(store ((lx-first car)) (values 1))))
|
|
|
|
|
|
; ----
|
|
; 6.1
|
|
|
|
(make-r6test/v '(eqv? 'a 'a) #t)
|
|
(make-r6test/v '(eqv? 'a 'b) #f)
|
|
(make-r6test/v '(eqv? 2 2) #t)
|
|
(make-r6test/v '(eqv? '() '()) #t)
|
|
(make-r6test/v '(eqv? 100000000 100000000) #t)
|
|
(make-r6test/v '(eqv? (cons 1 2) (cons 1 2)) #f)
|
|
(make-r6test '(store () (eqv? (lambda () 1) (lambda () 2)))
|
|
(list '(unknown "equivalence of procedures")))
|
|
(make-r6test/v '(eqv? #f 'nil) #f)
|
|
(make-r6test/v '(eqv? #f '()) #f)
|
|
(make-r6test '(store () ((lambda (p) (eqv? p p)) (lambda (x) x)))
|
|
(list '(unknown "equivalence of procedures")))
|
|
|
|
(make-r6test
|
|
'(store ()
|
|
(letrec* ([gen-counter
|
|
(lambda ()
|
|
((lambda (n)
|
|
(lambda () (set! n (+ n 1)) n))
|
|
0))])
|
|
((lambda (g) (eqv? g g))
|
|
(gen-counter))))
|
|
(list '(unknown "equivalence of procedures")))
|
|
|
|
(make-r6test
|
|
'(store ()
|
|
(letrec* ((gen-counter
|
|
(lambda ()
|
|
((lambda (n)
|
|
(lambda () (set! n (+ n 1)) n))
|
|
0))))
|
|
(eqv? (gen-counter) (gen-counter))))
|
|
(list '(unknown "equivalence of procedures")))
|
|
|
|
|
|
|
|
; ----
|
|
; 6.3.2
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ([x (list 'a 'b 'c)]
|
|
[y x])
|
|
y))
|
|
(list
|
|
'(store ((lx-x (cons 'a (cons 'b (cons 'c null))))
|
|
(lx-y (cons 'a (cons 'b (cons 'c null)))))
|
|
(values (cons 'a (cons 'b (cons 'c null)))))))
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ((x (list 'a 'b 'c))
|
|
(y x))
|
|
(set-cdr! x 4)
|
|
x))
|
|
(list
|
|
'(store ((lx-x (cons 'a 4))
|
|
(lx-y (cons 'a 4)))
|
|
(values (cons 'a 4)))))
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ((x (list 'a 'b 'c))
|
|
(y x))
|
|
(set-cdr! x 4)
|
|
(eqv? x y)))
|
|
(list
|
|
'(store ((lx-x (cons 'a 4))
|
|
(lx-y (cons 'a 4)))
|
|
(values #t))))
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ((x (list 'a 'b 'c))
|
|
(y x))
|
|
(set-cdr! x 4)
|
|
y))
|
|
(list
|
|
'(store ((lx-x (cons 'a 4))
|
|
(lx-y (cons 'a 4)))
|
|
(values (cons 'a 4)))))
|
|
|
|
; ----
|
|
; 6.4
|
|
(make-r6test/v '(apply + (list 3 4)) 7)
|
|
|
|
(make-r6test
|
|
'(store ()
|
|
(letrec* ([compose
|
|
(lambda (f g)
|
|
(lambda args
|
|
(f (apply g args))))]
|
|
|
|
[sqrt (lambda (x) (if (eqv? x 900) 30 #f))])
|
|
((compose sqrt *) 12 75)))
|
|
(list '(store ((lx-compose (lambda (f g)
|
|
(lambda args
|
|
(f (apply g args)))))
|
|
(lx-sqrt (lambda (x) (if (eqv? x 900) 30 #f))))
|
|
(values 30))))))
|
|
|
|
(define (conv-base base vec)
|
|
(let loop ([i (vector-length vec)]
|
|
[acc 0])
|
|
(cond
|
|
[(zero? i) acc]
|
|
[else (loop (- i 1)
|
|
(+ acc (* (expt base (- i 1))
|
|
(vector-ref vec (- i 1)))))])))
|
|
|
|
(define (deconv-base base number)
|
|
(list->vector
|
|
(let loop ([i number])
|
|
(cond
|
|
[(zero? i) '()]
|
|
[else (cons (modulo i base)
|
|
(loop (quotient i base)))]))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; app tests
|
|
;;
|
|
|
|
(define app-tests
|
|
(list
|
|
(make-r6test/v '((lambda () 1)) 1)
|
|
(make-r6test/v '(((lambda (x) (lambda (x) x)) 1) 2) 2)
|
|
(make-r6test/v '(((lambda (x) (lambda (x dot y) x)) 1) 2) 2)
|
|
(make-r6test/v '(((lambda (x) (lambda (y dot x) (car x))) 1) 2 3) 3)
|
|
(make-r6test/e '((lambda (x y) x) 1) "arity mismatch")
|
|
(make-r6test/v '(car ((lambda (x) (cons x null)) 3)) 3)
|
|
(make-r6test/v '((lambda (x) x) 3) 3)
|
|
(make-r6test/v '((lambda (x y) (- x y)) 6 5) 1)
|
|
(make-r6test/e '((lambda () (+ 1 2 3)) 3 4 5)
|
|
"arity mismatch")
|
|
(make-r6test/v '((lambda (x y z) (+ x y z)) 3 4 5) 12)
|
|
(make-r6test/v '((lambda (x y) (+ x y)) (+ 1 2) (+ 3 4)) 10)
|
|
(make-r6test/v '((lambda (x1 x2 dot y) (car y)) 1 2 3 4) 3)
|
|
(make-r6test/v '((lambda (x dot y) (car y)) 1 2 3 4) 2)
|
|
(make-r6test/v '((lambda (x dot y) x) 1) 1)
|
|
(make-r6test/e '((lambda (x y dot z) x) 1)
|
|
"arity mismatch")
|
|
(make-r6test/v '((lambda args (car (cdr args))) 1 2 3 4 5 6) 2)
|
|
(make-r6test/v '((lambda args (eqv? args args)) 1 2) #t)
|
|
(make-r6test/v '((lambda args ((lambda (y) args) (begin (set! args 50) 123)))) 50)
|
|
(make-r6test '(store () ((lambda args ((lambda (y) args) (set! args 50)))))
|
|
(list '(unknown "unspecified result")))
|
|
(make-r6test/v '(if ((lambda (x) x) 74) ((lambda () 6)) (6 54)) 6)
|
|
(make-r6test/e '(1 1) "can't call non-procedure")
|
|
(make-r6test/e '(if ((lambda (x) x) #f) ((lambda () 6)) (6 54))
|
|
"can't call non-procedure")
|
|
|
|
(make-r6test '(store () (- 1))
|
|
(list '(store () (values -1))))
|
|
|
|
(make-r6test '(store () (- (- 1)))
|
|
(list '(store () (values 1))))
|
|
|
|
(make-r6test '(store ((x 1)) (begin (set! x (begin (set! x (- x)) (- x))) x))
|
|
(list '(store ((x 1)) (values 1))))
|
|
|
|
(make-r6test '(store ((x 1))
|
|
((lambda (p q) x)
|
|
(begin (set! x (- x)) 1)
|
|
(begin (set! x (- x)) 1)))
|
|
(list '(store ((x 1))
|
|
(values 1))))
|
|
|
|
(make-r6test '(store ((x 1))
|
|
((lambda (p q) 1)
|
|
(begin (set! x 5) 1)
|
|
(begin (set! x 6) 2)))
|
|
(list '(store ((x 5)) (values 1))
|
|
'(store ((x 6)) (values 1))))
|
|
|
|
(make-r6test/v '(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
(lambda (e) (k e))
|
|
(lambda () (apply (lambda (x y) x) 1 null)))))
|
|
'(make-cond "arity mismatch"))
|
|
|
|
(make-r6test/v '((lambda (x) ((lambda (y) x) (begin (set! x 5) 'whatever))) 3) 5)
|
|
(make-r6test '(store ()
|
|
(((lambda (a b ret) ((lambda (x y) ret) (begin (set! ret a) #f)
|
|
(begin (set! ret b) #t)))
|
|
(lambda () 1)
|
|
(lambda () 3)
|
|
5)))
|
|
'((store () (values 1))
|
|
(store () (values 3))))
|
|
|
|
(make-r6test/v (let ([Y '(lambda (le)
|
|
((lambda (f) (f f))
|
|
(lambda (f)
|
|
(le (lambda (z) ((f f) z))))))])
|
|
`((,Y
|
|
(lambda (length)
|
|
(lambda (l)
|
|
(if (null? l)
|
|
0
|
|
(+ (length (cdr l)) 1)))))
|
|
(cons 1 null)))
|
|
1)
|
|
(make-r6test/v '((lambda (x y) (+ x y)) ((lambda (x) x) 3) ((lambda (x) x) 4))
|
|
7)
|
|
(make-r6test/v '((lambda (x) ((lambda (a b) x) (begin (set! x (- x)) 'x)
|
|
(begin (set! x (- x)) 'y)))
|
|
1)
|
|
1)
|
|
|
|
(make-r6test/v '((lambda (x) (begin (set! x 5) (set! x 4) (set! x 3) x)) 0) 3)
|
|
(make-r6test/v '((lambda (x y) (x y)) + 0) 0)
|
|
(make-r6test/v '(apply + (cons 1 (cons 2 null))) 3)
|
|
(make-r6test '(store ()
|
|
((lambda (x) (set-cdr! x x) (apply + x))
|
|
(cons 1 #f)))
|
|
(list '(uncaught-exception (make-cond "apply called on circular list"))))
|
|
|
|
(make-r6test '(store ()
|
|
((lambda (x)
|
|
(set-cdr! (cdr x) x)
|
|
(apply + x))
|
|
(cons 1 (cons 2 #f))))
|
|
(list '(uncaught-exception (make-cond "apply called on circular list"))))
|
|
|
|
;; app
|
|
(make-r6test/v '((lambda args (apply + args)) 1 2 3 4) 10)
|
|
(make-r6test/v '((lambda (f) (eqv? (f 1) (f 1))) (lambda args (car args))) #t)
|
|
(make-r6test '(store ()
|
|
(letrec* ((length
|
|
(lambda (l)
|
|
(if (null? l)
|
|
0
|
|
(+ 1 (length (cdr l)))))))
|
|
(length (list 1 2 3))))
|
|
(list '(store ((lx-length
|
|
(lambda (l)
|
|
(if (null? l)
|
|
0
|
|
(+ 1 (lx-length (cdr l)))))))
|
|
(values 3))))
|
|
(make-r6test '(store () ((lambda (x)
|
|
(set! x (x
|
|
(begin (set! x +) 4)
|
|
(begin (set! x *) 2)))
|
|
x)
|
|
/))
|
|
(list '(store () (values 2))
|
|
'(store () (values 6))
|
|
'(store () (values 8))))
|
|
|
|
(make-r6test '(store () ((lambda (x)
|
|
(set! x (x
|
|
(begin (set! x +) 12)
|
|
(begin (set! x *) 2)
|
|
(begin (set! x -) 2)))
|
|
x)
|
|
/))
|
|
(list '(store () (values 3))
|
|
'(store () (values 16))
|
|
'(store () (values 8))
|
|
'(store () (values 48))))
|
|
|
|
(make-r6test '(store ()
|
|
((lambda (x)
|
|
(set! x (x (begin (set! x *) 2)))
|
|
x)
|
|
/))
|
|
(list '(store () (values 2))
|
|
'(store () (values 1/2))))
|
|
|
|
;; test non-determinism in spec (a single application can go two different ways
|
|
;; at two different times)
|
|
(make-r6test '(store ()
|
|
(letrec ((x null)
|
|
(twice (lambda (f) (f) (f))))
|
|
(twice
|
|
(lambda ()
|
|
((lambda (p q) 1)
|
|
(begin (set! x (cons 1 x)) 'foo)
|
|
(begin (set! x (cons 2 x)) 'bar))))))
|
|
(list
|
|
'(store ((lx-x (cons 1 (cons 2 (cons 1 (cons 2 null)))))
|
|
(lx-twice (lambda (f) (f) (f))))
|
|
(values 1))
|
|
'(store ((lx-x (cons 2 (cons 1 (cons 1 (cons 2 null)))))
|
|
(lx-twice (lambda (f) (f) (f))))
|
|
(values 1))
|
|
'(store ((lx-x (cons 1 (cons 2 (cons 2 (cons 1 null)))))
|
|
(lx-twice (lambda (f) (f) (f))))
|
|
(values 1))
|
|
'(store ((lx-x (cons 2 (cons 1 (cons 2 (cons 1 null)))))
|
|
(lx-twice (lambda (f) (f) (f))))
|
|
(values 1))))
|
|
|
|
(make-r6test/v '(condition? (make-cond "xyz")) #t)
|
|
(make-r6test/v '(condition? 1) #f)
|
|
(make-r6test/v '(procedure?
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler k (lambda () (car 'x))))))
|
|
#f)
|
|
(make-r6test/v '(condition?
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler k (lambda () (car 'x))))))
|
|
#t)
|
|
|
|
;; test capture avoiding substitution
|
|
(make-r6test '(store ()
|
|
(letrec ((x 1))
|
|
(((lambda (f) (lambda (x) (+ x (f))))
|
|
(lambda () x))
|
|
2)))
|
|
(list '(store ((lx-x 1)) (values 3))))
|
|
|
|
(make-r6test '(store ()
|
|
(((lambda (x1) (lambda (x) x))
|
|
3)
|
|
4))
|
|
(list '(store () (values 4))))
|
|
(make-r6test '(store ()
|
|
(((lambda (x)
|
|
(lambda args (car args)))
|
|
1)
|
|
2))
|
|
(list '(store () (values 2))))
|
|
|
|
(make-r6test '(store ()
|
|
(letrec ((x 1))
|
|
(((lambda (f) (lambda (y dot x) (f)))
|
|
(lambda () x))
|
|
2)))
|
|
(list '(store ((lx-x 1)) (values 1))))
|
|
|
|
(make-r6test/v '((lambda (x y dot z) (set! z (cons x z)) (set! z (cons y z)) (apply + z))
|
|
1 2 3 4)
|
|
'10)
|
|
|
|
(make-r6test '(store ()
|
|
(letrec ((g (lambda (y) y))
|
|
(f (lambda (x) (g 1))))
|
|
(((lambda (x) (lambda (g) (g x))) f)
|
|
(lambda (x) 17))))
|
|
(list '(store ((lx-g (lambda (y) y))
|
|
(lx-f (lambda (x) (lx-g 1))))
|
|
(values 17))))))
|
|
|
|
(define mv-tests
|
|
(list
|
|
(make-r6test
|
|
'(store () ((lambda (x) x) (values (lambda (y) y))))
|
|
(list '(store () (values (lambda (y) y)))))
|
|
(make-r6test
|
|
'(store () (call-with-values (lambda () (lambda (y) y)) (lambda (x) x)))
|
|
(list '(store () (values (lambda (y) y)))))
|
|
(make-r6test
|
|
'(store () (call-with-values
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda () ((lambda (z) z) (lambda (q) q)))
|
|
(lambda (y) y)))
|
|
(lambda (x) x)))
|
|
(list '(store () (values (lambda (q) q)))))
|
|
(make-r6test
|
|
'(store () (call-with-values
|
|
(lambda ()
|
|
(call-with-values (lambda () (values (lambda (p) p)))
|
|
(((lambda (z) z) (lambda (a) (a a))) (lambda (m) m))))
|
|
(call-with-values (lambda () (values (lambda (q) q))) (lambda (x) (lambda (y) x)))))
|
|
(list '(store () (values (lambda (q) q)))))
|
|
|
|
|
|
(make-r6test
|
|
'(store () ((lambda (x) x) call-with-values))
|
|
(list '(store () (values call-with-values))))
|
|
(make-r6test
|
|
'(store () (values))
|
|
(list '(store () (values))))
|
|
(make-r6test
|
|
'(store () (values (lambda (x) x)))
|
|
(list '(store () (values (lambda (x) x)))))
|
|
(make-r6test
|
|
'(store () (values (lambda (x) x) (lambda (q) q)))
|
|
(list '(store () (values (lambda (x) x) (lambda (q) q)))))
|
|
|
|
(make-r6test
|
|
'(store () (call-with-values (values values) (lambda () (lambda (x) x))))
|
|
(list '(store () (values (lambda (x) x)))))
|
|
(make-r6test
|
|
'(store () ((lambda (x) x) (values (lambda (y) y))))
|
|
(list '(store () (values (lambda (y) y)))))
|
|
(make-r6test
|
|
'(store () (call-with-values (lambda () (lambda (y) y)) (lambda (x) x)))
|
|
(list '(store () (values (lambda (y) y)))))
|
|
|
|
(make-r6test
|
|
'(store ()
|
|
(call-with-values
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda ()
|
|
((lambda (z) z) (lambda (q) q)))
|
|
(lambda (y) y)))
|
|
(lambda (x) x)))
|
|
(list '(store () (values (lambda (q) q)))))
|
|
|
|
(make-r6test
|
|
'(store ()
|
|
(call-with-values
|
|
(lambda ()
|
|
(call-with-values (lambda ()
|
|
(values (lambda (p) p)))
|
|
(((lambda (x) x) (lambda (x) (x x))) (lambda (m) m))))
|
|
(call-with-values (lambda () (values (lambda (q) q)))
|
|
(lambda (x) (lambda (y) x)))))
|
|
(list '(store () (values (lambda (q) q)))))
|
|
|
|
(make-r6test
|
|
'(store () (call-with-values (lambda () (values values values)) call-with-values))
|
|
(list '(store () (values))))
|
|
|
|
(make-r6test
|
|
'(store () ((lambda (x y) x) (values (lambda (z) z) (lambda (q) q))))
|
|
(list '(unknown "context expected one value, received 2")))
|
|
|
|
(make-r6test
|
|
'(store () (begin (if #t 1 2) 3))
|
|
(list '(store () (values 3))))
|
|
|
|
|
|
(make-r6test
|
|
'(store () ((if (values 1 2 3 4 5 6 7 8 9 10) 11 12)))
|
|
(list '(unknown "context expected one value, received 10")))
|
|
|
|
|
|
(make-r6test
|
|
'(store () (if (begin 1 2) 1 2))
|
|
(list '(store () (values 1))))
|
|
|
|
(make-r6test
|
|
'(store () ((lambda (x) (begin (set! x (begin 1 2)) x)) 1))
|
|
(list '(store () (values 2))))
|
|
|
|
(make-r6test/v '(call/cc (lambda (k) (cons 1 (cons 2 (cons 3 (k 5)))))) 5)
|
|
(make-r6test/v '(call-with-values (lambda () (call/cc (lambda (k) (k)))) +) 0)
|
|
(make-r6test/v '(call-with-values (lambda () (call/cc (lambda (k) (k 1 2)))) +) 3)
|
|
(make-r6test/v '((call/cc values) values) 'values)
|
|
(make-r6test '(store ()
|
|
(letrec ((x 0)
|
|
(f
|
|
(lambda ()
|
|
(set! x (+ x 1))
|
|
(values x x))))
|
|
(call-with-values f (lambda (x y) x))
|
|
(call-with-values f (lambda (x y) x))))
|
|
(list
|
|
'(store ((lx-x 2)
|
|
(lx-f (lambda ()
|
|
(set! lx-x (+ lx-x 1))
|
|
(values lx-x lx-x))))
|
|
(values 2))))
|
|
(make-r6test/v '((lambda (x) (call-with-values x (lambda (x y) x)))
|
|
(lambda () (values (+ 1 2) 2)))
|
|
3)
|
|
|
|
(make-r6test/v '((if #t call-with-values +) (lambda () (+ 1 1)) (lambda (x) x))
|
|
2)
|
|
|
|
(make-r6test/v '(call-with-values (lambda () (values (+ 1 2) (+ 2 3))) +) 8)
|
|
(make-r6test/v '(call-with-values * +) 1)
|
|
(make-r6test/v '(call-with-values (lambda () (apply values (cons 1 (cons 2 null)))) +) 3)
|
|
(make-r6test/v '(call-with-values (lambda () 1) +) 1)
|
|
|
|
(make-r6test/e
|
|
'(call-with-values (lambda ()
|
|
((lambda (f)
|
|
(f ((lambda (id) id) (lambda (x) (x x)))
|
|
(lambda (x y) x)))
|
|
values))
|
|
(lambda (a b) (a b)))
|
|
"arity mismatch")
|
|
|
|
(make-r6test/v '((lambda (x) x) (values 1)) 1)
|
|
(make-r6test '(store () (values 1 2))
|
|
(list '(store () (values 1 2))))
|
|
(make-r6test '(store () (begin ((lambda (x) (values x x x)) 1) 1))
|
|
(list '(store () (values 1))))
|
|
(make-r6test '(store () ((lambda (x) (values x x x)) 1))
|
|
(list '(store () (values 1 1 1))))
|
|
|
|
(make-r6test/v '(begin (values) 1) 1)
|
|
(make-r6test/v '(+ 1 (begin (values 1 2 3) 1)) 2)))
|
|
|
|
(define dw-tests
|
|
(list
|
|
|
|
;; an infinite loop that produces a finite (circular) reduction graph
|
|
(make-r6test
|
|
'(store ()
|
|
((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
|
|
(list))
|
|
|
|
;; next examples is one a continuation example that mz gets wrong
|
|
(make-r6test
|
|
'(store ()
|
|
((lambda (count)
|
|
((lambda (first-time? k)
|
|
(if first-time?
|
|
(begin
|
|
(set! first-time? #f)
|
|
(set! count (+ count 1))
|
|
(k values))
|
|
1234))
|
|
#t
|
|
(call/cc values))
|
|
count)
|
|
0))
|
|
(list '(store () (values 2))))
|
|
|
|
(make-r6test
|
|
'(store ([x 2]) x)
|
|
(list '(store ((x 2)) (values 2))))
|
|
(make-r6test
|
|
'(store ([x 2]) (begin (set! x (+ x 1)) x))
|
|
(list '(store ((x 3)) (values 3))))
|
|
|
|
(make-r6test
|
|
'(store () (begin ((lambda (x) (+ x x)) 1) 2))
|
|
(list '(store () (values 2))))
|
|
|
|
(make-r6test
|
|
'(store () (+ (call/cc (lambda (k) (+ (k 1) 1))) 1))
|
|
(list '(store () (values 2))))
|
|
(make-r6test
|
|
'(store () ((call/cc (lambda (x) x)) (lambda (y) 1)))
|
|
(list '(store () (values 1))))
|
|
|
|
(make-r6test
|
|
'(store ((x 0))
|
|
(begin
|
|
(dynamic-wind (lambda () (set! x 1))
|
|
(lambda () (begin (set! x 2) 'whatever))
|
|
(lambda () (set! x 3)))
|
|
x))
|
|
(list '(store ((x 3)) (values 3))))
|
|
|
|
|
|
(make-r6test
|
|
'(store ((x 0)) (dynamic-wind (lambda () (set! x (+ x 1)))
|
|
(lambda () (begin (set! x (+ x 1)) x))
|
|
(lambda () (set! x (+ x 1)))))
|
|
(list '(store ((x 3)) (values 2))))
|
|
|
|
;; dynamic wind and multiple values
|
|
(make-r6test '(store () (dynamic-wind values (lambda () (values 1 2)) values))
|
|
(list '(store () (values 1 2))))
|
|
|
|
;; dynamic-wind given non-lambda procedure values
|
|
(make-r6test '(store () (dynamic-wind values values values))
|
|
(list '(store () (values))))
|
|
(make-r6test '(store () (dynamic-wind values (lambda x x) values))
|
|
(list '(store () (values null))))
|
|
|
|
|
|
(make-r6test/e '(dynamic-wind 1 1 1) "dynamic-wind expects procs")
|
|
(make-r6test/e '(dynamic-wind (lambda () (car 'x)) 1 1) "dynamic-wind expects procs")
|
|
|
|
;; make sure that dynamic wind signals non-proc errors directly
|
|
;; instead of calling procedures
|
|
(make-r6test/e '(dynamic-wind (lambda () (car 'x)) 1 2)
|
|
"dynamic-wind expects procs")
|
|
(make-r6test/e '(dynamic-wind (lambda () (car 1)) (lambda (x) x) (lambda (y) y))
|
|
"can't take car of non-pair")
|
|
|
|
(make-r6test/e '(dynamic-wind (lambda () (car 1)) (lambda (x dot y) x) (lambda () 1))
|
|
"can't take car of non-pair")
|
|
(make-r6test/v '(dynamic-wind + (lambda y 2) *)
|
|
2)
|
|
(make-r6test/v '(dynamic-wind values list (lambda y y))
|
|
'null)
|
|
|
|
|
|
(make-r6test ; "in thunk isn't really in"
|
|
'(store ((n 0))
|
|
|
|
(begin
|
|
(call/cc
|
|
(lambda (k)
|
|
(dynamic-wind
|
|
(lambda () (begin
|
|
(set! n (+ n 1))
|
|
(k 11)))
|
|
+
|
|
(lambda () (set! n (+ n 1))))))
|
|
n))
|
|
(list '(store ((n 1)) (values 1))))
|
|
|
|
(make-r6test ; "out thunk is really out"
|
|
'(store ((n 0)
|
|
(do-jump? #t)
|
|
(k-out #f))
|
|
|
|
(begin
|
|
(call/cc
|
|
(lambda (k)
|
|
(dynamic-wind
|
|
(lambda () (set! n (+ n 1)))
|
|
+
|
|
(lambda ()
|
|
(begin
|
|
(set! n (+ n 1))
|
|
(call/cc (lambda (k) (set! k-out k))))))))
|
|
(if do-jump?
|
|
(begin
|
|
(set! do-jump? #f)
|
|
(k-out 0))
|
|
11)
|
|
(set! k-out #f)
|
|
n))
|
|
(list '(store ((n 2) (do-jump? #f) (k-out #f)) (values 2))))
|
|
|
|
(make-r6test ; "out thunk is really out during trimming"
|
|
'(store ((n 0)
|
|
(do-jump? #t)
|
|
(k-out #f))
|
|
|
|
(begin
|
|
(call/cc
|
|
(lambda (k)
|
|
(dynamic-wind
|
|
(lambda () (set! n (+ n 1)))
|
|
+
|
|
(lambda ()
|
|
(begin
|
|
(set! n (+ n 1))
|
|
(call/cc (lambda (k) (set! k-out k))))))))
|
|
(if do-jump?
|
|
(begin
|
|
(set! do-jump? #f)
|
|
(k-out 0))
|
|
11)
|
|
(set! k-out #f)
|
|
n))
|
|
(list '(store ((n 2) (do-jump? #f) (k-out #f)) (values 2))))
|
|
|
|
(make-r6test ; "jumping during the results of trimming, pre-thunk"
|
|
'(store ((pre-count 0)
|
|
(pre-jump? #f)
|
|
(after-jump? #t)
|
|
(grab? #t)
|
|
(the-k #f))
|
|
|
|
(begin
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(begin
|
|
(set! pre-count (+ pre-count 1))
|
|
(if pre-jump?
|
|
(begin
|
|
(set! pre-jump? #f)
|
|
(set! after-jump? #f)
|
|
(the-k 999))
|
|
999)))
|
|
(lambda ()
|
|
(if grab?
|
|
(call/cc
|
|
(lambda (k)
|
|
(begin
|
|
(set! grab? #f)
|
|
(set! the-k k)
|
|
'ignoreme)))
|
|
999))
|
|
+)
|
|
(if after-jump?
|
|
(begin
|
|
(set! pre-jump? #t)
|
|
(the-k 999))
|
|
999)
|
|
(set! the-k #f) ;; just to make testing simpler
|
|
pre-count))
|
|
(list '(store ((pre-count 3) (pre-jump? #f) (after-jump? #f) (grab? #f) (the-k #f)) (values 3))))
|
|
|
|
(make-r6test ; "jumping during the results of trimming, post-thunk"
|
|
'(store ((post-count 0)
|
|
(post-jump? #t)
|
|
(jump-main? #t)
|
|
(grab? #t)
|
|
(the-k #f))
|
|
|
|
(begin
|
|
(if grab?
|
|
(call/cc
|
|
(lambda (k)
|
|
(begin
|
|
(set! grab? #f)
|
|
(set! the-k k))))
|
|
999)
|
|
(dynamic-wind
|
|
+
|
|
(lambda ()
|
|
(if jump-main?
|
|
(begin
|
|
(set! jump-main? #f)
|
|
(the-k 999))
|
|
999))
|
|
(lambda ()
|
|
(begin
|
|
(set! post-count (+ post-count 1))
|
|
(if post-jump?
|
|
(begin
|
|
(set! post-jump? #f)
|
|
(the-k 999))
|
|
999))))
|
|
(set! the-k #f) ;; just to make testing simpler
|
|
post-count))
|
|
(list '(store ((post-count 2) (post-jump? #f) (jump-main? #f) (grab? #f) (the-k #f)) (values 2))))
|
|
|
|
(make-r6test ; "dynamic-wind gets a continuation"
|
|
'(store () (call/cc (lambda (k) (dynamic-wind + k +))))
|
|
(list '(store () (values))))
|
|
|
|
#|
|
|
|
|
to read the following tests, read the argument to conv-base from right to left
|
|
each corresponding set! should happen in that order.
|
|
in case of a test case failure, turn the number back into a sequence
|
|
of digits with deconv-base
|
|
|
|
|#
|
|
|
|
(make-r6test ; "hop out one level"
|
|
'(store ((x 0)
|
|
(one 0)
|
|
(two 0)
|
|
(three 0))
|
|
|
|
(begin
|
|
(set! one (lambda () (set! x (+ (* x 2) 0))))
|
|
(set! two (lambda () (call/cc (lambda (k) k))))
|
|
(set! three (lambda () (set! x (+ (* x 2) 1))))
|
|
((dynamic-wind one two three)
|
|
(lambda (y) x))))
|
|
(list (let ([final-x (conv-base 2 #(1 0 1 0))])
|
|
`(store ((x ,final-x)
|
|
(one (lambda () (set! x (+ (* x 2) 0))))
|
|
(two (lambda () (call/cc (lambda (k) k))))
|
|
(three (lambda () (set! x (+ (* x 2) 1)))))
|
|
(values ,final-x)))))
|
|
|
|
(make-r6test ;"hop out two levels"
|
|
'(store ((x 0)
|
|
(one 0)
|
|
(two 0)
|
|
(three 0)
|
|
(four 0))
|
|
|
|
(begin
|
|
(set! one (lambda () (set! x (+ (* x 5) 1))))
|
|
(set! two (lambda () (set! x (+ (* x 5) 2))))
|
|
(set! three (lambda () (set! x (+ (* x 5) 3))))
|
|
(set! four (lambda () (set! x (+ (* x 5) 4))))
|
|
((dynamic-wind
|
|
one
|
|
(lambda ()
|
|
(dynamic-wind
|
|
two
|
|
(lambda () (call/cc (lambda (k) k)))
|
|
three))
|
|
four)
|
|
(lambda (y) x))))
|
|
(list
|
|
(let ([final-x (conv-base 5 #(4 3 2 1 4 3 2 1))])
|
|
`(store ((x ,final-x)
|
|
(one (lambda () (set! x (+ (* x 5) 1))))
|
|
(two (lambda () (set! x (+ (* x 5) 2))))
|
|
(three (lambda () (set! x (+ (* x 5) 3))))
|
|
(four (lambda () (set! x (+ (* x 5) 4)))))
|
|
(values ,final-x)))))
|
|
|
|
(make-r6test ; "don't duplicate tail"
|
|
'(store ((x 0)
|
|
(one 0)
|
|
(two 0)
|
|
(three 0)
|
|
(four 0))
|
|
|
|
(begin
|
|
(set! one (lambda () (set! x (+ (* x 5) 1))))
|
|
(set! two (lambda () (set! x (+ (* x 5) 2))))
|
|
(set! three (lambda () (set! x (+ (* x 5) 3))))
|
|
(set! four (lambda () (set! x (+ (* x 5) 4))))
|
|
(dynamic-wind
|
|
one
|
|
(lambda ()
|
|
((dynamic-wind two
|
|
(lambda () (call/cc (lambda (k) k)))
|
|
three)
|
|
(lambda (y) x)))
|
|
four)))
|
|
(list `(store ((x ,(conv-base 5 #(4 3 2 3 2 1)))
|
|
(one (lambda () (set! x (+ (* x 5) 1))))
|
|
(two (lambda () (set! x (+ (* x 5) 2))))
|
|
(three (lambda () (set! x (+ (* x 5) 3))))
|
|
(four (lambda () (set! x (+ (* x 5) 4)))))
|
|
|
|
(values ,(conv-base 5 #(3 2 3 2 1))))))
|
|
|
|
(make-r6test ; "dont' duplicate tail, 2 deep"
|
|
'(store ((x 0)
|
|
(one 0)
|
|
(two 0)
|
|
(three 0)
|
|
(four 0)
|
|
(five 0)
|
|
(six 0))
|
|
|
|
(begin
|
|
(set! one (lambda () (set! x (+ (* x 7) 1))))
|
|
(set! two (lambda () (set! x (+ (* x 7) 2))))
|
|
(set! three (lambda () (set! x (+ (* x 7) 3))))
|
|
(set! four (lambda () (set! x (+ (* x 7) 4))))
|
|
(set! five (lambda () (set! x (+ (* x 7) 5))))
|
|
(set! six (lambda () (set! x (+ (* x 7) 6))))
|
|
(dynamic-wind
|
|
one
|
|
(lambda ()
|
|
(dynamic-wind
|
|
two
|
|
(lambda ()
|
|
((dynamic-wind three
|
|
(lambda () (call/cc (lambda (k) k)))
|
|
four)
|
|
(lambda (y) x)))
|
|
five))
|
|
six)))
|
|
|
|
(list `(store ((x ,(conv-base 7 #(6 5 4 3 4 3 2 1)))
|
|
(one (lambda () (set! x (+ (* x 7) 1))))
|
|
(two (lambda () (set! x (+ (* x 7) 2))))
|
|
(three (lambda () (set! x (+ (* x 7) 3))))
|
|
(four (lambda () (set! x (+ (* x 7) 4))))
|
|
(five (lambda () (set! x (+ (* x 7) 5))))
|
|
(six (lambda () (set! x (+ (* x 7) 6)))))
|
|
(values ,(conv-base 7 #(4 3 4 3 2 1))))))
|
|
|
|
(make-r6test ; "hop out and back into another one"
|
|
'(store ((x 0)
|
|
(one 0)
|
|
(two 0)
|
|
(three 0)
|
|
(four 0))
|
|
|
|
(begin
|
|
(set! one (lambda () (set! x (+ (* x 5) 1))))
|
|
(set! two (lambda () (set! x (+ (* x 5) 2))))
|
|
(set! three (lambda () (set! x (+ (* x 5) 3))))
|
|
(set! four (lambda () (set! x (+ (* x 5) 4))))
|
|
((lambda (ok)
|
|
(dynamic-wind one
|
|
(lambda () (ok (lambda (y) x)))
|
|
two))
|
|
(dynamic-wind three
|
|
(lambda () (call/cc (lambda (k) k)))
|
|
four))))
|
|
(list `(store ((x ,(conv-base 5 #(2 1 4 3 2 1 4 3)))
|
|
(one (lambda () (set! x (+ (* x 5) 1))))
|
|
(two (lambda () (set! x (+ (* x 5) 2))))
|
|
(three (lambda () (set! x (+ (* x 5) 3))))
|
|
(four (lambda () (set! x (+ (* x 5) 4)))))
|
|
(values ,(conv-base 5 #(1 4 3 2 1 4 3))))))
|
|
|
|
(make-r6test ; "hop out one level and back in two levels"
|
|
'(store ((x 0)
|
|
(one 0)
|
|
(two 0)
|
|
(three 0)
|
|
(four 0))
|
|
|
|
(begin
|
|
(set! one (lambda () (set! x (+ (* x 5) 1))))
|
|
(set! two (lambda () (set! x (+ (* x 5) 2))))
|
|
(set! three (lambda () (set! x (+ (* x 5) 3))))
|
|
(set! four (lambda () (set! x (+ (* x 5) 4))))
|
|
((lambda (ok)
|
|
(dynamic-wind
|
|
one
|
|
(lambda ()
|
|
(dynamic-wind
|
|
two
|
|
(lambda () (ok (lambda (y) x)))
|
|
three))
|
|
four))
|
|
(call/cc (lambda (k) k)))))
|
|
(list `(store ((x ,(conv-base 5 #(4 3 2 1 4 3 2 1)))
|
|
(one (lambda () (set! x (+ (* x 5) 1))))
|
|
(two (lambda () (set! x (+ (* x 5) 2))))
|
|
(three (lambda () (set! x (+ (* x 5) 3))))
|
|
(four (lambda () (set! x (+ (* x 5) 4)))))
|
|
(values ,(conv-base 5 #(2 1 4 3 2 1))))))
|
|
|
|
(make-r6test ; "hop out two levels and back in two levels"
|
|
'(store ((x 0)
|
|
(one 0)
|
|
(two 0)
|
|
(three 0)
|
|
(four 0)
|
|
(five 0)
|
|
(six 0)
|
|
(seven 0)
|
|
(eight 0))
|
|
|
|
(begin
|
|
(set! one (lambda () (set! x (+ (* x 9) 1))))
|
|
(set! two (lambda () (set! x (+ (* x 9) 2))))
|
|
(set! three (lambda () (set! x (+ (* x 9) 3))))
|
|
(set! four (lambda () (set! x (+ (* x 9) 4))))
|
|
(set! five (lambda () (set! x (+ (* x 9) 5))))
|
|
(set! six (lambda () (set! x (+ (* x 9) 6))))
|
|
(set! seven (lambda () (set! x (+ (* x 9) 7))))
|
|
(set! eight (lambda () (set! x (+ (* x 9) 8))))
|
|
((lambda (ok)
|
|
(dynamic-wind
|
|
one
|
|
(lambda ()
|
|
(dynamic-wind
|
|
two
|
|
(lambda () (ok (lambda (y) x)))
|
|
three))
|
|
four))
|
|
(dynamic-wind
|
|
five
|
|
(lambda ()
|
|
(dynamic-wind
|
|
six
|
|
(lambda () (call/cc (lambda (k) k)))
|
|
seven))
|
|
eight))))
|
|
(list `(store ((x ,(conv-base 9 #(4 3 2 1 8 7 6 5 4 3 2 1 8 7 6 5)))
|
|
(one (lambda () (set! x (+ (* x 9) 1))))
|
|
(two (lambda () (set! x (+ (* x 9) 2))))
|
|
(three (lambda () (set! x (+ (* x 9) 3))))
|
|
(four (lambda () (set! x (+ (* x 9) 4))))
|
|
(five (lambda () (set! x (+ (* x 9) 5))))
|
|
(six (lambda () (set! x (+ (* x 9) 6))))
|
|
(seven (lambda () (set! x (+ (* x 9) 7))))
|
|
(eight (lambda () (set! x (+ (* x 9) 8)))))
|
|
(values ,(conv-base 9 #(2 1 8 7 6 5 4 3 2 1 8 7 6 5))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; exception tests
|
|
;;
|
|
|
|
(define exn-tests
|
|
(list
|
|
(make-r6test/v '(with-exception-handler (lambda (x) 1) (lambda () 2))
|
|
2)
|
|
(make-r6test/v '(with-exception-handler (lambda (x) 1) (lambda () (raise-continuable 2)))
|
|
1)
|
|
(make-r6test/v '(with-exception-handler (lambda (x) x) (lambda () (raise-continuable 2)))
|
|
2)
|
|
(make-r6test/v '(with-exception-handler values (lambda () (raise-continuable 2)))
|
|
2)
|
|
(make-r6test '(store () (with-exception-handler (lambda (x) x) values))
|
|
(list '(store () (values))))
|
|
(make-r6test '(store () (with-exception-handler (lambda (x) (values x x)) (lambda () (raise-continuable 1))))
|
|
(list '(store () (values 1 1))))
|
|
(make-r6test/v '(+ 1 (with-exception-handler
|
|
(lambda (x) (+ 2 x))
|
|
(lambda () (+ 3 (raise-continuable (+ 2 2))))))
|
|
10)
|
|
|
|
(make-r6test '(store ()
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
(lambda (x)
|
|
(with-exception-handler
|
|
(lambda (y) (k (eqv? x y)))
|
|
(lambda () (car 1))))
|
|
(lambda () (car 1))))))
|
|
(list '(store () (values #t))
|
|
'(store () (values #f))))
|
|
|
|
;; nested handlers
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (x) (+ 2 x))
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda (x) (+ 3 x))
|
|
(lambda () (raise-continuable 1)))))
|
|
4)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (y) (with-exception-handler
|
|
(lambda (x) (+ 3 x y))
|
|
(lambda () (raise-continuable 1))))
|
|
(lambda () (raise-continuable 17)))
|
|
21)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
values
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda (y) (raise-continuable y))
|
|
(lambda () (raise-continuable 1)))))
|
|
1)
|
|
|
|
(make-r6test '(store ()
|
|
(with-exception-handler
|
|
(lambda (y) (raise-continuable y))
|
|
(lambda () (raise 2))))
|
|
(list '(uncaught-exception 2)))
|
|
|
|
(make-r6test '(store ()
|
|
(with-exception-handler
|
|
(lambda (y) (raise y))
|
|
(lambda () (raise-continuable 2))))
|
|
(list '(uncaught-exception 2)))
|
|
|
|
(make-r6test '(store () (raise 2))
|
|
(list '(uncaught-exception 2)))
|
|
|
|
(make-r6test '(store () (raise-continuable 2))
|
|
(list '(uncaught-exception 2)))
|
|
|
|
(make-r6test '(store () (letrec* ([w 3]
|
|
[x (+ 1 (raise-continuable 2))]
|
|
[y 2])
|
|
1))
|
|
(list '(uncaught-exception 2)))
|
|
|
|
(make-r6test '(store ()
|
|
(with-exception-handler
|
|
(lambda (x) x)
|
|
(lambda () (raise 2))))
|
|
(list '(uncaught-exception (make-cond "handler returned"))))
|
|
|
|
(make-r6test/e '((lambda (c e)
|
|
(with-exception-handler
|
|
(lambda (x) (if (eqv? c 0)
|
|
(set! c 1)
|
|
(if (eqv? c 1)
|
|
(begin (set! c 2)
|
|
(set! e x))
|
|
(raise e))))
|
|
(lambda () (raise 2))))
|
|
0 #f)
|
|
"handler returned")
|
|
|
|
(make-r6test/v '(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
(lambda (x) (k (eqv? x 2)))
|
|
(lambda () (car 1)))))
|
|
#f)
|
|
|
|
(make-r6test/v '((lambda (sx first-time?)
|
|
((lambda (k)
|
|
(if first-time?
|
|
(begin
|
|
(set! first-time? #f)
|
|
(with-exception-handler
|
|
(lambda (x) (k values))
|
|
(lambda ()
|
|
(dynamic-wind
|
|
+
|
|
(lambda () (raise-continuable 1))
|
|
(lambda () (set! sx (+ sx 1)))))))
|
|
sx))
|
|
(call/cc values)))
|
|
1 #t)
|
|
2)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (x) (begin (set! x (+ x 1)) x))
|
|
(lambda ()
|
|
(raise-continuable 1)))
|
|
2)
|
|
|
|
(make-r6test/v '(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
(lambda (x) (set! x (+ x 1)) (k x))
|
|
(lambda ()
|
|
(raise 1)))))
|
|
2)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (x) 2)
|
|
(lambda ()
|
|
(dynamic-wind
|
|
+
|
|
(lambda () (raise-continuable 1))
|
|
+)))
|
|
2)
|
|
|
|
(make-r6test '(store ()
|
|
(with-exception-handler
|
|
(lambda (x) (raise (+ x 1)))
|
|
(lambda ()
|
|
(dynamic-wind
|
|
+
|
|
(lambda () (raise 1))
|
|
+))))
|
|
(list '(uncaught-exception 2)))
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (x) x)
|
|
(lambda ()
|
|
(dynamic-wind
|
|
+
|
|
(lambda () (raise-continuable 1))
|
|
+)))
|
|
1)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (x) (begin (set! x 2) x))
|
|
(lambda ()
|
|
(dynamic-wind
|
|
+
|
|
(lambda () (raise-continuable 1))
|
|
+)))
|
|
2)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (x) (with-exception-handler
|
|
(lambda (x) x)
|
|
(lambda () (raise-continuable 1))))
|
|
(lambda () (raise-continuable 2)))
|
|
1)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (y)
|
|
(with-exception-handler
|
|
(lambda (x) y)
|
|
(lambda ()
|
|
(raise-continuable 1))))
|
|
(lambda ()
|
|
(raise-continuable 2)))
|
|
2)
|
|
|
|
(make-r6test/v '(with-exception-handler
|
|
(lambda (y)
|
|
(with-exception-handler
|
|
(lambda (x) x)
|
|
(lambda ()
|
|
(raise-continuable 1))))
|
|
(lambda ()
|
|
(raise-continuable 2)))
|
|
1)
|
|
|
|
(make-r6test/e '(with-exception-handler 2 +)
|
|
"with-exception-handler expects procs")
|
|
(make-r6test/e '(with-exception-handler + 2)
|
|
"with-exception-handler expects procs")
|
|
(make-r6test/e '(with-exception-handler 1 2)
|
|
"with-exception-handler expects procs")
|
|
(make-r6test/v '(with-exception-handler (lambda (wrench crowbar) wrench) (lambda () 1))
|
|
1)
|
|
(make-r6test/e '(with-exception-handler (lambda (wrench crowbar) wrench) (lambda () (raise 1)))
|
|
"arity mismatch")
|
|
(make-r6test/e '(with-exception-handler 3 (lambda () 1))
|
|
"with-exception-handler expects procs")
|
|
|
|
(make-r6test/v '((lambda (y)
|
|
(with-exception-handler
|
|
(lambda (x) (set! y (+ x y)))
|
|
(lambda ()
|
|
(raise-continuable 1)
|
|
(raise-continuable 2)
|
|
y)))
|
|
0)
|
|
3)
|
|
|
|
(make-r6test '(store ()
|
|
(with-exception-handler
|
|
(lambda (x) (raise x))
|
|
(lambda () (raise 1))))
|
|
(list '(uncaught-exception 1)))
|
|
|
|
;; make sure that the inner handler is called twice,
|
|
;; rather than the inner handler called once and the outer one called once.
|
|
(make-r6test/v '((lambda (o)
|
|
(with-exception-handler
|
|
(lambda (x) (set! o (* 3 o)))
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda (x) (set! o (* 2 o)) x)
|
|
(lambda ()
|
|
(raise-continuable 4)
|
|
(raise-continuable 4)))))
|
|
o)
|
|
1)
|
|
4)
|
|
|
|
(make-r6test
|
|
'(store ()
|
|
(letrec* ([k #f]
|
|
[ans #f]
|
|
[first-time? #t])
|
|
(with-exception-handler
|
|
(lambda (x)
|
|
(begin
|
|
(call/cc (lambda (k2) (set! k k2)))
|
|
(set! x (+ x 1))
|
|
(set! ans x)))
|
|
(lambda ()
|
|
(raise-continuable 1)))
|
|
(if first-time?
|
|
(begin
|
|
(set! first-time? #f)
|
|
(k 1))
|
|
(set! k #f))
|
|
ans))
|
|
(list '(store ((lx-k #f) (lx-ans 3) (lx-first-time? #f))
|
|
(values 3))))
|
|
|
|
;; test trimming function in the presence of exceptions when trimming handlers
|
|
;; this test belongs in the dw section. have to move it there after changing its syntax
|
|
(make-r6test '(store ()
|
|
(letrec* ((phase 0)
|
|
(k #f)
|
|
(l '()))
|
|
(with-exception-handler
|
|
(lambda (x) (if (eqv? phase 0)
|
|
(begin
|
|
(set! phase 1)
|
|
(call/cc (lambda (k2) (begin (set! k k2) 'whatever))))
|
|
(if (eqv? phase 1)
|
|
(begin
|
|
(set! phase 2)
|
|
(k 1))
|
|
1234)))
|
|
(lambda ()
|
|
(dynamic-wind
|
|
(lambda () (set! l (cons 1 l)))
|
|
(lambda ()
|
|
(dynamic-wind
|
|
(lambda () (set! l (cons 2 l)))
|
|
(lambda () (raise-continuable 1))
|
|
(lambda () (set! l (cons 3 l))))
|
|
(dynamic-wind
|
|
(lambda () (set! l (cons 4 l)))
|
|
(lambda () (raise-continuable 1))
|
|
(lambda () (set! l (cons 5 l)))))
|
|
(lambda () (set! l (cons 6 l))))))
|
|
(set! k #f)
|
|
(apply values l)))
|
|
(list '(store ((lx-phase 2)
|
|
(lx-k #f)
|
|
(lx-l (cons 6 (cons 5 (cons 4 (cons 3 (cons 2 (cons 5 (cons 4 (cons 3 (cons 2 (cons 1 null))))))))))))
|
|
(values 6 5 4 3 2 5 4 3 2 1))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; letrec tests
|
|
;;
|
|
|
|
(define letrec-tests
|
|
(list
|
|
(make-r6test '(store () (letrec ([x 1] [y 2]) (+ x y)))
|
|
(list '(store ((lx-x 1) (lx-y 2)) (values 3))))
|
|
(make-r6test '(store ()
|
|
(letrec ([flip (lambda (x) (if x (flop #f) #t))]
|
|
[flop (lambda (x) (if x (flip x) x))])
|
|
(begin0 (flop #t)
|
|
(set! flip 1)
|
|
(set! flop 2))))
|
|
(list '(store ((lx-flip 1)
|
|
(lx-flop 2))
|
|
(values #f))))
|
|
(make-r6test '(store () (letrec ([x (begin (set! x 1) 2)]) x))
|
|
(list '(store ((lx-x 2)) (values 2))
|
|
'(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store ()
|
|
(letrec ([x (begin (set! y 2) 5)]
|
|
[y (begin (set! x 3) 7)])
|
|
(* x y)))
|
|
(list '(store ((lx-x 5) (lx-y 7)) (values 35))
|
|
'(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store () (letrec ([x x]) x))
|
|
(list '(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store () (letrec ([x y] [y x]) x))
|
|
(list '(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store () (letrec ([x 1] [y x]) y))
|
|
(list '(uncaught-exception (make-cond "letrec variable touched"))))
|
|
|
|
(make-r6test '(store () (letrec ([x 1] [y 2]) (set! x 3) (set! y 4) (+ x y)))
|
|
(list '(store ((lx-x 3) (lx-y 4)) (values 7))))
|
|
|
|
(make-r6test '(store () (letrec* ([x 1] [y 2]) (+ x y)))
|
|
(list '(store ((lx-x 1) (lx-y 2)) (values 3))))
|
|
(make-r6test '(store ()
|
|
(letrec* ([flip (lambda (x) (if x (flop #f) #t))]
|
|
[flop (lambda (x) (if x (flip x) x))])
|
|
(begin0 (flop #t)
|
|
(set! flip 1)
|
|
(set! flop 2))))
|
|
(list '(store ((lx-flip 1) (lx-flop 2)) (values #f))))
|
|
(make-r6test '(store () (letrec* ([x (begin (set! x 1) 2)]) x))
|
|
(list '(store ((lx-x 2)) (values 2))
|
|
'(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store ()
|
|
(letrec* ([x (begin (set! y 2) 5)]
|
|
[y (begin (set! x 3) 7)])
|
|
(* x y)))
|
|
(list '(store ((lx-x 3) (lx-y 7)) (values 21))
|
|
'(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store () (letrec* ([x x]) x))
|
|
(list '(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store () (letrec* ([x y] [y x]) x))
|
|
(list '(uncaught-exception (make-cond "letrec variable touched"))))
|
|
(make-r6test '(store () (letrec* ([x 1] [y x]) y))
|
|
(list '(store ((lx-x 1) (lx-y 1)) (values 1))))
|
|
|
|
(make-r6test '(store () ((lambda (x y) (letrec ([q (begin (set! x 2) 23)]) (begin (set! y 3) (* x y))))
|
|
5 7))
|
|
(list '(store ((lx-q 23)) (values 6))))
|
|
(make-r6test '(store () ((lambda (x y) (letrec* ([q (begin (set! x 2) 23)]) (begin (set! y 3) (* x y))))
|
|
5 7))
|
|
(list '(store ((lx-q 23)) (values 6))))
|
|
(make-r6test '(store () (letrec* ([x 1] [y 2]) (set! x 3) (set! y 4) (+ x y)))
|
|
(list '(store ((lx-x 3) (lx-y 4)) (values 7))))
|
|
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ([k (call/cc (lambda (x) x))])
|
|
(k (lambda (x) x))
|
|
(k 2)))
|
|
(list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
|
|
'(store ((lx-k (lambda (x) x))) (values 2))))
|
|
(make-r6test '(store ()
|
|
(letrec ([k (call/cc (lambda (x) x))])
|
|
(k (lambda (x) x))
|
|
(k 2)))
|
|
(list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
|
|
'(store ((lx-k (lambda (x2) x2))) (values 2))))
|
|
|
|
(make-r6test '(store ()
|
|
((lambda (flag)
|
|
(letrec* ([k
|
|
((lambda (k)
|
|
(if flag
|
|
'nothing-doing
|
|
(car 'not-a-pair))
|
|
k)
|
|
(call/cc (lambda (x) x)))])
|
|
(set! flag #f)
|
|
(k (lambda (x) x))
|
|
(k 2)))
|
|
#t))
|
|
(list '(uncaught-exception (make-cond "can't take car of non-pair"))))
|
|
(make-r6test '(store ()
|
|
((lambda (flag)
|
|
(letrec ([k
|
|
((lambda (k)
|
|
(if flag
|
|
'nothing-doing
|
|
(car 'not-a-pair))
|
|
k)
|
|
(call/cc (lambda (x) x)))])
|
|
(set! flag #f)
|
|
(k (lambda (x) x))
|
|
(k 2)))
|
|
#t))
|
|
(list '(uncaught-exception (make-cond "can't take car of non-pair"))))
|
|
|
|
|
|
(make-r6test '(store ()
|
|
((lambda (flag)
|
|
(letrec ([k (call/cc (lambda (x) x))]
|
|
[x (if flag
|
|
'nothing-doing
|
|
(car 'not-a-pair))])
|
|
(set! flag #f)
|
|
(k (lambda (x) x))
|
|
(k 2)))
|
|
#t))
|
|
(list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
|
|
'(uncaught-exception (make-cond "can't take car of non-pair"))
|
|
'(store ((lx-k (lambda (x2) x2)) (lx-x 'nothing-doing)) (values 2))))
|
|
|
|
(make-r6test '(store ()
|
|
((lambda (flag)
|
|
(letrec* ([k (call/cc (lambda (x) x))]
|
|
[x (if flag
|
|
'nothing-doing
|
|
(car 'not-a-pair))])
|
|
(set! flag #f)
|
|
(k (lambda (x) x))
|
|
(k 2)))
|
|
#t))
|
|
(list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
|
|
'(uncaught-exception (make-cond "can't take car of non-pair"))))
|
|
|
|
(make-r6test '(store ()
|
|
(letrec* ([x (values 1 2)])
|
|
x))
|
|
(list '(unknown "context expected one value, received 2")))
|
|
(make-r6test '(store ()
|
|
(letrec ([x (values 1 2)])
|
|
x))
|
|
(list '(unknown "context expected one value, received 2")))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; testing functions
|
|
;;
|
|
|
|
|
|
(define-syntax (test-fn stx)
|
|
(syntax-case stx ()
|
|
[(_ test-case expected)
|
|
(with-syntax ([line (syntax-line stx)])
|
|
(syntax (test-fn/proc (λ () test-case) expected line)))]))
|
|
|
|
(define (test-fn/proc tc expected line)
|
|
(let ([got (tc)])
|
|
(unless (equal? got expected)
|
|
(set! failed-tests (+ failed-tests 1))
|
|
(fprintf (current-error-port)
|
|
"line ~s failed\nexpected ~s\n got ~s\n"
|
|
line
|
|
expected
|
|
got))))
|
|
|
|
|
|
(define (test-fns)
|
|
(begin
|
|
(test-fn (term (Var-set!d? (x (set! x 1)))) #t)
|
|
(test-fn (term (Var-set!d? (x (set! y 1)))) #f)
|
|
(test-fn (term (Var-set!d? (x (lambda (x) (set! x 2))))) #f)
|
|
(test-fn (term (Var-set!d? (x (lambda (z dot x) (set! x 2))))) #f)
|
|
(test-fn (term (Var-set!d? (x (lambda (x dot z) (set! x 2))))) #f)
|
|
(test-fn (term (Var-set!d? (x (lambda (y) (set! x 2))))) #t)
|
|
(test-fn (term (Var-set!d? (x
|
|
(if (begin (set! x 2))
|
|
1
|
|
2))))
|
|
#t)
|
|
(test-fn (term (Var-set!d? (x (begin0 (begin (begin0 1 2) 3) 4))))
|
|
#f)
|
|
(test-fn (term (Var-set!d? (x (dw x1 1 2 3)))) #f)
|
|
(test-fn (term (Var-set!d? (y (throw x ((set! z x)))))) #f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; all of the tests
|
|
;;
|
|
|
|
(define the-sets
|
|
(list (list "app" app-tests)
|
|
(list "exn" exn-tests)
|
|
(list "dw" dw-tests)
|
|
(list "eqv" eqv-tests)
|
|
(list "r5" r5-tests)
|
|
(list "mv" mv-tests)
|
|
(list "letrec" letrec-tests)
|
|
(list "unspec" assignment-results-tests)
|
|
(list "quote" quote-tests)
|
|
(list "arith" arithmetic-tests)
|
|
(list "basic" basic-form-tests)
|
|
(list "pair" pair-tests)
|
|
(list "err" err-tests)))
|
|
|
|
(define the-tests (apply append (map cadr the-sets)))
|
|
|
|
(define (main #:verbose? [verbose? #f] #:compare-with-racket? [compare-with-racket? #f])
|
|
(cond
|
|
[compare-with-racket?
|
|
(let ()
|
|
|
|
(define redex-exps '())
|
|
(define r6-module-bodies '())
|
|
(define missing 0)
|
|
|
|
(define (no-bads? x)
|
|
(define bads '(begin0 make-cond))
|
|
(let loop ([x x])
|
|
(cond
|
|
[(pair? x) (and (loop (car x))
|
|
(loop (cdr x)))]
|
|
[(memq x bads) #f]
|
|
[else #t])))
|
|
|
|
(for ([set (in-list the-sets)]
|
|
[i (in-naturals)])
|
|
(for ([test (in-list (cadr set))]
|
|
[j (in-naturals)])
|
|
(match (r6test-test test)
|
|
[(and `(store () ,exp)
|
|
(? no-bads?))
|
|
(set! r6-module-bodies (cons exp r6-module-bodies))
|
|
(set! redex-exps (cons (r6test-test test) redex-exps))]
|
|
[_ (set! missing (+ missing 1))])))
|
|
|
|
(printf "Running ~a tests (skipping ~a)\n" (length redex-exps) missing)
|
|
|
|
(define ns (make-base-namespace))
|
|
|
|
;; initialize the namespace by evaluating a dummy module
|
|
(parameterize ([current-namespace ns])
|
|
(eval `(module r6rs-init r6rs (import (rnrs) (rnrs mutable-pairs (6))))))
|
|
|
|
(collect-garbage) (collect-garbage)
|
|
(printf "Running in Racket's R6RS mode...\n")
|
|
(parameterize ([current-namespace ns])
|
|
(time (eval `(module r6rs-big r6rs (import (rnrs) (rnrs mutable-pairs (6)))
|
|
(define null '())
|
|
,@r6-module-bodies))))
|
|
|
|
(collect-garbage) (collect-garbage)
|
|
(printf "Running in the Redex model finding only the first outcome...\n")
|
|
(time (for ([test (in-list redex-exps)])
|
|
(evaluate reductions test #f void
|
|
#:only-first-answer? #t)))
|
|
|
|
(collect-garbage) (collect-garbage)
|
|
(printf "Running in the Redex model finding all outcomes...\n")
|
|
(time (for ([test (in-list redex-exps)])
|
|
(evaluate reductions test #f void
|
|
#:only-first-answer? #f))))]
|
|
[else
|
|
(time
|
|
(let ()
|
|
(define first? #t)
|
|
(define (run-a-set name set)
|
|
(unless first?
|
|
(if verbose?
|
|
(printf "\n\n")
|
|
(printf "\n")))
|
|
(if verbose?
|
|
(printf "~a\n~a tests\n\n"
|
|
(apply string (build-list 60 (λ (i) #\-)))
|
|
name)
|
|
(begin (printf "~a tests " name)
|
|
(flush-output)))
|
|
(set! first? #f)
|
|
(for-each (λ (x) (run-a-test x verbose?)) set))
|
|
|
|
(set! failed-tests 0)
|
|
(set! verified-terms 0)
|
|
(test-fns)
|
|
(for-each (λ (set) (apply run-a-set set)) the-sets)
|
|
(unless verbose? (printf "\n"))
|
|
|
|
(if (= 0 failed-tests)
|
|
(printf "~a tests, all passed\n" test-count)
|
|
(fprintf (current-error-port) "~a tests, ~a tests failed\n" test-count failed-tests))
|
|
(printf "verified that ~a terms are p*\n" verified-terms)))
|
|
(when verbose?
|
|
(collect-garbage) (collect-garbage) (collect-garbage)
|
|
(printf "mem ~s\n" (current-memory-use))
|
|
(let ([v (make-vector 10)])
|
|
(vector-set-performance-stats! v)
|
|
(printf "ht searches ~a\nslots searched ~a\n" (vector-ref v 8) (vector-ref v 9))))]))
|
|
|
|
(provide main
|
|
the-tests
|
|
|
|
;; the 'test' and the 'expected' are not compared with equal?.
|
|
;; instead, the result of running the test is first simplified
|
|
;; by substituting all of the variables with a colon in their
|
|
;; names thru the term, and then the results from the test are
|
|
;; compared with equal? to the elements of `expected'
|
|
|
|
(struct-out r6test))
|