diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index c2bd10b68a..5eb32fb5ce 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -656,3 +656,28 @@ T{ reshape-test f "hi" } "tuple" set TUPLE: boa-coercer-test { x array-capacity } ; [ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test + +! Test error classes +ERROR: error-class-test a b c ; + +[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test +[ f ] [ \ error-class-test "inline" word-prop ] unit-test + +[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ] +[ error>> error>> redefine-error? ] must-fail-with + +DEFER: error-y + +[ ] [ [ \ error-y forget-class ] with-compilation-unit ] unit-test + +[ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test + +[ f ] [ \ error-y tuple-class? ] unit-test + +[ t ] [ \ error-y generic? ] unit-test + +[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test + +[ t ] [ \ error-y tuple-class? ] unit-test + +[ f ] [ \ error-y generic? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 0d1170b809..59a2d15749 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic classes classes.algebra classes.private slots.deprecated slots.private slots -compiler.units math.private accessors assocs ; +compiler.units math.private accessors assocs effects ; IN: classes.tuple M: tuple class 1 slot 2 slot { word } declare ; @@ -255,9 +255,13 @@ M: tuple-class define-tuple-class 3dup tuple-class-unchanged? [ 3drop ] [ redefine-tuple-class ] if ; +: thrower-effect ( slots -- effect ) + [ dup array? [ first ] when ] map f t >>terminated? ; + : define-error-class ( class superclass slots -- ) - [ define-tuple-class ] [ 2drop ] 3bi - dup [ boa throw ] curry define ; + [ define-tuple-class ] + [ [ dup [ boa throw ] curry ] [ drop ] [ thrower-effect ] tri* ] 3bi + define-declared ; M: tuple-class reset-class [ diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index e8ee857877..ad3bfed77b 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -175,6 +175,7 @@ IN: bootstrap.syntax "ERROR:" [ parse-tuple-definition + pick reset-generic pick save-location define-error-class ] define-syntax