1 2(module norm-define '#%kernel 3 (#%require "define-et-al.rkt" "qq-and-or.rkt" "stxcase-scheme.rkt" 4 "member.rkt" "stx.rkt" "qqstx.rkt") 5 6 (#%provide normalize-definition normalize-definition/mk-rhs) 7 8 (define-values (normalize-definition/mk-rhs) 9 (lambda (stx lambda-stx check-context? allow-key+opt? err-no-body?) 10 (when (and check-context? 11 (memq (syntax-local-context) '(expression))) 12 (raise-syntax-error 13 #f 14 "not allowed in an expression context" 15 stx)) 16 (syntax-case stx () 17 [(_ id expr) 18 (identifier? #'id) 19 (values #'id values #'expr)] 20 [(_ id . rest) 21 (identifier? #'id) 22 (raise-syntax-error 23 #f 24 (syntax-case stx () 25 [(_ id expr0 expr ...) 26 "bad syntax (multiple expressions after identifier)"] 27 [(_ id) 28 "bad syntax (missing expression after identifier)"] 29 [(_ id . rest) 30 "bad syntax (illegal use of `.')"]) 31 stx)] 32 [(_ something . rest) 33 (not (stx-pair? #'something)) 34 (raise-syntax-error 35 #f 36 "bad syntax" 37 stx 38 #'something)] 39 [(_ proto . body) 40 (let-values ([(id mk-rhs) 41 (letrec ([simple-proto 42 ;; check the args and set up a proc-maker; we return 43 ;; a proc maker instead of a final proc to enable 44 ;; left-to-right checking of the function protos 45 (lambda (proto) 46 (let-values ([(args rests mk-rhs) 47 (syntax-case proto () 48 [(id arg ...) 49 (values (syntax->list #'(arg ...)) 50 null 51 (lambda (body) 52 (quasisyntax/loc stx (#,lambda-stx (arg ...) 53 . #,body))))] 54 [(id arg ... . rest) 55 (values (syntax->list #'(arg ...)) 56 (list #'rest) 57 (lambda (body) 58 (quasisyntax/loc stx 59 (#,lambda-stx (arg ... . rest) 60 . #,body))))])]) 61 (let* ([args (if allow-key+opt? 62 (let* ([kw-ht (make-hasheq)] 63 [check-kw 64 (lambda (kw) 65 (when (hash-ref kw-ht (syntax-e kw) #f) 66 (raise-syntax-error 67 #f 68 "duplicate keyword for argument" 69 stx 70 kw)) 71 (hash-set! kw-ht (syntax-e kw) #t))]) 72 (let loop ([args args][need-def? #f]) 73 (syntax-case args () 74 [() null] 75 [(id . more) 76 (identifier? #'id) 77 (if need-def? 78 (raise-syntax-error 79 #f 80 "default-value expression missing" 81 stx 82 #'id) 83 (cons #'id (loop #'more #f)))] 84 [([id def-expr] . more) 85 (identifier? #'id) 86 (cons #'id (loop #'more #t))] 87 [(kw id . more) 88 (and (keyword? (syntax-e #'kw)) 89 (identifier? #'id)) 90 (begin 91 (check-kw #'kw) 92 (cons #'id (loop #'more need-def?)))] 93 [(kw [id def-expr] . more) 94 (and (keyword? (syntax-e #'kw)) 95 (identifier? #'id)) 96 (begin 97 (check-kw #'kw) 98 (cons #'id (loop #'more need-def?)))] 99 [(kw . more) 100 (keyword? (syntax-e #'kw)) 101 (raise-syntax-error #f 102 "missing argument identifier after keyword" 103 stx 104 #'kw)] 105 [(x . more) 106 (raise-syntax-error 107 #f 108 "not an identifier, identifier with default, or keyword for procedure argument" 109 stx 110 #'x)]))) 111 args)] 112 [all-args (if (null? rests) 113 args 114 (append args rests))]) 115 (for-each (lambda (a) 116 (unless (identifier? a) 117 (raise-syntax-error 118 #f 119 "not an identifier for procedure argument" 120 stx 121 a))) 122 all-args) 123 (let ([dup (check-duplicate-identifier all-args)]) 124 (when dup 125 (raise-syntax-error 126 #f 127 "duplicate argument identifier" 128 stx 129 dup))) 130 mk-rhs)))] 131 [general-proto 132 ;; proto is guaranteed to be a stx-pair 133 (lambda (proto) 134 (syntax-case proto () 135 [(id . rest) 136 (identifier? #'id) 137 (values #'id 138 (simple-proto proto))] 139 [((something . more) . rest) 140 (let-values ([(id mk-rhs) (general-proto #'(something . more))]) 141 (let ([mk-inner (simple-proto proto)]) 142 (values id 143 (lambda (body) 144 (mk-rhs (list (mk-inner body)))))))] 145 [(other . rest) 146 (raise-syntax-error 147 #f 148 "bad syntax (not an identifier for procedure name, and not a nested procedure form)" 149 stx 150 #'other)]))]) 151 (general-proto #'proto))]) 152 (unless (stx-list? #'body) 153 (raise-syntax-error 154 #f 155 "bad syntax (illegal use of `.' for procedure body)" 156 stx)) 157 (when (and err-no-body? (stx-null? #'body)) 158 (raise-syntax-error 159 #f 160 "bad syntax (no expressions for procedure body)" 161 stx)) 162 (values id mk-rhs #'body))]))) 163 164 (define-values (normalize-definition) 165 (case-lambda 166 [(stx lambda-stx check-context? allow-key+opt?) 167 (let-values ([(id mk-rhs body) 168 (normalize-definition/mk-rhs stx lambda-stx check-context? allow-key+opt? #t)]) 169 (values id (mk-rhs body)))] 170 [(stx lambda-stx check-context?) (normalize-definition stx lambda-stx check-context? #f)] 171 [(stx lambda-stx) (normalize-definition stx lambda-stx #t #f)]))) 172