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

minor bug fixes

Browse Source
This commit is contained in:
Robby Findler 2010-08-05 20:30:52 -05:00
parent 9bc1b63ed4
commit 2347568a6c
2 changed files with 39 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -146,21 +146,28 @@
(let ([opts? (ormap arg-optional? args)])
(cond
[(and opts? (ormap arg-kwd args))
(let ([arg->var (make-hash)]
[kwd-args (filter arg-kwd args)]
[non-kwd-args (filter (λ (x) (not (arg-kwd x))) args)])
(let* ([arg->var (make-hash)]
[kwd-args (filter arg-kwd args)]
[non-kwd-args (filter (λ (x) (not (arg-kwd x))) args)])
(for ([arg (in-list args)]
[var (in-vector vars)])
(hash-set! arg->var arg var))
;; has both optional and keyword args
#`(keyword-apply/no-unsupplied
#,fn
'#,(map arg-kwd 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)))]
(let ([sorted-kwd/arg-pairs
(sort
(map (λ (arg) (cons (arg-kwd arg) (hash-ref arg->var arg))) kwd-args)
(λ (x y) (keyword<? (syntax-e (car x)) (syntax-e (car y)))))])
;; has both optional and keyword args
#`(keyword-apply/no-unsupplied
#,fn
'#,(map car sorted-kwd/arg-pairs)
(list #,@(map cdr sorted-kwd/arg-pairs))
#,(if rst
#'rest-args
#'#f)
#,@(map (λ (arg) (hash-ref arg->var arg)) non-kwd-args))))]
[opts?
;; has optional args, but no keyword args
#`(apply/no-unsupplied #,fn
@ -565,10 +572,10 @@
(istx-args an-istx))))
#,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (arg-optional? arg)))
(istx-args an-istx))))
'#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) (arg-kwd arg)))
'#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) (arg-kwd arg) (syntax-e (arg-kwd arg))))
(istx-args an-istx)))
keyword<?)
'#,(sort (filter values (map (λ (arg) (and (arg-optional? arg) (arg-kwd arg)))
'#,(sort (filter values (map (λ (arg) (and (arg-optional? arg) (arg-kwd arg) (syntax-e (arg-kwd arg))))
(istx-args an-istx)))
keyword<?)
#,(and (istx-rst an-istx) #t)

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

@ -1,53 +1,27 @@
#lang racket/base
(require racket/contract
racket/pretty)
racket/pretty
racket/class)
(pretty-print
(syntax->datum
(expand-once
#'(->i ([b (box/c integer?)])
[res (b) (λ (x) #f)]))))
(syntax->datum (expand-once
#'(->i ([b (box/c integer?)])
[_ (b)
(let ((old (unbox b)))
(and/c void?
(λ (new) (= old (unbox b)))))]))))
(pretty-print
(syntax->datum
(expand-once
#'(->i ([b (box/c integer?)])
[res (λ (x) #f)]))))
((contract (->i ([b (box/c integer?)])
[_ (b)
(let ((old (unbox b)))
(and/c void?
(λ (new) (= old (unbox b)))))])
(λ (b) (set-box! b (+ (unbox b) 1)))
(quote pos)
(quote neg))
(box 1))
;; ==>
#;
(pretty-print
(syntax->datum (expand
#'(->i () [x integer?]))))
(with-handlers ((values values))
((contract (->i ([b any/c])
[res (b) (λ (x) #f)])
(lambda (b) 1)
'pos 'neg)
1))
(with-handlers ((values values))
((contract (->i ([b (box/c integer?)])
[_ (b)
(let ([v (unbox b)])
(λ (x)
#f))])
(lambda (b) (set-box! b (+ (unbox b) 1)))
'pos 'neg)
(box 0)))
(with-handlers ((values values))
((contract (->i ([b (box/c integer?)])
[res (b)
(let ([v (unbox b)])
(λ (x)
#f))])
(lambda (b) (set-box! b (+ (unbox b) 1)))
'pos 'neg)
(box 0)))
;; => pos violation
#|
;; timing tests: