7acc5b7852
This commit fix an unintentional change introduced by this commit:
c7d67f9bab
(and it also adds in test cases for what that commit appears to have
been doing)
Assuming everyone agrees that the behavior for first rest from back
in 2010 is the behavior we still want (and the lack of release notes
on the subject makes me believe that we do), then:
Please include in 5.2.
572 lines
28 KiB
Racket
572 lines
28 KiB
Racket
|
|
;; Basic checks for the advanced language. See also
|
|
;; beginner.rkt
|
|
|
|
(load-relative "../racket/loadtest.rktl")
|
|
|
|
;; Don't need these:
|
|
(define no-extra-if-tests? #t)
|
|
|
|
;; Check export names:
|
|
(require syntax/docprovide)
|
|
(let ([docs (lookup-documentation '(lib "htdp-advanced.rkt" "lang") 'procedures)])
|
|
(for-each
|
|
(lambda (row)
|
|
(for-each
|
|
(lambda (doc)
|
|
(let ([v (dynamic-require '(lib "htdp-advanced.rkt" "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 'lang/htdp-advanced)
|
|
(load-relative "htdp-test.rktl")
|
|
|
|
(require (lib "htdp-advanced.rkt" "lang"))
|
|
|
|
(load-relative "beg-adv.rktl")
|
|
(load-relative "bega-adv.rktl")
|
|
(load-relative "intm-adv.rktl")
|
|
|
|
(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 "begin: expected an open parenthesis before begin, but found none")
|
|
(htdp-syntax-test #'(begin) "begin: expected at least one expression after begin, but nothing's there")
|
|
(htdp-syntax-test #'(begin (define x 10)) "define: found a definition that is not at the top level")
|
|
(htdp-syntax-test #'(begin (define x 10) x) "define: found a definition that is not at the top level")
|
|
(htdp-syntax-test #'(let () (begin (define x 10) x)) "define: found a definition that is not at the top level")
|
|
(htdp-syntax-test #'(+ 1 (begin)) "begin: expected at least one expression after begin, but nothing's there")
|
|
|
|
(test 1 'begin (begin 1))
|
|
(test 2 'begin (begin 1 2))
|
|
(test 3 'begin (begin 1 2 3))
|
|
|
|
(htdp-top (define ex 12))
|
|
(htdp-test 13 'begin+set! (begin (set! ex 13) ex))
|
|
(htdp-test 12 'begin+set! (begin 12 ex))
|
|
(htdp-top-pop 1)
|
|
|
|
(htdp-syntax-test #'begin0 "begin0: expected an open parenthesis before begin0, but found none")
|
|
(htdp-syntax-test #'(begin0) "begin0: expected at least one expression after begin0, but nothing's there")
|
|
|
|
(htdp-test 1 'begin0 (begin0 1))
|
|
(htdp-test 2 'begin0 (begin0 2 1))
|
|
(htdp-test 3 'begin0 (begin0 3 2 1))
|
|
|
|
|
|
(htdp-syntax-test #'set! "set!: expected an open parenthesis before set!, but found none")
|
|
(htdp-syntax-test #'(set!) "set!: expected a variable after set!, but nothing's there")
|
|
(htdp-syntax-test #'(set! x) "set!: expected an expression for the new value, but nothing's there")
|
|
(htdp-syntax-test #'(set! 1 2) "set!: expected a variable after set!, but found a number")
|
|
(htdp-syntax-test #'(set! x 2 3) "set!: expected only one expression for the new value, but found 1 extra part")
|
|
(htdp-syntax-test #'(set! set! 2) "set!: expected a variable after set!, but found a set!")
|
|
(htdp-syntax-test #'(set! x 1) "x: this variable is not defined")
|
|
(htdp-syntax-test #'(lambda (x) (set! x 2)) "set!: expected a mutable variable after set!, but found a variable that cannot be modified: x")
|
|
|
|
(htdp-syntax-test #'(let ([x 5]) (lambda (x) (set! x 2))) "set!: expected a mutable variable after set!, but found a variable that cannot be modified")
|
|
|
|
(htdp-top (define x 5))
|
|
(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 "delay: expected an open parenthesis before delay, but found none")
|
|
(htdp-syntax-test #'(delay) "delay: expected an expression after delay, but nothing's there")
|
|
(htdp-syntax-test #'(delay 1 2) "delay: expected only one expression after delay, but found 1 extra part")
|
|
|
|
(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-top-pop 4)
|
|
|
|
(htdp-syntax-test #'(let name) "let: expected at least one binding (in parentheses) after let, but nothing's there")
|
|
(htdp-syntax-test #'(let name 10) "let: expected at least one binding (in parentheses) after let, but found a number")
|
|
(htdp-syntax-test #'(let name ()) "let: expected an expression after the bindings, but nothing's there")
|
|
(htdp-syntax-test #'(let name ([x]) 1) "let: expected an expression after the name x, but nothing's there")
|
|
(htdp-syntax-test #'(let name ([x 10] 2) 1) "let: expected a binding with a variable and an expression, but found a number")
|
|
(htdp-syntax-test #'(let name ([11 10]) 1) "let: expected a variable for the binding, but found a number")
|
|
(htdp-syntax-test #'(let name ([x 10]) 1 2) "let: expected only one expression after the bindings, but found 1 extra part")
|
|
(htdp-syntax-test #'(let name ([x 10][x 11]) 1) "let: x was defined locally more than once")
|
|
(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 "case: expected an open parenthesis before case, but found none")
|
|
(htdp-syntax-test #'(case) "case: expected an expression after case, but nothing's there")
|
|
(htdp-syntax-test #'(case 5) "expected a clause with at least one choice (in parentheses) and an answer after the expression, but nothing's there")
|
|
(htdp-syntax-test #'(case 5 12) "case: expected a clause with at least one choice (in parentheses) and an answer, but found a number")
|
|
(htdp-syntax-test #'(case 5 []) "case: expected a clause with at least one choice (in parentheses) and an answer, but found an empty part")
|
|
(htdp-syntax-test #'(case 5 [5 10]) "case: expected at least one choice (in parentheses), but found a number")
|
|
(htdp-syntax-test #'(case 5 [(5) 10] 12) "case: expected a clause with at least one choice (in parentheses) and an answer, but found a number")
|
|
(htdp-syntax-test #'(case 5 [(5)]) "case: expected an expression for the answer in the case clause, but nothing's there")
|
|
(htdp-syntax-test #'(case 5 [(5) 12 13]) "case: expected only one expression for the answer in the case clause, but found 1 extra part")
|
|
(htdp-syntax-test #'(case 5 [("a") 10]) "case: expected a symbol (without its quote) or a number as a choice, but found a string")
|
|
(htdp-syntax-test #'(case 5 [() 10]) "expected a symbol (without its quote) or a number as a choice, but nothing's there")
|
|
(htdp-syntax-test #'(case 5 [(5 "a") 10]) "case: expected a symbol (without its quote) or a number as a choice, but found a string")
|
|
(htdp-syntax-test #'(case 5 [else 12][(5) 10]) "case: found an else clause that isn't the last clause in its case expression")
|
|
(htdp-syntax-test #'(case 5 [(5) 10][else 12][else 13]) "case: found an else clause that isn't the last clause in its case expression")
|
|
|
|
(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 "when: expected an open parenthesis before when, but found none")
|
|
(htdp-syntax-test #'(when) "when: expected a question and an answer, but nothing's there")
|
|
(htdp-syntax-test #'(when 10) "when: expected a question and an answer, but found only one part")
|
|
(htdp-syntax-test #'(when 10 12 13) "when: expected a question and an answer, but found 3 parts")
|
|
|
|
(htdp-err/rt-test (when 1 2) rx:not-true-or-false)
|
|
|
|
(htdp-test (void) 'when (when false 1))
|
|
(htdp-test 11 'when (when true 11))
|
|
|
|
(htdp-syntax-test #'unless "unless: expected an open parenthesis before unless, but found none")
|
|
(htdp-syntax-test #'(unless) "unless: expected a question and an answer, but nothing's there")
|
|
(htdp-syntax-test #'(unless 10) "unless: expected a question and an answer, but found only one part")
|
|
(htdp-syntax-test #'(unless 10 12 13) "unless: expected a question and an answer, but found 3 parts")
|
|
|
|
(htdp-err/rt-test (unless 1 2) rx:not-true-or-false)
|
|
|
|
(htdp-test (void) 'unless (unless true 1))
|
|
(htdp-test 11 'unless (unless false 11))
|
|
|
|
(htdp-syntax-test #'shared "shared: expected an open parenthesis before shared, but found none")
|
|
(htdp-syntax-test #'(shared) "shared: expected at least one binding (in parentheses) after shared, but nothing's there")
|
|
(htdp-syntax-test #'(shared ()) "shared: expected an expression after the bindings, but nothing's there")
|
|
(htdp-syntax-test #'(shared 1 2) "shared: expected at least one binding (in parentheses) after shared, but found a number")
|
|
(htdp-syntax-test #'(shared () 1 2) "shared: expected only one expression after the bindings, but found 1 extra part")
|
|
(htdp-syntax-test #'(shared (x) 2) "shared: expected a binding with a variable and an expression, but found something else")
|
|
(htdp-syntax-test #'(shared ([]) 2) "shared: expected a variable for a binding, but nothing's there")
|
|
(htdp-syntax-test #'(shared ([x]) 2) "shared: expected an expression after the binding name, but nothing's there")
|
|
(htdp-syntax-test #'(shared ([x 1 3]) 2) "shared: expected only one expression after the binding name, but found 1 extra part")
|
|
(htdp-syntax-test #'(shared ([1 3]) 2) "shared: expected a variable for the binding, but found a number")
|
|
(htdp-syntax-test #'(shared ([x 1][x 2]) 2) "shared: found a variable that is used more than once: x")
|
|
|
|
(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 1 first (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 second (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 third (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 fourth (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 fifth (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 sixth (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 seventh (shared ([x (cons 1 x)]) x))
|
|
(htdp-test 1 eighth (shared ([x (cons 1 x)]) x))
|
|
(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 "recur: expected an open parenthesis before recur, but found none")
|
|
(htdp-syntax-test #'(recur) "recur: expected a function name after recur, but nothing's there")
|
|
(htdp-syntax-test #'(recur 10) "recur: expected a function name after recur, but found a number")
|
|
(htdp-syntax-test #'(recur name) "recur: expected at least one binding (in parentheses) after recur, but nothing's there")
|
|
(htdp-syntax-test #'(recur name 10) "recur: expected at least one binding (in parentheses) after recur, but found a number")
|
|
(htdp-syntax-test #'(recur name ([x 1])) "recur: expected an expression after the bindings, but nothing's there")
|
|
(htdp-syntax-test #'(recur name ([x]) 1) "recur: expected an expression after the name x, but nothing's there")
|
|
(htdp-syntax-test #'(recur name ([x 10] 2) 1) "recur: expected a binding with a variable and an expression, but found a number")
|
|
(htdp-syntax-test #'(recur name ([11 10]) 1) "recur: expected a variable for the binding, but found a number")
|
|
(htdp-syntax-test #'(recur name ([x 10]) 1 2) "recur: expected only one expression after the bindings, but found 1 extra part")
|
|
(htdp-syntax-test #'(recur name ([x 10][x 11]) 1) "recur: x was defined locally more than once")
|
|
(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" "racket") "shared-tests.rktl"))
|
|
|
|
(htdp-err/rt-test (cons 1 2) "cons: second argument must be a list or cyclic list, but received 1 and 2")
|
|
(htdp-err/rt-test (append (list 1) 2) "append: last argument must be a list or cyclic list, but received 2")
|
|
|
|
(htdp-err/rt-test (first 1) "first: expected argument of type <non-empty list>; given 1")
|
|
(htdp-err/rt-test (rest 1) "rest: expected argument of type <non-empty list>; given 1")
|
|
|
|
|
|
(htdp-test #t 'equal? (equal? (vector (list 10) 'apple) (vector (list 10) 'apple)))
|
|
(htdp-test #t 'equal? (equal? (shared ([x (cons 10 x)]) x) (shared ([x (cons 10 x)]) x)))
|
|
(htdp-test #t 'equal? (equal? (shared ([x (cons (vector x) x)]) x) (shared ([x (cons (vector x) x)]) x)))
|
|
(htdp-test #f 'equal? (equal? (shared ([x (cons 10 x)]) x) (shared ([x (cons 10 (cons 11 x))]) x)))
|
|
(htdp-test #f 'equal? (equal? (shared ([x (cons (vector x) x)]) x) (shared ([x (cons (box x) x)]) x)))
|
|
|
|
(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 #t 'equal~? (equal~? (shared ([x (cons 10 x)]) x) (shared ([x (cons 10.02 x)]) x) 0.1))
|
|
(htdp-test #f 'equal~? (equal~? (shared ([x (cons 10 x)]) x) (shared ([x (cons 10.2 x)]) x) 0.1))
|
|
|
|
(htdp-test 1 'hash-copy
|
|
(local [(define ht (make-hash (list (list 'a 1))))
|
|
(define htp (hash-copy ht))]
|
|
(begin (hash-set! htp 'a 2)
|
|
(hash-ref ht 'a))))
|
|
(htdp-test 1 'hash-count (hash-count (make-hash (list (list 'a 1)))))
|
|
(htdp-test 42 'hash-for-each
|
|
(local [(define x 0)
|
|
(define (f k v) (set! x 42))]
|
|
(begin (hash-for-each (make-hash (list (list 1 2))) f)
|
|
x)))
|
|
(htdp-test #t 'hash-has-key? (hash-has-key? (make-hash (list (list 1 2))) 1))
|
|
(htdp-test #f 'hash-has-key? (hash-has-key? (make-hash (list (list 1 2))) 2))
|
|
(htdp-test (list #f #f) 'hash-map
|
|
(hash-map (make-hash (list (list 1 #t) (list 2 #t)))
|
|
(lambda (k v) (not v))))
|
|
(htdp-test 1 'hash-ref (hash-ref (make-hash (list (list 'a 1))) 'a))
|
|
(htdp-test 2 'hash-ref (hash-ref (make-hash (list (list 'a 1))) 'b 2))
|
|
(htdp-test 2 'hash-ref (hash-ref (make-hash (list (list 'a 1))) 'b (lambda () 2)))
|
|
(htdp-test 1 'hash-ref!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(hash-ref! ht 'a 2)))
|
|
(htdp-test 2 'hash-ref!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(hash-ref! ht 'b 2)))
|
|
(htdp-test 2 'hash-ref!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(begin (hash-ref! ht 'b 2)
|
|
(hash-ref ht 'b))))
|
|
(htdp-test (list #t #f) 'hash-remove!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(list (hash-has-key? ht 'a)
|
|
(begin (hash-remove! ht 'a)
|
|
(hash-has-key? ht 'a)))))
|
|
(htdp-err/rt-test
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(list (hash-has-key? ht 'a)
|
|
(begin (hash-remove ht 'a)
|
|
(hash-has-key? ht 'a)))))
|
|
(htdp-test 2 'hash-set!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(begin (hash-set! ht 'a 2)
|
|
(hash-ref ht 'a))))
|
|
(htdp-err/rt-test
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(begin (hash-set ht 'a 2)
|
|
(hash-ref ht 'a))))
|
|
(htdp-err/rt-test
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(begin (hash-update ht 'a add1)
|
|
(hash-ref ht 'a))))
|
|
(htdp-test 2 'hash-update!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(begin (hash-update! ht 'a add1)
|
|
(hash-ref ht 'a))))
|
|
(htdp-test 2 'hash-update!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(begin (hash-update! ht 'b add1 1)
|
|
(hash-ref ht 'b))))
|
|
(htdp-test 2 'hash-update!
|
|
(local [(define ht (make-hash (list (list 'a 1))))]
|
|
(begin (hash-update! ht 'b add1 (lambda () 1))
|
|
(hash-ref ht 'b))))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-hash)))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-hasheq)))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-hasheqv)))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-hash (list (list 'a 1)))))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-hasheq (list (list 'a 1)))))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-hasheqv (list (list 'a 1)))))
|
|
(htdp-test #f 'hash?
|
|
(hash? 1))
|
|
(htdp-test #t 'hash-equal?
|
|
(hash-equal? (make-hash (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-equal?
|
|
(hash-equal? (make-hasheq (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-equal?
|
|
(hash-equal? (make-hasheqv (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eq?
|
|
(hash-eq? (make-hash (list (list 'a 1)))))
|
|
(htdp-test #t 'hash-eq?
|
|
(hash-eq? (make-hasheq (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eq?
|
|
(hash-eq? (make-hasheqv (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eqv?
|
|
(hash-eqv? (make-hash (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eqv?
|
|
(hash-eqv? (make-hasheq (list (list 'a 1)))))
|
|
(htdp-test #t 'hash-eqv?
|
|
(hash-eqv? (make-hasheqv (list (list 'a 1)))))
|
|
|
|
;; immutable tests
|
|
(htdp-test 1 'hash-copy
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))
|
|
(define htp (hash-copy ht))]
|
|
(hash-ref htp 'a)))
|
|
(htdp-test 1 'hash-count (hash-count (make-immutable-hash (list (list 'a 1)))))
|
|
(htdp-test 42 'hash-for-each
|
|
(local [(define x 0)
|
|
(define (f k v) (set! x 42))]
|
|
(begin (hash-for-each (make-immutable-hash (list (list 1 2))) f)
|
|
x)))
|
|
(htdp-test #t 'hash-has-key? (hash-has-key? (make-immutable-hash (list (list 1 2))) 1))
|
|
(htdp-test #f 'hash-has-key? (hash-has-key? (make-immutable-hash (list (list 1 2))) 2))
|
|
(htdp-test (list #f #f) 'hash-map
|
|
(hash-map (make-immutable-hash (list (list 1 #t) (list 2 #t)))
|
|
(lambda (k v) (not v))))
|
|
(htdp-test 1 'hash-ref (hash-ref (make-immutable-hash (list (list 'a 1))) 'a))
|
|
(htdp-test 2 'hash-ref (hash-ref (make-immutable-hash (list (list 'a 1))) 'b 2))
|
|
(htdp-test 2 'hash-ref (hash-ref (make-immutable-hash (list (list 'a 1))) 'b (lambda () 2)))
|
|
(htdp-err/rt-test
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(hash-ref! ht 'a 2)))
|
|
(htdp-err/rt-test
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(list (hash-has-key? ht 'a)
|
|
(begin (hash-remove! ht 'a)
|
|
(hash-has-key? ht 'a)))))
|
|
(htdp-test (list #t #f) 'hash-remove
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(list (hash-has-key? ht 'a)
|
|
(hash-has-key? (hash-remove ht 'a) 'a))))
|
|
(htdp-err/rt-test
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(begin (hash-set! ht 'a 2)
|
|
(hash-ref ht 'a))))
|
|
(htdp-test 2 'hash-set
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(hash-ref (hash-set ht 'a 2) 'a)))
|
|
(htdp-err/rt-test
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(begin (hash-update! ht 'a add1)
|
|
(hash-ref ht 'a))))
|
|
(htdp-test 2 'hash-update
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(hash-ref (hash-update ht 'a add1) 'a)))
|
|
(htdp-test 2 'hash-update
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(hash-ref (hash-update ht 'b add1 1) 'b)))
|
|
(htdp-test 2 'hash-update
|
|
(local [(define ht (make-immutable-hash (list (list 'a 1))))]
|
|
(hash-ref (hash-update ht 'b add1 (lambda () 1)) 'b)))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-immutable-hash)))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-immutable-hasheq)))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-immutable-hasheqv)))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-immutable-hash (list (list 'a 1)))))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-immutable-hasheq (list (list 'a 1)))))
|
|
(htdp-test #t 'hash?
|
|
(hash? (make-immutable-hasheqv (list (list 'a 1)))))
|
|
(htdp-test #f 'hash?
|
|
(hash? 1))
|
|
(htdp-test #t 'hash-equal?
|
|
(hash-equal? (make-immutable-hash (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-equal?
|
|
(hash-equal? (make-immutable-hasheq (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-equal?
|
|
(hash-equal? (make-immutable-hasheqv (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eq?
|
|
(hash-eq? (make-immutable-hash (list (list 'a 1)))))
|
|
(htdp-test #t 'hash-eq?
|
|
(hash-eq? (make-immutable-hasheq (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eq?
|
|
(hash-eq? (make-immutable-hasheqv (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eqv?
|
|
(hash-eqv? (make-immutable-hash (list (list 'a 1)))))
|
|
(htdp-test #f 'hash-eqv?
|
|
(hash-eqv? (make-immutable-hasheq (list (list 'a 1)))))
|
|
(htdp-test #t 'hash-eqv?
|
|
(hash-eqv? (make-immutable-hasheqv (list (list 'a 1)))))
|
|
|
|
;; Check set...! error message:
|
|
(htdp-top (define-struct a1 (b)))
|
|
(htdp-err/rt-test (set-a1-b! 1 2) #rx"set-a1-b!")
|
|
(htdp-top-pop 1)
|
|
|
|
;; Simulate set! in the repl
|
|
(module my-advanced-module (lib "htdp-advanced.rkt" "lang")
|
|
(define x 10)
|
|
(define (f y) f)
|
|
(define-struct s (x y)))
|
|
(mz-require 'my-advanced-module)
|
|
(parameterize ([current-namespace (module->namespace ''my-advanced-module)])
|
|
(eval #'(set! x 12))
|
|
(eval #'(set! f 12))
|
|
(eval #'(set! make-s 12))
|
|
(eval #'(set! s-x 12))
|
|
(eval #'(set! s? 12))
|
|
(eval #'(set! set-s-x! 12)))
|
|
|
|
;; define-datatype
|
|
|
|
(htdp-syntax-test #'define-datatype #rx"define-datatype: expected an open parenthesis before define-datatype, but found none")
|
|
(htdp-syntax-test #'(define-datatype) #rx"define-datatype: expected a datatype type name after `define-datatype', but nothing's there")
|
|
(htdp-syntax-test #'(define-datatype dt 10) #rx"define-datatype: expected a variant after the datatype type name in `define-datatype', but found a number")
|
|
(htdp-syntax-test #'(define-datatype dt [v1] 10) #rx"define-datatype: expected a variant after the datatype type name in `define-datatype', but found a number")
|
|
(htdp-syntax-test #'(define-datatype dt v1) #rx"define-datatype: expected a variant after the datatype type name in `define-datatype', but found something else")
|
|
(htdp-syntax-test #'(define-datatype dt [v1 f1 f1]) #rx"define-datatype: in variant `v1': found a field name that is used more than once: f1")
|
|
(htdp-syntax-test #'(define-datatype dt [10]) #rx"define-datatype: expected a variant name, found a number")
|
|
(htdp-syntax-test #'(define-datatype dt [(v1)]) #rx"define-datatype: expected a variant name, found a part")
|
|
(htdp-syntax-test #'(define-datatype dt [v1 10]) #rx"define-datatype: in variant `v1': expected a field name, found a number")
|
|
(htdp-syntax-test #'(define-datatype dt [v1] [v1]) #rx"define-datatype: found a variant name that is used more than once: v1")
|
|
(htdp-syntax-test #'(define-datatype posn [v1]) "posn?: this name was defined previously and cannot be re-defined")
|
|
(htdp-syntax-test #'(define-datatype dt [posn]) "posn: this name was defined previously and cannot be re-defined")
|
|
(htdp-syntax-test #'(define-datatype lambda [v1]) #rx"define-datatype: expected a datatype type name after `define-datatype', but found a keyword")
|
|
(htdp-syntax-test #'(define-datatype dt [lambda]) #rx"define-datatype: expected a variant name, found a keyword")
|
|
(htdp-syntax-test #'(define-datatype (dt)) #rx"define-datatype: expected a datatype type name after `define-datatype', but found a part")
|
|
(htdp-syntax-test #'(+ 1 (define-datatype dt [v1])) #rx"define-datatype: found a definition that is not at the top level")
|
|
|
|
(htdp-top (define-datatype dt))
|
|
(htdp-test #f 'dt? (dt? 1))
|
|
(htdp-top-pop 1)
|
|
|
|
(htdp-top (define x 5))
|
|
(htdp-syntax-test #'(define-datatype x [v1]) #rx"x: this name was defined previously and cannot be re-defined")
|
|
(htdp-syntax-test #'(define-datatype dt [x]) #rx"x: this name was defined previously and cannot be re-defined")
|
|
(htdp-top-pop 1)
|
|
|
|
(htdp-top (define-datatype a
|
|
[a0]
|
|
[a1 b]
|
|
[a3 b c d]))
|
|
(htdp-test #t 'a0? (a0? (make-a0)))
|
|
(htdp-test #t 'a? (a? (make-a0)))
|
|
(htdp-test #t 'a1? (a1? (make-a1 1)))
|
|
(htdp-test #t 'a? (a? (make-a1 1)))
|
|
(htdp-test #t 'a3? (a3? (make-a3 1 2 3)))
|
|
(htdp-test #t 'a? (a? (make-a3 1 2 3)))
|
|
(htdp-test #f 'a1? (a1? (make-a3 1 2 3)))
|
|
(htdp-test #f 'a3? (a3? (make-a1 1)))
|
|
(htdp-test #f 'a? (a? 1))
|
|
(htdp-top-pop 1)
|
|
|
|
;; match
|
|
|
|
(htdp-syntax-test #'match #rx"match: expected an open parenthesis before match, but found none")
|
|
(htdp-syntax-test #'(match) #rx"match: expected an expression after `match', but nothing's there")
|
|
(htdp-syntax-test #'(match 1) #rx"match: expected a pattern--answer clause after the expression following `match', but nothing's there")
|
|
|
|
(htdp-syntax-test #'(match 1 10) #rx"match: expected a pattern--answer clause, but found a number")
|
|
(htdp-syntax-test #'(match 1 x) #rx"match: expected a pattern--answer clause, but found something else")
|
|
(htdp-syntax-test #'(match 1 []) #rx"match: expected a pattern--answer clause, but found an empty clause")
|
|
(htdp-syntax-test #'(match 1 [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there")
|
|
(htdp-syntax-test #'(match 1 [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
|
|
(htdp-syntax-test #'(match 1 [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
|
|
|
|
(htdp-syntax-test #'(match 1 [x 10] 10) #rx"match: expected a pattern--answer clause, but found a number")
|
|
(htdp-syntax-test #'(match 1 [x 10] x) #rx"match: expected a pattern--answer clause, but found something else")
|
|
(htdp-syntax-test #'(match 1 [x 10] []) #rx"match: expected a pattern--answer clause, but found an empty clause")
|
|
(htdp-syntax-test #'(match 1 [x 10] [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there")
|
|
(htdp-syntax-test #'(match 1 [x 10] [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
|
|
(htdp-syntax-test #'(match 1 [x 10] [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
|
|
|
|
(define-syntax-rule (htdp-match/v res pat expr val)
|
|
(htdp-test res 'pat (match expr [pat val] [else #f])))
|
|
(define-syntax-rule (htdp-match res pat expr)
|
|
(htdp-match/v res pat expr #t))
|
|
|
|
(htdp-match #t true true)
|
|
(htdp-match #f true false)
|
|
(htdp-match #f true 1)
|
|
|
|
(htdp-match #f false true)
|
|
(htdp-match #t false false)
|
|
(htdp-match #f false 1)
|
|
|
|
(htdp-match #t empty empty)
|
|
(htdp-match #f empty 1)
|
|
|
|
(htdp-match #t 1 1)
|
|
(htdp-match #t '1 1)
|
|
(htdp-match #t `1 1)
|
|
(htdp-match #f 1 2)
|
|
|
|
(htdp-match #t "foo" "foo")
|
|
(htdp-match #t '"foo" "foo")
|
|
(htdp-match #t `"foo" "foo")
|
|
(htdp-match #f "foo" "bar")
|
|
|
|
(htdp-match #t #\a #\a)
|
|
(htdp-match #t '#\a #\a)
|
|
(htdp-match #t `#\a #\a)
|
|
(htdp-match #f #\a #\b)
|
|
|
|
(htdp-match #t 'a 'a)
|
|
(htdp-match #f 'a 'b)
|
|
|
|
(htdp-match #t '(a b) (list 'a 'b))
|
|
(htdp-match #t ''a ''a)
|
|
(htdp-match #t '`a '`a)
|
|
(htdp-match #t ',a ',a)
|
|
(htdp-match #t ',@a ',@a)
|
|
|
|
(htdp-match #t `(a b) (list 'a 'b))
|
|
(htdp-match #t `'a ''a)
|
|
(htdp-match #t ``a '`a)
|
|
|
|
(htdp-match #t (cons a b) (list 1))
|
|
(htdp-match #f (cons 1 2) 1)
|
|
(htdp-match #t (list a b) (list 1 2))
|
|
(htdp-match #f (list a b) (list 1))
|
|
(htdp-match #t (list* a b) (list 1))
|
|
(htdp-match #f (list* a b) empty)
|
|
|
|
(htdp-match #t (vector x y) (vector 1 2))
|
|
(htdp-match #f (vector x x) (vector 1 2))
|
|
(htdp-match #t (vector _ _) (vector 1 2))
|
|
(htdp-match #f (vector x y) (vector 1))
|
|
|
|
(htdp-match #t (box x) (box 1))
|
|
(htdp-match #f (box x) 1)
|
|
|
|
(htdp-match/v 1 a 1 a)
|
|
|
|
(htdp-top (define-struct my-posn (x y)))
|
|
(htdp-match/v 3 (struct my-posn (x y)) (make-my-posn 1 2) (+ x y))
|
|
(htdp-top-pop 1)
|
|
|
|
(htdp-match/v 3 (struct posn (x y)) (make-posn 1 2) (+ x y))
|
|
(htdp-match/v 3 (cons (struct posn (x y)) empty) (cons (make-posn 1 2) empty) (+ x y))
|
|
(htdp-match/v 3 (list* (struct posn (x y)) empty) (list* (make-posn 1 2) empty) (+ x y))
|
|
(htdp-match/v 3 (list (struct posn (x y))) (list (make-posn 1 2)) (+ x y))
|
|
(htdp-match/v 3 (vector (struct posn (x y))) (vector (make-posn 1 2)) (+ x y))
|
|
(htdp-match/v 3 (box (struct posn (x y))) (box (make-posn 1 2)) (+ x y))
|
|
|
|
(htdp-match/v 3 `,(struct posn (x y)) (make-posn 1 2) (+ x y))
|
|
(htdp-match/v 1 `(a ,b) (list 'a 1) b)
|
|
(htdp-match/v 1 `(a ,@(list b)) (list 'a 1) b)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(report-errs)
|