419 lines
20 KiB
Scheme
419 lines
20 KiB
Scheme
(module kw mzscheme
|
|
|
|
(require-for-syntax (lib "name.ss" "syntax"))
|
|
|
|
(begin-for-syntax ; -> configuration for lambda/kw
|
|
;; must appear at the end, each with exactly one variable
|
|
(define rest-like-kwds
|
|
'(#:rest #:body #:all-keys #:other-keys #:other-keys+body))
|
|
;; mode keys are in the end, without variable, cannot have contradictions
|
|
;; each descriptor for #:allow-kwd and #:forbid-kwd is
|
|
;; (kwd-sym (forcer ...) (enabler ...))
|
|
;; `forcer' is a rest-like keyword that forces the mode, `enabler' is a
|
|
;; rest-like keyword that makes it on by default
|
|
(define mode-keyword-specs
|
|
'((other-keys (#:other-keys) (#:rest #:all-keys #:other-keys+body))
|
|
(duplicate-keys () (#:rest #:all-keys))
|
|
(body (#:body) (#:rest #:other-keys+body))
|
|
(anything () ())))
|
|
;; precomputed mode keyword stuff
|
|
(define processed-keyword-specs
|
|
(map (lambda (ks)
|
|
(let* ([k (car ks)]
|
|
[make (lambda (str)
|
|
(string->keyword
|
|
(string-append str (symbol->string k))))])
|
|
(list* k (make "allow-") (make "forbid-") (cdr ks))))
|
|
mode-keyword-specs))
|
|
(define mode-keywords
|
|
(apply append (map (lambda (ks) (list (cadr ks) (caddr ks)))
|
|
processed-keyword-specs))))
|
|
|
|
(provide lambda/kw)
|
|
(define-syntax (lambda/kw stx)
|
|
;; --------------------------------------------------------------------------
|
|
;; easy syntax errors
|
|
(define (serror sub fmt . args)
|
|
(apply raise-syntax-error
|
|
#f (apply format fmt args) stx (if sub (list sub) '())))
|
|
;; contents of syntax
|
|
(define (syntax-e* x) (if (syntax? x) (syntax-e x) x))
|
|
;; turns formals into a syntax list
|
|
(define (formals->list formals)
|
|
(syntax-case formals ()
|
|
[(formal ... . rest)
|
|
;; dot is exactly like #:rest, but don't allow it with other
|
|
;; meta-keywords since its meaning is confusing
|
|
(let* ([formals (syntax->list #'(formal ...))]
|
|
[kwd (ormap (lambda (s) (and (keyword? (syntax-e* s)) s))
|
|
formals)])
|
|
(if kwd
|
|
(serror #'rest "use #:rest or #:body instead of dot notation"
|
|
;; (syntax-e* kwd) <- confusing to show this
|
|
)
|
|
(append formals (list #'#:rest #'rest))))]
|
|
[(formal ...) (syntax->list formals)]))
|
|
;; is an expression simple? (=> evaluating cannot have side effects)
|
|
(define (simple-expr? expr)
|
|
(let ([expr (local-expand expr 'expression null)]) ; expand id macros
|
|
(syntax-case expr (#%datum #%top quote)
|
|
[(#%datum . _) #t]
|
|
[(#%top . _) #t]
|
|
[(quote . _) #t]
|
|
[_ (identifier? expr)])))
|
|
;; split a list of syntax objects based on syntax keywords:
|
|
;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...)
|
|
(define (split-by-keywords xs)
|
|
(let loop ([xs (if (syntax? xs) (formals->list xs) xs)] [cur '()] [r '()])
|
|
(if (null? xs)
|
|
(reverse! (cons (reverse! cur) r))
|
|
(let ([x (car xs)])
|
|
(if (keyword? (syntax-e* x))
|
|
(loop (cdr xs) (list x) (cons (reverse! cur) r))
|
|
(loop (cdr xs) (cons x cur) r))))))
|
|
;; --------------------------------------------------------------------------
|
|
;; process an optional argument spec, returns (<id> <default-expr>)
|
|
(define (process-opt o)
|
|
(syntax-case o ()
|
|
[(var default) (identifier? #'var) (list #'var #'default)]
|
|
[(var) (identifier? #'var) (list #'var #'#f)]
|
|
[var (identifier? #'var) (list #'var #'#f)]
|
|
[var (serror #'var "not a valid ~a spec" #:optional)]))
|
|
;; --------------------------------------------------------------------------
|
|
;; process a key argument spec, returns (<id> <key-stx> <default-expr>)
|
|
(define (process-key k)
|
|
(define (key var)
|
|
(datum->syntax-object
|
|
k (string->keyword (symbol->string (syntax-e var))) k k))
|
|
(syntax-case k ()
|
|
[(var key default)
|
|
(and (identifier? #'var) (keyword? (syntax-e #'key)))
|
|
(list #'var #'key #'default)]
|
|
[(var default) (identifier? #'var) (list #'var (key #'var) #'default)]
|
|
[(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)]))
|
|
;; --------------------------------------------------------------------------
|
|
;; helpers for process-vars
|
|
(define ((process-mode modes rests) processed-spec)
|
|
(let ([allow (memq (cadr processed-spec) modes)]
|
|
[forbid (memq (caddr processed-spec) modes)]
|
|
[allow-any (memq #:allow-anything modes)]
|
|
[forbid-any (memq #:forbid-anything modes)])
|
|
(cond
|
|
[(and allow forbid)
|
|
(serror #f "contradicting #:...-~a keywords" (car processed-spec))]
|
|
[(and forbid allow-any)
|
|
(serror #f "~a contradicts #:allow-anything" (caddr processed-spec))]
|
|
[(and allow forbid-any)
|
|
(serror #f "~a contradicts #:forbid-anything" (cadr processed-spec))]
|
|
[(ormap (lambda (k) (assq k rests)) (cadddr processed-spec))
|
|
=> ; forced?
|
|
(lambda (r)
|
|
(when (or forbid forbid-any)
|
|
(serror #f "cannot ~s with ~s"
|
|
(car (or forbid forbid-any)) (car r)))
|
|
#t)]
|
|
[(or allow allow-any) #t]
|
|
[(or forbid forbid-any) #f]
|
|
[else (ormap (lambda (k) (and (assq k rests) #t)) ; suggested?
|
|
(car (cddddr processed-spec)))])))
|
|
;; --------------------------------------------------------------------------
|
|
;; test variables
|
|
(define (process-vars vars opts keys0 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))]
|
|
[(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)))]
|
|
[(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>)
|
|
[(keys)
|
|
(with-syntax ([r rest*])
|
|
(map (lambda (k)
|
|
(list
|
|
(car k)
|
|
(if (simple-expr? (caddr k))
|
|
;; simple case => no closure
|
|
#`(keyword-get* r #,(cadr k) #,(caddr k))
|
|
#`(keyword-get r #,(cadr k) (lambda () #,(caddr k))))))
|
|
keys0))]
|
|
[(all-ids)
|
|
`(,@vars ,@(map car opts) ,@(map car keys) ,rest* ,body*
|
|
;; make up names if not specified, to make checking easy
|
|
,(or all-keys (gensym #'all-keys))
|
|
,(or other-keys (gensym #'other-keys))
|
|
,(or other-keys+body (gensym #'other-keys+body))
|
|
,@(if (and body (not (identifier? body)))
|
|
(parse-formals body #t) '()))])
|
|
(cond [only-vars? all-ids]
|
|
[(ormap (lambda (x) (and (not (identifier? x)) x)) all-ids)
|
|
=> (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))])))
|
|
;; --------------------------------------------------------------------------
|
|
;; 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
|
|
;; or not; no duplicate names
|
|
(define (parse-formals formals . only-vars?)
|
|
(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)])
|
|
;; now get all rest-like vars
|
|
(let loop ([formals formals] [rests '()] [modes '()])
|
|
(if (null? formals)
|
|
(apply process-vars vars opts keys rests modes only-vars?)
|
|
(let* ([k-stx (caar formals)]
|
|
[k (syntax-e* k-stx)])
|
|
(cond [(memq k '(#:optional #:key))
|
|
(serror k-stx "misplaced ~a" k)]
|
|
[(memq k mode-keywords)
|
|
(cond [(null? keys)
|
|
(serror k-stx "cannot use without #:key arguments")]
|
|
[(pair? (cdar formals))
|
|
(serror (cadar formals)
|
|
"identifier following mode keyword ~a" k)]
|
|
[else (loop (cdr formals) rests (cons k modes))])]
|
|
[(not (memq k rest-like-kwds))
|
|
(serror k-stx "unknown meta keyword")]
|
|
[(assq k rests)
|
|
(serror k-stx "duplicate ~a" k)]
|
|
[(null? (cdar formals))
|
|
(serror k-stx "missing variable name")]
|
|
[(not (null? (cddar formals)))
|
|
(serror k-stx "too many variable names")]
|
|
[(and (null? keys) (not (eq? #:rest k)))
|
|
(serror k-stx "cannot use without #:key arguments")]
|
|
[else (loop (cdr formals)
|
|
(cons (cons k (cadar formals)) rests)
|
|
modes)]))))))
|
|
;; --------------------------------------------------------------------------
|
|
;; generates the actual body
|
|
(define (generate-body formals expr)
|
|
;; relations:
|
|
;; rest = (append all-keys body)
|
|
;; other-keys+body = (append other-keys body)
|
|
(define-values (vars ; plain variables
|
|
opts ; optionals, each is (id default)
|
|
keys ; keywords, each is (id key default)
|
|
rest ; rest variable (no optionals)
|
|
rest* ; always an id
|
|
body ; rest after all keyword-vals (id or formals)
|
|
body* ; always an id
|
|
all-keys ; keyword-vals without body
|
|
other-keys ; unprocessed keyword-vals
|
|
other-keys* ; always an id
|
|
other-keys+body ; rest without specified keys
|
|
allow-other-keys? ; allowing other keys?
|
|
allow-duplicate-keys? ; allowing duplicate keys?
|
|
allow-body? ; allowing body after keys?
|
|
allow-anything? ; allowing anything?
|
|
keywords) ; list of mentioned keywords
|
|
(parse-formals formals))
|
|
(define name
|
|
(or (syntax-local-infer-name stx) (quote-syntax lambda/kw-proc)))
|
|
;; ------------------------------------------------------------------------
|
|
;; make case-lambda clauses for a procedure with optionals
|
|
(define (make-opt-clauses expr rest)
|
|
(let loop ([vars (reverse vars)]
|
|
[opts opts]
|
|
[clauses '()])
|
|
(if (null? opts)
|
|
;; fast order: first the all-variable section, then from vars up
|
|
(cons (with-syntax ([vars (append! (reverse vars) rest)]
|
|
[expr expr])
|
|
#'[vars expr])
|
|
(reverse clauses))
|
|
(loop (cons (caar opts) vars) (cdr opts)
|
|
(cons (with-syntax ([(var ...) (reverse vars)]
|
|
[((ovar default) ...) opts]
|
|
[name name])
|
|
#'[(var ...)
|
|
(let* ([ovar default] ...)
|
|
(name var ... ovar ...))])
|
|
clauses)))))
|
|
;; ------------------------------------------------------------------------
|
|
;; generates the part of the body that deals with rest-related stuff
|
|
(define (make-rest-body expr)
|
|
(define others? (or other-keys other-keys+body))
|
|
(define track-seen? (or others? (not allow-duplicate-keys?)))
|
|
(with-syntax ([name name]
|
|
[rest* rest*]
|
|
[body* body*]
|
|
[keywords keywords]
|
|
[expr expr]
|
|
[all-keys* all-keys]
|
|
[other-keys* other-keys*]
|
|
[other-keys+body* other-keys+body]
|
|
[seen-keys #'seen-keys])
|
|
(with-syntax
|
|
([loop-vars #`([body* rest*]
|
|
#,@(if all-keys #`([all-keys* '()]) '())
|
|
#,@(if others? #`([other-keys* '()]) '())
|
|
#,@(if track-seen? #`([seen-keys '()]) '()))]
|
|
[next-loop
|
|
(let ([nl #`(loop
|
|
(cddr body*)
|
|
#,@(if all-keys
|
|
#`((list* (cadr body*) (car body*) all-keys*))
|
|
'())
|
|
#,@(if others?
|
|
#`((if (and in-keys? (not in-seen?))
|
|
other-keys*
|
|
(list* (cadr body*) (car body*)
|
|
other-keys*)))
|
|
'())
|
|
#,@(if track-seen?
|
|
#`((if (and in-seen? in-keys?)
|
|
#,(if allow-duplicate-keys?
|
|
#`seen-keys
|
|
#`(error* 'name "duplicate keyword: ~e"
|
|
(car body*)))
|
|
(cons (car body*) seen-keys)))
|
|
'()))])
|
|
(cond
|
|
[(or track-seen? others?)
|
|
#`(let ([in-keys? (memq (car body*) 'keywords)]
|
|
[in-seen? (memq (car body*) seen-keys)])
|
|
#,(if allow-other-keys?
|
|
nl
|
|
#`(if in-keys?
|
|
#,nl
|
|
(error* 'name "unknown keyword: ~e"
|
|
(car body*)))))]
|
|
[(not allow-other-keys?)
|
|
#`(if (memq (car body*) 'keywords)
|
|
#,nl
|
|
(error* 'name "unknown keyword: ~e"
|
|
(car body*)))]
|
|
[else nl]))]
|
|
[expr
|
|
(if (or all-keys others?)
|
|
#`(let* (#,@(if all-keys
|
|
#'([all-keys* (reverse! all-keys*)])
|
|
'())
|
|
#,@(if others?
|
|
#'([other-keys* (reverse! other-keys*)])
|
|
'())
|
|
#,@(cond [(and other-keys other-keys+body)
|
|
#'([other-keys+body*
|
|
(append other-keys* body*)])]
|
|
[other-keys+body ; can destroy other-keys
|
|
#'([other-keys+body*
|
|
(append! other-keys* body*)])]
|
|
[else '()]))
|
|
expr)
|
|
#'expr)])
|
|
(if (and allow-anything? (not body)
|
|
(not other-keys+body) (not all-keys) (not other-keys))
|
|
;; 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
|
|
#'next-loop
|
|
#'(if (pair? (cdr body*))
|
|
next-loop
|
|
(error* 'name "keyword list not balanced: ~e" rest*)))
|
|
#,(if allow-body?
|
|
(if (and body (not (identifier? body)))
|
|
(with-syntax ([name (string->symbol
|
|
(format "~a~~body"
|
|
(syntax-e* #'name)))])
|
|
(with-syntax ([subcall
|
|
(quasisyntax/loc stx
|
|
(let ([name (lambda/kw #,body expr)])
|
|
name))])
|
|
#'(apply subcall body*)))
|
|
#'expr)
|
|
#'(if (null? body*)
|
|
expr
|
|
(error* 'name "expecting a ~s keyword got: ~e"
|
|
'keywords (car body*))))))))))
|
|
;; ------------------------------------------------------------------------
|
|
;; 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)))
|
|
;; ------------------------------------------------------------------------
|
|
;; body generation starts here
|
|
(cond
|
|
;; no optionals or keys => plain lambda
|
|
[(and (null? opts) (null? keys))
|
|
(with-syntax ([vars (append! vars (or rest '()))] [expr expr])
|
|
(syntax/loc stx (lambda vars expr)))]
|
|
;; no keys => make a case-lambda for optionals
|
|
[(null? keys)
|
|
(let ([clauses (make-opt-clauses expr (or rest '()))])
|
|
(with-syntax ([name name] [clauses clauses])
|
|
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]
|
|
;; no opts => normal processing of keywords etc
|
|
[(null? opts)
|
|
(with-syntax ([vars (append! vars rest*)]
|
|
[body (make-keys-body expr)])
|
|
(syntax/loc stx (lambda vars body)))]
|
|
;; both opts and keys => combine the above two
|
|
[else
|
|
(let ([clauses (make-opt-clauses (make-keys-body expr) rest*)])
|
|
(with-syntax ([name name] [clauses clauses])
|
|
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]))
|
|
(syntax-case stx ()
|
|
[(_ formals expr0 expr ...)
|
|
(generate-body #'formals #'(let () expr0 expr ...))]))
|
|
|
|
(provide define/kw)
|
|
(define-syntax (define/kw stx)
|
|
(syntax-case stx ()
|
|
[(_ name val) (identifier? #'name) #'(define name val)]
|
|
[(_ (name . args) body0 body ...)
|
|
(syntax/loc stx (_ name (lambda/kw args body0 body ...)))]))
|
|
|
|
;; raise an appropriate exception
|
|
(define (error* who fmt . args)
|
|
(raise (make-exn:fail:contract
|
|
(string->immutable-string
|
|
(apply format (string-append "~a: " fmt) who args))
|
|
(current-continuation-marks))))
|
|
|
|
;; keyword searching utility (note: no errors for odd length)
|
|
(provide keyword-get)
|
|
(define (keyword-get args keyword . not-found)
|
|
(let loop ([args args])
|
|
(cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args))))
|
|
(and (pair? not-found) ((car not-found)))]
|
|
[(eq? (car args) keyword) (cadr args)]
|
|
[else (loop (cddr args))])))
|
|
|
|
;; a private version of keyword-get that is used with simple values
|
|
(define (keyword-get* args keyword . not-found)
|
|
(let loop ([args args])
|
|
(cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args))))
|
|
(and (pair? not-found) (car not-found))]
|
|
[(eq? (car args) keyword) (cadr args)]
|
|
[else (loop (cddr args))])))
|
|
|
|
)
|