~ chicken-core (chicken-5) f295b2dd1f994b08a40f53c769a3e809b48e5bee
commit f295b2dd1f994b08a40f53c769a3e809b48e5bee
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 24 00:28:13 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 24 00:28:13 2009 +0100
added some more unboxed flonum operations
diff --git a/c-platform.scm b/c-platform.scm
index 19781b8e..915137dc 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -146,7 +146,7 @@
f32vector-ref f64vector-ref f32vector-set! f64vector-set!
u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
locative-ref locative-set! locative->object locative? global-ref
- null-pointer? pointer->object flonum? finite?
+ null-pointer? pointer->object flonum? finite? address->pointer pointer->address
printf sprintf format) )
(define internal-bindings
@@ -180,6 +180,7 @@
u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared
f32vector->blob/shared f64vector->blob/shared
s32vector->blob/shared read-string read-string! o
+ address->pointer pointer->address
##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
##sys#byte ##sys#setbyte
u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
@@ -571,6 +572,7 @@
(rewrite 'finite? 2 1 "C_i_finitep" #f)
(rewrite 'fpinteger? 2 1 "C_u_i_fpintegerp" #f)
(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t)
+(rewrite 'pointer? 2 1 "C_i_safe_pointerp" #t)
(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t)
(rewrite 'exact? 2 1 "C_fixnump" #f)
(rewrite 'exact? 2 1 "C_i_exactp" #t)
@@ -604,15 +606,15 @@
(rewrite 'fx< 2 2 "C_fixnum_lessp" #t)
(rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t)
(rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t)
-(rewrite 'fp= 2 2 "C_flonum_equalp" #t)
-(rewrite 'fp> 2 2 "C_flonum_greaterp" #t)
-(rewrite 'fp< 2 2 "C_flonum_lessp" #t)
-(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #t)
-(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #t)
-(rewrite 'fxmax 2 2 "C_i_fixnum_max" #t)
-(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t)
-(rewrite 'fpmax 2 2 "C_i_flonum_max" #t)
-(rewrite 'fpmin 2 2 "C_i_flonum_min" #t)
+(rewrite 'fp= 2 2 "C_flonum_equalp" #f)
+(rewrite 'fp> 2 2 "C_flonum_greaterp" #f)
+(rewrite 'fp< 2 2 "C_flonum_lessp" #f)
+(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #f)
+(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #f)
+(rewrite 'fxmax 2 2 "C_i_fixnum_max" #f)
+(rewrite 'fxmin 2 2 "C_i_fixnum_min" #f)
+(rewrite 'fpmax 2 2 "C_i_flonum_max" #f)
+(rewrite 'fpmin 2 2 "C_i_flonum_min" #f)
(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t)
(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t)
(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t)
@@ -814,6 +816,8 @@
(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)
(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t)
(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
+(rewrite 'address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
+(rewrite 'pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
(rewrite
'##sys#setslot 8
diff --git a/chicken-install.scm b/chicken-install.scm
index 476e86da..79d55352 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -25,8 +25,7 @@
(require-library setup-download setup-api)
-(require-library srfi-1 posix data-structures utils regex ports extras
- srfi-13 files)
+(require-library srfi-1 posix data-structures utils regex ports extras srfi-13 files)
(require-library chicken-syntax) ; in case an import library reexports chicken syntax
@@ -179,7 +178,8 @@
(define *eggs+dirs+vers* '())
(define *dependencies* '())
(define *checked* '())
- (define *csi* (shellpath (make-pathname *program-path* (foreign-value "C_CSI_PROGRAM" c-string))))
+ (define *csi*
+ (shellpath (make-pathname *program-path* (foreign-value "C_CSI_PROGRAM" c-string))))
(define (try-extension name version trans locn)
(condition-case
diff --git a/chicken.h b/chicken.h
index d8941748..7b3b3129 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1060,6 +1060,9 @@ extern double trunc(double);
#define C_a_i_flonum_quotient(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) / C_flonum_magnitude(n2))
#define C_a_i_flonum_negate(ptr, c, n) C_flonum(ptr, -C_flonum_magnitude(n))
+#define C_a_i_address_to_pointer(ptr, c, addr) C_mpointer(ptr, (void *)C_num_to_unsigned_int(addr))
+#define C_a_i_pointer_to_address(ptr, c, pptr) C_unsigned_int_to_num(ptr, (unsigned int)pptr)
+
#define C_display_fixnum(p, n) (C_fprintf(C_port_file(p), C_text("%d"), C_unfix(n)), C_SCHEME_UNDEFINED)
#define C_display_char(p, c) (C_fputc(C_character_code(c), C_port_file(p)), C_SCHEME_UNDEFINED)
#define C_display_string(p, s) (C_fwrite(((C_SCHEME_BLOCK *)(s))->data, sizeof(C_char), C_header_size(s), \
@@ -1291,6 +1294,12 @@ extern double trunc(double);
#define C_ub_i_flonum_times(x, y) ((x) * (y))
#define C_ub_i_flonum_quotient(x, y) ((x) / (y))
+#define C_ub_i_flonum_equalp(n1, n2) ((n1) == (n2))
+#define C_ub_i_flonum_greaterp(n1, n2) ((n1) > (n2))
+#define C_ub_i_flonum_lessp(n1, n2) ((n1) < (n2))
+#define C_ub_i_flonum_greater_or_equal_p(n1, n2) ((n1) >= (n2))
+#define C_ub_i_flonum_less_or_equal_p(n1, n2) ((n1) <= (n2))
+
#define C_end_of_main
#if !defined(C_EMBEDDED) && !defined(C_SHARED)
@@ -2002,6 +2011,14 @@ C_inline C_word C_u_i_fpintegerp(C_word x)
}
+C_inline int C_ub_i_fpintegerp(double x)
+{
+ double dummy;
+
+ return C_modf(x, &dummy) == 0.0;
+}
+
+
C_inline C_word C_i_integerp(C_word x)
{
double dummy;
@@ -2057,6 +2074,21 @@ C_inline C_word C_i_flonum_max(C_word x, C_word y)
}
+C_inline C_word C_i_safe_pointerp(C_word x)
+{
+ if(C_immediatep(x)) return C_SCHEME_FALSE;
+
+ switch(C_block_header(x)) {
+ case C_POINTER_TAG:
+ case C_SWIG_POINTER_TAG:
+ case C_TAGGED_POINTER_TAG:
+ return C_SCHEME_TRUE;
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
C_END_C_DECLS
#endif /* ___CHICKEN */
diff --git a/unboxing.scm b/unboxing.scm
index e6975c4e..b563cd53 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -400,7 +400,30 @@
(C_u_i_f64vector_set (* fixnum flonum) fixnum "C_ub_i_f64vector_set")
(C_a_i_f32vector_ref (* fixnum) flonum "C_ub_i_f32vector_ref")
(C_a_i_f64vector_ref (* fixnum) flonum "C_ub_i_f64vector_ref")
- ; fpinteger?
- ; finite?
- ; fp= fp> fp< fp>= fp<=
+ (C_u_i_fpintegerp (flonum) bool "C_ub_i_fpintegerp")
+ (C_flonum_equalp (flonum flonum) bool "C_ub_i_flonum_equalp")
+ (C_flonum_greaterp (flonum flonum) bool "C_ub_i_flonum_greaterp")
+ (C_flonum_lessp (flonum flonum) bool "C_ub_i_flonum_lessp")
+ (C_flonum_greater_or_equal_p (flonum flonum) bool "C_ub_i_flonum_greater_or_equal_p")
+ (C_flonum_less_or_equal_p (flonum flonum) bool "C_ub_i_flonum_less_or_equal_p")
+ ; address->pointer
+ ; pointer->address
+ ; pointer+
+ ; pointer=?
+ ; pointer-u8-ref
+ ; pointer-s8-ref
+ ; pointer-u16-ref
+ ; pointer-s16-ref
+ ; pointer-u32-ref
+ ; pointer-s32-ref
+ ; pointer-f32-ref
+ ; pointer-f64-ref
+ ; pointer-u8-set!
+ ; pointer-s8-set!
+ ; pointer-u16-set!
+ ; pointer-s16-set!
+ ; pointer-u32-set!
+ ; pointer-s32-set!
+ ; pointer-f32-set!
+ ; pointer-f64-set!
)
Trap