Remove initializers from extra/constructors, add C:-like form that requires a stack effect
Doug Coleman
parent
f21fee3b73
commit
98979fc51c
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors calendar combinators.short-circuit
|
||||
constructors eval initializers kernel math tools.test ;
|
||||
constructors eval kernel math strings tools.test ;
|
||||
IN: constructors.tests
|
||||
|
||||
TUPLE: stock-spread stock spread timestamp ;
|
||||
|
|
@ -25,28 +25,65 @@ TUPLE: ct2 < ct1 b ;
|
|||
TUPLE: ct3 < ct2 c ;
|
||||
TUPLE: ct4 < ct3 d ;
|
||||
|
||||
CONSTRUCTOR: ct1 ( a -- obj )
|
||||
[ 1 + ] change-a ;
|
||||
DEFAULT-CONSTRUCTOR: ct1 ( a -- obj )
|
||||
|
||||
CONSTRUCTOR: ct2 ( a b -- obj )
|
||||
[ 1 + ] change-a ;
|
||||
DEFAULT-CONSTRUCTOR: ct2 ( a b -- obj )
|
||||
|
||||
CONSTRUCTOR: ct3 ( a b c -- obj )
|
||||
[ 1 + ] change-a ;
|
||||
DEFAULT-CONSTRUCTOR: ct3 ( a b c -- obj )
|
||||
|
||||
CONSTRUCTOR: ct4 ( a b c d -- obj )
|
||||
[ 1 + ] change-a ;
|
||||
DEFAULT-CONSTRUCTOR: ct4 ( a b c d -- obj )
|
||||
|
||||
[ 1001 ] [ 1000 <ct1> a>> ] unit-test
|
||||
[ 2 ] [ 0 0 <ct2> a>> ] unit-test
|
||||
[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
|
||||
[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
|
||||
[ 1000 ] [ 1000 <ct1> a>> ] unit-test
|
||||
[ 0 ] [ 0 0 <ct2> a>> ] unit-test
|
||||
[ 0 ] [ 0 0 0 <ct3> a>> ] unit-test
|
||||
[ 0 ] [ 0 0 0 0 <ct4> a>> ] unit-test
|
||||
|
||||
NAMED-CONSTRUCTOR: <ct1!> ct1 ( a -- obj )
|
||||
|
||||
NAMED-CONSTRUCTOR: <ct2!> ct2 ( a b -- obj )
|
||||
|
||||
NAMED-CONSTRUCTOR: <ct3!> ct3 ( a b c -- obj )
|
||||
|
||||
NAMED-CONSTRUCTOR: <ct4!> ct4 ( a b c d -- obj )
|
||||
|
||||
[ 1000 ] [ 1000 <ct1!> a>> ] unit-test
|
||||
[ 0 ] [ 0 0 <ct2!> a>> ] unit-test
|
||||
[ 0 ] [ 0 0 0 <ct3!> a>> ] unit-test
|
||||
[ 0 ] [ 0 0 0 0 <ct4!> a>> ] unit-test
|
||||
|
||||
TUPLE: monster
|
||||
{ name string read-only } { hp integer } { max-hp integer read-only }
|
||||
{ computed integer read-only }
|
||||
lots of extra slots that make me not want to use boa, maybe they get set later
|
||||
{ stop initial: 18 } ;
|
||||
|
||||
TUPLE: a-monster < monster ;
|
||||
|
||||
TUPLE: b-monster < monster ;
|
||||
|
||||
<<
|
||||
CONSTRUCTOR-SYNTAX: a-monster
|
||||
>>
|
||||
|
||||
: <a-monster> ( name hp max-hp -- obj )
|
||||
2dup +
|
||||
a-monster( name hp max-hp computed ) ;
|
||||
|
||||
: <b-monster> ( name hp max-hp -- obj )
|
||||
2dup +
|
||||
{ "name" "hp" "max-hp" "computed" } \ b-monster slots>boa ;
|
||||
|
||||
[ 20 ] [ "Norm" 10 10 <a-monster> computed>> ] unit-test
|
||||
[ 18 ] [ "Norm" 10 10 <a-monster> stop>> ] unit-test
|
||||
|
||||
[ 22 ] [ "Phil" 11 11 <b-monster> computed>> ] unit-test
|
||||
[ 18 ] [ "Phil" 11 11 <b-monster> stop>> ] unit-test
|
||||
|
||||
[
|
||||
"""USE: constructors
|
||||
IN: constructors.tests
|
||||
TUPLE: foo a b ;
|
||||
CONSTRUCTOR: foo ( a a -- obj ) ;""" eval( -- )
|
||||
DEFAULT-CONSTRUCTOR: foo ( a a -- obj )""" eval( -- )
|
||||
] [
|
||||
error>> repeated-constructor-parameters?
|
||||
] must-fail-with
|
||||
|
|
@ -55,7 +92,7 @@ CONSTRUCTOR: foo ( a a -- obj ) ;""" eval( -- )
|
|||
"""USE: constructors
|
||||
IN: constructors.tests
|
||||
TUPLE: foo a b ;
|
||||
CONSTRUCTOR: foo ( a c -- obj ) ;""" eval( -- )
|
||||
DEFAULT-CONSTRUCTOR: foo ( a c -- obj )""" eval( -- )
|
||||
] [
|
||||
error>> unknown-constructor-parameters?
|
||||
] must-fail-with
|
||||
|
|
|
|||
|
|
@ -1,35 +1,17 @@
|
|||
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.parser arrays assocs classes classes.tuple
|
||||
effects.parser fry generalizations sequences.generalizations
|
||||
generic.standard kernel lexer locals macros parser sequences
|
||||
sets slots vocabs words ;
|
||||
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
|
||||
|
||||
! 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 ;
|
||||
superclasses [
|
||||
[ "slots" word-prop ] keep '[ _ ] { } map>assoc
|
||||
] map concat ;
|
||||
|
||||
MACRO:: slots>constructor ( class slots -- quot )
|
||||
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
|
||||
|
|
@ -48,24 +30,42 @@ ERROR: unknown-constructor-parameters class effect unknown ;
|
|||
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 ] ;
|
||||
: constructor-boa-quot ( constructor-word class effect -- word quot )
|
||||
in>> swap '[ _ _ slots>boa ] ; inline
|
||||
|
||||
:: 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 ;
|
||||
: 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 ( -- class word effect def )
|
||||
scan-constructor complete-effect ensure-constructor-parameters
|
||||
: parse-constructor ( -- word class effect def )
|
||||
scan-constructor scan-effect ensure-constructor-parameters
|
||||
parse-definition ;
|
||||
|
||||
SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
|
||||
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 ;
|
||||
|
||||
"initializers" create-vocab drop
|
||||
|
|
|
|||
Loading…
Reference in New Issue