Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding initial support for SRFI 160 uniform vectors

Browse source
This commit is contained in:
Alex Shinn 2019-01-15 23:43:50 +08:00
parent afd887e672
commit 2b4394ea74
16 changed files with 895 additions and 110 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Makefile
View file

@ -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

4
Makefile.detect
View file

@ -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)

30
bignum.c
View file

@ -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);

7
eval.c
View file

@ -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);

1
include/chibi/bignum.h
View file

@ -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);

9
include/chibi/features.h
View file

@ -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

91
include/chibi/sexp.h
View file

@ -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 <inttypes.h>
#include <stdint.h>
# 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 <stdint.h>
#if SEXP_USE_INTTYPES
#include <inttypes.h>
#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)

155
lib/srfi/160/base.sld Normal file
View file

@ -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)
))

170
lib/srfi/160/uvprims.stub Normal file
View file

@ -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))

79
lib/srfi/38.scm
View file

@ -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))

15
lib/srfi/38.sld
View file

@ -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)))))))

6
opcodes.c
View file

@ -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),
};

285
sexp.c
View file

@ -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

18
tests/ffi/ffi-tests.scm
View file

@ -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!)

114
tools/chibi-ffi
View file

@ -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)

13
vm.c
View file

@ -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);