[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-0-33-g391
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-0-33-g39141c8 |
|
Date: |
Fri, 26 Jun 2009 10:42:49 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=39141c876b36431caa6bd0c84472de61fbc0a8e0
The branch, master has been updated
via 39141c876b36431caa6bd0c84472de61fbc0a8e0 (commit)
via a98f422ed61d36d2a0feca3d662ddc64067466f3 (commit)
via d6f1ce3d1627e27c2262cb8da15828d515050fd6 (commit)
via e6eb2467164de264c313af92d488144d2cdae94c (commit)
via caa92f5e951528c1ea31b2eea8b388e9888fa19e (commit)
via 5fa2deb3f715502866775a7e912dc66e3b6571ac (commit)
from e33779e3b84b4822b4d51562d7c4f1e65408151d (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 39141c876b36431caa6bd0c84472de61fbc0a8e0
Author: Andy Wingo <address@hidden>
Date: Fri Jun 26 12:41:34 2009 +0200
bytevector ops now compile down to low-level VM ops
* libguile/instructions.c (scm_instruction_list): Fix a longstanding bug
in this humble function.
* libguile/vm-i-scheme.c (BV_FIXABLE_INT_SET, BV_INT_SET, BV_FLOAT_SET):
Fix some bugs in these macros -- now the bytevector ops work.
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Compile
bytevector calls to VM ops.
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*): Resolve bytevector calls to primitive
calls.
commit a98f422ed61d36d2a0feca3d662ddc64067466f3
Author: Andy Wingo <address@hidden>
Date: Fri Jun 26 11:12:37 2009 +0200
run bytevectors tests under the compiler and evaluator
* test-suite/tests/bytevectors.test: Run a number of tests under the
compiler/vm and the evaluator.
commit d6f1ce3d1627e27c2262cb8da15828d515050fd6
Author: Andy Wingo <address@hidden>
Date: Fri Jun 26 00:15:37 2009 +0200
vector-ref and vector-set! now have opcodes
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*): Resolve vector-ref and vector-set!.
* module/language/tree-il/compile-glil.scm (*primcall-ops*): And compile
vector-ref and vector-set! to their opcodes.
* libguile/vm-i-scheme.c (vector-ref, vector-set): New opcodes, placed
before the bytevector ops. The renumbering shouldn't affect anyone,
given that the bytevector ops were not yet used. Fix a few bugs in the
bytevector ops.
commit e6eb2467164de264c313af92d488144d2cdae94c
Author: Andy Wingo <address@hidden>
Date: Wed Jun 24 23:49:11 2009 +0200
add bytevector ops to the vm
* libguile/instructions.h (SCM_VM_NUM_INSTRUCTIONS): Enlarge to 255. Not
sure what performance effects this will have.
* libguile/vm-engine.c: Add new error case, vm_error_not_a_bytevector.
* libguile/vm-engine.h: Don't assign specific registers for i386. Having
added the new VM vector ops, GCC 4.4 is erroring for me now.
* libguile/vm-i-scheme.c: Add bytevector-specific ops to the VM.
We don't actually use them yet, though.
commit caa92f5e951528c1ea31b2eea8b388e9888fa19e
Author: Andy Wingo <address@hidden>
Date: Wed Jun 24 23:46:42 2009 +0200
bytevectors provide scm_i_native_endianness to the vm
* libguile/bytevectors.h (scm_i_native_endianness): Allow the VM to use
scm_i_native_endianness, but still keep it marked as internal.
* libguile/bytevectors.c: Adjust to use scm_i_native_endianness instead
of native_endianness. Define it at bootstrap time.
commit 5fa2deb3f715502866775a7e912dc66e3b6571ac
Author: Andy Wingo <address@hidden>
Date: Wed Jun 24 23:44:03 2009 +0200
minor doc tweaks
* doc/ref/api-compound.texi: Generalized vector doc fixups.
* doc/ref/api-data.texi: Minor fixes to bytevector docs.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-compound.texi | 6 +-
doc/ref/api-data.texi | 34 +++--
libguile/bytevectors.c | 62 ++++----
libguile/bytevectors.h | 3 +
libguile/instructions.c | 11 +-
libguile/instructions.h | 4 +-
libguile/vm-engine.c | 8 +-
libguile/vm-engine.h | 12 +-
libguile/vm-i-scheme.c | 247 ++++++++++++++++++++++++++++++
module/language/tree-il/compile-glil.scm | 48 ++++++-
module/language/tree-il/primitives.scm | 31 ++++-
test-suite/tests/bytevectors.test | 34 ++++-
12 files changed, 424 insertions(+), 76 deletions(-)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 8d0e02f..b3997ef 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1651,16 +1651,16 @@ and writing.
Guile has a number of data types that are generally vector-like:
strings, uniform numeric vectors, bytevectors, bitvectors, and of course
ordinary vectors of arbitrary Scheme values. These types are disjoint:
-a Scheme value belongs to at most one of the four types listed above.
+a Scheme value belongs to at most one of the five types listed above.
If you want to gloss over this distinction and want to treat all four
types with common code, you can use the procedures in this section.
They work with the @emph{generalized vector} type, which is the union
-of the four vector-like types.
+of the five vector-like types.
@deffn {Scheme Procedure} generalized-vector? obj
@deffnx {C Function} scm_generalized_vector_p (obj)
-Return @code{#t} if @var{obj} is a vector, string,
+Return @code{#t} if @var{obj} is a vector, bytevector, string,
bitvector, or uniform numeric vector.
@end deffn
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 4401ef1..6e1a67a 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -3755,7 +3755,7 @@ stored and you probably need to try again with a larger
buffer.
A @dfn{bytevector} is a raw bit string. The @code{(rnrs bytevector)}
module provides the programming interface specified by the
address@hidden://www.r6rs.org/, Revised Report^6 on the Algorithmic Language
address@hidden://www.r6rs.org/, Revised^6 Report on the Algorithmic Language
Scheme (R6RS)}. It contains procedures to manipulate bytevectors and
interpret their contents in a number of ways: bytevector contents can be
accessed as signed or unsigned integer of various sizes and endianness,
@@ -3800,18 +3800,20 @@ R6RS (@pxref{R6RS I/O Ports}).
@cindex word order
Some of the following procedures take an @var{endianness} parameter.
-The @dfn{endianness} is defined is defined as the order of bytes in
-multi-byte numbers: numbers encoded in @dfn{big endian} have their most
-significant bytes written first, whereas numbers encoded in @dfn{little
-endian} have their least significant bytes address@hidden and little
-endian are the most common ``endiannesses'' but others exist. For
-instance, the GNU MP library allows @dfn{word order} to be specified
-independently of @dfn{byte order} (@pxref{Integer Import and Export,,,
-gmp, The GNU Multiple Precision Arithmetic Library Manual}).} Little
-endian is the native endianness of the IA32 architecture and its
-derivatives, while big endian is native to SPARC and PowerPC, among
-others. The @code{native-endianness} procedure returns the native
-endianness of the machine it runs on.
+The @dfn{endianness} is defined as the order of bytes in multi-byte
+numbers: numbers encoded in @dfn{big endian} have their most
+significant bytes written first, whereas numbers encoded in
address@hidden endian} have their least significant bytes
address@hidden and little-endian are the most common
+``endiannesses'', but others do exist. For instance, the GNU MP
+library allows @dfn{word order} to be specified independently of
address@hidden order} (@pxref{Integer Import and Export,,, gmp, The GNU
+Multiple Precision Arithmetic Library Manual}).}.
+
+Little-endian is the native endianness of the IA32 architecture and
+its derivatives, while big-endian is native to SPARC and PowerPC,
+among others. The @code{native-endianness} procedure returns the
+native endianness of the machine it runs on.
@deffn {Scheme Procedure} native-endianness
@deffnx {C Function} scm_native_endianness ()
@@ -3820,13 +3822,13 @@ Return a value denoting the native endianness of the
host machine.
@deffn {Scheme Macro} endianness symbol
Return an object denoting the endianness specified by @var{symbol}. If
address@hidden is neither @code{big} nor @code{little} then a compile-time
-error is raised.
address@hidden is neither @code{big} nor @code{little} then an error is
+raised at expand-time.
@end deffn
@defvr {C Variable} scm_endianness_big
@defvrx {C Variable} scm_endianness_little
-The objects denoting big (resp. little) endianness.
+The objects denoting big- and little-endianness, respectively.
@end defvr
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index fd9043a..24afd24 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -88,22 +88,22 @@
scm_out_of_range (FUNC_NAME, index);
/* Template for fixed-size integer access (only 8, 16 or 32-bit). */
-#define INTEGER_REF(_len, _sign) \
- SCM result; \
- \
- INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
- SCM_VALIDATE_SYMBOL (3, endianness); \
- \
- { \
- INT_TYPE (_len, _sign) c_result; \
- \
- memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
- if (!scm_is_eq (endianness, native_endianness)) \
- c_result = INT_SWAP (_len) (c_result); \
- \
- result = SCM_I_MAKINUM (c_result); \
- } \
- \
+#define INTEGER_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ if (!scm_is_eq (endianness, scm_i_native_endianness)) \
+ c_result = INT_SWAP (_len) (c_result); \
+ \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
return result;
/* Template for fixed-size integer access using the native endianness. */
@@ -138,7 +138,7 @@
scm_out_of_range (FUNC_NAME, value); \
\
c_value_short = (INT_TYPE (_len, _sign)) c_value; \
- if (!scm_is_eq (endianness, native_endianness)) \
+ if (!scm_is_eq (endianness, scm_i_native_endianness)) \
c_value_short = INT_SWAP (_len) (c_value_short); \
\
memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
@@ -398,7 +398,7 @@ SCM_SYMBOL (scm_sym_little, "little");
SCM scm_endianness_big, scm_endianness_little;
/* Host endianness (a symbol). */
-static SCM native_endianness = SCM_UNSPECIFIED;
+SCM scm_i_native_endianness = SCM_UNSPECIFIED;
/* Byte-swapping. */
#ifndef bswap_24
@@ -414,7 +414,7 @@ SCM_DEFINE (scm_native_endianness, "native-endianness", 0,
0, 0,
"Return a symbol denoting the machine's native endianness.")
#define FUNC_NAME s_scm_native_endianness
{
- return native_endianness;
+ return scm_i_native_endianness;
}
#undef FUNC_NAME
@@ -868,7 +868,7 @@ bytevector_large_set (char *c_bv, size_t c_size, int
signed_p,
int swap;
\
_sign int value; \
\
- swap = !scm_is_eq (endianness, native_endianness); \
+ swap = !scm_is_eq (endianness, scm_i_native_endianness); \
switch (c_size) \
{ \
case 1: \
@@ -943,7 +943,7 @@ bytevector_unsigned_ref (const char *c_bv, size_t c_size,
SCM endianness)
int swap; \
INT_TYPE (16, _sign) c_value16; \
\
- swap = !scm_is_eq (endianness, native_endianness); \
+ swap = !scm_is_eq (endianness, scm_i_native_endianness); \
\
if (swap) \
c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
@@ -1293,7 +1293,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x,
"bytevector-s16-native-set!",
#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
- SIGNEDNESS (_sign), native_endianness));
+ SIGNEDNESS (_sign), scm_i_native_endianness));
#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
int err; \
@@ -1301,7 +1301,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x,
"bytevector-s16-native-set!",
\
err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
SIGNEDNESS (_sign), value, \
- native_endianness); \
+ scm_i_native_endianness); \
if (SCM_UNLIKELY (err)) \
scm_out_of_range (FUNC_NAME, value); \
\
@@ -1640,7 +1640,7 @@ double_from_foreign_endianness (const union
scm_ieee754_double *source)
IEEE754_ACCESSOR_PROLOGUE (_type); \
SCM_VALIDATE_SYMBOL (3, endianness); \
\
- if (scm_is_eq (endianness, native_endianness)) \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
else \
{ \
@@ -1669,7 +1669,7 @@ double_from_foreign_endianness (const union
scm_ieee754_double *source)
SCM_VALIDATE_SYMBOL (4, endianness); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
- if (scm_is_eq (endianness, native_endianness)) \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
else \
{ \
@@ -2075,6 +2075,12 @@ scm_bootstrap_bytevectors (void)
scm_null_bytevector =
scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+#ifdef WORDS_BIGENDIAN
+ scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol
("big"));
+#else
+ scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol
("little"));
+#endif
+
scm_c_register_extension ("libguile", "scm_init_bytevectors",
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
@@ -2085,12 +2091,6 @@ scm_init_bytevectors (void)
{
#include "libguile/bytevectors.x"
-#ifdef WORDS_BIGENDIAN
- native_endianness = scm_sym_big;
-#else
- native_endianness = scm_sym_little;
-#endif
-
scm_endianness_big = scm_sym_big;
scm_endianness_little = scm_sym_little;
}
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 903ce7a..cb27262 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -116,6 +116,8 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
i.e., without allocating memory beside the SMOB itself (a double cell).
This optimization is necessary since small bytevectors are expected to be
common. */
+#define SCM_BYTEVECTOR_P(_bv) \
+ SCM_SMOB_PREDICATE (scm_tc16_bytevector, _bv)
#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
@@ -129,6 +131,7 @@ SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);
SCM_INTERNAL scm_t_bits scm_tc16_bytevector;
+SCM_INTERNAL SCM scm_i_native_endianness;
SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t);
#define scm_c_shrink_bytevector(_bv, _len) \
diff --git a/libguile/instructions.c b/libguile/instructions.c
index a67684e..8e6d169 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -109,10 +109,11 @@ SCM_DEFINE (scm_instruction_list, "instruction-list", 0,
0, 0,
#define FUNC_NAME s_scm_instruction_list
{
SCM list = SCM_EOL;
- struct scm_instruction *ip;
- for (ip = fetch_instruction_table (); ip->opcode != scm_op_last; ip++)
- if (ip->name)
- list = scm_cons (ip->symname, list);
+ int i;
+ struct scm_instruction *ip = fetch_instruction_table ();
+ for (i = 0; i < scm_op_last; i++)
+ if (ip[i].name)
+ list = scm_cons (ip[i].symname, list);
return scm_reverse_x (list, SCM_EOL);
}
#undef FUNC_NAME
diff --git a/libguile/instructions.h b/libguile/instructions.h
index c9fe6e9..d081b3e 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -21,7 +21,7 @@
#include <libguile.h>
-#define SCM_VM_NUM_INSTRUCTIONS (1<<7)
+#define SCM_VM_NUM_INSTRUCTIONS (1<<8)
#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
enum scm_opcode {
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 978d407..90cf697 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -203,6 +203,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* shouldn't get here */
goto vm_error;
+ vm_error_not_a_bytevector:
+ SYNC_ALL ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "bytevector");
+ /* shouldn't get here */
+ goto vm_error;
+
vm_error_no_values:
err_msg = scm_from_locale_string ("VM: 0-valued return");
finish_args = SCM_EOL;
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index c98dfdd..d684979 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -54,13 +54,9 @@
#endif
#endif
#ifdef __i386__
-/* gcc on lenny actually crashes if we allocate these variables in registers.
- hopefully this is the only one of these. */
-#if !(__GNUC__==4 && __GNUC_MINOR__==1 && __GNUC_PATCHLEVEL__==2)
-#define IP_REG asm("%esi")
-#define SP_REG asm("%edi")
-#define FP_REG
-#endif
+/* too few registers! because of register allocation errors with various gcs,
+ just punt on explicit assignments on i386, hoping that the "register"
+ declaration will be sufficient. */
#endif
#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
#define IP_REG asm("26")
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 4fc026c..5de39a2 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -279,6 +279,253 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0)
NEXT;
}
+VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2)
+{
+ long i;
+ ARGS2 (vect, idx);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < SCM_I_VECTOR_LENGTH (vect)))
+ RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
+ else
+ RETURN (scm_vector_ref (vect, idx));
+}
+
+VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0)
+{
+ long i;
+ SCM vect, idx, val;
+ POP (val); POP (idx); POP (vect);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < SCM_I_VECTOR_LENGTH (vect)))
+ SCM_I_VECTOR_WELTS (vect)[i] = val;
+ else
+ scm_vector_set_x (vect, idx, val);
+ NEXT;
+}
+
+#define VM_VALIDATE_BYTEVECTOR(x) \
+ if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
+ { finish_args = x; \
+ goto vm_error_not_a_bytevector; \
+ }
+
+#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \
+{ \
+ SCM endianness; \
+ POP (endianness); \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
+ goto VM_LABEL (bv_##stem##_native_ref); \
+ { \
+ ARGS2 (bv, idx); \
+ RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \
+ } \
+}
+
+VM_DEFINE_FUNCTION (111, bv_u16_ref, "bv-u16-ref", 3)
+BV_REF_WITH_ENDIANNESS (u16, u16)
+VM_DEFINE_FUNCTION (112, bv_s16_ref, "bv-s16-ref", 3)
+BV_REF_WITH_ENDIANNESS (s16, s16)
+VM_DEFINE_FUNCTION (113, bv_u32_ref, "bv-u32-ref", 3)
+BV_REF_WITH_ENDIANNESS (u32, u32)
+VM_DEFINE_FUNCTION (114, bv_s32_ref, "bv-s32-ref", 3)
+BV_REF_WITH_ENDIANNESS (s32, s32)
+VM_DEFINE_FUNCTION (115, bv_u64_ref, "bv-u64-ref", 3)
+BV_REF_WITH_ENDIANNESS (u64, u64)
+VM_DEFINE_FUNCTION (116, bv_s64_ref, "bv-s64-ref", 3)
+BV_REF_WITH_ENDIANNESS (s64, s64)
+VM_DEFINE_FUNCTION (117, bv_f32_ref, "bv-f32-ref", 3)
+BV_REF_WITH_ENDIANNESS (f32, ieee_single)
+VM_DEFINE_FUNCTION (118, bv_f64_ref, "bv-f64-ref", 3)
+BV_REF_WITH_ENDIANNESS (f64, ieee_double)
+
+#undef BV_REF_WITH_ENDIANNESS
+
+#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
+{ \
+ long i; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \
+ (SCM_BYTEVECTOR_CONTENTS (bv) + i))); \
+ else \
+ RETURN (scm_bytevector_##fn_stem##_ref (bv, idx)); \
+}
+
+#define BV_INT_REF(stem, type, size) \
+{ \
+ long i; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ { scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \
+ if (SCM_FIXABLE (x)) \
+ RETURN (SCM_I_MAKINUM (x)); \
+ else \
+ RETURN (scm_from_##type (x)); \
+ } \
+ else \
+ RETURN (scm_bytevector_##stem##_native_ref (bv, idx)); \
+}
+
+#define BV_FLOAT_REF(stem, fn_stem, type, size) \
+{ \
+ long i; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \
+ else \
+ RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \
+}
+
+VM_DEFINE_FUNCTION (119, bv_u8_ref, "bv-u8-ref", 2)
+BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
+VM_DEFINE_FUNCTION (120, bv_s8_ref, "bv-s8-ref", 2)
+BV_FIXABLE_INT_REF (s8, s8, int8, 1)
+VM_DEFINE_FUNCTION (121, bv_u16_native_ref, "bv-u16-native-ref", 2)
+BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
+VM_DEFINE_FUNCTION (122, bv_s16_native_ref, "bv-s16-native-ref", 2)
+BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
+VM_DEFINE_FUNCTION (123, bv_u32_native_ref, "bv-u32-native-ref", 2)
+/* FIXME: u32 is always a fixnum on 64-bit builds */
+BV_INT_REF (u32, uint32, 4)
+VM_DEFINE_FUNCTION (124, bv_s32_native_ref, "bv-s32-native-ref", 2)
+BV_INT_REF (s32, int32, 4)
+VM_DEFINE_FUNCTION (125, bv_u64_native_ref, "bv-u64-native-ref", 2)
+BV_INT_REF (u64, uint64, 8)
+VM_DEFINE_FUNCTION (126, bv_s64_native_ref, "bv-s64-native-ref", 2)
+BV_INT_REF (s64, int64, 8)
+VM_DEFINE_FUNCTION (127, bv_f32_native_ref, "bv-f32-native-ref", 2)
+BV_FLOAT_REF (f32, ieee_single, float, 4)
+VM_DEFINE_FUNCTION (128, bv_f64_native_ref, "bv-f64-native-ref", 2)
+BV_FLOAT_REF (f64, ieee_double, double, 8)
+
+#undef BV_FIXABLE_INT_REF
+#undef BV_INT_REF
+#undef BV_FLOAT_REF
+
+
+
+#define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \
+{ \
+ SCM endianness; \
+ POP (endianness); \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
+ goto VM_LABEL (bv_##stem##_native_set); \
+ { \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
+ NEXT; \
+ } \
+}
+
+VM_DEFINE_INSTRUCTION (129, bv_u16_set, "bv-u16-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (u16, u16)
+VM_DEFINE_INSTRUCTION (130, bv_s16_set, "bv-s16-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (s16, s16)
+VM_DEFINE_INSTRUCTION (131, bv_u32_set, "bv-u32-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (u32, u32)
+VM_DEFINE_INSTRUCTION (132, bv_s32_set, "bv-s32-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (s32, s32)
+VM_DEFINE_INSTRUCTION (133, bv_u64_set, "bv-u64-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (u64, u64)
+VM_DEFINE_INSTRUCTION (134, bv_s64_set, "bv-s64-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (s64, s64)
+VM_DEFINE_INSTRUCTION (135, bv_f32_set, "bv-f32-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (f32, ieee_single)
+VM_DEFINE_INSTRUCTION (136, bv_f64_set, "bv-f64-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (f64, ieee_double)
+
+#undef BV_SET_WITH_ENDIANNESS
+
+#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
+{ \
+ long i, j; \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0) \
+ && (SCM_I_INUMP (val)) \
+ && ((j = SCM_I_INUM (val)) >= min) \
+ && (j <= max))) \
+ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = (scm_t_##type)j; \
+ else \
+ scm_bytevector_##fn_stem##_set_x (bv, idx, val); \
+ NEXT; \
+}
+
+#define BV_INT_SET(stem, type, size) \
+{ \
+ long i; \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_##type (val);
\
+ else \
+ scm_bytevector_##stem##_native_set_x (bv, idx, val); \
+ NEXT; \
+}
+
+#define BV_FLOAT_SET(stem, fn_stem, type, size) \
+{ \
+ long i; \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val); \
+ else \
+ scm_bytevector_##fn_stem##_native_set_x (bv, idx, val); \
+ NEXT; \
+}
+
+VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
+VM_DEFINE_INSTRUCTION (138, bv_s8_set, "bv-s8-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
+VM_DEFINE_INSTRUCTION (139, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
+VM_DEFINE_INSTRUCTION (140, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX,
2)
+VM_DEFINE_INSTRUCTION (141, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
+/* FIXME: u32 is always a fixnum on 64-bit builds */
+BV_INT_SET (u32, uint32, 4)
+VM_DEFINE_INSTRUCTION (142, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+BV_INT_SET (s32, int32, 4)
+VM_DEFINE_INSTRUCTION (143, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
+BV_INT_SET (u64, uint64, 8)
+VM_DEFINE_INSTRUCTION (144, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
+BV_INT_SET (s64, int64, 8)
+VM_DEFINE_INSTRUCTION (145, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
+BV_FLOAT_SET (f32, ieee_single, float, 4)
+VM_DEFINE_INSTRUCTION (146, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
+BV_FLOAT_SET (f64, ieee_double, double, 8)
+
+#undef BV_FIXABLE_INT_SET
+#undef BV_INT_SET
+#undef BV_FLOAT_SET
+
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index a75843d..e0df038 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -81,7 +81,53 @@
(list . list)
(vector . vector)
((@slot-ref . 2) . slot-ref)
- ((@slot-set! . 3) . slot-set)))
+ ((@slot-set! . 3) . slot-set)
+ ((vector-ref . 2) . vector-ref)
+ ((vector-set! . 3) . vector-set)
+
+ ((bytevector-u8-ref . 2) . bv-u8-ref)
+ ((bytevector-u8-set! . 3) . bv-u8-set)
+ ((bytevector-s8-ref . 2) . bv-s8-ref)
+ ((bytevector-s8-set! . 3) . bv-s8-set)
+
+ ((bytevector-u16-ref . 3) . bv-u16-ref)
+ ((bytevector-u16-set! . 4) . bv-u16-set)
+ ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
+ ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
+ ((bytevector-s16-ref . 3) . bv-s16-ref)
+ ((bytevector-s16-set! . 4) . bv-s16-set)
+ ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
+ ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
+
+ ((bytevector-u32-ref . 3) . bv-u32-ref)
+ ((bytevector-u32-set! . 4) . bv-u32-set)
+ ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
+ ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
+ ((bytevector-s32-ref . 3) . bv-s32-ref)
+ ((bytevector-s32-set! . 4) . bv-s32-set)
+ ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
+ ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
+
+ ((bytevector-u64-ref . 3) . bv-u64-ref)
+ ((bytevector-u64-set! . 4) . bv-u64-set)
+ ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
+ ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
+ ((bytevector-s64-ref . 3) . bv-s64-ref)
+ ((bytevector-s64-set! . 4) . bv-s64-set)
+ ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
+ ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
+
+ ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
+ ((bytevector-ieee-single-set! . 4) . bv-f32-set)
+ ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
+ ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
+ ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
+ ((bytevector-ieee-double-set! . 4) . bv-f64-set)
+ ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
+ ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
+
+
+
(define (make-label) (gensym ":L"))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 7daae0c..9ccd272 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -19,6 +19,7 @@
;;; Code:
(define-module (language tree-il primitives)
+ #:use-module (rnrs bytevector)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:use-module (srfi srfi-16)
@@ -47,11 +48,37 @@
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+
+ vector-ref vector-set!
+
+ bytevector-u8-ref bytevector-u8-set!
+ bytevector-s8-ref bytevector-s8-set!
+
+ bytevector-u16-ref bytevector-u16-set!
+ bytevector-u16-native-ref bytevector-u16-native-set!
+ bytevector-s16-ref bytevector-s16-set!
+ bytevector-s16-native-ref bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-u32-set!
+ bytevector-u32-native-ref bytevector-u32-native-set!
+ bytevector-s32-ref bytevector-s32-set!
+ bytevector-s32-native-ref bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-u64-set!
+ bytevector-u64-native-ref bytevector-u64-native-set!
+ bytevector-s64-ref bytevector-s64-set!
+ bytevector-s64-native-ref bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+ bytevector-ieee-double-ref bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!))
(define (add-interesting-primitive! name)
(hashq-set! *interesting-primitive-vars*
- (module-variable (current-module) name) name))
+ (module-variable (current-module) name)
+ name))
(define *interesting-primitive-vars* (make-hash-table))
diff --git a/test-suite/tests/bytevectors.test
b/test-suite/tests/bytevectors.test
index 45f11ec..8b336bb 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -19,13 +19,33 @@
(define-module (test-bytevector)
:use-module (test-suite lib)
+ :use-module (system base compile)
:use-module (rnrs bytevector))
;;; Some of the tests in here are examples taken from the R6RS Standard
;;; Libraries document.
+(define-syntax c&e
+ (syntax-rules (pass-if pass-if-exception)
+ ((_ (pass-if test-name exp))
+ (begin (pass-if (string-append test-name " (eval)")
+ (primitive-eval 'exp))
+ (pass-if (string-append test-name " (compile)")
+ (compile 'exp #:to 'value))))
+ ((_ (pass-if-exception test-name exc exp))
+ (begin (pass-if-exception (string-append test-name " (eval)")
+ exc (primitive-eval 'exp))
+ (pass-if-exception (string-append test-name " (compile)")
+ exc (compile 'exp #:to 'value))))))
+
+(define-syntax with-test-prefix/c&e
+ (syntax-rules ()
+ ((_ section-name exp ...)
+ (with-test-prefix section-name (c&e exp) ...))))
+
+
-(with-test-prefix "2.2 General Operations"
+(with-test-prefix/c&e "2.2 General Operations"
(pass-if "native-endianness"
(not (not (memq (native-endianness) '(big little)))))
@@ -44,7 +64,7 @@
(make-bytevector 20 0))))))
-(with-test-prefix "2.3 Operations on Bytes and Octets"
+(with-test-prefix/c&e "2.3 Operations on Bytes and Octets"
(pass-if "bytevector-{u8,s8}-ref"
(equal? '(-127 129 -1 255)
@@ -131,7 +151,7 @@
(equal? bv1 bv2))))
-(with-test-prefix "2.4 Operations on Integers of Arbitrary Size"
+(with-test-prefix/c&e "2.4 Operations on Integers of Arbitrary Size"
(pass-if "bytevector->sint-list"
(let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
@@ -185,7 +205,7 @@
(uint-list->bytevector '(0 -1) (endianness big) 2)))
-(with-test-prefix "2.5 Operations on 16-Bit Integers"
+(with-test-prefix/c&e "2.5 Operations on 16-Bit Integers"
(pass-if "bytevector-u16-ref"
(let ((b (u8-list->bytevector
@@ -233,7 +253,7 @@
-77))))
-(with-test-prefix "2.6 Operations on 32-bit Integers"
+(with-test-prefix/c&e "2.6 Operations on 32-bit Integers"
(pass-if "bytevector-u32-ref"
(let ((b (u8-list->bytevector
@@ -270,7 +290,7 @@
(- 2222222222 (expt 2 32)))))))
-(with-test-prefix "2.7 Operations on 64-bit Integers"
+(with-test-prefix/c&e "2.7 Operations on 64-bit Integers"
(pass-if "bytevector-u64-ref"
(let ((b (u8-list->bytevector
@@ -315,7 +335,7 @@
(= 0 (bytevector-u64-ref b 0 (endianness big))))))
-(with-test-prefix "2.8 Operations on IEEE-754 Representations"
+(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations"
(pass-if "bytevector-ieee-single-native-{ref,set!}"
(let ((b (make-bytevector 4))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-0-33-g39141c8,
Andy Wingo <=