suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added test of let* unwinding, moved shared.rkt unit tests out here

Browse Source
This commit is contained in:
John Clements 2011-06-29 00:24:02 -07:00
parent 673f99417b
commit 0061218266
3 changed files with 78 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/tests/stepper/automatic-tests.rkt
View File

@ -1,5 +1,10 @@
#lang scheme
;; run shared.rkt unit tests:
(require "shared-unit-tests.rkt")
;; now, the rest:
(require "through-tests.ss"
"test-engine.ss")

62
collects/tests/stepper/shared-unit-tests.rkt Normal file
View File

@ -0,0 +1,62 @@
#lang racket
(require rackunit
stepper/private/shared)
; test cases taken from shared.rkt
;
(define (lifted-name sym)
(syntax->datum (get-lifted-var sym)))
(define cd-stx
(datum->syntax #f 'cd))
(check-equal? (lifted-name (datum->syntax #f 'ab)) 'lifter-ab-0)
(check-equal? (lifted-name cd-stx) 'lifter-cd-1)
(check-equal? (lifted-name (datum->syntax #f 'ef)) 'lifter-ef-2)
(check-equal? (lifted-name cd-stx) 'lifter-cd-1)
(check-equal? (map syntax-e (arglist->ilist #'(a b c))) '(a b c))
(check-equal? (map syntax-e (arglist->ilist #'(a . (b c)))) '(a b c))
(check-equal? (syntax-e (arglist->ilist #'a)) 'a)
(let ([result (arglist->ilist #' (a b . c))])
(check-equal? (syntax-e (car result)) 'a)
(check-equal? (syntax-e (cadr result)) 'b)
(check-equal? (syntax-e (cddr result)) 'c))
(check-equal? (map syntax-e (arglist-flatten #'(a b c))) '(a b c))
(check-equal? (map syntax-e (arglist-flatten #'(a . (b c)))) '(a b c))
(check-equal? (map syntax-e (arglist-flatten #'(a b . c))) '(a b c))
(check-equal? (map syntax-e (arglist-flatten #'a)) '(a))
(define new-queue (make-queue))
(check-equal? (queue-push new-queue 1) (void))
(check-equal? (queue-push new-queue 2) (void))
(check-equal? (queue-pop new-queue) 1)
(check-equal? (queue-push new-queue 3) (void))
(check-equal? (queue-pop new-queue) 2)
(check-equal? (queue-pop new-queue) 3)
(check-exn exn:fail? (lambda () (queue-pop new-queue)))
(check-equal?
(call-with-values (lambda ()
(values-map (lambda (a b) (values (+ a b) (- a b)))
`(1 2 3 4 5)
`(9 8 7 6 5)))
(lambda (sums diffs)
(list sums diffs)))
`((10 10 10 10 10)
(-8 -6 -4 -2 0)))
(check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle)))
(check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle #t)))
(check-equal? (stepper-syntax-property #`13 'stepper-hint) #f)
(check-equal? (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes)
'stepper-hint) 'yes)
(check-equal?
(stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13
'stepper-hint
'no)
'stepper-hint 'yes)
'stepper-hint)
'yes)
(check-equal? (stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg) 'stepper-hint) 'yes)
(check-equal? (syntax->datum (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg)) 13)

12
collects/tests/stepper/through-tests.rkt
View File

@ -721,6 +721,14 @@
((define a_0 9) (define b_1 6) (hilite 9)))
(finished-stepping)))
(let ([def '(define (f x) (let* ([a 13] [b 14]) (let* ([c 15] [d 16]) (+ a b c d))))])
(t1 'nested-let-unwinding
m:both-intermediates
"(define (f x) (let* ([a 13] [b 14]) (let* ([c 15] [d 16]) (+ a b c d)))) (+ 3 4)"
`((before-after (,def (hilite (+ 3 4)))
(,def (hilite 7)))
(finished-stepping))))
;;;;;;;;;;;;;
;;
;; LETREC
@ -762,6 +770,7 @@
(before-after (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))
(,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0))))
(finished-stepping))))
;;;;;;;;;;;;;
;;
;; RECUR
@ -2205,5 +2214,6 @@
check-error check-error-bad))
#;(run-tests '(teachpack-universe))
#;(run-all-tests)
(run-test 'require-test)
#;(run-test 'let-lifting1)
(run-test 'nested-let-unwinding)
))