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
4 effects.parser fry kernel lexer locals macros parser
5 sequences sequences.generalizations sets vocabs vocabs.parser
9 : all-slots-assoc ( class -- slots )
11 [ "slots" word-prop ] keep '[ _ ] { } map>assoc
14 MACRO:: slots>boa ( slots class -- quot )
15 class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
16 class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
20 _ narray slot-assoc swap zip
21 default-params swap assoc-union values _ firstn class boa
24 ERROR: repeated-constructor-parameters class effect ;
26 ERROR: unknown-constructor-parameters class effect unknown ;
28 : ensure-constructor-parameters ( class effect -- class effect )
29 dup in>> all-unique? [ repeated-constructor-parameters ] unless
30 2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
31 [ unknown-constructor-parameters ] unless-empty ;
33 : constructor-boa-quot ( constructor-word class effect -- word quot )
34 in>> swap '[ _ _ slots>boa ] ; inline
36 : define-constructor ( constructor-word class effect -- )
37 ensure-constructor-parameters
38 [ constructor-boa-quot ] keep define-declared ;
40 : create-reset ( string -- word )
41 create-word-in dup reset-generic ;
43 : scan-constructor ( -- word class )
44 scan-new-word scan-class ;
46 : parse-constructor ( -- word class effect def )
47 scan-constructor scan-effect ensure-constructor-parameters
52 [ [ constructor-boa-quot ] dip compose ]
53 [ drop ] 2bi define-declared ;
55 : scan-rest-input-effect ( -- effect )
56 ")" parse-effect-tokens nip
59 : scan-full-input-effect ( -- effect )
60 "(" expect scan-rest-input-effect ;
62 SYNTAX: SLOT-CONSTRUCTOR:
63 scan-new-word [ name>> "(" append create-reset ] keep
64 '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;