extra: moving constructors to basis.

diff --git a/basis/constructors/authors.txt b/basis/constructors/authors.txt
new file mode 100644 (file)
index 0000000..1901f27
--- /dev/null
+++ b/basis/constructors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov

diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor
new file mode 100644 (file)
index 0000000..59c84e4
--- /dev/null
+++ b/basis/constructors/constructors-tests.factor
@@ -0,0 +1,86 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar combinators.short-circuit
+constructors eval kernel math strings tools.test ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: <stock-spread> stock-spread ( stock spread -- stock-spread )
+   now >>timestamp ;
+
+SYMBOL: AAPL
+
+{ t } [
+    AAPL 1234 <stock-spread>
+    {
+        [ stock>> AAPL eq? ]
+        [ spread>> 1234 = ]
+        [ timestamp>> timestamp? ]
+    } 1&&
+] unit-test
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: <ct1> ct1 ( a -- obj ) ;
+
+CONSTRUCTOR: <ct2> ct2 ( a b -- obj ) ;
+
+CONSTRUCTOR: <ct3> ct3 ( a b c -- obj ) ;
+
+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 ;
+
+<<
+SLOT-CONSTRUCTOR: 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> foo ( a a -- obj )" eval( -- )
+] [
+    error>> repeated-constructor-parameters?
+] must-fail-with
+
+[
+    "USE: constructors
+IN: constructors.tests
+TUPLE: foo a b ;
+CONSTRUCTOR: <foo> foo ( a c -- obj )" eval( -- )
+] [
+    error>> unknown-constructor-parameters?
+] must-fail-with

diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor
new file mode 100644 (file)
index 0000000..49d9d50
--- /dev/null
+++ b/basis/constructors/constructors.factor
@@ -0,0 +1,64 @@
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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
+
+: all-slots-assoc ( class -- slots )
+    superclasses-of [
+        [ "slots" word-prop ] keep '[ _ ] { } map>assoc
+    ] map concat ;
+
+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
+    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 ;
+
+: constructor-boa-quot ( constructor-word class effect -- word quot )
+    in>> swap '[ _ _ slots>boa ] ; inline
+
+: define-constructor ( constructor-word class effect -- )
+    ensure-constructor-parameters
+    [ constructor-boa-quot ] keep define-declared ;
+
+: create-reset ( string -- word )
+    create-word-in dup reset-generic ;
+
+: scan-constructor ( -- word class )
+    scan-new-word scan-class ;
+
+: parse-constructor ( -- word class effect def )
+    scan-constructor scan-effect ensure-constructor-parameters
+    parse-definition ;
+
+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: SLOT-CONSTRUCTOR:
+    scan-new-word [ name>> "(" append create-reset ] keep
+    '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;

diff --git a/basis/constructors/summary.txt b/basis/constructors/summary.txt
new file mode 100644 (file)
index 0000000..6f135bd
--- /dev/null
+++ b/basis/constructors/summary.txt
@@ -0,0 +1 @@
+Utility to simplify tuple constructors

diff --git a/basis/constructors/tags.txt b/basis/constructors/tags.txt
new file mode 100644 (file)
index 0000000..f427429
--- /dev/null
+++ b/basis/constructors/tags.txt
@@ -0,0 +1 @@
+extensions

diff --git a/extra/constructors/authors.txt b/extra/constructors/authors.txt
deleted file mode 100644 (file)
index 1901f27..0000000
--- a/extra/constructors/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov

diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor
deleted file mode 100644 (file)
index 59c84e4..0000000
--- a/extra/constructors/constructors-tests.factor
+++ /dev/null
@@ -1,86 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar combinators.short-circuit
-constructors eval kernel math strings tools.test ;
-IN: constructors.tests
-
-TUPLE: stock-spread stock spread timestamp ;
-
-CONSTRUCTOR: <stock-spread> stock-spread ( stock spread -- stock-spread )
-   now >>timestamp ;
-
-SYMBOL: AAPL
-
-{ t } [
-    AAPL 1234 <stock-spread>
-    {
-        [ stock>> AAPL eq? ]
-        [ spread>> 1234 = ]
-        [ timestamp>> timestamp? ]
-    } 1&&
-] unit-test
-
-TUPLE: ct1 a ;
-TUPLE: ct2 < ct1 b ;
-TUPLE: ct3 < ct2 c ;
-TUPLE: ct4 < ct3 d ;
-
-CONSTRUCTOR: <ct1> ct1 ( a -- obj ) ;
-
-CONSTRUCTOR: <ct2> ct2 ( a b -- obj ) ;
-
-CONSTRUCTOR: <ct3> ct3 ( a b c -- obj ) ;
-
-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 ;
-
-<<
-SLOT-CONSTRUCTOR: 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> foo ( a a -- obj )" eval( -- )
-] [
-    error>> repeated-constructor-parameters?
-] must-fail-with
-
-[
-    "USE: constructors
-IN: constructors.tests
-TUPLE: foo a b ;
-CONSTRUCTOR: <foo> foo ( a c -- obj )" eval( -- )
-] [
-    error>> unknown-constructor-parameters?
-] must-fail-with

diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor
deleted file mode 100644 (file)
index 49d9d50..0000000
--- a/extra/constructors/constructors.factor
+++ /dev/null
@@ -1,64 +0,0 @@
-! Copyright (C) 2009 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-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
-
-: all-slots-assoc ( class -- slots )
-    superclasses-of [
-        [ "slots" word-prop ] keep '[ _ ] { } map>assoc
-    ] map concat ;
-
-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
-    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 ;
-
-: constructor-boa-quot ( constructor-word class effect -- word quot )
-    in>> swap '[ _ _ slots>boa ] ; inline
-
-: define-constructor ( constructor-word class effect -- )
-    ensure-constructor-parameters
-    [ constructor-boa-quot ] keep define-declared ;
-
-: create-reset ( string -- word )
-    create-word-in dup reset-generic ;
-
-: scan-constructor ( -- word class )
-    scan-new-word scan-class ;
-
-: parse-constructor ( -- word class effect def )
-    scan-constructor scan-effect ensure-constructor-parameters
-    parse-definition ;
-
-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: SLOT-CONSTRUCTOR:
-    scan-new-word [ name>> "(" append create-reset ] keep
-    '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;

diff --git a/extra/constructors/summary.txt b/extra/constructors/summary.txt
deleted file mode 100644 (file)
index 6f135bd..0000000
--- a/extra/constructors/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Utility to simplify tuple constructors

diff --git a/extra/constructors/tags.txt b/extra/constructors/tags.txt
deleted file mode 100644 (file)
index f427429..0000000
--- a/extra/constructors/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-extensions