1 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.parser arrays assocs classes classes.tuple
4 effects.parser fry generalizations sequences.generalizations
5 generic.standard kernel lexer locals macros parser sequences
6 sets slots vocabs words ;
11 : initializer-name ( class -- word )
12 name>> "initialize-" prepend ;
14 : lookup-initializer ( class -- word/f )
15 initializer-name "initializers" lookup ;
17 : initializer-word ( class -- word )
19 "initializers" create-vocab create
20 [ t "initializer" set-word-prop ] [ ] bi ;
22 : define-initializer-generic ( name -- )
23 initializer-word (( object -- object )) define-simple-generic ;
25 : define-initializer ( class def -- )
26 [ drop define-initializer-generic ]
27 [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
29 : all-slots-assoc ( class -- slots )
30 superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
32 MACRO:: slots>constructor ( class slots -- quot )
33 class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
34 class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
38 _ narray slot-assoc swap zip
39 default-params swap assoc-union values _ firstn class boa
42 ERROR: repeated-constructor-parameters class effect ;
44 ERROR: unknown-constructor-parameters class effect unknown ;
46 : ensure-constructor-parameters ( class effect -- class effect )
47 dup in>> all-unique? [ repeated-constructor-parameters ] unless
48 2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
49 [ unknown-constructor-parameters ] unless-empty ;
51 :: (define-constructor) ( constructor-word class effect def -- word quot )
53 class def define-initializer
54 class effect in>> '[ _ _ slots>constructor ] ;
56 :: define-constructor ( constructor-word class effect def reverse? -- )
57 constructor-word class effect def (define-constructor)
58 class superclasses [ lookup-initializer ] map sift
59 reverse? [ reverse ] when
60 '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
62 : scan-constructor ( -- word class )
63 scan-word [ name>> "<" ">" surround create-function ] keep ;
65 : parse-constructor ( -- class word effect def )
66 scan-constructor complete-effect ensure-constructor-parameters
69 SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
71 "initializers" create-vocab drop