allow #:flag specs
svn: r2992
This commit is contained in:
Eli Barzilay
parent
89d7fe2e1a
commit
2c22b8910a
|
|
@ -29,6 +29,8 @@
|
|||
(apply append (map (lambda (ks) (list (cadr ks) (caddr ks)))
|
||||
processed-keyword-specs))))
|
||||
|
||||
(define true (list 'true)) ; used for flag values
|
||||
|
||||
(provide lambda/kw)
|
||||
(define-syntax (lambda/kw stx)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
|
@ -86,6 +88,20 @@
|
|||
[var (identifier? #'var) (list #'var (key #'var) #'#f)]
|
||||
[var (serror #'var "not a valid ~a spec" #:key)]))
|
||||
;; --------------------------------------------------------------------------
|
||||
;; process a flag argument spec, returns (<id> <key-stx> <default-expr>)
|
||||
;; so it can be used like keys
|
||||
(define (process-flag k)
|
||||
(define (key var)
|
||||
(datum->syntax-object
|
||||
k (string->keyword (symbol->string (syntax-e var))) k k))
|
||||
(syntax-case k ()
|
||||
[(var key)
|
||||
(and (identifier? #'var) (keyword? (syntax-e #'key)))
|
||||
(list #'var #'key #'#f)]
|
||||
[(var) (identifier? #'var) (list #'var (key #'var) #'#f)]
|
||||
[var (identifier? #'var) (list #'var (key #'var) #'#f)]
|
||||
[var (serror #'var "not a valid ~a spec" #:flag)]))
|
||||
;; --------------------------------------------------------------------------
|
||||
;; helpers for process-vars
|
||||
(define ((process-mode modes rests) processed-spec)
|
||||
(let ([allow (memq (cadr processed-spec) modes)]
|
||||
|
|
@ -125,27 +141,28 @@
|
|||
#'(getter rest key default)))
|
||||
;; --------------------------------------------------------------------------
|
||||
;; test variables
|
||||
(define (process-vars vars opts keys0 rests modes . only-vars?)
|
||||
(define (process-vars vars opts keys0 flags rests modes . only-vars?)
|
||||
(define (gensym x)
|
||||
(car (generate-temporaries (list x))))
|
||||
(let*-values
|
||||
([(only-vars?) (and (pair? only-vars?) (car only-vars?))]
|
||||
[(opts keys0) (values (map process-opt opts) (map process-key keys0))]
|
||||
[(opts) (map process-opt opts)]
|
||||
[(keys0) (map process-key keys0)]
|
||||
[(flags) (map process-flag flags)]
|
||||
[(rest body all-keys other-keys other-keys+body)
|
||||
(apply values (map (lambda (k)
|
||||
(cond [(assq k rests) => cdr] [else #f]))
|
||||
rest-like-kwds))]
|
||||
[(rest* body* other-keys*)
|
||||
(values (or rest (gensym #'rest))
|
||||
(if (and body (identifier? body)) body (gensym #'body))
|
||||
(or other-keys (gensym #'other-keys)))]
|
||||
[(rest*) (or rest (gensym #'rest))]
|
||||
[(body*) (if (and body (identifier? body)) body (gensym #'body))]
|
||||
[(other-keys*) (or other-keys (gensym #'other-keys))]
|
||||
[(other-keys-mode duplicate-keys-mode body-mode anything-mode)
|
||||
(apply values (map (process-mode modes rests)
|
||||
processed-keyword-specs))]
|
||||
;; turn (<id> <key> <default>) keys to (<id> <default>)
|
||||
;; turn (<id> <key> <default>) keys to (<id> <getter>)
|
||||
[(keys)
|
||||
(with-syntax ([rst rest*])
|
||||
(let loop ([ks keys0] [r '()]
|
||||
(let loop ([ks (append keys0 flags)] [r '()]
|
||||
[known-vars (append vars (map car opts))])
|
||||
(if (null? ks)
|
||||
(reverse! r)
|
||||
|
|
@ -169,10 +186,11 @@
|
|||
=> (lambda (d) (serror d "not an identifier"))]
|
||||
[(check-duplicate-identifier all-ids)
|
||||
=> (lambda (d) (serror d "duplicate argument name"))]
|
||||
[else (values vars opts keys rest rest* body body* all-keys
|
||||
other-keys other-keys* other-keys+body
|
||||
other-keys-mode duplicate-keys-mode body-mode
|
||||
anything-mode (map cadr keys0))])))
|
||||
[else (values
|
||||
vars opts keys (map cadr flags) rest rest* body body*
|
||||
all-keys other-keys other-keys* other-keys+body
|
||||
other-keys-mode duplicate-keys-mode body-mode anything-mode
|
||||
(append (map cadr keys0) (map cadr flags)))])))
|
||||
;; --------------------------------------------------------------------------
|
||||
;; parses formals, returns list of normal vars, optional var specs, key var
|
||||
;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys
|
||||
|
|
@ -181,28 +199,36 @@
|
|||
(let* ([formals (split-by-keywords formals)]
|
||||
[vars (car formals)]
|
||||
[formals (cdr formals)]
|
||||
[pop-formals
|
||||
(lambda (key)
|
||||
(if (and (pair? formals) (eq? key (syntax-e* (caar formals))))
|
||||
(begin0 (cdar formals) (set! formals (cdr formals)))
|
||||
'()))]
|
||||
[opts (pop-formals #:optional)]
|
||||
[keys (pop-formals #:key)])
|
||||
[opts '()]
|
||||
[keys '()]
|
||||
[flags '()])
|
||||
(when (and (pair? formals) (eq? #:optional (syntax-e* (caar formals))))
|
||||
(set! opts (cdar formals)) (set! formals (cdr formals)))
|
||||
(let loop ([last #f])
|
||||
(let* ([k-stx (and (pair? formals) (caar formals))]
|
||||
[k (and k-stx (syntax-e* k-stx))])
|
||||
(when (and k (eq? k last)) (serror k-stx "two ~s sections" k))
|
||||
(case k
|
||||
[(#:key) (set! keys (append! keys (cdar formals)))
|
||||
(set! formals (cdr formals)) (loop k)]
|
||||
[(#:flag) (set! flags (append! flags (cdar formals)))
|
||||
(set! formals (cdr formals)) (loop k)]
|
||||
#| else continue below |#)))
|
||||
;; now get all rest-like vars and modes
|
||||
(let loop ([formals formals] [rests '()] [modes '()])
|
||||
(if (null? formals)
|
||||
(apply process-vars vars opts keys rests modes only-vars?)
|
||||
(apply process-vars vars opts keys flags rests modes only-vars?)
|
||||
(let* ([k-stx (caar formals)]
|
||||
[k (syntax-e* k-stx)])
|
||||
(cond [(memq k '(#:optional #:key))
|
||||
(cond [(memq k '(#:optional #:key #:flag))
|
||||
(serror k-stx "misplaced ~a" k)]
|
||||
[(memq k mode-keywords)
|
||||
(cond
|
||||
#; ;(*)
|
||||
;; don't throw an error here, it still fine if used with
|
||||
;; #:allow-other-keys (explicit or implicit), also below
|
||||
[(null? keys)
|
||||
(serror k-stx "cannot use without #:key arguments")]
|
||||
[(and (null? keys) (null? flags))
|
||||
(serror k-stx "cannot use without #:key/#:flag arguments")]
|
||||
[(pair? (cdar formals))
|
||||
(serror (cadar formals)
|
||||
"identifier following mode keyword ~a" k)]
|
||||
|
|
@ -219,7 +245,7 @@
|
|||
;; same as above: don't throw an error here, still fine if
|
||||
;; used with #:allow-other-keys (explicit or implicit)
|
||||
[(and (null? keys) (not (eq? #:rest k)))
|
||||
(serror k-stx "cannot use without #:key arguments")]
|
||||
(serror k-stx "cannot use without #:key/#:flag arguments")]
|
||||
[else (loop (cdr formals)
|
||||
(cons (cons k (cadar formals)) rests)
|
||||
modes)]))))))
|
||||
|
|
@ -232,6 +258,7 @@
|
|||
(define-values (vars ; plain variables
|
||||
opts ; optionals, each is (id default)
|
||||
keys ; keywords, each is (id key default)
|
||||
flags ; flag keyword syntaxes (args are part of keys)
|
||||
rest ; rest variable (no optionals)
|
||||
rest* ; always an id
|
||||
body ; rest after all keyword-vals (id or formals)
|
||||
|
|
@ -341,14 +368,15 @@
|
|||
expr)
|
||||
#'expr)])
|
||||
(if (and allow-anything? (not body)
|
||||
(not other-keys+body) (not all-keys) (not other-keys))
|
||||
(not other-keys+body) (not all-keys) (not other-keys)
|
||||
(null? flags))
|
||||
;; allowing anything and don't need special rests, so no loop
|
||||
#'expr
|
||||
;; normal code
|
||||
#`(let loop loop-vars
|
||||
(if (and (pair? body*) (keyword? (car body*))
|
||||
#,@(if allow-anything? #'((pair? (cdr body*))) '()))
|
||||
#,(if allow-anything? ; already checker pair? above
|
||||
#,(if allow-anything? ; already checked pair? above
|
||||
#'next-loop
|
||||
#'(if (pair? (cdr body*))
|
||||
next-loop
|
||||
|
|
@ -369,18 +397,36 @@
|
|||
(error* 'name "expecting a ~s keyword got: ~e"
|
||||
'keywords (car body*))))))))))
|
||||
;; ------------------------------------------------------------------------
|
||||
;; generates the loop that turns flags to #t's
|
||||
(define (make-flags-body) ; called only when there are flags
|
||||
(with-syntax ([flags flags] [rest* rest*])
|
||||
#'(let loop ([xs rest*])
|
||||
(when (and (pair? xs) (keyword? (car xs)))
|
||||
(if (memq (car xs) 'flags)
|
||||
(if (null? (cdr xs))
|
||||
(set-cdr! xs (list true))
|
||||
(begin (unless (eq? true (cadr xs))
|
||||
(set-cdr! xs (cons true (cdr xs))))
|
||||
(loop (cddr xs))))
|
||||
(when (pair? (cdr xs)) (loop (cddr xs))))))))
|
||||
;; ------------------------------------------------------------------------
|
||||
;; generates the part of the body that deals with rest-related stuff
|
||||
(define (make-keys-body expr)
|
||||
(with-syntax ([body (make-rest-body expr)] [keys keys])
|
||||
#'(let* keys body)))
|
||||
(let ([kb (with-syntax ([body (make-rest-body expr)] [keys keys])
|
||||
#'(let* keys body))])
|
||||
(if (null? flags)
|
||||
kb
|
||||
(with-syntax ([keys-body kb] [flag-tweaks (make-flags-body)])
|
||||
#'(begin flag-tweaks keys-body)))))
|
||||
;; ------------------------------------------------------------------------
|
||||
;; more sanity tests (see commented code above -- search for "(*)")
|
||||
(let ([r (or all-keys other-keys other-keys+body body rest)])
|
||||
(when (and (not allow-other-keys?) (null? keys))
|
||||
(when r (serror r "cannot use without #:key or #:allow-other-keys"))
|
||||
(when r
|
||||
(serror r "cannot use without #:key, #:flag, or #:allow-other-keys"))
|
||||
(when allow-duplicate-keys?
|
||||
(serror #f (string-append "cannot allow duplicate keys without"
|
||||
" #:key or #:allow-other-keys"))))
|
||||
" #:key, #:flag, or #:allow-other-keys"))))
|
||||
(when (and allow-other-keys? (null? keys) (not r))
|
||||
(serror #f "cannout allow other keys without using them in some way")))
|
||||
;; ------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user