~ chicken-core (chicken-5) 635578967909374ad36782888059a5f023f5b900
commit 635578967909374ad36782888059a5f023f5b900
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Sep 3 07:13:35 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Sep 3 07:13:35 2010 -0400
internal overflow-detection fixnum ops
diff --git a/chicken.h b/chicken.h
index 12633b14..5830ae3d 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1811,6 +1811,8 @@ C_fctexport C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
C_fctexport C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_plus(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_difference(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_o_fixnum_times(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_o_fixnum_quotient(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_and(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
diff --git a/library.scm b/library.scm
index dc3cde45..bb738448 100644
--- a/library.scm
+++ b/library.scm
@@ -702,12 +702,14 @@ EOF
(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
(define (fxodd? x) (##core#inline "C_i_fixnumoddp" x))
(define (fxeven? x) (##core#inline "C_i_fixnumevenp" x))
+(define (fx/ x y) (##core#inline "C_fixnum_divide" x y) )
+(define (fxmod x y) (##core#inline "C_fixnum_modulo" x y) )
-(define (fx/ x y)
- (##core#inline "C_fixnum_divide" x y) )
-
-(define (fxmod x y)
- (##core#inline "C_fixnum_modulo" x y) )
+;; these are currently undocumented
+(define (fx+? x y) (##core#inline "C_i_o_fixnum_plus" x y) )
+(define (fx-? x y) (##core#inline "C_i_o_fixnum_difference" x y) )
+(define (fx*? x y) (##core#inline "C_i_o_fixnum_times" x y) )
+(define (fx/? x y) (##core#inline "C_i_o_fixnum_quotient" x y) )
(define maximum-flonum (foreign-value "DBL_MAX" double))
(define minimum-flonum (foreign-value "DBL_MIN" double))
@@ -969,25 +971,22 @@ EOF
(define max)
(define min)
-(let ([> >] ;XXX could use faster versions
- [< <] )
- (letrec ([maxmin
- (lambda (n1 ns pred)
- (let loop ((nbest n1) (ns ns))
- (if (eq? ns '())
- nbest
- (let ([ni (##sys#slot ns 0)])
- (loop (if (pred ni nbest)
- (if (and (##core#inline "C_blockp" nbest)
- (##core#inline "C_flonump" nbest)
- (not (##core#inline "C_blockp" ni)) )
- (##core#inline_allocate ("C_a_i_fix_to_flo" 4) ni)
- ni)
- nbest)
- (##sys#slot ns 1) ) ) ) ) ) ] )
-
- (set! max (lambda (n1 . ns) (maxmin n1 ns >)))
- (set! min (lambda (n1 . ns) (maxmin n1 ns <))) ) )
+(letrec ((maxmin
+ (lambda (n1 ns pred)
+ (let loop ((nbest n1) (ns ns))
+ (if (eq? ns '())
+ nbest
+ (let ([ni (##sys#slot ns 0)])
+ (loop (if (pred ni nbest)
+ (if (and (##core#inline "C_blockp" nbest)
+ (##core#inline "C_flonump" nbest)
+ (not (##core#inline "C_blockp" ni)) )
+ (##core#inline_allocate ("C_a_i_fix_to_flo" 4) ni)
+ ni)
+ nbest)
+ (##sys#slot ns 1) ) ) ) ) ) ) )
+ (set! max (lambda (n1 . ns) (maxmin n1 ns >)))
+ (set! min (lambda (n1 . ns) (maxmin n1 ns <))) )
(define (exp n)
(##core#inline_allocate ("C_a_i_exp" 4) n) )
diff --git a/runtime.c b/runtime.c
index ca4de104..eee31556 100644
--- a/runtime.c
+++ b/runtime.c
@@ -8613,6 +8613,68 @@ C_regparm C_word C_fcall C_i_o_fixnum_difference(C_word n1, C_word n2)
}
+C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, C_word n2)
+{
+ C_word x1, x2;
+ /* otherwise gcc tries to be smart (and naturally fails) */
+#ifdef C_SIXTY_FOUR
+ static int seven_f = 0x7fffffffffffffff;
+ static int eight_0 = 0x8000000000000000;
+#else
+ static int seven_f = 0x7fffffff;
+ static int eight_0 = 0x80000000;
+#endif
+
+ if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
+
+ x1 = C_unfix(n1);
+ x2 = C_unfix(n2);
+
+ if(x1 > 0) {
+ if(x2 > 0) {
+ if(x1 > (seven_f / x2)) return C_SCHEME_FALSE;
+ else goto ok;
+ }
+ else {
+ if(x2 < (eight_0 / x2)) return C_SCHEME_FALSE;
+ else goto ok;
+ }
+ }
+ else if(x2 > 0) {
+ if(x1 < (eight_0 / x2)) return C_SCHEME_FALSE;
+ else goto ok;
+ }
+ else {
+ if(x1 != 0 && x2 < (seven_f / x1)) return C_SCHEME_FALSE;
+ }
+
+ ok:
+ return C_fix(x1 * x2);
+}
+
+
+C_regparm C_word C_fcall C_i_o_fixnum_quotient(C_word n1, C_word n2)
+{
+ C_word x1, x2;
+
+ if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
+
+ x1 = C_unfix(n1);
+ x2 = C_unfix(n2);
+
+ if(x2 == 0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "fx/?");
+
+#ifdef C_SIXYT_FOUR
+ if(x1 == 0x8000000000000000L && x2 == -1) return C_SCHEME_FALSE;
+#else
+ if(x1 == 0x80000000L && x2 == -1) return C_SCHEME_FALSE;
+#endif
+
+ return C_fix(x1 / x2);
+}
+
+
C_regparm C_word C_fcall C_i_o_fixnum_and(C_word n1, C_word n2)
{
C_uword x1, x2, r;
Trap