specialized-arrays, specialized-vectors: add direct-slice, direct-head, direct-tail...

diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor
index fd1a4a72f25e2947e86346e3a245ba5e9cc3ae2f..b476a4707251c5c6f50821831f1782b41b2b02b1 100644 (file)
--- a/basis/specialized-arrays/specialized-arrays-docs.factor
+++ b/basis/specialized-arrays/specialized-arrays-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax byte-arrays alien ;
+USING: help.markup help.syntax byte-arrays alien math sequences ;
 IN: specialized-arrays
 
 HELP: SPECIALIZED-ARRAY:
@@ -13,6 +13,28 @@ HELP: SPECIALIZED-ARRAYS:
 
 { POSTPONE: SPECIALIZED-ARRAY: POSTPONE: SPECIALIZED-ARRAYS: } related-words
 
+HELP: direct-slice
+{ $values { "from" integer } { "to" integer } { "seq" "a specialized array" } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as the subsequence of " { $snippet "seq" } " from elements " { $snippet "from" } " up to but not including " { $snippet "to" } ". Like " { $link slice } ", raises an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
+
+HELP: direct-head
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as the first " { $snippet "n" } " elements of " { $snippet "seq" } ". Like " { $link head } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+HELP: direct-tail
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as " { $snippet "seq" } " without the first " { $snippet "n" } " elements. Like " { $link tail } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+HELP: direct-head*
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as " { $snippet "seq" } " without the last " { $snippet "n" } " elements. Like " { $link head* } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+HELP: direct-tail*
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as the last " { $snippet "n" } " elements of " { $snippet "seq" } ". Like " { $link tail* } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+{ direct-slice direct-head direct-tail direct-head* direct-tail* } related-words
+
 ARTICLE: "specialized-array-words" "Specialized array words"
 "The " { $link POSTPONE: SPECIALIZED-ARRAY: } " and " { $link POSTPONE: SPECIALIZED-ARRAYS: } " parsing words generate specialized array types if they haven't been generated already and add the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
 { $table
@@ -25,7 +47,16 @@ ARTICLE: "specialized-array-words" "Specialized array words"
     { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
     { { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
 }
-"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } " or " { $link POSTPONE: SPECIALIZED-ARRAYS: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
+"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } " or " { $link POSTPONE: SPECIALIZED-ARRAYS: } ". This ensures that the vocabulary can get generated the first time it is needed."
+$nl
+"Additionally, special versions of the standard " { $link <slice> } ", " { $link head } ", and " { $link tail } " sequence operations are provided for specialized arrays to create a new specialized array object sharing storage with a subsequence of an existing array:"
+{ $subsections
+    direct-slice
+    direct-head
+    direct-tail
+    direct-head*
+    direct-tail*
+} ;
 
 ARTICLE: "specialized-array-c" "Passing specialized arrays to C functions"
 "If a C function is declared as taking a parameter with a pointer or an array type (for example, " { $snippet "float*" } " or " { $snippet "int[3]" } "), instances of the relevant specialized array can be passed in."

diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor
index 3a34b3891bebbb6fbe53a9ea051b88db7454e10d..02424a22fdc68cc9cd9c7b1a4ec521fa8c353177 100644 (file)
--- a/basis/specialized-arrays/specialized-arrays-tests.factor
+++ b/basis/specialized-arrays/specialized-arrays-tests.factor
@@ -191,3 +191,16 @@ SPECIALIZED-ARRAY: struct-resize-test
         \ struct-resize-test-usage forget
     ] with-compilation-unit
 ] unit-test
+
+[ int-array{ 4 5 6 } ] [ 3 6 int-array{ 1 2 3 4 5 6 7 8 } direct-slice ] unit-test
+[ int-array{ 1 2 3 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-head ] unit-test
+[ int-array{ 1 2 3 4 5 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-head* ] unit-test
+[ int-array{ 4 5 6 7 8 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-tail ] unit-test
+[ int-array{ 6 7 8 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-tail* ] unit-test
+
+
+[ int-array{ 1 2 3 4 55555 6 7 8 } ] [
+    int-array{ 1 2 3 4 5 6 7 8 }
+    3 6 pick direct-slice [ 55555 1 ] dip set-nth
+] unit-test
+

diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor
index dc070f99b4a453c1770296f42dfcf9573aa6cc01..5fa88e39a22b0c718704dd7b64ab8d8802419829 100644 (file)
--- a/basis/specialized-arrays/specialized-arrays.factor
+++ b/basis/specialized-arrays/specialized-arrays.factor
@@ -32,6 +32,9 @@ M: not-a-byte-array summary
 
 <PRIVATE
 
+GENERIC: nth-c-ptr ( n seq -- displaced-alien )
+GENERIC: direct-like ( alien len exemplar -- seq )
+
 FUNCTOR: define-array ( T -- )
 
 A          DEFINES-CLASS ${T}-array
@@ -52,6 +55,8 @@ TUPLE: A
 
 : <direct-A> ( alien len -- specialized-array ) A boa ; inline
 
+M: A direct-like drop <direct-A> ; inline
+
 : <A> ( n -- specialized-array )
     [ \ T <underlying> ] keep <direct-A> ; inline
 
@@ -71,6 +76,8 @@ M: A length length>> ; inline
 
 M: A nth-unsafe underlying>> \ T alien-element ; inline
 
+M: A nth-c-ptr underlying>> \ T array-accessor drop swap <displaced-alien> ; inline
+
 M: A set-nth-unsafe underlying>> \ T set-alien-element ; inline
 
 : >A ( seq -- specialized-array ) A new clone-like ;
@@ -132,6 +139,17 @@ M: pointer underlying-type
 
 PRIVATE>
 
+: direct-slice ( from to seq -- seq' )
+    check-slice
+    [ nip nth-c-ptr ]
+    [ drop swap - ]
+    [ 2nip ] 3tri direct-like ; inline
+
+: direct-head ( seq n -- seq' ) (head) direct-slice ; inline
+: direct-tail ( seq n -- seq' ) (tail) direct-slice ; inline
+: direct-head* ( seq n -- seq' ) from-end direct-head ; inline
+: direct-tail* ( seq n -- seq' ) from-end direct-tail ; inline
+
 : define-array-vocab ( type -- vocab )
     underlying-type
     [ specialized-array-vocab ] [ '[ _ define-array ] ] bi

diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor
index 5c47a9e879c9ff28f0c0402dfcc34f18fe030cc3..f96aea6815a7fae21f98d7b614f2b7ed84833dc8 100644 (file)
--- a/basis/specialized-vectors/specialized-vectors.factor
+++ b/basis/specialized-vectors/specialized-vectors.factor
@@ -6,6 +6,7 @@ parser prettyprint.custom sequences specialized-arrays
 specialized-arrays.private strings vocabs vocabs.parser
 vocabs.generated fry make ;
 FROM: sequences.private => nth-unsafe ;
+FROM: specialized-arrays.private => nth-c-ptr direct-like ;
 QUALIFIED: vectors.functor
 IN: specialized-vectors
 
@@ -17,6 +18,7 @@ V   DEFINES-CLASS ${T}-vector
 
 A   IS      ${T}-array
 <A> IS      <${A}>
+<direct-A> IS <direct-${A}>
 
 >V  DEFERS >${V}
 V{  DEFINES ${V}{
@@ -38,6 +40,9 @@ M: V pprint* pprint-object ;
 M: V >c-ptr underlying>> underlying>> ; inline
 M: V byte-length [ length ] [ element-size ] bi * ; inline
 
+M: V direct-like drop <direct-A> ; inline
+M: V nth-c-ptr underlying>> nth-c-ptr ; inline
+
 SYNTAX: V{ \ } [ >V ] parse-literal ;
 
 INSTANCE: V growable