Commit a6d17fa6 authored by Erick's avatar Erick

Re-implementation of R7RS bytevector-copy

parent 5f36cd3c
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 6-Jul-2018 22:03 (eg)
;;;; Last file update: 9-Jul-2018 19:32 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -425,22 +425,6 @@ doc>
(define (bytevector-u8-set! bv idx val)
(%claim-error 'bytevector-u8-set! (%uvector-set! 1 bv idx val)))
#|
<doc R7RS bytevector-copy
* (bytevector-copy bytevector)
*
* Returns a newly allocated bytevector containing the same bytes as |bytevector|.
doc>
|#
(define (bytevector-copy bv)
(unless (bytevector? bv)
(error "bad bytevector ~S" bv))
(let* ((len (bytevector-length bv))
(new (make-bytevector len)))
(dotimes (i len)
(bytevector-u8-set! new i (bytevector-u8-ref bv i)))
new))
#|
<doc R7RS bytevector-copy!
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 15-Apr-2001 10:13 (eg)
* Last file update: 6-Jul-2018 21:48 (eg)
* Last file update: 9-Jul-2018 19:34 (eg)
*/
#include "stklos.h"
......@@ -145,6 +145,60 @@ static int vector_element_size(int type)
}
static SCM control_index(int argc, SCM *argv, long *pstart, long *pend, SCM *pfill)
{
SCM v = NULL;
long len, start=0, end=-1;
/* Controling number of arguments */
if (!pfill) {
/* We do not have a fill parameter => vect at 0, start at -1 and end at -2 */
switch (argc) {
case 3: end = STk_integer_value(argv[-2]); /* no break */
case 2: start = STk_integer_value(argv[-1]); /* no break */
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 */
if (!UVECTORP(v)) error_bad_uvector(v, UVECT_U8);
len = UVECTOR_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[pfill ? -2: -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[pfill? -3: -2]);
if (start > end)
STk_error("low index is greater than high index");
/* everything is correct, return values */
*pstart = start;
*pend = end;
return v;
}
/* Return the type of an uniform vector given its tag */
int STk_uniform_vector_tag(char *s)
......@@ -473,6 +527,37 @@ static struct extended_type_descr xtype_uvector = {
};
/*==========================================================================*/
/* */
/* B Y T E V E C T O R S */
/* */
/*==========================================================================*/
/*
<doc R7RS bytevector-copy
* (bytevector-copy bytevector)
* (bytevector-copy bytevector start)
* (bytevector-copy bytevector start end)
*
* Returns a newly allocated bytevector containing the bytes in |bytevector|
* between |start| and |end|.
* @lisp
* (define a #u8(1 2 3 4 5))
* (bytevector-copy a 2 4)) => #u8(3 4)
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("bytevector-copy", bytevector_copy, vsubr, (int argc, SCM *argv))
{
long start, end, n;
SCM z, bvect;
bvect = control_index(argc, argv, &start, &end, NULL);
n = end-start;
z = makeuvect(UVECT_U8, n, (SCM) NULL);
memcpy(UVECTOR_DATA(z),
(unsigned char *)UVECTOR_DATA(bvect)+start,
n * sizeof(unsigned char));
return z;
}
int STk_init_uniform_vector(void)
......@@ -489,6 +574,9 @@ int STk_init_uniform_vector(void)
ADD_PRIMITIVE(uvector_ref);
ADD_PRIMITIVE(uvector_set);
/* R7RS specific bytevectors primitives */
ADD_PRIMITIVE(bytevector_copy);
/* A pseudo primitive to launch the definition of all the function of SRFI-4 */
ADD_PRIMITIVE(allow_uvectors);
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 6-Jul-2018 22:11 (eg)
;;;; Last file update: 9-Jul-2018 19:40 (eg)
;;;;
(require "test")
......@@ -281,7 +281,6 @@
(test "bytevector-length.3" 100 (bytevector-length (make-bytevector 100)))
(test "bytevector-length.4" 100 (bytevector-length (make-bytevector 100 42)))
(test "bytevector-u8-ref.1" 0 (bytevector-u8-ref (bytevector 0 1 2) 0))
(test "bytevector-u8-ref.2" 1 (bytevector-u8-ref (bytevector 0 1 2) 1))
(test "bytevector-u8-ref.3" 2 (bytevector-u8-ref (bytevector 0 1 2) 2))
......@@ -297,6 +296,11 @@
(test "bytevector-u8-set!.4" *test-failed*
(let ((bv #u8(1 2 3))) (bytevector-u8-set! bv 0 100) bv))
(test "bytevector-copy.1" #u8() (bytevector-copy #u8()))
(test "bytevector-copy.2" #u8(0 1 2 3 4 5) (bytevector-copy #u8(0 1 2 3 4 5)))
(test "bytevector-copy.3" #u8(2 3 4 5) (bytevector-copy #u8(0 1 2 3 4 5) 2))
(test "bytevector-copy.4" #u8(2 3) (bytevector-copy #u8(0 1 2 3 4 5) 2 4))
;;------------------------------------------------------------------
(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