From 98979fc51cfc7cb8578dbbef9b0be5c04bf4f67f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Oct 2011 22:49:10 -0700 Subject: [PATCH] Remove initializers from extra/constructors, add C:-like form that requires a stack effect --- extra/constructors/constructors-tests.factor | 67 +++++++++++++---- extra/constructors/constructors.factor | 78 ++++++++++---------- 2 files changed, 91 insertions(+), 54 deletions(-) diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor index 0ad83a6c5f..36419d60ee 100644 --- a/extra/constructors/constructors-tests.factor +++ b/extra/constructors/constructors-tests.factor @@ -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 a>> ] unit-test -[ 2 ] [ 0 0 a>> ] unit-test -[ 3 ] [ 0 0 0 a>> ] unit-test -[ 4 ] [ 0 0 0 0 a>> ] unit-test +[ 1000 ] [ 1000 a>> ] unit-test +[ 0 ] [ 0 0 a>> ] unit-test +[ 0 ] [ 0 0 0 a>> ] unit-test +[ 0 ] [ 0 0 0 0 a>> ] unit-test + +NAMED-CONSTRUCTOR: ct1 ( a -- obj ) + +NAMED-CONSTRUCTOR: ct2 ( a b -- obj ) + +NAMED-CONSTRUCTOR: ct3 ( a b c -- obj ) + +NAMED-CONSTRUCTOR: ct4 ( a b c d -- obj ) + +[ 1000 ] [ 1000 a>> ] unit-test +[ 0 ] [ 0 0 a>> ] unit-test +[ 0 ] [ 0 0 0 a>> ] unit-test +[ 0 ] [ 0 0 0 0 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 +>> + +: ( name hp max-hp -- obj ) + 2dup + + a-monster( name hp max-hp computed ) ; + +: ( name hp max-hp -- obj ) + 2dup + + { "name" "hp" "max-hp" "computed" } \ b-monster slots>boa ; + +[ 20 ] [ "Norm" 10 10 computed>> ] unit-test +[ 18 ] [ "Norm" 10 10 stop>> ] unit-test + +[ 22 ] [ "Phil" 11 11 computed>> ] unit-test +[ 18 ] [ "Phil" 11 11 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 diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor index cd5e3566d4..ae810dc328 100644 --- a/extra/constructors/constructors.factor +++ b/extra/constructors/constructors.factor @@ -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" } ; + +: 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