From 6688cf1c9779dce87529392f3bbdcdcabcd81baa Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 08:42:31 -0500
Subject: [PATCH 01/14] mopping up some noobsauce
---
extra/roles/roles.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor
index f9ce808eb8..d54b4339a7 100644
--- a/extra/roles/roles.factor
+++ b/extra/roles/roles.factor
@@ -8,8 +8,8 @@ IN: roles
ERROR: role-slot-overlap class slots ;
ERROR: multiple-inheritance-attempted classes ;
-PREDICATE: role < class
- { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ;
+PREDICATE: role < mixin-class
+ "role-slots" word-prop >boolean ;
: parse-role-definition ( -- class superroles slots )
CREATE-CLASS scan {
From d2e293eb5ea779d2bfbbde84b76009748ab8de6b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 09:39:38 -0500
Subject: [PATCH 02/14] product virtual sequence
---
extra/sequences/product/product-tests.factor | 24 ++++++++++-------
extra/sequences/product/product.factor | 28 ++++++++++++++++++++
2 files changed, 42 insertions(+), 10 deletions(-)
create mode 100644 extra/sequences/product/product.factor
diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor
index dfabc166ac..0a984072e0 100644
--- a/extra/sequences/product/product-tests.factor
+++ b/extra/sequences/product/product-tests.factor
@@ -1,19 +1,23 @@
-USING: arrays kernel sequences sequences.cartesian-product tools.test ;
+USING: arrays kernel make sequences sequences.product tools.test ;
IN: sequences.product.tests
-[
- { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } }
-] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test
+
+[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
+[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
+
+[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
+[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test
[
{
{ 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
{ 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
}
-] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test
-
-[
- { "012012" "aaabbb" }
-] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test
-
+] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
+[ "a1b1c1a2b2c2" ] [
+ [
+ { { "a" "b" "c" } { "1" "2" } }
+ [ [ % ] each ] product-each
+ ] "" make
+] unit-test
diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor
new file mode 100644
index 0000000000..73ba1e4e01
--- /dev/null
+++ b/extra/sequences/product/product.factor
@@ -0,0 +1,28 @@
+USING: accessors arrays kernel math sequences ;
+IN: sequences.product
+
+TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
+
+: <product-sequence> ( sequences -- product-sequence )
+ >array dup [ length ] map product-sequence boa ;
+
+INSTANCE: product-sequence sequence
+
+M: product-sequence length lengths>> product ;
+
+: ns ( n lengths -- ns )
+ [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
+
+: product@ ( n product-sequence -- ns seqs )
+ [ lengths>> ns ] [ nip sequences>> ] 2bi ;
+
+M: product-sequence nth
+ product@ [ nth ] { } 2map-as ;
+
+M: product-sequence set-nth
+ immutable ;
+
+: product-map ( sequences quot -- sequence )
+ [ <product-sequence> ] dip map ; inline
+: product-each ( sequences quot -- )
+ [ <product-sequence> ] dip each ; inline
From e0f6825757892b7226853af7d54d38c33795bb71 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 26 Apr 2009 10:02:52 -0500
Subject: [PATCH 03/14] Rename some fields to avoid conflicting with windows.h
macros 'small' and 'large'
---
vm/code_gc.c | 16 ++++++++--------
vm/code_gc.h | 4 ++--
2 files changed, 10 insertions(+), 10 deletions(-)
mode change 100644 => 100755 vm/code_gc.h
diff --git a/vm/code_gc.c b/vm/code_gc.c
index e7fcfd3289..1405daa93f 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -22,13 +22,13 @@ void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = block->block.size / BLOCK_SIZE_INCREMENT;
- block->next_free = heap->free.small[index];
- heap->free.small[index] = block;
+ block->next_free = heap->free.small_blocks[index];
+ heap->free.small_blocks[index] = block;
}
else
{
- block->next_free = heap->free.large;
- heap->free.large = block;
+ block->next_free = heap->free.large_blocks;
+ heap->free.large_blocks = block;
}
}
@@ -101,11 +101,11 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = attempt / BLOCK_SIZE_INCREMENT;
- F_FREE_BLOCK *block = heap->free.small[index];
+ F_FREE_BLOCK *block = heap->free.small_blocks[index];
if(block)
{
assert_free_block(block);
- heap->free.small[index] = block->next_free;
+ heap->free.small_blocks[index] = block->next_free;
return block;
}
@@ -113,7 +113,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
}
F_FREE_BLOCK *prev = NULL;
- F_FREE_BLOCK *block = heap->free.large;
+ F_FREE_BLOCK *block = heap->free.large_blocks;
while(block)
{
@@ -123,7 +123,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
if(prev)
prev->next_free = block->next_free;
else
- heap->free.large = block->next_free;
+ heap->free.large_blocks = block->next_free;
return block;
}
diff --git a/vm/code_gc.h b/vm/code_gc.h
old mode 100644
new mode 100755
index 9b1e768a7b..d71dee29c5
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -2,8 +2,8 @@
#define BLOCK_SIZE_INCREMENT 32
typedef struct {
- F_FREE_BLOCK *small[FREE_LIST_COUNT];
- F_FREE_BLOCK *large;
+ F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT];
+ F_FREE_BLOCK *large_blocks;
} F_HEAP_FREE_LIST;
typedef struct {
From 303ce55dc6d9ed566d05f36a995ba21200a56626 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 12:27:50 -0500
Subject: [PATCH 04/14] more efficient product-each and product-map that don't
/mod all over the place
---
extra/sequences/product/product-tests.factor | 6 ++-
extra/sequences/product/product.factor | 50 ++++++++++++++++----
2 files changed, 46 insertions(+), 10 deletions(-)
diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor
index 0a984072e0..087d7a6175 100644
--- a/extra/sequences/product/product-tests.factor
+++ b/extra/sequences/product/product-tests.factor
@@ -5,8 +5,10 @@ IN: sequences.product.tests
[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
-[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
-[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test
+: x ( n s -- sss ) <repetition> concat ;
+
+[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
+[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
[
{
diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor
index 73ba1e4e01..0c5bb88f32 100644
--- a/extra/sequences/product/product.factor
+++ b/extra/sequences/product/product.factor
@@ -1,4 +1,4 @@
-USING: accessors arrays kernel math sequences ;
+USING: accessors arrays kernel locals math sequences ;
IN: sequences.product
TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
@@ -10,19 +10,53 @@ INSTANCE: product-sequence sequence
M: product-sequence length lengths>> product ;
+<PRIVATE
+
: ns ( n lengths -- ns )
[ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
+: nths ( ns seqs -- nths )
+ [ nth ] { } 2map-as ;
+
: product@ ( n product-sequence -- ns seqs )
[ lengths>> ns ] [ nip sequences>> ] 2bi ;
+:: (carry-n) ( ns lengths i -- )
+ ns length i 1+ = [
+ i ns nth i lengths nth = [
+ 0 i ns set-nth
+ i 1+ ns [ 1+ ] change-nth
+ ns lengths i 1+ (carry-n)
+ ] when
+ ] unless ;
+
+: carry-ns ( ns lengths -- )
+ 0 (carry-n) ;
+
+: product-iter ( ns lengths -- )
+ [ 0 over [ 1+ ] change-nth ] dip carry-ns ;
+
+: start-product-iter ( sequence-product -- ns lengths )
+ [ [ drop 0 ] map ] [ [ length ] map ] bi ;
+
+: end-product-iter? ( ns lengths -- ? )
+ [ 1 tail* first ] bi@ = ;
+
+PRIVATE>
+
M: product-sequence nth
- product@ [ nth ] { } 2map-as ;
+ product@ nths ;
-M: product-sequence set-nth
- immutable ;
+:: product-each ( sequences quot -- )
+ sequences start-product-iter :> lengths :> ns
+ [ ns lengths end-product-iter? ]
+ [ ns sequences nths quot call ns lengths product-iter ] until ; inline
+
+:: product-map ( sequences quot -- sequence )
+ 0 :> i!
+ sequences [ length ] [ * ] map-reduce sequences
+ [| result |
+ sequences [ quot call i result set-nth i 1+ i! ] product-each
+ result
+ ] new-like ; inline
-: product-map ( sequences quot -- sequence )
- [ <product-sequence> ] dip map ; inline
-: product-each ( sequences quot -- )
- [ <product-sequence> ] dip each ; inline
From f007c281e3b2c0645a095b1f9febb31668eea9e9 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 13:08:15 -0500
Subject: [PATCH 05/14] docs for sequences.product
---
extra/sequences/product/product-docs.factor | 60 +++++++++++++++++++++
1 file changed, 60 insertions(+)
create mode 100644 extra/sequences/product/product-docs.factor
diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor
new file mode 100644
index 0000000000..6033767f47
--- /dev/null
+++ b/extra/sequences/product/product-docs.factor
@@ -0,0 +1,60 @@
+USING: help.markup help.syntax multiline quotations sequences sequences.product ;
+IN: sequences
+
+HELP: product-sequence
+{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
+{ $examples
+{ $example <" USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
+"> <" {
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}"> } } ;
+
+HELP: <product-sequence>
+{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
+{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
+{ $examples
+{ $example <" USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
+"> <" {
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}"> } } ;
+
+{ product-sequence <product-sequence> } related-words
+
+HELP: product-map
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
+{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
+
+HELP: product-each
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
+{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
+
+{ product-map product-each } related-words
+
+ARTICLE: "sequences.product" "Product sequences"
+"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
+{ $subsection product-sequence }
+{ $subsection <product-sequence> }
+{ $subsection product-map }
+{ $subsection product-each } ;
+
+ABOUT: "sequences.product"
From a2056d932c3c02fd6ecc5673a3f75ee067648990 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 13:09:30 -0500
Subject: [PATCH 06/14] gold plating for sequences.product
---
extra/sequences/product/authors.txt | 1 +
extra/sequences/product/product-docs.factor | 1 +
extra/sequences/product/product-tests.factor | 1 +
extra/sequences/product/product.factor | 1 +
extra/sequences/product/summary.txt | 1 +
5 files changed, 5 insertions(+)
create mode 100644 extra/sequences/product/authors.txt
create mode 100644 extra/sequences/product/summary.txt
diff --git a/extra/sequences/product/authors.txt b/extra/sequences/product/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/sequences/product/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor
index 6033767f47..b7dcaa626e 100644
--- a/extra/sequences/product/product-docs.factor
+++ b/extra/sequences/product/product-docs.factor
@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
USING: help.markup help.syntax multiline quotations sequences sequences.product ;
IN: sequences
diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor
index 087d7a6175..5e0997dc2e 100644
--- a/extra/sequences/product/product-tests.factor
+++ b/extra/sequences/product/product-tests.factor
@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
USING: arrays kernel make sequences sequences.product tools.test ;
IN: sequences.product.tests
diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor
index 0c5bb88f32..665d43f0cd 100644
--- a/extra/sequences/product/product.factor
+++ b/extra/sequences/product/product.factor
@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
USING: accessors arrays kernel locals math sequences ;
IN: sequences.product
diff --git a/extra/sequences/product/summary.txt b/extra/sequences/product/summary.txt
new file mode 100644
index 0000000000..c234c84a94
--- /dev/null
+++ b/extra/sequences/product/summary.txt
@@ -0,0 +1 @@
+Cartesian products of sequences
From 291ac48a1766e942a20099d023ba3e84deee5609 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Apr 2009 13:31:10 -0500
Subject: [PATCH 07/14] tuple-arrays: completely rewritten to use functors, 10x
faster on benchmark
---
basis/inverse/inverse.factor | 2 +-
basis/tuple-arrays/authors.txt | 2 +-
basis/tuple-arrays/summary.txt | 1 -
basis/tuple-arrays/tags.txt | 1 -
basis/tuple-arrays/tuple-arrays-docs.factor | 13 ----
basis/tuple-arrays/tuple-arrays-tests.factor | 16 ++--
basis/tuple-arrays/tuple-arrays.factor | 76 ++++++++++++++-----
extra/benchmark/tuple-arrays/authors.txt | 1 +
.../tuple-arrays/tuple-arrays.factor | 20 +++++
9 files changed, 88 insertions(+), 44 deletions(-)
delete mode 100644 basis/tuple-arrays/summary.txt
delete mode 100644 basis/tuple-arrays/tags.txt
delete mode 100644 basis/tuple-arrays/tuple-arrays-docs.factor
create mode 100644 extra/benchmark/tuple-arrays/authors.txt
create mode 100644 extra/benchmark/tuple-arrays/tuple-arrays.factor
diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor
index a988063293..0b86b02e92 100755
--- a/basis/inverse/inverse.factor
+++ b/basis/inverse/inverse.factor
@@ -12,7 +12,7 @@ IN: inverse
ERROR: fail ;
M: fail summary drop "Matching failed" ;
-: assure ( ? -- ) [ fail ] unless ;
+: assure ( ? -- ) [ fail ] unless ; inline
: =/fail ( obj1 obj2 -- ) = assure ;
diff --git a/basis/tuple-arrays/authors.txt b/basis/tuple-arrays/authors.txt
index f990dd0ed2..d4f5d6b3ae 100644
--- a/basis/tuple-arrays/authors.txt
+++ b/basis/tuple-arrays/authors.txt
@@ -1 +1 @@
-Daniel Ehrenberg
+Slava Pestov
\ No newline at end of file
diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt
deleted file mode 100644
index ac05ae9bcc..0000000000
--- a/basis/tuple-arrays/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Packed homogeneous tuple arrays
diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt
deleted file mode 100644
index 42d711b32b..0000000000
--- a/basis/tuple-arrays/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-collections
diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor
deleted file mode 100644
index 18f5547e7f..0000000000
--- a/basis/tuple-arrays/tuple-arrays-docs.factor
+++ /dev/null
@@ -1,13 +0,0 @@
-USING: help.syntax help.markup splitting kernel sequences ;
-IN: tuple-arrays
-
-HELP: tuple-array
-{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
-
-HELP: <tuple-array>
-{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
-{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
-
-HELP: >tuple-array
-{ $values { "seq" sequence } { "tuple-array" tuple-array } }
-{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;
diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor
index 7aa49b880f..4606ecdada 100644
--- a/basis/tuple-arrays/tuple-arrays-tests.factor
+++ b/basis/tuple-arrays/tuple-arrays-tests.factor
@@ -5,17 +5,21 @@ IN: tuple-arrays.tests
SYMBOL: mat
TUPLE: foo bar ;
C: <foo> foo
-[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
+TUPLE-ARRAY: foo
+
+[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
-[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
+[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test
[ T{ foo f 3 } t ]
-[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
+[ mat get [ bar>> 2 + <foo> ] map [ first ] keep foo-array? ] unit-test
-[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
+[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
TUPLE: baz { bing integer } bong ;
-[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
-[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
+TUPLE-ARRAY: baz
+
+[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
+[ f ] [ 1 <baz-array> first bong>> ] unit-test
diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor
index af62c0b0d7..466262f3e0 100644
--- a/basis/tuple-arrays/tuple-arrays.factor
+++ b/basis/tuple-arrays/tuple-arrays.factor
@@ -1,34 +1,68 @@
-! Copyright (C) 2007 Daniel Ehrenberg.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting grouping classes.tuple classes math kernel
-sequences arrays accessors ;
+USING: accessors arrays combinators.smart fry functors grouping
+kernel macros sequences sequences.private stack-checker
+parser ;
+FROM: inverse => undo ;
IN: tuple-arrays
-TUPLE: tuple-array { seq read-only } { class read-only } ;
+<PRIVATE
-: <tuple-array> ( length class -- tuple-array )
- [
- new tuple>array 1 tail
- [ <repetition> concat ] [ length ] bi <sliced-groups>
- ] [ ] bi tuple-array boa ;
+MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
-M: tuple-array nth
- [ seq>> nth ] [ class>> ] bi prefix >tuple ;
+: smart-tuple>array ( tuple class -- array )
+ '[ [ _ boa ] undo ] output>array ; inline
-M: tuple-array set-nth ( elt n seq -- )
- [ tuple>array 1 tail ] 2dip seq>> set-nth ;
+: smart-array>tuple ( array class -- tuple )
+ '[ _ boa ] input<sequence ; inline
-M: tuple-array new-sequence
- class>> <tuple-array> ;
+: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
-: >tuple-array ( seq -- tuple-array )
+: tuple-prototype ( class -- array )
+ [ new ] [ smart-tuple>array ] bi ; inline
+
+PRIVATE>
+
+FUNCTOR: define-tuple-array ( CLASS -- )
+
+CLASS IS ${CLASS}
+
+CLASS-array DEFINES-CLASS ${CLASS}-array
+CLASS-array? IS ${CLASS-array}?
+
+<CLASS-array> DEFINES <${CLASS}-array>
+>CLASS-array DEFINES >${CLASS}-array
+
+WHERE
+
+TUPLE: CLASS-array { seq sliced-groups read-only } ;
+
+: <CLASS-array> ( length -- tuple-array )
+ CLASS tuple-prototype <repetition> concat
+ CLASS tuple-arity <sliced-groups>
+ CLASS-array boa ;
+
+M: CLASS-array nth-unsafe
+ seq>> nth-unsafe CLASS smart-array>tuple ;
+
+M: CLASS-array set-nth-unsafe
+ [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ;
+
+M: CLASS-array new-sequence
+ drop <CLASS-array> ;
+
+: >CLASS-array ( seq -- tuple-array )
dup empty? [
- 0 over first class <tuple-array> clone-like
+ 0 <CLASS-array> clone-like
] unless ;
-M: tuple-array like
- drop dup tuple-array? [ >tuple-array ] unless ;
+M: CLASS-array like
+ drop dup CLASS-array? [ >CLASS-array ] unless ;
-M: tuple-array length seq>> length ;
+M: CLASS-array length seq>> length ;
-INSTANCE: tuple-array sequence
+INSTANCE: CLASS-array sequence
+
+;FUNCTOR
+
+SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;
diff --git a/extra/benchmark/tuple-arrays/authors.txt b/extra/benchmark/tuple-arrays/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/benchmark/tuple-arrays/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor
new file mode 100644
index 0000000000..483311d4f4
--- /dev/null
+++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions tuple-arrays accessors fry sequences
+prettyprint ;
+IN: benchmark.tuple-arrays
+
+TUPLE: point { x float } { y float } { z float } ;
+
+TUPLE-ARRAY: point
+
+: tuple-array-benchmark ( -- )
+ 100 [
+ drop 5000 <point-array> [
+ [ 1+ ] change-x
+ [ 1- ] change-y
+ [ 1+ 2 / ] change-z
+ ] map [ z>> ] sigma
+ ] sigma . ;
+
+MAIN: tuple-array-benchmark
\ No newline at end of file
From 06012cf2917e632f3b14c1a80c221b59e1f383b4 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 14:58:31 -0500
Subject: [PATCH 08/14] order-insensitive pair methods
---
extra/pair-methods/authors.txt | 1 +
extra/pair-methods/pair-methods-tests.factor | 43 +++++++++++++++
extra/pair-methods/pair-methods.factor | 57 ++++++++++++++++++++
extra/pair-methods/summary.txt | 1 +
4 files changed, 102 insertions(+)
create mode 100644 extra/pair-methods/authors.txt
create mode 100644 extra/pair-methods/pair-methods-tests.factor
create mode 100644 extra/pair-methods/pair-methods.factor
create mode 100644 extra/pair-methods/summary.txt
diff --git a/extra/pair-methods/authors.txt b/extra/pair-methods/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/pair-methods/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/pair-methods/pair-methods-tests.factor b/extra/pair-methods/pair-methods-tests.factor
new file mode 100644
index 0000000000..f88ca966aa
--- /dev/null
+++ b/extra/pair-methods/pair-methods-tests.factor
@@ -0,0 +1,43 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors pair-methods classes kernel sequences tools.test ;
+IN: pair-methods.tests
+
+TUPLE: thang ;
+
+TUPLE: foom < thang ;
+TUPLE: barm < foom ;
+
+TUPLE: zim < thang ;
+TUPLE: zang < zim ;
+
+: class-names ( a b prefix -- string )
+ [ [ class name>> ] bi@ "-" glue ] dip prepend ;
+
+PAIR-GENERIC: blibble ( a b -- c )
+
+PAIR-M: thang thang blibble
+ "vanilla " class-names ;
+
+PAIR-M: foom thang blibble
+ "chocolate " class-names ;
+
+PAIR-M: barm thang blibble
+ "strawberry " class-names ;
+
+PAIR-M: barm zim blibble
+ "coconut " class-names ;
+
+[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test
+
+! args automatically swap to match most specific method
+[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test
+[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test
+
+[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test
+[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test
+[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test
+
+[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test
+[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test
+
+[ 1 2 blibble ] [ no-pair-method? ] must-fail-with
diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor
new file mode 100644
index 0000000000..d44d5bce78
--- /dev/null
+++ b/extra/pair-methods/pair-methods.factor
@@ -0,0 +1,57 @@
+! (c)2009 Joe Groff bsd license
+USING: arrays assocs classes classes.tuple.private combinators
+effects.parser generic.parser kernel math math.order parser
+quotations sequences sorting words ;
+IN: pair-methods
+
+ERROR: no-pair-method a b generic ;
+
+: ?swap ( a b ? -- a/b b/a )
+ [ swap ] when ;
+
+: method-sort-key ( pair -- key )
+ first2 [ tuple-layout third ] bi@ + ;
+
+: pair-match-condition ( pair -- quot )
+ first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence
+ [ 2dup ] [ bi* and ] surround ;
+
+: pair-method-cond ( pair quot -- array )
+ [ pair-match-condition ] [ ] bi* 2array ;
+
+: sorted-pair-methods ( word -- alist )
+ "pair-generic-methods" word-prop >alist
+ [ [ first method-sort-key ] bi@ >=< ] sort ;
+
+: pair-generic-definition ( word -- def )
+ [ sorted-pair-methods [ first2 pair-method-cond ] map ]
+ [ [ no-pair-method ] curry suffix ] bi 1quotation
+ [ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ;
+
+: make-pair-generic ( word -- )
+ dup pair-generic-definition define ;
+
+: define-pair-generic ( word effect -- )
+ [ swap set-stack-effect ]
+ [ drop H{ } clone "pair-generic-methods" set-word-prop ]
+ [ drop make-pair-generic ] 2tri ;
+
+: (PAIR-GENERIC:) ( -- )
+ CREATE-GENERIC complete-effect define-pair-generic ;
+
+SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
+
+: define-pair-method ( a b pair-generic definition -- )
+ [ 2array ] 2dip swap
+ [ "pair-generic-methods" word-prop [ swap ] dip set-at ]
+ [ make-pair-generic ] bi ;
+
+: ?prefix-swap ( quot ? -- quot' )
+ [ \ swap prefix ] when ;
+
+: (PAIR-M:) ( -- )
+ scan-word scan-word 2dup <=> +gt+ eq? [
+ ?swap scan-word parse-definition
+ ] keep ?prefix-swap define-pair-method ;
+
+SYNTAX: PAIR-M: (PAIR-M:) ;
diff --git a/extra/pair-methods/summary.txt b/extra/pair-methods/summary.txt
new file mode 100644
index 0000000000..823bc712f6
--- /dev/null
+++ b/extra/pair-methods/summary.txt
@@ -0,0 +1 @@
+Order-insensitive double dispatch generics
From dac5203e81b6f40ac3660e1e4fdecec4a29a8678 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Apr 2009 16:04:44 -0500
Subject: [PATCH 09/14] compiler.tree.builder: Fix scoping of a variable by
hints vocab
---
basis/compiler/tree/builder/builder.factor | 19 ++++++++++---------
1 file changed, 10 insertions(+), 9 deletions(-)
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 7f760650e7..37cc1f05da 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -54,15 +54,16 @@ PRIVATE>
#! This slows down compiler.tree.propagation.inlining since then every
#! inlined usage of a method has an inline-dependency on the mixin, and
#! not the more specific type at the call site.
- specialize-method? off
- [
- #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
- {
- { [ dup not ] [ ] }
- { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
- [ in-d #call out-d>> #copy suffix ]
- } cond
- ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
+ f specialize-method? [
+ [
+ #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+ {
+ { [ dup not ] [ ] }
+ { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
+ [ in-d #call out-d>> #copy suffix ]
+ } cond
+ ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
+ ] with-variable ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;
From 087c962f75d432cdd533991f403364e4782f83d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Apr 2009 16:05:09 -0500
Subject: [PATCH 10/14] VM: simplify GC a bit, add GC_DEBUG compile-time flag
---
vm/code_block.c | 3 ++-
vm/data_gc.c | 4 ++--
vm/data_gc.h | 20 ++++++++++++++++++--
vm/data_heap.h | 1 -
4 files changed, 22 insertions(+), 6 deletions(-)
diff --git a/vm/code_block.c b/vm/code_block.c
index 8dda8bc16e..1ce440c9ab 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -224,7 +224,8 @@ void mark_object_code_block(CELL scan)
{
case WORD_TYPE:
word = (F_WORD *)scan;
- mark_code_block(word->code);
+ if(word->code)
+ mark_code_block(word->code);
if(word->profiling)
mark_code_block(word->profiling);
break;
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 3ab2055d82..a1a86e7789 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -330,7 +330,7 @@ CELL copy_next_from_tenured(CELL scan)
void copy_reachable_objects(CELL scan, CELL *end)
{
- if(HAVE_NURSERY_P && collecting_gen == NURSERY)
+ if(collecting_gen == NURSERY)
{
while(scan < *end)
scan = copy_next_from_nursery(scan);
@@ -405,7 +405,7 @@ void end_gc(CELL gc_elapsed)
if(collecting_gen != NURSERY)
reset_generations(NURSERY,collecting_gen - 1);
}
- else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
+ else if(collecting_gen == NURSERY)
{
nursery.here = nursery.start;
}
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 52d8b603ad..afa45c5522 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -58,7 +58,7 @@ INLINE bool should_copy(CELL untagged)
return true;
else if(HAVE_AGING_P && collecting_gen == AGING)
return !in_zone(&data_heap->generations[TENURED],untagged);
- else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
+ else if(collecting_gen == NURSERY)
return in_zone(&nursery,untagged);
else
{
@@ -78,15 +78,31 @@ allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
+/* If this is defined, we GC every 100 allocations. This catches missing local roots */
+#ifdef GC_DEBUG
+static int count;
+#endif
+
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
INLINE void *allot_object(CELL type, CELL a)
{
+
+#ifdef GC_DEBUG
+
+ if(!gc_off)
+ {
+ if(count++ % 1000 == 0)
+ gc();
+
+ }
+#endif
+
CELL *object;
- if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a)
+ if(nursery.size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
diff --git a/vm/data_heap.h b/vm/data_heap.h
index a7f44e73f8..5836967295 100644
--- a/vm/data_heap.h
+++ b/vm/data_heap.h
@@ -37,7 +37,6 @@ F_DATA_HEAP *data_heap;
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
-#define HAVE_NURSERY_P (data_heap->gen_count>1)
/* where objects hang around */
#define AGING (data_heap->gen_count-2)
#define HAVE_AGING_P (data_heap->gen_count>2)
From 6b5b839e727212c05df51ceefcb2f60854bf9a7c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Apr 2009 16:05:23 -0500
Subject: [PATCH 11/14] Makefile: add SITE_CFLAGS even if DEBUG=1
---
Makefile | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/Makefile b/Makefile
index db99120a77..c19d83e58e 100644
--- a/Makefile
+++ b/Makefile
@@ -15,9 +15,11 @@ FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
CFLAGS += -g
else
- CFLAGS += -O3 $(SITE_CFLAGS)
+ CFLAGS += -O3
endif
+CFLAGS += $(SITE_CFLAGS)
+
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
ifdef CONFIG
From 7094b78821bf4817af674284d2a40f070b46e894 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Apr 2009 21:22:06 -0500
Subject: [PATCH 12/14] Add firstn-unsafe, input<sequence-unsafe
---
basis/combinators/smart/smart.factor | 4 ++++
basis/generalizations/generalizations.factor | 9 ++++++---
2 files changed, 10 insertions(+), 3 deletions(-)
diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index aa7960539c..9519847810 100644
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn @ ] ;
+MACRO: input<sequence-unsafe ( quot -- newquot )
+ [ infer in>> ] keep
+ '[ _ firstn-unsafe @ ] ;
+
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index edee44acc6..139b7a528a 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -26,11 +26,14 @@ MACRO: narray ( n -- )
MACRO: nsum ( n -- )
1- [ + ] n*quot ;
+MACRO: firstn-unsafe ( n -- )
+ [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
+
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
- [ [ '[ [ _ ] dip nth-unsafe ] ] map ]
- [ 1- '[ [ _ ] dip bounds-check 2drop ] ]
- bi prefix '[ _ cleave ]
+ [ 1- swap bounds-check 2drop ]
+ [ firstn-unsafe ]
+ bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )
From 58cba832a0ab29580bb29a2a86d3557a02be81a9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Apr 2009 21:22:20 -0500
Subject: [PATCH 13/14] functors: add support for call-next-method
---
basis/functors/functors.factor | 27 ++++++++++++++++++++-------
1 file changed, 20 insertions(+), 7 deletions(-)
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index 309154fb49..6afa020128 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -18,6 +18,8 @@ IN: functors
: define-declared* ( word def effect -- ) pick set-word define-declared ;
+TUPLE: fake-call-next-method ;
+
TUPLE: fake-quotation seq ;
GENERIC: >fake-quotations ( quot -- fake )
@@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ;
M: object >fake-quotations ;
-GENERIC: fake-quotations> ( fake -- quot )
+GENERIC: (fake-quotations>) ( fake -- )
-M: fake-quotation fake-quotations>
- seq>> [ fake-quotations> ] [ ] map-as ;
+: fake-quotations> ( fake -- quot )
+ [ (fake-quotations>) ] [ ] make ;
-M: array fake-quotations> [ fake-quotations> ] map ;
+M: fake-quotation (fake-quotations>)
+ [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
-M: object fake-quotations> ;
+M: array (fake-quotations>)
+ [ [ (fake-quotations>) ] each ] { } make , ;
+
+M: fake-call-next-method (fake-quotations>)
+ drop method-body get literalize , \ (call-next-method) , ;
+
+M: object (fake-quotations>) , ;
: parse-definition* ( accum -- accum )
- parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
+ parse-definition >fake-quotations parsed
+ [ fake-quotations> first ] over push-all ;
: parse-declared* ( accum -- accum )
complete-effect
@@ -64,7 +74,7 @@ SYNTAX: `TUPLE:
SYNTAX: `M:
scan-param parsed
scan-param parsed
- \ create-method-in parsed
+ [ create-method-in dup method-body set ] over push-all
parse-definition*
\ define* parsed ;
@@ -92,6 +102,8 @@ SYNTAX: `INSTANCE:
SYNTAX: `inline [ word make-inline ] over push-all ;
+SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
+
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
@@ -117,6 +129,7 @@ DEFER: ;FUNCTOR delimiter
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "inline" POSTPONE: `inline }
+ { "call-next-method" POSTPONE: `call-next-method }
} ;
: push-functor-words ( -- )
From 84f672e74b3b6cd556e842df0455a444fa5602b9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Apr 2009 21:24:55 -0500
Subject: [PATCH 14/14] tuple-arrays: further performance improvements
---
basis/tuple-arrays/tuple-arrays-tests.factor | 7 +++
basis/tuple-arrays/tuple-arrays.factor | 55 +++++++++++---------
2 files changed, 37 insertions(+), 25 deletions(-)
diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor
index 4606ecdada..2eeae20aa1 100644
--- a/basis/tuple-arrays/tuple-arrays-tests.factor
+++ b/basis/tuple-arrays/tuple-arrays-tests.factor
@@ -23,3 +23,10 @@ TUPLE-ARRAY: baz
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
[ f ] [ 1 <baz-array> first bong>> ] unit-test
+
+TUPLE: broken x ;
+: broken ( -- ) ;
+
+TUPLE-ARRAY: broken
+
+[ 100 ] [ 100 <broken-array> length ] unit-test
\ No newline at end of file
diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor
index 466262f3e0..35d771416c 100644
--- a/basis/tuple-arrays/tuple-arrays.factor
+++ b/basis/tuple-arrays/tuple-arrays.factor
@@ -1,26 +1,36 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators.smart fry functors grouping
-kernel macros sequences sequences.private stack-checker
-parser ;
+USING: accessors arrays combinators.smart fry functors kernel
+kernel.private macros sequences combinators sequences.private
+stack-checker parser math classes.tuple.private ;
FROM: inverse => undo ;
IN: tuple-arrays
<PRIVATE
+MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
+
MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
+: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
+
: smart-tuple>array ( tuple class -- array )
'[ [ _ boa ] undo ] output>array ; inline
-: smart-array>tuple ( array class -- tuple )
- '[ _ boa ] input<sequence ; inline
-
-: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
-
: tuple-prototype ( class -- array )
[ new ] [ smart-tuple>array ] bi ; inline
+: tuple-slice ( n seq -- slice )
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
+
+: read-tuple ( slice class -- tuple )
+ '[ _ boa-unsafe ] input<sequence-unsafe ; inline
+
+MACRO: write-tuple ( class -- quot )
+ [ '[ [ _ boa ] undo ] ]
+ [ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
+ bi '[ _ dip @ ] ;
+
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
@@ -35,31 +45,26 @@ CLASS-array? IS ${CLASS-array}?
WHERE
-TUPLE: CLASS-array { seq sliced-groups read-only } ;
+TUPLE: CLASS-array
+{ seq array read-only }
+{ n array-capacity read-only }
+{ length array-capacity read-only } ;
: <CLASS-array> ( length -- tuple-array )
- CLASS tuple-prototype <repetition> concat
- CLASS tuple-arity <sliced-groups>
- CLASS-array boa ;
+ [ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
+ \ CLASS-array boa ; inline
-M: CLASS-array nth-unsafe
- seq>> nth-unsafe CLASS smart-array>tuple ;
+M: CLASS-array length length>> ;
-M: CLASS-array set-nth-unsafe
- [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ;
+M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
-M: CLASS-array new-sequence
- drop <CLASS-array> ;
+M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
-: >CLASS-array ( seq -- tuple-array )
- dup empty? [
- 0 <CLASS-array> clone-like
- ] unless ;
+M: CLASS-array new-sequence drop <CLASS-array> ;
-M: CLASS-array like
- drop dup CLASS-array? [ >CLASS-array ] unless ;
+: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
-M: CLASS-array length seq>> length ;
+M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
INSTANCE: CLASS-array sequence