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

added keywords to -> contract

Browse Source 
svn: r8041
This commit is contained in:
Robby Findler 2007-12-17 23:48:30 +00:00
parent 02bd5d4a66
commit 0e43e1da8c
8 changed files with 402 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/scheme/contract.ss
View File

@ -13,8 +13,7 @@
(except-out (all-from-out "private/contract-ds.ss") (except-out (all-from-out "private/contract-ds.ss")
lazy-depth-to-look) lazy-depth-to-look)
(except-out (all-from-out "private/contract-arrow.ss") (except-out (all-from-out "private/contract-arrow.ss"))
check-procedure)
(except-out (all-from-out "private/contract.ss") (except-out (all-from-out "private/contract.ss")
check-between/c check-between/c
check-unary-between/c)) check-unary-between/c))

33
collects/scheme/private/contract-arr-checks.ss
View File

@ -58,6 +58,10 @@
arity-count arity-count
f))) f)))
(define (get-mandatory-keywords f)
(let-values ([(mandatory optional) (procedure-keywords f)])
mandatory))
(define (no-mandatory-keywords? f) (define (no-mandatory-keywords? f)
(let-values ([(mandatory optional) (procedure-keywords f)]) (let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory))) (null? mandatory)))
@ -89,19 +93,31 @@
orig-str orig-str
"post-condition expression failure"))) "post-condition expression failure")))
(define (check-procedure val dom-length src-info blame orig-str) (define (check-procedure val dom-length mandatory-kwds src-info blame orig-str)
(unless (and (procedure? val) (unless (and (procedure? val)
(and (procedure-arity-includes? val dom-length) (procedure-arity-includes? val dom-length)
(no-mandatory-keywords? val))) (equal? mandatory-kwds (get-mandatory-keywords val)))
(raise-contract-error (raise-contract-error
val val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure that accepts ~a arguments without any keywords, given: ~e" "expected a procedure that accepts ~a arguments~a, given: ~e"
dom-length dom-length
(keyword-error-text mandatory-kwds)
val))) val)))
(define (keyword-error-text mandatory-keywords)
(cond
[(null? mandatory-keywords) " without any keywords"]
[(null? (cdr mandatory-keywords))
(format " and the keyword ~a" (car mandatory-keywords))]
[else
(format
" and the keywords ~a~a"
(car mandatory-keywords)
(apply string-append (map (λ (x) (format " ~a" x)) (cdr mandatory-keywords))))]))
(define ((check-procedure? arity) val) (define ((check-procedure? arity) val)
(and (procedure? val) (and (procedure? val)
(procedure-arity-includes? val arity) (procedure-arity-includes? val arity)
@ -149,17 +165,18 @@
(procedure-arity val) (procedure-arity val)
val))) val)))
(define (check-procedure/more val dom-length src-info blame orig-str) (define (check-procedure/more val dom-length mandatory-kwds src-info blame orig-str)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length)) (procedure-accepts-and-more? val dom-length)
(equal? mandatory-kwds (get-mandatory-keywords val)))
(raise-contract-error (raise-contract-error
val val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" "expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e"
dom-length
dom-length dom-length
(keyword-error-text mandatory-kwds)
val))) val)))

16
collects/scheme/private/contract-arr-obj-helpers.ss
View File

