1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
#lang racket/base
(require scribble/core
(for-syntax racket/base))
(provide cond-element
cond-block)
(define-for-syntax (render-cond stx mk check-result no-matching-case)
(syntax-case stx ()
[(_ [test body0 body ...] ...)
(let ([tests (syntax->list #'(test ...))])
(with-syntax ([(test-expr ...)
(for/list ([test (in-list tests)]
[pos (in-naturals)])
(let loop ([test test])
(syntax-case test (else and or not)
[else
(unless (= pos (sub1 (length tests)))
(raise-syntax-error
#f
"found `else' not in last clause"
stx
test))
#'#t]
[(and test ...)
#`(and . #,(map loop (syntax->list #'(test ...))))]
[(or test ...)
#`(or . #,(map loop (syntax->list #'(test ...))))]
[(not test)
#`(not #,(loop #'test))]
[id
(identifier? #'id)
#'(memq 'id mode)])))]
[mk mk]
[check-result check-result]
[no-matching-case no-matching-case])
#'(mk
(lambda (get put)
(let ([mode (get 'scribble:current-render-mode 'text)])
(cond
[test-expr (check-result (let () body0 body ...))]
...
[else (no-matching-case)]))))))]))
(define-syntax (cond-block stx)
(render-cond stx #'traverse-block #'check-block #'no-block-case))
(define-syntax (cond-element stx)
(render-cond stx #'traverse-element #'check-content #'no-element-case))
(define (check-block v)
(unless (block? v)
(raise-mismatch-error
'cond-block
"clause result is not a block: "
v))
v)
(define (check-content v)
(unless (content? v)
(raise-mismatch-error
'cond-element
"clause result is not content: "
v))
v)
(define (no-block-case)
(raise (make-exn:fail:contract
"cond-element: no clause matched"
(current-continuation-marks))))
(define (no-element-case)
(raise (make-exn:fail:contract
"cond-element: no clause matched"
(current-continuation-marks))))
|
