fix constructors for shadowed slots
parent
e64acee023
commit
0d308e6a4b
|
@ -57,3 +57,11 @@ TUPLE: default { a integer initial: 0 } ;
|
||||||
CONSTRUCTOR: default ( -- obj ) ;
|
CONSTRUCTOR: default ( -- obj ) ;
|
||||||
|
|
||||||
[ 0 ] [ <default> a>> ] unit-test
|
[ 0 ] [ <default> a>> ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
TUPLE: inherit1 a ;
|
||||||
|
TUPLE: inherit2 < inherit1 a ;
|
||||||
|
|
||||||
|
CONSTRUCTOR: inherit2 ( a -- obj ) ;
|
||||||
|
|
||||||
|
[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs classes classes.tuple effects.parser
|
USING: accessors assocs classes classes.tuple effects.parser
|
||||||
fry generalizations generic.standard kernel lexer locals macros
|
fry generalizations generic.standard kernel lexer locals macros
|
||||||
parser sequences slots vocabs words ;
|
parser sequences slots vocabs words arrays ;
|
||||||
IN: constructors
|
IN: constructors
|
||||||
|
|
||||||
! An experiment
|
! An experiment
|
||||||
|
@ -25,14 +25,17 @@ IN: constructors
|
||||||
[ drop define-initializer-generic ]
|
[ drop define-initializer-generic ]
|
||||||
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
|
[ [ 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 )
|
MACRO:: slots>constructor ( class slots -- quot )
|
||||||
class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
|
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
|
slots length
|
||||||
params length
|
default-params length
|
||||||
'[
|
'[
|
||||||
_ narray slots swap zip
|
_ narray slot-assoc swap zip
|
||||||
params swap assoc-union
|
default-params swap assoc-union values _ firstn class boa
|
||||||
values _ firstn class boa
|
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
:: (define-constructor) ( constructor-word class effect def -- word quot )
|
:: (define-constructor) ( constructor-word class effect def -- word quot )
|
||||||
|
|
Loading…
Reference in New Issue