diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 55edb5f969..1676e05c76 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -460,3 +460,11 @@ HELP: get-slot-named HELP: set-slot-named { $values { "value" object } { "name" string } { "tuple" tuple } } { $description "Stores the " { $snippet "value" } " into a tuple slot accessed by " { $snippet "name" } "." } ; + +HELP: set-slots +{ $values { "assoc" assoc } { "tuple" tuple } } +{ $description "For each " { $snippet "{ key value }" } " pair in " { $snippet "assoc" } ", sets the " { $snippet "key" } " slot in " { $snippet "obj" } " to " { $snippet "value" } "." } ; + +HELP: from-slots +{ $values { "assoc" assoc } { "class" tuple-class } { "tuple" tuple } } +{ $description "Creates a new instance of " { $snippet "class" } " with slot values specified by " { $snippet "assoc" } "." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index f42ed92611..ecdd4528d9 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -59,6 +59,12 @@ TUPLE: point x y ; [ 200 ] [ "p" get y>> ] unit-test [ 300 ] [ "p" get "z>>" "accessors" lookup-word execute ] unit-test +TUPLE: slotty a b c ; + +[ T{ slotty } ] [ H{ } slotty from-slots ] unit-test +[ 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: predicate-test ; C: predicate-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index b52304e342..6c940f5c6a 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -28,6 +28,12 @@ ERROR: no-slot name tuple ; : set-slot-named ( value name tuple -- ) [ nip ] [ offset-of-slot ] 2bi set-slot ; +: set-slots ( assoc tuple -- ) + [ swapd set-slot-named ] curry assoc-each ; inline + +: from-slots ( assoc class -- tuple ) + new [ set-slots ] keep ; inline + PREDICATE: immutable-tuple-class < tuple-class all-slots [ read-only>> ] all? ;