From 4cece22c436a667465f699f5829f274e99f8dc12 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 10 Oct 2011 18:24:35 -0700
Subject: [PATCH] Add copy-slots{ word to slots.syntax. Alias slots{ to get{
 and set-slots{ to set{, same for slots[ and set-slots[.

---
 extra/slots/syntax/syntax-docs.factor  | 18 ++++++++++++++----
 extra/slots/syntax/syntax-tests.factor | 21 +++++++++++++--------
 extra/slots/syntax/syntax.factor       | 21 ++++++++++++++++++---
 3 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/extra/slots/syntax/syntax-docs.factor b/extra/slots/syntax/syntax-docs.factor
index 6e201eac77..0845751ce9 100755
--- a/extra/slots/syntax/syntax-docs.factor
+++ b/extra/slots/syntax/syntax-docs.factor
@@ -40,15 +40,25 @@ HELP: set-slots[
            "T{ rectangle { width 3 } { height 5 } }"
 } ;
 
+HELP: copy-slots{
+{ $description "Copy slots from the first object to the second and return the second object." }
+{ $example "USING: prettyprint slots.syntax kernel ;"
+           "IN: slots.syntax.example"
+           "TUPLE: thing1 a b ;"
+           "TUPLE: thing2 a b c ;"
+           "1 2 thing1 boa 11 22 33 thing2 boa copy-slots{ a b } ."
+           "T{ thing2 f 1 2 33 }"
+} ;
+
 ARTICLE: "slots.syntax" "Slots syntax sugar"
 "The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for getting and setting multiple values of a tuple." $nl
 "Syntax sugar for cleaving slots to the stack:"
-{ $subsections POSTPONE: slots[ }
+{ $subsections POSTPONE: slots[ POSTPONE: get[ }
 "Cleaving slots to an array:"
-{ $subsections POSTPONE: slots{ }
+{ $subsections POSTPONE: slots{ POSTPONE: get{ }
 "Setting slots from the stack:"
-{ $subsections POSTPONE: set-slots[ }
+{ $subsections POSTPONE: set-slots[ POSTPONE: set[ }
 "Setting slots from an array:"
-{ $subsections POSTPONE: set-slots{ } ;
+{ $subsections POSTPONE: set-slots{ POSTPONE: set{ } ;
 
 ABOUT: "slots.syntax"
diff --git a/extra/slots/syntax/syntax-tests.factor b/extra/slots/syntax/syntax-tests.factor
index e4dac6e4a4..01335f54d1 100755
--- a/extra/slots/syntax/syntax-tests.factor
+++ b/extra/slots/syntax/syntax-tests.factor
@@ -1,14 +1,19 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test slots.syntax ;
+USING: kernel tools.test slots.syntax ;
 IN: slots.syntax.tests
 
-TUPLE: slot-test a b c ;
+TUPLE: slot-test1 a b c ;
 
-[ 1 2 3 ] [ T{ slot-test f 1 2 3 } slots[ a b c ] ] unit-test
-[ 3 ] [ T{ slot-test f 1 2 3 } slots[ c ] ] unit-test
-[ ] [ T{ slot-test f 1 2 3 } slots[ ] ] unit-test
+[ 1 2 3 ] [ T{ slot-test1 f 1 2 3 } slots[ a b c ] ] unit-test
+[ 3 ] [ T{ slot-test1 f 1 2 3 } slots[ c ] ] unit-test
+[ ] [ T{ slot-test1 f 1 2 3 } slots[ ] ] unit-test
 
-[ { 1 2 3 } ] [ T{ slot-test f 1 2 3 } slots{ a b c } ] unit-test
-[ { 3 } ] [ T{ slot-test f 1 2 3 } slots{ c } ] unit-test
-[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test
+[ { 1 2 3 } ] [ T{ slot-test1 f 1 2 3 } slots{ a b c } ] unit-test
+[ { 3 } ] [ T{ slot-test1 f 1 2 3 } slots{ c } ] unit-test
+[ { } ] [ T{ slot-test1 f 1 2 3 } slots{ } ] unit-test
+
+TUPLE: slot-test2 a b c d ;
+
+[ T{ slot-test2 f 1 2 33 44 } ]
+[ 1 2 3 slot-test1 boa 11 22 33 44 slot-test2 boa copy-slots{ a b } ] unit-test
diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor
index ef572910d8..cda8d402e6 100755
--- a/extra/slots/syntax/syntax.factor
+++ b/extra/slots/syntax/syntax.factor
@@ -12,14 +12,29 @@ SYNTAX: slots{
     "}" [ reader-word 1quotation ] map-tokens
     '[ [ _ cleave ] output>array ] append! ;
 
-: writer-word* ( name -- word )
+: >>writer-word ( name -- word )
+    ">>" prepend "accessors" lookup ;
+    
+: writer-word<< ( name -- word )
     ">>" prepend "accessors" lookup ;
 
 SYNTAX: set-slots[
-    "]" [ writer-word* 1quotation ] map-tokens
+    "]" [ >>writer-word 1quotation ] map-tokens
     '[ _ spread ] append! ;
 
 SYNTAX: set-slots{
-    "}" [ writer-word* 1quotation ] map-tokens
+    "}" [ >>writer-word 1quotation ] map-tokens
     [ length ] [ ] bi
     '[ _ firstn _ spread ] append! ;
+
+SYNTAX: copy-slots{
+    "}" [
+        [ reader-word 1quotation ]
+        [ writer-word<< 1quotation ] bi append
+    ] map-tokens
+    '[ swap _ cleave ] append! ;
+    
+SYNTAX: get[ POSTPONE: slots[ ;
+SYNTAX: get{ POSTPONE: slots{ ;
+SYNTAX: set[ POSTPONE: set-slots[ ;
+SYNTAX: set{ POSTPONE: set-slots{ ;
-- 
2.34.1