use initial values in constructors when approriate

diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor
index af1a879ee39aa7d8308ff63cfadfb3903e4f3496..271e173718cf9e96a7055291611f2fd505c1fb7d 100644 (file)
--- a/basis/constructors/constructors-tests.factor
+++ b/basis/constructors/constructors-tests.factor
@@ -20,7 +20,6 @@ SYMBOL: AAPL
     } 1&&
 ] unit-test
 
-
 TUPLE: ct1 a ;
 TUPLE: ct2 < ct1 b ;
 TUPLE: ct3 < ct2 c ;
@@ -41,7 +40,20 @@ CONSTRUCTOR: ct4 ( a b c d -- obj )
     initialize-ct3
     [ 1 + ] change-a ;
 
-[ 1 ] [ 0 <ct1> a>> ] unit-test
+[ 1001 ] [ 1000 <ct1> a>> ] unit-test
 [ 2 ] [ 0 0 <ct2> a>> ] unit-test
 [ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
 [ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+
+
+TUPLE: rofl a b c ;
+CONSTRUCTOR: rofl ( b c a  -- obj ) ;
+
+[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
+
+
+TUPLE: default { a integer initial: 0 } ;
+
+CONSTRUCTOR: default ( -- obj ) ;
+
+[ 0 ] [ <default> a>> ] unit-test

diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor
index b08ac0cda3fcf7795fd614a5b0e7d899123ae096..c2a7d828c9634083569f6303a1b22fc5f66a0844 100644 (file)
--- a/basis/constructors/constructors.factor
+++ b/basis/constructors/constructors.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: slots kernel sequences fry accessors parser lexer words
-effects.parser macros generalizations locals classes.tuple
-vocabs generic.standard ;
+USING: accessors assocs classes.tuple effects.parser fry
+generalizations generic.standard kernel lexer locals macros
+parser sequences slots vocabs words ;
 IN: constructors
 
 ! An experiment
@@ -26,14 +26,13 @@ IN: constructors
     [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
 
 MACRO:: slots>constructor ( class slots -- quot )
-    slots class
-    all-slots [ name>> ] map
-    [ '[ _ = ] find drop ] with map
-    [ [ ] count ] [ ] [ length ] tri
+    class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
+    slots length
+    params length
     '[
-        _ narray _
-        [ swap over [ nth ] [ drop ] if ] with map
-        _ firstn class boa
+        _ narray slots swap zip 
+        params swap assoc-union
+        values _ firstn class boa
     ] ;
 
 :: define-constructor ( constructor-word class effect def -- )