~ chicken-core (master) 50e6d7cea32c5aec3c0eb3d0bb736a409442e3e5
commit 50e6d7cea32c5aec3c0eb3d0bb736a409442e3e5
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Oct 28 18:42:50 2025 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Oct 28 18:42:50 2025 +0100
move exact-integer? into scheme.base module
diff --git a/c-backend.scm b/c-backend.scm
index b0e72336..fe692db3 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1519,7 +1519,7 @@ return((C_header_bits(lit) >> 24) & 0xff);
(oct (bitwise-and #xff (arithmetic-shift lit -16)))
(oct (bitwise-and #xff (arithmetic-shift lit -8)))
(oct (bitwise-and #xff lit)) ) )
- ((exact-integer? lit)
+ ((##core#inline "C_i_exact_integerp" lit)
;; Encode as hex to save space and get exact size
;; calculation. We could encode as base 32 to save more
;; space, but that makes debugging harder. The type tag is
diff --git a/c-platform.scm b/c-platform.scm
index 41aa7955..8111ecd4 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -132,7 +132,7 @@
write-char newline write display append symbol->string for-each map char? char->integer
integer->char eof-object? vector-length string-length string-ref string-set! vector-ref
vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
- number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
+ number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact? exact-integer?
max min quotient remainder modulo floor ceiling truncate round rationalize
exact->inexact inexact->exact
exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
@@ -172,7 +172,7 @@
chicken.base#current-error-port
chicken.base#symbol-append chicken.base#foldl chicken.base#foldr
chicken.base#setter chicken.base#getter-with-setter
- chicken.base#equal=? chicken.base#exact-integer?
+ chicken.base#equal=?
chicken.base#flush-output
chicken.base#weak-cons chicken.base#weak-pair? chicken.base#bwp-object?
@@ -547,7 +547,7 @@
(rewrite 'scheme#rational? 2 1 "C_i_rationalp" #t)
(rewrite 'scheme#real? 2 1 "C_i_realp" #t)
(rewrite 'scheme#integer? 2 1 "C_i_integerp" #t)
-(rewrite 'chicken.base#exact-integer? 2 1 "C_i_exact_integerp" #t)
+(rewrite 'scheme#exact-integer? 2 1 "C_i_exact_integerp" #t)
(rewrite 'chicken.base#flonum? 2 1 "C_i_flonump" #t)
(rewrite 'chicken.base#fixnum? 2 1 "C_fixnump" #t)
(rewrite 'chicken.base#bignum? 2 1 "C_i_bignump" #t)
diff --git a/chicken.base.import.scm b/chicken.base.import.scm
index ec27c02b..20af60d2 100644
--- a/chicken.base.import.scm
+++ b/chicken.base.import.scm
@@ -51,7 +51,6 @@
(enable-warnings . chicken.base#enable-warnings)
(equal=? . chicken.base#equal=?)
(error . chicken.base#error)
- (exact-integer? . chicken.base#exact-integer?)
(exact-integer-nth-root . chicken.base#exact-integer-nth-root)
(exit . chicken.base#exit)
(exit-handler . chicken.base#exit-handler)
diff --git a/library.scm b/library.scm
index fd2b0620..b507199d 100644
--- a/library.scm
+++ b/library.scm
@@ -226,6 +226,7 @@ EOF
member assq assv assoc symbol? symbol->string string->symbol number?
integer? exact? real? complex? inexact? rational? zero? odd? even?
positive? negative? max min + - * / = > < >= <= quotient remainder
+ exact-integer?
modulo gcd lcm abs floor ceiling truncate round rationalize
exact->inexact inexact->exact exp log expt sqrt
sin cos tan asin acos atan
@@ -524,6 +525,7 @@ EOF
(define (zero? n) (##core#inline "C_i_zerop" n))
(define (positive? n) (##core#inline "C_i_positivep" n))
(define (negative? n) (##core#inline "C_i_negativep" n))
+(define (exact-integer? x) (##core#inline "C_i_exact_integerp" x))
(define number->string (##core#primitive "C_number_to_string"))
(define string->number)
@@ -771,7 +773,7 @@ EOF
;; letrec-values nth-value optional parameterize rec receive
;; require-library require-extension set!-values syntax unless when
bignum? flonum? fixnum? ratnum? cplxnum? finite? infinite? nan?
- exact-integer? exact-integer-sqrt exact-integer-nth-root
+ exact-integer-sqrt exact-integer-nth-root
port-closed? flush-output
get-call-chain print print* add1 sub1 sleep
@@ -801,7 +803,6 @@ EOF
(define (bignum? x) (##core#inline "C_i_bignump" x))
(define (ratnum? x) (##core#inline "C_i_ratnump" x))
(define (cplxnum? x) (##core#inline "C_i_cplxnump" x))
-(define (exact-integer? x) (##core#inline "C_i_exact_integerp" x))
(define exact-integer-sqrt)
(define exact-integer-nth-root)
@@ -2347,27 +2348,29 @@ EOF
(set! scheme#numerator
(lambda (n)
- (cond ((exact-integer? n) n)
- ((##core#inline "C_i_flonump" n)
- (cond ((not (finite? n)) (##sys#error-bad-inexact n 'numerator))
- ((##core#inline "C_u_i_fpintegerp" n) n)
- (else (exact->inexact (numerator (inexact->exact n))))))
- ((ratnum? n) (%ratnum-numerator n))
- (else (##sys#signal-hook
- #:type-error 'numerator
- "bad argument type - not a rational number" n) ) )))
+ (cond ((##core#inline "C_i_exact_integerp" n) n)
+ ((##core#inline "C_i_flonump" n)
+ (cond ((not (finite? n)) (##sys#error-bad-inexact n 'numerator))
+ ((##core#inline "C_u_i_fpintegerp" n) n)
+ (else (exact->inexact (numerator (inexact->exact n))))))
+ ((ratnum? n) (%ratnum-numerator n))
+ (else (##sys#signal-hook
+ #:type-error 'numerator
+ "bad argument type - not a rational number" n) ) )))
+
(set! scheme#denominator
(lambda (n)
- (cond ((exact-integer? n) 1)
- ((##core#inline "C_i_flonump" n)
- (cond ((not (finite? n)) (##sys#error-bad-inexact n 'denominator))
- ((##core#inline "C_u_i_fpintegerp" n) 1.0)
- (else (exact->inexact (denominator (inexact->exact n))))))
- ((ratnum? n) (%ratnum-denominator n))
- (else (##sys#signal-hook
- #:type-error 'numerator
- "bad argument type - not a rational number" n) ) )))
+ (cond ((##core#inline "C_i_exact_integerp" n) 1)
+ ((##core#inline "C_i_flonump" n)
+ (cond ((not (finite? n)) (##sys#error-bad-inexact n 'denominator))
+ ((##core#inline "C_u_i_fpintegerp" n) 1.0)
+ (else (exact->inexact (denominator (inexact->exact n))))))
+ ((ratnum? n) (%ratnum-denominator n))
+ (else (##sys#signal-hook
+ #:type-error 'numerator
+ "bad argument type - not a rational number" n) ) )))
+
(define (##sys#extended-signum x)
(cond
@@ -2456,7 +2459,8 @@ EOF
(define (##sys#/-2 x y)
(when (eq? y 0)
(##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) '/ x y))
- (cond ((and (exact-integer? x) (exact-integer? y))
+ (cond ((and (##core#inline "C_i_exact_integerp" x)
+ (##core#inline "C_i_exact_integerp" y))
(let ((g (%integer-gcd x y)))
(ratnum (%integer-quotient x g) (%integer-quotient y g))))
;; Compnum *must* be checked first
@@ -2507,43 +2511,43 @@ EOF
(set! scheme#floor
(lambda (x)
- (cond ((exact-integer? x) x)
- ((##core#inline "C_i_flonump" x) (fpfloor x))
- ;; (floor x) = greatest integer <= x
- ((ratnum? x) (let* ((n (%ratnum-numerator x))
- (q (quotient n (%ratnum-denominator x))))
- (if (>= n 0) q (- q 1))))
- (else (##sys#error-bad-real x 'floor)) )))
+ (cond ((##core#inline "C_i_exact_integerp" x) x)
+ ((##core#inline "C_i_flonump" x) (fpfloor x))
+ ;; (floor x) = greatest integer <= x
+ ((ratnum? x) (let* ((n (%ratnum-numerator x))
+ (q (quotient n (%ratnum-denominator x))))
+ (if (>= n 0) q (- q 1))))
+ (else (##sys#error-bad-real x 'floor)) )))
(set! scheme#ceiling
(lambda (x)
- (cond ((exact-integer? x) x)
- ((##core#inline "C_i_flonump" x) (fpceiling x))
- ;; (ceiling x) = smallest integer >= x
- ((ratnum? x) (let* ((n (%ratnum-numerator x))
- (q (quotient n (%ratnum-denominator x))))
- (if (>= n 0) (+ q 1) q)))
- (else (##sys#error-bad-real x 'ceiling)) )))
+ (cond ((##core#inline "C_i_exact_integerp" x) x)
+ ((##core#inline "C_i_flonump" x) (fpceiling x))
+ ;; (ceiling x) = smallest integer >= x
+ ((ratnum? x) (let* ((n (%ratnum-numerator x))
+ (q (quotient n (%ratnum-denominator x))))
+ (if (>= n 0) (+ q 1) q)))
+ (else (##sys#error-bad-real x 'ceiling)) )))
(set! scheme#truncate
(lambda (x)
- (cond ((exact-integer? x) x)
- ((##core#inline "C_i_flonump" x) (fptruncate x))
- ;; (rational-truncate x) = integer of largest magnitude <= (abs x)
- ((ratnum? x) (quotient (%ratnum-numerator x)
- (%ratnum-denominator x)))
- (else (##sys#error-bad-real x 'truncate)) )))
+ (cond ((##core#inline "C_i_exact_integerp" x) x)
+ ((##core#inline "C_i_flonump" x) (fptruncate x))
+ ;; (rational-truncate x) = integer of largest magnitude <= (abs x)
+ ((ratnum? x) (quotient (%ratnum-numerator x)
+ (%ratnum-denominator x)))
+ (else (##sys#error-bad-real x 'truncate)) )))
(set! scheme#round
(lambda (x)
- (cond ((exact-integer? x) x)
- ((##core#inline "C_i_flonump" x)
- (##core#inline_allocate ("C_a_i_flonum_round_proper" 4) x))
- ((ratnum? x)
- (let* ((x+1/2 (+ x (%make-ratnum 1 2)))
- (r (floor x+1/2)))
- (if (and (= r x+1/2) (odd? r)) (- r 1) r)))
- (else (##sys#error-bad-real x 'round)) )))
+ (cond ((##core#inline "C_i_exact_integerp" x) x)
+ ((##core#inline "C_i_flonump" x)
+ (##core#inline_allocate ("C_a_i_flonum_round_proper" 4) x))
+ ((ratnum? x)
+ (let* ((x+1/2 (+ x (%make-ratnum 1 2)))
+ (r (floor x+1/2)))
+ (if (and (= r x+1/2) (odd? r)) (- r 1) r)))
+ (else (##sys#error-bad-real x 'round)) )))
(define (find-ratio-between x y)
(define (sr x y)
@@ -2735,7 +2739,7 @@ EOF
((negative? n)
(make-complex .0 (##core#inline_allocate
("C_a_i_sqrt" 4) (exact->inexact (- n)))))
- ((exact-integer? n)
+ ((##core#inline "C_i_exact_integerp" n)
(receive (s^2 r) (##sys#exact-integer-sqrt n)
(if (eq? 0 r)
s^2
@@ -2870,8 +2874,9 @@ EOF
;; Useful for sane error messages
(define (##sys#internal-gcd loc a b)
- (cond ((exact-integer? a)
- (cond ((exact-integer? b) (%integer-gcd a b))
+ (cond ((##core#inline "C_i_exact_integerp" a)
+ (cond ((##core#inline "C_i_exact_integerp" b)
+ (%integer-gcd a b))
((and (##core#inline "C_i_flonump" b)
(##core#inline "C_u_i_fpintegerp" b))
(exact->inexact (%integer-gcd a (inexact->exact b))))
@@ -2880,7 +2885,7 @@ EOF
(##core#inline "C_u_i_fpintegerp" a))
(cond ((##core#inline "C_i_flonump" b)
(##core#inline_allocate ("C_a_i_flonum_gcd" 4) a b))
- ((exact-integer? b)
+ ((##core#inline "C_i_exact_integerp" b)
(exact->inexact (%integer-gcd (inexact->exact a) b)))
(else (##sys#error-bad-integer b loc))))
(else (##sys#error-bad-integer a loc))))
diff --git a/modules.scm b/modules.scm
index 3dec9f93..a14a1c0d 100644
--- a/modules.scm
+++ b/modules.scm
@@ -1175,6 +1175,7 @@
(rational? . scheme#rational?) (zero? . scheme#zero?)
(odd? . scheme#odd?) (even? . scheme#even?)
(positive? . scheme#positive?) (negative? . scheme#negative?)
+ (exact-integer? . scheme#exact-integer?)
(max . scheme#max) (min . scheme#min)
(+ . scheme#+) (- . scheme#-) (* . scheme#*) (/ . scheme#/)
(= . scheme#=) (> . scheme#>) (< . scheme#<)
diff --git a/tests/numbers-test.scm b/tests/numbers-test.scm
index dc564534..b8b3f065 100644
--- a/tests/numbers-test.scm
+++ b/tests/numbers-test.scm
@@ -9,7 +9,7 @@
(chicken platform)
(chicken time))
-(import (only (scheme base) exact-integer-sqrt))
+(import (only (scheme base) exact-integer? exact-integer-sqrt))
;; The default "comparator" doesn't know how to deal with extended number types
(current-test-comparator
diff --git a/types.db b/types.db
index fba0eaa6..a791fbcb 100644
--- a/types.db
+++ b/types.db
@@ -283,6 +283,11 @@
((integer) (##core#inline "C_i_integer_negativep" #(1)))
((*) (##core#inline "C_i_negativep" #(1))))
+(scheme#exact-integer? (#(procedure #:pure #:foldable) scheme#exact-integer? (*) boolean)
+ ((integer) (let ((#(tmp) #(1))) '#t))
+ (((not integer)) (let ((#(tmp) #(1))) '#f))
+ ((*) (##core#inline "C_i_exact_integerp" #(1))))
+
(scheme#max (#(procedure #:clean #:enforce #:foldable) scheme#max (#!rest number) number)
((fixnum fixnum) (fixnum) (chicken.fixnum#fxmax #(1) #(2)))
((float float) (float) (##core#inline "C_i_flonum_max" #(1) #(2))))
@@ -941,10 +946,6 @@
(chicken.base#warning (procedure chicken.base#warning (* #!rest) undefined))
(chicken.base#notice (procedure chicken.base#notice (* #!rest) undefined))
-(chicken.base#exact-integer? (#(procedure #:pure #:foldable) chicken.base#exact-integer? (*) boolean)
- ((integer) (let ((#(tmp) #(1))) '#t))
- (((not integer)) (let ((#(tmp) #(1))) '#f))
- ((*) (##core#inline "C_i_exact_integerp" #(1))))
(chicken.base#exact-integer-nth-root (#(procedure #:clean #:enforce #:foldable) chicken.base#exact-integer-nth-root (integer integer) integer integer)
((integer integer) (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root #(1) #(2))))
Trap