72 lines
2.5 KiB
Factor
72 lines
2.5 KiB
Factor
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays assocs classes classes.tuple
|
|
effects.parser fry generalizations sequences.generalizations
|
|
generic.standard kernel lexer locals macros parser sequences
|
|
sets slots vocabs words ;
|
|
IN: constructors
|
|
|
|
! An experiment
|
|
|
|
: initializer-name ( class -- word )
|
|
name>> "initialize-" prepend ;
|
|
|
|
: lookup-initializer ( class -- word/f )
|
|
initializer-name "initializers" lookup ;
|
|
|
|
: initializer-word ( class -- word )
|
|
initializer-name
|
|
"initializers" create-vocab create
|
|
[ t "initializer" set-word-prop ] [ ] bi ;
|
|
|
|
: define-initializer-generic ( name -- )
|
|
initializer-word (( object -- object )) define-simple-generic ;
|
|
|
|
: define-initializer ( class def -- )
|
|
[ drop define-initializer-generic ]
|
|
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
|
|
|
|
: all-slots-assoc ( class -- slots )
|
|
superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
|
|
|
|
MACRO:: slots>constructor ( class slots -- 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 ;
|
|
|
|
:: (define-constructor) ( constructor-word class effect def -- word quot )
|
|
constructor-word
|
|
class def define-initializer
|
|
class effect in>> '[ _ _ slots>constructor ] ;
|
|
|
|
:: define-constructor ( constructor-word class effect def reverse? -- )
|
|
constructor-word class effect def (define-constructor)
|
|
class superclasses [ lookup-initializer ] map sift
|
|
reverse? [ reverse ] when
|
|
'[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
|
|
|
|
: scan-constructor ( -- word class )
|
|
scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ;
|
|
|
|
: parse-constructor ( -- class word effect def )
|
|
scan-constructor complete-effect ensure-constructor-parameters
|
|
parse-definition ;
|
|
|
|
SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
|
|
|
|
"initializers" create-vocab drop
|