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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
#lang racket/base
(require "../../parse.rkt"
"../experimental/template.rkt"
racket/dict)
(provide function-header formal formals)
(define-syntax-class function-header
(pattern ((~or header:function-header name:id) . args:formals)
#:attr params
(template ((?@ . (?? header.params ()))
. args.params))))
(define-syntax-class formals
#:attributes (params)
(pattern (arg:formal ...)
#:attr params #'(arg.name ...)
#:fail-when (check-duplicate-identifier (syntax->list #'params))
"duplicate argument name"
#:fail-when (check-duplicate (attribute arg.kw)
#:same? (λ (x y)
(and x y (equal? (syntax-e x)
(syntax-e y)))))
"duplicate keyword for argument"
#:fail-when (invalid-option-placement
(attribute arg.name) (attribute arg.default))
"default-value expression missing")
(pattern (arg:formal ... . rest:id)
#:attr params #'(arg.name ... rest)
#:fail-when (check-duplicate-identifier (syntax->list #'params))
"duplicate argument name"
#:fail-when (check-duplicate (attribute arg.kw)
#:same? (λ (x y)
(and x y (equal? (syntax-e x)
(syntax-e y)))))
"duplicate keyword for argument"
#:fail-when (invalid-option-placement
(attribute arg.name) (attribute arg.default))
"default-value expression missing"))
(define-splicing-syntax-class formal
#:attributes (name kw default)
(pattern name:id
#:attr kw #f
#:attr default #f)
(pattern [name:id default]
#:attr kw #f)
(pattern (~seq kw:keyword name:id)
#:attr default #f)
(pattern (~seq kw:keyword [name:id default])))
;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f
;; Checks for mandatory argument after optional argument; if found, returns
;; identifier of mandatory argument.
(define (invalid-option-placement names defaults)
;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f
;; Finds first name w/o corresponding default.
(define (find-mandatory names defaults)
(for/first ([name (in-list names)]
[default (in-list defaults)]
#:when (not default))
name))
;; Skip through mandatory args until first optional found, then search
;; for another mandatory.
(let loop ([names names] [defaults defaults])
(cond [(or (null? names) (null? defaults))
#f]
[(eq? (car defaults) #f) ;; mandatory
(loop (cdr names) (cdr defaults))]
[else ;; found optional
(find-mandatory (cdr names) (cdr defaults))])))
;; Copied from unstable/list
;; check-duplicate : (listof X)
;; #:key (X -> K)
;; #:same? (or/c (K K -> bool) dict?)
;; -> X or #f
(define (check-duplicate items
#:key [key values]
#:same? [same? equal?])
(cond [(procedure? same?)
(cond [(eq? same? equal?)
(check-duplicate/t items key (make-hash) #t)]
[(eq? same? eq?)
(check-duplicate/t items key (make-hasheq) #t)]
[(eq? same? eqv?)
(check-duplicate/t items key (make-hasheqv) #t)]
[else
(check-duplicate/list items key same?)])]
[(dict? same?)
(let ([dict same?])
(if (dict-mutable? dict)
(check-duplicate/t items key dict #t)
(check-duplicate/t items key dict #f)))]))
(define (check-duplicate/t items key table mutating?)
(let loop ([items items] [table table])
(and (pair? items)
(let ([key-item (key (car items))])
(if (dict-ref table key-item #f)
(car items)
(loop (cdr items) (if mutating?
(begin (dict-set! table key-item #t) table)
(dict-set table key-item #t))))))))
(define (check-duplicate/list items key same?)
(let loop ([items items] [sofar null])
(and (pair? items)
(let ([key-item (key (car items))])
(if (for/or ([prev (in-list sofar)])
(same? key-item prev))
(car items)
(loop (cdr items) (cons key-item sofar)))))))
|
