Improved ERROR:
parent
cb121c5b50
commit
72d9c040b4
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
[
|
[
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue