diff --git a/c-platform.scm b/c-platform.scm index bf034ff1..98d9440f 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -990,15 +990,27 @@ '("C_i_setslot") ) ) callargs) ) ) ) ) ) -(rewrite 'chicken.fixnum#fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus") -(rewrite 'chicken.fixnum#fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference") -(rewrite 'chicken.fixnum#fxshl 17 2 "C_fixnum_shift_left") -(rewrite 'chicken.fixnum#fxshr 17 2 "C_fixnum_shift_right") -(rewrite 'chicken.fixnum#fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate") -(rewrite 'chicken.fixnum#fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor") -(rewrite 'chicken.fixnum#fxand 17 2 "C_fixnum_and" "C_u_fixnum_and") -(rewrite 'chicken.fixnum#fxior 17 2 "C_fixnum_or" "C_u_fixnum_or") -(rewrite 'chicken.fixnum#fx/ 17 2 "C_fixnum_divide" "C_u_fixnum_divide") +(rewrite 'chicken.fixnum#fx= 17 2 "C_i_s_fixnum_equalp" "C_eqp") +(rewrite 'chicken.fixnum#fx+ 17 2 "C_i_s_fixnum_plus" "C_u_fixnum_plus") +(rewrite 'chicken.fixnum#fx- 17 2 "C_i_s_fixnum_difference" "C_u_fixnum_difference") +(rewrite 'chicken.fixnum#fx* 17 2 "C_i_s_fixnum_times" "C_fixnum_times") +(rewrite 'chicken.fixnum#fx/ 17 2 "C_i_s_fixnum_divide" "C_u_fixnum_divide") +(rewrite 'chicken.fixnum#fxand 17 2 "C_i_s_fixnum_and" "C_u_fixnum_and") +(rewrite 'chicken.fixnum#fxior 17 2 "C_i_s_fixnum_or" "C_u_fixnum_or") +(rewrite 'chicken.fixnum#fxxor 17 2 "C_i_s_fixnum_xor" "C_fixnum_xor") +(rewrite 'chicken.fixnum#fxnot 17 1 "C_i_s_fixnum_not" "C_fixnum_not") +(rewrite 'chicken.fixnum#fxshr 17 2 "C_i_s_fixnum_shift_right" "C_fixnum_shift_right") +(rewrite 'chicken.fixnum#fxshl 17 2 "C_i_s_fixnum_shift_left" "C_fixnum_shift_left") +(rewrite 'chicken.fixnum#fxmax 17 2 "C_i_s_fixnum_max" "C_i_fixnum_max") +(rewrite 'chicken.fixnum#fxmin 17 2 "C_i_s_fixnum_min" "C_i_fixnum_min") +(rewrite 'chicken.fixnum#fxmod 17 2 "C_i_s_fixnum_modulo" "C_u_fixnum_modulo") +(rewrite 'chicken.fixnum#fxneg 17 1 "C_i_s_fixnum_negate" "C_u_fixnum_negate") +(rewrite 'chicken.fixnum#fxodd? 17 1 "C_i_s_fixnum_oddp" "C_i_fixnumoddp") +(rewrite 'chicken.fixnum#fxeven? 17 1 "C_i_s_fixnum_evenp" "C_i_fixnumevenp") +(rewrite 'chicken.fixnum#fx< 17 2 "C_i_s_fixnum_lessp" "C_fixnum_lessp") +(rewrite 'chicken.fixnum#fx> 17 2 "C_i_s_fixnum_greaterp" "C_fixnum_greaterp") +(rewrite 'chicken.fixnum#fx<= 17 2 "C_i_s_fixnum_less_or_equal_p" "C_fixnum_less_or_equal_p") +(rewrite 'chicken.fixnum#fx>= 17 2 "C_i_s_fixnum_greater_or_equal_p" "C_fixnum_greater_or_equal_p") (rewrite 'chicken.fixnum#fxmod 17 2 "C_fixnum_modulo" "C_u_fixnum_modulo") (rewrite 'chicken.fixnum#fxrem 17 2 "C_i_fixnum_remainder_checked") diff --git a/chicken.h b/chicken.h index 72d5d397..d19a0378 100644 --- a/chicken.h +++ b/chicken.h @@ -2003,6 +2003,7 @@ C_fctexport C_word C_fcall C_i_length(C_word lst) C_regparm; C_fctexport C_word C_fcall C_u_i_length(C_word lst) C_regparm; C_fctexport C_word C_fcall C_i_check_closure_2(C_word x, C_word loc) C_regparm; C_fctexport C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc) C_regparm; +C_fctexport C_word C_fcall C_i_check_fixnum_2_c(C_word x, char *loc) C_regparm; C_fctexport C_word C_fcall C_i_check_exact_2(C_word x, C_word loc) C_regparm; /* DEPRECATED */ C_fctexport C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc) C_regparm; C_fctexport C_word C_fcall C_i_check_number_2(C_word x, C_word loc) C_regparm; @@ -2913,6 +2914,152 @@ inline static C_word C_fixnum_modulo(C_word x, C_word y) } } +inline static C_word C_i_s_fixnum_equalp(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx=")); + C_i_check_fixnum_2_c(n2, C_text("fx=")); + return C_eqp(n1, n2); +} + +inline static C_word C_i_s_fixnum_plus(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx+")); + C_i_check_fixnum_2_c(n2, C_text("fx+")); + return C_u_fixnum_plus(n1, n2); +} + +inline static C_word C_i_s_fixnum_difference(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx-")); + C_i_check_fixnum_2_c(n2, C_text("fx-")); + return C_u_fixnum_difference(n1, n2); +} + +inline static C_word C_i_s_fixnum_times(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx*")); + C_i_check_fixnum_2_c(n2, C_text("fx*")); + return C_fixnum_times(n1, n2); +} + +inline static C_word C_i_s_fixnum_divide(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx/")); + C_i_check_fixnum_2_c(n2, C_text("fx/")); + if(n2 == C_fix(0)) C_div_by_zero_error(C_text("fx/")); + return C_u_fixnum_divide(n1, n2); +} + +inline static C_word C_i_s_fixnum_and(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxand")); + C_i_check_fixnum_2_c(n2, C_text("fxand")); + return C_u_fixnum_and(n1, n2); +} + +inline static C_word C_i_s_fixnum_or(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxior")); + C_i_check_fixnum_2_c(n2, C_text("fxior")); + return C_u_fixnum_or(n1, n2); +} + +inline static C_word C_i_s_fixnum_xor(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxxor")); + C_i_check_fixnum_2_c(n2, C_text("fxxor")); + return C_fixnum_xor(n1, n2); +} + +inline static C_word C_i_s_fixnum_not(C_word n1) +{ + C_i_check_fixnum_2_c(n1, C_text("fxnot")); + return C_fixnum_not(n1); +} + +inline static C_word C_i_s_fixnum_shift_right(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxshr")); + C_i_check_fixnum_2_c(n2, C_text("fxshr")); + return C_fixnum_shift_right(n1, n2); +} + +inline static C_word C_i_s_fixnum_shift_left(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxshl")); + C_i_check_fixnum_2_c(n2, C_text("fxshl")); + return C_fixnum_shift_left(n1, n2); +} + +inline static C_word C_i_s_fixnum_max(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxmax")); + C_i_check_fixnum_2_c(n2, C_text("fxmax")); + return C_i_fixnum_max(n1, n2); +} + +inline static C_word C_i_s_fixnum_min(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxmin")); + C_i_check_fixnum_2_c(n2, C_text("fxmin")); + return C_i_fixnum_min(n1, n2); +} + +inline static C_word C_i_s_fixnum_modulo(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fxmod")); + C_i_check_fixnum_2_c(n2, C_text("fxmod")); + if(n2 == C_fix(0)) C_div_by_zero_error(C_text("fxmod")); + return C_u_fixnum_modulo(n1, n2); +} + +inline static C_word C_i_s_fixnum_negate(C_word n1) +{ + C_i_check_fixnum_2_c(n1, C_text("fxneg")); + return C_u_fixnum_negate(n1); +} + +inline static C_word C_i_s_fixnum_oddp(C_word n1) +{ + C_i_check_fixnum_2_c(n1, C_text("fxodd?")); + return C_i_fixnumoddp(n1); +} + +inline static C_word C_i_s_fixnum_evenp(C_word n1) +{ + C_i_check_fixnum_2_c(n1, C_text("fxeven?")); + return C_i_fixnumevenp(n1); +} + +inline static C_word C_i_s_fixnum_lessp(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx<")); + C_i_check_fixnum_2_c(n2, C_text("fx<")); + return C_fixnum_lessp(n1, n2); +} + +inline static C_word C_i_s_fixnum_greaterp(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx>")); + C_i_check_fixnum_2_c(n2, C_text("fx>")); + return C_fixnum_greaterp(n1, n2); +} + +inline static C_word C_i_s_fixnum_less_or_equal_p(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx<=")); + C_i_check_fixnum_2_c(n2, C_text("fx<=")); + return C_fixnum_less_or_equal_p(n1, n2); +} + +inline static C_word C_i_s_fixnum_greater_or_equal_p(C_word n1, C_word n2) +{ + C_i_check_fixnum_2_c(n1, C_text("fx>=")); + C_i_check_fixnum_2_c(n2, C_text("fx>=")); + return C_fixnum_greater_or_equal_p(n1, n2); +} + + /* XXX: Naming convention is inconsistent! There's C_fixnum_divide() * but also C_a_i_flonum_quotient_checked() */ diff --git a/library.scm b/library.scm index bc0ef42c..2a301ab7 100644 --- a/library.scm +++ b/library.scm @@ -969,29 +969,29 @@ EOF (define fixnum-bits (foreign-value "(C_WORD_SIZE - 1)" int)) (define fixnum-precision (foreign-value "(C_WORD_SIZE - (1 + 1))" int)) -(define (fx+ x y) (##core#inline "C_fixnum_plus" x y)) -(define (fx- x y) (##core#inline "C_fixnum_difference" x y)) -(define (fx* x y) (##core#inline "C_fixnum_times" x y)) -(define (fx= x y) (eq? x y)) -(define (fx> x y) (##core#inline "C_fixnum_greaterp" x y)) -(define (fx< x y) (##core#inline "C_fixnum_lessp" x y)) -(define (fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y)) -(define (fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y)) -(define (fxmin x y) (##core#inline "C_i_fixnum_min" x y)) -(define (fxmax x y) (##core#inline "C_i_fixnum_max" x y)) -(define (fxneg x) (##core#inline "C_fixnum_negate" x)) -(define (fxand x y) (##core#inline "C_fixnum_and" x y)) -(define (fxior x y) (##core#inline "C_fixnum_or" x y)) -(define (fxxor x y) (##core#inline "C_fixnum_xor" x y)) -(define (fxnot x) (##core#inline "C_fixnum_not" x)) -(define (fxshl x y) (##core#inline "C_fixnum_shift_left" x y)) -(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_i_s_fixnum_equalp x y)) +(define (fx+ x y) (##core#inline C_i_s_fixnum_plus x y)) +(define (fx- x y) (##core#inline C_i_s_fixnum_difference x y)) +(define (fx* x y) (##core#inline C_i_s_fixnum_times x y)) +(define (fx/ x y) (##core#inline C_i_s_fixnum_divide x y)) +(define (fxand x y) (##core#inline C_i_s_fixnum_and x y)) +(define (fxior x y) (##core#inline C_i_s_fixnum_or x y)) +(define (fxxor x y) (##core#inline C_i_s_fixnum_xor x y)) +(define (fxnot x) (##core#inline C_i_s_fixnum_not x)) +(define (fxshr x y) (##core#inline C_i_s_fixnum_shift_right x y)) +(define (fxshl x y) (##core#inline C_i_s_fixnum_shift_left x y)) +(define (fxmax x y) (##core#inline C_i_s_fixnum_max x y)) +(define (fxmin x y) (##core#inline C_i_s_fixnum_min x y)) +(define (fxmod x y) (##core#inline C_i_s_fixnum_modulo x y)) +(define (fxneg x) (##core#inline C_i_s_fixnum_negate x)) +(define (fxodd? x) (##core#inline C_i_s_fixnum_oddp x)) +(define (fxeven? x) (##core#inline C_i_s_fixnum_evenp x)) +(define (fx< x y) (##core#inline C_i_s_fixnum_lessp x y)) +(define (fx> x y) (##core#inline C_i_s_fixnum_greaterp x y)) +(define (fx<= x y) (##core#inline C_i_s_fixnum_less_or_equal_p x y)) +(define (fx>= x y) (##core#inline C_i_s_fixnum_greater_or_equal_p x y)) (define (fxlen x) (##core#inline "C_i_fixnum_length" x)) -(define (fx/ x y) (##core#inline "C_fixnum_divide" x y) ) (define (fxgcd x y) (##core#inline "C_i_fixnum_gcd" x y)) -(define (fxmod x y) (##core#inline "C_fixnum_modulo" x y) ) (define (fxrem x y) (##core#inline "C_i_fixnum_remainder_checked" x y) ) ;; Overflow-detecting versions of some of the above diff --git a/runtime.c b/runtime.c index 5e1bb9f1..a96c1232 100644 --- a/runtime.c +++ b/runtime.c @@ -7292,6 +7292,14 @@ C_regparm C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc) return C_SCHEME_UNDEFINED; } +C_regparm C_word C_fcall C_i_check_fixnum_2_c(C_word x, char *loc) +{ + if(C_unlikely(!(x & C_FIXNUM_BIT))) { + error_location = loc; + barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x); + } +} + /* DEPRECATED */ C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc) { diff --git a/types.db b/types.db index 06514b28..ad0ef145 100644 --- a/types.db +++ b/types.db @@ -1270,29 +1270,72 @@ (chicken.fixnum#fixnum-precision fixnum) ;;XXX These aren't enforcing, and aren't foldable due to 32/64-bit issues -(chicken.fixnum#fx- (#(procedure #:clean) chicken.fixnum#fx- (fixnum fixnum) fixnum)) -(chicken.fixnum#fx* (#(procedure #:clean) chicken.fixnum#fx* (fixnum fixnum) fixnum)) -(chicken.fixnum#fx/ (#(procedure #:clean) chicken.fixnum#fx/ (fixnum fixnum) fixnum)) +(chicken.fixnum#fx= + (#(procedure #:pure #:enforce) chicken.fixnum#fx= (fixnum fixnum) boolean) + ((fixnum fixnum) (##core#inline "C_eqp" #(1) #(2)))) +(chicken.fixnum#fx+ + (#(procedure #:pure #:enforce) chicken.fixnum#fx+ (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_u_fixnum_plus" #(1) #(2)))) +(chicken.fixnum#fx- + (#(procedure #:pure #:enforce) chicken.fixnum#fx- (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_u_fixnum_difference" #(1) #(2)))) +(chicken.fixnum#fx* + (#(procedure #:pure #:enforce) chicken.fixnum#fx* (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_fixnum_times" #(1) #(2)))) +(chicken.fixnum#fx/ + (#(procedure #:pure #:enforce) chicken.fixnum#fx/ (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_u_fixnum_divide" #(1) #(2)))) +(chicken.fixnum#fxand + (#(procedure #:pure #:enforce) chicken.fixnum#fxand (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_u_fixnum_and" #(1) #(2)))) +(chicken.fixnum#fxior + (#(procedure #:pure #:enforce) chicken.fixnum#fxior (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_u_fixnum_or" #(1) #(2)))) +(chicken.fixnum#fxxor + (#(procedure #:pure #:enforce) chicken.fixnum#fxxor (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_fixnum_xor" #(1) #(2)))) +(chicken.fixnum#fxnot + (#(procedure #:pure #:enforce) chicken.fixnum#fxnot (fixnum) fixnum) + ((fixnum) (##core#inline "C_fixnum_not" #(1)))) +(chicken.fixnum#fxshr + (#(procedure #:pure #:enforce) chicken.fixnum#fxshr (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_fixnum_shift_right" #(1) #(2)))) +(chicken.fixnum#fxshl + (#(procedure #:pure #:enforce) chicken.fixnum#fxshl (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_fixnum_shift_left" #(1) #(2)))) +(chicken.fixnum#fxmax + (#(procedure #:pure #:enforce) chicken.fixnum#fxmax (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_i_fixnum_max" #(1) #(2)))) +(chicken.fixnum#fxmin + (#(procedure #:pure #:enforce) chicken.fixnum#fxmin (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_i_fixnum_min" #(1) #(2)))) +(chicken.fixnum#fxmod + (#(procedure #:pure #:enforce) chicken.fixnum#fxmod (fixnum fixnum) fixnum) + ((fixnum fixnum) (##core#inline "C_u_fixnum_modulo" #(1) #(2)))) +(chicken.fixnum#fxneg + (#(procedure #:pure #:enforce) chicken.fixnum#fxneg (fixnum) fixnum) + ((fixnum) (##core#inline "C_u_fixnum_negate" #(1)))) +(chicken.fixnum#fxodd? + (#(procedure #:pure #:enforce) chicken.fixnum#fxodd? (fixnum) boolean) + ((fixnum) (##core#inline "C_i_fixnumoddp" #(1)))) +(chicken.fixnum#fxeven? + (#(procedure #:pure #:enforce) chicken.fixnum#fxeven? (fixnum) boolean) + ((fixnum) (##core#inline "C_i_fixnumevenp" #(1)))) +(chicken.fixnum#fx< + (#(procedure #:pure #:enforce) chicken.fixnum#fx< (fixnum fixnum) boolean) + ((fixnum fixnum) (##core#inline "C_fixnum_lessp" #(1) #(2)))) +(chicken.fixnum#fx> + (#(procedure #:pure #:enforce) chicken.fixnum#fx> (fixnum fixnum) boolean) + ((fixnum fixnum) (##core#inline "C_fixnum_greaterp" #(1) #(2)))) +(chicken.fixnum#fx<= + (#(procedure #:pure #:enforce) chicken.fixnum#fx<= (fixnum fixnum) boolean) + ((fixnum fixnum) (##core#inline "C_fixnum_less_or_equal_p" #(1) #(2)))) +(chicken.fixnum#fx>= + (#(procedure #:pure #:enforce) chicken.fixnum#fx>= (fixnum fixnum) boolean) + ((fixnum fixnum) (##core#inline "C_fixnum_greater_or_equal_p" #(1) #(2)))) + (chicken.fixnum#fxgcd (#(procedure #:clean) chicken.fixnum#fxgcd (fixnum fixnum) fixnum)) -(chicken.fixnum#fx+ (#(procedure #:clean) chicken.fixnum#fx+ (fixnum fixnum) fixnum)) -(chicken.fixnum#fx< (#(procedure #:clean) chicken.fixnum#fx< (fixnum fixnum) boolean)) -(chicken.fixnum#fx<= (#(procedure #:clean) chicken.fixnum#fx<= (fixnum fixnum) boolean)) -(chicken.fixnum#fx= (#(procedure #:clean) chicken.fixnum#fx= (fixnum fixnum) boolean)) -(chicken.fixnum#fx> (#(procedure #:clean) chicken.fixnum#fx> (fixnum fixnum) boolean)) -(chicken.fixnum#fx>= (#(procedure #:clean) chicken.fixnum#fx>= (fixnum fixnum) boolean)) -(chicken.fixnum#fxand (#(procedure #:clean) chicken.fixnum#fxand (fixnum fixnum) fixnum)) -(chicken.fixnum#fxeven? (#(procedure #:clean) chicken.fixnum#fxeven? (fixnum) boolean)) -(chicken.fixnum#fxior (#(procedure #:clean) chicken.fixnum#fxior (fixnum fixnum) fixnum)) -(chicken.fixnum#fxmax (#(procedure #:clean) chicken.fixnum#fxmax (fixnum fixnum) fixnum)) -(chicken.fixnum#fxmin (#(procedure #:clean) chicken.fixnum#fxmin (fixnum fixnum) fixnum)) -(chicken.fixnum#fxmod (#(procedure #:clean) chicken.fixnum#fxmod (fixnum fixnum) fixnum)) (chicken.fixnum#fxrem (#(procedure #:clean) chicken.fixnum#fxrem (fixnum fixnum) fixnum)) -(chicken.fixnum#fxneg (#(procedure #:clean) chicken.fixnum#fxneg (fixnum) fixnum)) -(chicken.fixnum#fxnot (#(procedure #:clean) chicken.fixnum#fxnot (fixnum) fixnum)) -(chicken.fixnum#fxodd? (#(procedure #:clean) chicken.fixnum#fxodd? (fixnum) boolean)) -(chicken.fixnum#fxshl (#(procedure #:clean) chicken.fixnum#fxshl (fixnum fixnum) fixnum)) -(chicken.fixnum#fxshr (#(procedure #:clean) chicken.fixnum#fxshr (fixnum fixnum) fixnum)) -(chicken.fixnum#fxxor (#(procedure #:clean) chicken.fixnum#fxxor (fixnum fixnum) fixnum)) (chicken.fixnum#fxlen (#(procedure #:clean) chicken.fixnum#fxlen (fixnum) fixnum)) (chicken.fixnum#fx+? (#(procedure #:pure) chicken.fixnum#fx+? ((or fixnum false) (or fixnum false)) (or fixnum false)))