From bb7bd9de51f01b2620a8162da5de0bfffd645247 Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Sun, 17 Jan 2010 07:23:47 +0000
Subject: [PATCH] Typos and type errors in new property stuff.

svn: r17700
---
 .../mzlib/private/contract-arr-obj-helpers.ss |  2 +-
 collects/mzlib/private/contract-object.ss     |  4 ++--
 collects/scheme/contract/private/base.ss      | 16 ++++++++-------
 collects/scheme/contract/private/helpers.ss   | 20 +++++++++++--------
 collects/scheme/contract/private/misc.ss      | 11 +++++-----
 5 files changed, 29 insertions(+), 24 deletions(-)

diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss
index 4dd2791f5c..de1788c37d 100644
--- a/collects/mzlib/private/contract-arr-obj-helpers.ss
+++ b/collects/mzlib/private/contract-arr-obj-helpers.ss
@@ -365,7 +365,7 @@
                              [(val blame name-id) outer-args])
                  (syntax
                   (let ([dom-contract-x (coerce-contract '-> dom)] ...)
-                    (let ([dom-x (contract-proc dom-contract-x)] ...)
+                    (let ([dom-x (contract-projection dom-contract-x)] ...)
                       (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)])
                         body))))))
              
diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss
index 63c91ed701..c5018cb950 100644
--- a/collects/mzlib/private/contract-object.ss
+++ b/collects/mzlib/private/contract-object.ss
@@ -331,9 +331,9 @@
                     ...
                     [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
                     ...)
-                (let ([method-var (contract-proc method-ctc-var)] 
+                (let ([method-var (contract-projection method-ctc-var)] 
                       ...
-                      [field-var (contract-proc field-ctc-var)]
+                      [field-var (contract-projection field-ctc-var)]
                       ...)
                   (let ([cls (make-wrapper-class 'wrapper-class 
                                                  '(method-name ...)
diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss
index 7ad1766804..0b83cec658 100644
--- a/collects/scheme/contract/private/base.ss
+++ b/collects/scheme/contract/private/base.ss
@@ -57,13 +57,15 @@ improve method arity mismatch contract violation error messages?
    [(syntax? info) (build-source-location info)]
    [(list? info)
     (let ([loc (list-ref info 0)])
-      (struct-copy
-       srcloc loc
-       [source
-        (resolved-module-path-name
-         (module-path-index-resolve
-          (syntax-source-module
-           (srcloc-source loc))))]))]
+      (if (syntax? (srcloc-source loc))
+        (struct-copy
+         srcloc loc
+         [source
+          (resolved-module-path-name
+           (module-path-index-resolve
+            (syntax-source-module
+             (srcloc-source loc))))])
+        loc))]
    [else
     (error 'contract
            "expected a syntax object or list of two elements, got: ~e"
diff --git a/collects/scheme/contract/private/helpers.ss b/collects/scheme/contract/private/helpers.ss
index e666344253..8f589c6430 100644
--- a/collects/scheme/contract/private/helpers.ss
+++ b/collects/scheme/contract/private/helpers.ss
@@ -109,14 +109,18 @@
                             (syntax-line stx)
                             (syntax-column stx)
                             (syntax-position stx))
-                    (values (source->name 
-                             (resolved-module-path-name 
-                              (module-path-index-resolve 
-                               (syntax-source-module 
-                                (srcloc-source stx)))))
-                            (srcloc-line stx)
-                            (srcloc-column stx)
-                            (srcloc-position stx)))])
+                    (if (syntax? (srcloc-source stx))
+                      (values (source->name 
+                               (resolved-module-path-name 
+                                (module-path-index-resolve 
+                                 (syntax-source-module
+                                  (srcloc-source stx)))))
+                              (srcloc-line stx)
+                              (srcloc-column stx)
+                              (srcloc-position stx))
+                      (error 'contract
+                             "malformed srcloc has non-syntax source: ~e"
+                             stx)))])
     (let ([location (cond [(and line col) (format "~a:~a" line col)]
                           [pos (format "~a" pos)]
                           [else #f])])
diff --git a/collects/scheme/contract/private/misc.ss b/collects/scheme/contract/private/misc.ss
index 000fcb9174..3f1c54b6ea 100644
--- a/collects/scheme/contract/private/misc.ss
+++ b/collects/scheme/contract/private/misc.ss
@@ -740,7 +740,7 @@
                             'type-name
                             val))
                          (fill-name p-app val))))
-                   predicate?)))))))]))
+                   #:first-order predicate?)))))))]))
 
 (define listof
   (*-immutableof list? map andmap list listof))
@@ -902,8 +902,7 @@
                                          "expected immutable <~a>, given: ~e"
                                          "expected <~a>, given: ~e")
                                    'type-name
-                                   v)))))
-                        #f))))))))]
+                                   v)))))))))))))]
     [(_ predicate? constructor (arb? selector) correct-size type-name name)
      (eq? #t (syntax->datum (syntax arb?)))
      (syntax
@@ -936,8 +935,7 @@
                           v
                           "expected <~a>, given: ~e"
                           'type-name
-                          v)))))
-               #f))))))]))
+                          v)))))))))))]))
 
 (define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
 (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
@@ -1012,6 +1010,7 @@
            [ctc-proc (contract-projection ctc)])
       (simple-contract
        #:name (build-compound-type-name 'promise/c ctc)
+       #:projection
        (λ (blame)
          (let ([p-app (ctc-proc blame)])
            (λ (val)
@@ -1022,7 +1021,7 @@
                 "expected <promise>, given: ~e"
                 val))
              (delay (p-app (force val))))))
-       promise?))))
+       #:first-order promise?))))
 
 #|
    as with copy-struct in struct.ss, this first begin0