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

added support for rest arguments

Browse Source
This commit is contained in:
Robby Findler 2010-08-05 10:32:07 -05:00
parent c31de06cc0
commit 10b6e58dd0
3 changed files with 236 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/racket/contract/private/arr-i-parse.rkt
View File

@ -18,7 +18,7 @@ code does the parsing and validation of the syntax.
|# |#
;; args : (listof arg?) ;; args : (listof arg?)
;; rst : (or/c #f rst?) ;; rst : (or/c #f arg/res?)
;; pre : (or/c pre/post? #f) ;; pre : (or/c pre/post? #f)
;; ress : (or/c #f (listof eres?) (listof lres?)) ;; ress : (or/c #f (listof eres?) (listof lres?))
;; post : (or/c pre/post? #f) ;; post : (or/c pre/post? #f)
@ -29,11 +29,11 @@ code does the parsing and validation of the syntax.
;; var : identifier? ;; var : identifier?
;; vars : (or/c #f (listof identifier?)) ;; vars : (or/c #f (listof identifier?))
;; optional? : boolean? ;; ctc : syntax[expr]
(struct arg/res (var vars ctc) #:constructor-name ___do-not-use-this-constructor) (struct arg/res (var vars ctc))
;; kwd : (or/c #f syntax[kwd]) ;; kwd : (or/c #f syntax[kwd])
;; ctc : syntax[expr] ;; optional? : boolean?
(struct arg arg/res (kwd optional?)) (struct arg arg/res (kwd optional?))
;; these represent res contracts that came from _s (and thus should be evaluated early) ;; these represent res contracts that came from _s (and thus should be evaluated early)
@ -42,12 +42,6 @@ code does the parsing and validation of the syntax.
;; these represent res contracts that do not come from _s (and thus should be evaluated later) ;; these represent res contracts that do not come from _s (and thus should be evaluated later)
(struct lres arg/res ()) (struct lres arg/res ())
;; var : identifier?
;; vars : (or/c #f (listof identifier?))
;; ctc : syntax[expr]
(struct rst (var vars ctc))
;; vars : (listof identifier?) ;; vars : (listof identifier?)
;; exp : syntax[expr] ;; exp : syntax[expr]
(struct pre/post (vars exp)) (struct pre/post (vars exp))
@ -136,9 +130,9 @@ code does the parsing and validation of the syntax.
;; no dups in the rest var ;; no dups in the rest var
(when (istx-rst istx) (when (istx-rst istx)
(when (rst-vars (istx-rst istx)) (when (arg/res-vars (istx-rst istx))
(not-range-bound (rst-vars (istx-rst istx)) #t)) (not-range-bound (arg/res-vars (istx-rst istx)) #t))
(no-var-dups (rst-var (istx-rst istx)))) (no-var-dups (arg/res-var (istx-rst istx))))
;; dependent arg variables are all bound, but not to a range variable ;; dependent arg variables are all bound, but not to a range variable
(for ([an-arg (in-list (istx-args istx))]) (for ([an-arg (in-list (istx-args istx))])
@ -196,11 +190,11 @@ code does the parsing and validation of the syntax.
(let ([a-rst (istx-rst istx)]) (let ([a-rst (istx-rst istx)])
(when a-rst (when a-rst
(cond (cond
[(rst-vars a-rst) [(arg/res-vars a-rst)
(for ([nvar (in-list (rst-vars a-rst))]) (for ([nvar (in-list (arg/res-vars a-rst))])
(link (rst-var a-rst) nvar))] (link (arg/res-var a-rst) nvar))]
[else [else
(no-links (rst-var a-rst))]))) (no-links (arg/res-var a-rst))])))
(for ([var (in-list sp)]) (for ([var (in-list sp)])
(let loop ([var var] (let loop ([var var]
@ -333,14 +327,14 @@ code does the parsing and validation of the syntax.
[(#:rest [id rest-expr] . leftover) [(#:rest [id rest-expr] . leftover)
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(values (rst #'id #f #'rest-expr) (values (arg/res #'id #f #'rest-expr)
#'leftover))] #'leftover))]
[(#:rest [id (id2 ...) rest-expr] . leftover) [(#:rest [id (id2 ...) rest-expr] . leftover)
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(for-each (λ (x) (check-id stx x)) (for-each (λ (x) (check-id stx x))
(syntax->list #'(id2 ...))) (syntax->list #'(id2 ...)))
(values (rst #'id (values (arg/res #'id
(syntax->list #'(id2 ...)) (syntax->list #'(id2 ...))
#'rest-expr) #'rest-expr)
#'leftover))] #'leftover))]
@ -402,5 +396,4 @@ code does the parsing and validation of the syntax.
(struct-out arg) (struct-out arg)
(struct-out lres) (struct-out lres)
(struct-out eres) (struct-out eres)
(struct-out rst)
(struct-out pre/post)) (struct-out pre/post))

333
collects/racket/contract/private/arr-i.rkt
View File

@ -109,31 +109,40 @@
;; args/vars->arglist : (listof arg?) (vectorof identifier?) -> syntax ;; args/vars->arglist : (listof arg?) (vectorof identifier?) -> syntax
;; (vector-length vars) = (length args) ;; (vector-length vars) = (length args)
;; builds the parameter list for the wrapper λ ;; builds the parameter list for the wrapper λ
(define-for-syntax (args/vars->arglist args vars) (define-for-syntax (args/vars->arglist an-istx vars)
(let loop ([args args] (let ([args (istx-args an-istx)])
[i 0]) (let loop ([args args]
(cond [i 0])
[(null? args) #'()] (cond
[else [(null? args) (if (istx-rst an-istx)
(let* ([arg (car args)] #'rest-args
[kwd (arg-kwd arg)] #'())]
[opt? (arg-optional? arg)] [else
[arg-exp (let* ([arg (car args)]
(cond [kwd (arg-kwd arg)]
[(and kwd opt?) [opt? (arg-optional? arg)]
#`(#,kwd [#,(vector-ref vars i) the-unsupplied-arg])] [arg-exp
[kwd (cond
#`(#,kwd #,(vector-ref vars i))] [(and kwd opt?)
[opt? #`(#,kwd [#,(vector-ref vars i) the-unsupplied-arg])]
#`([#,(vector-ref vars i) the-unsupplied-arg])] [kwd
[else #`(#,kwd #,(vector-ref vars i))]
#`(#,(vector-ref vars i))])]) [opt?
#`([#,(vector-ref vars i) the-unsupplied-arg])]
[else
#`(#,(vector-ref vars i))])])
#`(#,@arg-exp #`(#,@arg-exp
. .
#,(loop (cdr args) (+ i 1))) )]))) #,(loop (cdr args) (+ i 1))))]))))
(define-for-syntax (args/vars->callsite fn args vars) (define-for-syntax (all-but-last lst)
(reverse (cdr (reverse lst))))
;; vars : (listof identifier)
;; vars will contain one identifier for each arg, plus one more for rst,
;; unless rst is #f, in which case it just contains one identifier for each arg.
(define-for-syntax (args/vars->callsite fn args rst vars)
(let ([opts? (ormap arg-optional? args)]) (let ([opts? (ormap arg-optional? args)])
(cond (cond
[(and opts? (ormap arg-kwd args)) [(and opts? (ormap arg-kwd args))
@ -148,29 +157,41 @@
#,fn #,fn
'#,(map arg-kwd kwd-args) '#,(map arg-kwd kwd-args)
(list #,@(map (λ (arg) (hash-ref arg->var arg)) kwd-args)) (list #,@(map (λ (arg) (hash-ref arg->var arg)) kwd-args))
#,(if rst
#'rest-args
#'#f)
#,@(map (λ (arg) (hash-ref arg->var arg)) non-kwd-args)))] #,@(map (λ (arg) (hash-ref arg->var arg)) non-kwd-args)))]
[opts? [opts?
;; has optional args, but no keyword args ;; has optional args, but no keyword args
#`(apply/no-unsupplied #,fn #,@(vector->list vars))] #`(apply/no-unsupplied #,fn
#,(if rst
#'rest-args
#'#f)
#,@(if rst
(all-but-last (vector->list vars))
(vector->list vars)))]
[else [else
;; no optional args (let ([middle-arguments
#`(#,fn (let loop ([args args]
#,@(let loop ([args args] [i 0])
[i 0]) (cond
(cond [(null? args) #'()]
[(null? args) #'()] [else
[else (let ([arg (car args)])
(let ([arg (car args)]) #`(#,@(if (arg-kwd arg)
#`(#,@(if (arg-kwd arg) #`(#,(arg-kwd arg) #,(vector-ref vars i))
#`(#,(arg-kwd arg) #,(vector-ref vars i)) #`(#,(vector-ref vars i)))
#`(#,(vector-ref vars i))) .
. #,(loop (cdr args) (+ i 1))))]))])
#,(loop (cdr args) (+ i 1))))])))]))) (if rst
#`(apply #,fn #,@middle-arguments rest-args)
#`(#,fn #,@middle-arguments)))])))
(define (apply/no-unsupplied fn . args) (define (apply/no-unsupplied fn rest-args . args)
(apply fn (filter (λ (x) (not (eq? x the-unsupplied-arg))) args))) (apply fn (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args)
rest-args)))
(define (keyword-apply/no-unsupplied fn kwds kwd-args . args) (define (keyword-apply/no-unsupplied fn kwds kwd-args rest-args . args)
(let-values ([(supplied-kwds supplied-kwd-args) (let-values ([(supplied-kwds supplied-kwd-args)
(let loop ([kwds kwds] (let loop ([kwds kwds]
[kwd-args kwd-args]) [kwd-args kwd-args])
@ -184,7 +205,10 @@
[else [else
(values (cons (car kwds) kwds-rec) (values (cons (car kwds) kwds-rec)
(cons (car kwd-args) args-rec))]))]))]) (cons (car kwd-args) args-rec))]))]))])
(keyword-apply fn kwds kwd-args (filter (λ (x) (not (eq? x the-unsupplied-arg))) args)))) (keyword-apply fn
supplied-kwds supplied-kwd-args
(append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args)
rest-args))))
(define-for-syntax (maybe-generate-temporary x) (define-for-syntax (maybe-generate-temporary x)
(and x (car (generate-temporaries (list x))))) (and x (car (generate-temporaries (list x)))))
@ -193,6 +217,10 @@
(unless bool (unless bool
(raise-blame-error blame val "#:pre condition violation"))) (raise-blame-error blame val "#:pre condition violation")))
(define (check-post bool val blame)
(unless bool
(raise-blame-error blame val "#:post condition violation")))
(define-for-syntax (add-pre-cond an-istx arg/res-to-indy-var call-stx) (define-for-syntax (add-pre-cond an-istx arg/res-to-indy-var call-stx)
(cond (cond
[(istx-pre an-istx) [(istx-pre an-istx)
@ -205,11 +233,10 @@
(define-for-syntax (add-post-cond an-istx arg/res-to-indy-var call-stx) (define-for-syntax (add-post-cond an-istx arg/res-to-indy-var call-stx)
(cond (cond
#;
[(istx-post an-istx) [(istx-post an-istx)
#`(begin (check-post (post-proc #,@(map arg/res-to-indy-var (pre/post-vars (istx-post an-istx)))) #`(begin (check-post (post-proc #,@(map arg/res-to-indy-var (pre/post-vars (istx-post an-istx))))
val val
swapped-blame) blame)
#,call-stx)] #,call-stx)]
[else [else
call-stx])) call-stx]))
@ -285,7 +312,7 @@
#`(let-values ([#,(vector->list wrapper-ress) #,arg-call-stx]) #`(let-values ([#,(vector->list wrapper-ress) #,arg-call-stx])
#,(add-wrapper-let #,(add-wrapper-let
(add-post-cond #`(values #,@(vector->list wrapper-ress))) (add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress)))
ordered-ress res-indicies ordered-ress res-indicies
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars wrapper-ress indy-res-vars
@ -294,138 +321,166 @@
arg-call-stx])) arg-call-stx]))
(define-for-syntax (mk-wrapper-func an-istx used-indy-vars) (define-for-syntax (mk-wrapper-func an-istx used-indy-vars)
(let-values ([(ordered-args arg-indicies) (find-ordering (istx-args an-istx))] (let ([args+rst (append (istx-args an-istx)
[(ordered-ress res-indicies) (if (istx-ress an-istx) (if (istx-rst an-istx)
(find-ordering (istx-ress an-istx)) (list (istx-rst an-istx))
(values '() '()))]) '()))])
(let-values ([(ordered-args arg-indicies) (find-ordering args+rst)]
[(ordered-ress res-indicies) (if (istx-ress an-istx)
(find-ordering (istx-ress an-istx))
(values '() '()))])
(let ([wrapper-args (list->vector (generate-temporaries (map arg/res-var (istx-args an-istx))))] (let ([wrapper-args (list->vector
[indy-arg-vars (generate-temporaries (map arg/res-var ordered-args))] (append (generate-temporaries (map arg/res-var (istx-args an-istx)))
[arg-proj-vars (list->vector (generate-temporaries (map arg/res-var (istx-args an-istx))))] (if (istx-rst an-istx)
(list #'rest-args)
'())))]
[indy-arg-vars (generate-temporaries (map arg/res-var ordered-args))]
[arg-proj-vars (list->vector (generate-temporaries (map arg/res-var args+rst)))]
;; this list is parallel to arg-proj-vars (so use arg-indicies to find the right ones) ;; this list is parallel to arg-proj-vars (so use arg-indicies to find the right ones)
;; but it contains #fs in places where we don't need the indy projections (because the corresponding ;; but it contains #fs in places where we don't need the indy projections (because the corresponding
;; argument is not dependened on by anything) ;; argument is not dependened on by anything)
[indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary [indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and (not (arg/res-vars x)) (and (not (arg/res-vars x))
(free-identifier-mapping-get used-indy-vars (free-identifier-mapping-get used-indy-vars
(arg/res-var x) (arg/res-var x)
(λ () #f)) (λ () #f))
(arg/res-var x)))) (arg/res-var x))))
(istx-args an-istx)))] args+rst))]
[wrapper-ress (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))] [wrapper-ress (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))]
[indy-res-vars (generate-temporaries (map arg/res-var ordered-ress))] [indy-res-vars (generate-temporaries (map arg/res-var ordered-ress))]
[res-proj-vars (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))] [res-proj-vars (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))]
;; this list is parallel to res-proj-vars (so use res-indicies to find the right ones) ;; this list is parallel to res-proj-vars (so use res-indicies to find the right ones)
;; but it contains #fs in places where we don't need the indy projections (because the corresponding ;; but it contains #fs in places where we don't need the indy projections (because the corresponding
;; result is not dependened on by anything) ;; result is not dependened on by anything)
[indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary [indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and (not (arg/res-vars x)) (and (not (arg/res-vars x))
(free-identifier-mapping-get used-indy-vars (free-identifier-mapping-get used-indy-vars
(arg/res-var x) (arg/res-var x)
(λ () #f)) (λ () #f))
(arg/res-var x)))) (arg/res-var x))))
(or (istx-ress an-istx) '())))]) (or (istx-ress an-istx) '())))])
(define (arg/res-to-indy-var var) (define (arg/res-to-indy-var var)
(let loop ([iargs (append indy-arg-vars indy-res-vars)] (let loop ([iargs (append indy-arg-vars indy-res-vars)]
[args (append (map arg/res-var ordered-args) (map arg/res-var ordered-ress))]) [args (append (map arg/res-var ordered-args) (map arg/res-var ordered-ress))])
(cond (cond
[(null? args) [(null? args)
(error '->i "internal error; did not find a matching var for ~s" var)] (error '->i "internal error; did not find a matching var for ~s" var)]
[else [else
(let ([arg (car args)] (let ([arg (car args)]
[iarg (car iargs)]) [iarg (car iargs)])
(cond (cond
[(free-identifier=? var arg) iarg] [(free-identifier=? var arg) iarg]
[else (loop (cdr iargs) (cdr args))]))]))) [else (loop (cdr iargs) (cdr args))]))])))
#`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc #`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc
;; the pre- and post-condition procs ;; the pre- and post-condition procs
#,@(if (istx-pre an-istx) (list #'pre-proc) '()) #,@(if (istx-pre an-istx) (list #'pre-proc) '())
#,@(if (istx-post an-istx) (list #'post-proc) '()) #,@(if (istx-post an-istx) (list #'post-proc) '())
;; first the non-dependent arg projections ;; first the non-dependent arg projections
#,@(filter values (map (λ (arg arg-proj-var) (and (not (arg/res-vars arg)) arg-proj-var)) #,@(filter values (map (λ (arg arg-proj-var) (and (not (arg/res-vars arg)) arg-proj-var))
(istx-args an-istx) args+rst
(vector->list arg-proj-vars))) (vector->list arg-proj-vars)))
;; then the dependent arg projections ;; then the dependent arg projections
#,@(filter values (map (λ (arg arg-proj-var) (and (arg/res-vars arg) arg-proj-var)) #,@(filter values (map (λ (arg arg-proj-var) (and (arg/res-vars arg) arg-proj-var))
(istx-args an-istx) args+rst
(vector->list arg-proj-vars))) (vector->list arg-proj-vars)))
;; then the non-dependent indy arg projections ;; then the non-dependent indy arg projections
#,@(filter values (vector->list indy-arg-proj-vars)) #,@(filter values (vector->list indy-arg-proj-vars))
;; then the non-dependent res projections ;; then the non-dependent res projections
#,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var)) #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var))
(or (istx-ress an-istx) '()) (or (istx-ress an-istx) '())
(vector->list res-proj-vars))) (vector->list res-proj-vars)))
;; then the dependent res projections ;; then the dependent res projections
#,@(filter values (map (λ (arg/res res-proj-var) (and (arg/res-vars arg/res) res-proj-var)) #,@(filter values (map (λ (arg/res res-proj-var) (and (arg/res-vars arg/res) res-proj-var))
(or (istx-ress an-istx) '()) (or (istx-ress an-istx) '())
(vector->list arg-proj-vars))) (vector->list res-proj-vars)))
;; then the non-dependent indy res projections ;; then the non-dependent indy res projections
#,@(filter values (vector->list indy-res-proj-vars))) #,@(filter values (vector->list indy-res-proj-vars)))
(λ (val) (λ (val)
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(make-contracted-function (make-contracted-function
(λ #,(args/vars->arglist (istx-args an-istx) wrapper-args) (λ #,(args/vars->arglist an-istx wrapper-args)
#,(add-wrapper-let #,(add-wrapper-let
(add-pre-cond (add-pre-cond
an-istx an-istx
arg/res-to-indy-var arg/res-to-indy-var
(add-result-checks (add-result-checks
an-istx an-istx
ordered-ress res-indicies ordered-ress res-indicies
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars wrapper-ress indy-res-vars
arg/res-to-indy-var arg/res-to-indy-var
(args/vars->callsite #'val (istx-args an-istx) wrapper-args))) (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args)))
ordered-args arg-indicies ordered-args arg-indicies
arg-proj-vars indy-arg-proj-vars arg-proj-vars indy-arg-proj-vars
wrapper-args indy-arg-vars wrapper-args indy-arg-vars
arg/res-to-indy-var)) arg/res-to-indy-var))
ctc)))))) ctc)))))))
(define (un-dep ctc obj blame) (define (un-dep ctc obj blame)
;; WRONG (well, just need to avoid calling coerce-contract if 'ctc' is something simple) ;; WRONG (well, maybe just need to avoid calling coerce-contract if 'ctc' is something simple)
(let ([ctc (coerce-contract '->i ctc)]) (let ([ctc (coerce-contract '->i ctc)])
(((contract-projection ctc) blame) obj))) (((contract-projection ctc) blame) obj)))
(define-for-syntax (used-indy-vars an-istx) (define-for-syntax (used-indy-vars an-istx)
(let ([vars (make-free-identifier-mapping)]) (let ([vars (make-free-identifier-mapping)])
;; add in regular arguments' uses
(for ([an-arg (in-list (istx-args an-istx))]) (for ([an-arg (in-list (istx-args an-istx))])
(when (arg/res-vars an-arg) (when (arg/res-vars an-arg)
(for ([var (in-list (arg/res-vars an-arg))]) (for ([var (in-list (arg/res-vars an-arg))])
(free-identifier-mapping-put! vars var #t)))) (free-identifier-mapping-put! vars var #t))))
;; add in rest argument uses
(when (istx-rst an-istx)
(let ([an-arg/rst (istx-rst an-istx)])
(when (arg/res-vars an-arg/rst)
(for ([var (in-list (arg/res-vars an-arg/rst))])
(free-identifier-mapping-put! vars var #t)))))
;; pre-condition
(when (istx-pre an-istx) (when (istx-pre an-istx)
(for ([var (in-list (pre/post-vars (istx-pre an-istx)))]) (for ([var (in-list (pre/post-vars (istx-pre an-istx)))])
(free-identifier-mapping-put! vars var #t))) (free-identifier-mapping-put! vars var #t)))
(when (istx-post an-istx)
(for ([var (in-list (pre/post-vars (istx-post an-istx)))]) ;; results
(free-identifier-mapping-put! vars var #t)))
(when (istx-ress an-istx) (when (istx-ress an-istx)
(for ([a-res (in-list (istx-ress an-istx))]) (for ([a-res (in-list (istx-ress an-istx))])
(when (arg/res-vars a-res) (when (arg/res-vars a-res)
(for ([var (in-list (arg/res-vars a-res))]) (for ([var (in-list (arg/res-vars a-res))])
(free-identifier-mapping-put! vars var #t))))) (free-identifier-mapping-put! vars var #t)))))
;; post-condition
(when (istx-post an-istx)
(for ([var (in-list (pre/post-vars (istx-post an-istx)))])
(free-identifier-mapping-put! vars var #t)))
vars)) vars))
(define-syntax (->i/m stx) (define-syntax (->i/m stx)
(let* ([an-istx (parse-->i stx)] (let* ([an-istx (parse-->i stx)]
[used-indy-vars (used-indy-vars an-istx)] [used-indy-vars (used-indy-vars an-istx)]
[wrapper-func (mk-wrapper-func an-istx used-indy-vars)]) [wrapper-func (mk-wrapper-func an-istx used-indy-vars)]
[args+rst (append (istx-args an-istx)
(if (istx-rst an-istx)
(list (istx-rst an-istx))
'()))])
(with-syntax ([(arg-exp-xs ...) (with-syntax ([(arg-exp-xs ...)
(generate-temporaries (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-var arg))) (generate-temporaries (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-var arg)))
(istx-args an-istx))))] args+rst)))]
[(arg-exps ...) [(arg-exps ...)
(filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-ctc arg))) (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-ctc arg)))
(istx-args an-istx)))] args+rst))]
[(res-exp-xs ...) [(res-exp-xs ...)
(if (istx-ress an-istx) (if (istx-ress an-istx)
@ -444,13 +499,13 @@
(list arg-exp-xs ...) (list arg-exp-xs ...)
;; all of the dependent argument contracts ;; all of the dependent argument contracts
(list #,@(filter values (map (λ (arg) (and (arg/res-vars arg) #`(λ #,(arg/res-vars arg) (opt/c #,(arg/res-ctc arg))))) (list #,@(filter values (map (λ (arg) (and (arg/res-vars arg) #`(λ #,(arg/res-vars arg) (opt/c #,(arg/res-ctc arg)))))
(istx-args an-istx)))) args+rst)))
;; then the non-dependent argument contracts that are themselves dependend on ;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values (list #,@(filter values
(map (λ (arg/res indy-id) (map (λ (arg/res indy-id)
(and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f))
indy-id)) indy-id))
(filter (λ (arg/res) (not (arg/res-vars arg/res))) (istx-args an-istx)) (filter (λ (arg/res) (not (arg/res-vars arg/res))) args+rst)
(syntax->list #'(arg-exp-xs ...))))) (syntax->list #'(arg-exp-xs ...)))))

24
collects/racket/contract/scratch.rkt
View File

@ -4,18 +4,16 @@
(pretty-print (pretty-print
(syntax->datum (expand-once (syntax->datum (expand-once
#'(->i ([f (-> number? number?)]) [res number?])))) #'(->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]))))
#; #;
(pretty-print (pretty-print
(syntax->datum (expand (syntax->datum (expand
#'(->i () [x integer?])))) #'(->i () [x integer?]))))
((contract (->i ([f (-> number? number?)]) [res number?] #:post (res) (= res 11))
(λ (f) 2) ((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) 2 3)
'pos 'neg) ;; => '(1 2 3)
(λ (n) (+ n 1)))
;; => pos violation (#:post condition)
#| #|
;; timing tests: ;; timing tests:
@ -196,5 +194,19 @@ test cases:
(λ (n) (+ n 1))) (λ (n) (+ n 1)))
;; => pos violation ;; => pos violation
((contract (->i ([x integer?]) () #:rest [rst (listof number?)] [r any/c]) (lambda w w) 'pos 'neg) 1 2)
;; => '(1 2)
((contract (->i (#:x [x integer?]) () #:rest [rst (listof number?)] [r any/c]) (lambda (#:x x . w) (cons x w)) 'pos 'neg) #:x 1 2)
;; => '(1 2)
((contract (->i () ([x integer?]) #:rest [rst (listof number?)] [r any/c]) (lambda w w) 'pos 'neg) 1 2)
;; => '(1 2)
((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) #:x 2 3)
;; => '(2 3)
((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) 2 3)
;; => '(1 2 3)
|# |#