.

original commit: 65115e7d7f33f160eb8c71d6d86b2a3a83f67145

collects/mzlib/contract.ss

@@ -1066,13 +1066,7 @@ add struct contracts for immutable structs?
                 (syntax 
                  (->d any/c doms ... 
                       (let ([f rng-proc])
-                        (unless (procedure? f)
+			(check->* f arity-count)
-                          (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
-                        (unless (procedure-arity-includes? f arity-count)
-                          (error 'object-contract 
-                                 "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
-                                 arity-count
-                                 f))
                         (lambda (_this-var arg-vars ...)
                           (f arg-vars ...))))))
               (with-syntax ([(args-vars ...) (generate-temporaries doms-val)])
@@ -1085,13 +1079,7 @@ add struct contracts for immutable structs?
                             [arity-count (length doms-val)])
                 (syntax (->d* (any/c doms ...)
                               (let ([f rng-proc])
-                                (unless (procedure? f)
+				(check->* f arity-count)
-                                  (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
-                                (unless (procedure-arity-includes? f arity-count)
-                                  (error 'object-contract 
-                                         "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
-                                         arity-count
-                                         f))
                                 (lambda (_this-var arg-vars ...)
                                   (f arg-vars ...)))))))
             (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
@@ -1107,13 +1095,7 @@ add struct contracts for immutable structs?
                 (syntax (->d* (any/c doms ...)
                               rst-ctc
                               (let ([f rng-proc])
-                                (unless (procedure? f)
+				(check->*/more f arity-count)
-                                  (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
-                                (unless (procedure-accepts-and-more? f arity-count)
-                                  (error 'object-contract 
-                                         "expected last argument of ->d* to be a procedure that accepts ~a arguments and arbitrarily many more, got ~e"
-                                         arity-count
-                                         f))
                                 (lambda (_this-var arg-vars ... . rest-var)
                                   (apply f arg-vars ... rest-var))))))
               (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
@@ -1268,34 +1250,17 @@ add struct contracts for immutable structs?
                                                       '(field-name ...))]
                              [field-names-list '(field-name ...)])
                          (lambda (val)
-                           (unless (object? val)
+			   (check-object val src-info pos-blame neg-blame orig-str)
-                             (raise-contract-error src-info
-                                                   pos-blame
-                                                   neg-blame
-                                                   orig-str
-                                                   "expected an object, got ~e"
-                                                   val))
                            (let ([val-mtd-names
                                   (interface->method-names
                                    (object-interface
                                     val))])
                              (void)
-                             (unless (memq 'method-name val-mtd-names)
+			     (check-method 'method-name val-mtd-names src-info pos-blame neg-blame orig-str)
-                               (raise-contract-error src-info
-                                                     pos-blame
-                                                     neg-blame
-                                                     orig-str
-                                                     "expected an object with method ~s"
-                                                     'method-name))
                              ...)
                            
                            (unless (field-bound? field-name val)
-                             (raise-contract-error src-info
+			     (field-error 'field-name src-info pos-blame neg-blame orig-str)) ...
-                                                   pos-blame
-                                                   neg-blame
-                                                   orig-str
-                                                   "expected an object with field ~s"
-                                                   'field-name)) ...
                            
                            (let ([vtable (extract-vtable val)]
                                  [method-ht (extract-method-ht val)])
@@ -1473,16 +1438,7 @@ add struct contracts for immutable structs?
                  (lambda (outer-args)
                    (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                      (syntax
-                      (unless (and (procedure? val)
+		      (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
-                                   (procedure-arity-includes? val dom-length))
-                        (raise-contract-error
-                         src-info
-                         pos-blame
-                         neg-blame
-                         orig-str
-                         "expected a procedure that accepts ~a arguments, given: ~e"
-                         dom-length
-                         val)))))
                  
                  (lambda (outer-args)
                    (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -1523,16 +1479,7 @@ add struct contracts for immutable structs?
                    (lambda (outer-args)
                      (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                        (syntax
-                        (unless (and (procedure? val)
+			(check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
-                                     (procedure-arity-includes? val dom-length))
-                          (raise-contract-error
-                           src-info
-                           pos-blame
-                           neg-blame
-                           orig-str
-                           "expected a procedure that accepts ~a arguments, given: ~e"
-                           dom-length
-                           val)))))
                    
                    (lambda (outer-args)
                      (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -1571,16 +1518,7 @@ add struct contracts for immutable structs?
                    (lambda (outer-args)
                      (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                        (syntax
-                        (unless (and (procedure? val)
+			(check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
-                                     (procedure-arity-includes? val dom-length))
-                          (raise-contract-error
-                           src-info
-                           pos-blame
-                           neg-blame
-                           orig-str
-                           "expected a procedure that accepts ~a arguments, given: ~e"
-                           dom-length
-                           val)))))
                    
                    (lambda (outer-args)
                      (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -1638,16 +1576,7 @@ add struct contracts for immutable structs?
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
-                 (unless (and (procedure? val)
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
-                              (procedure-arity-includes? val dom-length))
-                   (raise-contract-error
-                    src-info
-                    pos-blame
-                    neg-blame
-                    orig-str
-                    "expected a procedure that accepts ~a arguments, given: ~e"
-                    dom-length
-                    val)))))
             
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -1693,16 +1622,7 @@ add struct contracts for immutable structs?
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
-                 (unless (and (procedure? val)
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
-                              (procedure-arity-includes? val dom-length))
-                   (raise-contract-error
-                    src-info
-                    pos-blame
-                    neg-blame
-                    orig-str
-                    "expected a procedure that accepts ~a arguments, given: ~e"
-                    dom-length
-                    val)))))
             
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -1763,17 +1683,7 @@ add struct contracts for immutable structs?
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
-                 (unless (and (procedure? val)
+		 (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str))))
-                              (procedure-accepts-and-more? val dom-length))
-                   (raise-contract-error
-                    src-info
-                    pos-blame
-                    neg-blame
-                    orig-str
-                    "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
-                    dom-length
-                    dom-length
-                    val)))))
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
@@ -1829,15 +1739,8 @@ add struct contracts for immutable structs?
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
-                 (unless (procedure? val)
+		 ;; CHECK: previously, this test didn't use `procedure-arity' and compare to `dom-length'
-                   (raise-contract-error
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
-                    src-info
-                    pos-blame
-                    neg-blame
-                    orig-str
-                    "expected a procedure that accepts ~a arguments, given: ~e"
-                    dom-length
-                    val)))))
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
@@ -1872,11 +1775,7 @@ add struct contracts for immutable structs?
                  (let ([dom-contract-x (coerce-contract ->d dom)] ...)
                    (let ([dom-x (contract-proc dom-contract-x)] ...
                          [rng-x rng])
-                     (unless (and (procedure? rng-x)
+		     (check-rng-procedure '->d rng-x arity)
-                                  (procedure-arity-includes? rng-x arity))
-                       (error '->d "expected range portion to be a function that takes ~a arguments, given: ~e"
-                              arity
-                              rng-x))
                      (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))])
                        
                        body))))))
@@ -1889,16 +1788,7 @@ add struct contracts for immutable structs?
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
-                 (unless (and (procedure? val)
+		 (check-procedure val arity src-info pos-blame neg-blame orig-str))))
-                              (procedure-arity-includes? val arity))
-                   (raise-contract-error
-                    src-info
-                    pos-blame
-                    neg-blame
-                    orig-str
-                    "expected a procedure that accepts ~a arguments, given: ~e"
-                    arity
-                    val)))))
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
@@ -1935,10 +1825,7 @@ add struct contracts for immutable structs?
                  (let ([dom-contract-x (coerce-contract ->d* dom)] ...)
                    (let ([dom-x (contract-proc dom-contract-x)] ...
                          [rng-mk-x rng-mk])
-                     (unless (and (procedure? rng-mk-x)
+		     (check-rng-procedure '->d* rng-mk-x dom-length)
-                                  (procedure-arity-includes? rng-mk-x dom-length))
-                       (error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e"
-                              dom-length rng-mk-x))
                      (let ([name-id (build-compound-type-name
                                      '->d* 
                                      (build-compound-type-name name-dom-contract-x ...)
@@ -1953,16 +1840,7 @@ add struct contracts for immutable structs?
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
-                 (unless (and (procedure? val)
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
-                              (procedure-arity-includes? val dom-length))
-                   (raise-contract-error
-                    src-info
-                    pos-blame
-                    neg-blame
-                    orig-str
-                    "expected a procedure that accepts ~a arguments, given: ~e"
-                    dom-length
-                    val)))))
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
@@ -1974,10 +1852,7 @@ add struct contracts for immutable structs?
                       (lambda ()
                         (val (dom-projection-x arg-x) ...))
                       (lambda results
-                        (unless (= (length results) (length rng-contracts))
+			(check-rng-lengths results rng-contracts)
-                          (error '->d* 
-                                 "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" 
-                                 (length results) (length rng-contracts)))
                         (apply 
                          values
                          (map (lambda (rng-contract result)
@@ -2014,11 +1889,7 @@ add struct contracts for immutable structs?
                    (let ([dom-x (contract-proc dom-contract-x)] ...
                          [dom-rest-x (contract-proc dom-rest-contract-x)]
                          [rng-mk-x rng-mk])
-                     (unless (and (procedure? rng-mk-x)
+		     (check-rng-procedure/more rng-mk-x arity)
-                                  (procedure-accepts-and-more? rng-mk-x arity))
-                       (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
-                              arity 
-                              rng-mk-x))
                      (let ([name-id (build-compound-type-name 
                                      '->d*
                                      (build-compound-type-name name-dom-contract-x ...)
@@ -2035,16 +1906,8 @@ add struct contracts for immutable structs?
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
-                 (unless (and (procedure? val)
+		 ;; CHECK: old check use "and more", but error message didn't
-                              (procedure-accepts-and-more? val arity))
+		 (check-procedure/more val arity src-info pos-blame neg-blame orig-str))))
-                   (raise-contract-error
-                    src-info
-                    pos-blame
-                    neg-blame
-                    orig-str
-                    "expected a procedure that accepts ~a arguments, given: ~e"
-                    arity
-                    val)))))
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax
@@ -2061,10 +1924,7 @@ add struct contracts for immutable structs?
                          ...
                          (dom-rest-projection-x rest-arg-x)))
                       (lambda results
-                        (unless (= (length results) (length rng-contracts))
+			(check-rng-lengths results rng-contracts)
-                          (error '->d* 
-                                 "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" 
-                                 (length results) (length rng-contracts)))
                         (apply 
                          values
                          (map (lambda (rng-contract result)
@@ -2105,26 +1965,10 @@ add struct contracts for immutable structs?
             (lambda (outer-args inner-lambda) inner-lambda)
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
-                            [kind-of-thing (if method-proc? "method" "procedure")])
+                            [kind-of-thing (if method-proc? 'method 'procedure)])
                 (syntax
                  (begin 
-                   (unless (procedure? val)
+		   (check-procedure/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str)))))
-                     (raise-contract-error src-info
-                                           pos-blame
-                                           neg-blame
-                                           orig-str
-                                           "expected a procedure, got ~e"
-                                           val))
-                   (unless (procedure-arity-includes? val arity)
-                     (raise-contract-error src-info
-                                           pos-blame
-                                           neg-blame
-                                           orig-str
-                                           "expected a ~a of arity ~a (not arity ~a), got  ~e"
-                                           kind-of-thing
-                                           arity
-                                           (procedure-arity val)
-                                           val))))))
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax-case* (syntax rng) (any values) module-or-top-identifier=?
@@ -2203,26 +2047,10 @@ add struct contracts for immutable structs?
             (lambda (outer-args inner-lambda) inner-lambda)
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
-                            [kind-of-thing (if method-proc? "method" "procedure")])
+                            [kind-of-thing (if method-proc? 'method 'procedure)])
                 (syntax
                  (begin 
-                   (unless (procedure? val)
+		   (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str)))))
-                     (raise-contract-error src-info
-                                           pos-blame
-                                           neg-blame
-                                           orig-str
-                                           "expected a procedure, got ~e"
-                                           val))
-                   (unless (procedure-accepts-and-more? val arity)
-                     (raise-contract-error src-info
-                                           pos-blame
-                                           neg-blame
-                                           orig-str
-                                           "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got  ~e"
-                                           kind-of-thing
-                                           arity
-                                           (procedure-arity val)
-                                           val))))))
             (lambda (outer-args)
               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                 (syntax-case* (syntax rng) (values any) module-or-top-identifier=?
@@ -2366,6 +2194,138 @@ add struct contracts for immutable structs?
                            (void)]
                           [else (loop (cdr counts))]))))
                   (<= min-at-least dom-length))))])))
+
+  ;; ----------------------------------------
+  ;; Checks and error functions used in macro expansions
+  
+  (define (check->* f arity-count)
+    (unless (procedure? f)
+      (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
+    (unless (procedure-arity-includes? f arity-count)
+      (error 'object-contract 
+	     "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
+	     arity-count
+	     f)))
+
+  (define (check->*/more f arity-count)
+    (unless (procedure? f)
+      (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
+    (unless (procedure-accepts-and-more? f arity-count)
+      (error 'object-contract 
+	     "expected last argument of ->d* to be a procedure that accepts ~a arguments and arbitrarily many more, got ~e"
+	     arity-count
+	     f)))
+
+
+  (define (check-procedure val dom-length src-info pos-blame neg-blame orig-str)
+    (unless (and (procedure? val)
+		 (procedure-arity-includes? val dom-length))
+      (raise-contract-error
+       src-info
+       pos-blame
+       neg-blame
+       orig-str
+       "expected a procedure that accepts ~a arguments, given: ~e"
+       dom-length
+       val)))
+
+  (define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
+    (unless (procedure? val)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a procedure, got ~e"
+			    val))
+    (unless (procedure-arity-includes? val arity)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a ~a of arity ~a (not arity ~a), got  ~e"
+			    kind-of-thing
+			    arity
+			    (procedure-arity val)
+			    val)))
+
+  (define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
+    (unless (procedure? val)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a procedure, got ~e"
+			    val))
+    (unless (procedure-accepts-and-more? val arity)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got  ~e"
+			    kind-of-thing
+			    arity
+			    (procedure-arity val)
+			    val)))
+
+  (define (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str)
+    (unless (and (procedure? val)
+		 (procedure-accepts-and-more? val dom-length))
+      (raise-contract-error
+       src-info
+       pos-blame
+       neg-blame
+       orig-str
+       "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
+       dom-length
+       dom-length
+       val)))
+
+
+  (define (check-rng-procedure who rng-x arity)
+    (unless (and (procedure? rng-x)
+		 (procedure-arity-includes? rng-x arity))
+      (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
+	     arity
+	     rng-x)))
+
+  (define (check-rng-procedure/more rng-mk-x arity)
+    (unless (and (procedure? rng-mk-x)
+		 (procedure-accepts-and-more? rng-mk-x arity))
+      (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
+	     arity 
+	     rng-mk-x)))
+
+  (define (check-rng-lengths results rng-contracts)
+    (unless (= (length results) (length rng-contracts))
+      (error '->d* 
+	     "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" 
+	     (length results) (length rng-contracts))))
+
+  (define (check-object val src-info pos-blame neg-blame orig-str)
+    (unless (object? val)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected an object, got ~e"
+			    val)))
+
+  (define (check-method method-name val-mtd-names src-info pos-blame neg-blame orig-str)
+    (unless (memq method-name val-mtd-names)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected an object with method ~s"
+			    method-name)))
+
+  (define (field-error field-name src-info pos-blame neg-blame orig-str)
+    (raise-contract-error src-info
+			  pos-blame
+			  neg-blame
+			  orig-str
+			  "expected an object with field ~s"
+			  field-name))
                                                 
   #|
 

collects/mzlib/etc.ss

@@ -560,5 +560,11 @@
   (define-syntax (begin-lifted stx)
     (syntax-case stx ()
       [(_ expr0 expr ...)
-       (syntax-local-lift-expression 
+       (let ([name (syntax-local-name)])
-	#'(begin expr0 expr ...))])))
+	 (if name
+	     (with-syntax ([name name])
+	       (syntax-local-lift-expression 
+		#'(let ([name (begin expr0 expr ...)])
+		    name)))
+	     (syntax-local-lift-expression 
+	      #'(begin expr0 expr ...))))])))