200 lines
6.3 KiB
Scheme
200 lines
6.3 KiB
Scheme
|
|
;; Basic checks for the advanced language. See also
|
|
;; beginner.ss
|
|
|
|
(load-relative "loadtest.ss")
|
|
|
|
;; Don't need these:
|
|
(define no-extra-if-tests? #t)
|
|
|
|
;; Check export names:
|
|
(require (lib "docprovide.ss" "syntax"))
|
|
(let ([docs (lookup-documentation '(lib "htdp-advanced.ss" "lang") 'procedures)])
|
|
(for-each
|
|
(lambda (row)
|
|
(for-each
|
|
(lambda (doc)
|
|
(let ([v (dynamic-require '(lib "htdp-advanced.ss" "lang") (car doc))])
|
|
(when (and (procedure? v)
|
|
(not (eq? v call/cc)))
|
|
(test (car doc) object-name v))))
|
|
(cdr row)))
|
|
docs))
|
|
|
|
(define current-htdp-lang '(lib "htdp-advanced.ss" "lang"))
|
|
(load-relative "htdp-test.ss")
|
|
|
|
(require (lib "htdp-advanced.ss" "lang"))
|
|
|
|
(load-relative "beg-adv.ss")
|
|
(load-relative "bega-adv.ss")
|
|
(load-relative "intm-adv.ss")
|
|
|
|
(define (f6 a) (a))
|
|
(test (void) f6 void)
|
|
|
|
(define (x7) 10)
|
|
(test 10 x7)
|
|
(define x8 (lambda () 11))
|
|
(test 11 x8)
|
|
|
|
(htdp-syntax-test #'begin)
|
|
(htdp-syntax-test #'(begin))
|
|
(htdp-syntax-test #'(begin (define x 10)))
|
|
(htdp-syntax-test #'(begin (define x 10) x))
|
|
(htdp-syntax-test #'(let () (begin (define x 10) x)))
|
|
(htdp-syntax-test #'(+ 1 (begin)))
|
|
|
|
(test 1 'begin (begin 1))
|
|
(test 2 'begin (begin 1 2))
|
|
(test 3 'begin (begin 1 2 3))
|
|
|
|
(htdp-syntax-test #'begin0)
|
|
(htdp-syntax-test #'(begin0))
|
|
|
|
(test 1 'begin0 (begin0 1))
|
|
(test 2 'begin0 (begin0 2 1))
|
|
(test 3 'begin0 (begin0 3 2 1))
|
|
|
|
(htdp-syntax-test #'set!)
|
|
(htdp-syntax-test #'(set!))
|
|
(htdp-syntax-test #'(set! x))
|
|
(htdp-syntax-test #'(set! 1 2))
|
|
(htdp-syntax-test #'(set! x 2 3))
|
|
(htdp-syntax-test #'(set! set! 2))
|
|
(htdp-syntax-test #'(lambda (x) (set! x 2)))
|
|
(htdp-syntax-test #'(let ([x 5]) (lambda (x) (set! x 2))))
|
|
|
|
(htdp-top (set! x 'hello))
|
|
(htdp-test 'hello 'access-x x)
|
|
(htdp-test 18 'set! (local [(define x 12)]
|
|
(begin
|
|
(set! x 18)
|
|
x)))
|
|
(htdp-test 19 (lambda (x)
|
|
(local [(define x 12)]
|
|
(begin
|
|
(set! x 19)
|
|
x)))
|
|
45)
|
|
|
|
(htdp-syntax-test #'delay)
|
|
(htdp-syntax-test #'(delay))
|
|
(htdp-syntax-test #'(delay 1 2))
|
|
|
|
(htdp-top (define d (delay (begin (set! x 89) 12))))
|
|
(htdp-test #t promise? d)
|
|
(htdp-test 12 force d)
|
|
(htdp-top (force d))
|
|
(htdp-test 89 'access-x x)
|
|
(htdp-top (set! x 13))
|
|
(htdp-test 12 force d)
|
|
(htdp-test 13 'access-x x)
|
|
|
|
(htdp-syntax-test #'(let name))
|
|
(htdp-syntax-test #'(let name 10))
|
|
(htdp-syntax-test #'(let name ()))
|
|
(htdp-syntax-test #'(let name ([x]) 1))
|
|
(htdp-syntax-test #'(let name ([x 10] 2) 1))
|
|
(htdp-syntax-test #'(let name ([11 10]) 1))
|
|
(htdp-syntax-test #'(let name ([x 10]) 1 2))
|
|
(htdp-syntax-test #'(let name ([x 10][x 11]) 1))
|
|
(htdp-test 10 'lookup (let name () 10))
|
|
(htdp-test 1024 'loop (let loop ([n 10]) (if (zero? n) 1 (* 2 (loop (sub1 n))))))
|
|
|
|
(htdp-test 19 'lookup (recur empty-f () 19))
|
|
|
|
(htdp-syntax-test #'case)
|
|
(htdp-syntax-test #'(case))
|
|
(htdp-syntax-test #'(case 5))
|
|
(htdp-syntax-test #'(case 5 12))
|
|
(htdp-syntax-test #'(case 5 []))
|
|
(htdp-syntax-test #'(case 5 [5 10]))
|
|
(htdp-syntax-test #'(case 5 [(5) 10] 12))
|
|
(htdp-syntax-test #'(case 5 [(5)]))
|
|
(htdp-syntax-test #'(case 5 [(5) 12 13]))
|
|
(htdp-syntax-test #'(case 5 [("a") 10]))
|
|
(htdp-syntax-test #'(case 5 [() 10]))
|
|
(htdp-syntax-test #'(case 5 [(5 "a") 10]))
|
|
(htdp-syntax-test #'(case 5 [else 12][(5) 10]))
|
|
(htdp-syntax-test #'(case 5 [(5) 10][else 12][else 13]))
|
|
|
|
(htdp-test 'a 'case (case 5 [(5) 'a]))
|
|
(htdp-test 'b 'case (case 5 [(6) 'a][else 'b]))
|
|
(htdp-test 'c 'case (case 5 [(6 5) 'c][else 'b]))
|
|
(htdp-test 'd 'case (case 'hello [(6 5 hello) 'd][else 'b]))
|
|
(htdp-test 'd 'case (case 'hello [(no) 10][(6 5 hello) 'd][else 'b]))
|
|
(htdp-test 'cc 'case (case (+ 2 3) [(6 5) 'cc][else 'b]))
|
|
|
|
(htdp-syntax-test #'when)
|
|
(htdp-syntax-test #'(when))
|
|
(htdp-syntax-test #'(when 10))
|
|
(htdp-syntax-test #'(when 10 12 13))
|
|
|
|
(htdp-err/rt-test (when 1 2))
|
|
|
|
(htdp-test (void) 'when (when false 1))
|
|
(htdp-test 11 'when (when true 11))
|
|
|
|
(htdp-syntax-test #'unless)
|
|
(htdp-syntax-test #'(unless))
|
|
(htdp-syntax-test #'(unless 10))
|
|
(htdp-syntax-test #'(unless 10 12 13))
|
|
|
|
(htdp-err/rt-test (unless 1 2))
|
|
|
|
(htdp-test (void) 'unless (unless true 1))
|
|
(htdp-test 11 'unless (unless false 11))
|
|
|
|
(htdp-syntax-test #'shared)
|
|
(htdp-syntax-test #'(shared))
|
|
(htdp-syntax-test #'(shared ()))
|
|
(htdp-syntax-test #'(shared 1 2))
|
|
(htdp-syntax-test #'(shared () 1 2))
|
|
(htdp-syntax-test #'(shared (x) 2))
|
|
(htdp-syntax-test #'(shared ([]) 2))
|
|
(htdp-syntax-test #'(shared ([x]) 2))
|
|
(htdp-syntax-test #'(shared ([x 1 3]) 2))
|
|
(htdp-syntax-test #'(shared ([1 3]) 2))
|
|
(htdp-syntax-test #'(shared ([x 1][x 2]) 2))
|
|
|
|
(htdp-test 1 'shared (shared () 1))
|
|
(htdp-test 1 'shared (shared ([x 1]) x))
|
|
(htdp-test '(1) 'shared (shared ([x (cons 1 null)]) x))
|
|
(htdp-test 1 car (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 cadr (shared ([x (cons 1 x)][y (cons 2 x)]) y))
|
|
(htdp-test 1 cadddr (shared ([x (cons 1 x)][y (cons 2 x)]) y))
|
|
(htdp-test #t (lambda (l) (eq? l (cdr l))) (shared ([x (cons 1 x)]) x))
|
|
(htdp-test #t (lambda (l) (eq? l (car l))) (shared ([x (list x x)]) x))
|
|
(htdp-test #t (lambda (l) (eq? l (cadr l))) (shared ([x (list x x)]) x))
|
|
(htdp-err/rt-test (shared ([x (cons 1 y)][y 5]) x))
|
|
|
|
(htdp-syntax-test #'recur)
|
|
(htdp-syntax-test #'(recur))
|
|
(htdp-syntax-test #'(recur 10))
|
|
(htdp-syntax-test #'(recur name))
|
|
(htdp-syntax-test #'(recur name 10))
|
|
(htdp-syntax-test #'(recur name ([x 1])))
|
|
(htdp-syntax-test #'(recur name ([x]) 1))
|
|
(htdp-syntax-test #'(recur name ([x 10] 2) 1))
|
|
(htdp-syntax-test #'(recur name ([11 10]) 1))
|
|
(htdp-syntax-test #'(recur name ([x 10]) 1 2))
|
|
(htdp-syntax-test #'(recur name ([x 10][x 11]) 1))
|
|
(htdp-test 18 'lookup (recur name ([x 18]) x))
|
|
(htdp-test 1024 'loop (recur loop ([n 10]) (if (zero? n) 1 (* 2 (loop (sub1 n))))))
|
|
(htdp-test 13 'loop (recur f ([f 13]) f))
|
|
(htdp-test 14 'loop (let ([f 14]) (recur f ([f f]) f)))
|
|
|
|
(load (build-path (collection-path "tests" "mzscheme") "shared-tests.ss"))
|
|
|
|
(htdp-test #t 'equal? (equal? (vector (list 10) 'apple) (vector (list 10) 'apple)))
|
|
(htdp-test #t 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10) 'apple) 0.1))
|
|
(htdp-test #t 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10.02) 'apple) 0.1))
|
|
(htdp-test #f 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10.2) 'apple) 0.1))
|
|
(htdp-test #t 'equal? (equal? (box (list 10)) (box (list 10))))
|
|
(htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10)) 0.1))
|
|
(htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10.02)) 0.1))
|
|
(htdp-test #f 'equal~? (equal~? (box (list 10)) (box (list 10.2)) 0.1))
|
|
|
|
(report-errs)
|