From acd7b572aefd98f11e2bc5380d21486eabe2d042 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 25 Aug 2010 17:12:24 -0400
Subject: [PATCH] Added with-asserts, from code from Neil Toronto.

original commit: ea472a9d57b7344e9111bd37663fd7ad0884f0d5
---
 .../tests/typed-scheme/fail/with-asserts.rkt  |  7 +++++++
 .../tests/typed-scheme/fail/with-asserts2.rkt |  7 +++++++
 .../tests/typed-scheme/fail/with-asserts3.rkt |  7 +++++++
 .../typed-scheme/succeed/with-asserts.rkt     | 20 +++++++++++++++++++
 collects/typed-scheme/private/prims.rkt       | 19 ++++++++++++++++++
 5 files changed, 60 insertions(+)
 create mode 100644 collects/tests/typed-scheme/fail/with-asserts.rkt
 create mode 100644 collects/tests/typed-scheme/fail/with-asserts2.rkt
 create mode 100644 collects/tests/typed-scheme/fail/with-asserts3.rkt
 create mode 100644 collects/tests/typed-scheme/succeed/with-asserts.rkt

diff --git a/collects/tests/typed-scheme/fail/with-asserts.rkt b/collects/tests/typed-scheme/fail/with-asserts.rkt
new file mode 100644
index 00000000..b543f7b9
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/with-asserts.rkt
@@ -0,0 +1,7 @@
+#;
+(exn-pred exn:fail?)
+#lang typed/racket
+
+(let ([x 1] [y "2"])
+  (with-asserts ([x string?] [y integer?])
+                x))
diff --git a/collects/tests/typed-scheme/fail/with-asserts2.rkt b/collects/tests/typed-scheme/fail/with-asserts2.rkt
new file mode 100644
index 00000000..79ec314a
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/with-asserts2.rkt
@@ -0,0 +1,7 @@
+#;
+(exn-pred exn:fail?)
+#lang typed/racket
+
+(let ([x 1] [y "2"])
+  (with-asserts ([x string?])
+                x))
diff --git a/collects/tests/typed-scheme/fail/with-asserts3.rkt b/collects/tests/typed-scheme/fail/with-asserts3.rkt
new file mode 100644
index 00000000..f38cb1e6
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/with-asserts3.rkt
@@ -0,0 +1,7 @@
+#;
+(exn-pred exn:fail?)
+#lang typed/racket
+
+(let ([x #f])
+  (with-asserts ([x])
+                x))
diff --git a/collects/tests/typed-scheme/succeed/with-asserts.rkt b/collects/tests/typed-scheme/succeed/with-asserts.rkt
new file mode 100644
index 00000000..c6dc9b32
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/with-asserts.rkt
@@ -0,0 +1,20 @@
+#lang typed/racket
+
+(let ([x 1] [y "2"])
+  (with-asserts ([x integer?] [y string?])
+                x))
+(let ([x 1] [y "2"])
+  (with-asserts ([x integer?])
+                x))
+(let ([x 1] [y "2"])
+  (with-asserts ()
+                x))
+(let ([x 1] [y "2"])
+  (with-asserts ([x])
+                x))
+
+(: f : (U Integer String) -> Integer)
+(define (f x)
+  (with-asserts ([x integer?])
+                x))
+(f 1)
diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index bf9cdbc8..522ee962 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -624,3 +624,22 @@ This file defines two sorts of primitives. All of them are provided into any mod
        [(_ (~var k (param-annotated-name (lambda (s) #`(#,s -> (U))))) . body)
 	(quasisyntax/loc stx (#,l/c k.ann-name . body))]))
     (values (mk #'let/cc) (mk #'let/ec))))
+
+(define-syntax (with-asserts stx)
+  (define-syntax-class with-asserts-clause
+    [pattern [x:id]
+             #:with cond-clause
+             (syntax/loc #'x
+               [(not x)
+                (error "Assertion failed")])]
+    [pattern [x:id pred]
+             #:with cond-clause
+             (syntax/loc #'x
+               [(not (pred x))
+                (error "Assertion failed")])])
+   (syntax-parse stx
+     [(_ (c:with-asserts-clause ...) body:expr ...+)
+      (syntax/loc stx
+        (cond c.cond-clause
+              ...
+              [else body ...]))]))