diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7803c08c..68b37edf 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -269,6 +269,9 @@ typedef int32_t sexp_int32_t; # include # else # include +# if SEXP_USE_UNIFORM_VECTOR_LITERALS +# include +# endif # endif # if UCHAR_MAX == 255 # define SEXP_UINT8_DEFINED 1 @@ -287,7 +290,7 @@ typedef long sexp_int32_t; typedef unsigned short sexp_uint32_t; typedef short sexp_int32_t; # endif -#endif +#endif /* SEXP_USE_INTTYPES */ #if defined(__APPLE__) || defined(_WIN64) || (defined(__CYGWIN__) && __SIZEOF_POINTER__ == 8) #define SEXP_PRIdOFF "lld" @@ -398,6 +401,9 @@ struct sexp_mark_stack_ptr_t { struct sexp_mark_stack_ptr_t *prev; /* TODO: remove for allocations on stack */ }; +/* Note this must be kept in sync with the type registry in sexp.c. */ +/* sexp fields must be placed first if you use slot-ref/set!, as is */ +/* done by write. */ struct sexp_struct { sexp_tag_t tag; char markedp; @@ -430,9 +436,9 @@ struct sexp_struct { char data SEXP_FLEXIBLE_ARRAY; } bytes; struct { + sexp bytes; unsigned char element_type; sexp_sint_t length; - sexp bytes; } uvector; struct { #if SEXP_USE_PACKED_STRINGS @@ -451,15 +457,15 @@ struct sexp_struct { char data SEXP_FLEXIBLE_ARRAY; } symbol; struct { + sexp name; + sexp cookie; + sexp fd; FILE *stream; char *buf; char openp, bidirp, binaryp, shutdownp, no_closep, sourcep, blockedp, fold_casep; sexp_uint_t offset, line, flags; size_t size; - sexp name; - sexp cookie; - sexp fd; } port; struct { char openp, no_closep; @@ -480,9 +486,9 @@ struct sexp_struct { sexp real, imag; } complex; struct { + sexp parent; sexp_uint_t length; void *value; - sexp parent; char body SEXP_FLEXIBLE_ARRAY; } cpointer; /* runtime types */ @@ -493,14 +499,14 @@ struct sexp_struct { #endif } env; struct { - sexp_uint_t length, max_depth; sexp name, literals, source; + sexp_uint_t length, max_depth; unsigned char data SEXP_FLEXIBLE_ARRAY; } bytecode; struct { + sexp bc, vars; char flags; sexp_proc_num_args_t num_args; - sexp bc, vars; } procedure; struct { sexp proc, env, source, aux; @@ -572,8 +578,8 @@ struct sexp_struct { } context; #if SEXP_USE_STABLE_ABI || SEXP_USE_AUTO_FORCE struct { - int donep; sexp value; + int donep; } promise; #endif #if SEXP_USE_STABLE_ABI || SEXP_USE_WEAK_REFERENCES diff --git a/lib/srfi/160/test.sld b/lib/srfi/160/test.sld index 791027bc..9f5ca0a7 100644 --- a/lib/srfi/160/test.sld +++ b/lib/srfi/160/test.sld @@ -1,5 +1,7 @@ (define-library (srfi 160 test) - (import (scheme base) (srfi 160 u32) (chibi test)) + (import (scheme base) + (srfi 160 u32) (srfi 160 u64) (srfi 160 s64) + (chibi test)) (export run-tests) (begin (define (run-tests) @@ -19,6 +21,8 @@ (test '#u32(1 2 3 4) (u32vector-reverse-copy '#u32(5 4 3 2 1 0) 1 5)) (test '#u32(0 1) (u32vector-append '#u32(0) '#u32(1))) (test '#u32(0 1 2 3) (u32vector-append '#u32(0) '#u32(1 2 3))) + (test '#u64(0 1 2 3) (u64vector-append '#u64(0) '#u64(1 2 3))) + (test '#s64(0 -1 2 -3) (s64vector-append '#s64(0) '#s64(-1 2 -3))) (test '#u32(0 1 2 3) (u32vector-concatenate '(#u32(0 1) #u32(2 3)))) (test '#u32(0 1 6 7) (u32vector-append-subvectors '#u32(0 1 2 3 4) 0 2 '#u32(4 5 6 7 8) 2 4)) diff --git a/lib/srfi/160/u64.sld b/lib/srfi/160/u64.sld index de9aaafd..7c04249b 100644 --- a/lib/srfi/160/u64.sld +++ b/lib/srfi/160/u64.sld @@ -1,70 +1,70 @@ -(define-library (srfi 160 s64) +(define-library (srfi 160 u64) (export - make-s64vector - s64? - s64vector? - s64vector-ref - s64vector-set! - s64vector-length - (rename vector s64vector) - (rename uvector-unfold s64vector-unfold) - (rename uvector-unfold-right s64vector-unfold-right) - (rename vector-copy s64vector-copy) - (rename vector-reverse-copy s64vector-reverse-copy) - (rename vector-append s64vector-append) - (rename vector-concatenate s64vector-concatenate) - (rename vector-append-subvectors s64vector-append-subvectors) - (rename vector-empty? s64vector-empty?) - (rename vector= s64vector=) - (rename vector-take s64vector-take) - (rename vector-take-right s64vector-take-right) - (rename vector-drop s64vector-drop) - (rename vector-drop-right s64vector-drop-right) - (rename vector-segment s64vector-segment) - (rename vector-fold s64vector-fold) - (rename vector-fold-right s64vector-fold-right) - (rename vector-map s64vector-map) - (rename vector-map! s64vector-map!) - (rename vector-for-each s64vector-for-each) - (rename vector-count s64vector-count) - (rename vector-cumulate s64vector-cumulate) - (rename vector-take-while s64vector-take-while) - (rename vector-take-while-right s64vector-take-while-right) - (rename vector-drop-while s64vector-drop-while) - (rename vector-drop-while-right s64vector-drop-while-right) - (rename vector-index s64vector-index) - (rename vector-index-right s64vector-index-right) - (rename vector-skip s64vector-skip) - (rename vector-skip-right s64vector-skip-right) - (rename vector-binary-search s64vector-binary-search) - (rename vector-any s64vector-any) - (rename vector-every s64vector-every) - (rename vector-partition s64vector-partition) - (rename vector-filter s64vector-filter) - (rename vector-remove s64vector-remove) - (rename vector-swap! s64vector-swap!) - (rename vector-fill! s64vector-fill!) - (rename vector-reverse! s64vector-reverse!) - (rename vector-copy! s64vector-copy!) - (rename vector-reverse-copy! s64vector-reverse-copy!) - (rename uvector->list s64vector->list) - (rename reverse-vector->list reverse-s64vector->list) - (rename list->uvector list->s64vector) - (rename reverse-list->vector reverse-list->s64vector) - (rename uvector->vector s64vector->vector) - (rename vector->uvector vector->s64vector) - (rename make-vector-generator make-s64vector-generator) - (rename write-vector write-s64vector)) + make-u64vector + u64? + u64vector? + u64vector-ref + u64vector-set! + u64vector-length + (rename vector u64vector) + (rename uvector-unfold u64vector-unfold) + (rename uvector-unfold-right u64vector-unfold-right) + (rename vector-copy u64vector-copy) + (rename vector-reverse-copy u64vector-reverse-copy) + (rename vector-append u64vector-append) + (rename vector-concatenate u64vector-concatenate) + (rename vector-append-subvectors u64vector-append-subvectors) + (rename vector-empty? u64vector-empty?) + (rename vector= u64vector=) + (rename vector-take u64vector-take) + (rename vector-take-right u64vector-take-right) + (rename vector-drop u64vector-drop) + (rename vector-drop-right u64vector-drop-right) + (rename vector-segment u64vector-segment) + (rename vector-fold u64vector-fold) + (rename vector-fold-right u64vector-fold-right) + (rename vector-map u64vector-map) + (rename vector-map! u64vector-map!) + (rename vector-for-each u64vector-for-each) + (rename vector-count u64vector-count) + (rename vector-cumulate u64vector-cumulate) + (rename vector-take-while u64vector-take-while) + (rename vector-take-while-right u64vector-take-while-right) + (rename vector-drop-while u64vector-drop-while) + (rename vector-drop-while-right u64vector-drop-while-right) + (rename vector-index u64vector-index) + (rename vector-index-right u64vector-index-right) + (rename vector-skip u64vector-skip) + (rename vector-skip-right u64vector-skip-right) + (rename vector-binary-search u64vector-binary-search) + (rename vector-any u64vector-any) + (rename vector-every u64vector-every) + (rename vector-partition u64vector-partition) + (rename vector-filter u64vector-filter) + (rename vector-remove u64vector-remove) + (rename vector-swap! u64vector-swap!) + (rename vector-fill! u64vector-fill!) + (rename vector-reverse! u64vector-reverse!) + (rename vector-copy! u64vector-copy!) + (rename vector-reverse-copy! u64vector-reverse-copy!) + (rename uvector->list u64vector->list) + (rename reverse-vector->list reverse-u64vector->list) + (rename list->uvector list->u64vector) + (rename reverse-list->vector reverse-list->u64vector) + (rename uvector->vector u64vector->vector) + (rename vector->uvector vector->u64vector) + (rename make-vector-generator make-u64vector-generator) + (rename write-vector write-u64vector)) (import (except (scheme base) vector-append vector-copy vector-copy! vector-map vector-for-each) (scheme write) (srfi 160 base)) (begin - (define uvector? s64vector?) - (define make-uvector make-s64vector) - (define uvector-length s64vector-length) - (define uvector-ref s64vector-ref) - (define uvector-set! s64vector-set!)) + (define uvector? u64vector?) + (define make-uvector make-u64vector) + (define uvector-length u64vector-length) + (define uvector-ref u64vector-ref) + (define uvector-set! u64vector-set!)) (include "uvector.scm")) diff --git a/lib/srfi/160/uvprims.stub b/lib/srfi/160/uvprims.stub index d0eb609e..a1481a70 100644 --- a/lib/srfi/160/uvprims.stub +++ b/lib/srfi/160/uvprims.stub @@ -1,4 +1,6 @@ +(c-system-include "stdint.h") + (define-c-const int SEXP_U1 SEXP_S8 @@ -47,31 +49,31 @@ void s16vector_set(short* uv, int i, short v) { uv[i] = v; } -unsigned int u32vector_ref(unsigned int* uv, int i) { +uint32_t u32vector_ref(uint32_t* uv, int i) { return uv[i]; } -void u32vector_set(unsigned int* uv, int i, unsigned int v) { +void u32vector_set(uint32_t* uv, int i, uint32_t v) { uv[i] = v; } -int s32vector_ref(int* uv, int i) { +int32_t s32vector_ref(int32_t* uv, int i) { return uv[i]; } -void s32vector_set(int* uv, int i, int v) { +void s32vector_set(int32_t* uv, int i, int32_t v) { uv[i] = v; } -unsigned long u64vector_ref(unsigned long* uv, int i) { +uint64_t u64vector_ref(uint64_t* uv, int i) { return uv[i]; } -void u64vector_set(unsigned long* uv, int i, unsigned long v) { +void u64vector_set(uint64_t* uv, int i, uint64_t v) { uv[i] = v; } -long s64vector_ref(long* uv, int i) { +int64_t s64vector_ref(int64_t* uv, int i) { return uv[i]; } -void s64vector_set(long* uv, int i, long v) { +void s64vector_set(int64_t* uv, int i, int64_t v) { uv[i] = v; } @@ -148,14 +150,14 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) { (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 int32_t s32vector-ref (s32vector int)) +(define-c void (s32vector-set! "s32vector_set") (s32vector int int32_t)) -(define-c unsigned-long u64vector-ref (u64vector int)) -(define-c void (u64vector-set! "u64vector_set") (u64vector int unsigned-long)) +(define-c uint64_t u64vector-ref (u64vector int)) +(define-c void (u64vector-set! "u64vector_set") (u64vector int uint64_t)) -(define-c long s64vector-ref (s64vector int)) -(define-c void (s64vector-set! "s64vector_set") (s64vector int long)) +(define-c int64_t s64vector-ref (s64vector int)) +(define-c void (s64vector-set! "s64vector_set") (s64vector int int64_t)) (define-c float f32vector-ref (f32vector int)) (define-c void (f32vector-set! "f32vector_set") (f32vector int float)) diff --git a/sexp.c b/sexp.c index 41dc04a6..b17e808b 100644 --- a/sexp.c +++ b/sexp.c @@ -153,10 +153,10 @@ sexp sexp_write_uvector(sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp write 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; + case SEXP_S32: sexp_write(ctx, tmp=sexp_make_integer(ctx, ((int32_t*)str)[i]), out); break; + case SEXP_U32: sexp_write(ctx, tmp=sexp_make_unsigned_integer(ctx, ((uint32_t*)str)[i]), out); break; + case SEXP_S64: sexp_write(ctx, tmp=sexp_make_integer(ctx, ((int64_t*)str)[i]), out); break; + case SEXP_U64: sexp_write(ctx, tmp=sexp_make_unsigned_integer(ctx, ((uint64_t*)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; @@ -243,8 +243,8 @@ sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl) { #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)); + /* if (sexp_uvector_freep(obj)) */ + /* free(sexp_uvector_data(obj)); */ return SEXP_VOID; } #endif @@ -2998,8 +2998,9 @@ static int sexp_resolve_uniform_type(int c, sexp len) { #endif sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sexp ls) { - long et, i, min; - unsigned long max; + long et, i; + long long min; + unsigned long long max; sexp ls2, tmp; sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, etype); sexp_gc_var1(res); @@ -3010,12 +3011,13 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex 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 = sexp_uvector_element_size(et) == 64 ? -1 : - (1uLL << sexp_uvector_element_size(et)) - 1; if (sexp_uvector_prefix(et) == 's') { - min = -(max/2) - 1; - max = (max/2); + min = (-1LL << (sexp_uvector_element_size(et)-1)); + max = (1LL << (sexp_uvector_element_size(et)-1)) - 1LL; + } else { + min = 0; + max = sexp_uvector_element_size(et) == 64 ? -1 : + (1uLL << sexp_uvector_element_size(et)) - 1LL; } for (ls2=ls; sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { tmp = sexp_car(ls2); @@ -3023,14 +3025,18 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex #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) + !(sexp_exact_integerp(tmp) && sexp_sint_value(tmp) >= min + && (sexp_sint_value(tmp) < 0 || sexp_uint_value(tmp) <= max)) #if SEXP_USE_UNIFORM_VECTOR_LITERALS - : (sexp_uvector_prefix(et) == 'c') ? !sexp_numberp(tmp) : - !(sexp_exact_integerp(tmp) || sexp_realp(tmp)) + : ((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); + res = sexp_cons(ctx, SEXP_FALSE, SEXP_FALSE); + sexp_car(res) = sexp_make_integer(ctx, min); + sexp_cdr(res) = sexp_make_integer(ctx, max); + res = sexp_list2(ctx, res, tmp); + res = sexp_xtype_exception(ctx, self, "invalid uniform vector value", res); break; } } @@ -3052,25 +3058,13 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex 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; + ((signed int*)sexp_uvector_data(res))[i] = sexp_sint_value(sexp_car(ls)); break; case SEXP_U32: - ((unsigned int*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); break; + ((unsigned int*)sexp_uvector_data(res))[i] = sexp_uint_value(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; + ((sexp_sint_t*)sexp_uvector_data(res))[i] = sexp_sint_value(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; + ((sexp_uint_t*)sexp_uvector_data(res))[i] = sexp_uint_value(sexp_car(ls)); break; #if SEXP_USE_FLONUMS case SEXP_F32: ((float*)sexp_uvector_data(res))[i] = sexp_to_double(ctx, sexp_car(ls)); break; @@ -3095,8 +3089,8 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex #endif /* SEXP_USE_UNIFORM_VECTOR_LITERALS */ } } + sexp_gc_release1(ctx); } - sexp_gc_release1(ctx); return res; } diff --git a/tools/chibi-ffi b/tools/chibi-ffi index a0075fdb..d8cd34a1 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -214,13 +214,15 @@ (assq type *c-enum-types*)) (define (signed-int-type? type) - (or (memq type '(signed-char short int long s8 s16 s32 s64)) + (or (memq type '(signed-char short int long s8 s16 s32 s64 + int8_t int16_t int32_t int64_t)) (memq type *c-int-types*) (enum-type? type))) (define (unsigned-int-type? type) (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uint8_t uint16_t uint32_t uint64_t uid_t gid_t pid_t blksize_t blkcnt_t sigval_t u1 u8 u16 u32 u64))) @@ -290,10 +292,10 @@ ((s8vector) "signed char*") ((u16vector) "unsigned short*") ((s16vector) "signed short*") - ((u32vector) "unsigned int*") - ((s32vector) "signed int*") - ((u64vector) "sexp_uint_t*") - ((s64vector) "sexp_sint_t*") + ((u32vector) "uint32_t*") + ((s32vector) "int32_t*") + ((u64vector) "uint64_t*") + ((s64vector) "int64_t*") ((f32vector) "float*") ((f64vector) "double*") ((c64vector) "float*")