Commit 5f36cd3c authored by Erick's avatar Erick

Code cleaning of R7RS bytevector-{length,u8-ref,u8-set!} primitives

parent 08ec2858
......@@ -923,3 +923,7 @@ See SRFI document for more information.])
(insertdoc 'base64-encode-string)
(insertdoc 'base64-decode-string) )
)
;; Local Variables:
;; mode: scheme
;; End:
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 6-Jul-2018 19:11 (eg)
;;;; Last file update: 6-Jul-2018 22:03 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -366,16 +366,6 @@ doc>
(define (bytevector? obj)
(%uvector? 1 obj))
#|
<doc R7RS bytevector-length
* (bytevector-length bytevector)
*
* Returns the length of |bytevector| in bytes as an exact integer.
doc>
|#
(define (bytevector-length bv)
(%uvector-length 1 bv))
#|
<doc R7RS bytevector
* (bytevector byte ...)
......@@ -390,28 +380,50 @@ doc>
(define (bytevector . lst)
(%claim-error 'bytevector (%uvector 1 lst)))
#|
<doc R7RS bytevector-length
* (bytevector-length bytevector)
*
* Returns the length of |bytevector| in bytes as an exact integer.
doc>
|#
(define (bytevector-length bv)
(%claim-error 'bytevector-length (%uvector-length 1 bv)))
#|
<doc R7RS bytevector-u8-ref
* (bytevector-u8-ref bytevector k)
*
* Returns the byte at index |k| of |bytevector| as an exact integer in the
* range [0..255].
* range [0..255]. It is an error if |k| is not a valid index of |bytevector|.
*
* @lisp
* (bytevector-u8-ref ’#u8(1 1 2 3 5 8 13 21) 5 => 8
* @end lisp
doc>
|#
(define (bytevector-u8-ref bv idx)
(%uvector-ref 1 bv idx))
(%claim-error 'bytevector-u8-ref (%uvector-ref 1 bv idx)))
#|
<doc EXT bytevector-u8-set!
* (bytevector-u8-ref bytevector k u8)
* (bytevector-u8-ref bytevector k byte)
*
* Stores |u8| in the byte at index |k| of |bytevector|. |u8| must be an
* exact integer in the range [0..255]. The value returned by
* |bytevector-u8-set!| is ,(emph "void").
* Stores byte as the k th byte of bytevector. It is an error if |k|
* is not a valid index of |bytevector|.
*
* @lisp
* (let ((bv (bytevector 1 2 3 4)))
* (bytevector-u8-set! bv 1 3)
* bv) => #u8(1 3 3 4)
* @end lisp
doc>
|#
(define (bytevector-u8-set! bv idx val)
(%uvector-set! 1 bv idx val))
(%claim-error 'bytevector-u8-set! (%uvector-set! 1 bv idx val)))
#|
<doc R7RS bytevector-copy
......
This diff is collapsed.
This diff is collapsed.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 15-Apr-2001 10:13 (eg)
* Last file update: 6-Jul-2018 17:46 (eg)
* Last file update: 6-Jul-2018 21:48 (eg)
*/
#include "stklos.h"
......@@ -69,6 +69,24 @@ static SCM u64_max, s64_min, s64_max;
*
*/
static char* type_vector(int tip)
{
switch (tip) {
case UVECT_S8: return "s8";
case UVECT_U8: return "u8";
case UVECT_S16: return "s16";
case UVECT_U16: return "u16";
case UVECT_S32: return "s32";
case UVECT_U32: return "u32";
case UVECT_S64: return "s64";
case UVECT_U64: return "u64";
case UVECT_F32: return "f32";
case UVECT_F64: return "f64";
default: return ""; /* never reached */
}
}
static void error_change_const_vector(SCM v)
{
STk_error("changing the constant vector ~s is not allowed", v);
......@@ -79,6 +97,11 @@ static void error_bad_vector(SCM v)
STk_error("bad vector ~s", v);
}
static void error_bad_uvector(SCM v, int tip)
{
STk_error("bad #%s vector ~s", type_vector(tip), v);
}
static void error_bad_index(SCM index)
{
STk_error("index ~S is invalid or out of bounds", index);
......@@ -100,23 +123,6 @@ static void error_bad_list(SCM l)
}
static char* type_vector(SCM vect)
{
switch (UVECTOR_TYPE(vect)) {
case UVECT_S8: return "s8";
case UVECT_U8: return "u8";
case UVECT_S16: return "s16";
case UVECT_U16: return "u16";
case UVECT_S32: return "s32";
case UVECT_U32: return "u32";
case UVECT_S64: return "s64";
case UVECT_U64: return "u64";
case UVECT_F32: return "f32";
case UVECT_F64: return "f64";
default: return ""; /* never reached */
}
}
static int vector_element_size(int type)
{
/* compute len of one element depending of type. We assume here
......@@ -250,7 +256,7 @@ static void uvector_set(int type, SCM v, long i, SCM value)
/* If we arrive here we are sure that we have a value which is out of bounds */
STk_error("value ~S is out of bounds or incorrect for a %svector",
value, type_vector(v));
value, type_vector(UVECTOR_TYPE(v)));
}
static SCM uvector_ref(int type, SCM v, long i)
......@@ -363,7 +369,7 @@ DEFINE_PRIMITIVE("%uvector-length", uvector_length, subr2, (SCM type, SCM v))
long tip = STk_integer_value(type);
if (tip < UVECT_S8 || tip > UVECT_F64) error_bad_uniform_type(type);
if (!UVECTORP(v) || (UVECTOR_TYPE(v) != tip)) error_bad_vector(v);
if (!UVECTORP(v) || (UVECTOR_TYPE(v) != tip)) error_bad_uvector(v, tip);
return MAKE_INT(UVECTOR_SIZE(v));
}
......@@ -452,7 +458,7 @@ static void print_uvector(SCM vect, SCM port, int mode)
int n = UVECTOR_SIZE(vect);
int t = UVECTOR_TYPE(vect);
STk_fprintf(port, "#%s(", type_vector(vect));
STk_fprintf(port, "#%s(", type_vector(UVECTOR_TYPE(vect)));
for (i = 0; i < n; i++) {
STk_print(uvector_ref(t, vect, i), port, mode);
if (i < n - 1) STk_putc(' ', port);
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 6-Jul-2018 19:50 (eg)
;;;; Last file update: 6-Jul-2018 22:11 (eg)
;;;;
(require "test")
......@@ -276,7 +276,26 @@
(test "bytevector.4" *test-failed* (bytevector 1 2 -1))
(test "bytevector.5" *test-failed* (bytevector 1 2 'a))
(test "bytevector-length.1" 5 (bytevector-length (bytevector 1 2 3 4 5)))
(test "bytevector-length.2" 0 (bytevector-length (make-bytevector 0)))
(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))
(test "bytevector-u8-ref.4" *test-failed* (bytevector-u8-ref (bytevector 0 1 2) 3))
(test "bytevector-u8-ref.5" *test-failed* (bytevector-u8-ref (vector 0 1 2) 0))
(test "bytevector-u8-set!.1" #u8(1 3 3 4)
(let ((bv (bytevector 1 2 3 4))) (bytevector-u8-set! bv 1 3) bv))
(test "bytevector-u8-set!.2" #u8(100 2 3 4)
(let ((bv (bytevector 1 2 3 4))) (bytevector-u8-set! bv 0 100) bv))
(test "bytevector-u8-set!.3" *test-failed*
(let ((bv (bytevector))) (bytevector-u8-set! bv 0 100) bv))
(test "bytevector-u8-set!.4" *test-failed*
(let ((bv #u8(1 2 3))) (bytevector-u8-set! bv 0 100) bv))
;;------------------------------------------------------------------
(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