Commit a92c10e7 authored by Erick's avatar Erick

Added `start` and `end` parameters to R7RS `vector-fill!`

parent bd721d25
This source diff could not be displayed because it is too large. You can view the blob instead.
This source diff could not be displayed because it is too large. You can view the blob instead.
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
* *
* Author: Erick Gallesio [eg@unice.fr] * Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??? 1993 * Creation date: ??? 1993
* Last file update: 6-Jul-2018 15:39 (eg) * Last file update: 6-Jul-2018 16:20 (eg)
*/ */
#include <string.h> #include <string.h>
...@@ -59,18 +59,32 @@ static void error_bad_list(SCM l) ...@@ -59,18 +59,32 @@ static void error_bad_list(SCM l)
} }
static SCM control_index(int argc, SCM *argv, int *pstart, int *pend) static SCM control_index(int argc, SCM *argv, long *pstart, long *pend, SCM *pfill)
{ {
SCM v = NULL; SCM v = NULL;
long len, start=0, end=-1; long len, start=0, end=-1;
/* Controling number of arguments */ /* Controling number of arguments */
switch (argc) { if (!pfill) {
case 1: v = argv[0]; break; /* We do not have a fill parameter => vect at 0, start at -1 and end at -2 */
case 2: v = argv[0]; start = STk_integer_value(argv[-1]); break; switch (argc) {
case 3: v = argv[0]; start = STk_integer_value(argv[-1]); case 3: end = STk_integer_value(argv[-2]); /* no break */
end = STk_integer_value(argv[-2]); break; case 2: start = STk_integer_value(argv[-1]); /* no break */
default: STk_error("incorrect number of arguments (%d)", argc); case 1: v = argv[0]; break;
default: goto bad_number_of_args;
}
} else {
/* We have a fill param. => vect at 0, fill at -1, start at -2 and end at -3 */
switch (argc) {
case 4: end = STk_integer_value(argv[-3]); /* no break */
case 3: start = STk_integer_value(argv[-2]); /* no break */
case 2: if (pfill) *pfill = argv[-1];
v = argv[0];
break;
default:
bad_number_of_args:
STk_error("incorrect number of arguments (%d)", argc);
}
} }
/* Controlling s */ /* Controlling s */
...@@ -80,7 +94,7 @@ static SCM control_index(int argc, SCM *argv, int *pstart, int *pend) ...@@ -80,7 +94,7 @@ static SCM control_index(int argc, SCM *argv, int *pstart, int *pend)
/* Controlling start index */ /* Controlling start index */
if (start == LONG_MIN || start < 0 || start > len) if (start == LONG_MIN || start < 0 || start > len)
/* argc cannot be 1 (start would be 0) */ /* argc cannot be 1 (start would be 0) */
STk_error("bad starting index ~S", argv[-1]); STk_error("bad starting index ~S", argv[pfill ? -2: -1]);
/* Controlling end index */ /* Controlling end index */
if (end == -1) if (end == -1)
...@@ -88,7 +102,7 @@ static SCM control_index(int argc, SCM *argv, int *pstart, int *pend) ...@@ -88,7 +102,7 @@ static SCM control_index(int argc, SCM *argv, int *pstart, int *pend)
else else
if (end == LONG_MIN || end < 0 || end > len) if (end == LONG_MIN || end < 0 || end > len)
/* We have an end index ==> argc = 3 */ /* We have an end index ==> argc = 3 */
STk_error("bad ending index ~S", argv[-2]); STk_error("bad ending index ~S", argv[pfill? -3: -2]);
if (start > end) if (start > end)
STk_error("low index is greater than high index"); STk_error("low index is greater than high index");
...@@ -349,10 +363,10 @@ doc> ...@@ -349,10 +363,10 @@ doc>
*/ */
DEFINE_PRIMITIVE("vector-copy", vector_copy, vsubr, (int argc, SCM *argv)) DEFINE_PRIMITIVE("vector-copy", vector_copy, vsubr, (int argc, SCM *argv))
{ {
int start, end, n; long start, end, n;
SCM z, vect; SCM z, vect;
vect = control_index(argc, argv, &start, &end); vect = control_index(argc, argv, &start, &end, NULL);
n = end-start; n = end-start;
z = STk_makevect(n, (SCM) NULL); z = STk_makevect(n, (SCM) NULL);
memcpy(VECTOR_DATA(z), VECTOR_DATA(vect)+start, n * sizeof(SCM)); memcpy(VECTOR_DATA(z), VECTOR_DATA(vect)+start, n * sizeof(SCM));
...@@ -395,23 +409,27 @@ DEFINE_PRIMITIVE("vector-append", vector_append, vsubr, (int argc, SCM *argv)) ...@@ -395,23 +409,27 @@ DEFINE_PRIMITIVE("vector-append", vector_append, vsubr, (int argc, SCM *argv))
} }
/* /*
<doc vector-fill! <doc R57RS vector-fill!
* (vector-fill! vector fill) * (vector-fill! vector fill)
* (vector-fill! vector fill start)
* (vector-fill! vector fill start end)
*
* Stores |fill| in every element of |vector| between |start| and |end|.
* *
* Stores |fill| in every element of |vector|. The value returned by * ,@("Note"): The R5RS version of |vector-fill!| accepts only one
* |vector-fill!| is ,(emph "void"). * parameter.
doc> doc>
*/ */
DEFINE_PRIMITIVE("vector-fill!", vector_fill, subr2, (SCM v, SCM fill)) DEFINE_PRIMITIVE("vector-fill!", vector_fill, vsubr, (int argc, SCM *argv))
{ {
int j, len; SCM fill, v;
SCM *p; long start, end;
if (!VECTORP(v)) error_bad_vector(v); v = control_index(argc, argv, &start, &end, &fill);
if (BOXED_INFO(v) & VECTOR_CONST) error_change_const_vector(v); if (BOXED_INFO(v) & VECTOR_CONST) error_change_const_vector(v);
for (j=0, len=VECTOR_SIZE(v), p=VECTOR_DATA(v); j < len; j++) while (start < end)
*p++ = fill; VECTOR_DATA(v)[start++]= fill;
return STk_void; return STk_void;
} }
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg) ;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 6-Jul-2018 15:45 (eg) ;;;; Last file update: 6-Jul-2018 16:55 (eg)
;;;; ;;;;
(require "test") (require "test")
...@@ -240,6 +240,22 @@ ...@@ -240,6 +240,22 @@
(test "chibi vector-append.6" #(a b c d e f) (vector-append #(a b c) #(d e) #(f))) (test "chibi vector-append.6" #(a b c d e f) (vector-append #(a b c) #(d e) #(f)))
(test "chibi vector-fill!.1" #(1 2 smash smash 5)
(let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'smash 2 4) vec))
(test "chibi vector-fill!.2" #(x x x x x)
(let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x) vec))
(test "chibi vector-fill!.3" #(1 2 x x x)
(let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2) vec))
(test "chibi vector-fill!.4" #(1 2 x 4 5)
(let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 3) vec))
(test "vector-fill!.5" #(1 2 x x x)
(let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 5) vec))
(test "vector-fill!.6" *test-failed*
(let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 6) vec))
(test "vector-fill!.7" #(1 2 3 4 5)
(let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 2) vec))
;;------------------------------------------------------------------ ;;------------------------------------------------------------------
(test-subsection "Lists and Pairs") (test-subsection "Lists and Pairs")
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment