From 2347568a6ca1bc98cadef6050581fdcdf3502ac8 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 5 Aug 2010 20:30:52 -0500
Subject: [PATCH] minor bug fixes

---
 collects/racket/contract/private/arr-i.rkt | 35 +++++++-----
 collects/racket/contract/scratch.rkt       | 62 +++++++---------------
 2 files changed, 39 insertions(+), 58 deletions(-)

diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt
index 95bd1edb5f..102a30900d 100644
--- a/collects/racket/contract/private/arr-i.rkt
+++ b/collects/racket/contract/private/arr-i.rkt
@@ -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)
diff --git a/collects/racket/contract/scratch.rkt b/collects/racket/contract/scratch.rkt
index 55f8f53b98..f021f0ed90 100644
--- a/collects/racket/contract/scratch.rkt
+++ b/collects/racket/contract/scratch.rkt
@@ -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: