/extra/constructors/constructors.factor

 1! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 2! See http://factorcode.org/license.txt for BSD license.
 3USING: accessors assocs classes classes.tuple effects
 4effects.parser fry kernel lexer locals macros parser
 5sequences sequences.generalizations sets vocabs vocabs.parser
 6words alien.parser ;
 7IN: constructors
 8
 9: all-slots-assoc ( class -- slots )
10    superclasses [
11        [ "slots" word-prop ] keep '[ _ ] { } map>assoc
12    ] map concat ;
13
14MACRO:: 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
17    slots length
18    default-params length
19    '[
20        _ narray slot-assoc swap zip 
21        default-params swap assoc-union values _ firstn class boa
22    ] ;
23
24ERROR: repeated-constructor-parameters class effect ;
25
26ERROR: unknown-constructor-parameters class effect unknown ;
27
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 ;
32
33: constructor-boa-quot ( constructor-word class effect -- word quot )
34    in>> swap '[ _ _ slots>boa ] ; inline
35
36: define-constructor ( constructor-word class effect -- )
37    ensure-constructor-parameters
38    [ constructor-boa-quot ] keep define-declared ;
39
40: create-reset ( string -- word )
41    create-in dup reset-generic ;
42
43: scan-constructor ( -- word class )
44    scan-word [ name>> "<" ">" surround create-function ] keep ;
45
46: parse-constructor ( -- word class effect def )
47    scan-constructor scan-effect ensure-constructor-parameters
48    parse-definition ;
49
50SYNTAX: CONSTRUCTOR:
51    parse-constructor
52    [ [ constructor-boa-quot ] dip compose ]
53    [ drop ] 2bi define-declared ;
54
55: scan-rest-input-effect ( -- effect )
56    ")" parse-effect-tokens nip
57    { "obj" } <effect> ;
58
59: scan-full-input-effect ( -- effect )
60    "(" expect scan-rest-input-effect ;
61
62SYNTAX: NAMED-CONSTRUCTOR:
63    scan-new-word scan-word scan-effect define-constructor ;
64    
65SYNTAX: DEFAULT-CONSTRUCTOR:
66    scan-constructor scan-effect define-constructor ;
67
68SYNTAX: CONSTRUCTOR-SYNTAX:
69    scan-word [ name>> "(" append create-reset ] keep
70    '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;
71