classes.tuple: check slot value in set-slot-named / from-slots

diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 44168556c621807803857fdb5126cd4d8a3dd58e..d97f0e5e118f78074f6906e8b07b096b878bf9b6 100644 (file)
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -63,6 +63,13 @@ TUPLE: slotty a b c ;
 { T{ slotty f 1 2 f } } [ H{ { "a" 1 } { "b" 2 } } slotty from-slots ] unit-test
 [ H{ { "d" 0 } } slotty new set-slots ] must-fail
 
+TUPLE: slotty2 { a integer } { b number } c ;
+
+{ T{ slotty2 } } [ H{ } slotty2 from-slots ] unit-test
+{ T{ slotty2 f 1 2 f } } [ H{ { "a" 1 } { "b" 2 } } slotty2 from-slots ] unit-test
+[ H{ { "a" 1 } { "b" "two" } } slotty2 from-slots ] must-fail
+[ H{ { "d" 0 } } slotty2 new set-slots ] must-fail
+
 TUPLE: predicate-test ;
 
 C: <predicate-test> predicate-test

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 666dd40864764cb2514a72017102091d92e0c8c3..4b329e2efa10b2923e1a60cd31e3e3fdf21506dc 100644 (file)
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -40,7 +40,10 @@ ERROR: no-slot name tuple ;
     [ nip ] [ offset-of-slot ] 2bi slot ;
 
 : set-slot-named ( value name tuple -- )
-    [ nip ] [ offset-of-slot ] 2bi set-slot ;
+    [ nip ] [
+        2dup class-of all-slots slot-named
+        [ 2nip pick over check-slot-value offset>> ] [ no-slot ] if*
+    ] 2bi set-slot ;
 
 : set-slots ( assoc tuple -- )
     [ swapd set-slot-named ] curry assoc-each ; inline
@@ -76,12 +79,7 @@ M: tuple class-of layout-of 2 slot { word } declare ; inline
     [ array-nth ] curry map ;
 
 : check-slots ( seq class -- seq class )
-    [ ] [
-        2dup all-slots [
-            class>> 2dup instance?
-            [ 2drop ] [ bad-slot-value ] if
-        ] 2each
-    ] if-bootstrapping ; inline
+    [ ] [ 2dup all-slots [ check-slot-value ] 2each ] if-bootstrapping ; inline
 
 : pad-slots ( seq class -- seq' class )
     [ all-slots ] keep 2over 2length 2dup > [