#lang scheme
(require htdp/testing)
(require lang/htdp-advanced)
(provide (all-defined-out))
(require "data.scm")
(define (parse-error-msg production sexp)
(format "~a: malformed syntax: ~a" production sexp))
(define (parse-error production sexp)
(error production (format "malformed syntax: ~a" sexp)))
(define (define-keyword? x)
(and (symbol? x)
(case x
[(define define-struct) true]
[else false])))
(define (expr-keyword? x)
(or (head-keyword? x)
(identifier-keyword? x)))
(define (head-keyword? x)
(and (symbol? x)
(case x
[(begin begin0 set! delay lambda local letrec
shared let let* recur cond case else
if when unless and or time quote
quasiquote unquote unquote-splicing)
true]
[else false])))
(define (identifier-keyword? x)
(and (symbol? x)
(case x
[(empty true false) true]
[else false])))
(define (test-case-keyword? x)
(and (symbol? x)
(case x
[(check-expect check-within check-error) true]
[else false])))
(define (require-keyword? x)
(and (symbol? x)
(symbol=? x 'require)))
(define (name? x)
(and (symbol? x)
(not (any-keyword? x))))
(define (any-keyword? x)
(or (define-keyword? x)
(expr-keyword? x)
(test-case-keyword? x)
(require-keyword? x)))
(define (parse-program sexp)
(if (list? sexp)
(map parse-def-or-expr sexp)
(parse-error 'parse-program sexp)))
(check-expect (parse-program empty) empty)
(check-expect (parse-program '{ 1 }) (list (parse-expr 1)))
(check-error (parse-program 'x)
(parse-error-msg 'parse-program 'x))
(define (parse-def-or-expr sexp)
(cond [(and (cons? sexp) (symbol? (first sexp)))
(case (first sexp)
[(define define-struct)
(parse-definition sexp)]
[(check-expect check-within check-error)
(parse-test-case sexp)]
[(require)
(parse-library-require sexp)]
[else
(parse-expr sexp)])]
[else
(parse-expr sexp)]))
(check-expect (parse-def-or-expr 1)
(parse-expr 1))
(check-expect (parse-def-or-expr '(f x))
(parse-expr '(f x)))
(check-expect (parse-def-or-expr '(define x 1))
(parse-definition '(define x 1)))
(check-expect (parse-def-or-expr '(check-expect x y))
(parse-test-case '(check-expect x y)))
(check-expect (parse-def-or-expr '(require "f"))
(parse-library-require '(require "f")))
(define (parse-define sexp)
(if (= 3 (length sexp))
(cond [(name? (second sexp))
(make-<definition-value> (make-<identifier> (second sexp))
(parse-expr (third sexp)))]
[(and (list? (second sexp))
(not (empty? (second sexp)))
(andmap name? (second sexp)))
(make-<definition-procedure> (make-<identifier> (first (second sexp)))
(map make-<identifier> (rest (second sexp)))
(parse-expr (third sexp)))]
[else
(parse-error 'parse-define sexp)])
(parse-error 'parse-define sexp)))
(define (parse-define-struct sexp)
(if (and (= 3 (length sexp))
(name? (second sexp))
(list? (third sexp))
(andmap name? (third sexp)))
(make-<definition-struct>
(make-<identifier> (second sexp))
(map make-<identifier> (third sexp)))
(parse-error 'parse-define-struct sexp)))
(define (parse-definition sexp)
(cond [(and (pair? sexp) (define-keyword? (first sexp)))
(case (first sexp)
[(define) (parse-define sexp)]
[(define-struct) (parse-define-struct sexp)])]
[else
(parse-error 'parse-definition sexp)]))
(check-expect (parse-definition '(define x 1))
(make-<definition-value> (make-<identifier> 'x)
(parse-expr 1)))
(check-expect (parse-definition '(define (x) 1))
(make-<definition-procedure> (make-<identifier> 'x)
empty
(parse-expr 1)))
(check-expect (parse-definition '(define-struct f ()))
(make-<definition-struct> (make-<identifier> 'f) empty))
(check-expect (parse-definition '(define-struct f (x)))
(make-<definition-struct> (make-<identifier> 'f) (list (make-<identifier> 'x))))
(check-error (parse-definition '(define-struct f (1)))
(parse-error-msg 'parse-define-struct '(define-struct f (1))))
(check-error (parse-definition 1)
(parse-error-msg 'parse-definition 1))
(check-error (parse-definition '(define x y z))
(parse-error-msg 'parse-define '(define x y z)))
(check-error (parse-definition '(defun x 1))
(parse-error-msg 'parse-definition '(defun x 1)))
(check-error (parse-definition '(define (f 1) x))
(parse-error-msg 'parse-define '(define (f 1) x)))
(define (parse-id+exprs name ctx sexp k)
(local [(define (parse-id+exprs-accum sexp ids exprs)
(cond [(empty? sexp) (k (reverse ids) (reverse exprs))]
[(and (list? sexp)
(list? (first sexp))
(= 2 (length (first sexp)))
(name? (first (first sexp))))
(parse-id+exprs-accum
(rest sexp)
(cons (make-<identifier> (first (first sexp))) ids)
(cons (parse-expr (second (first sexp))) exprs))]
[else
(parse-error name ctx)]))]
(parse-id+exprs-accum sexp empty empty)))
(check-expect (parse-id+exprs 'name 'ctx empty list)
(list empty empty))
(check-expect (parse-id+exprs 'name 'ctx '((x 1)) list)
(list (list (make-<identifier> 'x))
(list (parse-expr 1))))
(check-error (parse-id+exprs 'name 'ctx '(1) list)
(parse-error-msg 'name 'ctx))
(define (parse-let-helper name sexp k)
(if (and (= 3 (length sexp))
(list? (second sexp)))
(parse-id+exprs name sexp (second sexp)
(lambda (ids exprs)
(k ids exprs (parse-expr (third sexp)))))
(parse-error name sexp)))
(check-expect (parse-let-helper 'name '(_ () x) list)
(list empty empty (parse-expr 'x)))
(check-expect (parse-let-helper 'name '(_ ((x 1)) x) list)
(list (list (make-<identifier> 'x))
(list (parse-expr 1))
(parse-expr 'x)))
(check-error (parse-let-helper 'name '(_ x) list)
(parse-error-msg 'name '(_ x)))
(define (parse-named-let-helper name sexp k)
(if (and (= 4 (length sexp))
(name? (second sexp))
(list? (third sexp)))
(parse-id+exprs name sexp (third sexp)
(lambda (ids exprs)
(k (make-<identifier> (second sexp))
ids exprs (parse-expr (fourth sexp)))))
(parse-error name sexp)))
(check-expect (parse-named-let-helper 'name '(_ f () x) list)
(list (make-<identifier> 'f)
empty
empty
(make-<identifier> 'x)))
(check-expect (parse-named-let-helper 'name '(_ f ((x 1)) x) list)
(list (make-<identifier> 'f)
(list (make-<identifier> 'x))
(list (parse-expr 1))
(make-<identifier> 'x)))
(check-error (parse-named-let-helper 'name '(_ x) list)
(parse-error-msg 'name '(_ x)))
(define (parse-begin-helper name sexp k)
(if (not (empty? (rest sexp)))
(k (map parse-expr (rest sexp)))
(parse-error name sexp)))
(check-expect (parse-begin-helper 'name '(_ 1) identity)
(list (parse-expr 1)))
(check-expect (parse-begin-helper 'name '(_ 1 2) identity)
(list (parse-expr 1)
(parse-expr 2)))
(check-error (parse-begin-helper 'name '(_) identity)
(parse-error-msg 'name '(_)))
(define (parse-delay-helper name sexp k)
(if (= 2 (length sexp))
(k (parse-expr (second sexp)))
(parse-error name sexp)))
(check-expect (parse-delay-helper 'name '(_ x) identity)
(parse-expr 'x))
(check-error (parse-delay-helper 'name '(_) identity)
(parse-error-msg 'name '(_)))
(check-error (parse-delay-helper 'name '(_ x y) identity)
(parse-error-msg 'name '(_ x y)))
(define (parse-when-helper name sexp k)
(if (= 3 (length sexp))
(k (parse-expr (second sexp)) (parse-expr (third sexp)))
(parse-error name sexp)))
(check-expect (parse-when-helper 'name '(_ x y) list)
(list (parse-expr 'x) (parse-expr 'y)))
(check-error (parse-when-helper 'name '(_ x) list)
(parse-error-msg 'name '(_ x)))
(check-error (parse-when-helper 'name '(_) list)
(parse-error-msg 'name '(_)))
(define (parse-and-helper name sexp k)
(if (<= 3 (length sexp))
(k (map parse-expr (rest sexp)))
(parse-error name sexp)))
(check-expect (parse-and-helper 'name '(_ x y) identity)
(map parse-expr '(x y)))
(check-expect (parse-and-helper 'name '(_ x y z) identity)
(map parse-expr '(x y z)))
(check-error (parse-and-helper 'name '(_ x) identity)
(parse-error-msg 'name '(_ x)))
(define (parse-begin sexp)
(parse-begin-helper 'parse-begin sexp make-<begin>))
(define (parse-begin0 sexp)
(parse-begin-helper 'parse-begin0 sexp make-<begin0>))
(define (parse-set! sexp)
(if (and (= 3 (length sexp))
(name? (second sexp)))
(make-<set!> (make-<identifier> (second sexp))
(parse-expr (third sexp)))
(parse-error 'parse-set! sexp)))
(define (parse-delay sexp)
(parse-delay-helper 'parse-delay sexp make-<delay>))
(define (parse-if sexp)
(if (= 4 (length sexp))
(make-<if> (parse-expr (second sexp))
(parse-expr (third sexp))
(parse-expr (fourth sexp)))
(parse-error 'parse-if sexp)))
(define (parse-when sexp)
(parse-when-helper 'parse-when sexp make-<when>))
(define (parse-unless sexp)
(parse-when-helper 'parse-unless sexp make-<unless>))
(define (parse-and sexp)
(parse-and-helper 'parse-and sexp make-<and>))
(define (parse-or sexp)
(parse-and-helper 'parse-or sexp make-<or>))
(define (parse-time sexp)
(parse-delay-helper 'parse-time sexp make-<time>))
(define (parse-lambda sexp)
(if (and (= 3 (length sexp))
(list? (second sexp))
(andmap name? (second sexp)))
(make-<lambda> (map make-<identifier> (second sexp))
(parse-expr (third sexp)))
(parse-error 'parse-lambda sexp)))
(define (parse-local sexp)
(if (and (= (length sexp) 3)
(list? (second sexp)))
(make-<local> (map parse-definition (second sexp))
(parse-expr (third sexp)))
(parse-error 'parse-local sexp)))
(define (parse-letrec sexp)
(parse-let-helper 'parse-let sexp make-<letrec>))
(define (parse-let sexp)
(case (length sexp)
[(3) (parse-let-helper 'parse-let sexp make-<let>)]
[(4) (parse-named-let-helper 'parse-named-let sexp make-<recur>)]
[else (parse-error 'parse-let sexp)]))
(define (parse-let* sexp)
(parse-let-helper 'parse-let* sexp make-<let*>))
(define (parse-shared sexp)
(parse-let-helper 'parse-shared sexp make-<shared>))
(define (parse-recur sexp)
(parse-named-let-helper 'parse-recur sexp make-<recur>))
(define (parse-cond sexp)
(local [(define (parse-cond-clauses-accum cs qs as)
(if (and (pair? cs)
(list? (first cs))
(= 2 (length (first cs))))
(if (empty? (rest cs))
(if (symbol=? (first (first cs)) 'else)
(make-<cond/else> (reverse qs) (reverse as) (parse-expr (second (first cs))))
(make-<cond> (reverse (cons (parse-expr (first (first cs))) qs))
(reverse (cons (parse-expr (second (first cs))) as))))
(parse-cond-clauses-accum
(rest cs)
(cons (parse-expr (first (first cs))) qs)
(cons (parse-expr (second (first cs))) as)))
(parse-error 'parse-cond sexp)))]
(parse-cond-clauses-accum (rest sexp) empty empty)))
(define (choice? x)
(or (number? x)
(symbol? x)))
(define (parse-choice sexp)
(cond [(number? sexp) (make-<number> sexp)]
[(symbol? sexp) (make-<identifier> sexp)]))
(define (parse-case sexp)
(local [(define (parse-case-lines-accum ls cs as)
(if (and (pair? ls)
(list? (first ls))
(= 2 (length (first ls)))
(or (and (list? (first (first ls)))
(andmap choice? (first (first ls))))
(and (symbol? (first (first ls)))
(symbol=? 'else (first (first ls))))))
(if (empty? (rest ls))
(if (and (symbol? (first (first ls)))
(symbol=? (first (first ls)) 'else))
(make-<case/else> (parse-expr (second sexp))
(reverse cs)
(reverse as)
(parse-expr (second (first ls))))
(make-<case> (parse-expr (second sexp))
(reverse (cons (map parse-choice (first (first ls))) cs))
(reverse (cons (parse-expr (second (first ls))) as))))
(parse-case-lines-accum
(rest ls)
(cons (map parse-choice (first (first ls))) cs)
(cons (parse-expr (second (first ls))) as)))
(parse-error 'parse-case sexp)))]
(if (<= 3 (length sexp))
(parse-case-lines-accum (rest (rest sexp)) empty empty)
(parse-error 'parse-case sexp))))
(define (parse-quote sexp)
(if (= 2 (length sexp))
(make-<quote> (parse-quoted (second sexp)))
(parse-error 'parse-quote sexp)))
(define (parse-quoted sexp)
(cond [(symbol? sexp)
(make-<identifier> sexp)]
[(number? sexp)
(make-<number> sexp)]
[(string? sexp)
(make-<string> sexp)]
[(char? sexp)
(make-<character> sexp)]
[(list? sexp)
(make-<quoted-list> (map parse-quoted sexp))]))
(define (parse-application sexp)
(make-<application> (parse-expr (first sexp))
(map parse-expr (rest sexp))))
(define (parse-expr sexp)
(cond [(and (pair? sexp) (head-keyword? (first sexp)))
(case (first sexp)
[(begin) (parse-begin sexp)]
[(begin0) (parse-begin0 sexp)]
[(set!) (parse-set! sexp)]
[(delay) (parse-delay sexp)]
[(lambda) (parse-lambda sexp)]
[(local) (parse-local sexp)]
[(letrec) (parse-letrec sexp)]
[(shared) (parse-shared sexp)]
[(let) (parse-let sexp)]
[(let*) (parse-let* sexp)]
[(recur) (parse-recur sexp)]
[(cond) (parse-cond sexp)]
[(case) (parse-case sexp)]
[(if) (parse-if sexp)]
[(when) (parse-when sexp)]
[(unless) (parse-unless sexp)]
[(and) (parse-and sexp)]
[(or) (parse-or sexp)]
[(time) (parse-time sexp)]
[(quote) (parse-quote sexp)])]
[(cons? sexp) (parse-application sexp)]
[(name? sexp) (make-<identifier> sexp)]
[(number? sexp) (make-<number> sexp)]
[(string? sexp) (make-<string> sexp)]
[(char? sexp) (make-<character> sexp)]
[(identifier-keyword? sexp)
(case sexp
[(empty) (make-<empty>)]
[(true) (make-<true>)]
[(false) (make-<false>)])]
[else (parse-error 'parse-expr sexp)]))
(check-expect (parse-expr 'empty)
(make-<empty>))
(check-expect (parse-expr 'true)
(make-<true>))
(check-expect (parse-expr 'false)
(make-<false>))
(check-expect (parse-expr 5)
(make-<number> 5))
(check-expect (parse-expr #\a)
(make-<character> #\a))
(check-expect (parse-expr "hi")
(make-<string> "hi"))
(check-expect (parse-expr '(f x))
(make-<application> (parse-expr 'f) (list (parse-expr 'x))))
(check-expect (parse-expr '(begin x))
(make-<begin> (list (parse-expr 'x))))
(check-expect (parse-expr '(begin0 x))
(make-<begin0> (list (parse-expr 'x))))
(check-expect (parse-expr '(set! x y))
(make-<set!> (make-<identifier> 'x)
(parse-expr 'y)))
(check-error (parse-expr '(set! 1 x))
(parse-error-msg 'parse-set! '(set! 1 x)))
(check-expect (parse-expr '(delay x))
(make-<delay> (parse-expr 'x)))
(check-expect (parse-expr '(let () 1))
(make-<let> empty empty (parse-expr 1)))
(check-expect (parse-expr '(let* () 1))
(make-<let*> empty empty (parse-expr 1)))
(check-expect (parse-expr '(letrec () 1))
(make-<letrec> empty empty (parse-expr 1)))
(check-expect (parse-expr '(shared () 1))
(make-<shared> empty empty (parse-expr 1)))
(check-expect (parse-expr '(let ((x 1)) x))
(make-<let> (list (make-<identifier> 'x))
(list (parse-expr 1))
(parse-expr 'x)))
(check-expect (parse-expr '(let ((x 1) (y 2)) x))
(make-<let> (list (make-<identifier> 'x)
(make-<identifier> 'y))
(list (parse-expr 1)
(parse-expr 2))
(parse-expr 'x)))
(check-expect (parse-expr '(let f () x))
(make-<recur> (make-<identifier> 'f)
empty
empty
(parse-expr 'x)))
(check-expect (parse-expr '(let f ((x 1)) x))
(make-<recur> (make-<identifier> 'f)
(list (make-<identifier> 'x))
(list (parse-expr 1))
(parse-expr 'x)))
(check-error (parse-expr '(let f))
(parse-error-msg 'parse-let '(let f)))
(check-expect (parse-expr '(cond [x y]))
(make-<cond> (list (parse-expr 'x))
(list (parse-expr 'y))))
(check-expect (parse-expr '(cond [u v] [w x]))
(make-<cond> (list (parse-expr 'u) (parse-expr 'w))
(list (parse-expr 'v) (parse-expr 'x))))
(check-expect (parse-expr '(cond [else x]))
(make-<cond/else> empty empty (parse-expr 'x)))
(check-expect (parse-expr '(cond [u v] [else w]))
(make-<cond/else> (list (parse-expr 'u))
(list (parse-expr 'v))
(parse-expr 'w)))
(check-error (parse-expr '(cond x))
(parse-error-msg 'parse-cond '(cond x)))
(check-error (parse-expr '(cond [x]))
(parse-error-msg 'parse-cond '(cond (x))))
(check-error (parse-expr '(cond [x y z]))
(parse-error-msg 'parse-cond '(cond (x y z))))
(check-expect (parse-expr '(case x [(1) x]))
(make-<case> (parse-expr 'x)
(list (list (parse-choice 1)))
(list (parse-expr 'x))))
(check-expect (parse-expr '(case x [(a) x]))
(make-<case> (parse-expr 'x)
(list (list (parse-choice 'a)))
(list (parse-expr 'x))))
(check-expect (parse-expr '(case x [(a 1) x]))
(make-<case> (parse-expr 'x)
(list (list (parse-choice 'a) (parse-choice 1)))
(list (parse-expr 'x))))
(check-expect (parse-expr '(case x [(1) x] [(b) y]))
(make-<case> (parse-expr 'x)
(list (list (parse-choice '1)) (list (parse-choice 'b)))
(list (parse-expr 'x) (parse-expr 'y))))
(check-error (parse-expr '(case x))
(parse-error-msg 'parse-case '(case x)))
(check-error (parse-expr '(case x ["f" x]))
(parse-error-msg 'parse-case '(case x ["f" x])))
(check-expect (parse-expr '(case x [(a) x] [else z]))
(make-<case/else> (parse-expr 'x)
(list (list (parse-choice 'a)))
(list (parse-expr 'x))
(parse-expr 'z)))
(check-expect (parse-expr '(case x [(a 1) x] [else z]))
(make-<case/else> (parse-expr 'x)
(list (list (parse-choice 'a) (parse-choice 1)))
(list (parse-expr 'x))
(parse-expr 'z)))
(check-expect (parse-expr '(case x [(1) x] [(b) y] [else z]))
(make-<case/else> (parse-expr 'x)
(list (list (parse-choice '1)) (list (parse-choice 'b)))
(list (parse-expr 'x) (parse-expr 'y))
(parse-expr 'z)))
(check-expect (parse-expr '(recur f () x))
(make-<recur> (make-<identifier> 'f)
empty
empty
(parse-expr 'x)))
(check-expect (parse-expr '(recur f ((x 1)) x))
(make-<recur> (make-<identifier> 'f)
(list (make-<identifier> 'x))
(list (parse-expr 1))
(parse-expr 'x)))
(check-expect (parse-expr '(if x y z))
(make-<if> (parse-expr 'x)
(parse-expr 'y)
(parse-expr 'z)))
(check-error (parse-expr '(if x))
(parse-error-msg 'parse-if '(if x)))
(check-error (parse-expr '(if x y))
(parse-error-msg 'parse-if '(if x y)))
(check-expect (parse-expr '(when x y))
(make-<when> (parse-expr 'x)
(parse-expr 'y)))
(check-expect (parse-expr '(unless x y))
(make-<unless> (parse-expr 'x)
(parse-expr 'y)))
(check-expect (parse-expr '(and x y))
(make-<and> (map parse-expr '(x y))))
(check-expect (parse-expr '(and x y z))
(make-<and> (map parse-expr '(x y z))))
(check-expect (parse-expr '(or x y))
(make-<or> (map parse-expr '(x y))))
(check-expect (parse-expr '(or x y z))
(make-<or> (map parse-expr '(x y z))))
(check-expect (parse-expr '(time x))
(make-<time> (parse-expr 'x)))
(check-expect (parse-expr '(lambda () x))
(make-<lambda> empty (parse-expr 'x)))
(check-expect (parse-expr '(lambda (x) x))
(make-<lambda> (list (make-<identifier> 'x))
(parse-expr 'x)))
(check-expect (parse-expr '(lambda (x y z) x))
(make-<lambda> (list (make-<identifier> 'x)
(make-<identifier> 'y)
(make-<identifier> 'z))
(parse-expr 'x)))
(check-error (parse-expr '(lambda (1) x))
(parse-error-msg 'parse-lambda '(lambda (1) x)))
(check-expect (parse-expr '(local () x))
(make-<local> empty (parse-expr 'x)))
(check-expect (parse-expr '(local ((define x 1)) x))
(make-<local> (list (parse-definition '(define x 1)))
(parse-expr 'x)))
(check-error (parse-expr '(local () x y))
(parse-error-msg 'parse-local '(local () x y)))
(check-error (parse-expr '(local x y))
(parse-error-msg 'parse-local '(local x y)))
(check-expect (parse-expr '((f g) x))
(make-<application>
(make-<application> (parse-expr 'f)
(list (parse-expr 'g)))
(list (parse-expr 'x))))
(check-error (parse-expr '(lambda (lambda) lambda))
(parse-error-msg 'parse-lambda '(lambda (lambda) lambda)))
(check-error (parse-expr '(lambda (quote) quote))
(parse-error-msg 'parse-lambda '(lambda (quote) quote)))
(check-expect (parse-expr '(quote x))
(make-<quote> (make-<identifier> 'x)))
(check-expect (parse-expr '(quote quote))
(make-<quote> (make-<identifier> 'quote)))
(check-expect (parse-expr '(quote 3))
(make-<quote> (make-<number> 3)))
(check-expect (parse-expr '(quote "s"))
(make-<quote> (make-<string> "s")))
(check-expect (parse-expr '(quote #\c))
(make-<quote> (make-<character> #\c)))
(check-expect (parse-expr '(quote ()))
(make-<quote> (make-<quoted-list> empty)))
(check-expect (parse-expr '(quote (x y lambda)))
(make-<quote> (make-<quoted-list>
(list (make-<identifier> 'x)
(make-<identifier> 'y)
(make-<identifier> 'lambda)))))
(check-error (parse-expr '(quote x y))
(parse-error-msg 'parse-quote '(quote x y)))
(check-error (parse-expr 'quote)
(parse-error-msg 'parse-expr 'quote))
(define (parse-test-case s)
(case (first s)
[(check-expect)
(cond [(and (list? s) (= 3 (length s)))
(make-<check-expect> (parse-expr (second s))
(parse-expr (third s)))]
[else (parse-error 'check-expect s)])]
[(check-within)
(cond [(and (list? s) (= 4 (length s)))
(make-<check-within> (parse-expr (second s))
(parse-expr (third s))
(parse-expr (fourth s)))]
[else (parse-error 'check-within s)])]
[(check-error)
(cond [(and (list? s) (= 3 (length s)))
(make-<check-error> (parse-expr (second s))
(parse-expr (third s)))]
[else (parse-error 'check-error s)])]))
(check-expect (parse-test-case '(check-expect e1 e2))
(make-<check-expect> (parse-expr 'e1) (parse-expr 'e2)))
(check-expect (parse-test-case '(check-within e1 e2 e3))
(make-<check-within> (parse-expr 'e1) (parse-expr 'e2) (parse-expr 'e3)))
(check-expect (parse-test-case '(check-error e1 e2))
(make-<check-error> (parse-expr 'e1) (parse-expr 'e2)))
(check-error (parse-test-case '(check-expect))
(parse-error-msg 'check-expect '(check-expect)))
(check-error (parse-test-case '(check-within))
(parse-error-msg 'check-within '(check-within)))
(check-error (parse-test-case '(check-error))
(parse-error-msg 'check-error '(check-error)))
(define (parse-library-require sexp)
(if (and (list? sexp)
(= 2 (length sexp))
(symbol? (first sexp))
(symbol=? (first sexp) 'require))
(cond [(string? (second sexp))
(make-<require-file> (second sexp))]
[(and (list? (second sexp))
(>= (length (second sexp)) 2)
(and (symbol? (first (second sexp)))
(symbol=? 'lib (first (second sexp))))
(andmap string? (rest (second sexp))))
(make-<require-lib> (rest (second sexp)))]
[(and (list? (second sexp))
(= 3 (length (second sexp)))
(and (symbol? (first (second sexp)))
(symbol=? 'planet (first (second sexp))))
(string? (second (second sexp)))
(list? (third (second sexp)))
(= 4 (length (third (second sexp))))
(string? (first (third (second sexp))))
(string? (second (third (second sexp))))
(number? (third (third (second sexp))))
(number? (fourth (third (second sexp)))))
(make-<require-planet>
(second (second sexp))
(first (third (second sexp)))
(second (third (second sexp)))
(third (third (second sexp)))
(fourth (third (second sexp))))]
[else
(parse-error 'parse-require sexp)])
(parse-error 'parse-require sexp)))
(check-expect (parse-library-require '(require "f"))
(make-<require-file> "f"))
(check-error (parse-library-require '(require 1))
(parse-error-msg 'parse-require '(require 1)))
(check-error (parse-library-require '(require f g))
(parse-error-msg 'parse-require '(require f g)))
(check-expect (parse-library-require '(require (lib "f")))
(make-<require-lib> (list "f")))
(check-expect (parse-library-require '(require (lib "f" "g")))
(make-<require-lib> (list "f" "g")))
(check-error (parse-library-require '(require (lib f)))
(parse-error-msg 'parse-require '(require (lib f))))
(check-expect (parse-library-require
'(require (planet "tetris.ss" ("dvanhorn" "tetris.plt" 5 0))))
(make-<require-planet> "tetris.ss"
"dvanhorn"
"tetris.plt"
5
0))
(generate-report)