From a34c762de0cda0fdd56fd582de0cdc71eab2116e Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Thu, 5 Aug 2021 19:43:21 +0200 Subject: Extend core vector-copy to r7rs vector-copy * libguile/vectors.h: Declare scm_vector_copy_partial. * libguile/vectors.c (scm_vector_copy_partial): As stated. (scm_vector_copy): Reuse scm_vector_copy_partial. * module/scheme/base.scm: Reuse core vector-copy. * module/srfi/srfi-43: Reuse core vector-copy. * test-suite/tests/vectors.test: Test vector-copy. --- module/srfi/srfi-43.scm | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) (limited to 'module/srfi/srfi-43.scm') 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 () -- cgit v1.2.3 From 5df5555d12f1408a66a5368a918abb981edf5445 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 6 Aug 2021 16:51:40 +0200 Subject: Add function vector-copy! to core This is up to 20%-30% faster than the previous versions in (scheme base) or (srfi srfi-43) that used vector-move-left!/vector-move-right!. * libguile/vectors.h: * libguile/vectors.c: As stated. * doc/ref/api-data.texi (vector-copy!): Document the new function. (vector-fill!): Document optional arguments. (vector-copy): Document optional arguments. * module/scheme/base.scm: Reuse core vector-copy!. * module/srfi/srfi-43.scm: Reuse core vector-copy!. --- doc/ref/api-data.texi | 36 +++++++++++++++++++++++++++++++----- libguile/vectors.c | 42 ++++++++++++++++++++++++++++++++++++++++++ libguile/vectors.h | 6 +++--- module/scheme/base.scm | 17 ++--------------- module/srfi/srfi-43.scm | 17 ++--------------- 5 files changed, 80 insertions(+), 38 deletions(-) (limited to 'module/srfi/srfi-43.scm') diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index eb3d91060..a3e6d6c31 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -6381,16 +6381,38 @@ Store @var{obj} in position @var{k} (a @code{size_t}) of @var{vec}. @end deftypefn @rnindex vector-fill! -@deffn {Scheme Procedure} vector-fill! vec fill +@deffn {Scheme Procedure} vector-fill! vec fill [start [end]] @deffnx {C Function} scm_vector_fill_x (vec, fill) -Store @var{fill} in every position of @var{vec}. The value -returned by @code{vector-fill!} is unspecified. +Store @var{fill} in every position of @var{vec} in the range +[@var{start} ... @var{end}). @var{start} defaults to 0 and @var{end} +defaults to the length of @var{vec}. + +The value returned by @code{vector-fill!} is unspecified. @end deffn @rnindex vector-copy -@deffn {Scheme Procedure} vector-copy vec +@deffn {Scheme Procedure} vector-copy vec [start [end]] @deffnx {C Function} scm_vector_copy (vec) -Return a copy of @var{vec}. +Returns a freshly allocated vector containing the elements of @var{vec} +in the range [@var{start} ... @var{end}). @var{start} defaults to 0 and +@var{end} defaults to the length of @var{vec}. +@end deffn + +@rnindex vector-copy! +@deffn {Scheme Procedure} vector-copy! dst at src [start [end]] +Copy the block of elements from vector @var{src} in the range +[@var{start} ... @var{end}) into vector @var{dst}, starting at position +@var{at}. @var{at} and @var{start} default to 0 and @var{end} defaults +to the length of @var{src}. + +It is an error for @var{dst} to have a length less than @var{at} + +(@var{end} - @var{start}). + +The order in which elements are copied is unspecified, except that if the +source and destination overlap, copying takes place as if the source is +first copied into a temporary vector and then into the destination. + +The value returned by @code{vector-copy!} is unspecified. @end deffn @deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2 @@ -6403,6 +6425,8 @@ to @var{vec2} starting at position @var{start2}. @var{start1} and Therefore, in the case where @var{vec1} and @var{vec2} refer to the same vector, @code{vector-move-left!} is usually appropriate when @var{start1} is greater than @var{start2}. + +The value returned by @code{vector-move-left!} is unspecified. @end deffn @deffn {Scheme Procedure} vector-move-right! vec1 start1 end1 vec2 start2 @@ -6415,6 +6439,8 @@ to @var{vec2} starting at position @var{start2}. @var{start1} and Therefore, in the case where @var{vec1} and @var{vec2} refer to the same vector, @code{vector-move-right!} is usually appropriate when @var{start1} is less than @var{start2}. + +The value returned by @code{vector-move-right!} is unspecified. @end deffn @node Vector Accessing from C diff --git a/libguile/vectors.c b/libguile/vectors.c index 3a2ff7ab5..40e80ddd2 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -329,6 +329,48 @@ scm_vector_copy (SCM vec) return scm_vector_copy_partial (vec, SCM_UNDEFINED, SCM_UNDEFINED); } +SCM_DEFINE (scm_vector_copy_x, "vector-copy!", 3, 2, 0, + (SCM dst, SCM at, SCM src, SCM start, SCM end), + "Copy a block of elements from @var{src} to @var{dst}, both of which must be\n" + "vectors, starting in @var{dst} at @var{at} and starting in @var{src} at\n" + "@var{start} and ending at @var{end}.\n\n" + "It is an error for @var{dst} to have a length less than\n" + "@var{at} + (@var{end} - @var{start}). @var{at} and @var{start} default\n" + "to 0 and @var{end} defaults to the length of @var{src}.\n\n" + "The order in which elements are copied is unspecified, except that if the\n" + "source and destination overlap, copying takes place as if the source is\n" + "first copied into a temporary vector and then into the destination.") +#define FUNC_NAME s_scm_vector_copy_x +{ + SCM_VALIDATE_MUTABLE_VECTOR (1, dst); + SCM_VALIDATE_VECTOR (3, src); + size_t src_org = 0; + size_t dst_org = scm_to_size_t (at); + size_t src_end = SCM_I_VECTOR_LENGTH (src); + size_t dst_end = SCM_I_VECTOR_LENGTH (dst); + + if (!SCM_UNBNDP (start)) + { + src_org = scm_to_size_t (start); + SCM_ASSERT_RANGE (SCM_ARG4, start, src_org<=src_end); + + if (!SCM_UNBNDP (end)) + { + size_t e = scm_to_size_t (end); + SCM_ASSERT_RANGE (SCM_ARG5, end, e>=src_org && e<=src_end); + src_end = e; + } + } + size_t len = src_end-src_org; + SCM_ASSERT_RANGE (SCM_ARG2, at, dst_org<=dst_end && len<=dst_end-dst_org); + + memmove (SCM_I_VECTOR_WELTS (dst) + dst_org, SCM_I_VECTOR_ELTS (src) + src_org, + len * sizeof(SCM)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, (SCM vec), diff --git a/libguile/vectors.h b/libguile/vectors.h index 1c04f9afe..78abc16f2 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -41,6 +41,8 @@ SCM_API SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1, SCM_API SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2); SCM_API SCM scm_vector_copy (SCM vec); +SCM_API SCM scm_vector_copy_partial (SCM vec, SCM start, SCM end); +SCM_API SCM scm_vector_copy_x (SCM dst, SCM at, SCM src, SCM start, SCM end); SCM_API int scm_is_vector (SCM obj); SCM_API int scm_is_simple_vector (SCM obj); @@ -87,9 +89,7 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec, #define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1)) #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 SCM scm_i_vector_equal_p (SCM x, SCM y); SCM_INTERNAL void scm_init_vectors (void); #endif /* SCM_VECTORS_H */ diff --git a/module/scheme/base.scm b/module/scheme/base.scm index c57bdf110..c6a73c092 100644 --- a/module/scheme/base.scm +++ b/module/scheme/base.scm @@ -57,7 +57,7 @@ string->vector vector->string (r7:string->utf8 . string->utf8) (r7:vector->list . vector->list) - vector-copy! vector-append vector-for-each vector-map + vector-append vector-for-each vector-map (r7:bytevector-copy . bytevector-copy) (r7:bytevector-copy! . bytevector-copy!) (r7:utf8->string . utf8->string) @@ -114,7 +114,7 @@ (char-ready? . u8-ready?) unless unquote unquote-splicing values - vector vector-copy vector-fill! + vector vector-copy vector-copy! vector-fill! vector-length vector-ref vector-set! vector? when with-exception-handler write-char zero?)) @@ -431,19 +431,6 @@ ;;; vector -(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 -vectors, starting in TARGET at TSTART and starting in SOURCE at SSTART, -ending when SEND - SSTART elements have been copied. It is an error for -TARGET to have a length less than TSTART + (SEND - SSTART). SSTART -defaults to 0 and SEND defaults to the length of SOURCE." - (let ((tlen (vector-length target)) - (slen (vector-length source))) - (if (< tstart sstart) - (vector-move-left! source sstart send target tstart) - (vector-move-right! source sstart send target tstart)))) - (define r7:vector->list (case-lambda* ((v) (vector->list v)) diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm index f8e38e27c..18e97cf53 100644 --- a/module/srfi/srfi-43.scm +++ b/module/srfi/srfi-43.scm @@ -22,7 +22,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-8) #:re-export (make-vector vector vector? vector-ref vector-set! - vector-length vector-fill!) + vector-length vector-fill! vector-copy!) #:replace (vector-copy list->vector vector->list) #:export (vector-empty? vector= vector-unfold vector-unfold-right vector-reverse-copy @@ -35,7 +35,7 @@ vector-binary-search vector-any vector-every vector-swap! vector-reverse! - vector-copy! vector-reverse-copy! + vector-reverse-copy! reverse-vector->list reverse-list->vector)) @@ -933,19 +933,6 @@ START defaults to 0 and END defaults to the length of VEC." (error-from 'copy! "would write past end of target")) (%copy! target tstart source sstart send))))))) -(define-vector-copier! vector-copy! - "(vector-copy! target tstart source [sstart [send]]) -> unspecified - -Copy a block of elements from SOURCE to TARGET, both of which must be -vectors, starting in TARGET at TSTART and starting in SOURCE at -SSTART, ending when SEND - SSTART elements have been copied. It is an -error for TARGET to have a length less than TSTART + (SEND - SSTART). -SSTART defaults to 0 and SEND defaults to the length of SOURCE." - (lambda (target tstart source sstart send) - (if (< tstart sstart) - (vector-move-left! source sstart send target tstart) - (vector-move-right! source sstart send target tstart)))) - (define-vector-copier! vector-reverse-copy! "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified -- cgit v1.2.3