From 3c68ac4a0c0d3e21df86217c3b8025ba0fc58e7b Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Sat, 14 Nov 2009 14:17:06 +0000
Subject: [PATCH] Add `contract' contract to DeinProgramm / DMdA languages.

While we're at it, improve source-location reporting for application
contracts.

svn: r16769
---
 .../deinprogramm/contract/contract-syntax.ss  | 19 ++++++++++++++++---
 .../scribblings/DMdA-beginner.scrbl           |  3 +++
 .../deinprogramm/scribblings/std-grammar.ss   |  1 +
 3 files changed, 20 insertions(+), 3 deletions(-)

diff --git a/collects/deinprogramm/contract/contract-syntax.ss b/collects/deinprogramm/contract/contract-syntax.ss
index d42f529d45..1d692df334 100644
--- a/collects/deinprogramm/contract/contract-syntax.ss
+++ b/collects/deinprogramm/contract/contract-syntax.ss
@@ -19,7 +19,9 @@
       #'?stx1)))
 
 (define-for-syntax (parse-contract name stx)
-  (syntax-case* stx (mixed one-of predicate list -> combined property reference at) module-or-top-identifier=?
+  (syntax-case* stx
+		(mixed one-of predicate list -> combined property reference at contract)
+		module-or-top-identifier=?
     ((mixed ?contract ...)
      (with-syntax ((?stx (phase-lift stx))
 		   (?name name)
@@ -76,6 +78,9 @@
     ((at ?loc ?ctr)
      (with-syntax ((?ctr-expr (parse-contract #f #'?ctr)))
        #'(contract-update-syntax ?ctr-expr #'?loc)))
+    (contract
+     (with-syntax ((?stx (phase-lift stx)))
+       #'(contract-update-syntax contract/contract #'?loc)))
     (?id
      (identifier? #'?id)
      (with-syntax ((?stx (phase-lift stx)))
@@ -112,18 +117,26 @@
 				 ?stx)))
     ((?contract-abstr ?contract ...)
      (identifier? #'?contract-abstr)
-     (with-syntax (((?contract-expr ...) (map (lambda (ctr)
+     (with-syntax ((?stx (phase-lift stx))
+		   ((?contract-expr ...) (map (lambda (ctr)
 						(parse-contract #f ctr))
 					      (syntax->list #'(?contract ...)))))
        (with-syntax
 	   ((?call (syntax/loc stx (?contract-abstr ?contract-expr ...))))
 	 #'(make-delayed-contract '?name
 				  (delay ?call)
-				  #'?stx))))
+				  ?stx))))
     (else
      (raise-syntax-error 'contract
 			 "ungültiger Vertrag" stx))))
 
+; regrettable
+(define contract/contract
+  (make-predicate-contract 'contract
+			   (delay contract?)
+			   #f))
+			     
+
 (define-syntax contract
   (lambda (stx)
     (syntax-case stx ()
diff --git a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
index e9c17b1169..9aaef821b7 100644
--- a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
+++ b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
@@ -242,6 +242,9 @@ Vertrag für Zeichenketten.
 Vertrag für die leere Liste.
 }
 
+@defform/none[contract]{
+Vertrag  Verträge.}
+
 @subsection{@scheme[predicate]}
 @defform[(predicate expr)]{
 Bei diesem Vertrag muß @scheme[expr] als Wert ein Prädikat haben, also
diff --git a/collects/deinprogramm/scribblings/std-grammar.ss b/collects/deinprogramm/scribblings/std-grammar.ss
index b42152a5a4..eced83cc27 100644
--- a/collects/deinprogramm/scribblings/std-grammar.ss
+++ b/collects/deinprogramm/scribblings/std-grammar.ss
@@ -61,6 +61,7 @@
 	      @#,scheme[(code:line %a %b %c (code:comment @#,seclink["contract-variable"]{Vertrags-Variable}))]
 	      @#,scheme[(combined contr (... ...))]
 	      @#,scheme[(property expr contr)]
+	      @#,scheme[contract]
    ]
    [test-case @#,scheme[(check-expect expr expr)]
               @#,scheme[(check-within expr expr expr)]