diff --git a/core/classes/error/authors.txt b/core/classes/error/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/core/classes/error/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/core/classes/error/error-tests.factor b/core/classes/error/error-tests.factor new file mode 100644 index 0000000000..80c881d174 --- /dev/null +++ b/core/classes/error/error-tests.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2015 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors classes classes.error classes.tuple +compiler.units effects eval generic io.streams.string kernel +math namespaces parser tools.test words words.symbol ; +IN: classes.error.tests + +! Test error classes +ERROR: error-class-test a b c ; + +{ "( a b c -- * )" } [ \ throw-error-class-test stack-effect effect>string ] unit-test +{ f } [ \ throw-error-class-test "inline" word-prop ] unit-test + +[ "IN: classes.error.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ] +[ error>> error>> redefine-error? ] must-fail-with + +DEFER: error-y + +{ } [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test + +{ } [ "IN: classes.error.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test + +{ f } [ \ error-y tuple-class? ] unit-test + +{ f } [ \ error-y error-class? ] unit-test + +{ t } [ \ error-y generic? ] unit-test + +{ } [ "IN: classes.error.tests ERROR: error-y ;" eval( -- ) ] unit-test + +{ t } [ \ error-y tuple-class? ] unit-test + +{ t } [ \ error-y error-class? ] unit-test + +{ f } [ \ error-y generic? ] unit-test + +ERROR: base-error x y ; +ERROR: derived-error < base-error z ; + +{ ( x y z -- * ) } [ \ throw-derived-error stack-effect ] unit-test diff --git a/core/classes/error/error.factor b/core/classes/error/error.factor new file mode 100644 index 0000000000..ca9d0bab65 --- /dev/null +++ b/core/classes/error/error.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2015 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors classes.private classes.tuple +classes.tuple.private combinators kernel parser sequences words ; +IN: classes.error + +PREDICATE: error-class < tuple-class + "error-class" word-prop ; + +M: error-class reset-class + [ call-next-method ] [ "error-class" remove-word-prop ] bi ; + +: define-error-class ( class superclass slots -- ) + error-slots { + [ define-tuple-class ] + [ 2drop reset-generic ] + [ 2drop t "error-class" set-word-prop ] + [ + 2drop + [ ] + [ [ boa throw ] curry ] + [ all-slots thrower-effect ] + tri define-declared + ] + [ + 2drop + [ name>> "throw-" prepend create-word-in [ reset-generic ] keep ] + [ [ boa throw ] curry ] + [ all-slots thrower-effect ] + tri define-declared + ] + } 3cleave ;