From 959082d12dd66abf9bec26b7b8565f9236b10911 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 29 Jul 2008 11:04:52 -0700
Subject: [PATCH] assert now gives source information when available.

---
 scheme/last-revision       |  2 +-
 scheme/makefile.ss         |  1 +
 scheme/psyntax.expander.ss | 38 ++++++++++++++++++++++++++------------
 3 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/scheme/last-revision b/scheme/last-revision
index fa1d255..f64a277 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1560
+1561
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 794078a..6cceed5 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -634,6 +634,7 @@
     [apply                                       i r ba se]
     [asin                                        i r ba se]
     [assert                                      i r ba]
+    [assertion-error                             ]
     [assertion-violation                         i r ba]
     [atan                                        i r ba se]
     [boolean=?                                   i r ba]
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index 7e2ef4c..213a36c 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -30,7 +30,7 @@
           compile-r6rs-top-level boot-library-expand 
           null-environment scheme-report-environment
           interaction-environment
-          ellipsis-map)
+          ellipsis-map assertion-error)
   (import
     (except (rnrs)
       environment environment? identifier?
@@ -1435,8 +1435,10 @@
     (lambda (stx)
       (syntax-match stx ()
         ((_ expr)
-         (bless `(unless ,expr
-                   (assertion-violation 'assert "assertion failed" ',expr)))))))
+         (let ([pos (or (expression-position stx)
+                        (expression-position expr))])
+           (bless 
+             `(unless ,expr (assertion-error ',expr ',pos))))))))
   
   (define endianness-macro
     (lambda (stx)
@@ -3843,21 +3845,33 @@
               (assertion-violation 'bound-identifier=? "not an identifier" y))
           (assertion-violation 'bound-identifier=? "not an identifier" x))))
   
-  (define (extract-position-condition x)
+  (define (make-source-condition x)
     (define-condition-type &source-information &condition
       make-source-condition source-condition?
       (file-name source-filename)
       (character source-character))
-    (if (stx? x) 
-        (let ([x (stx-expr x)])
-          (if (annotation? x)
-              (let ([src (annotation-source x)])
-                (if (pair? src) 
-                    (make-source-condition (car src) (cdr src))
-                    (condition)))
-              (condition)))
+    (if (pair? x)
+        (make-source-condition (car x) (cdr x))
         (condition)))
 
+  (define (extract-position-condition x)
+    (make-source-condition (expression-position x)))
+
+  (define (expression-position x)
+    (and (stx? x)
+         (let ([x (stx-expr x)])
+           (and (annotation? x)
+                (annotation-source x)))))
+
+  (define (assertion-error expr pos)
+    (raise
+      (condition
+        (make-assertion-violation)
+        (make-who-condition 'assert)
+        (make-message-condition "assertion failed")
+        (make-irritants-condition (list expr))
+        (make-source-condition pos))))
+
   (define syntax-error
     (lambda (x . args)
       (unless (for-all string? args)