From 22dc82567d388ae1d23e9b8abfc0b1909117558b Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Mon, 3 Aug 2009 10:36:18 +0300
Subject: [PATCH] added a "warning" procedure, that's like assertion-violation
 and error except that it throws a warning via raise-continuable.

---
 scheme/ikarus.exceptions.ss | 34 +++++++++++++++-------------------
 scheme/ikarus.reader.ss     |  3 ++-
 scheme/ikarus.writer.ss     |  4 ----
 scheme/last-revision        |  2 +-
 scheme/makefile.ss          |  1 +
 5 files changed, 19 insertions(+), 25 deletions(-)

diff --git a/scheme/ikarus.exceptions.ss b/scheme/ikarus.exceptions.ss
index 971110d..eb24b50 100644
--- a/scheme/ikarus.exceptions.ss
+++ b/scheme/ikarus.exceptions.ss
@@ -16,14 +16,14 @@
 
 (library (ikarus exceptions)
   (export with-exception-handler raise raise-continuable 
-    error assertion-violation die)
+    error warning assertion-violation die)
   (import 
     (only (rnrs) condition make-non-continuable-violation
           make-message-condition make-error make-who-condition
           make-irritants-condition make-assertion-violation)
     (except (ikarus)
       with-exception-handler raise raise-continuable 
-      error assertion-violation die))
+      error warning assertion-violation die))
 
   (define handlers
     (make-parameter
@@ -60,28 +60,24 @@
               (make-non-continuable-violation)
               (make-message-condition "handler returned")))))))
 
-  (define (error who msg . irritants) 
-    (unless (string? msg) 
-      (assertion-violation 'error "message is not a string" msg))
-    (raise
+  (define (err who* raise* cond* who msg irritants)
+    (unless (string? msg)
+      (assertion-violation who* "message is not a string" msg))
+    (raise*
        (condition
-         (make-error)
+         (cond*)
          (if who (make-who-condition who) (condition))
          (make-message-condition msg)
          (make-irritants-condition irritants))))
 
-  (define (assertion-violation who msg . irritants) 
-    (unless (string? msg) 
-      (assertion-violation 'assertion-violation "message is not a string" msg))
-    (raise
-       (condition
-         (make-assertion-violation)
-         (if who (make-who-condition who) (condition))
-         (make-message-condition msg)
-         (make-irritants-condition irritants))))
-
-  (define die assertion-violation)
-  
+  (define (error who msg . irritants)
+    (err 'error raise make-error who msg irritants))
+  (define (assertion-violation who msg . irritants)
+    (err 'assertion-violation raise make-assertion-violation who msg irritants))
+  (define (warning who msg . irritants)
+    (err 'warning raise-continuable make-warning who msg irritants))
+  (define (die who msg . irritants)
+    (err 'die raise make-assertion-violation who msg irritants))
 
 )
 
diff --git a/scheme/ikarus.reader.ss b/scheme/ikarus.reader.ss
index 3bbe43d..dc6a065 100644
--- a/scheme/ikarus.reader.ss
+++ b/scheme/ikarus.reader.ss
@@ -29,7 +29,8 @@
           input-port-column-number)
     (except (ikarus) read-char read read-token comment-handler get-datum
       read-annotated read-script-annotated annotation?
-      annotation-expression annotation-source annotation-stripped))
+      annotation-expression annotation-source annotation-stripped
+      input-port-column-number))
 
   (define (die/lex id pos who msg arg*)
     (raise 
diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss
index 20fa5c3..aafdb91 100644
--- a/scheme/ikarus.writer.ss
+++ b/scheme/ikarus.writer.ss
@@ -790,10 +790,6 @@
     (lambda (who fmt . args)
       (display-error "Error" who fmt args)))
 
-  (define warning 
-    (lambda (who fmt . args)
-      (display-error "Warning" who fmt args)))
-
   (define (assert-open-textual-output-port p who)
     (unless (output-port? p) 
       (die who "not an output port" p))
diff --git a/scheme/last-revision b/scheme/last-revision
index 4e6b92a..1105122 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1841
+1842
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 8228aed..4edb06f 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -735,6 +735,7 @@
     [equal?                                      i r ba se]
     [eqv?                                        i r ba se]
     [error                                       i r ba]
+    [warning                                     i]
     [die                                         i]
     [even?                                       i r ba se]
     [exact                                       i r ba]