Remove initializers from extra/constructors, add C:-like form that requires a stack effect

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 )
+DEFAULT-CONSTRUCTOR: ct1 ( a -- obj )
-    [ 1 + ] change-a ;
 
-CONSTRUCTOR: ct2 ( a b -- obj )
+DEFAULT-CONSTRUCTOR: ct2 ( a b -- obj )
-    [ 1 + ] change-a ;
 
-CONSTRUCTOR: ct3 ( a b c -- obj )
+DEFAULT-CONSTRUCTOR: ct3 ( a b c -- obj )
-    [ 1 + ] change-a ;
 
-CONSTRUCTOR: ct4 ( a b c d -- obj )
+DEFAULT-CONSTRUCTOR: ct4 ( a b c d -- obj )
-    [ 1 + ] change-a ;
 
-[ 1001 ] [ 1000 <ct1> a>> ] unit-test
+[ 1000 ] [ 1000 <ct1> a>> ] unit-test
-[ 2 ] [ 0 0 <ct2> a>> ] unit-test
+[ 0 ] [ 0 0 <ct2> a>> ] unit-test
-[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 0 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 4 ] [ 0 0 0 0 <ct4> 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

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
+USING: accessors assocs classes classes.tuple effects
-effects.parser fry generalizations sequences.generalizations
+effects.parser fry kernel lexer locals macros parser
-generic.standard kernel lexer locals macros parser sequences
+sequences sequences.generalizations sets vocabs vocabs.parser
-sets slots vocabs words ;
+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-boa-quot ( constructor-word class effect -- word quot )
-    constructor-word
+    in>> swap '[ _ _ slots>boa ] ; inline
-    class def define-initializer
-    class effect in>> '[ _ _ slots>constructor ] ;
 
-:: define-constructor ( constructor-word class effect def reverse? -- )
+: define-constructor ( constructor-word class effect -- )
-    constructor-word class effect def (define-constructor)
+    ensure-constructor-parameters
-    class superclasses [ lookup-initializer ] map sift
+    [ constructor-boa-quot ] keep define-declared ;
-    reverse? [ reverse ] when
+
-    '[ @ _ [ execute( obj -- obj ) ] each ] effect 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 )
+: parse-constructor ( -- word class effect def )
-    scan-constructor complete-effect ensure-constructor-parameters
+    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