summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-data.texi1
-rw-r--r--libguile/vectors.c40
-rw-r--r--libguile/vectors.h2
-rw-r--r--module/scheme/base.scm24
-rw-r--r--module/srfi/srfi-43.scm26
-rw-r--r--test-suite/tests/vectors.test9
6 files changed, 59 insertions, 43 deletions
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 2ad13f5a5..eb3d91060 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -6387,6 +6387,7 @@ Store @var{fill} in every position of @var{vec}. The value
returned by @code{vector-fill!} is unspecified.
@end deffn
+@rnindex vector-copy
@deffn {Scheme Procedure} vector-copy vec
@deffnx {C Function} scm_vector_copy (vec)
Return a copy of @var{vec}.
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 4f95644ef..3a2ff7ab5 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -265,17 +265,36 @@ scm_c_make_vector (size_t k, SCM fill)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
- (SCM vec),
- "Return a copy of @var{vec}.")
-#define FUNC_NAME s_scm_vector_copy
+SCM_DEFINE (scm_vector_copy_partial, "vector-copy", 1, 2, 0,
+ (SCM vec, SCM start, SCM end),
+ "Returns a freshly allocated vector containing the elements\n"
+ "of @var{vec} between @var{start} and @var{end}.\n\n"
+ "@var{start} defaults to 0 and @var{end} defaults to the\n"
+ "length of @var{vec}.")
+#define FUNC_NAME s_scm_vector_copy_partial
{
SCM result;
if (SCM_I_IS_VECTOR (vec))
{
- size_t len = SCM_I_VECTOR_LENGTH (vec);
+ size_t cstart = 0, cend = SCM_I_VECTOR_LENGTH (vec);
+
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_size_t (start);
+ SCM_ASSERT_RANGE (SCM_ARG2, start, cstart<=cend);
+
+ if (!SCM_UNBNDP (end))
+ {
+ size_t e = scm_to_size_t (end);
+ SCM_ASSERT_RANGE (SCM_ARG3, end, e>=cstart && e<=cend);
+ cend = e;
+ }
+ }
+
+ size_t len = cend-cstart;
result = make_vector (len);
- memcpy (SCM_I_VECTOR_WELTS (result), SCM_I_VECTOR_ELTS (vec), len * sizeof(SCM));
+ memcpy (SCM_I_VECTOR_WELTS (result), SCM_I_VECTOR_ELTS (vec) + cstart,
+ len * sizeof(SCM));
}
else
{
@@ -290,6 +309,9 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
("Using vector-copy on arrays is deprecated. "
"Use array-copy instead.");
+ if (SCM_UNBNDP (start))
+ scm_misc_error (s_scm_vector_copy_partial, "Too many arguments", SCM_EOL);
+
result = make_vector (len);
dst = SCM_I_VECTOR_WELTS (result);
for (i = 0; i < len; i++, src += inc)
@@ -301,6 +323,12 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
}
#undef FUNC_NAME
+SCM
+scm_vector_copy (SCM vec)
+{
+ return scm_vector_copy_partial (vec, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
(SCM vec),
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 41e2c8909..1c04f9afe 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -88,7 +88,7 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
-
+SCM_INTERNAL SCM scm_vector_copy_partial (SCM vec, SCM start, SCM end);
SCM_INTERNAL void scm_init_vectors (void);
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index 20e280467..fcb1f49b7 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -56,7 +56,6 @@
bytevector bytevector-append
string->vector vector->string
(r7:string->utf8 . string->utf8)
- (r7:vector-copy . vector-copy)
(r7:vector->list . vector->list)
(r7:vector-fill! . vector-fill!)
vector-copy! vector-append vector-for-each vector-map
@@ -116,7 +115,7 @@
(char-ready? . u8-ready?)
unless
unquote unquote-splicing values
- vector
+ vector vector-copy
vector-length vector-ref vector-set! vector?
when with-exception-handler write-char
zero?))
@@ -433,23 +432,6 @@
;;; vector
-(define (%subvector v start end)
- (define mlen (- end start))
- (define out (make-vector (- end start)))
- (define (itr r)
- (if (= r mlen)
- out
- (begin
- (vector-set! out r (vector-ref v (+ start r)))
- (itr (+ r 1)))))
- (itr 0))
-
-(define r7:vector-copy
- (case-lambda*
- ((v) (vector-copy v))
- ((v start #:optional (end (vector-length v)))
- (%subvector v start end))))
-
(define* (vector-copy! target tstart source
#:optional (sstart 0) (send (vector-length source)))
"Copy a block of elements from SOURCE to TARGET, both of which must be
@@ -467,7 +449,7 @@ defaults to 0 and SEND defaults to the length of SOURCE."
(case-lambda*
((v) (vector->list v))
((v start #:optional (end (vector-length v)))
- (vector->list (%subvector v start end)))))
+ (vector->list (vector-copy v start end)))))
(define vector-map
(case-lambda*
@@ -518,7 +500,7 @@ defaults to 0 and SEND defaults to the length of SOURCE."
(case-lambda*
((v) (list->string (vector->list v)))
((v start #:optional (end (vector-length v)))
- (vector->string (%subvector v start end)))))
+ (vector->string (vector-copy v start end)))))
(define r7:vector-fill!
(case-lambda*
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
index eb6d8c317..f8e38e27c 100644
--- a/module/srfi/srfi-43.scm
+++ b/module/srfi/srfi-43.scm
@@ -204,7 +204,6 @@ error for the number of seeds to vary between iterations."
(define guile-vector-copy (@ (guile) vector-copy))
-;; TODO: Enhance Guile core 'vector-copy' to do this.
(define vector-copy
(case-lambda*
"(vector-copy vec [start [end [fill]]]) -> vector
@@ -217,23 +216,20 @@ VEC, the slots in the new vector that obviously cannot be filled by
elements from VEC are filled with FILL, whose default value is
unspecified."
((v) (guile-vector-copy v))
- ((v start)
- (assert-vector v 'vector-copy)
- (let ((len (vector-length v)))
- (assert-valid-start start len 'vector-copy)
- (let ((result (make-vector (- len start))))
- (vector-move-left! v start len result 0)
- result)))
+ ((v start) (guile-vector-copy v start))
((v start end #:optional (fill *unspecified*))
(assert-vector v 'vector-copy)
(let ((len (vector-length v)))
- (unless (and (exact-integer? start)
- (exact-integer? end)
- (<= 0 start end))
- (error-from 'vector-copy "invalid index range" start end))
- (let ((result (make-vector (- end start) fill)))
- (vector-move-left! v start (min end len) result 0)
- result)))))
+ (if (<= end len)
+ (guile-vector-copy v start end)
+ (begin
+ (unless (and (exact-integer? start)
+ (exact-integer? end)
+ (<= 0 start end))
+ (error-from 'vector-copy "invalid index range" start end))
+ (let ((result (make-vector (- end start) fill)))
+ (vector-move-left! v start (min end len) result 0)
+ result)))))))
(define vector-reverse-copy
(let ()
diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test
index 97b3f187a..8bdbc89bc 100644
--- a/test-suite/tests/vectors.test
+++ b/test-suite/tests/vectors.test
@@ -31,6 +31,15 @@
exception:immutable-vector
(vector-set! '#(1 2 3) 0 4)))
+(with-test-prefix "vector-copy"
+
+ (pass-if "defaults"
+ (equal? #(1 2 3) (vector-copy #(1 2 3))))
+ (pass-if "default end"
+ (equal? #(2 3) (vector-copy #(1 2 3) 1)))
+ (pass-if "start end"
+ (equal? #(2) (vector-copy #(1 2 3) 1 2))))
+
(with-test-prefix "vector->list"
(pass-if "simple vector"