1 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs classes classes.tuple effects.parser
4 fry generalizations generic.standard kernel lexer locals macros
5 parser sequences slots vocabs words ;
10 : initializer-name ( class -- word )
11 name>> "initialize-" prepend ;
13 : lookup-initializer ( class -- word/f )
14 initializer-name "initializers" lookup ;
16 : initializer-word ( class -- word )
18 "initializers" create-vocab create
19 [ t "initializer" set-word-prop ] [ ] bi ;
21 : define-initializer-generic ( name -- )
22 initializer-word (( object -- object )) define-simple-generic ;
24 : define-initializer ( class def -- )
25 [ drop define-initializer-generic ]
26 [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
28 MACRO:: slots>constructor ( class slots -- quot )
29 class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
33 _ narray slots swap zip
34 params swap assoc-union
35 values _ firstn class boa
38 :: (define-constructor) ( constructor-word class effect def -- word quot )
40 class def define-initializer
41 class effect in>> '[ _ _ slots>constructor ] ;
43 :: define-constructor ( constructor-word class effect def -- )
44 constructor-word class effect def (define-constructor)
45 class lookup-initializer
46 '[ @ _ execute( obj -- obj ) ] effect define-declared ;
48 :: define-auto-constructor ( constructor-word class effect def -- )
49 constructor-word class effect def (define-constructor)
50 class superclasses [ lookup-initializer ] map sift
51 '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
53 : scan-constructor ( -- class word )
54 scan-word [ name>> "<" ">" surround create-in ] keep ;
56 : parse-constructor ( -- class word effect def )
57 scan-constructor complete-effect parse-definition ;
59 SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
61 SYNTAX: AUTO-CONSTRUCTOR: parse-constructor define-auto-constructor ;
63 "initializers" create-vocab drop