suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

allow #:flag specs

Browse Source 
svn: r2992
This commit is contained in:
Eli Barzilay 2006-05-19 20:07:22 +00:00
parent 89d7fe2e1a
commit 2c22b8910a
1 changed files with 78 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/mzlib/kw.ss
View File

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