diff options
-rw-r--r-- | doc/ref/api-data.texi | 1 | ||||
-rw-r--r-- | libguile/vectors.c | 40 | ||||
-rw-r--r-- | libguile/vectors.h | 2 | ||||
-rw-r--r-- | module/scheme/base.scm | 24 | ||||
-rw-r--r-- | module/srfi/srfi-43.scm | 26 | ||||
-rw-r--r-- | test-suite/tests/vectors.test | 9 |
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" |