! 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 ;
[ 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
-! 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 ;