From c21076562e1c2ca2a68d2d569980190994c7ece4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 4 Jun 2009 10:17:09 -0500
Subject: [PATCH] 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 | 30 ++++++++++-
 basis/constructors/constructors.factor       | 52 +++++++++++++++-----
 2 files changed, 69 insertions(+), 13 deletions(-)

diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor
index 367f0ad143..af1a879ee3 100644
--- a/basis/constructors/constructors-tests.factor
+++ b/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 ;
@@ -18,4 +18,30 @@ SYMBOL: AAPL
         [ spread>> 1234 = ]
         [ timestamp>> timestamp? ]
     } 1&&
-] unit-test
\ No newline at end of file
+] 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
diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor
index 7a98cd5e0a..b08ac0cda3 100644
--- a/basis/constructors/constructors.factor
+++ b/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 )
-    <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+: initializer-name ( class -- word )
+    name>> "initialize-" prepend ;
 
-: construct ( ... class slots -- instance )
-    [ new ] dip set-slots ; inline
+: lookup-initializer ( class -- word/f )
+    initializer-name "initializers" lookup ;
 
-: define-constructor ( name class effect body -- )
-    [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
-    define-declared ;
+: initializer-word ( class -- word )
+    initializer-name
+    "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 ;
\ No newline at end of file
+    define-constructor ;