/extra/constructors/constructors.factor
http://github.com/abeaumont/factor · Factor · 71 lines · 52 code · 17 blank · 2 comment · 3 complexity · 54fade285425a1127f5bec6e4b6338ef MD5 · raw file
- ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
- ! See http://factorcode.org/license.txt for BSD license.
- USING: accessors assocs classes classes.tuple effects
- effects.parser fry kernel lexer locals macros parser
- sequences sequences.generalizations sets vocabs vocabs.parser
- words alien.parser ;
- IN: constructors
- : all-slots-assoc ( class -- slots )
- superclasses [
- [ "slots" word-prop ] keep '[ _ ] { } map>assoc
- ] map concat ;
- MACRO:: slots>boa ( slots class -- quot )
- class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
- class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
- slots length
- default-params length
- '[
- _ narray slot-assoc swap zip
- default-params swap assoc-union values _ firstn class boa
- ] ;
- ERROR: repeated-constructor-parameters class effect ;
- ERROR: unknown-constructor-parameters class effect unknown ;
- : ensure-constructor-parameters ( class effect -- class effect )
- dup in>> all-unique? [ repeated-constructor-parameters ] unless
- 2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
- [ unknown-constructor-parameters ] unless-empty ;
- : constructor-boa-quot ( constructor-word class effect -- word quot )
- in>> swap '[ _ _ slots>boa ] ; inline
- : define-constructor ( constructor-word class effect -- )
- ensure-constructor-parameters
- [ constructor-boa-quot ] keep define-declared ;
- : create-reset ( string -- word )
- create-in dup reset-generic ;
- : scan-constructor ( -- word class )
- scan-word [ name>> "<" ">" surround create-function ] keep ;
- : parse-constructor ( -- word class effect def )
- scan-constructor scan-effect ensure-constructor-parameters
- parse-definition ;
- SYNTAX: CONSTRUCTOR:
- parse-constructor
- [ [ constructor-boa-quot ] dip compose ]
- [ drop ] 2bi define-declared ;
- : scan-rest-input-effect ( -- effect )
- ")" parse-effect-tokens nip
- { "obj" } <effect> ;
- : scan-full-input-effect ( -- effect )
- "(" expect scan-rest-input-effect ;
- SYNTAX: NAMED-CONSTRUCTOR:
- scan-new-word scan-word scan-effect define-constructor ;
-
- SYNTAX: DEFAULT-CONSTRUCTOR:
- scan-constructor scan-effect define-constructor ;
- SYNTAX: CONSTRUCTOR-SYNTAX:
- scan-word [ name>> "(" append create-reset ] keep
- '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;