function-header.rkt (4766B)
1 #lang racket/base 2 3 (require "../../parse.rkt" 4 racket/dict) 5 6 (provide function-header formal formals) 7 8 (define-syntax-class function-header 9 #:attributes (name params args) 10 (pattern ((~or header:function-header name*:id) . args:formals) 11 #:attr params #'((~@ . (~? header.params ())) . args.params) 12 #:attr name #'(~? header.name name*))) 13 14 (define-syntax-class formals 15 #:attributes (params) 16 (pattern (arg:formal ...) 17 #:attr params #'(arg.name ...) 18 #:fail-when (check-duplicate-identifier (syntax->list #'params)) 19 "duplicate argument name" 20 #:fail-when (check-duplicate (attribute arg.kw) 21 #:same? (λ (x y) 22 (and x y (equal? (syntax-e x) 23 (syntax-e y))))) 24 "duplicate keyword for argument" 25 #:fail-when (invalid-option-placement 26 (attribute arg.name) (attribute arg.default)) 27 "default-value expression missing") 28 (pattern (arg:formal ... . rest:id) 29 #:attr params #'(arg.name ... rest) 30 #:fail-when (check-duplicate-identifier (syntax->list #'params)) 31 "duplicate argument name" 32 #:fail-when (check-duplicate (attribute arg.kw) 33 #:same? (λ (x y) 34 (and x y (equal? (syntax-e x) 35 (syntax-e y))))) 36 "duplicate keyword for argument" 37 #:fail-when (invalid-option-placement 38 (attribute arg.name) (attribute arg.default)) 39 "default-value expression missing")) 40 41 (define-splicing-syntax-class formal 42 #:attributes (name kw default) 43 (pattern name:id 44 #:attr kw #f 45 #:attr default #f) 46 (pattern [name:id default] 47 #:attr kw #f) 48 (pattern (~seq kw:keyword name:id) 49 #:attr default #f) 50 (pattern (~seq kw:keyword [name:id default]))) 51 52 ;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f 53 ;; Checks for mandatory argument after optional argument; if found, returns 54 ;; identifier of mandatory argument. 55 (define (invalid-option-placement names defaults) 56 ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f 57 ;; Finds first name w/o corresponding default. 58 (define (find-mandatory names defaults) 59 (for/first ([name (in-list names)] 60 [default (in-list defaults)] 61 #:when (not default)) 62 name)) 63 ;; Skip through mandatory args until first optional found, then search 64 ;; for another mandatory. 65 (let loop ([names names] [defaults defaults]) 66 (cond [(or (null? names) (null? defaults)) 67 #f] 68 [(eq? (car defaults) #f) ;; mandatory 69 (loop (cdr names) (cdr defaults))] 70 [else ;; found optional 71 (find-mandatory (cdr names) (cdr defaults))]))) 72 73 ;; Copied from unstable/list 74 ;; check-duplicate : (listof X) 75 ;; #:key (X -> K) 76 ;; #:same? (or/c (K K -> bool) dict?) 77 ;; -> X or #f 78 (define (check-duplicate items 79 #:key [key values] 80 #:same? [same? equal?]) 81 (cond [(procedure? same?) 82 (cond [(eq? same? equal?) 83 (check-duplicate/t items key (make-hash) #t)] 84 [(eq? same? eq?) 85 (check-duplicate/t items key (make-hasheq) #t)] 86 [(eq? same? eqv?) 87 (check-duplicate/t items key (make-hasheqv) #t)] 88 [else 89 (check-duplicate/list items key same?)])] 90 [(dict? same?) 91 (let ([dict same?]) 92 (if (dict-mutable? dict) 93 (check-duplicate/t items key dict #t) 94 (check-duplicate/t items key dict #f)))])) 95 (define (check-duplicate/t items key table mutating?) 96 (let loop ([items items] [table table]) 97 (and (pair? items) 98 (let ([key-item (key (car items))]) 99 (if (dict-ref table key-item #f) 100 (car items) 101 (loop (cdr items) (if mutating? 102 (begin (dict-set! table key-item #t) table) 103 (dict-set table key-item #t)))))))) 104 (define (check-duplicate/list items key same?) 105 (let loop ([items items] [sofar null]) 106 (and (pair? items) 107 (let ([key-item (key (car items))]) 108 (if (for/or ([prev (in-list sofar)]) 109 (same? key-item prev)) 110 (car items) 111 (loop (cdr items) (cons key-item sofar)))))))