mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
f60298b707
Quarter precision is 1.5.2 format. Used to implement f16-storage-class and f8-storage-class. Can be disabled at compile time.
239 lines
7.5 KiB
Text
239 lines
7.5 KiB
Text
|
|
(c-system-include "stdint.h")
|
|
|
|
(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
|
|
SEXP_F8
|
|
SEXP_F16
|
|
)
|
|
|
|
(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;
|
|
}
|
|
|
|
uint32_t u32vector_ref(uint32_t* uv, int i) {
|
|
return uv[i];
|
|
}
|
|
void u32vector_set(uint32_t* uv, int i, uint32_t v) {
|
|
uv[i] = v;
|
|
}
|
|
|
|
int32_t s32vector_ref(int32_t* uv, int i) {
|
|
return uv[i];
|
|
}
|
|
void s32vector_set(int32_t* uv, int i, int32_t v) {
|
|
uv[i] = v;
|
|
}
|
|
|
|
uint64_t u64vector_ref(uint64_t* uv, int i) {
|
|
return uv[i];
|
|
}
|
|
void u64vector_set(uint64_t* uv, int i, uint64_t v) {
|
|
uv[i] = v;
|
|
}
|
|
|
|
int64_t s64vector_ref(int64_t* uv, int i) {
|
|
return uv[i];
|
|
}
|
|
void s64vector_set(int64_t* uv, int i, int64_t v) {
|
|
uv[i] = v;
|
|
}
|
|
|
|
float f8vector_ref(unsigned char* uv, int i) {
|
|
return sexp_quarter_to_double(uv[i]);
|
|
}
|
|
void f8vector_set(unsigned char* uv, int i, double v) {
|
|
uv[i] = sexp_double_to_quarter(v);
|
|
}
|
|
|
|
double f16vector_ref(unsigned short* uv, int i) {
|
|
return sexp_half_to_double(uv[i]);
|
|
}
|
|
void f16vector_set(unsigned short* uv, int i, double v) {
|
|
uv[i] = sexp_double_to_half(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(sexp ctx, float* uv, int i, sexp v) {
|
|
uv[i*2] = sexp_to_double(ctx, sexp_real_part(v));
|
|
uv[i*2 + 1] = sexp_to_double(ctx, 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(sexp ctx, double* uv, int i, sexp v) {
|
|
uv[i*2] = sexp_to_double(ctx, sexp_real_part(v));
|
|
uv[i*2 + 1] = sexp_to_double(ctx, sexp_imag_part(v));
|
|
}
|
|
")
|
|
|
|
(define-c long (uvector-length "sexp_uvector_length") (sexp))
|
|
|
|
(define-c boolean (u1vector? "uvector_of") (sexp (value SEXP_U1 int)))
|
|
(define-c boolean (s8vector? "uvector_of") (sexp (value SEXP_S8 int)))
|
|
(define-c boolean (u16vector? "uvector_of") (sexp (value SEXP_U16 int)))
|
|
(define-c boolean (s16vector? "uvector_of") (sexp (value SEXP_S16 int)))
|
|
(define-c boolean (u32vector? "uvector_of") (sexp (value SEXP_U32 int)))
|
|
(define-c boolean (s32vector? "uvector_of") (sexp (value SEXP_S32 int)))
|
|
(define-c boolean (u64vector? "uvector_of") (sexp (value SEXP_U64 int)))
|
|
(define-c boolean (s64vector? "uvector_of") (sexp (value SEXP_S64 int)))
|
|
(define-c boolean (f8vector? "uvector_of") (sexp (value SEXP_F8 int)))
|
|
(define-c boolean (f16vector? "uvector_of") (sexp (value SEXP_F16 int)))
|
|
(define-c boolean (f32vector? "uvector_of") (sexp (value SEXP_F32 int)))
|
|
(define-c boolean (f64vector? "uvector_of") (sexp (value SEXP_F64 int)))
|
|
(define-c boolean (c64vector? "uvector_of") (sexp (value SEXP_C64 int)))
|
|
(define-c boolean (c128vector? "uvector_of") (sexp (value SEXP_C128 int)))
|
|
|
|
(define-c int u1vector-ref (sexp int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (u1vector-set! "u1vector_set") (sexp int int)
|
|
(assert (mutable? arg0)
|
|
(< -1 arg1 (uvector-length arg0))
|
|
(< -1 arg2 (expt 2 1))))
|
|
|
|
(define-c signed-char s8vector-ref (s8vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (s8vector-set! "s8vector_set") (s8vector int signed-char)
|
|
(assert (mutable? arg0)
|
|
(< -1 arg1 (uvector-length arg0))
|
|
(<= (- (expt 2 7)) arg2 (- (expt 2 7) 1))))
|
|
|
|
(define-c unsigned-short u16vector-ref (u16vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (u16vector-set! "u16vector_set") (u16vector int unsigned-short)
|
|
(assert (mutable? arg0)
|
|
(< -1 arg1 (uvector-length arg0))
|
|
(<= 0 arg2 (expt 2 16))))
|
|
|
|
(define-c short s16vector-ref (s16vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (s16vector-set! "s16vector_set") (s16vector int short)
|
|
(assert (mutable? arg0)
|
|
(< -1 arg1 (uvector-length arg0))
|
|
(<= (- (expt 2 15)) arg2 (- (expt 2 15) 1))))
|
|
|
|
(define-c unsigned-int u32vector-ref (u32vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (u32vector-set! "u32vector_set") (u32vector int unsigned-int)
|
|
(assert (mutable? arg0)
|
|
(< -1 arg1 (uvector-length arg0))
|
|
(<= 0 arg2 (expt 2 32))))
|
|
|
|
(define-c int32_t s32vector-ref (s32vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (s32vector-set! "s32vector_set") (s32vector int int32_t)
|
|
(assert (mutable? arg0)
|
|
(< -1 arg1 (uvector-length arg0))
|
|
(<= (- (expt 2 31)) arg2 (- (expt 2 31) 1))))
|
|
|
|
(define-c uint64_t u64vector-ref (u64vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (u64vector-set! "u64vector_set") (u64vector int uint64_t)
|
|
(assert (mutable? arg0)
|
|
(< -1 arg1 (uvector-length arg0))
|
|
(<= 0 arg2)))
|
|
|
|
(define-c int64_t s64vector-ref (s64vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (s64vector-set! "s64vector_set") (s64vector int int64_t)
|
|
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
|
|
|
|
(define-c double f8vector-ref (f8vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (f8vector-set! "f8vector_set") (f8vector int double)
|
|
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
|
|
|
|
(define-c double f16vector-ref (f16vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (f16vector-set! "f16vector_set") (f16vector int double)
|
|
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
|
|
|
|
(define-c float f32vector-ref (f32vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (f32vector-set! "f32vector_set") (f32vector int float)
|
|
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
|
|
|
|
(define-c double f64vector-ref (f64vector int)
|
|
(assert (< -1 arg1 (uvector-length arg0))))
|
|
(define-c void (f64vector-set! "f64vector_set") (f64vector int double)
|
|
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
|
|
|
|
(define-c sexp c64vector-ref ((value ctx sexp) c64vector int)
|
|
(assert (< -1 arg2 (uvector-length arg1))))
|
|
(define-c void (c64vector-set! "c64vector_set") ((value ctx sexp) c64vector int sexp)
|
|
(assert (mutable? arg1) (< -1 arg2 (uvector-length arg1))))
|
|
|
|
(define-c sexp c128vector-ref ((value ctx sexp) c128vector int)
|
|
(assert (< -1 arg2 (uvector-length arg1))))
|
|
(define-c void (c128vector-set! "c128vector_set") ((value ctx sexp) c128vector int sexp)
|
|
(assert (mutable? arg1) (< -1 arg2 (uvector-length arg1))))
|