diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 960855b191..57b819b43b 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -6,7 +6,8 @@ io.streams.string kernel kernel.private math math.constants math.order namespaces parser parser.notes prettyprint quotations random see sequences sequences.private slots slots.private splitting strings summary threads tools.test -vectors vocabs words words.symbol fry literals memory ; +vectors vocabs words words.symbol fry literals memory +combinators.short-circuit ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -837,3 +838,41 @@ DEFER: initial-slot [ "IN: classes.tuple.tests USE: math TUPLE: foo < foo ;" eval( -- ) ] [ error>> bad-superclass? ] must-fail-with [ "IN: classes.tuple.tests USE: math TUPLE: foo < + ;" eval( -- ) ] [ error>> bad-superclass? ] must-fail-with + + +! Test no-slot error and get/set-slot-named + +TUPLE: no-slot-tuple0 a b c ; +C: no-slot-tuple0 + +[ 1 2 3 "d" over get-slot-named ] +[ + { + [ no-slot? ] + [ tuple>> no-slot-tuple0? ] + [ name>> "d" = ] + } 1&& +] must-fail-with + +{ 1 } +[ 1 2 3 "a" swap get-slot-named ] unit-test + +{ 2 } +[ 1 2 3 "b" swap get-slot-named ] unit-test + +{ 3 } +[ 1 2 3 "c" swap get-slot-named ] unit-test + +{ 4 } [ + 1 2 3 4 "a" pick set-slot-named + "a" swap get-slot-named +] unit-test + +[ 1 2 3 4 "d" pick set-slot-named ] +[ + { + [ no-slot? ] + [ tuple>> no-slot-tuple0? ] + [ name>> "d" = ] + } 1&& +] must-fail-with diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index c92a1fe6cb..b52304e342 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -16,10 +16,11 @@ ERROR: not-a-tuple object ; : all-slots ( class -- slots ) superclasses [ "slots" word-prop ] map concat ; -ERROR: no-slot ; +ERROR: no-slot name tuple ; : offset-of-slot ( name tuple -- n ) - class-of all-slots slot-named dup [ no-slot ] unless offset>> ; + 2dup class-of all-slots slot-named + [ 2nip offset>> ] [ no-slot ] if* ; : get-slot-named ( name tuple -- value ) [ nip ] [ offset-of-slot ] 2bi slot ;