Improved ERROR:

db4
Slava Pestov 2008-07-03 02:47:29 -05:00
parent cb121c5b50
commit 72d9c040b4
3 changed files with 33 additions and 3 deletions

View File

@ -656,3 +656,28 @@ T{ reshape-test f "hi" } "tuple" set
TUPLE: boa-coercer-test { x array-capacity } ; TUPLE: boa-coercer-test { x array-capacity } ;
[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test [ 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

View File

@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra quotations memory combinators generic classes classes.algebra
classes.private slots.deprecated slots.private slots classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ; compiler.units math.private accessors assocs effects ;
IN: classes.tuple IN: classes.tuple
M: tuple class 1 slot 2 slot { word } declare ; M: tuple class 1 slot 2 slot { word } declare ;
@ -255,9 +255,13 @@ M: tuple-class define-tuple-class
3dup tuple-class-unchanged? 3dup tuple-class-unchanged?
[ 3drop ] [ redefine-tuple-class ] if ; [ 3drop ] [ redefine-tuple-class ] if ;
: thrower-effect ( slots -- effect )
[ dup array? [ first ] when ] map f <effect> t >>terminated? ;
: define-error-class ( class superclass slots -- ) : define-error-class ( class superclass slots -- )
[ define-tuple-class ] [ 2drop ] 3bi [ define-tuple-class ]
dup [ boa throw ] curry define ; [ [ dup [ boa throw ] curry ] [ drop ] [ thrower-effect ] tri* ] 3bi
define-declared ;
M: tuple-class reset-class M: tuple-class reset-class
[ [

View File

@ -175,6 +175,7 @@ IN: bootstrap.syntax
"ERROR:" [ "ERROR:" [
parse-tuple-definition parse-tuple-definition
pick reset-generic
pick save-location pick save-location
define-error-class define-error-class
] define-syntax ] define-syntax