@ -382,7 +382,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info pos-blame orig-str)))) (check-procedure val dom-length '() #|mandatory-keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@ -428,7 +428,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info pos-blame orig-str)))) (check-procedure val dom-length '() #|mandatory-keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (lambda (outer-args)
@ -472,7 +472,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info pos-blame orig-str)))) (check-procedure val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@ -548,7 +548,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure/more val dom-length src-info pos-blame orig-str)))) (check-procedure/more val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure/more? dom-length)) (syntax (check-procedure/more? dom-length))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@ -610,7 +610,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure/more val dom-length src-info pos-blame orig-str)))) (check-procedure/more val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure/more? dom-length)) (syntax (check-procedure/more? dom-length))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@ -663,7 +663,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val arity src-info pos-blame orig-str)))) (check-procedure val arity '() #|mandatory keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? arity)) (syntax (check-procedure? arity))
@ -723,7 +723,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info pos-blame orig-str)))) (check-procedure val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (lambda (outer-args)
@ -797,7 +797,7 @@
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure/more val arity src-info pos-blame orig-str)))) (check-procedure/more val arity '() #|mandatory keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure/more? arity)) (syntax (check-procedure/more? arity))
(lambda (outer-args) (lambda (outer-args)

179
collects/scheme/private/contract-arrow.ss
View File

@ -2,11 +2,21 @@
#| #|
add mandatory keywords to ->, ->* ->d ->d* keywords done:
- added mandatory keywords to ->
keywords todo:
add mandatory keywords to ->* ->d ->d*
Add both optional and mandatory keywords to opt-> and friends. Add both optional and mandatory keywords to opt-> and friends.
(Update opt-> so that it doesn't use case-lambda anymore.) (Update opt-> so that it doesn't use case-lambda anymore.)
- raise-syntax-errors
. multiple identical keywords syntax error, sort-keywords
. split-doms
|# |#
(require "contract-guts.ss" (require "contract-guts.ss"
@ -16,8 +26,8 @@ Add both optional and mandatory keywords to opt-> and friends.
(for-syntax "contract-opt-guts.ss") (for-syntax "contract-opt-guts.ss")
(for-syntax "contract-helpers.ss") (for-syntax "contract-helpers.ss")
(for-syntax "contract-arr-obj-helpers.ss") (for-syntax "contract-arr-obj-helpers.ss")
(for-syntax (lib "stx.ss" "syntax")) (for-syntax syntax/stx)
(for-syntax (lib "name.ss" "syntax"))) (for-syntax syntax/name))
(provide -> (provide ->
->d ->d
@ -29,8 +39,7 @@ Add both optional and mandatory keywords to opt-> and friends.
case-> case->
opt-> opt->
opt->* opt->*
unconstrained-domain-> unconstrained-domain->)
check-procedure)
(define-syntax (unconstrained-domain-> stx) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
@ -57,20 +66,30 @@ Add both optional and mandatory keywords to opt-> and friends.
"expected a procedure"))))) "expected a procedure")))))
procedure?))))])) procedure?))))]))
;; FIXME: need to pass in the name of the contract combinator. (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
(define (build--> name doms doms-rest rngs rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)] [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
[kwds/c (map (λ (kwd) (coerce-contract name kwd)) kwds)]
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))]) [doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
(make--> rng-any? doms/c doms-rest/c rngs/c func))) (make--> rng-any? doms/c doms-rest/c rngs/c kwds/c quoted-kwds func)))
;; rng-any? : boolean
(define-struct/prop -> (rng-any? doms dom-rest rngs func) ;; doms : (listof contract)
;; dom-rest : (or/c false/c contract)
;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
;; kwds : (listof contract)
;; quoted-keywords : (listof keyword) -- must be sorted by keyword<
;; func : the wrapper function maker. It accepts a procedure for
;; checking the first-order properties and the contracts
;; and it produces a wrapper-making function.
(define-struct/prop -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
((proj-prop (λ (ctc) ((proj-prop (λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x)) (let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc) (if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc))) (append (->-doms ctc) (list (->-dom-rest ctc)))
(->-doms ctc)))] (->-doms ctc)))]
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
[mandatory-keywords (->-quoted-kwds ctc)]
[func (->-func ctc)] [func (->-func ctc)]
[dom-length (length (->-doms ctc))] [dom-length (length (->-doms ctc))]
[check-proc [check-proc
@ -81,10 +100,12 @@ Add both optional and mandatory keywords to opt-> and friends.
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
doms/c)] doms/c)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
rngs/c)]) rngs/c)]
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
kwds/c)])
(apply func (apply func
(λ (val) (check-proc val dom-length src-info pos-blame orig-str)) (λ (val) (check-proc val dom-length mandatory-keywords src-info pos-blame orig-str))
(append partial-doms partial-ranges))))))) (append partial-doms partial-ranges partial-kwds)))))))
(name-prop (λ (ctc) (single-arrow-name-maker (name-prop (λ (ctc) (single-arrow-name-maker
(->-doms ctc) (->-doms ctc)
(->-dom-rest ctc) (->-dom-rest ctc)
@ -134,68 +155,134 @@ Add both optional and mandatory keywords to opt-> and friends.
[else (apply build-compound-type-name 'values rngs)])]) [else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))])) (apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(define-for-syntax (sort-keywords stx kwd/ctc-pairs)
(define (insert x lst)
(cond
[(null? lst) (list x)]
[else
(let ([fst-kwd (syntax-e (car (car lst)))])
(printf "comparing ~s to ~s\n" (car x) fst-kwd)
(cond
[(equal? (syntax-e (car x)) fst-kwd)
(raise-syntax-error #f
"duplicate keyword"
stx
(car x))]
[(keyword<? (syntax-e (car x)) fst-kwd)
(cons x lst)]
[else (cons (car lst) (insert x (cdr lst)))]))]))
(let loop ([pairs (map syntax->list kwd/ctc-pairs)])
(cond
[(null? pairs) null]
[else (insert (car pairs) (loop (cdr pairs)))])))
(define-for-syntax (split-doms stx name raw-doms)
(let loop ([raw-doms raw-doms]
[doms '()]
[kwd-doms '()])
(syntax-case raw-doms ()
[() (list (reverse doms)
(sort-keywords stx kwd-doms))]
[(kwd arg . rest)
(and (keyword? (syntax-e #'kwd))
(not (keyword? (syntax-e #'arg))))
(loop #'rest
doms
(cons #'(kwd arg) kwd-doms))]
[(kwd arg . rest)
(and (keyword? (syntax-e #'kwd))
(keyword? (syntax-e #'arg)))
(raise-syntax-error name
"expected a keyword followed by a contract"
stx
#'kwd)]
[(kwd)
(keyword? (syntax-e #'kwd))
(raise-syntax-error name
"expected a keyword to be followed by a contract"
stx
#'kwd)]
[(x . rest)
(loop #'rest (cons #'x doms) kwd-doms)])))
(define-for-syntax (->-helper stx) (define-for-syntax (->-helper stx)
(syntax-case* stx (-> any values) module-or-top-identifier=? (syntax-case stx ()
[(-> doms ... any) [(-> raw-doms ... last-one)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] (with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))])
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] (with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))]
[(ignored) (generate-temporaries (syntax (rng)))]) [(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))])
(with-syntax ([(keyword-call/ctc ...) (apply append (map syntax->list (syntax->list #'((dom-kwd (dom-kwd-ctc-id dom-kwd-arg)) ...))))]
[(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))])
(syntax-case* #'last-one (-> any values) module-or-top-identifier=?
[any
(with-syntax ([(ignored) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...)) (values (syntax (dom-ctc ...))
(syntax (ignored)) (syntax (ignored))
(syntax (dom-kwd-ctc-id ...))
(syntax (doms ...)) (syntax (doms ...))
(syntax (any/c)) (syntax (any/c))
(syntax ((args ...) (val (dom-ctc args) ...))) (syntax (dom-kwd-ctc ...))
(syntax (dom-kwd ...))
(syntax ((args ... keyword-formal-parameters ...) (val (dom-ctc args) ... keyword-call/ctc ...)))
#t))] #t))]
[(-> doms ... (values rngs ...)) [(values rngs ...)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))]) [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
(values (syntax (dom-ctc ...)) (values (syntax (dom-ctc ...))
(syntax (rng-ctc ...)) (syntax (rng-ctc ...))
(syntax (dom-kwd-ctc-id ...))
(syntax (doms ...)) (syntax (doms ...))
(syntax (rngs ...)) (syntax (rngs ...))
(syntax ((args ...) (syntax (dom-kwd-ctc ...))
(let-values ([(rng-x ...) (val (dom-ctc args) ...)]) (syntax (dom-kwd ...))
(syntax ((args ... keyword-formal-parameters ...)
(let-values ([(rng-x ...) (val (dom-ctc args) ... keyword-call/ctc ...)])
(values (rng-ctc rng-x) ...)))) (values (rng-ctc rng-x) ...))))
#f))] #f))]
[(_ doms ... rng) [rng
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] (with-syntax ([(rng-ctc) (generate-temporaries (syntax (rng)))])
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-ctc) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...)) (values (syntax (dom-ctc ...))
(syntax (rng-ctc)) (syntax (rng-ctc))
(syntax (dom-kwd-ctc-id ...))
(syntax (doms ...)) (syntax (doms ...))
(syntax (rng)) (syntax (rng))
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...)))) (syntax (dom-kwd-ctc ...))
#f))])) (syntax (dom-kwd ...))
(syntax ((args ... keyword-formal-parameters ...) (rng-ctc (val (dom-ctc args) ... keyword-call/ctc ...))))
#f))]))))]))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->/proc/main stx) (define-for-syntax (->/proc/main stx)
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)]) (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)])
(with-syntax ([(args body) inner-args/body]) (with-syntax ([(args body) inner-args/body])
(with-syntax ([(dom-names ...) dom-names] (with-syntax ([(dom-names ...) dom-names]
[(rng-names ...) rng-names] [(rng-names ...) rng-names]
[(kwd-names ...) kwd-names]
[(dom-ctcs ...) dom-ctcs] [(dom-ctcs ...) dom-ctcs]
[(rng-ctcs ...) rng-ctcs] [(rng-ctcs ...) rng-ctcs]
[(kwd-ctcs ...) kwd-ctcs]
[(kwds ...) kwds]
[inner-lambda [inner-lambda
(add-name-prop (add-name-prop
(syntax-local-infer-name stx) (syntax-local-infer-name stx)
(syntax (lambda args body)))] (syntax (lambda args body)))]
[use-any? use-any?]) [use-any? use-any?])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)]
[len (and lst (length lst))])
(syntax (syntax
(lambda (chk dom-names ... rng-names ...) (lambda (chk dom-names ... rng-names ... kwd-names ...)
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda))))]) inner-lambda)))])
(values (values
(syntax (build--> '-> (syntax (build--> '->
(list dom-ctcs ...) (list dom-ctcs ...)
#f #f
(list rng-ctcs ...) (list rng-ctcs ...)
(list kwd-ctcs ...)
'(kwds ...)
use-any? use-any?
outer-lambda)) outer-lambda))
inner-args/body inner-args/body
@ -237,6 +324,8 @@ Add both optional and mandatory keywords to opt-> and friends.
(list doms ...) (list doms ...)
rst rst
(list rngs ...) (list rngs ...)
'()
'()
#f #f
outer-lambda)) outer-lambda))
inner-args/body inner-args/body
@ -263,6 +352,8 @@ Add both optional and mandatory keywords to opt-> and friends.
(list doms ...) (list doms ...)
rst rst
(list any/c) (list any/c)
'()
'()
#t #t
outer-lambda)) outer-lambda))
inner-args/body inner-args/body
@ -364,7 +455,7 @@ Add both optional and mandatory keywords to opt-> and friends.
(dom-len (length dom-vars)) (dom-len (length dom-vars))
((next-rng ...) next-rngs)) ((next-rng ...) next-rngs))
(syntax (begin (syntax (begin
(check-procedure val dom-len src-info pos orig-str) (check-procedure val dom-len '() #| mandatory-keywords |# src-info pos orig-str)
(λ (dom-arg ...) (λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)]) (let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...)))))) (values next-rng ...))))))
@ -412,7 +503,7 @@ Add both optional and mandatory keywords to opt-> and friends.
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars))) (dom-len (length dom-vars)))
(syntax (begin (syntax (begin
(check-procedure val dom-len src-info pos orig-str) (check-procedure val dom-len '() #|mandatory-keywords|# src-info pos orig-str)
(λ (dom-arg ...) (λ (dom-arg ...)
(val next-dom ...))))) (val next-dom ...)))))
lifts-doms lifts-doms
@ -424,10 +515,16 @@ Add both optional and mandatory keywords to opt-> and friends.
(syntax-case* stx (-> values any) module-or-top-identifier=? (syntax-case* stx (-> values any) module-or-top-identifier=?
[(-> dom ... (values rng ...)) [(-> dom ... (values rng ...))
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(opt/arrow-ctc (syntax->list (syntax (dom ...))) (opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...))))] (syntax->list (syntax (rng ...)))))]
[(-> dom ... any) [(-> dom ... any)
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))]
[(-> dom ... rng) [(-> dom ... rng)
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(opt/arrow-ctc (syntax->list (syntax (dom ...))) (opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))])) (list #'rng)))]))

44
collects/scheme/private/contract-opt-guts.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts (require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts
(for-template scheme/base) (for-template scheme/base)
(for-template "contract-guts.ss")
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide get-opter reg-opter! opter (provide get-opter reg-opter! opter
@ -20,7 +21,9 @@
opt/info-that opt/info-that
opt/info-swap-blame opt/info-swap-blame
opt/info-change-val) opt/info-change-val
opt/unknown)
;; a hash table of opters ;; a hash table of opters
(define opters-table (define opters-table
@ -159,3 +162,42 @@
(define (lifts-to-save lifts) (filter values (map car lifts))) (define (lifts-to-save lifts) (filter values (map car lifts)))
;;
;; opt/unknown : opt/i id id syntax
;;
(define (opt/unknown opt/i opt/info uctc)
(let* ((lift-var (car (generate-temporaries (syntax (lift)))))
(partial-var (car (generate-temporaries (syntax (partial)))))
(partial-flat-var (car (generate-temporaries (syntax (partial-flat))))))
(values
(with-syntax ((partial-var partial-var)
(lift-var lift-var)
(uctc uctc)
(val (opt/info-val opt/info)))
(syntax (partial-var val)))
(list (cons lift-var
;; FIXME needs to get the contract name somehow
(with-syntax ((uctc uctc))
(syntax (coerce-contract 'opt/c uctc)))))
null
(list (cons
partial-var
(with-syntax ((lift-var lift-var)
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))
(cons
partial-flat-var
(with-syntax ((lift-var lift-var))
(syntax (if (flat-pred? lift-var)
((flat-get lift-var) lift-var)
(lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s"
lift-var
x)))))))
(with-syntax ([val (opt/info-val opt/info)]
[partial-flat-var partial-flat-var])
#'(partial-flat-var val))
lift-var
null)))

40
collects/scheme/private/contract-opt.ss
View File

@ -52,46 +52,6 @@
(void)) (void))
(error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))])) (error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))]))
;;
;; opt/unknown : opt/i id id syntax
;;
(define-for-syntax (opt/unknown opt/i opt/info uctc)
(let* ((lift-var (car (generate-temporaries (syntax (lift)))))
(partial-var (car (generate-temporaries (syntax (partial)))))
(partial-flat-var (car (generate-temporaries (syntax (partial-flat))))))
(values
(with-syntax ((partial-var partial-var)
(lift-var lift-var)
(uctc uctc)
(val (opt/info-val opt/info)))
(syntax (partial-var val)))
(list (cons lift-var
;; FIXME needs to get the contract name somehow
(with-syntax ((uctc uctc))
(syntax (coerce-contract 'opt/c uctc)))))
null
(list (cons
partial-var
(with-syntax ((lift-var lift-var)
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))
(cons
partial-flat-var
(with-syntax ((lift-var lift-var))
(syntax (if (flat-pred? lift-var)
((flat-get lift-var) lift-var)
(lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s"
lift-var
x)))))))
(with-syntax ([val (opt/info-val opt/info)]
[partial-flat-var partial-flat-var])
#'(partial-flat-var val))
lift-var
null)))
;; ;;
;; opt/recursive-call ;; opt/recursive-call
;; ;;

31
collects/scribblings/reference/contracts.scrbl
View File

@ -317,16 +317,17 @@ checks for its arguments and results.
@defform*[#:literals (any) @defform*[#:literals (any)
[(-> expr ... res-expr) [(-> expr ... res-expr)
(-> expr ... (values res-expr ...))
(-> expr ... any)]]{ (-> expr ... any)]]{
Produces a contract for a function that accepts a fixed number of Produces a contract for a function that accepts a fixed
arguments and returns either a single result or an unspecified number number of arguments and returns either a fixed number of
of results (the latter when @scheme[any] is specified). results or completely unspecified results (the latter when
@scheme[any] is specified).
Each @scheme[expr] is a contract on the argument to a function, and Each @scheme[expr] is a contract on the argument to a
either @scheme[res-expr] or @scheme[any] specifies the result function, and each @scheme[res-expr] is a contract on the
contract. Each @scheme[expr] or @scheme[res-expr] must produce a result of the function.
contract or a predicate.
For example, For example,
@ -338,11 +339,25 @@ function must produce an integer. (This example uses Scheme's infix
notation so that the @scheme[->] appears in a suggestive place; see notation so that the @scheme[->] appears in a suggestive place; see
@secref["parse-pair"]). @secref["parse-pair"]).
The @scheme[expr] may be keywords. If so, the functions must
have the corresponding (mandatory) keyword and those keyword
arguments must match the contracts that follow them. For example:
@schemeblock[(integer? #:x boolean? . -> . integer?)]
is a contract on a function that accepts a single, integer
ordinary argument and the keyword argument @scheme[#:x]
whose values must be booleans.
If @scheme[any] is used as the last argument to @scheme[->], no If @scheme[any] is used as the last argument to @scheme[->], no
contract checking is performed on the result of the function, and contract checking is performed on the result of the function, and
tail-recursion is preserved. Note that the function may return tail-recursion is preserved. Note that the function may return
multiple values in that case.} multiple values in that case.
If @scheme[(values res-expr ...)] is used as the last
argument to @scheme[->], the result must have single value
for each contract and the values must match their respective
contracts.}
@defform*[#:literals (any) @defform*[#:literals (any)
[(->* (expr ...) (res-expr ...)) [(->* (expr ...) (res-expr ...))

144
collects/tests/mzscheme/contract-test.ss
View File

@ -428,12 +428,154 @@
1)) 1))
(test/pos-blame (test/pos-blame
'contract-arrow-keyword 'contract-arrow-keyword1
'(contract (-> integer? any)
(λ (x #:y y) x)
'pos
'neg))
(test/pos-blame
'contract-arrow-keyword1b
'(contract (-> integer? #:y integer? any)
(λ (x) x)
'pos
'neg))
(test/spec-passed
'contract-arrow-keyword2
'(contract (-> integer? #:y boolean? any)
(λ (x #:y y) x)
'pos
'neg))
(test/spec-passed
'contract-arrow-keyword2b
'(contract (-> #:x boolean? #:y boolean? any)
(λ (#:x x #:y y) x)
'pos
'neg))
(test/spec-passed
'contract-arrow-keyword2c
'(contract (-> #:y boolean? #:x boolean? any)
(λ (#:x x #:y y) x)
'pos
'neg))
(test/spec-passed
'contract-arrow-keyword2d
'(contract (-> #:y boolean? #:x boolean? any)
(λ (#:y y #:x x) x)
'pos
'neg))
(test/spec-passed
'contract-arrow-keyword2e
'(contract (-> #:x boolean? #:y boolean? any)
(λ (#:y y #:x x) x)
'pos
'neg))
(test/neg-blame
'contract-arrow-keyword3
'((contract (-> integer? #:y boolean? any)
(λ (x #:y y) x)
'pos
'neg)
1 #:y 1))
(test/neg-blame
'contract-arrow-keyword4
'((contract (-> integer? #:y boolean? any)
(λ (x #:y y) x)
'pos
'neg)
#t #:y #t))
(test/spec-passed
'contract-arrow-keyword5
'((contract (-> integer? #:y boolean? any)
(λ (x #:y y) x)
'pos
'neg)
1 #:y #t))
(test/pos-blame
'contract-arrow-keyword6
'(contract (-> integer? integer?) '(contract (-> integer? integer?)
(λ (x #:y y) x) (λ (x #:y y) x)
'pos 'pos
'neg)) 'neg))
(test/spec-passed
'contract-arrow-keyword7
'(contract (-> integer? #:y boolean? integer?)
(λ (x #:y y) x)
'pos
'neg))
(test/neg-blame
'contract-arrow-keyword8
'((contract (-> integer? #:y boolean? integer?)
(λ (x #:y y) x)
'pos
'neg)
1 #:y 1))
(test/neg-blame
'contract-arrow-keyword9
'((contract (-> integer? #:y boolean? integer?)
(λ (x #:y y) x)
'pos
'neg)
#t #:y #t))
(test/spec-passed
'contract-arrow-keyword10
'((contract (-> integer? #:y boolean? integer?)
(λ (x #:y y) x)
'pos
'neg)
1 #:y #t))
(test/pos-blame
'contract-arrow-keyword11
'(contract (-> integer? (values integer? integer?))
(λ (x #:y y) x)
'pos
'neg))
(test/spec-passed
'contract-arrow-keyword12
'(contract (-> integer? #:y boolean? (values integer? integer?))
(λ (x #:y y) x)
'pos
'neg))
(test/neg-blame
'contract-arrow-keyword13
'((contract (-> integer? #:y boolean? (values integer? integer?))
(λ (x #:y y) x)
'pos
'neg)
1 #:y 1))
(test/neg-blame
'contract-arrow-keyword14
'((contract (-> integer? #:y boolean? (values integer? integer?))
(λ (x #:y y) x)
'pos
'neg)
#t #:y #t))
(test/spec-passed
'contract-arrow-keyword15
'((contract (-> integer? #:y boolean? (values integer? integer?))
(λ (x #:y y) (values x x))
'pos
'neg)
1 #:y #t))
(test/pos-blame (test/pos-blame
'contract-d1 'contract-d1
'(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y)))) '(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))