Hello fellow Schemers!
I have locally implemented and used srfi-4 (Homogeneous numeric vector
datatypes) and have attached a patch against git HEAD here.
All the different vector types of srfi-4 are subsumed in a new type
TC_INTVEC (which replaces the commented-out TC_COMBINATION_1 0x07, but
could use any other code). The first byte contains the element size in
bytes and the signedness, after that all the indexed elements follow.
The following new primitives are implemented:
(integer-vector-cons length element-size-in-bytes signedness)
(integer-vector-type intvec)
(integer-vector-ref intvec index element-size-in-bytes signedness)
(integer-vector-set! intvec index value element-size-in-bytes)
(integer-vector-length intvec element-size-in-bytes)
(integer-vector? intvec)
These are exposed as intvec-...
A new package (runtime srfi-4) implements all of srfi-4 with the
following exceptions:
- The f32/f64 functions all map to the respective flo:vector..
functions.
- Neither parse nor unparse is implemented for f32/f64.
The test suite code is taken from guile Scheme, if that is impossible
due to licensing problems, I could provide newly-written code.
This functionality is very useful for the FFI, especially with things
like OpenGL, as it allows to populate the relevant data arrays directly
from Scheme.
I'd be glad about any comments on whether this would be acceptable for
inclusion in MIT/GNU Scheme proper. I'll update and change the code if
you have any suggestions for that. I'd also update the documentation. It
might be useful to extend this for f32/f64 too (converting an f32 to a
normal boxed double when it is accessed) to implement all of srfi-4.
Thank you for any comments and suggestions,
Peter
diff --git a/src/compiler/machines/C/machin.scm b/src/compiler/machines/C/machin.scm
index 6f36d52..c88ee05 100644
--- a/src/compiler/machines/C/machin.scm
+++ b/src/compiler/machines/C/machin.scm
@@ -302,4 +302,4 @@ USA.
(define compiler:primitives-with-no-open-coding
'(DIVIDE-FIXNUM GCD-FIXNUM &/
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
\ No newline at end of file
+ VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS INTEGER-VECTOR-CONS))
diff --git a/src/compiler/machines/x86-64/machin.scm b/src/compiler/machines/x86-64/machin.scm
index 7f817a4..5767b11 100644
--- a/src/compiler/machines/x86-64/machin.scm
+++ b/src/compiler/machines/x86-64/machin.scm
@@ -414,7 +414,7 @@ USA.
(define compiler:primitives-with-no-open-coding
'(DIVIDE-FIXNUM
&/
- FLOATING-VECTOR-CONS FLONUM-ACOS FLONUM-ASIN FLONUM-ATAN
+ FLOATING-VECTOR-CONS INTEGER-VECTOR-CONS FLONUM-ACOS FLONUM-ASIN FLONUM-ATAN
FLONUM-ATAN2 FLONUM-CEILING FLONUM-COS FLONUM-EXP FLONUM-EXPM1
FLONUM-FLOOR FLONUM-LOG FLONUM-LOG1P FLONUM-ROUND FLONUM-SIN
- FLONUM-TAN FLONUM-TRUNCATE GCD-FIXNUM STRING-ALLOCATE VECTOR-CONS))
\ No newline at end of file
+ FLONUM-TAN FLONUM-TRUNCATE GCD-FIXNUM STRING-ALLOCATE VECTOR-CONS))
diff --git a/src/microcode/debug.c b/src/microcode/debug.c
index ca6b9d4..dddb607 100644
--- a/src/microcode/debug.c
+++ b/src/microcode/debug.c
@@ -396,6 +396,10 @@ do_printing (outf_channel stream, SCHEME_OBJECT Expr, bool Detailed)
outf (stream, "%lf", (FLONUM_TO_DOUBLE (Expr)));
return;
+ case TC_INTVEC:
+ outf (stream, "intvec");
+ return;
+
case TC_WEAK_CONS:
case TC_LIST:
print_list (stream, Expr);
diff --git a/src/microcode/fixnum.c b/src/microcode/fixnum.c
index 8e32c14..f182d12 100644
--- a/src/microcode/fixnum.c
+++ b/src/microcode/fixnum.c
@@ -33,7 +33,7 @@ USA.
#include "prims.h"
#include "fixnum.h"
-static long
+long
arg_fixnum (int n)
{
SCHEME_OBJECT argument = (ARG_REF (n));
diff --git a/src/microcode/gcloop.c b/src/microcode/gcloop.c
index d7153a7..a95d801 100644
--- a/src/microcode/gcloop.c
+++ b/src/microcode/gcloop.c
@@ -356,6 +356,7 @@ initialize_gc_table (gc_table_t * table, bool transport_p)
(GCT_ENTRY (table, TC_WEAK_CONS)) = gc_handle_weak_pair;
(GCT_ENTRY (table, TC_EPHEMERON)) = gc_handle_ephemeron;
(GCT_ENTRY (table, TC_BIG_FLONUM)) = gc_handle_aligned_vector;
+ (GCT_ENTRY (table, TC_INTVEC)) = gc_handle_aligned_vector;
(GCT_ENTRY (table, TC_COMPILED_CODE_BLOCK)) = gc_handle_aligned_vector;
(GCT_TUPLE (table)) = gc_tuple;
(GCT_VECTOR (table)) = gc_vector;
@@ -1258,7 +1259,7 @@ gc_type_t gc_type_map [N_TYPE_CODES] =
GC_UNDEFINED, /* was TC_PCOMB2 */
GC_PAIR, /* TC_UNINTERNED_SYMBOL */
GC_VECTOR, /* TC_BIG_FLONUM */
- GC_UNDEFINED, /* was TC_COMBINATION_1 */
+ GC_VECTOR, /* TC_INTVEC */
GC_NON_POINTER, /* TC_CONSTANT */
GC_PAIR, /* TC_EXTENDED_PROCEDURE */
GC_VECTOR, /* TC_VECTOR */
diff --git a/src/microcode/interp.c b/src/microcode/interp.c
index fce91c3..3e54628 100644
--- a/src/microcode/interp.c
+++ b/src/microcode/interp.c
@@ -407,6 +407,7 @@ Interpret (int pop_return_p)
{
case TC_BIG_FIXNUM: /* The self evaluating items */
case TC_BIG_FLONUM:
+ case TC_INTVEC:
case TC_CHARACTER_STRING:
case TC_CHARACTER:
case TC_COMPILED_CODE_BLOCK:
diff --git a/src/microcode/intvec.c b/src/microcode/intvec.c
new file mode 100644
index 0000000..a77348a
--- /dev/null
+++ b/src/microcode/intvec.c
@@ -0,0 +1,272 @@
+/* -*-C-*-
+
+ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
+ Massachusetts Institute of Technology
+
+ This file is part of MIT/GNU Scheme.
+
+ MIT/GNU Scheme is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at
+ your option) any later version.
+
+ MIT/GNU Scheme is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with MIT/GNU Scheme; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+ USA.
+
+*/
+
+/* Integer vector primitives */
+#include <stdio.h>
+#include "scheme.h"
+#include "prims.h"
+
+static long
+arg_big_fixnum (int n)
+{
+ SCHEME_OBJECT argument = (ARG_REF (n));
+ if (FIXNUM_P (argument))
+ return (FIXNUM_TO_LONG (argument));
+ else if(BIGNUM_P (argument))
+ return (long)bignum_to_long ((bignum_type)argument);
+ else
+ error_wrong_type_arg (n);
+
+}
+static long
+arg_vector_size (int arg_number)
+{
+ long result = (arg_nonnegative_integer (arg_number));
+ if(result == 1 || result == 2 || result == 4 || result == 8)
+ return result;
+ error_bad_range_arg (arg_number);
+}
+
+static long
+arg_vector_sign (int arg_number)
+{
+ long result = (arg_nonnegative_integer (arg_number));
+ if(result == 0 || result == 1)
+ return result;
+ error_bad_range_arg (arg_number);
+}
+
+#define INTEGER_VECTOR_INDEX_ARG(argument_number, vector, size) \
+ (arg_index_integer ((argument_number), (INTEGER_VECTOR_LENGTH (vector, size))))
+
+#include <stdint.h>
+
+DEFINE_PRIMITIVE ("INTEGER-VECTOR-CONS", Prim_integer_vector_cons, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (1);
+ {
+ long size = (arg_vector_size (2));
+ long sign = (arg_vector_sign (3));
+ long length = (arg_nonnegative_integer (1));
+ long length_in_words = (length * size) + INTEGER_VECTOR_TYPE_SIZE;
+ SCHEME_OBJECT result;
+ char *vect;
+ uint8_t *xvect;
+ int alignment = sizeof(long);
+ int padding = (length_in_words % alignment == 0) ? 0 : (alignment - (length_in_words % alignment));
+ length_in_words += padding;
+ ALIGN_FLOAT (Free);
+ Primitive_GC_If_Needed (length_in_words + 1);
+ result = (MAKE_POINTER_OBJECT (TC_INTVEC, Free));
+ (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length_in_words));
+ vect = ((char *) Free);
+ xvect = (uint8_t*)vect;
+ *xvect = size | (sign << 4) | padding << 5;
+ vect += INTEGER_VECTOR_TYPE_SIZE;
+ length_in_words -= INTEGER_VECTOR_TYPE_SIZE;
+ while ((length_in_words--) > 0) (*vect++) = 0;
+ Free = ((SCHEME_OBJECT *) vect);
+ PRIMITIVE_RETURN (result);
+ }
+}
+
+DEFINE_PRIMITIVE ("INTEGER-VECTOR-TYPE", Prim_integer_vector_type, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ SCHEME_OBJECT vector = (INTEGER_VECTOR_ARG (1));
+ int type;
+ Primitive_GC_If_Needed (sizeof(int) + 1);
+ type = INTEGER_VECTOR_TYPE (vector);
+ PRIMITIVE_RETURN
+ (LONG_TO_FIXNUM
+ (type));
+ }
+}
+
+DEFINE_PRIMITIVE ("INTEGER-VECTOR-REF", Prim_integer_vector_ref, 4, 4, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ // TODO: this should check whether the result is too large for a long, if yes, return a bignum
+ SCHEME_OBJECT vector = (INTEGER_VECTOR_ARG (1));
+ int size = (arg_vector_size (3));
+ int sign = (arg_vector_sign (4));
+ int index = (INTEGER_VECTOR_INDEX_ARG (2, vector, size));
+ long value;
+ Primitive_GC_If_Needed (sizeof(long) + 1);
+
+ switch(size) {
+ case 1: {
+ if(sign) {
+ value = ((long)(INTEGER_VECTOR_REF (vector,
+ index,
+ int8_t)));
+ } else {
+ value = ((unsigned long)(INTEGER_VECTOR_REF (vector,
+ index,
+ uint8_t)));
+ }
+ break;
+ }
+ case 2:
+ if(sign) {
+ value = ((long)(INTEGER_VECTOR_REF (vector,
+ index,
+ int16_t)));
+ } else {
+ value = ((unsigned long)(INTEGER_VECTOR_REF (vector,
+ index,
+ uint16_t)));
+ }
+ break;
+ case 4:
+ if(sign) {
+ value = ((long)(INTEGER_VECTOR_REF (vector,
+ index,
+ int32_t)));
+ } else {
+ value = ((unsigned long)(INTEGER_VECTOR_REF (vector,
+ index,
+ uint32_t)));
+ }
+ break;
+ case 8:
+ if(sign) {
+ value = ((long)(INTEGER_VECTOR_REF (vector,
+ index,
+ int64_t)));
+ } else {
+
+ value = ((unsigned long)(INTEGER_VECTOR_REF (vector,
+ index,
+ uint64_t)));
+ }
+ break;
+ default:
+ error_bad_range_arg (size);
+ break;
+ }
+ if(sign) {
+ if(LONG_TO_FIXNUM_P(value))
+ PRIMITIVE_RETURN
+ (LONG_TO_FIXNUM (value));
+ else
+ PRIMITIVE_RETURN
+ ((SCHEME_OBJECT)(long_to_bignum (value)));
+ } else {
+ if(ULONG_TO_FIXNUM_P(value))
+ PRIMITIVE_RETURN
+ (ULONG_TO_FIXNUM (value));
+ else
+ PRIMITIVE_RETURN
+ ((SCHEME_OBJECT)(ulong_to_bignum (value)));
+
+ }
+ }
+}
+
+extern long arg_fixnum (int);
+
+DEFINE_PRIMITIVE ("INTEGER-VECTOR-SET!", Prim_integer_vector_set, 4, 4, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ // TODO: this should check whether argument 3 (value) is a bignum, if yes, check whether it is small enough to fit in a long, if yes,
+ // store the value.
+ SCHEME_OBJECT vector = (INTEGER_VECTOR_ARG (1));
+ int size = arg_vector_size(4);
+ int index = (INTEGER_VECTOR_INDEX_ARG (2, vector, size));
+ long value = (arg_big_fixnum (3));
+ switch(size) {
+ case 1:
+ INTEGER_VECTOR_SET
+ (vector,
+ index,
+ value,
+ uint8_t);
+ break;
+ case 2:
+ INTEGER_VECTOR_SET
+ (vector,
+ index,
+ value,
+ uint16_t);
+ break;
+ case 4:
+ INTEGER_VECTOR_SET
+ (vector,
+ index,
+ value,
+ uint32_t);
+ break;
+ case 8:
+ INTEGER_VECTOR_SET
+ (vector,
+ index,
+ value,
+ uint64_t);
+ break;
+ default:
+ error_bad_range_arg (size);
+ break;
+ };
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("INTEGER-VECTOR-LENGTH", Prim_integer_vector_length, 2, 2, 0)
+{
+ SCHEME_OBJECT object;
+ int size;
+ PRIMITIVE_HEADER (1);
+ object = INTEGER_VECTOR_ARG (1);
+ size = arg_vector_size (2);
+ int len = (INTEGER_VECTOR_LENGTH (object, size));
+ switch(size) {
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ break;
+ default:
+ error_bad_range_arg (size);
+ break;
+ }
+ PRIMITIVE_RETURN
+ (LONG_TO_UNSIGNED_FIXNUM(len));
+}
+
+DEFINE_PRIMITIVE ("INTEGER-VECTOR?", Prim_integer_vector_p, 1, 1,
+ "(object)\n\
+ Returns #t if object is an integer-vector; otherwise returns #f.\
+")
+{
+ SCHEME_OBJECT object;
+ PRIMITIVE_HEADER (1);
+ object = (ARG_REF (1));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (INTEGER_VECTOR_P (object)));
+}
diff --git a/src/microcode/makegen/files-core.scm b/src/microcode/makegen/files-core.scm
index d3c995f..79ab9fe 100644
--- a/src/microcode/makegen/files-core.scm
+++ b/src/microcode/makegen/files-core.scm
@@ -52,6 +52,7 @@ USA.
"intern"
"interp"
"intprm"
+"intvec"
"list"
"lookprm"
"lookup"
diff --git a/src/microcode/object.h b/src/microcode/object.h
index 2734058..f58c58c 100644
--- a/src/microcode/object.h
+++ b/src/microcode/object.h
@@ -194,6 +194,7 @@ extern SCHEME_OBJECT * memory_base;
#define BROKEN_HEART_P(object) ((OBJECT_TYPE (object)) == TC_BROKEN_HEART)
#define RETURN_CODE_P(object) ((OBJECT_TYPE (object)) == TC_RETURN_CODE)
#define EPHEMERON_P(object) ((OBJECT_TYPE (object)) == TC_EPHEMERON)
+#define INTEGER_VECTOR_P(object) ((OBJECT_TYPE (object)) == TC_INTVEC)
#define NON_MARKED_VECTOR_P(object) \
((OBJECT_TYPE (object)) == TC_NON_MARKED_VECTOR)
@@ -427,6 +428,26 @@ extern SCHEME_OBJECT * memory_base;
#define FLOATING_VECTOR_SET(vector, index, x) \
(* (FLOATING_VECTOR_LOC ((vector), (index)))) = ((double) (x))
+/* Integer-vector Operations */
+#define INTEGER_VECTOR_TYPE_SIZE 1
+#define INTEGER_VECTOR_LENGTH(vector, size) \
+ ((((VECTOR_LENGTH (vector)) - INTEGER_VECTOR_TYPE_SIZE - (INTEGER_VECTOR_PADDING (vector))) / (size)))
+
+#define INTEGER_VECTOR_LOC(vector, index, size) \
+ ((void *) (((char*)VECTOR_LOC ((vector), 0)) + ((index) * (size) + INTEGER_VECTOR_TYPE_SIZE)))
+
+#define INTEGER_VECTOR_TYPE(vector) \
+ (*((uint8_t *) (VECTOR_LOC ((vector), 0))))
+
+#define INTEGER_VECTOR_PADDING(vector) \
+ ((INTEGER_VECTOR_TYPE(vector)) >> 5)
+
+#define INTEGER_VECTOR_REF(vector, index, type) \
+ (* ((type*)(INTEGER_VECTOR_LOC ((vector), (index), (sizeof(type))))))
+
+#define INTEGER_VECTOR_SET(vector, index, x, type) \
+ (* ((type*)(INTEGER_VECTOR_LOC ((vector), (index), (sizeof(type)))))) = ((type) (x))
+
/* Numeric Type Conversions */
#define BIGNUM_TO_FIXNUM_P(bignum) \
diff --git a/src/microcode/prims.h b/src/microcode/prims.h
index a98f9d1..482687b 100644
--- a/src/microcode/prims.h
+++ b/src/microcode/prims.h
@@ -147,4 +147,9 @@ extern unsigned char * arg_extended_string (unsigned int, unsigned long *);
? (ARG_REF (arg)) \
: ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
+#define INTEGER_VECTOR_ARG(arg) \
+ ((INTEGER_VECTOR_P (ARG_REF (arg))) \
+ ? (ARG_REF (arg)) \
+ : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
+
#endif /* SCM_PRIMS_H */
diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index e03abe3..7f05f52 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -838,6 +838,8 @@ arg_pointer (int argn)
return (alien_address (arg));
if (FLONUM_P (arg))
return ((void *) (MEMORY_LOC ((arg), 1)));
+ if (INTEGER_VECTOR_P (arg))
+ return ((void *) (INTEGER_VECTOR_LOC ((arg), 0, 0)));
error_wrong_type_arg (argn);
/*NOTREACHED*/
diff --git a/src/microcode/types.h b/src/microcode/types.h
index f74222c..973894c 100644
--- a/src/microcode/types.h
+++ b/src/microcode/types.h
@@ -33,6 +33,7 @@ USA.
/* #define TC_PCOMB2 0x04 */
#define TC_UNINTERNED_SYMBOL 0x05
#define TC_BIG_FLONUM 0x06
+#define TC_INTVEC 0x07
/* #define TC_COMBINATION_1 0x07 */
#define TC_CONSTANT 0x08
#define TC_EXTENDED_PROCEDURE 0x09
@@ -111,7 +112,7 @@ USA.
/* 0x04 */ 0, \
/* 0x05 */ "uninterned-symbol", \
/* 0x06 */ "flonum", \
- /* 0x07 */ 0, \
+ /* 0x07 */ "intvec", \
/* 0x08 */ "constant", \
/* 0x09 */ "extended-procedure", \
/* 0x0A */ "vector", \
diff --git a/src/runtime/equals.scm b/src/runtime/equals.scm
index 99d9bb8..a64339b 100644
--- a/src/runtime/equals.scm
+++ b/src/runtime/equals.scm
@@ -73,7 +73,10 @@ USA.
((char-set? x)
(and (char-set? y)
(char-set=? x y)))
+ ((intvec? x)
+ (and (intvec? y)
+ (intvec=? x y)))
(else #f))
(and (number? x)
(number? y)
- (number:eqv? x y)))))
\ No newline at end of file
+ (number:eqv? x y)))))
diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index 9ec6a71..94f4d4d 100644
--- a/src/runtime/fixart.scm
+++ b/src/runtime/fixart.scm
@@ -130,7 +130,13 @@ USA.
(flo:vector-cons floating-vector-cons 1)
(flo:vector-length floating-vector-length 1)
(flo:vector-ref floating-vector-ref 2)
- (flo:vector-set! floating-vector-set! 3))
+ (flo:vector-set! floating-vector-set! 3)
+ (intvec-cons integer-vector-cons 3)
+ (intvec-length integer-vector-length 2)
+ (intvec-ref integer-vector-ref 4)
+ (intvec-set! integer-vector-set! 4)
+ (intvec-type integer-vector-type 1)
+ (intvec? integer-vector? 1))
(define-guarantee fixnum "fixnum")
@@ -209,4 +215,4 @@ USA.
(define (->flonum x)
(guarantee-real x '->FLONUM)
- (exact->inexact (real-part x)))
\ No newline at end of file
+ (exact->inexact (real-part x)))
diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 793a722..f46404a 100644
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -275,6 +275,8 @@ USA.
(store-char-set special special-number-leaders handler:number)
(store-char initial #\( handler:list)
(store-char special #\( handler:vector)
+ (store-char special #\u handler:un/signed-vector)
+ (store-char special #\s handler:un/signed-vector)
(store-char special #\< handler:uri)
(store-char special #\[ handler:hashed-object)
(store-char initial #\) handler:close-parenthesis)
@@ -636,6 +638,24 @@ USA.
(list->vector (reverse! objects))
(loop (cons object objects))))))
+(define (handler:un/signed-vector port db ctx char1 char2)
+ ctx char1 char2
+ (let ((size (string->number (parse-atom/no-quoting port db '()))))
+ (if (not (char=? #\( (%read-char/no-eof port db)))
+ (error "missing opening paren")
+ (if (not (memq size '(8 16 32 64)))
+ (error "unsupported size" size)
+ (let loop ((objects '()))
+ (let ((object (read-in-context port db 'CLOSE-PAREN-OK)))
+ (if (eq? object close-parenthesis)
+ (apply (if (char=? #\s char2)
+ (case size ((8) s8vector) ((16) s16vector) ((32) s32vector) ((64) s64vector))
+ (case size ((8) u8vector) ((16) u16vector) ((32) u32vector) ((64) u64vector)))
+ (reverse! objects))
+ (if (not (integer? object))
+ (error "not a number" object)
+ (loop (cons object objects))))))))))
+
(define (handler:close-parenthesis port db ctx char)
db
(cond ((eq? ctx 'CLOSE-PAREN-OK)
@@ -1206,4 +1226,4 @@ USA.
(lambda (port* port)
(write-string "Unexpected parse restart on: " port)
(write port* port)))
- unspecific)
\ No newline at end of file
+ unspecific)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4929d32..197edf7 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -273,6 +273,12 @@ USA.
flo:vector-length
flo:vector-ref
flo:vector-set!
+ intvec-cons
+ intvec-length
+ intvec-ref
+ intvec-set!
+ intvec-type
+ intvec?
flo:y0
flo:y1
flo:yn
@@ -2707,6 +2713,97 @@ USA.
weak-set-cdr!
xcons))
+(define-package (runtime srfi-4)
+ (files "srfi-4")
+ (parent (runtime))
+ (export ()
+ intvec=?
+
+ s8vector?
+ make-s8vector
+ s8vector
+ s8vector-length
+ s8vector-ref
+ s8vector-set!
+ s8vector->list
+ list->s8vector
+ u8vector?
+ make-u8vector
+ u8vector
+ u8vector-length
+ u8vector-ref
+ u8vector-set!
+ u8vector->list
+ list->u8vector
+
+ s16vector?
+ make-s16vector
+ s16vector
+ s16vector-length
+ s16vector-ref
+ s16vector-set!
+ s16vector->list
+ list->s16vector
+ u16vector?
+ make-u16vector
+ u16vector
+ u16vector-length
+ u16vector-ref
+ u16vector-set!
+ u16vector->list
+ list->u16vector
+
+ s32vector?
+ make-s32vector
+ s32vector
+ s32vector-length
+ s32vector-ref
+ s32vector-set!
+ s32vector->list
+ list->s32vector
+ u32vector?
+ make-u32vector
+ u32vector
+ u32vector-length
+ u32vector-ref
+ u32vector-set!
+ u32vector->list
+ list->u32vector
+
+ s64vector?
+ make-s64vector
+ s64vector
+ s64vector-length
+ s64vector-ref
+ s64vector-set!
+ s64vector->list
+ list->s64vector
+ u64vector?
+ make-u64vector
+ u64vector
+ u64vector-length
+ u64vector-ref
+ u64vector-set!
+ u64vector->list
+ list->u64vector
+
+ f32vector?
+ make-f32vector
+ f32vector
+ f32vector-length
+ f32vector-ref
+ f32vector-set!
+ f32vector->list
+ list->f32vector
+ f64vector?
+ make-f64vector
+ f64vector
+ f64vector-length
+ f64vector-ref
+ f64vector-set!
+ f64vector->list
+ list->f64vector))
+
(define-package (runtime lambda-list)
(files "lambda-list")
(parent (runtime))
@@ -5782,4 +5879,4 @@ USA.
(import (runtime save/restore)
time-world-restored)
(export ()
- world-report))
\ No newline at end of file
+ world-report))
diff --git a/src/runtime/srfi-4.scm b/src/runtime/srfi-4.scm
new file mode 100644
index 0000000..7c2632b
--- /dev/null
+++ b/src/runtime/srfi-4.scm
@@ -0,0 +1,156 @@
+;;;; SRFI-4 Homogeneous numeric vector datatypes
+
+(declare (usual-integrations))
+
+(define 8bit 1)
+(define 16bit 2)
+(define 32bit 4)
+(define 64bit 8)
+(define signed 1)
+(define unsigned 0)
+
+(define (size+sign size sign)
+ (if (not (memq size '(1 2 4 8)))
+ (error "incorrect size" size))
+ (if (not (memq sign '(1 0)))
+ (error "incorrect sign" sign))
+ (bitwise-ior size (arithmetic-shift sign 4)))
+
+(define size+sign-mask #b11111)
+
+(define (intvec=? a b)
+ (and (intvec? a)
+ (intvec? b)
+ (= (bitwise-and size+sign-mask (intvec-type a))
+ (bitwise-and size+sign-mask (intvec-type b)))
+ (= (intvec-length a 1) (intvec-length b 1))
+ (let loop ((i 0))
+ (if (= i (intvec-length a 1))
+ #t
+ (if (= (intvec-ref a i 1 0) (intvec-ref b i 1 0))
+ (loop (+ i 1))
+ #f)))))
+
+(define-syntax define-vector-type
+ (sc-macro-transformer
+ (lambda (exp env)
+ (let ((name (second exp))
+ (size (third exp))
+ (signedness (fourth exp)))
+ `(begin
+
+ (define (,(symbol-append name '?) v)
+ (and (intvec? v)
+ (= (bitwise-and (intvec-type v) size+sign-mask) (size+sign ,size ,signedness))))
+ (define (,(symbol-append 'make- name) size #!optional fill)
+ (let ((v (intvec-cons size ,size ,signedness)))
+ (if (default-object? fill)
+ v
+ (let loop ((i 0))
+ (if (< i (,(symbol-append name '-length) v))
+ (begin
+ (,(symbol-append name '-set!) v i fill)
+ (loop (+ i 1)))
+ v)))))
+
+ (define (,name . elements)
+ (,(symbol-append 'list-> name) elements))
+
+ (define (,(symbol-append name '-length) vector)
+ (intvec-length vector ,size))
+
+ (define (,(symbol-append name '-ref) vector i)
+ (intvec-ref vector i ,size ,signedness))
+
+ (define (,(symbol-append name '-set!) vector i value)
+ (intvec-set! vector i value ,size))
+
+ (define (,(symbol-append name '->list) vector)
+ (let ((len (,(symbol-append name '-length) vector)))
+ (let loop ((i 0)
+ (result '()))
+ (if (= i len)
+ (reverse result)
+ (loop (+ i 1)
+ (cons (,(symbol-append name '-ref) vector i) result))))))
+
+ (define (,(symbol-append 'list-> name) lst)
+ (let* ((len (length lst))
+ (vector (,(symbol-append 'make- name) len)))
+ (let loop ((i 0)
+ (lst lst))
+ (if (= i len)
+ vector
+ (begin
+ (,(symbol-append name '-set!) vector i (car lst))
+ (loop (+ i 1)
+ (cdr lst))))))))))))
+
+(define-vector-type s8vector 8bit signed)
+(define-vector-type u8vector 8bit unsigned)
+
+(define-vector-type s16vector 16bit signed)
+(define-vector-type u16vector 16bit unsigned)
+
+(define-vector-type s32vector 32bit signed)
+(define-vector-type u32vector 32bit unsigned)
+
+(define-vector-type s64vector 64bit signed)
+(define-vector-type u64vector 64bit unsigned)
+
+(define (f64vector? v)
+ ;; This works on everything returned by flo:vector-cons, but also on single float values...
+ (= (object-type v) (microcode-type 'flonum)))
+
+(define (make-f64vector size #!optional fill)
+ (let ((v (flo:vector-cons size)))
+ (if (default-object? fill)
+ v
+ (let loop ((i 0))
+ (if (< i (f64vector-length v))
+ (begin
+ (f64vector-set! v i fill)
+ (loop (+ i 1)))
+ v)))))
+
+(define (f64vector . elements)
+ (list->f64vector elements))
+
+(define (f64vector-length vector)
+ (flo:vector-length vector))
+
+(define (f64vector-ref vector i)
+ (flo:vector-ref vector i))
+
+(define (f64vector-set! vector i value)
+ (flo:vector-set! vector i value))
+
+(define (f64vector->list vector)
+ (let ((len (f64vector-length vector)))
+ (let loop ((i 0)
+ (result '()))
+ (if (= i len)
+ (reverse result)
+ (loop (+ i 1)
+ (cons (f64vector-ref vector i) result))))))
+
+(define (list->f64vector lst)
+ (let* ((len (length lst))
+ (vector (make-f64vector len)))
+ (let loop ((i 0)
+ (lst lst))
+ (if (= i len)
+ vector
+ (begin
+ (f64vector-set! vector i (car lst))
+ (loop (+ i 1)
+ (cdr lst)))))))
+
+(define f32vector? f64vector?)
+(define make-f32vector make-f64vector)
+(define f32vector f64vector)
+(define f32vector-length f64vector-length)
+(define f32vector-ref f64vector-ref)
+(define f32vector-set! f64vector-set!)
+(define f32vector->list f64vector->list)
+(define list->f32vector list->f64vector)
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 1a7edcd..36d5e3f 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -214,6 +214,7 @@ USA.
(EXTENDED-PROCEDURE ,unparse/compound-procedure)
(FLONUM ,unparse/flonum)
(INTERNED-SYMBOL ,unparse/interned-symbol)
+ (INTVEC ,unparse/intvec)
(LAMBDA ,unparse/lambda)
(LIST ,unparse/pair)
(NEGATIVE-FIXNUM ,unparse/number)
@@ -892,6 +893,30 @@ USA.
(unparse/number flonum)
(unparse/floating-vector flonum)))
+(define (unparse/intvec vector)
+ (let* ((type ((ucode-primitive integer-vector-type 1) vector))
+ (size (bitwise-and type #x0f))
+ (sign (arithmetic-shift (bitwise-and type #x10) -4))
+ (length ((ucode-primitive integer-vector-length 2) vector size)))
+ (limit-unparse-depth
+ (lambda ()
+ (let ((length ((ucode-primitive integer-vector-length 2) vector size)))
+ (*unparse-string (string-append "#" (if (zero? sign) "u" "s") (number->string (* 8 size)) "("))
+ (if (fix:> length 0)
+ (begin
+ (*unparse-object ((ucode-primitive integer-vector-ref 4) vector 0 size sign))
+ (let loop ((index 1))
+ (cond ((fix:= index length)
+ (*unparse-char #\)))
+ ((let ((limit (get-param:unparser-list-breadth-limit)))
+ (and limit (>= index limit)))
+ (*unparse-string " ...)"))
+ (else
+ (*unparse-char #\space)
+ (*unparse-object ((ucode-primitive integer-vector-ref 4) vector index size sign))
+ (loop (fix:+ index 1))))))
+ (*unparse-char #\))))))))
+
(define (unparse/floating-vector v)
(let ((length ((ucode-primitive floating-vector-length) v)))
(*unparse-with-brackets "floating-vector" v
@@ -958,4 +983,4 @@ USA.
(if (get-param:unparse-with-datum?)
(begin
(*unparse-char #\space)
- (*unparse-datum promise)))))))
\ No newline at end of file
+ (*unparse-datum promise)))))))
diff --git a/tests/check.scm b/tests/check.scm
index 90ebb69..f2886b9 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -51,6 +51,7 @@ USA.
"runtime/test-floenv"
"runtime/test-hash-table"
"runtime/test-integer-bits"
+ "runtime/test-srfi-4"
"runtime/test-mime-codec"
"runtime/test-thread-queue"
"runtime/test-process"
@@ -98,4 +99,4 @@ USA.
(pathname-new-type pathname "so")
pathname)))
(run-unit-tests p environment))))))
- known-tests)))
\ No newline at end of file
+ known-tests)))
diff --git a/tests/runtime/test-srfi-4.scm b/tests/runtime/test-srfi-4.scm
new file mode 100644
index 0000000..340499c
--- /dev/null
+++ b/tests/runtime/test-srfi-4.scm
@@ -0,0 +1,519 @@
+;; Mostly copied from guile/test-suite/tests/srfi-4.test
+;; which contains this header:
+;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*-
+;;;; Martin Grabmueller, 2001-06-26
+;;;;
+;;;; Copyright (C) 2001, 2006, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
+
+(declare (usual-integrations))
+
+;;;; u8vector
+(define-test "u8vector? success"
+ (lambda ()
+ (assert-true
+ (u8vector? (u8vector)))))
+
+(define-test "u8vector? failure"
+ (lambda ()
+ (assert-false
+ (u8vector? (s8vector)))))
+
+(define-test "u8vector-length success 1"
+ (lambda ()
+ (assert-=
+ (u8vector-length (u8vector)) 0)))
+
+(define-test "u8vector-length success 2"
+ (lambda ()
+ (assert-=
+ (u8vector-length (u8vector 3)) 1)))
+
+(define-test "u8vector-length failure"
+ (lambda ()
+ (assert-!=
+ (u8vector-length (u8vector 3)) 3)))
+
+(define-test "u8vector-ref"
+ (lambda ()
+ (assert-=
+ (u8vector-ref (u8vector 1 2 3) 1) 2)))
+
+(define-test "u8vector-set!/ref"
+ (lambda ()
+ (let ((s (make-u8vector 10 0)))
+ (u8vector-set! s 4 33)
+ (assert-= (u8vector-ref s 4) 33))))
+
+(define-test "u8vector->list/list->u8vector"
+ (lambda ()
+ (assert-equal
+ (u8vector->list (u8vector 1 2 3 4))
+ (u8vector->list (list->u8vector '(1 2 3 4))))))
+
+(define-test "make-u8vector"
+ (lambda ()
+ (assert-equal
+ (list->u8vector '(7 7 7 7))
+ (make-u8vector 4 7))))
+
+
+;;;; s8vector
+(define-test "s8vector? success"
+ (lambda ()
+ (assert-true
+ (s8vector? (s8vector)))))
+
+(define-test "s8vector? failure"
+ (lambda ()
+ (assert-false
+ (s8vector? (u8vector)))))
+
+(define-test "s8vector-length success 1"
+ (lambda ()
+ (assert-=
+ (s8vector-length (s8vector)) 0)))
+
+(define-test "s8vector-length success 2"
+ (lambda ()
+ (assert-=
+ (s8vector-length (s8vector -3)) 1)))
+
+(define-test "s8vector-length failure"
+ (lambda ()
+ (assert-!=
+ (s8vector-length (s8vector 3)) 3)))
+
+(define-test "s8vector-ref"
+ (lambda ()
+ (assert-=
+ (s8vector-ref (s8vector 1 2 3) 1) 2)))
+
+(define-test "s8vector-set!/ref"
+ (lambda ()
+ (let ((s (make-s8vector 10 0)))
+ (s8vector-set! s 4 33)
+ (assert-= (s8vector-ref s 4) 33))))
+
+(define-test "s8vector->list/list->s8vector"
+ (lambda ()
+ (assert-equal
+ (s8vector->list (s8vector 1 2 3 4))
+ (s8vector->list (list->s8vector '(1 2 3 4))))))
+
+(define-test "make-s8vector"
+ (lambda ()
+ (assert-equal
+ (list->s8vector '(7 7 7 7))
+ (make-s8vector 4 7))))
+
+;;;; u16vector
+(define-test "u16vector? success"
+ (lambda ()
+ (assert-true
+ (u16vector? (u16vector)))))
+
+(define-test "u16vector? failure"
+ (lambda ()
+ (assert-false
+ (u16vector? (s16vector)))))
+
+(define-test "u16vector-length success 1"
+ (lambda ()
+ (assert-=
+ (u16vector-length (u16vector)) 0)))
+
+(define-test "u16vector-length success 2"
+ (lambda ()
+ (assert-=
+ (u16vector-length (u16vector 3)) 1)))
+
+(define-test "u16vector-length failure"
+ (lambda ()
+ (assert-!=
+ (u16vector-length (u16vector 3)) 3)))
+
+(define-test "u16vector-ref"
+ (lambda ()
+ (assert-=
+ (u16vector-ref (u16vector 1 2 3) 1) 2)))
+
+(define-test "u16vector-set!/ref"
+ (lambda ()
+ (let ((s (make-u16vector 10 0)))
+ (u16vector-set! s 4 33)
+ (assert-= (u16vector-ref s 4) 33))))
+
+(define-test "u16vector->list/list->u16vector"
+ (lambda ()
+ (assert-equal
+ (u16vector->list (u16vector 1 2 3 4))
+ (u16vector->list (list->u16vector '(1 2 3 4))))))
+
+(define-test "make-u16vector"
+ (lambda ()
+ (assert-equal
+ (list->u16vector '(7 7 7 7))
+ (make-u16vector 4 7))))
+
+
+;;;; s16vector
+(define-test "s16vector? success"
+ (lambda ()
+ (assert-true
+ (s16vector? (s16vector)))))
+
+(define-test "s16vector? failure"
+ (lambda ()
+ (assert-false
+ (s16vector? (u16vector)))))
+
+(define-test "s16vector-length success 1"
+ (lambda ()
+ (assert-=
+ (s16vector-length (s16vector)) 0)))
+
+(define-test "s16vector-length success 2"
+ (lambda ()
+ (assert-=
+ (s16vector-length (s16vector -3)) 1)))
+
+(define-test "s16vector-length failure"
+ (lambda ()
+ (assert-!=
+ (s16vector-length (s16vector 3)) 3)))
+
+(define-test "s16vector-ref"
+ (lambda ()
+ (assert-=
+ (s16vector-ref (s16vector 1 2 3) 1) 2)))
+
+(define-test "s16vector-set!/ref"
+ (lambda ()
+ (let ((s (make-s16vector 10 0)))
+ (s16vector-set! s 4 33)
+ (assert-= (s16vector-ref s 4) 33))))
+
+(define-test "s16vector->list/list->s16vector"
+ (lambda ()
+ (assert-equal
+ (s16vector->list (s16vector 1 2 3 4))
+ (s16vector->list (list->s16vector '(1 2 3 4))))))
+
+(define-test "make-s16vector"
+ (lambda ()
+ (assert-equal
+ (list->s16vector '(7 7 7 7))
+ (make-s16vector 4 7))))
+
+
+;;;; u32vector
+(define-test "u32vector? success"
+ (lambda ()
+ (assert-true
+ (u32vector? (u32vector)))))
+
+(define-test "u32vector? failure"
+ (lambda ()
+ (assert-false
+ (u32vector? (s32vector)))))
+
+(define-test "u32vector-length success 1"
+ (lambda ()
+ (assert-=
+ (u32vector-length (u32vector)) 0)))
+
+(define-test "u32vector-length success 2"
+ (lambda ()
+ (assert-=
+ (u32vector-length (u32vector 3)) 1)))
+
+(define-test "u32vector-length failure"
+ (lambda ()
+ (assert-!=
+ (u32vector-length (u32vector 3)) 3)))
+
+(define-test "u32vector-ref"
+ (lambda ()
+ (assert-=
+ (u32vector-ref (u32vector 1 2 3) 1) 2)))
+
+(define-test "u32vector-set!/ref"
+ (lambda ()
+ (let ((s (make-u32vector 10 0)))
+ (u32vector-set! s 4 33)
+ (assert-= (u32vector-ref s 4) 33))))
+
+(define-test "u32vector->list/list->u32vector"
+ (lambda ()
+ (assert-equal
+ (u32vector->list (u32vector 1 2 3 4))
+ (u32vector->list (list->u32vector '(1 2 3 4))))))
+
+(define-test "make-u32vector"
+ (lambda ()
+ (assert-equal
+ (list->u32vector '(7 7 7 7))
+ (make-u32vector 4 7))))
+
+
+;;;; s32vector
+(define-test "s32vector? success"
+ (lambda ()
+ (assert-true
+ (s32vector? (s32vector)))))
+
+(define-test "s32vector? failure"
+ (lambda ()
+ (assert-false
+ (s32vector? (u32vector)))))
+
+(define-test "s32vector-length success 1"
+ (lambda ()
+ (assert-=
+ (s32vector-length (s32vector)) 0)))
+
+(define-test "s32vector-length success 2"
+ (lambda ()
+ (assert-=
+ (s32vector-length (s32vector -3)) 1)))
+
+(define-test "s32vector-length failure"
+ (lambda ()
+ (assert-!=
+ (s32vector-length (s32vector 3)) 3)))
+
+(define-test "s32vector-ref"
+ (lambda ()
+ (assert-=
+ (s32vector-ref (s32vector 1 2 3) 1) 2)))
+
+(define-test "s32vector-set!/ref"
+ (lambda ()
+ (let ((s (make-s32vector 10 0)))
+ (s32vector-set! s 4 33)
+ (assert-= (s32vector-ref s 4) 33))))
+
+(define-test "s32vector->list/list->s32vector"
+ (lambda ()
+ (assert-equal
+ (s32vector->list (s32vector 1 2 3 4))
+ (s32vector->list (list->s32vector '(1 2 3 4))))))
+
+(define-test "make-s32vector"
+ (lambda ()
+ (assert-equal
+ (list->s32vector '(7 7 7 7))
+ (make-s32vector 4 7))))
+
+
+;;;; u64vector
+(define-test "u64vector? success"
+ (lambda ()
+ (assert-true
+ (u64vector? (u64vector)))))
+
+(define-test "u64vector? failure"
+ (lambda ()
+ (assert-false
+ (u64vector? (s64vector)))))
+
+(define-test "u64vector-length success 1"
+ (lambda ()
+ (assert-=
+ (u64vector-length (u64vector)) 0)))
+
+(define-test "u64vector-length success 2"
+ (lambda ()
+ (assert-=
+ (u64vector-length (u64vector 3)) 1)))
+
+(define-test "u64vector-length failure"
+ (lambda ()
+ (assert-!=
+ (u64vector-length (u64vector 3)) 3)))
+
+(define-test "u64vector-ref"
+ (lambda ()
+ (assert-=
+ (u64vector-ref (u64vector 1 2 3) 1) 2)))
+
+(define-test "u64vector-set!/ref"
+ (lambda ()
+ (let ((s (make-u64vector 10 0)))
+ (u64vector-set! s 4 33)
+ (assert-= (u64vector-ref s 4) 33))))
+
+(define-test "u64vector->list/list->u64vector"
+ (lambda ()
+ (assert-equal
+ (u64vector->list (u64vector 1 2 3 4))
+ (u64vector->list (list->u64vector '(1 2 3 4))))))
+
+(define-test "make-u64vector"
+ (lambda ()
+ (assert-equal
+ (list->u64vector '(7 7 7 7))
+ (make-u64vector 4 7))))
+
+
+;;;; s64vector
+(define-test "s64vector? success"
+ (lambda ()
+ (assert-true
+ (s64vector? (s64vector)))))
+
+(define-test "s64vector? failure"
+ (lambda ()
+ (assert-false
+ (s64vector? (u64vector)))))
+
+(define-test "s64vector-length success 1"
+ (lambda ()
+ (assert-=
+ (s64vector-length (s64vector)) 0)))
+
+(define-test "s64vector-length success 2"
+ (lambda ()
+ (assert-=
+ (s64vector-length (s64vector -3)) 1)))
+
+(define-test "s64vector-length failure"
+ (lambda ()
+ (assert-!=
+ (s64vector-length (s64vector 3)) 3)))
+
+(define-test "s64vector-ref"
+ (lambda ()
+ (assert-=
+ (s64vector-ref (s64vector 1 2 3) 1) 2)))
+
+(define-test "s64vector-set!/ref"
+ (lambda ()
+ (let ((s (make-s64vector 10 0)))
+ (s64vector-set! s 4 33)
+ (assert-= (s64vector-ref s 4) 33))))
+
+(define-test "s64vector->list/list->s64vector"
+ (lambda ()
+ (assert-equal
+ (s64vector->list (s64vector 1 2 3 4))
+ (s64vector->list (list->s64vector '(1 2 3 4))))))
+
+(define-test "make-s64vector"
+ (lambda ()
+ (assert-equal
+ (list->s64vector '(7 7 7 7))
+ (make-s64vector 4 7))))
+
+(define-test "u32vector-length of u16vector"
+ (lambda ()
+ (assert-=
+ 2 (u32vector-length (make-u16vector 4)))))
+
+(define-test "u32vector-length of u8vector"
+ (lambda ()
+ (assert-=
+ 2 (u32vector-length (make-u8vector 8)))))
+
+(define-test "u8vector-length of u16vector"
+ (lambda ()
+ (assert-= 4 (u8vector-length (make-u16vector 2)))))
+
+(define-test "u8vector-length of u32vector"
+ (lambda ()
+ (assert-= 8 (u8vector-length (make-u32vector 2)))))
+
+(define-test "u32vector-set! of u16vector"
+ (lambda ()
+ (let ((v (make-u16vector 4 #xFFFF)))
+ (u32vector-set! v 1 0)
+ (assert-equal v (u16vector #xFFFF #xFFFF 0 0)))))
+
+(define-test "u16vector-set! of u32vector"
+ (lambda ()
+ (let ((v (make-u32vector 2 #xFFFFFFFF)))
+ (u16vector-set! v 2 0)
+ (u16vector-set! v 3 0)
+ (assert-equal v (u32vector #xFFFFFFFF 0)))))
+
+;;;; f32vector
+(define-test "f32vector? success"
+ (lambda ()
+ (assert-true (f32vector? (f32vector)))))
+
+(define-test "f32vector? failure"
+ (lambda ()
+ (assert-false (f32vector? (s8vector)))))
+
+(define-test "f32vector-length success 1"
+ (lambda ()
+ (assert-= (f32vector-length (f32vector)) 0)))
+
+(define-test "f32vector-length success 2"
+ (lambda ()
+ (assert-= (f32vector-length (f32vector -3.0)) 1)))
+
+(define-test "f32vector-length failure"
+ (lambda ()
+ (assert-!= (f32vector-length (f32vector 3.0)) 3)))
+
+(define-test "f32vector-ref"
+ (lambda ()
+ (assert-= (f32vector-ref (f32vector 1.0 2.0 3.0) 1) 2.0)))
+
+(define-test "f32vector-set!/ref"
+ (lambda ()
+ (let ((s (make-f32vector 10 0.0)))
+ (f32vector-set! s 4 33.0)
+ (assert-= (f32vector-ref s 4) 33.0))))
+
+(define-test "f32vector->list/list->f32vector"
+ (lambda ()
+ (assert-equal (f32vector->list (f32vector 1.0 2.0 3.0 4.0))
+ (f32vector->list (list->f32vector '(1.0 2.0 3.0 4.0))))))
+
+(define-test "make-f32vector"
+ (lambda ()
+ (assert-equal (list->f32vector '(7.0 7.0 7.0 7.0))
+ (make-f32vector 4 7.0))))
+
+;;;; f64vector
+(define-test "f64vector? success"
+ (lambda ()
+ (assert-true (f64vector? (f64vector)))))
+
+(define-test "f64vector? failure"
+ (lambda ()
+ (assert-false (f64vector? (s8vector)))))
+
+(define-test "f64vector-length success 1"
+ (lambda ()
+ (assert-= (f64vector-length (f64vector)) 0)))
+
+(define-test "f64vector-length success 2"
+ (lambda ()
+ (assert-= (f64vector-length (f64vector -3.0)) 1)))
+
+(define-test "f64vector-length failure"
+ (lambda ()
+ (assert-!= (f64vector-length (f64vector 3.0)) 3)))
+
+(define-test "f64vector-ref"
+ (lambda ()
+ (assert-= (f64vector-ref (f64vector 1.0 2.0 3.0) 1) 2.0)))
+
+(define-test "f64vector-set!/ref"
+ (lambda ()
+ (let ((s (make-f64vector 10 0.0)))
+ (f64vector-set! s 4 33.0)
+ (assert-= (f64vector-ref s 4) 33.0))))
+
+(define-test "f64vector->list/list->f64vector"
+ (lambda ()
+ (assert-equal (f64vector->list (f64vector 1.0 2.0 3.0 4.0))
+ (f64vector->list (list->f64vector '(1.0 2.0 3.0 4.0))))))
+
+(define-test "make-f64vector"
+ (lambda ()
+ (assert-equal (list->f64vector '(7.0 7.0 7.0 7.0))
+ (make-f64vector 4 7.0))))
_______________________________________________
MIT-Scheme-devel mailing list
MIT-Scheme-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/mit-scheme-devel
