From 731ef32c18d46cd43f2007b85b1d29c08c965749 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 3 Sep 2002 18:23:30 +0000
Subject: [PATCH] ..

original commit: 675bb6abd03f47554357a4f9f97193e31f8f565f
---
 collects/mzlib/contracts.ss | 88 ++++++++++++++++++++++++++++++-------
 1 file changed, 71 insertions(+), 17 deletions(-)

diff --git a/collects/mzlib/contracts.ss b/collects/mzlib/contracts.ss
index 5cae3d6..15b92cb 100644
--- a/collects/mzlib/contracts.ss
+++ b/collects/mzlib/contracts.ss
@@ -9,7 +9,8 @@
 	   opt->
            opt->*
            (rename -contract? contract?)
-           provide/contract)
+           provide/contract
+           define/contract)
 
   (require-for-syntax mzscheme
                       (lib "list.ss")
@@ -17,7 +18,73 @@
                       (lib "stx.ss" "syntax"))
   
   (require (lib "class.ss"))
+  (require (lib "contract-helpers.scm" "mzlib" "private"))
   
+  ;; (define/contract id contract expr)
+  ;; defines `id' with `contract'; initially binding
+  ;; it to the result of `expr'.  These variables may not be set!'d.
+  (define-syntax (define/contract define-stx)
+    (syntax-case define-stx ()
+      [(_ name contract-expr expr)
+       (identifier? (syntax name))
+       (with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)]
+                     [contract-id (datum->syntax-object define-stx 'ACK-define/contract-contract-id)]
+                     [id (datum->syntax-object define-stx 'ACK-define/contract-id)])
+         (syntax 
+          (begin
+            (define contract-id contract-expr)
+            (define-syntax name
+              (make-set!-transformer
+               (lambda (stx)
+                 
+                 ;; build-src-loc-string : syntax -> string
+                 (define (build-src-loc-string/unk stx)
+                   (let ([source (syntax-source stx)]
+                         [line (syntax-line stx)]
+                         [col (syntax-column stx)]
+                         [pos (syntax-position stx)])
+                     (cond
+                       [(and (string? source) line col)
+                        (format "~a: ~a.~a" source line col)]
+                       [(and line col)
+                        (format "~a.~a" line col)]
+                       [(and (string? source) pos)
+                        (format "~a: ~a" source pos)]
+                       [pos
+                        (format "~a" pos)]
+                       [else "<<unknown>>"])))
+                 
+                 (with-syntax ([neg-blame-str (build-src-loc-string/unk stx)])
+                   (syntax-case stx ()
+                     [(set! _ arg) 
+                      (raise-syntax-error 'define/contract
+                                          "cannot set! a define/contract variable" 
+                                          stx 
+                                          (syntax _))]
+                     [(_ arg (... ...))
+                      (syntax 
+                       ((-contract contract-id
+                                   id
+                                   (syntax-object->datum (quote-syntax _))
+                                   (string->symbol neg-blame-str)
+                                   (quote-syntax _))
+                        arg
+                        (... ...)))]
+                     [_
+                      (identifier? (syntax _))
+                      (syntax 
+                       (-contract contract-id
+                                  id  
+                                  (syntax-object->datum (quote-syntax _)) 
+                                  (string->symbol neg-blame-str)
+                                  (quote-syntax _)))])))))
+            (define id (let ([name expr]) name))  ;; let for procedure naming
+            )))]
+      [(_ name contract-expr expr)
+       (raise-syntax-error 'define/contract "expected identifier in first position"
+                           define-stx
+                           (syntax name))]))
+      
   ;; (provide/contract (id expr) ...)
   ;; provides each `id' with the contract `expr'.
   (define-syntax (provide/contract provide-stx)
@@ -60,7 +127,7 @@
                    (syntax-case stx (set!)
                      [(set! _ body) (raise-syntax-error
                                      #f 
-                                     "cannot mutate provide/contract identifier"
+                                     "cannot set! provide/contract identifier"
                                      stx
                                      (syntax _))]
                      [(_ arg (... ...))
@@ -100,25 +167,12 @@
 		provide-stx
 		clause)]))
 	(syntax->list (syntax (clauses ...))))]))
-  
+
   ;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
   ;; doesn't return
   (define (raise-contract-error src-info to-blame other-party fmt . args)
     (let ([blame-src (if (syntax? src-info)
-			 (let ([source (syntax-source src-info)]
-			       [line (syntax-line src-info)]
-			       [col (syntax-column src-info)]
-			       [pos (syntax-position src-info)])
-			   (cond
-			      [(and (string? source) line col)
-			       (format "~a: ~a.~a: " source line col)]
-			      [(and line col)
-			       (format "~a.~a: " line col)]
-			      [(and (string? source) pos)
-			       (format "~a: ~a: " source pos)]
-			      [pos
-			       (format "~a: " pos)]
-			      [else ""]))
+			 (string-append (build-src-loc-string src-info) ": ")
 			 "")]
 	  [specific-blame
 	   (let ([datum (syntax-object->datum src-info)])