keyword-procedure implementation scribblings; reverted opt-lambda hacks
svn: r6654
This commit is contained in:
Matthew Flatt
parent
2385d8bd93
commit
b0328d4853
|
|
@ -24,9 +24,6 @@
|
|||
loop-until
|
||||
|
||||
opt-lambda
|
||||
define-opt
|
||||
keyword-apply
|
||||
make-keyword-procedure
|
||||
|
||||
local
|
||||
recur
|
||||
|
|
@ -133,110 +130,52 @@
|
|||
(eq? x y))
|
||||
|
||||
(define-syntax (opt-lambda stx)
|
||||
(syntax-case stx ()
|
||||
[(_ args body1 body ...)
|
||||
(with-syntax ([((plain ...) (opt ...) (kw ...) need-kw rest)
|
||||
(let loop ([args (syntax args)]
|
||||
[needs-default? #f])
|
||||
(syntax-case args ()
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
#'(() () () () (#:body id))]
|
||||
[()
|
||||
#'(() () () () ())]
|
||||
[(id . rest)
|
||||
(identifier? (syntax id))
|
||||
(begin
|
||||
(when needs-default?
|
||||
(raise-syntax-error
|
||||
#f "default value missing" stx (syntax id)))
|
||||
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest #f)])
|
||||
#'((id . plain) opts kws need-kw rest)))]
|
||||
[([id default] . rest)
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest #t)])
|
||||
#'(plain ([id default] . opts) kws need-kw rest))]
|
||||
[(kw id . rest)
|
||||
(and (identifier? #'id)
|
||||
(keyword? (syntax-e #'kw)))
|
||||
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest needs-default?)])
|
||||
#'(plain opts ([id kw #f] . kws) (kw . need-kw) rest))]
|
||||
[(kw [id default] . rest)
|
||||
(and (identifier? #'id)
|
||||
(keyword? (syntax-e #'kw)))
|
||||
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest needs-default?)])
|
||||
#'(plain opts ([id kw default] . kws) need-kw rest))]
|
||||
[(bad . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier or identifier with default"
|
||||
stx
|
||||
(syntax bad))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f "bad identifier sequence" stx (syntax args))]))])
|
||||
(let ([kw-proc (syntax/loc stx
|
||||
(lambda/kw [plain ... #:optional opt ... #:key kw ... . rest] body1 body ...))])
|
||||
(if (null? (syntax-e #'(kw ...)))
|
||||
kw-proc
|
||||
(with-syntax ([name (or (syntax-local-infer-name stx)
|
||||
(quote-syntax opt-lambda-proc))]
|
||||
[kw-proc kw-proc]
|
||||
[len (length (syntax->list #'(plain ...)))])
|
||||
(syntax/loc stx
|
||||
(let ([name kw-proc])
|
||||
(lambda all-args
|
||||
(apply name (sort-kws len 'need-kw all-args)))))))))]))
|
||||
|
||||
(define-syntax define-opt
|
||||
(syntax-rules ()
|
||||
[(_ (id . args) body1 body ...)
|
||||
(define id (opt-lambda args body1 body ...))]
|
||||
[(_ . rest) (define . rest)]))
|
||||
|
||||
(define (keyword-apply f kw-args normal-args . normal-argss)
|
||||
(apply f (append (apply append
|
||||
(map (lambda (p) (list (car p) (cdr p))) kw-args))
|
||||
(if (null? normal-argss)
|
||||
normal-args
|
||||
(cons normal-args
|
||||
(let loop ([normal-argss normal-argss])
|
||||
(if (null? (cdr normal-argss))
|
||||
(car normal-argss)
|
||||
(cons (car normal-argss)
|
||||
(loop (cdr normal-argss))))))))))
|
||||
|
||||
(define (make-keyword-procedure f)
|
||||
(lambda args
|
||||
(let loop ([args args]
|
||||
[normal null]
|
||||
[kw null])
|
||||
(cond
|
||||
[(null? args) (apply f kw (reverse normal))]
|
||||
[(and (keyword? (car args))
|
||||
(pair? (cdr args)))
|
||||
(loop (cddr args)
|
||||
normal
|
||||
(cons (cons (car args) (cadr args)) kw))]
|
||||
[else (loop (cdr args)
|
||||
(cons (car args) normal)
|
||||
kw)]))))
|
||||
|
||||
(define (sort-kws len need-kw l)
|
||||
(for-each (lambda (kw)
|
||||
(unless (memq kw l)
|
||||
(error "missing required argument for" kw)))
|
||||
need-kw)
|
||||
(let loop ([len len][l l][kws null])
|
||||
(cond
|
||||
[(null? l) (append kws l)]
|
||||
[(zero? len) (append kws l)]
|
||||
[(and (keyword? (car l))
|
||||
(pair? (cdr l)))
|
||||
(loop len (cddr l) (list* (car l)
|
||||
(cadr l)
|
||||
kws))]
|
||||
[else (cons (car l) (loop (sub1 len) (cdr l) kws))])))
|
||||
(with-syntax ([name (or (syntax-local-infer-name stx)
|
||||
(quote-syntax opt-lambda-proc))])
|
||||
(syntax-case stx ()
|
||||
[(_ args body1 body ...)
|
||||
(let ([clauses (let loop ([pre-args null]
|
||||
[args (syntax args)]
|
||||
[needs-default? #f])
|
||||
(syntax-case args ()
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ... . id)
|
||||
body1 body ...])))]
|
||||
[()
|
||||
(with-syntax ([(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ...)
|
||||
body1 body ...])))]
|
||||
[(id . rest)
|
||||
(identifier? (syntax id))
|
||||
(begin
|
||||
(when needs-default?
|
||||
(raise-syntax-error
|
||||
#f "default value missing" stx (syntax id)))
|
||||
(loop (append pre-args (list (syntax id)))
|
||||
(syntax rest)
|
||||
#f))]
|
||||
[([id default] . rest)
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([rest (loop (append pre-args (list (syntax id)))
|
||||
(syntax rest)
|
||||
#t)]
|
||||
[(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ...) (name pre-arg ... default)]
|
||||
. rest)))]
|
||||
[(bad . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier or identifier with default"
|
||||
stx
|
||||
(syntax bad))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f "bad identifier sequence" stx (syntax args))]))])
|
||||
(with-syntax ([clauses clauses])
|
||||
(syntax/loc stx
|
||||
(letrec ([name (case-lambda . clauses)]) name))))])))
|
||||
|
||||
(define-syntax (local stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -126,12 +126,14 @@ are effectively @scheme[cons]ed onto the argument list:
|
|||
The @scheme[apply] procedure supports only by-position arguments. To
|
||||
apply a procedure with keyword arguments, use the
|
||||
@scheme[keyword-apply] procedure, which accepts a procedure to apply
|
||||
and two lists. The first list contains pairs, each matching a
|
||||
keyword with its corresponding value. The second list contains
|
||||
by-position procedure arguments, as for @scheme[apply].
|
||||
and three lists. The first two lists are in parallel, where the first
|
||||
list contains keywords (sorted by @scheme[keyword<]), and the second
|
||||
list contains a corresponding argument for each keyword. The third
|
||||
list contains by-position procedure arguments, as for @scheme[apply].
|
||||
|
||||
@schemeblock[
|
||||
(keyword-apply go
|
||||
(list (cons '#:mode 'fast))
|
||||
'(#:mode)
|
||||
'(fast)
|
||||
(list "super.ss"))
|
||||
]
|
||||
|
|
|
|||
|
|
@ -3,8 +3,6 @@
|
|||
@require[(lib "eval.ss" "scribble")]
|
||||
@require["guide-utils.ss"]
|
||||
|
||||
@interaction-eval[(require (rename (lib "etc.ss") define define-opt))]
|
||||
|
||||
@title{Definitions: @scheme[define]}
|
||||
|
||||
A basic definition has the form
|
||||
|
|
|
|||
|
|
@ -2,7 +2,11 @@
|
|||
(require (lib "manual.ss" "scribble")
|
||||
(lib "struct.ss" "scribble")
|
||||
(lib "decode.ss" "scribble")
|
||||
(lib "kw.ss"))
|
||||
(lib "kw.ss")
|
||||
(lib "eval.ss" "scribble"))
|
||||
|
||||
(interaction-eval (require (lib "new-lambda.ss" "scribblings")))
|
||||
|
||||
|
||||
(provide Quick MzScheme HtDP
|
||||
tool
|
||||
|
|
|
|||
|
|
@ -3,10 +3,6 @@
|
|||
@require[(lib "eval.ss" "scribble")]
|
||||
@require["guide-utils.ss"]
|
||||
|
||||
@interaction-eval[(require (rename (lib "etc.ss") lambda opt-lambda))]
|
||||
@interaction-eval[(require (only (lib "etc.ss") keyword-apply
|
||||
make-keyword-procedure))]
|
||||
|
||||
@title[#:tag "guide:lambda"]{Procedures: @scheme[lambda]}
|
||||
|
||||
Such a @scheme[lambda] expression creates a procedure. In the simplest
|
||||
|
|
@ -186,8 +182,8 @@ The @scheme[lambda] form does not directly support the creation
|
|||
of a procedure that accepts ``rest'' keywords. To construct a
|
||||
procedure that accepts any and all keyword arguments, use
|
||||
@scheme[make-keyword-procedure]. The procedure supplied to
|
||||
@scheme[make-keyword-procedure] receives all keyword arguments as
|
||||
a list of pairs through the first (by-position) argument, and
|
||||
@scheme[make-keyword-procedure] receives keyword arguments throw
|
||||
two parallel lists in the first two (by-position) arguments, and
|
||||
then all by-position arguments from an application as the
|
||||
remaining by-position arguments.
|
||||
|
||||
|
|
@ -197,9 +193,9 @@ remaining by-position arguments.
|
|||
@defexamples[
|
||||
(define (trace-wrap f)
|
||||
(make-keyword-procedure
|
||||
(lambda (kw-args . rest)
|
||||
(printf "Called with ~s ~s\n" kw-args rest)
|
||||
(keyword-apply f kw-args rest))))
|
||||
(lambda (kws kw-args . rest)
|
||||
(printf "Called with ~s ~s ~s\n" kws kw-args rest)
|
||||
(keyword-apply f kws kw-args rest))))
|
||||
((trace-wrap greet) "John" #:hi "Howdy")
|
||||
]
|
||||
|
||||
|
|
|
|||
689
collects/scribblings/new-lambda.ss
Normal file
689
collects/scribblings/new-lambda.ss
Normal file
|
|
@ -0,0 +1,689 @@
|
|||
(module new-lambda mzscheme
|
||||
(require-for-syntax (lib "name.ss" "syntax"))
|
||||
|
||||
(provide (all-from-except mzscheme #%datum lambda define #%app)
|
||||
(rename new-datum #%datum)
|
||||
(rename new-lambda lambda)
|
||||
(rename new-define define)
|
||||
(rename new-app #%app)
|
||||
(rename *make-keyword-procedure make-keyword-procedure)
|
||||
keyword-apply)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-struct keyword-procedure (proc required allowed))
|
||||
|
||||
;; Constructor for a procedure with only optional keywords.
|
||||
;; The `procedure' property dispatches to a procedure in the
|
||||
;; struct (which has exactly the right arity).
|
||||
(define-values (struct:okp make-optional-keyword-procedure okp? okp-ref okp-set!)
|
||||
(make-struct-type 'procedure
|
||||
struct:keyword-procedure
|
||||
1 0 #f
|
||||
null (current-inspector) 0))
|
||||
|
||||
;; Constructor generator for a procedure with a required keyword.
|
||||
;; (This is used with lift-expression, so that the same constructor
|
||||
;; is used for each evaluation of a keyword lambda.)
|
||||
;; The `procedure' property is a per-type method that has exactly
|
||||
;; the right arity, and that sends all arguments to `missing-kw'.
|
||||
(define (make-required name fail-proc)
|
||||
(let-values ([(s: mk ? -ref -set!)
|
||||
(make-struct-type (string->symbol (format "procedure:~a" name))
|
||||
struct:keyword-procedure
|
||||
0 0 #f
|
||||
null (current-inspector) fail-proc)])
|
||||
mk))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define *make-keyword-procedure
|
||||
(letrec ([make-keyword-procedure
|
||||
(case-lambda
|
||||
[(proc) (make-keyword-procedure
|
||||
proc
|
||||
(lambda args
|
||||
(apply proc null null args)))]
|
||||
[(proc plain-proc)
|
||||
(make-optional-keyword-procedure
|
||||
proc
|
||||
null
|
||||
#f
|
||||
plain-proc)])])
|
||||
make-keyword-procedure))
|
||||
|
||||
(define (keyword-apply proc kws kw-vals . normal-argss)
|
||||
(let ([type-error
|
||||
(lambda (what which)
|
||||
(apply raise-type-error
|
||||
'keyword-apply
|
||||
what
|
||||
which
|
||||
proc
|
||||
kws
|
||||
kw-vals
|
||||
normal-argss))])
|
||||
(unless (procedure? proc)
|
||||
(type-error "procedure" 0))
|
||||
(let loop ([ks kws])
|
||||
(cond
|
||||
[(null? ks) (void)]
|
||||
[(or (not (pair? ks))
|
||||
(not (keyword? (car ks))))
|
||||
(type-error "list of keywords" 1)]
|
||||
[(null? (cdr ks)) (void)]
|
||||
[(or (not (pair? (cdr ks)))
|
||||
(not (keyword? (cadr ks))))
|
||||
(loop (cdr ks))]
|
||||
[(keyword<? (car ks) (cadr ks))
|
||||
(loop (cdr ks))]
|
||||
[else (type-error "sorted list of keywords" 1)]))
|
||||
(unless (list? kw-vals)
|
||||
(type-error "list" 2))
|
||||
(unless (= (length kws) (length kw-vals))
|
||||
(raise-mismatch-error
|
||||
'keyword-apply
|
||||
(format
|
||||
"keyword list: ~e; does not match the length of the value list: "
|
||||
kws)
|
||||
kw-vals))
|
||||
(let ([normal-args
|
||||
(let loop ([normal-argss normal-argss][pos 3])
|
||||
(if (null? (cdr normal-argss))
|
||||
(let ([l (car normal-argss)])
|
||||
(if (list? l)
|
||||
l
|
||||
(type-error "list" pos)))
|
||||
(cons (car normal-argss)
|
||||
(loop (cdr normal-argss) (add1 pos)))))])
|
||||
(if (null? kws)
|
||||
(apply proc normal-args)
|
||||
(apply
|
||||
(keyword-procedure-extract kws (+ 2 (length normal-args)) proc)
|
||||
(apply list-immutable kws)
|
||||
(apply list-immutable kw-vals)
|
||||
normal-args)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; #%datum that doesn't allow keywords as expressions
|
||||
(define-syntax (new-datum stx)
|
||||
(syntax-case stx ()
|
||||
[(id . kw)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(raise-syntax-error 'expand "a keyword is not an expression" #'kw)]
|
||||
[(id . thing)
|
||||
#'(quote thing)]))
|
||||
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Sorting keywords.
|
||||
|
||||
;; The sort in "list.ss" should be moved into it's own library,
|
||||
;; so we can use it here without requiring lots of other stuff.)
|
||||
|
||||
;; Also, keyword<? should be made built in. (We need it in two phases.)
|
||||
|
||||
(define (keyword<? a b)
|
||||
(string<? (keyword->string a)
|
||||
(keyword->string b)))
|
||||
(define-for-syntax (keyword<? a b)
|
||||
(string<? (keyword->string a)
|
||||
(keyword->string b)))
|
||||
|
||||
(define-for-syntax (sort l <?)
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(null? (cdr l)) l]
|
||||
[else (let loop ([l l]
|
||||
[a null]
|
||||
[b null])
|
||||
(cond
|
||||
[(null? l) (let loop ([a (sort a <?)]
|
||||
[b (sort b <?)])
|
||||
(cond
|
||||
[(null? a) b]
|
||||
[(null? b) a]
|
||||
[(<? (car a) (car b))
|
||||
(cons (car a) (loop (cdr a) b))]
|
||||
[else
|
||||
(cons (car b) (loop a (cdr b)))]))]
|
||||
[else (loop (cdr l) (cons (car l) b) a)]))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; `lambda' with optional and keyword arguments
|
||||
|
||||
(define-for-syntax (simple-args? args)
|
||||
(cond
|
||||
[(identifier? args) #t]
|
||||
[(pair? args) (and (identifier? (car args))
|
||||
(simple-args? (cdr args)))]
|
||||
[(syntax? args) (simple-args? (syntax-e args))]
|
||||
[(null? args) #t]
|
||||
[else #f]))
|
||||
|
||||
;; Helper to parse the argument list.
|
||||
;; The result is syntax:
|
||||
;; ((plain-id ...) ; non-potional, non-keyword args
|
||||
;; (opt-id ...) ; optional, non-keyword args
|
||||
;; ([id opt-expr kind] ...) ; all args, kind is one of: #:plain, #:opt, #:kw
|
||||
;; ([kw kw-id req?] ...) ; kw args
|
||||
;; (req-kw ...) ; required keywords (could be extracted from previous)
|
||||
;; rest) ; either () or (rest-id)
|
||||
(define-for-syntax (parse-formals stx args)
|
||||
(let* ([kw-ht (make-hash-table)]
|
||||
[check-kw (lambda (kw)
|
||||
(when (hash-table-get kw-ht (syntax-e kw) #f)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate keyword for argument"
|
||||
stx
|
||||
kw))
|
||||
(hash-table-put! kw-ht (syntax-e kw) #t))])
|
||||
(let loop ([args args] [needs-default? #f])
|
||||
(syntax-case args ()
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
#'(() () () () () (id))]
|
||||
[()
|
||||
#'(() () () () () ())]
|
||||
[(id . rest)
|
||||
(identifier? (syntax id))
|
||||
(begin
|
||||
(when needs-default?
|
||||
(raise-syntax-error
|
||||
#f "default value missing" stx (syntax id)))
|
||||
(with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest #f)])
|
||||
#'((id . plain) opt-ids ([id #f #:plain] . opts) kws need-kw rest)))]
|
||||
[([id default] . rest)
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest #t)])
|
||||
#'(plain (id . opt-ids) ([id default #:opt] . opts) kws need-kw rest))]
|
||||
[(kw id . rest)
|
||||
(and (identifier? #'id)
|
||||
(keyword? (syntax-e #'kw)))
|
||||
(begin
|
||||
(check-kw #'kw)
|
||||
(with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest needs-default?)])
|
||||
#'(plain opt-ids ([id #f #:kw-req] . opts) ([kw id #t] . kws) (kw . need-kw) rest)))]
|
||||
[(kw [id default] . rest)
|
||||
(and (identifier? #'id)
|
||||
(keyword? (syntax-e #'kw)))
|
||||
(begin
|
||||
(check-kw #'kw)
|
||||
(with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest needs-default?)])
|
||||
#'(plain opt-ids ([id default #:kw-opt] . opts) ([kw id #f] . kws) need-kw rest)))]
|
||||
[(kw)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(begin
|
||||
(check-kw #'kw)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"missing argument identifier after keyword"
|
||||
stx
|
||||
#'kw))]
|
||||
[(bad . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier, identifier with default, or keyword"
|
||||
stx
|
||||
(syntax bad))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f "bad argument sequence" stx (syntax args))]))))
|
||||
|
||||
;; The new `lambda' form:
|
||||
(define-syntax (new-lambda stx)
|
||||
(syntax-case stx ()
|
||||
[(_ args body1 body ...)
|
||||
(if (simple-args? #'args)
|
||||
;; Use plain old `lambda':
|
||||
(syntax/loc stx
|
||||
(lambda args body1 body ...))
|
||||
;; Handle keyword or optional arguments:
|
||||
(with-syntax ([((plain-id ...)
|
||||
(opt-id ...)
|
||||
([id opt-expr kind] ...)
|
||||
([kw kw-id kw-req] ...)
|
||||
need-kw
|
||||
rest)
|
||||
(parse-formals stx #'args)])
|
||||
(let ([dup-id (check-duplicate-identifier (syntax->list #'(id ... . rest)))])
|
||||
(when dup-id
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate argument identifier"
|
||||
stx
|
||||
dup-id)))
|
||||
(let* ([kws (syntax->list #'(kw ...))]
|
||||
[opts (syntax->list #'(opt-id ...))]
|
||||
[ids (syntax->list #'(id ...))]
|
||||
[plain-ids (syntax->list #'(plain-id ...))]
|
||||
[kw-reqs (syntax->list #'(kw-req ...))]
|
||||
[kw-args (generate-temporaries kws)] ; to hold supplied value
|
||||
[kw-arg?s (generate-temporaries kws)] ; to indicated whether it was supplied
|
||||
[opt-args (generate-temporaries opts)] ; supplied value
|
||||
[opt-arg?s (generate-temporaries opts)] ; whether supplied
|
||||
[needed-kws (sort (syntax->list #'need-kw)
|
||||
(lambda (a b) (keyword<? (syntax-e a) (syntax-e b))))]
|
||||
[sorted-kws (sort (map list kws kw-args kw-arg?s kw-reqs)
|
||||
(lambda (a b) (keyword<? (syntax-e (car a))
|
||||
(syntax-e (car b)))))])
|
||||
(with-syntax ([(kw-arg ...) kw-args]
|
||||
[(kw-arg? ...) (let loop ([kw-arg?s kw-arg?s]
|
||||
[kw-reqs kw-reqs])
|
||||
(cond
|
||||
[(null? kw-arg?s) null]
|
||||
[(not (syntax-e (car kw-reqs)))
|
||||
(cons (car kw-arg?s) (loop (cdr kw-arg?s) (cdr kw-reqs)))]
|
||||
[else (loop (cdr kw-arg?s) (cdr kw-reqs))]))]
|
||||
[kws-sorted sorted-kws]
|
||||
[(opt-arg ...) opt-args]
|
||||
[(opt-arg? ...) opt-arg?s]
|
||||
[(new-plain-id ...) (generate-temporaries #'(plain-id ...))]
|
||||
[new-rest (if (null? (syntax-e #'rest))
|
||||
'()
|
||||
'(new-rest))]
|
||||
[(rest-id) (if (null? (syntax-e #'rest))
|
||||
'(())
|
||||
#'rest)]
|
||||
[rest-empty (if (null? (syntax-e #'rest))
|
||||
'()
|
||||
'(null))])
|
||||
(let ([with-core
|
||||
(lambda (result)
|
||||
;; body of procedure, where all keyword and optional
|
||||
;; argments come in as a pair of arguments (value and
|
||||
;; whether the value is valid):
|
||||
(quasisyntax/loc stx
|
||||
(let ([core (lambda (given-kws given-args
|
||||
new-plain-id ...
|
||||
opt-arg ...
|
||||
opt-arg? ...
|
||||
. new-rest)
|
||||
;; sort out the arguments into the user-supplied bindings,
|
||||
;; evaluating default-values expressions as needed:
|
||||
(let-kws given-kws given-args kws-sorted
|
||||
(let-maybe ([id opt-expr kind] ... . rest)
|
||||
(kw-arg ...) (kw-arg? ...)
|
||||
(opt-arg ...) (opt-arg? ...)
|
||||
(new-plain-id ... . new-rest)
|
||||
;; the original body, finally:
|
||||
body1 body ...)))])
|
||||
;; entry points use `core':
|
||||
#,result)))]
|
||||
[mk-no-kws
|
||||
(lambda ()
|
||||
;; entry point without keywords:
|
||||
(syntax/loc stx
|
||||
(opt-cases (core null null) ([opt-id opt-arg opt-arg?] ...) (plain-id ...)
|
||||
() (rest-empty rest-id . rest)
|
||||
())))]
|
||||
[mk-with-kws
|
||||
(lambda ()
|
||||
;; entry point with keywords:
|
||||
(if (and (null? opts)
|
||||
(null? #'new-rest))
|
||||
#'core
|
||||
(syntax/loc stx
|
||||
(opt-cases (core) ([opt-id opt-arg opt-arg?] ...) (given-kws given-args plain-id ...)
|
||||
() (rest-empty rest-id . rest)
|
||||
()))))]
|
||||
[mk-kw-arity-stub
|
||||
(lambda ()
|
||||
;; struct-type entry point for no keywords when a keyword is required
|
||||
(syntax/loc stx
|
||||
(fail-opt-cases (missing-kw) (opt-id ...) (self plain-id ...)
|
||||
() (rest-id . rest)
|
||||
())))])
|
||||
(cond
|
||||
[(null? kws)
|
||||
;; just the no-kw part
|
||||
(with-core (mk-no-kws))]
|
||||
[(null? needed-kws)
|
||||
;; both parts dispatch to core
|
||||
(with-core
|
||||
(with-syntax ([kws (map car sorted-kws)]
|
||||
[no-kws (let ([p (mk-no-kws)]
|
||||
[n (syntax-local-infer-name stx)])
|
||||
(if n
|
||||
#`(let ([#,n #,p]) #,n)
|
||||
p))]
|
||||
[with-kws (mk-with-kws)])
|
||||
(syntax/loc stx
|
||||
(make-optional-keyword-procedure
|
||||
with-kws
|
||||
null
|
||||
'(kw ...)
|
||||
no-kws))))]
|
||||
[else
|
||||
;; just the keywords part dispatches to core,
|
||||
;; and the other part dispatches to failure
|
||||
(with-core
|
||||
(with-syntax ([kws (map car sorted-kws)]
|
||||
[needed-kws needed-kws]
|
||||
[no-kws (mk-no-kws)]
|
||||
[with-kws (mk-with-kws)]
|
||||
[mk-id (with-syntax ([n (syntax-local-infer-name stx)]
|
||||
[call-fail (mk-kw-arity-stub)])
|
||||
(syntax-local-lift-expression
|
||||
#'(make-required 'n call-fail)))])
|
||||
(syntax/loc stx
|
||||
(mk-id
|
||||
with-kws
|
||||
'needed-kws
|
||||
'(kw ...)))))]))))))]))
|
||||
|
||||
(define (missing-kw proc . args)
|
||||
(printf "~s\n" args)
|
||||
(apply
|
||||
(keyword-procedure-extract null 0 proc)
|
||||
null
|
||||
null
|
||||
args))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Helper macro:
|
||||
;; Steps through the list bound to `kw-args', extracting
|
||||
;; the available values. For each keyword, this binds one
|
||||
;; id to say whether the value is present, and one id
|
||||
;; to the actual value (if present); if the keyword isn't
|
||||
;; available, then the corresponding `req' is applied, which
|
||||
;; should signal an error if the keyword is required.
|
||||
(define-syntax let-kws
|
||||
(syntax-rules ()
|
||||
[(_ kws kw-args () . body)
|
||||
(begin . body)]
|
||||
[(_ kws kw-args ([kw arg arg? #f] . rest) . body)
|
||||
(let ([arg? (and (pair? kws)
|
||||
(eq? 'kw (car kws)))])
|
||||
(let ([arg (if arg? (car kw-args))]
|
||||
[kws (if arg? (cdr kws) kws)]
|
||||
[kw-args (if arg? (cdr kw-args) kw-args)])
|
||||
(let-kws kws kw-args rest . body)))]
|
||||
[(_ kws kw-args ([kw arg arg? #t] . rest) . body)
|
||||
(let ([arg (car kw-args)]
|
||||
[kws (cdr kws)]
|
||||
[kw-args (cdr kw-args)])
|
||||
(let-kws kws kw-args rest . body))]))
|
||||
|
||||
;; Used for `req' when the keyword argument is optional:
|
||||
(define-syntax missing-ok
|
||||
(syntax-rules ()
|
||||
[(_ x y) #f]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Helper macro:
|
||||
;; Builds up a `case-lambda' to handle the arities
|
||||
;; possible due to optional arguments. Each clause
|
||||
;; jumps directory to `core', where each optional
|
||||
;; argument is split into two: a boolean argument that
|
||||
;; indicates whether it was supplied, and an argument
|
||||
;; for the value (if supplied).
|
||||
(define-syntax opt-cases
|
||||
(syntax-rules ()
|
||||
[(_ (core ...) () (base ...) () (rest-empty rest-id . rest) ())
|
||||
;; This case only happens when there are no optional arguments
|
||||
(case-lambda
|
||||
[(base ... . rest-id)
|
||||
(core ... base ... . rest)])]
|
||||
[(_ (core ...) ([opt-id opt-arg opt-arg?]) (base ...) (done-id ...) (rest-empty rest-id . rest) clauses)
|
||||
;; Handle the last optional argument and the rest args (if any)
|
||||
;; at the same time.
|
||||
(case-lambda
|
||||
[(base ...) (core ... base ... (a-false done-id) ... #f (a-false done-id) ... #f . rest-empty)]
|
||||
[(base ... done-id ... opt-arg . rest-id)
|
||||
(core ... base ... done-id ... opt-arg (a-true done-id) ... #t . rest)]
|
||||
. clauses)]
|
||||
[(_ (core ...) ([opt-id opt-arg opt-arg?] more ...) (base ...) (done-id ...) (rest-empty rest-id . rest) clauses)
|
||||
;; Handle just one optional argument, add it to the "done" sequence,
|
||||
;; and continue generating clauses for the remaining optional arguments.
|
||||
(opt-cases (core ...) (more ...) (base ...) (done-id ... opt-id) (rest-empty rest-id . rest)
|
||||
([(base ... done-id ... opt-arg)
|
||||
(core ... base ...
|
||||
done-id ... opt-arg (a-false more) ...
|
||||
(a-true done-id) ... #t (a-false more) ... . rest-empty)
|
||||
. clauses]))]))
|
||||
|
||||
;; Helper macro:
|
||||
;; Similar to opt-cases, but just pass all arguments along to `fail'.
|
||||
(define-syntax fail-opt-cases
|
||||
(syntax-rules ()
|
||||
[(_ (fail ...) () (base ...) () (rest-id . rest) ())
|
||||
;; This case only happens when there are no optional arguments
|
||||
(case-lambda
|
||||
[(base ... . rest-id)
|
||||
(apply fail ... base ... rest)])]
|
||||
[(_ (fail ...) (opt-id) (base ...) (done ...) (rest-id . rest) clauses)
|
||||
;; Handle the last optional argument and the rest args (if any)
|
||||
;; at the same time.
|
||||
(case-lambda
|
||||
[(base ...) (fail ... base ...)]
|
||||
[(base ... done ... opt-id . rest-id) (apply fail ... base ... done ... opt-id rest)]
|
||||
. clauses)]
|
||||
[(_ (fail ...) (opt-id more ...) (base ...) (done ...) (rest-id . rest) clauses)
|
||||
;; Handle just one more optional argument:
|
||||
(fail-opt-cases (fail ...) (more ...) (base ...) (done ... opt-id) (rest-id . rest)
|
||||
([(base ... done ... opt-arg)
|
||||
(fail ... base ... done ... opt-arg)]
|
||||
. clauses))]))
|
||||
|
||||
;; Helper macros:
|
||||
(define-syntax (a-false stx) #'#f)
|
||||
(define-syntax (a-true stx) #'#t)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Helper macro:
|
||||
;; Walks through all arguments in order, shifting supplied
|
||||
;; optional values into the user-supplied binding, and
|
||||
;; evaluating default-value expressions when the optional
|
||||
;; value is not available. The binding order here is
|
||||
;; consistent with the original order of the arguments
|
||||
;; (where, e.g., an optional keyword argument might
|
||||
;; precede a required argument, so the required argument
|
||||
;; cannot be used to compute the default).
|
||||
(define-syntax let-maybe
|
||||
(syntax-rules (required)
|
||||
[(_ () () () () () () body)
|
||||
(let () body)]
|
||||
[(_ ([id ignore #:plain] . more) kw-args kw-arg?s opt-args opt-arg?s (req-id . req-ids) . body)
|
||||
(let ([id req-id])
|
||||
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
|
||||
[(_ ([id expr #:opt] . more) kw-args kw-arg?s (opt-arg . opt-args) (opt-arg? . opt-arg?s) req-ids . body)
|
||||
(let ([id (if opt-arg?
|
||||
opt-arg
|
||||
expr)])
|
||||
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
|
||||
[(_ ([id expr #:kw-req] . more) (kw-arg . kw-args) kw-arg?s opt-args opt-arg?s req-ids . body)
|
||||
(let ([id kw-arg])
|
||||
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
|
||||
[(_ ([id expr #:kw-opt] . more) (kw-arg . kw-args) (kw-arg? . kw-arg?s) opt-args opt-arg?s req-ids . body)
|
||||
(let ([id (if kw-arg?
|
||||
kw-arg
|
||||
expr)])
|
||||
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
|
||||
[(_ (id) () () () () (req-id) . body)
|
||||
(let ([id req-id]) . body)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; `define' with keyword arguments
|
||||
|
||||
;; Not enough syntax checking here, yet.
|
||||
;; Also, the currying notation needs to be
|
||||
;; supported.
|
||||
|
||||
(define-syntax (new-define stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id . formals) . body)
|
||||
(identifier? #'id)
|
||||
(syntax/loc stx (define id (new-lambda formals . body)))]
|
||||
[(_ . rest)
|
||||
(syntax/loc stx (define . rest))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; `#%app' with keyword arguments
|
||||
|
||||
(define-syntax (new-app stx)
|
||||
(let ([l (syntax->list stx)])
|
||||
(if (not (and l
|
||||
(pair? (cdr l))
|
||||
(not (keyword? (cadr l)))
|
||||
(ormap (lambda (x) (keyword? (syntax-e x)))
|
||||
l)))
|
||||
;; simple or erroneous app:
|
||||
(quasisyntax/loc stx
|
||||
(#%app . #,(cdr (syntax-e stx))))
|
||||
;; keyword app (maybe)
|
||||
(let ([exprs
|
||||
(let ([kw-ht (make-hash-table)])
|
||||
(let loop ([l (cddr l)])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(keyword? (syntax-e (car l)))
|
||||
(when (hash-table-get kw-ht (syntax-e (car l)) #f)
|
||||
(raise-syntax-error
|
||||
'application
|
||||
"duplicate keyword in application"
|
||||
stx
|
||||
(car l)))
|
||||
(hash-table-put! kw-ht (syntax-e (car l)) #t)
|
||||
(cond
|
||||
[(null? (cdr l))
|
||||
(raise-syntax-error
|
||||
'application
|
||||
"missing argument expression after keyword"
|
||||
stx
|
||||
(car l))]
|
||||
[(keyword? (cadr l))
|
||||
(raise-syntax-error
|
||||
'application
|
||||
"keyword in expression possition (immediately after another keyword)"
|
||||
stx
|
||||
(cadr l))]
|
||||
[else
|
||||
(cons (cadr l)
|
||||
(loop (cddr l)))])]
|
||||
[else
|
||||
(cons (car l) (loop (cdr l)))])))])
|
||||
(let ([ids (cons (or (syntax-local-infer-name stx)
|
||||
'procedure)
|
||||
(generate-temporaries exprs))])
|
||||
(let loop ([l (cdr l)]
|
||||
[ids ids]
|
||||
[bind-accum null]
|
||||
[arg-accum null]
|
||||
[kw-pairs null])
|
||||
(cond
|
||||
[(null? l)
|
||||
(let* ([args (reverse arg-accum)]
|
||||
[sorted-kws (sort kw-pairs
|
||||
(lambda (a b)
|
||||
(keyword<? (syntax-e (car a))
|
||||
(syntax-e (car b)))))]
|
||||
[lifted (syntax-local-lift-expression
|
||||
#`(list-immutable #,@(map (lambda (p) #`(#%datum . #,(car p)))
|
||||
sorted-kws)))]
|
||||
[cnt (+ 1 (length args))])
|
||||
(quasisyntax/loc stx
|
||||
(let #,(reverse bind-accum)
|
||||
((keyword-procedure-extract #,lifted #,cnt #,(car args))
|
||||
#,lifted
|
||||
(list-immutable #,@(map cdr sorted-kws))
|
||||
. #,(cdr args)))))]
|
||||
[(keyword? (syntax-e (car l)))
|
||||
(loop (cddr l)
|
||||
(cdr ids)
|
||||
(cons (list (car ids) (cadr l)) bind-accum)
|
||||
arg-accum
|
||||
(cons (cons (car l) (car ids))
|
||||
kw-pairs))]
|
||||
[else (loop (cdr l)
|
||||
(cdr ids)
|
||||
(cons (list (car ids) (car l)) bind-accum)
|
||||
(cons (car ids) arg-accum)
|
||||
kw-pairs)])))))))
|
||||
|
||||
;; Checks given kws against expected. Result is
|
||||
;; (values missing-kw extra-kw), where both are #f if
|
||||
;; the arguments are ok.
|
||||
(define (check-kw-args p kws)
|
||||
(let loop ([kws kws]
|
||||
[required (keyword-procedure-required p)]
|
||||
[allowed (keyword-procedure-allowed p)])
|
||||
(cond
|
||||
[(null? kws)
|
||||
(if (null? required)
|
||||
(values #f #f)
|
||||
(values (car required) #f))]
|
||||
[(and (pair? required)
|
||||
(eq? (car required) (car kws)))
|
||||
(loop (cdr kws) (cdr required) (cdr allowed))]
|
||||
[(not allowed) ; => all keywords are allowed
|
||||
(loop (cdr kws) required #f)]
|
||||
[(pair? allowed)
|
||||
(if (eq? (car allowed) (car kws))
|
||||
(loop (cdr kws) required (cdr allowed))
|
||||
(loop kws required (cdr allowed)))]
|
||||
[else (values #f (car kws))])))
|
||||
|
||||
;; Extracts the procedure using the keyword-argument protocol.
|
||||
;; If `p' doesn't accept keywords, make up a procedure that
|
||||
;; reports an error.
|
||||
(define (keyword-procedure-extract kws n p)
|
||||
(if (and (keyword-procedure? p)
|
||||
(procedure-arity-includes? (keyword-procedure-proc p) n)
|
||||
(let-values ([(missing-kw extra-kw) (check-kw-args p kws)])
|
||||
(and (not missing-kw) (not extra-kw))))
|
||||
;; Ok:
|
||||
(keyword-procedure-proc p)
|
||||
;; Not ok:
|
||||
(lambda (kws kw-args . args)
|
||||
(let-values ([(missing-kw extra-kw)
|
||||
(if (keyword-procedure? p)
|
||||
(check-kw-args p kws)
|
||||
(values #f (car kws)))])
|
||||
(let ([args-str
|
||||
;; Hack to format arguments:
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(cadr (regexp-match #rx"other arguments were: (.*)$"
|
||||
(exn-message exn))))])
|
||||
(apply raise-type-error 'x "x" 0 'x
|
||||
(append (apply append (map list kws kw-args))
|
||||
args)))])
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(if extra-kw
|
||||
(if (keyword-procedure? p)
|
||||
(format
|
||||
(string-append
|
||||
"procedure application: procedure: ~e;"
|
||||
" does not expect an argument with keyword ~a; arguments were: ~a")
|
||||
p
|
||||
extra-kw
|
||||
args-str)
|
||||
(format
|
||||
(string-append
|
||||
"procedure application: expected a procedure that"
|
||||
" accepts keyword arguments, given ~e; arguments were: ~a")
|
||||
p
|
||||
args-str))
|
||||
(if missing-kw
|
||||
(format
|
||||
(string-append
|
||||
"procedure application: procedure: ~e; requires"
|
||||
" an argument with keyword ~a, not supplied; arguments were: ~a")
|
||||
p
|
||||
missing-kw
|
||||
args-str)
|
||||
(format
|
||||
(string-append
|
||||
"procedure application: no case matching ~a non-keyword"
|
||||
" arguments for: ~e; arguments were: ~a")
|
||||
(- n 2)
|
||||
p
|
||||
args-str)))
|
||||
(current-continuation-marks)))))))))
|
||||
|
|
@ -5,6 +5,8 @@
|
|||
(lib "decode.ss" "scribble")
|
||||
(lib "kw.ss"))
|
||||
|
||||
(interaction-eval (require (lib "new-lambda.ss" "scribblings")))
|
||||
|
||||
(provide (all-from (lib "manual.ss" "scribble"))
|
||||
(all-from (lib "eval.ss" "scribble")))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,6 @@
|
|||
#reader(lib "docreader.ss" "scribble")
|
||||
@require["mz.ss"]
|
||||
|
||||
@interaction-eval[(require (rename (lib "etc.ss") lambda opt-lambda))]
|
||||
@interaction-eval[(require (only (lib "etc.ss") keyword-apply
|
||||
make-keyword-procedure))]
|
||||
|
||||
@title[#:tag "mz:procedures"]{Procedures}
|
||||
|
||||
@defproc[(procedure? [v any/c]) boolean]{ Returns @scheme[#t] if
|
||||
|
|
@ -30,27 +26,31 @@ is called in tail position with respect to the @scheme[apply] call.
|
|||
|
||||
|
||||
@defproc[(keyword-apply [proc procedure?]
|
||||
[kw-lst (listof (cons/c keyword? any/c))]
|
||||
[kw-lst (listof keyword?)]
|
||||
[kw-val-lst list?]
|
||||
[v any/c] ...
|
||||
[lst list?])
|
||||
any]{
|
||||
|
||||
@guideintro["guide:apply"]{@scheme[keyword-apply]}
|
||||
|
||||
Like @scheme[apply], but @scheme[kw-lst] supplies by-keyword arguments
|
||||
in addition to the by-position arguments of the @scheme[v]s and
|
||||
@scheme[lst]. The given @scheme[kw-lst] must be sorted using
|
||||
@scheme[keyword<] on the @scheme[car] of each pair in the list, and no
|
||||
keyword can appear twice in the @scheme[car]s of @scheme[kw-lst]. The
|
||||
Like @scheme[apply], but @scheme[kw-lst] and @scheme[kw-val-lst]
|
||||
supply by-keyword arguments in addition to the by-position arguments
|
||||
of the @scheme[v]s and @scheme[lst]. The given @scheme[kw-lst] must be
|
||||
sorted using @scheme[keyword<], and no keyword can appear twice in
|
||||
@scheme[kw-lst], otherwise, the @exnraise[exn:fail:contract]. The
|
||||
given @scheme[kw-val-lst] must have the same length as
|
||||
@scheme[kw-lst], otherwise, the @exnraise[exn:fail:contract]. The
|
||||
given @scheme[proc] must accept all of the keywords in
|
||||
@scheme[kw-lst], and it must not require any other keywords;
|
||||
otherwise, the @exnraise[exn:fail:contract].
|
||||
@scheme[kw-lst], it must not require any other keywords, and it must
|
||||
accept as many by-position arguments as supplied via the @scheme[v]s
|
||||
and @scheme[lst]; otherwise, the @exnraise[exn:fail:contract].
|
||||
|
||||
@defexamples[
|
||||
(define (f x #:y y #:z [z 10])
|
||||
(list x y z))
|
||||
(keyword-apply f '((#:y . 2)) '(1))
|
||||
(keyword-apply f '((#:y . 2) (#:z . 3)) '(1))
|
||||
(keyword-apply f '(#:y) '(2) '(1))
|
||||
(keyword-apply f '(#:y #:z) '(2 3) '(1))
|
||||
]}
|
||||
|
||||
@defproc[(procedure-arity [proc procedure?])
|
||||
|
|
@ -125,21 +125,27 @@ to mean that any keyword is accepted. The last result is as for
|
|||
are required.}
|
||||
|
||||
@defproc[(make-keyword-procedure
|
||||
[proc (((listof (cons/c keyword? any/c))) list? . ->* . any)])
|
||||
[proc (((listof keyword?) list?) list? . ->* . any)]
|
||||
[plain-proc procedure? (lambda args (apply proc null null args))])
|
||||
procedure?]{
|
||||
|
||||
Returns a procedure that accepts any number of arguments and all
|
||||
keyword arguments (without requiring any keyword arguments). The
|
||||
resulting procedure calls @scheme[proc], supplying to @scheme[proc]
|
||||
all keyword arguments given in the original application as a list of
|
||||
keyword--value pairs, sorted by @scheme[keyword<] on the keywords. All
|
||||
by-position arguments supplied in the original application are
|
||||
supplied to @scheme[proc] after the list for keyword arguments.
|
||||
Returns a procedure that accepts all keyword arguments (without
|
||||
requiring any keyword arguments).
|
||||
|
||||
When the result is called with keyword arguments, then @scheme[proc]
|
||||
is called; the first argument is a list of keywords sorted by
|
||||
@scheme[keyword<], the second argument is a parllel list containing a
|
||||
value for each keyword, and the remaining arguments are the
|
||||
by-position arguments.
|
||||
|
||||
When the result is called without keyword arguments, then
|
||||
@scheme[plain-proc] is called. Furthermore, @scheme[procedure-arity]
|
||||
obtains its result frmo @scheme[plain-proc].
|
||||
|
||||
@defexamples[
|
||||
(define show
|
||||
(make-keyword-procedure (lambda (kw-args . rest)
|
||||
(list kw-args rest))))
|
||||
(make-keyword-procedure (lambda (kws kw-args . rest)
|
||||
(list kws kw-args rest))))
|
||||
|
||||
(show 1)
|
||||
(show #:init 0 1 2 3 #:extra 4)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user