1(module kw mzscheme 2 3(require-for-syntax syntax/name) 4 5(begin-for-syntax ; -> configuration for lambda/kw 6 ;; must appear at the end, each with exactly one variable 7 (define rest-like-kwds 8 '(#:rest #:body #:all-keys #:other-keys #:other-keys+body)) 9 ;; mode keys are in the end, without variable, cannot have contradictions 10 ;; each descriptor for #:allow-kwd and #:forbid-kwd is 11 ;; (kwd-sym (forcer ...) (enabler ...)) 12 ;; `forcer' is a rest-like keyword that forces the mode, `enabler' is a 13 ;; rest-like keyword that makes it on by default 14 (define mode-keyword-specs 15 '((other-keys (#:other-keys) (#:rest #:all-keys #:other-keys+body)) 16 (duplicate-keys () (#:rest #:all-keys)) 17 (body (#:body) (#:rest #:other-keys+body)) 18 (anything () ()))) 19 ;; precomputed mode keyword stuff 20 (define processed-keyword-specs 21 (map (lambda (ks) 22 (let* ([k (car ks)] 23 [make (lambda (str) 24 (string->keyword 25 (string-append str (symbol->string k))))]) 26 (list* k (make "allow-") (make "forbid-") (cdr ks)))) 27 mode-keyword-specs)) 28 (define mode-keywords 29 (apply append (map (lambda (ks) (list (cadr ks) (caddr ks))) 30 processed-keyword-specs)))) 31 32(define true (list 'true)) ; used for flag values 33 34(provide lambda/kw) 35(define-syntax (lambda/kw stx) 36 ;; -------------------------------------------------------------------------- 37 ;; easy syntax errors 38 (define (serror sub fmt . args) 39 (apply raise-syntax-error 40 #f (apply format fmt args) stx (if sub (list sub) '()))) 41 ;; contents of syntax 42 (define (syntax-e* x) (if (syntax? x) (syntax-e x) x)) 43 ;; turns formals into a syntax list 44 (define (formals->list formals) 45 (syntax-case formals () 46 [(formal ... . rest) 47 (not (null? (syntax-e #'rest))) 48 ;; dot is exactly like #:rest, but don't allow it with other 49 ;; meta-keywords since its meaning is confusing 50 (let* ([formals (syntax->list #'(formal ...))] 51 [kwd (ormap (lambda (s) (and (keyword? (syntax-e* s)) s)) 52 formals)]) 53 (if kwd 54 (serror #'rest "use #:rest or #:body instead of dot notation" 55 ;; (syntax-e* kwd) <- confusing to show this 56 ) 57 (append formals (list #'#:rest #'rest))))] 58 [(formal ...) (syntax->list formals)])) 59 ;; split a list of syntax objects based on syntax keywords: 60 ;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...) 61 (define (split-by-keywords xs) 62 (let loop ([xs (if (syntax? xs) (formals->list xs) xs)] [cur '()] [r '()]) 63 (if (null? xs) 64 (reverse (cons (reverse cur) r)) 65 (let ([x (car xs)]) 66 (if (keyword? (syntax-e* x)) 67 (loop (cdr xs) (list x) (cons (reverse cur) r)) 68 (loop (cdr xs) (cons x cur) r)))))) 69 ;; -------------------------------------------------------------------------- 70 ;; process an optional argument spec, returns (<id> <default-expr>) 71 (define (process-opt o) 72 (syntax-case o () 73 [(var default) (identifier? #'var) (list #'var #'default)] 74 [(var) (identifier? #'var) (list #'var #'#f)] 75 [var (identifier? #'var) (list #'var #'#f)] 76 [var (serror #'var "not a valid ~a spec" #:optional)])) 77 ;; -------------------------------------------------------------------------- 78 ;; process a key argument spec, returns (<id> <key-stx> <default-expr>) 79 (define (process-key k) 80 (define (key var) 81 (datum->syntax-object 82 k (string->keyword (symbol->string (syntax-e var))) k k)) 83 (syntax-case k () 84 [(var key default) 85 (and (identifier? #'var) (keyword? (syntax-e #'key))) 86 (list #'var #'key #'default)] 87 [(var default) (identifier? #'var) (list #'var (key #'var) #'default)] 88 [(var) (identifier? #'var) (list #'var (key #'var) #'#f)] 89 [var (identifier? #'var) (list #'var (key #'var) #'#f)] 90 [var (serror #'var "not a valid ~a spec" #:key)])) 91 ;; -------------------------------------------------------------------------- 92 ;; process a flag argument spec, returns (<id> <key-stx> <default-expr>) 93 ;; so it can be used like keys 94 (define (process-flag k) 95 (define (key var) 96 (datum->syntax-object 97 k (string->keyword (symbol->string (syntax-e var))) k k)) 98 (syntax-case k () 99 [(var key) 100 (and (identifier? #'var) (keyword? (syntax-e #'key))) 101 (list #'var #'key #'#f)] 102 [(var) (identifier? #'var) (list #'var (key #'var) #'#f)] 103 [var (identifier? #'var) (list #'var (key #'var) #'#f)] 104 [var (serror #'var "not a valid ~a spec" #:flag)])) 105 ;; -------------------------------------------------------------------------- 106 ;; helpers for process-vars 107 (define ((process-mode modes rests) processed-spec) 108 (let ([allow (memq (cadr processed-spec) modes)] 109 [forbid (memq (caddr processed-spec) modes)] 110 [allow-any (memq #:allow-anything modes)] 111 [forbid-any (memq #:forbid-anything modes)]) 112 (cond 113 [(and allow forbid) 114 (serror #f "contradicting #:...-~a keywords" (car processed-spec))] 115 [(and forbid allow-any) 116 (serror #f "~a contradicts #:allow-anything" (caddr processed-spec))] 117 [(and allow forbid-any) 118 (serror #f "~a contradicts #:forbid-anything" (cadr processed-spec))] 119 [(ormap (lambda (k) (assq k rests)) (cadddr processed-spec)) 120 => ; forced? 121 (lambda (r) 122 (when (or forbid forbid-any) 123 (serror #f "cannot ~s with ~s" 124 (car (or forbid forbid-any)) (car r))) 125 #t)] 126 [(or allow allow-any) #t] 127 [(or forbid forbid-any) #f] 128 [else (ormap (lambda (k) (and (assq k rests) #t)) ; suggested? 129 (car (cddddr processed-spec)))]))) 130 (define (make-keyword-get-expr key rest default known-vars) 131 ;; expand (for id macros) and check if it's a simple expression, because if 132 ;; it is, evaluation cannot have side-effects and we can use keyword-get* 133 (define default* 134 (local-expand default 'expression (cons #'#%app known-vars))) 135 (define simple? 136 (syntax-case default* (#%datum #%top quote) 137 [(#%datum . _) #t] [(#%top . _) #t] [(quote . _) #t] 138 [_ (identifier? default*)])) 139 (with-syntax ([getter (if simple? #'keyword-get* #'keyword-get)] 140 [default (if simple? default* #`(lambda () #,default*))] 141 [rest rest] [key key]) 142 #'(getter rest key default))) 143 ;; -------------------------------------------------------------------------- 144 ;; test variables 145 (define (process-vars vars opts keys0 flags rests modes . only-vars?) 146 (define (gensym x) 147 (car (generate-temporaries (list x)))) 148 (let*-values 149 ([(only-vars?) (and (pair? only-vars?) (car only-vars?))] 150 [(opts) (map process-opt opts)] 151 [(keys0) (map process-key keys0)] 152 [(flags) (map process-flag flags)] 153 [(rest body all-keys other-keys other-keys+body) 154 (apply values (map (lambda (k) 155 (cond [(assq k rests) => cdr] [else #f])) 156 rest-like-kwds))] 157 [(rest*) (or rest (gensym #'rest))] 158 [(body*) (if (and body (identifier? body)) body (gensym #'body))] 159 [(other-keys*) (or other-keys (gensym #'other-keys))] 160 [(other-keys-mode duplicate-keys-mode body-mode anything-mode) 161 (apply values (map (process-mode modes rests) 162 processed-keyword-specs))] 163 ;; turn (<id> <key> <default>) keys to (<id> <getter>) 164 [(keys) 165 (with-syntax ([rst rest*]) 166 (let loop ([ks (append keys0 flags)] [r '()] 167 [known-vars (append vars (map car opts))]) 168 (if (null? ks) 169 (reverse r) 170 (let ([k (car ks)]) 171 (loop (cdr ks) 172 (cons (list (car k) 173 (make-keyword-get-expr 174 (cadr k) rest* (caddr k) known-vars)) 175 r) 176 (cons (car k) known-vars))))))] 177 [(all-ids) 178 `(,@vars ,@(map car opts) ,@(map car keys) ,rest* ,body* 179 ;; make up names if not specified, to make checking easy 180 ,(or all-keys (gensym #'all-keys)) 181 ,(or other-keys (gensym #'other-keys)) 182 ,(or other-keys+body (gensym #'other-keys+body)) 183 ,@(if (and body (not (identifier? body))) 184 (parse-formals body #t) '()))]) 185 (cond [only-vars? all-ids] 186 [(ormap (lambda (x) (and (not (identifier? x)) x)) all-ids) 187 => (lambda (d) (serror d "not an identifier"))] 188 [(check-duplicate-identifier all-ids) 189 => (lambda (d) (serror d "duplicate argument name"))] 190 [else (values 191 vars opts keys (map cadr flags) rest rest* body body* 192 all-keys other-keys other-keys* other-keys+body 193 other-keys-mode duplicate-keys-mode body-mode anything-mode 194 (append (map cadr keys0) (map cadr flags)))]))) 195 ;; -------------------------------------------------------------------------- 196 ;; parses formals, returns list of normal vars, optional var specs, key var 197 ;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys 198 ;; or not; no duplicate names 199 (define (parse-formals formals . only-vars?) 200 (let* ([formals (split-by-keywords formals)] 201 [vars (car formals)] 202 [formals (cdr formals)] 203 [opts '()] 204 [keys '()] 205 [flags '()]) 206 (when (and (pair? formals) (eq? #:optional (syntax-e* (caar formals)))) 207 (set! opts (cdar formals)) (set! formals (cdr formals))) 208 (let loop ([last #f]) 209 (let* ([k-stx (and (pair? formals) (caar formals))] 210 [k (and k-stx (syntax-e* k-stx))]) 211 (when (and k (eq? k last)) (serror k-stx "two ~s sections" k)) 212 (case k 213 [(#:key) (set! keys (append keys (cdar formals))) 214 (set! formals (cdr formals)) (loop k)] 215 [(#:flag) (set! flags (append flags (cdar formals))) 216 (set! formals (cdr formals)) (loop k)] 217 #| else continue below |#))) 218 ;; now get all rest-like vars and modes 219 (let loop ([formals formals] [rests '()] [modes '()]) 220 (if (null? formals) 221 (apply process-vars vars opts keys flags rests modes only-vars?) 222 (let* ([k-stx (caar formals)] 223 [k (syntax-e* k-stx)]) 224 (cond [(memq k '(#:optional #:key #:flag)) 225 (serror k-stx "misplaced ~a" k)] 226 [(memq k mode-keywords) 227 (cond 228 #; ;(*) 229 ;; don't throw an error here, it is still fine if used with 230 ;; #:allow-other-keys (explicit or implicit), also below 231 [(and (null? keys) (null? flags)) 232 (serror k-stx "cannot use without #:key/#:flag arguments")] 233 [(pair? (cdar formals)) 234 (serror (cadar formals) 235 "identifier following mode keyword ~a" k)] 236 [else (loop (cdr formals) rests (cons k modes))])] 237 [(not (memq k rest-like-kwds)) 238 (serror k-stx "unknown meta keyword")] 239 [(assq k rests) 240 (serror k-stx "duplicate ~a" k)] 241 [(null? (cdar formals)) 242 (serror k-stx "missing variable name")] 243 [(not (null? (cddar formals))) 244 (serror k-stx "too many variable names")] 245 #; ;(*) 246 ;; same as above: don't throw an error here, still fine if 247 ;; used with #:allow-other-keys (explicit or implicit) 248 [(and (null? keys) (not (eq? #:rest k))) 249 (serror k-stx "cannot use without #:key/#:flag arguments")] 250 [else (loop (cdr formals) 251 (cons (cons k (cadar formals)) rests) 252 modes)])))))) 253 ;; -------------------------------------------------------------------------- 254 ;; generates the actual body 255 (define (generate-body formals expr) 256 ;; relations: 257 ;; rest = (append all-keys body) 258 ;; other-keys+body = (append other-keys body) 259 (define-values (vars ; plain variables 260 opts ; optionals, each is (id default) 261 keys ; keywords, each is (id key default) 262 flags ; flag keyword syntaxes (args are part of keys) 263 rest ; rest variable (no optionals) 264 rest* ; always an id 265 body ; rest after all keyword-vals (id or formals) 266 body* ; always an id 267 all-keys ; keyword-vals without body 268 other-keys ; unprocessed keyword-vals 269 other-keys* ; always an id 270 other-keys+body ; rest without specified keys 271 allow-other-keys? ; allowing other keys? 272 allow-duplicate-keys? ; allowing duplicate keys? 273 allow-body? ; allowing body after keys? 274 allow-anything? ; allowing anything? 275 keywords) ; list of mentioned keywords 276 (parse-formals formals)) 277 (define name 278 (or (syntax-local-infer-name stx) (quote-syntax lambda/kw-proc))) 279 ;; ------------------------------------------------------------------------ 280 ;; make case-lambda clauses for a procedure with optionals 281 (define (make-opt-clauses expr rest) 282 (let loop ([vars (reverse vars)] 283 [opts opts] 284 [clauses '()]) 285 (if (null? opts) 286 ;; fast order: first the all-variable section, then from vars up 287 (cons (with-syntax ([vars (append (reverse vars) rest)] 288 [expr expr]) 289 #'[vars expr]) 290 (reverse clauses)) 291 (loop (cons (caar opts) vars) (cdr opts) 292 (cons (with-syntax ([(var ...) (reverse vars)] 293 [((ovar default) ...) opts] 294 [name name]) 295 #'[(var ...) 296 (let* ([ovar default] ...) 297 (name var ... ovar ...))]) 298 clauses))))) 299 ;; ------------------------------------------------------------------------ 300 ;; generates the part of the body that deals with rest-related stuff 301 (define (make-rest-body expr) 302 (define others? (or other-keys other-keys+body)) 303 (define track-seen? (or others? (not allow-duplicate-keys?))) 304 (with-syntax ([name name] 305 [rest* rest*] 306 [body* body*] 307 [keywords keywords] 308 [expr expr] 309 [all-keys* all-keys] 310 [other-keys* other-keys*] 311 [other-keys+body* other-keys+body] 312 [seen-keys #'seen-keys]) 313 (with-syntax 314 ([loop-vars #`([body* rest*] 315 #,@(if all-keys #`([all-keys* '()]) '()) 316 #,@(if others? #`([other-keys* '()]) '()) 317 #,@(if track-seen? #`([seen-keys '()]) '()))] 318 [next-loop 319 (let ([nl #`(loop 320 (cddr body*) 321 #,@(if all-keys 322 #`((list* (cadr body*) (car body*) all-keys*)) 323 '()) 324 #,@(if others? 325 #`((if (and in-keys? (not in-seen?)) 326 other-keys* 327 (list* (cadr body*) (car body*) 328 other-keys*))) 329 '()) 330 #,@(if track-seen? 331 #`((if (and in-seen? in-keys?) 332 #,(if allow-duplicate-keys? 333 #`seen-keys 334 #`(error* 'name "duplicate keyword: ~.s" 335 (car body*))) 336 (cons (car body*) seen-keys))) 337 '()))]) 338 (cond 339 [(or track-seen? others?) 340 #`(let ([in-keys? (memq (car body*) 'keywords)] 341 [in-seen? (memq (car body*) seen-keys)]) 342 #,(if allow-other-keys? 343 nl 344 #`(if in-keys? 345 #,nl 346 (error* 'name "unknown keyword: ~.s" 347 (car body*)))))] 348 [(not allow-other-keys?) 349 #`(if (memq (car body*) 'keywords) 350 #,nl 351 (error* 'name "unknown keyword: ~.s" 352 (car body*)))] 353 [else nl]))] 354 [expr 355 (if (or all-keys others?) 356 #`(let* (#,@(if all-keys 357 #'([all-keys* (reverse all-keys*)]) 358 '()) 359 #,@(if others? 360 #'([other-keys* (reverse other-keys*)]) 361 '()) 362 #,@(cond [(and other-keys other-keys+body) 363 #'([other-keys+body* 364 (append other-keys* body*)])] 365 [other-keys+body ; can destroy other-keys 366 #'([other-keys+body* 367 (append other-keys* body*)])] 368 [else '()])) 369 expr) 370 #'expr)]) 371 (if (and allow-anything? (not body) 372 (not other-keys+body) (not all-keys) (not other-keys) 373 (null? flags)) 374 ;; allowing anything and don't need special rests, so no loop 375 #'expr 376 ;; normal code 377 #`(let loop loop-vars 378 (if (and (pair? body*) (keyword? (car body*)) 379 #,@(if allow-anything? #'((pair? (cdr body*))) '())) 380 #,(if allow-anything? ; already checked pair? above 381 #'next-loop 382 #'(if (pair? (cdr body*)) 383 next-loop 384 (error* 'name "keyword list not balanced: ~.s" rest*))) 385 #,(if allow-body? 386 (if (and body (not (identifier? body))) 387 (with-syntax ([name (string->symbol 388 (format "~a~~body" 389 (syntax-e* #'name)))]) 390 (with-syntax ([subcall 391 (quasisyntax/loc stx 392 (let ([name (lambda/kw #,body expr)]) 393 name))]) 394 #'(apply subcall body*))) 395 #'expr) 396 #'(if (null? body*) 397 expr 398 (error* 'name "expecting a ~s keyword got: ~.s" 399 'keywords (car body*)))))))))) 400 ;; ------------------------------------------------------------------------ 401 ;; generates the loop that turns flags to #t's 402 (define (make-flags-body) ; called only when there are flags 403 (with-syntax ([flags flags] [rest* rest*]) 404 #'(let loop ([xs rest*]) 405 (if (and (pair? xs) (keyword? (car xs))) 406 (if (memq (car xs) 'flags) 407 (if (null? (cdr xs)) 408 (list (car xs) true) 409 (list* (car xs) 410 true 411 (loop (cddr xs)))) 412 (if (pair? (cdr xs)) 413 (list* (car xs) 414 (cadr xs) 415 (loop (cddr xs))) 416 xs)) 417 xs)))) 418 ;; ------------------------------------------------------------------------ 419 ;; generates the part of the body that deals with rest-related stuff 420 (define (make-keys-body expr) 421 (let ([kb (with-syntax ([body (make-rest-body expr)] [keys keys]) 422 #'(let* keys body))]) 423 (if (null? flags) 424 kb 425 (with-syntax ([keys-body kb] [flag-tweaks (make-flags-body)] [rest* rest*]) 426 #'(let ([rest* flag-tweaks]) keys-body))))) 427 ;; ------------------------------------------------------------------------ 428 ;; more sanity tests (see commented code above -- search for "(*)") 429 (when (null? keys) 430 (let ([r (or all-keys other-keys other-keys+body body rest)]) 431 (if allow-other-keys? 432 ;; allow-other-keys? ==> 433 (unless r 434 (serror #f "cannout allow other keys ~a" 435 "without using them in some way")) 436 ;; (not allow-other-keys?) ==> 437 (begin 438 ;; can use #:body with no keys to forbid all keywords 439 (when (and r (not (eq? r body))) 440 (serror r "cannot use without #:key, #:flag, or ~a" 441 "#:allow-other-keys")) 442 (when allow-duplicate-keys? 443 (serror #f "cannot allow duplicate keys without ~a" 444 "#:key, #:flag, or #:allow-other-keys")))))) 445 ;; ------------------------------------------------------------------------ 446 ;; body generation starts here 447 (cond 448 ;; no optionals or keys (or other-keys) => plain lambda 449 [(and (null? opts) (null? keys) (not allow-other-keys?)) 450 (if (not body) 451 ;; really just a plain lambda 452 (with-syntax ([vars (append vars (or rest '()))] [expr expr]) 453 (syntax/loc stx (lambda vars expr))) 454 ;; has body => forbid keywords 455 (with-syntax ([vars (append vars body)] [expr expr] [body body]) 456 (syntax/loc stx 457 (lambda vars 458 (if (and (pair? body) (keyword? (car body))) 459 (error* 'name "unknown keyword: ~.s" (car body)) 460 expr)))))] 461 ;; no keys => make a case-lambda for optionals 462 [(and (null? keys) (not (or body allow-other-keys?))) 463 ;; cannot write a special case for having `body' here, because it 464 ;; requires the special pop-non-keywords-for-optionals that is done 465 ;; below, and generalizing that is a hassle with little benefit 466 (let ([clauses (make-opt-clauses expr (or rest '()))]) 467 (with-syntax ([name name] [clauses clauses]) 468 (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))] 469 ;; no opts => normal processing of keywords etc 470 [(null? opts) 471 (with-syntax ([vars (append vars rest*)] 472 [body (make-keys-body expr)]) 473 (syntax/loc stx (lambda vars body)))] 474 ;; both opts and keys => combine the above two 475 ;; (the problem with this is that things that follow the required 476 ;; arguments are always taken as optionals, even if they're keywords, so 477 ;; the next piece of code is used.) 478 #; 479 [else 480 (let ([clauses (make-opt-clauses (make-keys-body expr) rest*)]) 481 (with-syntax ([name name] [clauses clauses]) 482 (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))] 483 ;; both opts and keys => pop optionals as long as they're not keywords 484 [else 485 (with-syntax 486 ([rest rest*] 487 [vars (append vars rest*)] 488 [body (make-keys-body expr)] 489 [((optvar optexpr) ...) 490 (apply append 491 (map (lambda (opt) 492 (with-syntax ([(ovar odef) opt] [rest rest*]) 493 (list #'[otmp (if (null? rest) 494 #t (keyword? (car rest)))] 495 #'[ovar (if otmp odef (car rest))] 496 #'[rest (if otmp rest (cdr rest))]))) 497 opts))]) 498 (syntax/loc stx (lambda vars (let* ([optvar optexpr] ...) body))))])) 499 (syntax-case stx () 500 [(_ formals expr0 expr ...) 501 ;; check if there are only identifiers, and save the whole mess if so 502 (if (let loop ([xs #'formals]) 503 (cond [(syntax? xs) (loop (syntax-e xs))] 504 [(symbol? xs) #t] 505 [(null? xs) #t] 506 [(not (pair? xs)) #f] 507 [(symbol? (if (syntax? (car xs)) (syntax-e (car xs)) (car xs))) 508 (loop (cdr xs))] 509 [else #f])) 510 #'(lambda formals expr0 expr ...) 511 (generate-body #'formals #'(let () expr0 expr ...)))])) 512 513(provide define/kw) 514(define-syntax (define/kw stx) 515 (syntax-case stx () 516 [(_ name val) (identifier? #'name) #'(define name val)] 517 [(d/kw (name . args) body0 body ...) 518 (syntax/loc stx (d/kw name (lambda/kw args body0 body ...)))])) 519 520;; raise an appropriate exception 521(define (error* who fmt . args) 522 (raise (make-exn:fail:contract 523 (apply format (string-append "~a: " fmt) who args) 524 (current-continuation-marks)))) 525 526;; keyword searching utility (note: no errors for odd length) 527(provide keyword-get) 528(define keyword-get 529 (case-lambda 530 [(args keyword not-found) 531 (let loop ([args args]) 532 (cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args)))) 533 (not-found)] 534 [(eq? (car args) keyword) (cadr args)] 535 [else (loop (cddr args))]))] 536 ;; the following makes another function call, but the code that is generated 537 ;; by this module never gets here 538 [(args keyword) (keyword-get* args keyword #f)])) 539 540;; a private version of keyword-get that is used with simple values 541(define (keyword-get* args keyword not-found) 542 (let loop ([args args]) 543 (cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args)))) 544 not-found] 545 [(eq? (car args) keyword) (cadr args)] 546 [else (loop (cddr args))]))) 547 548) 549