constructor foo now creates an initialize-foo word in the initializers vocabualary. <foo> is instantiated with boa constructors now, so constructors handle read-only slots

basis/constructors/constructors-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
+combinators.short-circuit initializers math ;
 IN: constructors.tests
 
 TUPLE: stock-spread stock spread timestamp ;
@@ -19,3 +19,29 @@ SYMBOL: AAPL
         [ timestamp>> timestamp? ]
     } 1&&
 ] unit-test
+
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: ct1 ( a -- obj )
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct2 ( a b -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct3 ( a b c -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct4 ( a b c d -- obj )
+    initialize-ct3
+    [ 1 + ] change-a ;
+
+[ 1 ] [ 0 <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

basis/constructors/constructors.factor

@@ -1,23 +1,53 @@
-! Copyright (C) 2009 Slava Pestov.
+! 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 ;
+effects.parser macros generalizations locals classes.tuple
+vocabs generic.standard ;
 IN: constructors
 
 ! An experiment
 
-MACRO: set-slots ( slots -- quot )
+: initializer-name ( class -- word )
-    <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+    name>> "initialize-" prepend ;
 
-: construct ( ... class slots -- instance )
+: lookup-initializer ( class -- word/f )
-    [ new ] dip set-slots ; inline
+    initializer-name "initializers" lookup ;
 
-: define-constructor ( name class effect body -- )
+: initializer-word ( class -- word )
-    [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
+    initializer-name
-    define-declared ;
+    "initializers" create-vocab create
+    [ t "initializer" set-word-prop ] [ ] bi ;
+
+: define-initializer-generic ( name -- )
+    initializer-word (( object -- object )) define-simple-generic ;
+
+: define-initializer ( class def -- )
+    [ drop define-initializer-generic ]
+    [ [ 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
+    '[
+        _ narray _
+        [ swap over [ nth ] [ drop ] if ] with map
+        _ firstn class boa
+    ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+    constructor-word
+    class def define-initializer
+    class effect in>> '[ _ _ slots>constructor ]
+    class lookup-initializer
+    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+    scan-word [ name>> "<" ">" surround create-in ] keep ;
 
 SYNTAX: CONSTRUCTOR:
-    scan-word [ name>> "<" ">" surround create-in ] keep
+    scan-constructor
     complete-effect
     parse-definition
     define-constructor ;