From 1598255151dd3ea4bb39ddd677da03750b886eb1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 14:19:36 -0600
Subject: [PATCH] Add Eduardo-style setters

---
 extra/new-slots/new-slots.factor | 24 ++++++++++++++++++++----
 1 file changed, 20 insertions(+), 4 deletions(-)

diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor
index 0f411f3e88..4edd4239fa 100755
--- a/extra/new-slots/new-slots.factor
+++ b/extra/new-slots/new-slots.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: effects words kernel sequences slots slots.private
-assocs parser mirrors namespaces math vocabs ;
+assocs parser mirrors namespaces math vocabs tuples ;
 IN: new-slots
 
 : create-accessor ( name effect -- word )
@@ -19,11 +19,21 @@ IN: new-slots
 : writer-effect T{ effect f { "value" "object" } { } } ; inline
 
 : writer-word ( name -- word )
-    ">>" swap append writer-effect create-accessor ;
+    "(>>" swap ")" 3append writer-effect create-accessor ;
 
 : define-writer ( class slot name -- )
     writer-word [ set-slot ] define-slot-word ;
 
+: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
+
+: setter-word ( name -- word )
+    ">>" swap append setter-effect create-accessor ;
+
+: define-setter ( name -- )
+    dup setter-word dup deferred? [
+        [ \ over , swap writer-word , ] [ ] make define-inline
+    ] [ 2drop ] if ;
+
 : changer-effect T{ effect f { "object" "quot" } } ; inline
 
 : changer-word ( name -- word )
@@ -40,12 +50,18 @@ IN: new-slots
     ] [ 2drop ] if ;
 
 : define-new-slot ( class slot name -- )
-    dup define-changer 3dup define-reader define-writer ;
+    dup define-changer
+    dup define-setter
+    3dup define-reader
+    define-writer ;
 
 : define-new-slots ( tuple-class -- )
     [ "slot-names" word-prop <enum> >alist ] keep
     [ swap first2 >r 4 + r> define-new-slot ] curry each ;
 
-: NEW-SLOTS: scan-word define-new-slots ; parsing
+: TUPLE:
+    CREATE-CLASS
+    dup ";" parse-tokens define-tuple-class
+    define-new-slots ; parsing
 
 "accessors" create-vocab drop