On Mon, Apr 08, 2019 at 10:04:20PM +0200, Peter Bex wrote: > Hi all, > > Here's a reasonably straightforward patch to make XXXvector-ref, > XXXvector-set!, XXXvector-length and XXXvector? inlineable, as > per #757.
I forgot to add the rewriteable identifiers to +extended-bindings+ so they weren't actually applied. Here's a new version. Cheers, Peter
From 032d06eba859c627af10d3726fbb6efce1925072 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Mon, 8 Apr 2019 21:47:03 +0200
Subject: [PATCH] Add inlined srfi-4 accessors, predicates and length proedures
These can now be used in tight loops without paying the cost of a CPS
call.
---
NEWS | 2 +
c-platform.scm | 85 ++++++--
chicken.h | 55 +++++
library.scm | 6 +-
runtime.c | 620 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
srfi-4.scm | 181 ++++-------------
6 files changed, 790 insertions(+), 159 deletions(-)
diff --git a/NEWS b/NEWS
index 5e8a133a..c8f21f8b 100644
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,8 @@
longer accept multiple values via direct invocation after being
captured through `call/cc`, only via `values` (revert of #1390,
due to #1601)
+ - SRFI-4 vector predicates, reference, set and length procedures
+ should now be faster in tight loops as they're inlineable (#757).
- Module system
- When you try to import the module you are currently defining into
diff --git a/c-platform.scm b/c-platform.scm
index 35a327cc..37429841 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -180,11 +180,30 @@
chicken.keyword#get-keyword
+ srfi-4#u8vector? srfi-4#s8vector?
+ srfi-4#u16vector? srfi-4#s16vector?
+ srfi-4#u32vector? srfi-4#u64vector?
+ srfi-4#s32vector? srfi-4#s64vector?
+ srfi-4#f32vector? srfi-4#f64vector?
+
srfi-4#u8vector-length srfi-4#s8vector-length
srfi-4#u16vector-length srfi-4#s16vector-length
srfi-4#u32vector-length srfi-4#u64vector-length
srfi-4#s32vector-length srfi-4#s64vector-length
srfi-4#f32vector-length srfi-4#f64vector-length
+
+ srfi-4#u8vector-ref srfi-4#s8vector-ref
+ srfi-4#u16vector-ref srfi-4#s16vector-ref
+ srfi-4#u32vector-ref srfi-4#u64vector-ref
+ srfi-4#s32vector-ref srfi-4#s64vector-ref
+ srfi-4#f32vector-ref srfi-4#f64vector-ref
+
+ srfi-4#u8vector-set! srfi-4#s8vector-set!
+ srfi-4#u16vector-set! srfi-4#s16vector-set!
+ srfi-4#u32vector-set! srfi-4#u64vector-set!
+ srfi-4#s32vector-set! srfi-4#s64vector-set!
+ srfi-4#f32vector-set! srfi-4#f64vector-set!
+
srfi-4#u8vector->blob/shared srfi-4#s8vector->blob/shared
srfi-4#u16vector->blob/shared srfi-4#s16vector->blob/shared
srfi-4#u32vector->blob/shared srfi-4#s32vector->blob/shared
@@ -501,6 +520,17 @@
(rewrite 'scheme#symbol? 2 1 "C_i_symbolp" #t)
(rewrite 'scheme#vector? 2 1 "C_i_vectorp" #t)
(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t)
+(rewrite '##sys#srfi-4-vector? 2 1 "C_i_srfi_4_vectorp" #t)
+(rewrite 'srfi-4#u8vector? 2 1 "C_i_u8vectorp" #t)
+(rewrite 'srfi-4#s8vector? 2 1 "C_i_s8vectorp" #t)
+(rewrite 'srfi-4#u16vector? 2 1 "C_i_u16vectorp" #t)
+(rewrite 'srfi-4#s16vector? 2 1 "C_i_s16vectorp" #t)
+(rewrite 'srfi-4#u32vector? 2 1 "C_i_u32vectorp" #t)
+(rewrite 'srfi-4#s32vector? 2 1 "C_i_s32vectorp" #t)
+(rewrite 'srfi-4#u64vector? 2 1 "C_i_u64vectorp" #t)
+(rewrite 'srfi-4#s64vector? 2 1 "C_i_s64vectorp" #t)
+(rewrite 'srfi-4#f32vector? 2 1 "C_i_f32vectorp" #t)
+(rewrite 'srfi-4#f64vector? 2 1 "C_i_f64vectorp" #t)
(rewrite 'scheme#pair? 2 1 "C_i_pairp" #t)
(rewrite '##sys#pair? 2 1 "C_i_pairp" #t)
(rewrite 'scheme#procedure? 2 1 "C_i_closurep" #t)
@@ -887,34 +917,63 @@
;; TODO: Move this stuff to types.db
(rewrite 'srfi-4#u8vector-ref 2 2 "C_u_i_u8vector_ref" #f)
+(rewrite 'srfi-4#u8vector-ref 2 2 "C_i_u8vector_ref" #t)
(rewrite 'srfi-4#s8vector-ref 2 2 "C_u_i_s8vector_ref" #f)
+(rewrite 'srfi-4#s8vector-ref 2 2 "C_i_s8vector_ref" #t)
(rewrite 'srfi-4#u16vector-ref 2 2 "C_u_i_u16vector_ref" #f)
+(rewrite 'srfi-4#u16vector-ref 2 2 "C_i_u16vector_ref" #t)
(rewrite 'srfi-4#s16vector-ref 2 2 "C_u_i_s16vector_ref" #f)
+(rewrite 'srfi-4#s16vector-ref 2 2 "C_i_s16vector_ref" #t)
+
+(rewrite 'srfi-4#u32vector-ref 16 2 "C_a_i_u32vector_ref" #t words-per-flonum)
+(rewrite 'srfi-4#s32vector-ref 16 2 "C_a_i_s32vector_ref" #t words-per-flonum)
(rewrite 'srfi-4#f32vector-ref 16 2 "C_a_u_i_f32vector_ref" #f words-per-flonum)
+(rewrite 'srfi-4#f32vector-ref 16 2 "C_a_i_f32vector_ref" #t words-per-flonum)
(rewrite 'srfi-4#f64vector-ref 16 2 "C_a_u_i_f64vector_ref" #f words-per-flonum)
+(rewrite 'srfi-4#f64vector-ref 16 2 "C_a_i_f64vector_ref" #t words-per-flonum)
(rewrite 'srfi-4#u8vector-set! 2 3 "C_u_i_u8vector_set" #f)
+(rewrite 'srfi-4#u8vector-set! 2 3 "C_i_u8vector_set" #t)
(rewrite 'srfi-4#s8vector-set! 2 3 "C_u_i_s8vector_set" #f)
+(rewrite 'srfi-4#s8vector-set! 2 3 "C_i_s8vector_set" #t)
(rewrite 'srfi-4#u16vector-set! 2 3 "C_u_i_u16vector_set" #f)
+(rewrite 'srfi-4#u16vector-set! 2 3 "C_i_u16vector_set" #t)
(rewrite 'srfi-4#s16vector-set! 2 3 "C_u_i_s16vector_set" #f)
+(rewrite 'srfi-4#s16vector-set! 2 3 "C_i_s16vector_set" #t)
(rewrite 'srfi-4#u32vector-set! 2 3 "C_u_i_u32vector_set" #f)
+(rewrite 'srfi-4#u32vector-set! 2 3 "C_i_u32vector_set" #t)
(rewrite 'srfi-4#s32vector-set! 2 3 "C_u_i_s32vector_set" #f)
-(rewrite 'srfi-4#u64vector-set! 2 3 "C_u_i_u32vector_set" #f)
-(rewrite 'srfi-4#s64vector-set! 2 3 "C_u_i_s32vector_set" #f)
+(rewrite 'srfi-4#s32vector-set! 2 3 "C_i_s32vector_set" #t)
+(rewrite 'srfi-4#u64vector-set! 2 3 "C_u_i_u64vector_set" #f)
+(rewrite 'srfi-4#u64vector-set! 2 3 "C_i_u64vector_set" #t)
+(rewrite 'srfi-4#s64vector-set! 2 3 "C_u_i_s64vector_set" #f)
+(rewrite 'srfi-4#s64vector-set! 2 3 "C_i_s64vector_set" #t)
(rewrite 'srfi-4#f32vector-set! 2 3 "C_u_i_f32vector_set" #f)
+(rewrite 'srfi-4#f32vector-set! 2 3 "C_i_f32vector_set" #t)
(rewrite 'srfi-4#f64vector-set! 2 3 "C_u_i_f64vector_set" #f)
-
-(rewrite 'srfi-4#u8vector-length 2 1 "C_u_i_8vector_length" #f)
-(rewrite 'srfi-4#s8vector-length 2 1 "C_u_i_8vector_length" #f)
-(rewrite 'srfi-4#u16vector-length 2 1 "C_u_i_16vector_length" #f)
-(rewrite 'srfi-4#s16vector-length 2 1 "C_u_i_16vector_length" #f)
-(rewrite 'srfi-4#u32vector-length 2 1 "C_u_i_32vector_length" #f)
-(rewrite 'srfi-4#s32vector-length 2 1 "C_u_i_32vector_length" #f)
-(rewrite 'srfi-4#u64vector-length 2 1 "C_u_i_64vector_length" #f)
-(rewrite 'srfi-4#s64vector-length 2 1 "C_u_i_64vector_length" #f)
-(rewrite 'srfi-4#f32vector-length 2 1 "C_u_i_32vector_length" #f)
-(rewrite 'srfi-4#f64vector-length 2 1 "C_u_i_64vector_length" #f)
+(rewrite 'srfi-4#f64vector-set! 2 3 "C_i_f64vector_set" #t)
+
+(rewrite 'srfi-4#u8vector-length 2 1 "C_u_i_u8vector_length" #f)
+(rewrite 'srfi-4#u8vector-length 2 1 "C_i_u8vector_length" #t)
+(rewrite 'srfi-4#s8vector-length 2 1 "C_u_i_s8vector_length" #f)
+(rewrite 'srfi-4#s8vector-length 2 1 "C_i_s8vector_length" #t)
+(rewrite 'srfi-4#u16vector-length 2 1 "C_u_i_u16vector_length" #f)
+(rewrite 'srfi-4#u16vector-length 2 1 "C_i_u16vector_length" #t)
+(rewrite 'srfi-4#s16vector-length 2 1 "C_u_i_s16vector_length" #f)
+(rewrite 'srfi-4#s16vector-length 2 1 "C_i_s16vector_length" #t)
+(rewrite 'srfi-4#u32vector-length 2 1 "C_u_i_u32vector_length" #f)
+(rewrite 'srfi-4#u32vector-length 2 1 "C_i_u32vector_length" #t)
+(rewrite 'srfi-4#s32vector-length 2 1 "C_u_i_s32vector_length" #f)
+(rewrite 'srfi-4#s32vector-length 2 1 "C_i_s32vector_length" #t)
+(rewrite 'srfi-4#u64vector-length 2 1 "C_u_i_u64vector_length" #f)
+(rewrite 'srfi-4#u64vector-length 2 1 "C_i_u64vector_length" #t)
+(rewrite 'srfi-4#s64vector-length 2 1 "C_u_i_s64vector_length" #f)
+(rewrite 'srfi-4#s64vector-length 2 1 "C_i_s64vector_length" #t)
+(rewrite 'srfi-4#f32vector-length 2 1 "C_u_i_f32vector_length" #f)
+(rewrite 'srfi-4#f32vector-length 2 1 "C_i_f32vector_length" #t)
+(rewrite 'srfi-4#f64vector-length 2 1 "C_u_i_f64vector_length" #f)
+(rewrite 'srfi-4#f64vector-length 2 1 "C_i_f64vector_length" #t)
(rewrite 'chicken.base#atom? 17 1 "C_i_not_pair_p")
diff --git a/chicken.h b/chicken.h
index 1a990b69..68b636df 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1910,11 +1910,31 @@ C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
C_fctexport C_word C_a_i_port(C_word **a, int c);
C_fctexport C_word C_fcall C_a_i_bytevector(C_word **a, int c, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_listp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u8vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s8vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u16vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s16vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u32vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s32vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u64vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s64vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_f32vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_f64vectorp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_string_equal_p(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_set_car(C_word p, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_set_cdr(C_word p, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u8vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_exactp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_inexactp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_nanp(C_word x) C_regparm;
@@ -1942,10 +1962,30 @@ C_fctexport C_word C_fcall C_i_integer_evenp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_oddp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_integer_oddp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_u8vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_s8vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_u16vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_s16vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
C_fctexport C_word C_fcall C_i_block_ref(C_word x, C_word i) C_regparm;
C_fctexport C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c) C_regparm;
C_fctexport C_word C_fcall C_i_string_ref(C_word s, C_word i) C_regparm;
C_fctexport C_word C_fcall C_i_vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_u8vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_s8vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_u16vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_s16vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_u32vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_s32vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_u64vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_s64vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_f32vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_f64vector_length(C_word v) C_regparm;
C_fctexport C_word C_fcall C_i_string_length(C_word s) C_regparm;
C_fctexport C_word C_fcall C_i_assq(C_word x, C_word lst) C_regparm;
C_fctexport C_word C_fcall C_i_assv(C_word x, C_word lst) C_regparm;
@@ -2646,6 +2686,21 @@ inline static C_word C_i_vectorp(C_word x)
return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
}
+inline static C_word C_i_srfi_4_vectorp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) &&
+ C_header_bits(x) == C_STRUCTURE_TYPE &&
+ (C_truep(C_i_u8vectorp(x)) ||
+ C_truep(C_i_s8vectorp(x)) ||
+ C_truep(C_i_u16vectorp(x)) ||
+ C_truep(C_i_s16vectorp(x)) ||
+ C_truep(C_i_u32vectorp(x)) ||
+ C_truep(C_i_s32vectorp(x)) ||
+ C_truep(C_i_u64vectorp(x)) ||
+ C_truep(C_i_s64vectorp(x)) ||
+ C_truep(C_i_f32vectorp(x)) ||
+ C_truep(C_i_f64vectorp(x))));
+}
inline static C_word C_i_portp(C_word x)
{
diff --git a/library.scm b/library.scm
index cba0f723..e7ada7f4 100644
--- a/library.scm
+++ b/library.scm
@@ -5453,11 +5453,7 @@ EOF
(define (##sys#permanent? x) (##core#inline "C_permanentp" x))
(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 6) x))
(define (##sys#locative? x) (##core#inline "C_locativep" x))
-(define (##sys#srfi-4-vector? x)
- (and (##core#inline "C_blockp" x)
- (##sys#generic-structure? x)
- (memq (##sys#slot x 0)
- '(u8vector u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector))))
+(define (##sys#srfi-4-vector? x) (##core#inline "C_i_srfi_4_vectorp" x))
(define (##sys#null-pointer)
(let ([ptr (##sys#make-pointer)])
diff --git a/runtime.c b/runtime.c
index c06b5432..55d6db2a 100644
--- a/runtime.c
+++ b/runtime.c
@@ -417,6 +417,16 @@ static C_TLS C_word
pending_finalizers_symbol,
callback_continuation_stack_symbol,
core_provided_symbol,
+ u8vector_symbol,
+ s8vector_symbol,
+ u16vector_symbol,
+ s16vector_symbol,
+ u32vector_symbol,
+ s32vector_symbol,
+ u64vector_symbol,
+ s64vector_symbol,
+ f32vector_symbol,
+ f64vector_symbol,
*forwarding_table;
static C_TLS int
trace_buffer_full,
@@ -1095,6 +1105,18 @@ void initialize_symbol_table(void)
callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("##sys#callback-continuation-stack"), C_SCHEME_END_OF_LIST);
pending_finalizers_symbol = C_intern2(C_heaptop, C_text("##sys#pending-finalizers"));
current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);
+
+ /* SRFI-4 tags */
+ u8vector_symbol = C_intern2(C_heaptop, C_text("u8vector"));
+ s8vector_symbol = C_intern2(C_heaptop, C_text("s8vector"));
+ u16vector_symbol = C_intern2(C_heaptop, C_text("u16vector"));
+ s16vector_symbol = C_intern2(C_heaptop, C_text("s16vector"));
+ u32vector_symbol = C_intern2(C_heaptop, C_text("u32vector"));
+ s32vector_symbol = C_intern2(C_heaptop, C_text("s32vector"));
+ u64vector_symbol = C_intern2(C_heaptop, C_text("u64vector"));
+ s64vector_symbol = C_intern2(C_heaptop, C_text("s64vector"));
+ f32vector_symbol = C_intern2(C_heaptop, C_text("f32vector"));
+ f64vector_symbol = C_intern2(C_heaptop, C_text("f64vector"));
}
@@ -3603,6 +3625,17 @@ C_regparm void C_fcall mark_system_globals(void)
mark(&callback_continuation_stack_symbol);
mark(&pending_finalizers_symbol);
mark(¤t_thread_symbol);
+
+ mark(&u8vector_symbol);
+ mark(&s8vector_symbol);
+ mark(&u16vector_symbol);
+ mark(&s16vector_symbol);
+ mark(&u32vector_symbol);
+ mark(&s32vector_symbol);
+ mark(&u64vector_symbol);
+ mark(&s64vector_symbol);
+ mark(&f32vector_symbol);
+ mark(&f64vector_symbol);
}
@@ -3942,6 +3975,17 @@ C_regparm void C_fcall remark_system_globals(void)
remark(&callback_continuation_stack_symbol);
remark(&pending_finalizers_symbol);
remark(¤t_thread_symbol);
+
+ remark(&u8vector_symbol);
+ remark(&s8vector_symbol);
+ remark(&u16vector_symbol);
+ remark(&s16vector_symbol);
+ remark(&u32vector_symbol);
+ remark(&s32vector_symbol);
+ remark(&u64vector_symbol);
+ remark(&s64vector_symbol);
+ remark(&f32vector_symbol);
+ remark(&f64vector_symbol);
}
@@ -5058,6 +5102,56 @@ C_regparm C_word C_fcall C_i_listp(C_word x)
return C_SCHEME_TRUE;
}
+C_regparm C_word C_fcall C_i_u8vectorp(C_word x)
+{
+ return C_i_structurep(x, u8vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_s8vectorp(C_word x)
+{
+ return C_i_structurep(x, s8vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_u16vectorp(C_word x)
+{
+ return C_i_structurep(x, u16vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_s16vectorp(C_word x)
+{
+ return C_i_structurep(x, s16vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_u32vectorp(C_word x)
+{
+ return C_i_structurep(x, u32vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_s32vectorp(C_word x)
+{
+ return C_i_structurep(x, s32vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_u64vectorp(C_word x)
+{
+ return C_i_structurep(x, u64vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_s64vectorp(C_word x)
+{
+ return C_i_structurep(x, s64vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_f32vectorp(C_word x)
+{
+ return C_i_structurep(x, f32vector_symbol);
+}
+
+C_regparm C_word C_fcall C_i_f64vectorp(C_word x)
+{
+ return C_i_structurep(x, f64vector_symbol);
+}
+
C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
{
@@ -5641,6 +5735,200 @@ C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
}
+C_regparm C_word C_fcall C_i_u8vector_ref(C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_u8vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-ref", v, i);
+
+ return C_fix(((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_s8vector_ref(C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_s8vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-ref", v, i);
+
+ return C_fix(((signed char *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_u16vector_ref(C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_u16vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);
+
+ return C_fix(((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_s16vector_ref(C_word v, C_word i)
+{
+ C_word size;
+ int j;
+
+ if(C_immediatep(v) || C_header_bits(v) != C_STRUCTURE_TYPE ||
+ C_header_size(v) != 2 || C_block_item(v, 0) != s16vector_symbol)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);
+
+ return C_fix(((signed short *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_u32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-ref", v, i);
+
+ return C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_s32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-ref", v, i);
+
+ return C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_u64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-ref", v, i);
+
+ return C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_s64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-ref", v, i);
+
+ return C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+{
+ int j;
+
+ if(!C_truep(C_i_f32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-ref", v, i);
+
+ return C_flonum(ptr, ((float *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+{
+ C_word size;
+ int j;
+
+ if(!C_truep(C_i_f64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-ref", v, i);
+
+ return C_flonum(ptr, ((double *)C_data_pointer(C_block_item(v, 1)))[j]);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+
C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
{
int j;
@@ -5712,6 +6000,87 @@ C_regparm C_word C_fcall C_i_vector_length(C_word v)
return C_fix(C_header_size(v));
}
+C_regparm C_word C_fcall C_i_u8vector_length(C_word v)
+{
+ if(!C_truep(C_i_u8vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)));
+}
+
+C_regparm C_word C_fcall C_i_s8vector_length(C_word v)
+{
+ if(!C_truep(C_i_s8vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)));
+}
+
+C_regparm C_word C_fcall C_i_u16vector_length(C_word v)
+{
+ if(!C_truep(C_i_u16vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 1);
+}
+
+C_regparm C_word C_fcall C_i_s16vector_length(C_word v)
+{
+ if(!C_truep(C_i_s16vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 1);
+}
+
+C_regparm C_word C_fcall C_i_u32vector_length(C_word v)
+{
+ if(!C_truep(C_i_u32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
+}
+
+C_regparm C_word C_fcall C_i_s32vector_length(C_word v)
+{
+ if(!C_truep(C_i_s32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
+}
+
+C_regparm C_word C_fcall C_i_u64vector_length(C_word v)
+{
+ if(!C_truep(C_i_u64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 3);
+}
+
+C_regparm C_word C_fcall C_i_s64vector_length(C_word v)
+{
+ if(!C_truep(C_i_s64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 3);
+}
+
+
+C_regparm C_word C_fcall C_i_f32vector_length(C_word v)
+{
+ if(!C_truep(C_i_f32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
+}
+
+C_regparm C_word C_fcall C_i_f64vector_length(C_word v)
+{
+ if(!C_truep(C_i_f64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-length", v);
+
+ return C_fix(C_header_size(C_block_item(v, 1)) >> 3);
+}
+
C_regparm C_word C_fcall C_i_string_length(C_word s)
{
@@ -5806,6 +6175,257 @@ C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
+
+C_regparm C_word C_fcall C_i_u8vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_word n;
+
+ if(!C_truep(C_i_u8vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", v, i);
+
+ if(x & C_FIXNUM_BIT) {
+ if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 8) n = C_unfix(x);
+ else barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", i);
+
+ ((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_word n;
+
+ if(!C_truep(C_i_s8vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-set!", v, i);
+
+ if(x & C_FIXNUM_BIT) {
+ if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", i);
+
+ ((signed char *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_word n;
+
+ if(!C_truep(C_i_u16vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);
+
+ if(x & C_FIXNUM_BIT) {
+ if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 16) n = C_unfix(x);
+ else barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", i);
+
+ ((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_word n;
+
+ if(!C_truep(C_i_s16vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);
+
+ if(x & C_FIXNUM_BIT) {
+ if (C_unfix(C_i_fixnum_length(x)) <= 16) n = C_unfix(x);
+ else barf(C_OUT_OF_RANGE_ERROR, "s16vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", i);
+
+ ((short *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_u32 n;
+
+ if(!C_truep(C_i_u32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", v, i);
+
+ if(C_truep(C_i_exact_integerp(x))) {
+ if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_unsigned_int(x);
+ else barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", i);
+
+ ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_s32 n;
+
+ if(!C_truep(C_i_s32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", v, i);
+
+ if(C_truep(C_i_exact_integerp(x))) {
+ if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_int(x);
+ else barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", i);
+
+ ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_u64 n;
+
+ if(!C_truep(C_i_u64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", v, i);
+
+ if(C_truep(C_i_exact_integerp(x))) {
+ if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_uint64(x);
+ else barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", i);
+
+ ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ C_s64 n;
+
+ if(!C_truep(C_i_s64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", v, i);
+
+ if(C_truep(C_i_exact_integerp(x))) {
+ if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_int64(x);
+ else barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", i);
+
+ ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ double f;
+
+ if(!C_truep(C_i_f32vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-set!", v, i);
+
+ if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);
+ else if(x & C_FIXNUM_BIT) f = C_unfix(x);
+ else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", i);
+
+ ((float *)C_data_pointer(C_block_item(v, 1)))[j] = (float)f;
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+ double f;
+
+ if(!C_truep(C_i_f64vectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-set!", v, i);
+
+ if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);
+ else if(x & C_FIXNUM_BIT) f = C_unfix(x);
+ else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", x);
+
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", i);
+
+ ((double *)C_data_pointer(C_block_item(v, 1)))[j] = f;
+ return C_SCHEME_UNDEFINED;
+}
+
+
/* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */
C_regparm C_word C_fcall
C_s_a_i_abs(C_word **ptr, C_word n, C_word x)
diff --git a/srfi-4.scm b/srfi-4.scm
index 8480dd72..884f41be 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -121,226 +121,125 @@ EOF
;;; Get vector length:
(define (u8vector-length x)
- (##sys#check-structure x 'u8vector 'u8vector-length)
- (##core#inline "C_u_i_8vector_length" x))
+ (##core#inline "C_i_u8vector_length" x))
(define (s8vector-length x)
- (##sys#check-structure x 's8vector 's8vector-length)
- (##core#inline "C_u_i_8vector_length" x))
+ (##core#inline "C_i_s8vector_length" x))
(define (u16vector-length x)
- (##sys#check-structure x 'u16vector 'u16vector-length)
- (##core#inline "C_u_i_16vector_length" x))
+ (##core#inline "C_i_u16vector_length" x))
(define (s16vector-length x)
- (##sys#check-structure x 's16vector 's16vector-length)
- (##core#inline "C_u_i_16vector_length" x))
+ (##core#inline "C_i_s16vector_length" x))
(define (u32vector-length x)
- (##sys#check-structure x 'u32vector 'u32vector-length)
- (##core#inline "C_u_i_32vector_length" x))
+ (##core#inline "C_i_u32vector_length" x))
(define (s32vector-length x)
- (##sys#check-structure x 's32vector 's32vector-length)
- (##core#inline "C_u_i_32vector_length" x))
+ (##core#inline "C_i_s32vector_length" x))
(define (u64vector-length x)
- (##sys#check-structure x 'u64vector 'u64vector-length)
- (##core#inline "C_u_i_64vector_length" x))
+ (##core#inline "C_i_u64vector_length" x))
(define (s64vector-length x)
- (##sys#check-structure x 's64vector 's64vector-length)
- (##core#inline "C_u_i_64vector_length" x))
+ (##core#inline "C_i_s64vector_length" x))
(define (f32vector-length x)
- (##sys#check-structure x 'f32vector 'f32vector-length)
- (##core#inline "C_u_i_32vector_length" x))
+ (##core#inline "C_i_f32vector_length" x))
(define (f64vector-length x)
- (##sys#check-structure x 'f64vector 'f64vector-length)
- (##core#inline "C_u_i_64vector_length" x))
+ (##core#inline "C_i_f64vector_length" x))
-;; XXX TODO: u64/s64-vectors
;;; Safe accessors:
(define (u8vector-set! x i y)
- (##sys#check-structure x 'u8vector 'u8vector-set!)
- (let ((len (##core#inline "C_u_i_8vector_length" x)))
- (check-uint-length y 8 'u8vector-set!)
- (check-range i 0 len 'u8vector-set!)
- (##core#inline "C_u_i_u8vector_set" x i y)))
+ (##core#inline "C_i_u8vector_set" x i y))
(define (s8vector-set! x i y)
- (##sys#check-structure x 's8vector 's8vector-set!)
- (let ((len (##core#inline "C_u_i_8vector_length" x)))
- (check-int-length y 8 's8vector-set!)
- (check-range i 0 len 's8vector-set!)
- (##core#inline "C_u_i_s8vector_set" x i y)))
+ (##core#inline "C_i_s8vector_set" x i y))
(define (u16vector-set! x i y)
- (##sys#check-structure x 'u16vector 'u16vector-set!)
- (let ((len (##core#inline "C_u_i_16vector_length" x)))
- (check-uint-length y 16 'u16vector-set!)
- (check-range i 0 len 'u16vector-set!)
- (##core#inline "C_u_i_u16vector_set" x i y)))
+ (##core#inline "C_i_u16vector_set" x i y))
(define (s16vector-set! x i y)
- (##sys#check-structure x 's16vector 's16vector-set!)
- (let ((len (##core#inline "C_u_i_16vector_length" x)))
- (check-int-length y 16 's16vector-set!)
- (check-range i 0 len 's16vector-set!)
- (##core#inline "C_u_i_s16vector_set" x i y)))
+ (##core#inline "C_i_s16vector_set" x i y))
(define (u32vector-set! x i y)
- (##sys#check-structure x 'u32vector 'u32vector-set!)
- (let ((len (##core#inline "C_u_i_32vector_length" x)))
- (check-uint-length y 32 'u32vector-set!)
- (check-range i 0 len 'u32vector-set!)
- (##core#inline "C_u_i_u32vector_set" x i y)))
+ (##core#inline "C_i_u32vector_set" x i y))
(define (s32vector-set! x i y)
- (##sys#check-structure x 's32vector 's32vector-set!)
- (let ((len (##core#inline "C_u_i_32vector_length" x)))
- (check-int-length y 32 's32vector-set!)
- (check-range i 0 len 's32vector-set!)
- (##core#inline "C_u_i_s32vector_set" x i y)))
+ (##core#inline "C_i_s32vector_set" x i y))
(define (u64vector-set! x i y)
- (##sys#check-structure x 'u64vector 'u64vector-set!)
- (let ((len (##core#inline "C_u_i_64vector_length" x)))
- (check-uint-length y 64 'u64vector-set!)
- (check-range i 0 len 'u64vector-set!)
- (##core#inline "C_u_i_u64vector_set" x i y)))
+ (##core#inline "C_i_u64vector_set" x i y))
(define (s64vector-set! x i y)
- (##sys#check-structure x 's64vector 's64vector-set!)
- (let ((len (##core#inline "C_u_i_64vector_length" x)))
- (check-int-length y 64 's64vector-set!)
- (check-range i 0 len 's64vector-set!)
- (##core#inline "C_u_i_s64vector_set" x i y)))
+ (##core#inline "C_i_s64vector_set" x i y))
(define (f32vector-set! x i y)
- (##sys#check-structure x 'f32vector 'f32vector-set!)
- (let ((len (##core#inline "C_u_i_32vector_length" x)))
- (check-int/flonum y 'f32vector-set!)
- (check-range i 0 len 'f32vector-set!)
- (##core#inline
- "C_u_i_f32vector_set"
- x i
- (if (##core#inline "C_i_flonump" y)
- y
- (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) y)))))
+ (##core#inline "C_i_f32vector_set" x i y))
(define (f64vector-set! x i y)
- (##sys#check-structure x 'f64vector 'f64vector-set!)
- (let ((len (##core#inline "C_u_i_64vector_length" x)))
- (check-int/flonum y 'f64vector-set!)
- (check-range i 0 len 'f64vector-set!)
- (##core#inline
- "C_u_i_f64vector_set"
- x i
- (if (##core#inline "C_i_flonump" y)
- y
- (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) y)))))
+ (##core#inline "C_i_f64vector_set" x i y))
(define u8vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 'u8vector 'u8vector-ref)
- (let ((len (##core#inline "C_u_i_s8vector_length" x)))
- (check-range i 0 len 'u8vector-ref)
- (##core#inline "C_u_i_u8vector_ref" x i)))
+ (lambda (x i) (##core#inline "C_i_u8vector_ref" x i))
u8vector-set!
"(chicken.srfi-4#u8vector-ref v i)"))
(define s8vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 's8vector 's8vector-ref)
- (let ((len (##core#inline "C_u_i_s8vector_length" x)))
- (check-range i 0 len 's8vector-ref)
- (##core#inline "C_u_i_s8vector_ref" x i)))
+ (lambda (x i) (##core#inline "C_i_s8vector_ref" x i))
s8vector-set!
"(chicken.srfi-4#s8vector-ref v i)"))
(define u16vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 'u16vector 'u16vector-ref)
- (let ((len (##core#inline "C_u_i_s16vector_length" x)))
- (check-range i 0 len 'u16vector-ref)
- (##core#inline "C_u_i_u16vector_ref" x i)))
+ (lambda (x i) (##core#inline "C_i_u16vector_ref" x i))
u16vector-set!
"(chicken.srfi-4#u16vector-ref v i)"))
(define s16vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 's16vector 's16vector-ref)
- (let ((len (##core#inline "C_u_i_s16vector_length" x)))
- (check-range i 0 len 's16vector-ref)
- (##core#inline "C_u_i_s16vector_ref" x i)))
+ (lambda (x i) (##core#inline "C_i_s16vector_ref" x i))
s16vector-set!
"(chicken.srfi-4#s16vector-ref v i)"))
(define u32vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 'u32vector 'u32vector-ref)
- (let ((len (##core#inline "C_u_i_u32vector_length" x)))
- (check-range i 0 len 'u32vector-ref)
- (##core#inline_allocate ("C_a_u_i_u32vector_ref" 6) x i)))
+ (lambda (x i) (##core#inline_allocate ("C_a_i_u32vector_ref" 4) x i))
u32vector-set!
"(chicken.srfi-4#u32vector-ref v i)"))
(define s32vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 's32vector 's32vector-ref)
- (let ((len (##core#inline "C_u_i_s32vector_length" x)))
- (check-range i 0 len 's32vector-ref)
- (##core#inline_allocate ("C_a_u_i_s32vector_ref" 6) x i)))
+ (lambda (x i) (##core#inline_allocate ("C_a_i_s32vector_ref" 4) x i))
s32vector-set!
"(chicken.srfi-4#s32vector-ref v i)"))
(define u64vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 'u64vector 'u64vector-ref)
- (let ((len (##core#inline "C_u_i_u64vector_length" x)))
- (check-range i 0 len 'u64vector-ref)
- (##core#inline_allocate ("C_a_u_i_u64vector_ref" 7) x i)))
+ (lambda (x i) (##core#inline_allocate ("C_a_i_u64vector_ref" 7) x i))
u64vector-set!
"(chicken.srfi-4#u64vector-ref v i)"))
(define s64vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 's64vector 's64vector-ref)
- (let ((len (##core#inline "C_u_i_s64vector_length" x)))
- (check-range i 0 len 's64vector-ref)
- (##core#inline_allocate ("C_a_u_i_s64vector_ref" 7) x i)))
+ (lambda (x i) (##core#inline_allocate ("C_a_i_s64vector_ref" 7) x i))
s64vector-set!
"(chicken.srfi-4#s64vector-ref v i)"))
(define f32vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 'f32vector 'f32vector-ref)
- (let ((len (##core#inline "C_u_i_f32vector_length" x)))
- (check-range i 0 len 'f32vector-ref)
- (##core#inline_allocate ("C_a_u_i_f32vector_ref" 4) x i)))
+ (lambda (x i) (##core#inline_allocate ("C_a_i_f32vector_ref" 4) x i))
f32vector-set!
"(chicken.srfi-4#f32vector-ref v i)"))
(define f64vector-ref
(getter-with-setter
- (lambda (x i)
- (##sys#check-structure x 'f64vector 'f64vector-ref)
- (let ((len (##core#inline "C_u_i_f64vector_length" x)))
- (check-range i 0 len 'f64vector-ref)
- (##core#inline_allocate ("C_a_u_i_f64vector_ref" 4) x i)))
+ (lambda (x i) (##core#inline_allocate ("C_a_i_f64vector_ref" 4) x i))
f64vector-set!
"(chicken.srfi-4#f64vector-ref v i)"))
@@ -617,16 +516,16 @@ EOF
;;; Predicates:
-(define (u8vector? x) (##sys#structure? x 'u8vector))
-(define (s8vector? x) (##sys#structure? x 's8vector))
-(define (u16vector? x) (##sys#structure? x 'u16vector))
-(define (s16vector? x) (##sys#structure? x 's16vector))
-(define (u32vector? x) (##sys#structure? x 'u32vector))
-(define (s32vector? x) (##sys#structure? x 's32vector))
-(define (u64vector? x) (##sys#structure? x 'u64vector))
-(define (s64vector? x) (##sys#structure? x 's64vector))
-(define (f32vector? x) (##sys#structure? x 'f32vector))
-(define (f64vector? x) (##sys#structure? x 'f64vector))
+(define (u8vector? x) (##core#inline "C_i_u8vectorp" x))
+(define (s8vector? x) (##core#inline "C_i_s8vectorp" x))
+(define (u16vector? x) (##core#inline "C_i_u16vectorp" x))
+(define (s16vector? x) (##core#inline "C_i_s16vectorp" x))
+(define (u32vector? x) (##core#inline "C_i_u32vectorp" x))
+(define (s32vector? x) (##core#inline "C_i_s32vectorp" x))
+(define (u64vector? x) (##core#inline "C_i_u64vectorp" x))
+(define (s64vector? x) (##core#inline "C_i_s64vectorp" x))
+(define (f32vector? x) (##core#inline "C_i_f32vectorp" x))
+(define (f64vector? x) (##core#inline "C_i_f64vectorp" x))
;; Catch-all predicate
(define number-vector? ##sys#srfi-4-vector?)
--
2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
