From 7ef1aecf885e2dd19a57b49a0d97e3698c32dd61 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sun, 25 Sep 2011 16:33:08 -0700
Subject: [PATCH] Defining an "error-class", and printing error tuples out with
 ERROR:.  See #188.

---
 basis/see/see.factor            | 10 ++++++++--
 core/classes/tuple/tuple.factor | 23 ++++++++++++++---------
 2 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/basis/see/see.factor b/basis/see/see.factor
index 38a8a48934..800709db95 100644
--- a/basis/see/see.factor
+++ b/basis/see/see.factor
@@ -191,8 +191,8 @@ M: array pprint-slot-name
 : superclass. ( class -- )
     superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
 
-M: tuple-class see-class*
-    <colon \ TUPLE: pprint-word
+: pprint-tuple-class ( class definer -- )
+    <colon pprint-word
     {
         [ pprint-word ]
         [ superclass. ]
@@ -201,6 +201,12 @@ M: tuple-class see-class*
     } cleave
     block> ;
 
+M: tuple-class see-class*
+    \ TUPLE: pprint-tuple-class ;
+
+M: error-class see-class* ( class -- )
+    \ ERROR: pprint-tuple-class ;
+
 M: word see-class* drop ;
 
 M: builtin-class see-class*
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index d67875046e..ab61fa6c37 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -290,16 +290,21 @@ M: tuple-class (define-tuple-class)
     3dup tuple-class-unchanged?
     [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
 
+PREDICATE: error-class < tuple-class
+    "error-class" word-prop ;
+
 : define-error-class ( class superclass slots -- )
-    error-slots
-    [ define-tuple-class ]
-    [ 2drop reset-generic ]
-    [
-        2drop
-        [ dup [ boa throw ] curry ]
-        [ all-slots thrower-effect ]
-        bi define-declared
-    ] 3tri ;
+    error-slots {
+        [ define-tuple-class ]
+        [ 2drop reset-generic ]
+        [ 2drop t "error-class" set-word-prop ]
+        [
+            2drop
+            [ dup [ boa throw ] curry ]
+            [ all-slots thrower-effect ]
+            bi define-declared
+        ]
+    } 3cleave ;
 
 : boa-effect ( class -- effect )
     [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;