From d0dc6ba8af5e1bc282098c39933547fd9af7feb6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 16 Jan 2010 19:29:19 +1300
Subject: [PATCH] slots, classes.tuple: make 'integer'-declared slots call
 >integer on the new value before storing it in, and remove code duplication
 between type checks in writer methods and boa constructors

---
 core/classes/tuple/tuple-tests.factor | 29 +++++++++++++++--
 core/classes/tuple/tuple.factor       | 21 +-----------
 core/slots/slots.factor               | 46 +++++++++++----------------
 3 files changed, 45 insertions(+), 51 deletions(-)

diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index eb033edfe4..710a011aa4 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -6,7 +6,7 @@ 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 ;
+vectors vocabs words words.symbol fry literals ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -577,8 +577,31 @@ unit-test
 [ T{ bad-slot-value f "hi" fixnum } = ]
 must-fail-with
 
-[ T{ declared-types f 0 "hi" } ]
-[ 0.0 "hi" declared-types boa ] unit-test
+! Check fixnum coercer
+[ 0 ] [ 0.0 "hi" declared-types boa n>> ] unit-test
+
+[ 0 ] [ declared-types new 0.0 >>n n>> ] unit-test
+
+! Check bignum coercer
+TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
+
+[ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class ] unit-test
+
+[ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class ] unit-test
+
+! Check float coercer
+TUPLE: float-coercer { n float } ;
+
+[ 13.0 float ] [ 13 float-coercer boa n>> dup class ] unit-test
+
+[ 13.0 float ] [ float-coercer new 13 >>n n>> dup class ] unit-test
+
+! Check integer coercer
+TUPLE: integer-coercer { n integer } ;
+
+[ 13 fixnum ] [ 13.5 integer-coercer boa n>> dup class ] unit-test
+
+[ 13 fixnum ] [ integer-coercer new 13.5 >>n n>> dup class ] unit-test
 
 : foo ( a b -- c ) declared-types boa ;
 
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index d5c8b4dcff..d5ae145203 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions hashtables kernel kernel.private math
 namespaces make sequences sequences.private strings vectors
@@ -121,25 +121,6 @@ ERROR: bad-superclass class ;
 : class-size ( class -- n )
     superclasses [ "slots" word-prop length ] map-sum ;
 
-: (instance-check-quot) ( class -- quot )
-    [
-        \ dup ,
-        [ "predicate" word-prop % ]
-        [ [ literalize , \ bad-slot-value , ] [ ] make , ] bi
-        \ unless ,
-    ] [ ] make ;
-
-: (fixnum-check-quot) ( class -- quot )
-    (instance-check-quot) fixnum "coercer" word-prop prepend ;
-
-: instance-check-quot ( class -- quot )
-    {
-        { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
-        { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
-        { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
-        [ (instance-check-quot) ]
-    } cond ;
-
 : boa-check-quot ( class -- quot )
     all-slots [ class>> instance-check-quot ] map spread>quot
     f like ;
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 0422478884..7b97748249 100644
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays byte-arrays kernel kernel.private math namespaces
 make sequences strings effects generic generic.standard
@@ -64,39 +64,29 @@ M: object reader-quot
 
 ERROR: bad-slot-value value class ;
 
-: writer-quot/object ( slot-spec -- )
-    offset>> , \ set-slot , ;
-
-: writer-quot/coerce ( slot-spec -- )
-    [ class>> "coercer" word-prop [ dip ] curry % ]
-    [ offset>> , \ set-slot , ]
-    bi ;
-
-: writer-quot/check ( slot-spec -- )
-    [ offset>> , ]
+: (instance-check-quot) ( class -- quot )
     [
-        \ pick ,
-        dup class>> "predicate" word-prop %
-        [ set-slot ] ,
-        class>> [ 2nip bad-slot-value ] curry [ ] like ,
-        \ if ,
-    ]
-    bi ;
+        \ dup ,
+        [ "predicate" word-prop % ]
+        [ [ bad-slot-value ] curry , ] bi
+        \ unless ,
+    ] [ ] make ;
 
-: writer-quot/fixnum ( slot-spec -- )
-    [ [ >fixnum ] dip ] % writer-quot/check ;
+: instance-check-quot ( class -- quot )
+    {
+        { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
+        { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+        { [ dup integer bootstrap-word eq? ] [ drop [ >integer ] ] }
+        [ (instance-check-quot) ]
+    } cond ;
 
 GENERIC# writer-quot 1 ( class slot-spec -- quot )
 
 M: object writer-quot
-    nip [
-        {
-            { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
-            { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
-            { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] }
-            [ writer-quot/check ]
-        } cond
-    ] [ ] make ;
+    nip
+    [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
+    [ offset>> [ set-slot ] curry ]
+    bi append ;
 
 : writer-props ( slot-spec -- assoc )
     "writing" associate ;