Commit 3882e2f0 authored by Erick's avatar Erick

Extended vector-copy to be R7RS and added the R7RS vector-copy!

parent 6b1bf4dc
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 5-Jul-2018 16:50 (eg)
;; Last file update: 6-Jul-2018 08:57 (eg)
;;
;; ======================================================================
......@@ -389,6 +389,7 @@ following: ,(fontified-code [#(0 (2 2 2 2) "Anna")])])
(insertdoc 'string->vector)
(insertdoc 'vector-fill!)
(insertdoc 'vector-copy)
(insertdoc 'vector-copy!)
(insertdoc 'vector-resize)
(insertdoc 'vector-mutable?)
(insertdoc 'sort))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 5-Jul-2018 17:34 (eg)
;;;; Last file update: 6-Jul-2018 08:56 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -232,6 +232,54 @@ doc>
(%set-procedure-name! vector->list 'vector->list))
#|
<doc R7RS vector-copy!
* (vector-copy! to at from)
* (vector-copy! to at from start)
* (vector-copy! to at from start end)
*
doc>
|#
(define (vector-copy! to at from :optional (start 0 start?) (end 0 end?))
(define (err . l)
(apply error 'vector-copy! l))
(define (%vector-copy! to tstart from fstart fend)
(if (> fstart tstart)
(do ((i fstart (+ i 1))
(j tstart (+ j 1)))
((>= i fend))
(vector-set! to j (vector-ref from i)))
(do ((i (- fend 1) (- i 1))
(j (+ -1 tstart (- fend fstart)) (- j 1)))
((< i fstart))
(vector-set! to j (vector-ref from i)))))
;; body starts here
(unless (vector? to) (err "bad vector ~S" to))
(unless (vector? from) (err "bad vector ~S" from))
(let ((length-from (vector-length from))
(length-to (vector-length to)))
(unless (and (integer? at) (>= at 0) (< at length-to))
(err "bad destination index ~S" at))
(when start?
(unless (and (integer? start) (>= start 0) (<= start length-from))
(err "bad integer for start index ~S" start)))
(if end?
(unless (and (integer? end) (>= end 0) (<= end length-from))
(err "bad integer for end index ~S" end))
(set! end (vector-length from)))
(when (< (- length-to at) (- end start))
(err "not enough room in destination vector ~S" to))
;; do the copy
(%claim-error 'vector-copy!
(%vector-copy! to at from start end))))
#|
<doc R7RS vector->string string->vector
* (vector->string string)
......
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??? 1993
* Last file update: 5-Jul-2018 17:20 (eg)
* Last file update: 6-Jul-2018 08:45 (eg)
*/
#include <string.h>
......@@ -59,6 +59,59 @@ static void error_bad_list(SCM l)
}
static SCM control_index(int argc, SCM *argv, int *pstart, int *pend)
{
SCM v = NULL;
long len, start=0, end=-1;
/* Controling number of arguments */
switch (argc) {
case 1: v = argv[0]; break;
case 2: v = argv[0]; start = STk_integer_value(argv[-1]); break;
case 3: v = argv[0]; start = STk_integer_value(argv[-1]);
end = STk_integer_value(argv[-2]); break;
default: STk_error("incorrect number of arguments (%d)", argc);
}
/* Controlling s */
if (!VECTORP(v)) error_bad_vector(v);
len = VECTOR_SIZE(v);
/* Controlling start index */
if (start == LONG_MIN || start < 0 || start > len)
/* argc cannot be 1 (start would be 0) */
STk_error("bad starting index ~S", argv[-1]);
/* Controlling end index */
if (end == -1)
end = len;
else
if (end == LONG_MIN || end < 0 || end > len)
/* We have an end index ==> argc = 3 */
STk_error("bad ending index ~S", argv[-2]);
if (start > end)
STk_error("low index is greater than high index");
/* everything is correct, return values */
*pstart = start;
*pend = end;
return v;
}
static SCM r5rs_vector_copy(SCM vect)
{
SCM z;
int n;
if (!VECTORP(vect)) error_bad_vector(vect);
n = VECTOR_SIZE(vect);
z = STk_makevect(n, (SCM) NULL);
memcpy(VECTOR_DATA(z), VECTOR_DATA(vect), n * sizeof(SCM));
return z;
}
SCM STk_makevect(int len, SCM init)
{
......@@ -221,12 +274,15 @@ DEFINE_PRIMITIVE("vector-set!", vector_set, subr3, (SCM v, SCM index, SCM value)
* newly created vector initialized to the elements of the list |list|.
*
* In both procedures, order is preserved.
*
*
* @lisp
* (vector->list '#(dah dah didah)) => (dah dah didah)
* (vector->list '#(dah dah didah) 1 2) => (dah)
* (list->vector '(dididit dah)) => #(dididit dah)
* @end lisp
*
*,@("Note"): The R5RS version of |vector->list| accepts only one
* parameter.
doc>
*/
......@@ -267,6 +323,42 @@ DEFINE_PRIMITIVE("list->vector", list2vector, subr1, (SCM l))
}
/*
<doc R57RS vector-copy
* (vector-copy v)
* (vector-copy string start)
* (vector-copy string start stop)
*
* Return a newly allocated copy of the elements of the given
* vector between |start| and |end| . The elements of the new
* vector are the same (in the sense of eqv?) as the elements
* of the old.
*
* Note that, if |v| is a constant vector, its copy is not constant.
*
* @lisp
* (define a #(1 8 2 8)) ; a is immutable
* (define b (vector-copy a)) ; b is mutable
* (vector-set! b 0 3)
* b => #(3 8 2 8)
* (define c (vector-copy b 1 3))
* c => #(8 2)
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("vector-copy", vector_copy, vsubr, (int argc, SCM *argv))
{
int start, end, n;
SCM z, vect;
vect = control_index(argc, argv, &start, &end);
n = end-start;
z = STk_makevect(n, (SCM) NULL);
memcpy(VECTOR_DATA(z), VECTOR_DATA(vect)+start, n * sizeof(SCM));
return z;
}
/*
<doc vector-fill!
* (vector-fill! vector fill)
......@@ -296,26 +388,6 @@ DEFINE_PRIMITIVE("vector-fill!", vector_fill, subr2, (SCM v, SCM fill))
*
*/
/*
<doc EXT vector-copy
* (vector-copy v)
*
* Return a copy of vector |v|. Note that, if |v| is a constant vector,
* its copy is not constant.
doc>
*/
DEFINE_PRIMITIVE("vector-copy", vector_copy, subr1, (SCM vect))
{
SCM z;
int n;
if (!VECTORP(vect)) error_bad_vector(vect);
n = VECTOR_SIZE(vect);
z = STk_makevect(n, (SCM) NULL);
memcpy(VECTOR_DATA(z), VECTOR_DATA(vect), n * sizeof(SCM));
return z;
}
/*
<doc EXT vector-resize
......@@ -398,7 +470,7 @@ DEFINE_PRIMITIVE("sort", sort, subr2, (SCM obj, SCM test))
if (NULLP(obj)) { return STk_nil; }
else if (CONSP(obj)) { obj = STk_list2vector(obj); list = 1; }
else if (VECTORP(obj)) { obj = STk_vector_copy(obj); }
else if (VECTORP(obj)) { obj = r5rs_vector_copy(obj); }
else { STk_error("bad object to sort: ~S", obj); }
/*
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 5-Jul-2018 17:41 (eg)
;;;; Last file update: 6-Jul-2018 09:16 (eg)
;;;;
(require "test")
......@@ -178,7 +178,49 @@
(test "Extended vector->list.3" '(1 2) (vector->list '#(1 2 3) 0 2))
(test "Extended vector->list.4" *test-failed* (vector->list '#(1 2 3) 0 7))
(let ((v #(a b c d e f)))
(test "Extended vector-copy.1" #(a b c d e f) (vector-copy v))
(test "Extended vector-copy.2" #(c d e f) (vector-copy v 2))
(test "Extended vector-copy.3" #(c d e) (vector-copy v 2 5))
(test "Extended vector-copy.4" *test-failed* (vector-copy v 2 100)))
(let ((vect #(a b c d e f)))
(test "vector-copy!.1"
#(a b c 1 2 f)
(let ((v (vector-copy vect))) (vector-copy! v 3 #(1 2)) v))
(test "vector-copy!.2"
*test-failed*
(let ((v (vector-copy vect))) (vector-copy! v 5 #(1 2)) v))
(test "vector-copy!.3"
#(a 2 3 d e f)
(let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 1) v))
(test "vector-copy!.4"
#(a 2 3 d e f)
(let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 1) v))
(test "vector-copy!.5"
#(a 3 c d e f)
(let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 2) v))
(test "vector-copy!.6"
#(a b c d e f)
(let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 3) v))
(test "vector-copy!.7"
#(a 1 2 d e f)
(let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 0 2) v))
(test "vector-copy!.8"
#(a 1 2 3 e f)
(let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 0 3) v))
(test "vector-copy!.9"
*test-failed*
(let ((v (vector-copy vect))) (vector-copy! v 1 #(1 2 3) 0 4) v))
(test "vector-copy!overlap.1"
#(a b a b c f g)
(let ((v (vector 'a 'b 'c 'd 'e 'f 'g)))
(vector-copy! v 2 v 0 3) v))
(test "vector-copy!overlap.2"
#(e f c d e f g)
(let ((v (vector 'a 'b 'c 'd 'e 'f 'g)))
(vector-copy! v 0 v 4 6) v)))
;;------------------------------------------------------------------
(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