diff --git a/Makefile b/Makefile index d9b2e497..f443cdc4 100644 --- a/Makefile +++ b/Makefile @@ -60,7 +60,8 @@ COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \ $(EXTRA_COMPILED_LIBS) \ lib/srfi/27/rand$(SO) lib/srfi/151/bit$(SO) \ lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ - lib/srfi/98/env$(SO) lib/srfi/144/math$(SO) lib/scheme/time$(SO) + lib/srfi/98/env$(SO) lib/srfi/144/math$(SO) lib/srfi/160/uvprims$(SO) \ + lib/scheme/time$(SO) ifndef EXCLUDE_POSIX_LIBS COMPILED_LIBS += lib/srfi/18/threads$(SO) @@ -326,7 +327,7 @@ install-base: all $(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term $(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char $(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time - $(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 + $(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/ $(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/ $(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/ @@ -371,6 +372,7 @@ install-base: all $(INSTALL) -m0644 lib/srfi/144/*.scm $(DESTDIR)$(MODDIR)/srfi/144/ $(INSTALL) -m0644 lib/srfi/151/*.scm $(DESTDIR)$(MODDIR)/srfi/151/ $(INSTALL) -m0644 lib/srfi/159/*.sld $(DESTDIR)$(MODDIR)/srfi/159/ + $(INSTALL) -m0644 lib/srfi/160/*.sld $(DESTDIR)$(MODDIR)/srfi/160/ $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/ $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/ $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/ @@ -389,6 +391,7 @@ install-base: all $(INSTALL_EXE) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98 $(INSTALL_EXE) -m0755 lib/srfi/144/math$(SO) $(DESTDIR)$(BINMODDIR)/srfi/144 $(INSTALL_EXE) -m0755 lib/srfi/151/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/151 + $(INSTALL_EXE) -m0755 lib/srfi/169/uvprim$(SO) $(DESTDIR)$(BINMODDIR)/srfi/160 $(MKDIR) $(DESTDIR)$(INCDIR) $(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/ $(MKDIR) $(DESTDIR)$(LIBDIR) @@ -464,6 +467,7 @@ uninstall: -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99 -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(BINMODDIR)/srfi/151 -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(BINMODDIR)/srfi/144 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(BINMODDIR)/srfi/160 -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi -$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR) -$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1 diff --git a/Makefile.detect b/Makefile.detect index 2d1227f7..fddb88a8 100644 --- a/Makefile.detect +++ b/Makefile.detect @@ -122,7 +122,7 @@ endif # Check for headers (who needs autoconf?) ifndef SEXP_USE_NTP_GETTIME -SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0) +SEXP_USE_NTP_GETTIME := $(shell echo "int main(){struct ntptimeval n; ntp_gettime(&n);}" | $(CC) -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0) endif ifeq ($(SEXP_USE_NTP_GETTIME),1) @@ -130,7 +130,7 @@ CPPFLAGS += -DSEXP_USE_NTPGETTIME endif ifndef SEXP_USE_INTTYPES -SEXP_USE_INTTYPES := $(shell echo "main(){int_least8_t x;}" | gcc -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0) +SEXP_USE_INTTYPES := $(shell echo "int main(){int_least8_t x;}" | $(CC) -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0) endif ifeq ($(SEXP_USE_INTTYPES),1) diff --git a/bignum.c b/bignum.c index 98890dc6..3052cbe3 100644 --- a/bignum.c +++ b/bignum.c @@ -894,6 +894,21 @@ sexp sexp_ratio_ceiling (sexp ctx, sexp a) { #endif +double sexp_to_double (sexp x) { + if (sexp_flonump(x)) + return sexp_flonum_value(x); + else if (sexp_fixnump(x)) + return sexp_fixnum_to_double(x); + else if (sexp_bignump(x)) + return sexp_bignum_to_double(x); +#if SEXP_USE_RATIOS + else if (sexp_ratiop(x)) + return sexp_ratio_to_double(x); +#endif + else + return 0.0; +} + /************************ complex numbers ****************************/ #if SEXP_USE_COMPLEX @@ -975,21 +990,6 @@ sexp sexp_complex_div (sexp ctx, sexp a, sexp b) { return sexp_complex_normalize(res); } -static double sexp_to_double (sexp x) { - if (sexp_flonump(x)) - return sexp_flonum_value(x); - else if (sexp_fixnump(x)) - return sexp_fixnum_to_double(x); - else if (sexp_bignump(x)) - return sexp_bignum_to_double(x); -#if SEXP_USE_RATIOS - else if (sexp_ratiop(x)) - return sexp_ratio_to_double(x); -#endif - else - return 0.0; -} - static sexp sexp_to_complex (sexp ctx, sexp x) { #if SEXP_USE_RATIOS sexp_gc_var1(tmp); diff --git a/eval.c b/eval.c index 939d2fd3..a3b2d66e 100644 --- a/eval.c +++ b/eval.c @@ -2281,6 +2281,10 @@ sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { return res; } +sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) { + return sexp_context_env(ctx); +} + #if SEXP_USE_MODULES sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { if (sexp_pairp(x) && sexp_stringp(sexp_car(x))) { @@ -2298,9 +2302,6 @@ sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, se sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); return sexp_load_module_file(ctx, sexp_string_data(file), env); } -sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) { - return sexp_context_env(ctx); -} sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env) { sexp oldenv; sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h index 9bd6461f..bff6a03b 100644 --- a/include/chibi/bignum.h +++ b/include/chibi/bignum.h @@ -369,6 +369,7 @@ SEXP_API sexp_uint_t sexp_bignum_hi (sexp a); SEXP_API sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); SEXP_API double sexp_bignum_to_double (sexp a); SEXP_API sexp sexp_double_to_bignum (sexp ctx, double f); +SEXP_API double sexp_to_double (sexp x); SEXP_API sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b); SEXP_API sexp sexp_bignum_fxsub (sexp ctx, sexp a, sexp_uint_t b); SEXP_API sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset); diff --git a/include/chibi/features.h b/include/chibi/features.h index 349c9e50..6daa103b 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -559,13 +559,16 @@ #define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES) #endif -/* Dangerous without shared object detection. */ #ifndef SEXP_USE_TYPE_PRINTERS -#define SEXP_USE_TYPE_PRINTERS 0 +#define SEXP_USE_TYPE_PRINTERS SEXP_USE_OBJECT_BRACE_LITERALS +#endif + +#ifndef SEXP_USE_UNIFORM_VECTOR_LITERALS +#define SEXP_USE_UNIFORM_VECTOR_LITERALS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_BYTEVECTOR_LITERALS -#define SEXP_USE_BYTEVECTOR_LITERALS ! SEXP_USE_NO_FEATURES +#define SEXP_USE_BYTEVECTOR_LITERALS SEXP_USE_UNIFORM_VECTOR_LITERALS #endif #ifndef SEXP_BYTEVECTOR_HEX_LITERALS diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 3a5ee1a6..c5c17c43 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -196,6 +196,7 @@ enum sexp_types { SEXP_STACK, SEXP_CONTEXT, SEXP_CPOINTER, + SEXP_UNIFORM_VECTOR, #if SEXP_USE_AUTO_FORCE SEXP_PROMISE, #endif @@ -248,7 +249,7 @@ typedef int sexp_sint_t; #ifdef SEXP_USE_INTTYPES -# include +#include # ifdef UINT8_MAX # define SEXP_UINT8_DEFINED 1 typedef uint8_t sexp_uint8_t; @@ -289,8 +290,8 @@ typedef short sexp_int32_t; #define SEXP_PRIdOFF "ld" #endif -#if defined(__GNUC__) || defined(_WIN64) || defined(__APPLE__) -#include +#if SEXP_USE_INTTYPES +#include #if SEXP_64_BIT #define SEXP_PRIdFIXNUM PRId64 #else @@ -430,6 +431,12 @@ struct sexp_struct { char data SEXP_FLEXIBLE_ARRAY; } bytes; struct { + unsigned char element_type; + sexp_uint_t length; + sexp bytes; + unsigned char* data; + } uvector; + struct { #if SEXP_USE_PACKED_STRINGS sexp_uint_t length; char data SEXP_FLEXIBLE_ARRAY; @@ -745,6 +752,7 @@ union sexp_flonum_conv { SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); #if SEXP_64_BIT SEXP_API float sexp_flonum_value (sexp x); +#define sexp_flonum_value_set(f, x) (f = sexp_make_flonum(NULL, x)) #define sexp_flonum_bits(f) ((char*)&f) SEXP_API sexp sexp_make_flonum(sexp ctx, float f); #else @@ -754,6 +762,7 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, float f); #else #define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) #define sexp_flonum_value(f) ((f)->value.flonum) +#define sexp_flonum_value_set(f, x) ((f)->value.flonum = x) #define sexp_flonum_bits(f) ((f)->value.flonum_bits) SEXP_API sexp sexp_make_flonum(sexp ctx, double f); #endif @@ -808,6 +817,38 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, double f); #define sexp_promisep(x) (sexp_check_tag(x, SEXP_PROMISE)) #define sexp_ephemeronp(x) (sexp_check_tag(x, SEXP_EPHEMERON)) +#if SEXP_USE_UNIFORM_VECTOR_LITERALS +#define sexp_uvectorp(x) (sexp_check_tag(x, SEXP_UNIFORM_VECTOR)) +#define sexp_u1vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U1) +#define sexp_u8vectorp(x) (sexp_bytesp(x)) +#define sexp_s8vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S8) +#define sexp_u16vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U16) +#define sexp_s16vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S16) +#define sexp_u32vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U32) +#define sexp_s32vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S32) +#define sexp_u64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U64) +#define sexp_s64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S64) +#define sexp_f32vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F32) +#define sexp_f64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F64) +#define sexp_c64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_C64) +#define sexp_c128vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_C128) +#else +#define sexp_uvectorp(x) (sexp_vectorp(x)) +#define sexp_u1vectorp(x) (sexp_vectorp(x)) +#define sexp_u8vectorp(x) (sexp_bytesp(x)) +#define sexp_s8vectorp(x) (sexp_vectorp(x)) +#define sexp_u16vectorp(x) (sexp_vectorp(x)) +#define sexp_s16vectorp(x) (sexp_vectorp(x)) +#define sexp_u32vectorp(x) (sexp_vectorp(x)) +#define sexp_s32vectorp(x) (sexp_vectorp(x)) +#define sexp_u64vectorp(x) (sexp_vectorp(x)) +#define sexp_s64vectorp(x) (sexp_vectorp(x)) +#define sexp_f32vectorp(x) (sexp_vectorp(x)) +#define sexp_f64vectorp(x) (sexp_vectorp(x)) +#define sexp_c64vectorp(x) (sexp_vectorp(x)) +#define sexp_c128vectorp(x) (sexp_vectorp(x)) +#endif + #define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) #if SEXP_USE_HUFF_SYMS @@ -937,8 +978,12 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #if SEXP_USE_COMPLEX #define sexp_numberp(x) (sexp_realp(x) || sexp_complexp(x)) +#define sexp_real_part(x) (sexp_complexp(x) ? sexp_complex_real(x) : x) +#define sexp_imag_part(x) (sexp_complexp(x) ? sexp_complex_imag(x) : SEXP_ZERO) #else #define sexp_numberp(x) (sexp_realp(x)) +#define sexp_real_part(x) (x) +#define sexp_imag_part(x) SEXP_ZERO #endif #define sexp_exact_negativep(x) (sexp_fixnump(x) ? (sexp_unbox_fixnum(x) < 0) \ @@ -1043,6 +1088,40 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_bytes_data(x) (sexp_field(x, bytes, SEXP_BYTES, data)) #define sexp_bytes_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_bytes_data(x)) +static const unsigned char sexp_uvector_sizes[] = { + 0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128}; +static const unsigned char sexp_uvector_chars[] = "#ususususuffcc"; + +enum sexp_uniform_vector_type { + SEXP_NOT_A_UNIFORM_TYPE, + SEXP_U1, + SEXP_S8, + SEXP_U8, + SEXP_S16, + SEXP_U16, + SEXP_S32, + SEXP_U32, + SEXP_S64, + SEXP_U64, + SEXP_F32, + SEXP_F64, + SEXP_C64, + SEXP_C128 +}; + +#define sexp_uvector_freep(x) (sexp_freep(x)) +#define sexp_uvector_element_size(uvt) (sexp_uvector_sizes[uvt]) +#define sexp_uvector_prefix(uvt) (sexp_uvector_chars[uvt]) + +#define sexp_uvector_length(x) (sexp_field(x, uvector, SEXP_UNIFORM_VECTOR, length)) +#define sexp_uvector_type(x) (sexp_field(x, uvector, SEXP_UNIFORM_VECTOR, element_type)) +#define sexp_uvector_data(x) (sexp_field(x, uvector, SEXP_UNIFORM_VECTOR, data)) +#define sexp_uvector_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_uvector_data(x)) +#define sexp_uvector_bytes(x) (sexp_field(x, uvector, SEXP_UNIFORM_VECTOR, bytes)) + +#define sexp_bit_ref(u1v, i) (((sexp_uvector_data(u1v)[i/8])>>(i%8))&1) +#define sexp_bit_set(u1v, i, x) (x ? (sexp_uvector_data(u1v)[i/8]|=(1<<(i%8))) : (sexp_uvector_data(u1v)[i/8]&=~(1<<(i%8)))) + #define sexp_string_size(x) (sexp_field(x, string, SEXP_STRING, length)) #if SEXP_USE_PACKED_STRINGS #define sexp_string_data(x) (sexp_field(x, string, SEXP_STRING, data)) @@ -1520,6 +1599,7 @@ SEXP_API sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_ SEXP_API sexp sexp_make_context(sexp ctx, size_t size, size_t max_size); SEXP_API sexp sexp_cons_op(sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail); SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_list3(sexp ctx, sexp a, sexp b, sexp c); SEXP_API sexp sexp_equalp_bound (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp depth, sexp bound); SEXP_API sexp sexp_equalp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b); SEXP_API sexp sexp_listp_op(sexp ctx, sexp self, sexp_sint_t n, sexp obj); @@ -1533,6 +1613,7 @@ SEXP_API sexp sexp_length_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls); SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); SEXP_API sexp sexp_make_ephemeron_op(sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp value); SEXP_API sexp sexp_make_bytes_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i); +SEXP_API sexp sexp_make_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp elt_type, sexp len); SEXP_API sexp sexp_make_string_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp ch); SEXP_API sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); SEXP_API sexp sexp_subbytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); @@ -1544,6 +1625,7 @@ SEXP_API sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp SEXP_API sexp sexp_flonump_op (sexp ctx, sexp self, sexp_sint_t n, sexp x); SEXP_API sexp sexp_make_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp dflt); SEXP_API sexp sexp_list_to_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls); +SEXP_API sexp sexp_list_to_uvector_op (sexp ctx, sexp self, sexp_sint_t n, sexp etype, sexp ls); SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); SEXP_API int sexp_is_separator(int c); SEXP_API sexp sexp_write_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out); @@ -1600,6 +1682,7 @@ SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x); SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y); +SEXP_API sexp sexp_apply3 (sexp ctx, sexp f, sexp x, sexp y, sexp z); SEXP_API sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args); SEXP_API sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args); SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data); @@ -1732,12 +1815,14 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp); #define sexp_append2(ctx, a, b) sexp_append2_op(ctx, NULL, 2, a, b) #define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx, NULL, 2, a, b) #define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx, NULL, 1, x) +#define sexp_list_to_uvector(ctx, etype, ls) sexp_list_to_uvector_op(ctx, NULL, 2, etype, ls) #define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx, NULL, 1, x) #define sexp_string_to_symbol(ctx, s) sexp_string_to_symbol_op(ctx, NULL, 1, s) #define sexp_string_to_number(ctx, s, b) sexp_string_to_number_op(ctx, NULL, 2, s, b) #define sexp_symbol_to_string(ctx, s) sexp_symbol_to_string_op(ctx, NULL, 1, s) #define sexp_make_ephemeron(ctx, k, v) sexp_make_ephemeron_op(ctx, NULL, 2, k, v) #define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx, NULL, 2, l, i) +#define sexp_make_uvector(ctx, et, l) sexp_make_uvector_op(ctx, NULL, 2, et, l) #define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx, NULL, 2, l, c) #define sexp_subbytes(ctx, a, b, c) sexp_subbytes_op(ctx, NULL, 3, a, b, c) #define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx, NULL, 2, ls, s) diff --git a/lib/srfi/160/base.sld b/lib/srfi/160/base.sld new file mode 100644 index 00000000..3ccaae10 --- /dev/null +++ b/lib/srfi/160/base.sld @@ -0,0 +1,155 @@ + +(define-library (srfi 160 base) + (import (scheme base) + (only (chibi) list->uvector make-uvector)) + (export + ;; + make-u1vector u1vector u1? u1vector? + u1vector-ref u1vector-set! u1vector-length + u1vector->list list->u1vector + ;; + make-u8vector u8vector u8? u8vector? + u8vector-ref u8vector-set! u8vector-length + u8vector->list list->u8vector + ;; + make-s8vector s8vector s8? s8vector? + s8vector-ref s8vector-set! s8vector-length + s8vector->list list->s8vector + ;; + make-u16vector u16vector u16? u16vector? + u16vector-ref u16vector-set! u16vector-length + u16vector->list list->u16vector + ;; + make-s16vector s16vector s16? s16vector? + s16vector-ref s16vector-set! s16vector-length + s16vector->list list->s16vector + ;; + make-u32vector u32vector u32? u32vector? + u32vector-ref u32vector-set! u32vector-length + u32vector->list list->u32vector + ;; + make-s32vector s32vector s32? s32vector? + s32vector-ref s32vector-set! s32vector-length + s32vector->list list->s32vector + ;; + make-u64vector u64vector u64? u64vector? + u64vector-ref u64vector-set! u64vector-length + u64vector->list list->u64vector + ;; + make-s64vector s64vector s64? s64vector? + s64vector-ref s64vector-set! s64vector-length + s64vector->list list->s64vector + ;; + make-f32vector f32vector f32? f32vector? + f32vector-ref f32vector-set! f32vector-length + f32vector->list list->f32vector + ;; + make-f64vector f64vector f64? f64vector? + f64vector-ref f64vector-set! f64vector-length + f64vector->list list->f64vector + ;; + make-c64vector c64vector c64? c64vector? + c64vector-ref c64vector-set! c64vector-length + c64vector->list list->c64vector + ;; + make-c128vector c128vector c128? c128vector? + c128vector-ref c128vector-set! c128vector-length + c128vector->list list->c128vector + ) + (cond-expand + (uvector + (include-shared "uvprims")) + (else + (begin + ))) + (begin + (define u8vector? bytevector?) + (define u8vector-ref bytevector-u8-ref) + (define u8vector-set! bytevector-u8-set!) + (define (u1? x) (memq x '(0 1))) + (define (u8? x) (and (exact-integer? x) (<= 0 x 255))) + (define (s8? x) (and (exact-integer? x) (<= -128 x 127))) + (define (u16? x) (and (exact-integer? x) (<= 0 x 65536))) + (define (s16? x) (and (exact-integer? x) (<= -32768 x 32767))) + (define (u32? x) (and (exact-integer? x) (<= 0 x 4294967296))) + (define (s32? x) (and (exact-integer? x) (<= -2147483648 x 2147483647))) + (define (u64? x) (and (exact-integer? x) (<= 0 x 18446744073709551616))) + (define (s64? x) + (and (exact-integer? x) (<= -9223372036854775808 x 9223372036854775807))) + (define (f32? x) (and (real? x) (inexact? x))) + (define (f64? x) (and (real? x) (inexact? x))) + (define (c64? x) (and (complex? x) (inexact? x))) + (define (c128? x) (and (complex? x) (inexact? x))) + (define u1vector-length uvector-length) + (define u8vector-length bytevector-length) + (define s8vector-length uvector-length) + (define u16vector-length uvector-length) + (define s16vector-length uvector-length) + (define u32vector-length uvector-length) + (define s32vector-length uvector-length) + (define u64vector-length uvector-length) + (define s64vector-length uvector-length) + (define f32vector-length uvector-length) + (define f64vector-length uvector-length) + (define c64vector-length uvector-length) + (define c128vector-length uvector-length) + (define (list->u1vector ls) (list->uvector SEXP_U1 ls)) + (define (list->u8vector ls) (apply u8vector ls)) + (define (list->s8vector ls) (list->uvector SEXP_S8 ls)) + (define (list->u16vector ls) (list->uvector SEXP_U16 ls)) + (define (list->s16vector ls) (list->uvector SEXP_S16 ls)) + (define (list->u32vector ls) (list->uvector SEXP_U32 ls)) + (define (list->s32vector ls) (list->uvector SEXP_S32 ls)) + (define (list->u64vector ls) (list->uvector SEXP_U64 ls)) + (define (list->s64vector ls) (list->uvector SEXP_S64 ls)) + (define (list->f32vector ls) (list->uvector SEXP_F32 ls)) + (define (list->f64vector ls) (list->uvector SEXP_F64 ls)) + (define (list->c64vector ls) (list->uvector SEXP_C64 ls)) + (define (list->c128vector ls) (list->uvector SEXP_C128 ls)) + (define (u1vector . ls) (list->u1vector ls)) + (define (u8vector . ls) (list->u8vector ls)) + (define (s8vector . ls) (list->s8vector ls)) + (define (u16vector . ls) (list->u16vector ls)) + (define (s16vector . ls) (list->s16vector ls)) + (define (u32vector . ls) (list->u32vector ls)) + (define (s32vector . ls) (list->s32vector ls)) + (define (u64vector . ls) (list->u64vector ls)) + (define (s64vector . ls) (list->s64vector ls)) + (define (f32vector . ls) (list->f32vector ls)) + (define (f64vector . ls) (list->f64vector ls)) + (define (c64vector . ls) (list->c64vector ls)) + (define (c128vector . ls) (list->c128vector ls)) + (define (make-u1vector len) (make-u1vector SEXP_U1 len)) + (define make-u8vector make-bytevector) + (define (make-s8vector len) (make-s8vector SEXP_S8 len)) + (define (make-u16vector len) (make-u16vector SEXP_U16 len)) + (define (make-s16vector len) (make-s16vector SEXP_S16 len)) + (define (make-u32vector len) (make-u32vector SEXP_U32 len)) + (define (make-s32vector len) (make-s32vector SEXP_S32 len)) + (define (make-u64vector len) (make-u64vector SEXP_U64 len)) + (define (make-s64vector len) (make-s64vector SEXP_S64 len)) + (define (make-f32vector len) (make-f32vector SEXP_F32 len)) + (define (make-f64vector len) (make-f64vector SEXP_F64 len)) + (define (make-c64vector len) (make-c64vector SEXP_C64 len)) + (define (make-c128vector len) (make-c128vector SEXP_C128 len)) + (define-syntax define-uvector->list + (syntax-rules () + ((define-uvector->list uv->list len ref) + (define (uv->list uv) + (do ((i (- (len uv) 1) (- i 1)) + (res '() (cons (ref uv i) res))) + ((< i 0) res)))))) + (define-uvector->list u1vector->list u1vector-length u1vector-ref) + (define-uvector->list u8vector->list bytevector-length bytevector-u8-ref) + (define-uvector->list s8vector->list s8vector-length s8vector-ref) + (define-uvector->list u16vector->list u16vector-length u16vector-ref) + (define-uvector->list s16vector->list s16vector-length s16vector-ref) + (define-uvector->list u32vector->list u32vector-length u32vector-ref) + (define-uvector->list s32vector->list s32vector-length s32vector-ref) + (define-uvector->list u64vector->list u64vector-length u64vector-ref) + (define-uvector->list s64vector->list s64vector-length s64vector-ref) + (define-uvector->list f32vector->list f32vector-length f32vector-ref) + (define-uvector->list f64vector->list f64vector-length f64vector-ref) + (define-uvector->list c64vector->list c64vector-length c64vector-ref) + (define-uvector->list c128vector->list c128vector-length c128vector-ref) + )) diff --git a/lib/srfi/160/uvprims.stub b/lib/srfi/160/uvprims.stub new file mode 100644 index 00000000..607c1d4f --- /dev/null +++ b/lib/srfi/160/uvprims.stub @@ -0,0 +1,170 @@ + +(define-c-const int + SEXP_U1 + SEXP_S8 + SEXP_U8 + SEXP_S16 + SEXP_U16 + SEXP_S32 + SEXP_U32 + SEXP_S64 + SEXP_U64 + SEXP_F32 + SEXP_F64 + SEXP_C64 + SEXP_C128) + + (c-declare " +int uvector_of(sexp uv, int etype) { + return sexp_uvectorp(uv) && sexp_uvector_type(uv) == etype; +} + +int u1vector_ref(sexp uv, int i) { + return sexp_bit_ref(uv, i); +} +void u1vector_set(sexp uv, int i, int b) { + sexp_bit_set(uv, i, b); +} + +signed char s8vector_ref(signed char* uv, int i) { + return uv[i]; +} +void s8vector_set(signed char* uv, int i, signed char v) { + uv[i] = v; +} + +unsigned short u16vector_ref(unsigned short* uv, int i) { + return uv[i]; +} +void u16vector_set(unsigned short* uv, int i, unsigned short v) { + uv[i] = v; +} + +short s16vector_ref(short* uv, int i) { + return uv[i]; +} +void s16vector_set(short* uv, int i, short v) { + uv[i] = v; +} + +unsigned int u32vector_ref(unsigned int* uv, int i) { + return uv[i]; +} +void u32vector_set(unsigned int* uv, int i, unsigned int v) { + uv[i] = v; +} + +int s32vector_ref(int* uv, int i) { + return uv[i]; +} +void s32vector_set(int* uv, int i, int v) { + uv[i] = v; +} + +unsigned long u64vector_ref(unsigned long* uv, int i) { + return uv[i]; +} +void u64vector_set(unsigned long* uv, int i, unsigned long v) { + uv[i] = v; +} + +long s64vector_ref(long* uv, int i) { + return uv[i]; +} +void s64vector_set(long* uv, int i, long v) { + uv[i] = v; +} + +float f32vector_ref(float* uv, int i) { + return uv[i]; +} +void f32vector_set(float* uv, int i, float v) { + uv[i] = v; +} + +double f64vector_ref(double* uv, int i) { + return uv[i]; +} +void f64vector_set(double* uv, int i, double v) { + uv[i] = v; +} + +sexp c64vector_ref(sexp ctx, float* uv, int i) { + sexp_gc_var3(real, imag, res); + sexp_gc_preserve3(ctx, real, imag, res); + real = sexp_make_flonum(ctx, uv[i*2]); + imag = sexp_make_flonum(ctx, uv[i*2 + 1]); + res = sexp_make_complex(ctx, real, imag); + sexp_gc_release3(ctx); + return res; +} +void c64vector_set(float* uv, int i, sexp v) { + uv[i*2] = sexp_to_double(sexp_real_part(v)); + uv[i*2 + 1] = sexp_to_double(sexp_imag_part(v)); +} + +sexp c128vector_ref(sexp ctx, double* uv, int i) { + sexp_gc_var3(real, imag, res); + sexp_gc_preserve3(ctx, real, imag, res); + real = sexp_make_flonum(ctx, uv[i*2]); + imag = sexp_make_flonum(ctx, uv[i*2 + 1]); + res = sexp_make_complex(ctx, real, imag); + sexp_gc_release3(ctx); + return res; +} +void c128vector_set(double* uv, int i, sexp v) { + uv[i*2] = sexp_to_double(sexp_real_part(v)); + uv[i*2 + 1] = sexp_to_double(sexp_imag_part(v)); +} +") + +(define-c int (uvector-length "sexp_uvector_length") (uvector)) + +(define-c int (u1vector? "uvector_of") (uvector (value SEXP_U1 int))) +(define-c int (s8vector? "uvector_of") (uvector (value SEXP_S8 int))) +(define-c int (u16vector? "uvector_of") (uvector (value SEXP_U16 int))) +(define-c int (s16vector? "uvector_of") (uvector (value SEXP_S16 int))) +(define-c int (u32vector? "uvector_of") (uvector (value SEXP_U32 int))) +(define-c int (s32vector? "uvector_of") (uvector (value SEXP_S32 int))) +(define-c int (u64vector? "uvector_of") (uvector (value SEXP_U64 int))) +(define-c int (s64vector? "uvector_of") (uvector (value SEXP_S64 int))) +(define-c int (f32vector? "uvector_of") (uvector (value SEXP_F32 int))) +(define-c int (f64vector? "uvector_of") (uvector (value SEXP_F64 int))) +(define-c int (c64vector? "uvector_of") (uvector (value SEXP_C64 int))) +(define-c int (c128vector? "uvector_of") (uvector (value SEXP_C128 int))) + +(define-c int u1vector-ref (sexp int)) +(define-c void (u1vector-set! "u1vector_set") (sexp int int)) + +(define-c signed-char s8vector-ref (s8vector int)) +(define-c void (s8vector-set! "s8vector_set") (s8vector int signed-char)) + +(define-c unsigned-short u16vector-ref (u16vector int)) +(define-c void (u16vector-set! "u16vector_set") (u16vector int unsigned-short)) + +(define-c short s16vector-ref (s16vector int)) +(define-c void (s16vector-set! "s16vector_set") (s16vector int short)) + +(define-c unsigned-int u32vector-ref (u32vector int)) +(define-c void (u32vector-set! "u32vector_set") (u32vector int unsigned-int)) + +(define-c int s32vector-ref (s32vector int)) +(define-c void (s32vector-set! "s32vector_set") (s32vector int int)) + +(define-c unsigned-long u64vector-ref (u64vector int)) +(define-c void (u64vector-set! "u64vector_set") (u64vector int unsigned-long)) + +(define-c long s64vector-ref (s64vector int)) +(define-c void (s64vector-set! "s64vector_set") (s64vector int long)) + +(define-c float f32vector-ref (f32vector int)) +(define-c void (f32vector-set! "f32vector_set") (f32vector int float)) + +(define-c double f64vector-ref (f64vector int)) +(define-c void (f64vector-set! "f64vector_set") (f64vector int double)) + +(define-c sexp c64vector-ref ((value ctx sexp) c64vector int)) +(define-c void (c64vector-set! "c64vector_set") (c64vector int sexp)) + +(define-c sexp c128vector-ref ((value ctx sexp) c128vector int)) +(define-c void (c128vector-set! "c128vector_set") (c128vector int sexp)) diff --git a/lib/srfi/38.scm b/lib/srfi/38.scm index 0b3c28b8..56e0dc8c 100644 --- a/lib/srfi/38.scm +++ b/lib/srfi/38.scm @@ -189,6 +189,32 @@ ("escape" . ,(integer->char 27)) ("delete" . ,(integer->char 127)))) +(define U1 1) +(define S8 2) +(define U8 3) +(define S16 4) +(define U16 5) +(define S32 6) +(define U32 7) +(define S64 8) +(define U64 9) +(define F32 10) +(define F64 11) +(define C64 12) +(define C128 13) + +(define (resolve-uniform-type c prec) + (or + (case prec + ((1) (and (eqv? c #\u) U1)) + ((8) (case c ((#\u) U8) ((#\s) S8) (else #f))) + ((16) (case c ((#\u) U16) ((#\s) S16) (else #f))) + ((32) (case c ((#\u) U32) ((#\s) S32) ((#\f) F32) (else #f))) + ((64) (case c ((#\u) U64) ((#\s) S64) ((#\f) F64) ((#\c) C64) (else #f))) + ((128) (case c ((#\c) C128) (else #f))) + (else #f)) + (error "invalid uniform type" c prec))) + (define read-with-shared-structure (let ((read read)) (lambda o @@ -370,18 +396,26 @@ ((#\() (list->vector (read-one in))) ((#\') (read-char in) (list 'syntax (read-one in))) ((#\`) (read-char in) (list 'quasisyntax (read-one in))) - ((#\,) (read-char in) - (let ((sym (if (eqv? #\@ (peek-char in)) - (begin (read-char in) 'unsyntax-splicing) - 'unsyntax))) - (list sym (read-one in)))) - ((#\t) (let ((s (read-name #f in))) - (or (string-ci=? s "t") (string-ci=? s "true") - (read-error "bad # syntax" s)))) - ((#\f) (let ((s (read-name #f in))) - (if (or (string-ci=? s "f") (string-ci=? s "false")) - #f - (read-error "bad # syntax" s)))) + ((#\,) (read-char in) + (let ((sym (if (eqv? #\@ (peek-char in)) + (begin (read-char in) 'unsyntax-splicing) + 'unsyntax))) + (list sym (read-one in)))) + ((#\t) + (let ((s (read-name #f in))) + (or (string-ci=? s "t") (string-ci=? s "true") + (read-error "bad # syntax" s)))) + ((#\f) + (let ((s (read-name #f in))) + (cond + ((or (string-ci=? s "f") (string-ci=? s "false")) + #f) + ((member s '("f32" "F32")) + (list->uvector F32 (read in))) + ((member s '("f64" "F64")) + (list->uvector F64 (read in))) + (else + (read-error "bad # syntax" s))))) ((#\d) (read-char in) (read in)) ((#\x) (read-char in) (read-number 16)) ((#\o) (read-char in) (read-number 8)) @@ -391,21 +425,16 @@ (let ((s (read-name #\# in))) (or (string->number s) (read-one (open-input-string (substring s 2)))))) - ((#\u #\v) - (if (eqv? #\v (peek-char in)) + ((#\u #\v #\s #\c) + (if (char-ci=? #\v (peek-char in)) (read-char in)) - (read-char in) - (if (not (eqv? #\8 (peek-char in))) - (read-error "invalid syntax #u" (peek-char in))) - (read-char in) - (let ((ls (read-one in))) + (let* ((c (char-downcase (read-char in))) + (prec (read-number 10)) + (etype (resolve-uniform-type c prec)) + (ls (read-one in))) (if (not (list? ls)) - (read-error "invalid bytevector syntax" ls)) - (let* ((len (length ls)) - (bv (make-bytevector len))) - (do ((i 0 (+ i 1)) (ls ls (cdr ls))) - ((null? ls) bv) - (bytevector-u8-set! bv i (car ls)))))) + (read-error "invalid uniform vector syntax" ls)) + (list->uvector etype ls))) ((#\\) (read-char in) (let* ((c1 (read-char in)) diff --git a/lib/srfi/38.sld b/lib/srfi/38.sld index 60a6c31c..4be2cee6 100644 --- a/lib/srfi/38.sld +++ b/lib/srfi/38.sld @@ -3,4 +3,17 @@ (import (chibi) (srfi 69) (chibi ast)) (export write-with-shared-structure write/ss read-with-shared-structure read/ss) - (include "38.scm")) + (include "38.scm") + (cond-expand + (uvector + ) + (else + (begin + (define (list->uvector etype ls) + (if (eq? etype U8) + (let* ((len (length ls)) + (bv (make-bytevector len))) + (do ((i 0 (+ i 1)) (ls ls (cdr ls))) + ((null? ls) bv) + (bytevector-u8-set! bv i (car ls)))) + (list->vector ls))))))) diff --git a/opcodes.c b/opcodes.c index 4f7f259a..744bb46d 100644 --- a/opcodes.c +++ b/opcodes.c @@ -259,8 +259,8 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEX #else _FN1(_I(SEXP_OBJECT), _I(SEXP_IPORT), "port-fileno", 0, sexp_get_port_fileno), #endif -#if SEXP_USE_MODULES _FN0(_I(SEXP_ENV), "current-environment", 0, sexp_current_environment), +#if SEXP_USE_MODULES _FN1(_I(SEXP_ENV), _I(SEXP_ENV), "set-current-environment!", 0, sexp_set_current_environment), _FN0(_I(SEXP_ENV), "%meta-env", 0, sexp_meta_environment), _FN1(SEXP_NULL, _I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), @@ -284,6 +284,10 @@ _OP(SEXP_OPC_GENERIC, SEXP_OP_FORCE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEX _FN2(_I(SEXP_PROMISE), _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "promise", 0, sexp_make_promise), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "promise?", _I(SEXP_PROMISE), 0), #endif +#if SEXP_USE_UNIFORM_VECTOR_LITERALS +_FN2(_I(SEXP_UNIFORM_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), "list->uvector", 0, sexp_list_to_uvector_op), +_FN2(_I(SEXP_UNIFORM_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-uvector", 0, sexp_make_uvector_op), +#endif _OP(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), }; diff --git a/sexp.c b/sexp.c index 6d771bc7..324f103a 100644 --- a/sexp.c +++ b/sexp.c @@ -133,6 +133,62 @@ sexp sexp_write_simple_object (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sex #define sexp_write_simple_object NULL #endif +#if SEXP_USE_UNIFORM_VECTOR_LITERALS +sexp sexp_write_uvector(sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp writer, sexp out) { + sexp_uint_t i, len; + char* str; + sexp_gc_var2(f, tmp); + sexp_gc_preserve2(ctx, f, tmp); + f = sexp_make_flonum(ctx, 0.0f); + sexp_write_char(ctx, '#', out); + sexp_write_char(ctx, sexp_uvector_prefix(sexp_uvector_type(obj)), out); + sexp_write(ctx, sexp_make_fixnum(sexp_uvector_element_size(sexp_uvector_type(obj))), out); + sexp_write_char(ctx, '(', out); + len = sexp_uvector_length(obj); + str = (char*) sexp_uvector_data(obj); + for (i=0; i<(sexp_sint_t)len; i++) { + if (i!=0) sexp_write_char(ctx, ' ', out); + switch (sexp_uvector_type(obj)) { + case SEXP_U1: sexp_write(ctx, sexp_make_fixnum(sexp_bit_ref(obj, i)), out); break; + case SEXP_S8: sexp_write(ctx, sexp_make_fixnum(((signed char*)str)[i]), out); break; + case SEXP_S16: sexp_write(ctx, sexp_make_fixnum(((signed short*)str)[i]), out); break; + case SEXP_U16: sexp_write(ctx, sexp_make_fixnum(((unsigned short*)str)[i]), out); break; + case SEXP_S32: sexp_write(ctx, tmp=sexp_make_integer(ctx, ((signed int*)str)[i]), out); break; + case SEXP_U32: sexp_write(ctx, tmp=sexp_make_unsigned_integer(ctx, ((unsigned int*)str)[i]), out); break; + case SEXP_S64: sexp_write(ctx, tmp=sexp_make_integer(ctx, ((signed int*)str)[i]), out); break; + case SEXP_U64: sexp_write(ctx, tmp=sexp_make_unsigned_integer(ctx, ((unsigned int*)str)[i]), out); break; +#if SEXP_USE_FLONUMS + case SEXP_F32: sexp_flonum_value_set(f, ((float*)str)[i]); sexp_write(ctx, f, out); break; + case SEXP_F64: sexp_flonum_value_set(f, ((double*)str)[i]); sexp_write(ctx, f, out); break; +#endif +#if SEXP_USE_COMPLEX + case SEXP_C64: + sexp_flonum_value_set(f, ((float*)str)[i*2]); + sexp_write(ctx, f, out); + if (((float*)str)[i*2 + 1] >= 0) + sexp_write_char(ctx, '+', out); + sexp_flonum_value_set(f, ((float*)str)[i*2 + 1]); + sexp_write(ctx, f, out); + sexp_write_char(ctx, 'i', out); + break; + case SEXP_C128: + sexp_flonum_value_set(f, ((double*)str)[i*2]); + sexp_write(ctx, f, out); + if (((double*)str)[i*2 + 1] >= 0) + sexp_write_char(ctx, '+', out); + sexp_flonum_value_set(f, ((double*)str)[i*2 + 1]); + sexp_write(ctx, f, out); + sexp_write_char(ctx, 'i', out); + break; +#endif + } + } + sexp_write_char(ctx, ')', out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} +#endif + sexp sexp_finalize_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp fileno) { if (sexp_fileno_openp(fileno) && !sexp_fileno_no_closep(fileno)) { sexp_fileno_openp(fileno) = 0; @@ -185,6 +241,14 @@ sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl) { #endif #endif +#if SEXP_USE_UNIFORM_VECTOR_LITERALS +sexp sexp_finalize_uvector (sexp ctx, sexp self, sexp_sint_t n, sexp obj) { + if (sexp_uvector_freep(obj)) + free(sexp_uvector_data(obj)); + return SEXP_VOID; +} +#endif + static struct sexp_type_struct _sexp_type_specs[] = { {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, {SEXP_TYPE, sexp_offsetof(type, name), 8+SEXP_USE_DL, 8+SEXP_USE_DL, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, @@ -236,6 +300,9 @@ static struct sexp_type_struct _sexp_type_specs[] = { {SEXP_STACK, sexp_offsetof(stack, data), 0, 0, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, {SEXP_CONTEXT, sexp_offsetof(context, stack), 12+SEXP_USE_DL, 12+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + {SEXP_UNIFORM_VECTOR, sexp_offsetof(uvector, bytes), 1, 1, 0, 0, sexp_sizeof(uvector), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Uniform-Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_uvector, NULL, (sexp)"sexp_finalize_uvector", sexp_finalize_uvector}, +#endif #if SEXP_USE_AUTO_FORCE {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #endif @@ -424,6 +491,9 @@ static const char* sexp_initial_features[] = { #if SEXP_USE_AUTO_FORCE "auto-force", #endif +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + "uvector", +#endif #if SEXP_USE_COMPLEX "complex", #endif @@ -812,6 +882,15 @@ sexp sexp_list2 (sexp ctx, sexp a, sexp b) { return res; } +sexp sexp_list3 (sexp ctx, sexp a, sexp b, sexp c) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_list2(ctx, b, c); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + return res; +} + sexp sexp_listp_op (sexp ctx, sexp self, sexp_sint_t n, sexp hare) { sexp turtle; if (! sexp_pairp(hare)) @@ -1024,6 +1103,46 @@ sexp sexp_make_bytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i) { return s; } +#if SEXP_USE_UNIFORM_VECTOR_LITERALS +sexp sexp_make_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp elt_type, sexp len) { + sexp_uint_t etype = sexp_unbox_fixnum(elt_type), elen = sexp_unbox_fixnum(len), clen; + sexp_gc_var1(res); + if (etype == SEXP_U8) + return sexp_make_bytes(ctx, len, SEXP_VOID); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, elt_type); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (etype < SEXP_U1 || etype > SEXP_C128) + return sexp_xtype_exception(ctx, self, "unknown uniform vector type", elt_type); + if (elen < 0) + return sexp_xtype_exception(ctx, self, "negative length", len); + sexp_gc_preserve1(ctx, res); + res = sexp_alloc_type(ctx, uvector, SEXP_UNIFORM_VECTOR); + if (!sexp_exceptionp(res)) { + clen = ((elen * sexp_uvector_element_size(etype)) + 7) / 8; + sexp_uvector_type(res) = etype; + sexp_uvector_length(res) = elen; + sexp_uvector_bytes(res) = sexp_make_bytes(ctx, sexp_make_fixnum(clen), SEXP_VOID); + if (sexp_exceptionp(sexp_uvector_bytes(res))) + res = sexp_uvector_bytes(res); + else + sexp_uvector_data(res) = (unsigned char*) sexp_bytes_data(sexp_uvector_bytes(res)); + } + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_make_cuvector(sexp ctx, sexp_uint_t etype, void* cptr, int freep) { + sexp res = sexp_alloc_type(ctx, uvector, SEXP_UNIFORM_VECTOR); + if (!sexp_exceptionp(res)) { + sexp_uvector_type(res) = etype; + sexp_uvector_length(res) = -1; + sexp_uvector_data(res) = cptr; + sexp_uvector_freep(res) = freep; + } + return res; +} +#endif + #if SEXP_USE_UTF8_STRINGS int sexp_utf8_initial_byte_count (int c) { @@ -1869,17 +1988,6 @@ static struct {const char* name; char ch;} sexp_char_names[] = { #define sexp_num_char_names (sizeof(sexp_char_names)/sizeof(sexp_char_names[0])) -sexp sexp_apply_writer(sexp ctx, sexp writer, sexp obj, sexp out) { - sexp res; - sexp_gc_var1(args); - sexp_gc_preserve1(ctx, args); - args = sexp_list2(ctx, NULL, out); - args = sexp_cons(ctx, obj, args); - res = sexp_apply(ctx, writer, args); - sexp_gc_release1(ctx); - return res; -} - sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { #if SEXP_USE_HUFF_SYMS sexp_uint_t res; @@ -2111,7 +2219,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { x = sexp_type_by_index(ctx, i); #if SEXP_USE_TYPE_PRINTERS if (sexp_type_print(x)) { - x = sexp_apply_writer(ctx, sexp_type_print(x), obj, out); + x = sexp_apply3(ctx, sexp_type_print(x), obj, SEXP_FALSE, out); if (sexp_exceptionp(x)) return x; } else { #endif @@ -2775,6 +2883,123 @@ static int sexp_peek_char(sexp ctx, sexp in) { return c; } +#if SEXP_USE_UNIFORM_VECTOR_LITERALS +static int sexp_resolve_uniform_type(int c, sexp len) { + switch (sexp_fixnump(len) ? sexp_unbox_fixnum(len) : 0) { + case 1: if (c=='u') return SEXP_U1; break; + case 8: if (c=='u') return SEXP_U8; if (c=='s') return SEXP_S8; break; + case 16: if (c=='u') return SEXP_U16; if (c=='s') return SEXP_S16; break; + case 32: if (c=='u') return SEXP_U32; if (c=='s') return SEXP_S32; if (c=='f') return SEXP_F32; break; + case 64: if (c=='u') return SEXP_U64; if (c=='s') return SEXP_S64; if (c=='f') return SEXP_F64; if (c=='c') return SEXP_C64; break; + case 128: if (c=='c') return SEXP_C128; break; + } + return SEXP_NOT_A_UNIFORM_TYPE; +} +#else +#define sexp_resolve_uniform_type(c, len) SEXP_U8 +#endif + +sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sexp ls) { + int et, i, min, max; + sexp ls2, tmp; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, etype); + sexp_gc_var1(res); + if (!sexp_listp(ctx, ls)) { + res = sexp_exceptionp(ls) ? ls + : sexp_xtype_exception(ctx, self, "list->uvector expected a list", ls); + } else { + sexp_gc_preserve1(ctx, res); + et = sexp_unbox_fixnum(etype); + res = et == SEXP_U8 ? sexp_make_bytes(ctx, sexp_length(ctx, ls), SEXP_VOID) : sexp_make_uvector(ctx, etype, sexp_length(ctx, ls)); + min = 0; + max = (1 << sexp_uvector_element_size(et)) - 1; + if (sexp_uvector_prefix(et) == 's') { + min = -(max/2) - 1; + max = (max/2); + } + for (ls2=ls; sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = sexp_car(ls2); + if ( +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + ((sexp_uvector_prefix(et) == 'u') || (sexp_uvector_prefix(et) == 's')) ? +#endif + !(sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) >= min + && sexp_unbox_fixnum(tmp) <= max) +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + : (sexp_uvector_prefix(et) == 'c') ? !sexp_numberp(tmp) : + !(sexp_exact_integerp(tmp) || sexp_realp(tmp)) +#endif + ) { + res = sexp_xtype_exception(ctx, self, "invalid uniform vector value", tmp); + break; + } + } + if (!sexp_exceptionp(res)) { + for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) { +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + switch (et) { + case SEXP_U1: + sexp_bit_set(res, i, sexp_unbox_fixnum(sexp_car(ls))); break; + case SEXP_S8: + ((signed char*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); break; + case SEXP_U8: +#endif + sexp_bytes_set(res, sexp_make_fixnum(i), sexp_car(ls)); +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + break; + case SEXP_S16: + ((signed short*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); break; + case SEXP_U16: + ((unsigned short*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); break; + case SEXP_S32: + ((signed int*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); break; + case SEXP_U32: + ((unsigned int*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); break; + case SEXP_S64: +#if SEXP_USE_BIGNUMS + if (sexp_bignump(sexp_car(ls))) + ((sexp_sint_t*)sexp_uvector_data(res))[i] = sexp_bignum_data(sexp_car(ls))[0] * sexp_bignum_sign(sexp_car(ls)); + else +#endif + ((sexp_sint_t*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); + break; + case SEXP_U64: +#if SEXP_USE_BIGNUMS + if (sexp_bignump(sexp_car(ls))) + ((sexp_uint_t*)sexp_uvector_data(res))[i] = sexp_bignum_data(sexp_car(ls))[0]; + else +#endif + ((sexp_uint_t*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); + break; +#if SEXP_USE_FLONUMS + case SEXP_F32: + ((float*)sexp_uvector_data(res))[i] = sexp_to_double(sexp_car(ls)); break; + case SEXP_F64: + ((double*)sexp_uvector_data(res))[i] = sexp_to_double(sexp_car(ls)); break; +#endif +#if SEXP_USE_COMPLEX + case SEXP_C64: + ((float*)sexp_uvector_data(res))[i*2] = + sexp_to_double(sexp_real_part(sexp_car(ls))); + ((float*)sexp_uvector_data(res))[i*2 + 1] = + sexp_to_double(sexp_imag_part(sexp_car(ls))); + break; + case SEXP_C128: + ((double*)sexp_uvector_data(res))[i*2] = + sexp_to_double(sexp_real_part(sexp_car(ls))); + ((double*)sexp_uvector_data(res))[i*2 + 1] = + sexp_to_double(sexp_imag_part(sexp_car(ls))); + break; +#endif + } +#endif /* SEXP_USE_UNIFORM_VECTOR_LITERALS */ + } + } + } + sexp_gc_release1(ctx); + return res; +} + sexp sexp_read_one (sexp ctx, sexp in, sexp *shares); sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) { @@ -2977,6 +3202,11 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) { if (c2 == EOF || sexp_is_separator(c2)) { res = (sexp_tolower(c1) == 't' ? SEXP_TRUE : SEXP_FALSE); sexp_push_char(ctx, c2, in); +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + } else if (sexp_isdigit(c2)) { + sexp_push_char(ctx, c2, in); + goto read_uvector; +#endif } else { sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 0); @@ -2999,27 +3229,20 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) { } /* ... FALLTHROUGH ... */ case 'u': case 'U': - if ((c1 = sexp_read_char(ctx, in)) == '8') { +#if SEXP_USE_UNIFORM_VECTOR_LITERALS + case 's': case 'S': + case 'c': case 'C': + read_uvector: +#endif + res = sexp_read_number(ctx, in, 10, 1); + c2 = sexp_resolve_uniform_type(sexp_tolower(c1), res); + if (sexp_exceptionp(res)) { + } else if (c2 != SEXP_NOT_A_UNIFORM_TYPE) { tmp = sexp_read_one(ctx, in, shares); - if (!sexp_listp(ctx, tmp)) { - res = sexp_exceptionp(tmp) ? tmp - : sexp_read_error(ctx, "invalid syntax object after #u8", tmp, in); - } else { - res = sexp_make_bytes(ctx, sexp_length(ctx, tmp), SEXP_VOID); - for (c1=0; sexp_pairp(tmp); tmp=sexp_cdr(tmp), c1++) { - tmp2 = sexp_car(tmp); - if (!(sexp_fixnump(tmp2) && sexp_unbox_fixnum(tmp2) >= 0 - && sexp_unbox_fixnum(tmp2) < 0x100)) { - res = sexp_read_error(ctx, "invalid bytevector value", tmp2, in); - break; - } else { - sexp_bytes_set(res, sexp_make_fixnum(c1), tmp2); - } - } - } + res = sexp_list_to_uvector(ctx, sexp_make_fixnum(c2), tmp); } else { - tmp = sexp_list2(ctx, sexp_make_character('u'), sexp_make_character(c1)); - res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in); + tmp = sexp_list2(ctx, sexp_make_character(c1), res); + res = sexp_read_error(ctx, "invalid uniform vector syntax #%c%c", tmp, in); } break; #endif diff --git a/tests/ffi/ffi-tests.scm b/tests/ffi/ffi-tests.scm index 4515664c..f2607a16 100644 --- a/tests/ffi/ffi-tests.scm +++ b/tests/ffi/ffi-tests.scm @@ -547,6 +547,24 @@ struct vec2box { (list (vec2-x v) (vec2-y v)))) (test-assert (vec2box? (make-vec2box (make-vec2 17.0 23.0))))) +(test-ffi + "uniform vectors" + (begin + (c-declare " +float f32vector_ref(float* uv, int i) { + return uv[i]; +} +void f32vector_set(float* uv, int i, float v) { + uv[i] = v; +} +") + (define-c float f32vector-ref (f32vector int)) + (define-c void f32vector-set (f32vector int float))) + (let ((uv #f32(0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7))) + (test 0.3 (f32vector-ref uv 3)) + (f32vector-set uv 3 3.14) + (test 3.14 (f32vector-ref uv 3)))) + ;; TODO: virtual method accessors (cleanup-shared-objects!) diff --git a/tools/chibi-ffi b/tools/chibi-ffi index 132557f1..d51a0475 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -254,6 +254,45 @@ (or (and (eq? 'void (type-base type)) (type-pointer? type)) (eq? 'void* (type-base type)))) +(define (uniform-vector-type-code type) + (case type + ((u1vector) 'SEXP_U1) + ((u8vector) 'SEXP_U8) + ((s8vector) 'SEXP_S8) + ((u16vector) 'SEXP_U16) + ((s16vector) 'SEXP_S16) + ((u32vector) 'SEXP_U32) + ((s32vector) 'SEXP_S32) + ((u64vector) 'SEXP_U64) + ((s64vector) 'SEXP_S64) + ((f32vector) 'SEXP_F32) + ((f64vector) 'SEXP_F64) + ((c64vector) 'SEXP_C64) + ((c128vector) 'SEXP_C128) + (else #f))) + +(define (uniform-vector-type? type) + (or (eq? type 'uvector) + (and (uniform-vector-type-code type) #t))) + +(define (uniform-vector-ctype type) + (case type + ((uvector) "sexp") + ((u1vector) "char*") + ((u8vector) "unsigned char*") + ((s8vector) "signed char*") + ((u16vector) "unsigned short*") + ((s16vector) "signed short*") + ((u32vector) "unsigned int*") + ((s32vector) "signed int*") + ((u64vector) "sexp_uint_t*") + ((s64vector) "sexp_sint_t*") + ((f32vector) "float*") + ((f64vector) "double*") + ((c64vector) "float*") + ((c128vector) "double*") + (else #f))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; function objects @@ -663,15 +702,30 @@ ((int-type? base) "sexp_exact_integerp") ((float-type? base) "sexp_flonump") ((string-type? base) "sexp_stringp") - ((eq? base 'bytevector) "sexp_bytesp") - ((eq? base 'char) "sexp_charp") - ((memq base '(bool boolean status-bool)) "sexp_booleanp") - ((eq? base 'port) "sexp_portp") - ((eq? base 'input-port) "sexp_iportp") - ((eq? base 'output-port) "sexp_oportp") - ((eq? base 'input-output-port) "sexp_ioportp") - ((memq base '(fileno fileno-nonblock)) "sexp_filenop") - (else #f)))) + (else + (case base + ((bytevector u8vector) "sexp_bytesp") + ((char) "sexp_charp") + ((bool boolean status-bool) "sexp_booleanp") + ((port) "sexp_portp") + ((input-port) "sexp_iportp") + ((output-port) "sexp_oportp") + ((input-output-port) "sexp_ioportp") + ((fileno fileno-nonblock) "sexp_filenop") + ((uvector) "sexp_uvectorp") + ((u1vector) "sexp_u1vectorp") + ((s8vector) "sexp_s8vectorp") + ((u16vector) "sexp_u16vectorp") + ((s16vector) "sexp_s16vectorp") + ((u32vector) "sexp_u32vectorp") + ((s32vector) "sexp_s32vectorp") + ((u64vector) "sexp_u64vectorp") + ((s64vector) "sexp_s64vectorp") + ((f32vector) "sexp_f32vectorp") + ((f64vector) "sexp_f64vectorp") + ((c64vector) "sexp_c64vectorp") + ((c128vector) "sexp_c128vectorp") + (else #f)))))) (define (type-name type) (let ((base (type-base (parse-type type)))) @@ -687,7 +741,7 @@ ((int-type? base) "SEXP_FIXNUM") ((float-type? base) "SEXP_FLONUM") ((string-type? base) "SEXP_STRING") - ((eq? base 'bytevector) "SEXP_BYTES") + ((memq base '(bytevector u8vector)) "SEXP_BYTES") ((eq? base 'char) "SEXP_CHAR") ((memq base '(bool boolean status-bool)) "SEXP_BOOLEAN") ((eq? base 'string) "SEXP_STRING") @@ -698,6 +752,8 @@ ((eq? base 'output-port) "SEXP_OPORT") ((eq? base 'input-output-port) "SEXP_IPORT") ((memq base '(fileno fileno-nonblock)) "SEXP_FILENO") + ((uniform-vector-type? base) + "SEXP_UNIFORM_VECTOR") ((void-pointer-type? type) "SEXP_CPOINTER") ((lookup-type base) ;; (string-append "sexp_type_tag(" (type-id-name base) ")") @@ -738,6 +794,13 @@ "sexp_unbox_fixnum(res)" "-1")) +(define (c-type-free? type) + (or (type-free? type) + (type-new? type) + (and (type-result? type) + (not (basic-type? type)) + (not (type-no-free? type))))) + (define (c->scheme-converter type val . o) (let ((base (type-base type))) (cond @@ -768,7 +831,7 @@ (if (and *c++?* (eq? 'string base)) (cat "sexp_c_string(ctx, " val ".c_str(), " val ".size())") (cat "sexp_c_string(ctx, " val ", " (c-array-length type) ")"))) - ((eq? 'bytevector base) + ((memq base '(bytevector u8vector)) (if *c++?* (cat "sexp_string_to_bytes(ctx, sexp_c_string(ctx, " val ".data(), " val ".size()))") @@ -782,6 +845,11 @@ (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)")) ((memq base '(fileno fileno-nonblock)) (cat "sexp_make_fileno(ctx, sexp_make_fixnum(" val "), SEXP_FALSE)")) + ((eq? base 'uvector) + val) + ((uniform-vector-type? base) + (cat "sexp_make_cuvector(ctx, " (uniform-vector-type-code base) ", " + val ", " (if (c-type-free? type) 1 0))) (else (let ((ctype (lookup-type base)) (void*? (void-pointer-type? type))) @@ -794,13 +862,7 @@ (type-id-number type #t)) ", " val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " - (if (or (type-free? type) - (type-new? type) - (and (type-result? type) - (not (basic-type? type)) - (not (type-no-free? type)))) - 1 - 0) + (if (c-type-free? type) 1 0) ")")) (else (error "unknown type" base)))))))) @@ -832,7 +894,7 @@ "sexp_string_maybe_null_data" "sexp_string_data") "(" val ")")) - ((eq? base 'bytevector) + ((memq base '(bytevector u8vector)) (cat (if (type-null? type) "sexp_bytes_maybe_null_data" "sexp_bytes_data") @@ -846,6 +908,8 @@ ((memq base '(fileno fileno-nonblock)) (cat "(sexp_filenop(" val ") ? sexp_fileno_fd(" val ")" " : sexp_unbox_fixnum(" val "))")) + ((uniform-vector-type? base) + (cat "((" (uniform-vector-ctype base) ") sexp_uvector_data(" val "))")) (else (let ((ctype (lookup-type base)) (void*? (void-pointer-type? type))) @@ -863,7 +927,7 @@ (define (base-type-c-name base) (case base - ((string env-string non-null-string bytevector) + ((string env-string non-null-string bytevector u8vector) (if *c++?* "string" "char*")) ((fileno fileno-nonblock) "int") (else (string-replace (symbol->string base) #\- " ")))) @@ -916,8 +980,8 @@ (if (type-null? type) "(" "") (type-predicate type) "(" arg ")" (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) - ((or (eq? base 'char) (eq? base 'bytevector) (int-type? base) - (float-type? base) (port-type? base)) + ((or (eq? base 'char) (int-type? base) (float-type? base) (port-type? base) + (memq base '(bytevector u8vector)) (uniform-vector-type? base)) (cat (type-predicate type) "(" arg ")")) ((or (lookup-type base) (void-pointer-type? type)) (cat @@ -959,7 +1023,8 @@ (float-type? base-type) (string-type? base-type) (port-type? base-type) - (memq base-type '(bytevector fileno fileno-nonblock)) + (uniform-vector-type? base-type) + (memq base-type '(bytevector u8vector fileno fileno-nonblock)) (and (not array) (eq? 'char base-type))) (cat " if (! " (lambda () (check-type arg type)) ")\n" @@ -1160,7 +1225,8 @@ ((eq? name 'length) 'sexp_length_unboxed) ((eq? name 'string-length) 'sexp_string_length) ((eq? name 'string-size) 'sexp_string_size) - ((eq? name 'bytevector-length) 'sexp_bytes_length) + ((memq name '(bytevector-length u8vector-length)) 'sexp_bytes_length) + ((eq? name 'uvector-length) 'sexp_uvector_length) (else name))) (define (write-value func val) diff --git a/vm.c b/vm.c index 347f92c2..cdb6ef9f 100644 --- a/vm.c +++ b/vm.c @@ -2252,6 +2252,19 @@ sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y) { return res; } +sexp sexp_apply3 (sexp ctx, sexp f, sexp x, sexp y, sexp z) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f) && sexp_opcode_func(f)) { + res = ((sexp_proc4)sexp_opcode_func(f))(ctx, f, 3, x, y, z); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list3(ctx, x, y, z)); + sexp_gc_release1(ctx); + } + return res; +} + sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args) { sexp res, err_cell; sexp_gc_var2(handler, params);