~ chicken-core (chicken-5) c47ac2643ca05600e7b3a0411e765e385358a6fe
commit c47ac2643ca05600e7b3a0411e765e385358a6fe
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sat Jan 24 18:05:57 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:10:15 2015 +0200
Add a few predicates and teach existing ones about extended numbers; add complex constructors.
Added:
- cplxnum?
- ratnum?
- exact-integer?
- imag-part
- real-part
- make-rectangular
- make-polar
- infinite?
- nan?
- ##sys#check-real
Updated to understand new types:
- exact? (and ##sys#check-exact)
- inexact? (and ##sys#check-inexact)
- integer? (and ##sys#check-integer)
- real?
- rational?
- finite?
- zero?
- exact?
- inexact?
- negative?
- positive?
- odd?
- even?
diff --git a/c-platform.scm b/c-platform.scm
index 31c0f200..501a2a47 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -145,7 +145,7 @@
fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set? fxodd? fxeven?
fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos fpatan
- fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger?
+ fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger? exact-integer?
arithmetic-shift void flush-output
atom? print print* error call/cc
blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
@@ -156,9 +156,8 @@
blob->f32vector/shared blob->f64vector/shared
block-ref block-set! number-of-slots substring-index substring-index-ci
any? read-string substring=? substring-ci=? blob=? equal=?
- alist-ref rassoc real-part imag-part
- string->symbol symbol-append
- make-record-instance foldl foldr
+ alist-ref rassoc make-polar make-rectangular real-part imag-part
+ string->symbol symbol-append make-record-instance foldl foldr
u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length
s32vector-length
f32vector-length f64vector-length setter
@@ -166,7 +165,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?
- pointer->object flonum? finite? address->pointer pointer->address
+ pointer->object flonum? nan? finite? infinite? 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
@@ -574,20 +573,23 @@
(rewrite 'number? 2 1 "C_i_numberp" #t)
(rewrite 'complex? 2 1 "C_i_numberp" #t)
(rewrite 'rational? 2 1 "C_i_rationalp" #t)
-(rewrite 'real? 2 1 "C_i_numberp" #t)
+(rewrite 'real? 2 1 "C_i_realp" #t)
(rewrite 'integer? 2 1 "C_i_integerp" #t)
+(rewrite 'exact-integer? 2 1 "C_i_exact_integerp" #t)
(rewrite 'flonum? 2 1 "C_i_flonump" #t)
(rewrite 'fixnum? 2 1 "C_fixnump" #t)
(rewrite 'bignum? 2 1 "C_i_bignump" #t)
+(rewrite 'cplxnum? 2 1 "C_i_cplxnump" #t)
+(rewrite 'ratnum? 2 1 "C_i_ratnump" #t)
+(rewrite 'nan? 2 1 "C_i_nanp" #f)
(rewrite 'finite? 2 1 "C_i_finitep" #f)
+(rewrite 'infinite? 2 1 "C_i_infinitep" #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)
(rewrite 'exact? 2 1 "C_u_i_exactp" #f)
-(rewrite 'inexact? 2 1 "C_nfixnump" #f)
(rewrite 'inexact? 2 1 "C_i_inexactp" #t)
(rewrite 'inexact? 2 1 "C_u_i_inexactp" #f)
(rewrite 'list? 2 1 "C_i_listp" #t)
diff --git a/chicken.h b/chicken.h
index 2b6e274c..ca25047c 100644
--- a/chicken.h
+++ b/chicken.h
@@ -521,6 +521,7 @@ static inline int isinf_ld (long double x)
#define C_SWIG_POINTER_TAG (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1)))
#define C_SYMBOL_TAG (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
#define C_FLONUM_TAG (C_FLONUM_TYPE | sizeof(double))
+#define C_STRUCTURE3_TAG (C_STRUCTURE_TYPE | 3)
/* Locative subtypes */
#define C_SLOT_LOCATIVE 0
@@ -657,6 +658,9 @@ static inline int isinf_ld (long double x)
#define C_FLOATING_POINT_EXCEPTION_ERROR 45
#define C_ILLEGAL_INSTRUCTION_ERROR 46
#define C_BUS_ERROR 47
+#define C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR 48
+#define C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR 49
+#define C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR 50
/* Platform information */
@@ -1157,6 +1161,7 @@ extern double trunc(double);
#define C_isnan(f) isnan(f)
#define C_isinf(f) isinf(f)
+#define C_isfinite(f) isfinite(f)
#ifdef C_STRESS_TEST
# define C_STRESS_FAILURE 3
@@ -1226,8 +1231,6 @@ extern double trunc(double);
#define C_eqp(x, y) C_mk_bool((x) == (y))
#define C_vemptyp(x) C_mk_bool(C_header_size(x) == 0)
#define C_notvemptyp(x) C_mk_bool(C_header_size(x) > 0)
-#define C_u_i_exactp(x) C_mk_bool((x) & C_FIXNUM_BIT)
-#define C_u_i_inexactp(x) C_mk_bool(((x) & C_FIXNUM_BIT) == 0)
#define C_slot(x, i) C_block_item(x, C_unfix(i))
#define C_subbyte(x, i) C_fix(((C_byte *)C_data_pointer(x))[ C_unfix(i) ] & 0xff)
@@ -1408,6 +1411,8 @@ extern double trunc(double);
#define C_i_equalp(x, y) C_mk_bool(C_equalp((x), (y)))
#define C_i_fixnumevenp(x) C_mk_nbool((x) & 0x00000002)
#define C_i_fixnumoddp(x) C_mk_bool((x) & 0x00000002)
+#define C_i_fixnum_negativep(x) C_mk_bool((x) & C_INT_SIGN_BIT)
+#define C_i_fixnum_positivep(x) C_mk_bool(!((x) & C_INT_SIGN_BIT) && (x) != C_fix(0))
#define C_i_nullp(x) C_mk_bool((x) == C_SCHEME_END_OF_LIST)
#define C_i_structurep(x, s) C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRUCTURE_TYPE && C_block_item(x, 0) == (s))
@@ -1659,6 +1664,9 @@ extern double trunc(double);
#define C_a_i_flonum_log(ptr, c, x) C_flonum(ptr, C_log(C_flonum_magnitude(x)))
#define C_a_i_flonum_sqrt(ptr, c, x) C_flonum(ptr, C_sqrt(C_flonum_magnitude(x)))
#define C_a_i_flonum_abs(ptr, c, x) C_flonum(ptr, C_fabs(C_flonum_magnitude(x)))
+#define C_u_i_flonum_nanp(x) C_mk_bool(C_isnan(C_flonum_magnitude(x)))
+#define C_u_i_flonum_infinitep(x) C_mk_bool(C_isinf(C_flonum_magnitude(x)))
+#define C_u_i_flonum_finitep(x) C_mk_bool(C_isfinite(C_flonum_magnitude(x)))
#define C_a_i_current_milliseconds(ptr, c, dummy) C_flonum(ptr, C_milliseconds())
@@ -1919,12 +1927,19 @@ 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_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;
+C_fctexport C_word C_fcall C_i_finitep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_infinitep(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_zerop(C_word x) C_regparm;
C_fctexport C_word C_fcall C_u_i_zerop(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_positivep(C_word x) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_u_i_positivep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_integer_positivep(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_negativep(C_word x) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_u_i_negativep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_integer_negativep(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_car(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_cdr(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_caar(C_word x) C_regparm;
@@ -1936,10 +1951,14 @@ C_fctexport C_word C_fcall C_i_cdddr(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_cadddr(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_cddddr(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_list_tail(C_word lst, C_word i) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_i_evenp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_u_i_evenp(C_word x) C_regparm;
+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;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_u_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_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;
@@ -2381,23 +2400,37 @@ C_inline C_word C_i_numberp(C_word x)
(!C_immediatep(x) &&
(C_block_header(x) == C_FLONUM_TAG ||
C_header_bits(x) == C_BIGNUM_TYPE ||
- (C_header_bits(x) == C_STRUCTURE_TYPE &&
+ (C_block_header(x) == C_STRUCTURE3_TAG &&
(C_block_item(x, 0) == C_ratnum_type_tag ||
C_block_item(x, 0) == C_cplxnum_type_tag)))));
}
+/* All numbers are real, except for cplxnums */
+C_inline C_word C_i_realp(C_word x)
+{
+ return C_mk_bool((x & C_FIXNUM_BIT) ||
+ (!C_immediatep(x) &&
+ (C_block_header(x) == C_FLONUM_TAG ||
+ C_header_bits(x) == C_BIGNUM_TYPE ||
+ (C_header_bits(x) == C_STRUCTURE_TYPE &&
+ C_block_item(x, 0) == C_ratnum_type_tag))));
+}
+/* All finite real numbers are rational */
C_inline C_word C_i_rationalp(C_word x)
{
- if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
-
- if((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)) {
+ if(x & C_FIXNUM_BIT) {
+ return C_SCHEME_TRUE;
+ } else if (C_immediatep(x)) {
+ return C_SCHEME_FALSE;
+ } else if(C_block_header(x) == C_FLONUM_TAG) {
double n = C_flonum_magnitude(x);
-
- if(!C_isinf(n) && !C_isnan(n)) return C_SCHEME_TRUE;
+ return C_mk_bool(!C_isinf(n) && !C_isnan(n));
+ } else {
+ return C_mk_bool(C_header_bits(x) == C_BIGNUM_TYPE ||
+ (C_header_bits(x) == C_STRUCTURE_TYPE &&
+ C_block_item(x, 0) == C_ratnum_type_tag));
}
-
- return C_SCHEME_FALSE;
}
@@ -2420,12 +2453,54 @@ C_inline int C_ub_i_fpintegerp(double x)
return C_modf(x, &dummy) == 0.0;
}
+C_inline C_word C_i_exact_integerp(C_word x)
+{
+ return C_mk_bool((x) & C_FIXNUM_BIT ||
+ (!C_immediatep(x) && (C_header_bits(x) == C_BIGNUM_TYPE)));
+}
+
+C_inline C_word C_u_i_exactp(C_word x)
+{
+ if (C_truep(C_i_exact_integerp(x))) {
+ return C_SCHEME_TRUE;
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_SCHEME_FALSE;
+ } else if (C_block_header(x) != C_STRUCTURE3_TAG) {
+ return C_SCHEME_FALSE;
+ } else if (C_block_item(x, 0) == C_ratnum_type_tag) {
+ return C_SCHEME_TRUE;
+ } else if (C_block_item(x, 0) != C_cplxnum_type_tag) {
+ return C_SCHEME_FALSE;
+ } else {
+ x = C_block_item(x, 1);
+ /* r and i are always the same exactness, and we assume they
+ * always store a number.
+ */
+ return C_mk_bool(C_immediatep(x) || (C_block_header(x) != C_FLONUM_TAG));
+ }
+}
+
+C_inline C_word C_u_i_inexactp(C_word x)
+{
+ if (C_immediatep(x)) {
+ return C_SCHEME_FALSE;
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_SCHEME_TRUE;
+ } else if (C_block_header(x) != C_STRUCTURE3_TAG ||
+ C_block_item(x, 0) != C_cplxnum_type_tag) {
+ return C_SCHEME_FALSE;
+ } else {
+ x = C_block_item(x, 1); /* r and i are always the same exactness */
+ return C_mk_bool(!C_immediatep(x) && (C_block_header(x) == C_FLONUM_TAG));
+ }
+}
C_inline C_word C_i_integerp(C_word x)
{
double dummy, val;
- if (x & C_FIXNUM_BIT)
+ if (x & C_FIXNUM_BIT ||
+ (!C_immediatep(x) && (C_header_bits(x) == C_BIGNUM_TYPE)))
return C_SCHEME_TRUE;
if (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
return C_SCHEME_FALSE;
@@ -2442,16 +2517,18 @@ C_inline C_word C_i_flonump(C_word x)
return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
}
+C_inline C_word C_i_cplxnump(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) &&
+ C_block_header(x) == C_STRUCTURE3_TAG &&
+ C_block_item(x, 0) == C_cplxnum_type_tag);
+}
-C_inline C_word C_i_finitep(C_word x)
+C_inline C_word C_i_ratnump(C_word x)
{
- double val;
-
- if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
-
- val = C_flonum_magnitude(x);
- if(C_isnan(val) || C_isinf(val)) return C_SCHEME_FALSE;
- else return C_SCHEME_TRUE;
+ return C_mk_bool(!C_immediatep(x) &&
+ C_block_header(x) == C_STRUCTURE3_TAG &&
+ C_block_item(x, 0) == C_ratnum_type_tag);
}
diff --git a/chicken.import.scm b/chicken.import.scm
index aea7d7f6..6cceb89c 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -73,6 +73,7 @@
er-macro-transformer
errno
error
+ exact-integer?
exit
exit-handler
expand
@@ -159,6 +160,7 @@
get-properties
getter-with-setter
implicit-exit-handler
+ infinite?
ir-macro-transformer
keyword->string
keyword-style
@@ -179,6 +181,7 @@
module-environment
most-negative-fixnum
most-positive-fixnum
+ nan?
on-exit
open-input-string
open-output-string
diff --git a/library.scm b/library.scm
index 269e05d9..5cda691c 100644
--- a/library.scm
+++ b/library.scm
@@ -314,6 +314,12 @@ EOF
(foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int)
(and (pair? loc) (car loc)) x) ) )
+(define (##sys#check-real x . loc)
+ (unless (##core#inline "C_i_realp" x)
+ (##sys#error-hook
+ (foreign-value "C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR" int)
+ (and (pair? loc) (car loc)) x) ) )
+
(define (##sys#check-range i from to . loc)
(##sys#check-exact i loc)
(unless (and (fx<= from i) (fx< i to))
@@ -431,8 +437,11 @@ EOF
(define (##sys#error-not-a-proper-list arg #!optional loc)
(##sys#error-hook
- (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
- loc arg))
+ (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) loc arg))
+
+(define (##sys#error-bad-number arg #!optional loc)
+ (##sys#error-hook
+ (foreign-value "C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR" int) loc arg))
(define (append . lsts)
(if (eq? lsts '())
@@ -748,12 +757,12 @@ EOF
(define (flonum? x) (##core#inline "C_i_flonump" x))
(define (bignum? x) (##core#inline "C_i_bignump" x))
-(define (ratnum? x) (##sys#structure? x '##sys#ratnum))
-(define (cplxnum? x) (##sys#structure? x '##sys#cplxnum))
+(define (ratnum? x) (##core#inline "C_i_ratnump" x))
+(define (cplxnum? x) (##core#inline "C_i_cplxnump" x))
-(define (finite? x)
- (##sys#check-number x 'finite?)
- (##core#inline "C_i_finitep" x) )
+(define (finite? x) (##core#inline "C_i_finitep" x))
+(define (infinite? x) (##core#inline "C_i_infinitep" x))
+(define (nan? x) (##core#inline "C_i_nanp" x))
(define-inline (fp-check-flonum x loc)
(unless (flonum? x)
@@ -904,9 +913,10 @@ EOF
(define (number? x) (##core#inline "C_i_numberp" x))
(define ##sys#number? number?)
(define complex? number?)
-(define real? number?)
+(define (real? x) (##core#inline "C_i_realp" x))
(define (rational? n) (##core#inline "C_i_rationalp" n))
(define (integer? x) (##core#inline "C_i_integerp" x))
+(define (exact-integer? x) (##core#inline "C_i_exact_integerp" x))
(define ##sys#integer? integer?)
(define (exact? x) (##core#inline "C_i_exactp" x))
(define (inexact? x) (##core#inline "C_i_inexactp" x))
@@ -921,19 +931,50 @@ EOF
(define (negative? n) (##core#inline "C_i_negativep" n))
(define (abs n) (##core#inline_allocate ("C_a_i_abs" 4) n)) ; 4 => words-per-flonum
+;;; Complex numbers
+
+(define-inline (%cplxnum-real c) (##sys#slot c 1))
+(define-inline (%cplxnum-imag c) (##sys#slot c 2))
+
+(define-inline (%ratnum-numerator c) (##sys#slot c 1))
+(define-inline (%ratnum-denominator c) (##sys#slot c 2))
+
+(define (make-complex r i)
+ (if (or (eq? i 0) (and (##core#inline "C_i_flonump" i) (fp= i 0.0)))
+ r
+ (##sys#make-structure '##sys#cplxnum
+ (if (inexact? i) (exact->inexact r) r)
+ (if (inexact? r) (exact->inexact i) i)) ) )
+
+(define (make-rectangular r i)
+ (##sys#check-real r 'make-rectangular)
+ (##sys#check-real i 'make-rectangular)
+ (make-complex r i) )
+
+(define (make-polar r phi)
+ (##sys#check-real r 'make-polar)
+ (##sys#check-real phi 'make-polar)
+ (let ((fphi (exact->inexact phi)))
+ (make-complex (* r (##core#inline_allocate ("C_a_i_cos" 4) fphi))
+ (* r (##core#inline_allocate ("C_a_i_sin" 4) fphi)))))
+
+(define (real-part x)
+ (cond ((cplxnum? x) (%cplxnum-real x))
+ ((number? x) x)
+ (else (##sys#error-bad-number x 'real-part))))
+
+(define (imag-part x)
+ (cond ((cplxnum? x) (%cplxnum-imag x))
+ ((##core#inline "C_i_flonump" x) 0.0)
+ ((number? x) 0)
+ (else (##sys#error-bad-number x 'imag-part))))
+
(define (angle n)
(##sys#check-number n 'angle)
(if (< n 0) (fp* 2.0 (acos 0.0)) 0.0) )
-(define (real-part n)
- (##sys#check-number n 'real-part)
- n)
-
-(define (imag-part n)
- (##sys#check-number n 'imag-part)
- 0)
-;;; Rationals
+;;; Rational numbers
(define-inline (%ratnum-numerator c) (##sys#slot c 1))
(define-inline (%ratnum-denominator c) (##sys#slot c 2))
@@ -4231,6 +4272,9 @@ EOF
((45) (apply ##sys#signal-hook #:arithmetic-error loc "floating-point exception" args))
((46) (apply ##sys#signal-hook #:runtime-error loc "illegal instruction" args))
((47) (apply ##sys#signal-hook #:memory-error loc "bus error" args))
+ ((48) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact number" args))
+ ((49) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an inexact number" args))
+ ((50) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a real" args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
diff --git a/manual/C interface b/manual/C interface
index 21ef4c69..81caf6f5 100644
--- a/manual/C interface
+++ b/manual/C interface
@@ -225,12 +225,30 @@ Is {{x}} a number object (fixnum, bignum, flonum, ratnum, cplxnum)?
Is {{x}} a Scheme bignum object?
+===== C_i_cplxnump
+
+ [C function] C_word C_i_cplxnump(C_word x)
+
+Is {{x}} a Scheme cplxnum object?
+
+===== C_i_ratnump
+
+ [C function] C_word C_i_ratnump(C_word x)
+
+Is {{x}} a Scheme ratnum object?
+
===== C_i_flonump
[C function] C_word C_i_flonump(C_word x)
Is {{x}} a flonum object?
+===== C_i_exact_integerp
+
+ [C macro] C_word C_i_exact_integerp(C_word x)
+
+Is {{x}} an exact integer (i.e., a fixnum or a bignum)?
+
===== C_pointerp
[C macro] C_word C_pointerp(C_word x)
@@ -751,21 +769,21 @@ Is the (byte- or heterogenous) vector {{v}} nonempty?
==== Numbers
-These procedures accept any type of number, so you can pass in either
-a fixnum or a flonum. You shouldn't pass in another type though,
-since that could crash your program.
+These procedures accept any type of number, so you can pass in a
+fixnum, a flonum, a bignum, a ratnum or a cplxnum. You shouldn't pass
+in another type though, since that could crash your program.
===== C_u_i_exactp
[C macro] C_word C_u_i_exactp(C_word x)
-Is {{x}} an exact number (i.e., a fixnum)?
+Is {{x}} an exact number (i.e., a fixnum, bignum, ratnum or exact cplxnum)?
===== C_u_i_inexactp
[C macro] C_word C_u_i_inexactp(C_word x)
-Is {{x}} an inexact number (i.e., not a fixnum)?
+Is {{x}} an inexact number (i.e., a flonum or an inexact cplxnum)?
===== C_i_finitep
@@ -949,6 +967,20 @@ Returns {{C_SCHEME_TRUE}} when {{n1}} is less than {{n2}},
Returns {{C_SCHEME_TRUE}} when {{n1}} is less than or equal to
{{n2}}, {{C_SCHEME_FALSE}} if not.
+===== C_i_fixnum_positivep
+
+ [C macro] C_word C_i_fixnum_positivep(C_word n)
+
+Returns {{C_SCHEME_TRUE}} when {{n}} is a positive fixnum,
+{{C_SCHEME_FALSE}} if it is zero or negative.
+
+===== C_i_fixnum_negativep
+
+ [C macro] C_word C_i_fixnum_negativep(C_word n)
+
+Returns {{C_SCHEME_TRUE}} when {{n}} is a negative fixnum,
+{{C_SCHEME_FALSE}} if it is zero or positive.
+
===== C_fixnum_increase
[C macro] C_word C_fixnum_increase(C_word n)
@@ -1209,6 +1241,58 @@ Calculates the square root of {{n}}.
Calculates the absolute value of {{n}}.
+===== C_u_i_flonum_nanp
+
+ [C macro] C_word C_u_i_flonum_nanp(C_word n)
+
+Is {{n}} a flonum NaN value?
+
+===== C_u_i_flonum_finitep
+
+ [C macro] C_word C_u_i_flonum_finitep(C_word n)
+
+Is {{n}} a finite flonum (i.e., not NaN or one of the infinities)?
+
+===== C_u_i_flonum_infinitep
+
+ [C macro] C_word C_u_i_flonum_infinitep(C_word n)
+
+Is {{n}} an infinite flonum?
+
+==== Exact integers
+
+Often you know a value is an integer, but you don't know whether it's
+a fixnum or a bignum. In those cases, there are some optimized C
+functions and macros to perform operations on them.
+
+===== C_i_integer_evenp
+
+ [C macro] C_word C_i_integer_evenp(C_word n)
+
+Returns {{C_SCHEME_TRUE}} when {{n}} is an even fixnum or bignum,
+{{C_SCHEME_FALSE}} if it is odd.
+
+===== C_i_integer_oddp
+
+ [C macro] C_word C_i_integer_oddp(C_word n)
+
+Returns {{C_SCHEME_TRUE}} when {{n}} is an odd fixnum or bignum,
+{{C_SCHEME_FALSE}} if it is even.
+
+===== C_i_integer_positivep
+
+ [C macro] C_word C_i_integer_positivep(C_word n)
+
+Returns {{C_SCHEME_TRUE}} when {{n}} is a positive fixnum or bignum,
+{{C_SCHEME_FALSE}} if it is zero or negative.
+
+===== C_i_integer_negativep
+
+ [C macro] C_word C_i_integer_negativep(C_word n)
+
+Returns {{C_SCHEME_TRUE}} when {{n}} is a negative fixnum or bignum,
+{{C_SCHEME_FALSE}} if it is zero or positive.
+
==== Pointers
diff --git a/manual/Deviations from the standard b/manual/Deviations from the standard
index 3be8e714..59570e4e 100644
--- a/manual/Deviations from the standard
+++ b/manual/Deviations from the standard
@@ -99,18 +99,6 @@ data other than pairs, strings and vectors. However, R5RS does not
dictate the treatment of data types that are not specified by R5RS
-=== No built-in support for bignums
-
-There is no built-in support for exact rationals, complex
-numbers or extended-precision integers (bignums). The routines
-{{complex?}}, {{real?}} and {{rational?}} are identical to
-the standard procedure {{number?}}. The procedures {{make-rectangular}}
-and {{make-polar}} are not implemented. Fixnums are limited to
-2^<nowiki><sup>30</sup></nowiki> (or 2^<nowiki><sup>62</sup></nowiki>
-on 64-bit hardware). Support for the full numeric tower is available
-as a separate package (see the {{numbers}} package).
-
-
=== {{transcript-on}} and {{transcript-off}} are not implemented
The {{transcript-on}} and {{transcript-off}} procedures are
diff --git a/manual/Unit library b/manual/Unit library
index 10944eee..c1beed5e 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -45,6 +45,13 @@ set, or {{#f}} otherwise. The rightmost/least-significant bit is bit 0.
Returns {{#t}} if {{X}} is a bignum (integer larger than fits in a
fixnum), or {{#f}} otherwise.
+==== exact-integer?
+
+<procedure>(exact-integer? X)</procedure>
+
+Returns {{#t}} if {{X}} is an exact integer (i.e., a fixnum or a
+bignum), or {{#f}} otherwise.
+
==== cplxnum?
<procedure>(cplxnum? X)</procedure>
@@ -224,11 +231,30 @@ all floating-point numbers of a certain precision is given by the
formula {{ceil(1+N*log10(2))}}, where N is the number of bits of
precision; for double-precision, {{N=53}}.
+==== nan?
+
+<procedure>(nan? N)</procedure>
+
+Returns {{#t}} if {{N}} is not a number (a IEEE flonum NaN-value). If
+{{N}} is a complex number, it's considered nan if it has a real or
+imaginary component that's nan.
+
+==== finite?
+
+<procedure>(infinite? N)</procedure>
+
+Returns {{#t}} if {{N}} is negative or positive infinity, and {{#f}}
+otherwise. If {{N}} is a complex number, it's considered infinite if
+it has a real or imaginary component that's infinite.
+
==== finite?
<procedure>(finite? N)</procedure>
-Returns {{#f}} if {{N}} is negative or positive infinity, and {{#t}} otherwise.
+Returns {{#t}} if {{N}} represents a finite number and {{#f}}
+otherwise. Positive and negative infinity as well as NaNs are not
+considered finite. If {{N}} is a complex number, it's considered
+finite if both the real and imaginary components are finite.
==== signum
diff --git a/manual/faq b/manual/faq
index 024e7944..6fb485db 100644
--- a/manual/faq
+++ b/manual/faq
@@ -464,6 +464,8 @@ and compiler settings:
{{member}}
{{memq}}
{{memv}}
+{{make-polar}}
+{{make-rectangular}}
{{negative?}}
{{not}}
{{null?}}
@@ -594,6 +596,7 @@ The following extended bindings are handled specially:
{{fxshr}}
{{fxxor}}
{{identity}}
+{{infinite?}}
{{list->string}}
{{list->vector}}
{{locative->object}}
@@ -601,6 +604,7 @@ The following extended bindings are handled specially:
{{locative-set!}}
{{locative?}}
{{make-record-instance}}
+{{nan?}}
{{number-of-slots}}
{{o}}
{{pointer+}}
diff --git a/modules.scm b/modules.scm
index 102fddc8..a9ee89f0 100644
--- a/modules.scm
+++ b/modules.scm
@@ -893,7 +893,8 @@
close-input-port close-output-port load read eof-object? read-char
peek-char write display write-char newline with-input-from-file
with-output-to-file eval
- char-ready? imag-part real-part magnitude numerator denominator
+ char-ready? imag-part real-part make-rectangular make-polar
+ magnitude numerator denominator
scheme-report-environment null-environment interaction-environment
else))
(r4rs-syntax
diff --git a/runtime.c b/runtime.c
index 41748117..627e6639 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1758,6 +1758,21 @@ void barf(int code, char *loc, ...)
c = 0;
break;
+ case C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR:
+ msg = C_text("bad argument type - not an exact number");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR:
+ msg = C_text("bad argument type - not an inexact number");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR:
+ msg = C_text("bad argument type - not an real");
+ c = 1;
+ break;
+
default: panic(C_text("illegal internal error code"));
}
@@ -4663,136 +4678,280 @@ C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
return (C_word)p0;
}
+C_regparm C_word C_fcall C_i_nanp(C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ return C_SCHEME_FALSE;
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_u_i_flonum_nanp(x);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_SCHEME_FALSE;
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG) {
+ if (C_block_item(x, 0) == C_ratnum_type_tag)
+ return C_SCHEME_FALSE;
+ else if (C_block_item(x, 0) == C_cplxnum_type_tag)
+ return C_mk_bool(C_truep(C_i_nanp(C_block_item(x, 1))) ||
+ C_truep(C_i_nanp(C_block_item(x, 2))));
+ else
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
+ }
+}
-C_regparm C_word C_fcall C_i_exactp(C_word x)
+C_regparm C_word C_fcall C_i_finitep(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+ if (x & C_FIXNUM_BIT) {
+ return C_SCHEME_TRUE;
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_u_i_flonum_finitep(x);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_SCHEME_TRUE;
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG) {
+ if (C_block_item(x, 0) == C_ratnum_type_tag)
+ return C_SCHEME_TRUE;
+ else if (C_block_item(x, 0) == C_cplxnum_type_tag)
+ return C_and(C_i_finitep(C_block_item(x, 1)),
+ C_i_finitep(C_block_item(x, 2)));
+ else
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
+ }
+}
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact?", x);
+C_regparm C_word C_fcall C_i_infinitep(C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ return C_SCHEME_FALSE;
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_u_i_flonum_infinitep(x);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_SCHEME_FALSE;
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG) {
+ if (C_block_item(x, 0) == C_ratnum_type_tag)
+ return C_SCHEME_FALSE;
+ else if (C_block_item(x, 0) == C_cplxnum_type_tag)
+ return C_mk_bool(C_truep(C_i_infinitep(C_block_item(x, 1))) ||
+ C_truep(C_i_infinitep(C_block_item(x, 2))));
+ else
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
+ }
+}
- return C_SCHEME_FALSE;
+C_regparm C_word C_fcall C_i_exactp(C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ return C_SCHEME_TRUE;
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_SCHEME_FALSE;
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_SCHEME_TRUE;
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG) {
+ if (C_block_item(x, 0) == C_ratnum_type_tag)
+ return C_SCHEME_TRUE;
+ else if (C_block_item(x, 0) == C_cplxnum_type_tag)
+ return C_i_exactp(C_block_item(x, 1)); /* Exactness of i and r matches */
+ else
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);
+ }
}
C_regparm C_word C_fcall C_i_inexactp(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
-
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact?", x);
-
- return C_SCHEME_TRUE;
+ if (x & C_FIXNUM_BIT) {
+ return C_SCHEME_FALSE;
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_SCHEME_TRUE;
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_SCHEME_FALSE;
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG) {
+ if (C_block_item(x, 0) == C_ratnum_type_tag)
+ return C_SCHEME_FALSE;
+ else if (C_block_item(x, 0) == C_cplxnum_type_tag)
+ return C_i_inexactp(C_block_item(x, 1)); /* Exactness of i and r matches */
+ else
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);
+ }
}
C_regparm C_word C_fcall C_i_zerop(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
-
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "zero?", x);
-
- return C_mk_bool(C_flonum_magnitude(x) == 0.0);
+ if (x & C_FIXNUM_BIT) {
+ return C_mk_bool(x == C_fix(0));
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ return C_mk_bool(C_flonum_magnitude(x) == 0.0);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE ||
+ (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_ratnum_type_tag ||
+ C_block_item(x, 0) == C_cplxnum_type_tag))) {
+ return C_SCHEME_FALSE;
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);
+ }
}
-
/* I */
C_regparm C_word C_fcall C_u_i_zerop(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
-
- return C_mk_bool(C_flonum_magnitude(x) == 0.0);
+ return C_mk_bool(x == C_fix(0) ||
+ (!C_immediatep(x) &&
+ C_block_header(x) == C_FLONUM_TAG &&
+ C_flonum_magnitude(x) == 0.0));
}
C_regparm C_word C_fcall C_i_positivep(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
-
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "positive?", x);
-
- return C_mk_bool(C_flonum_magnitude(x) > 0.0);
+ if (x & C_FIXNUM_BIT)
+ return C_i_fixnum_positivep(x);
+ else if (C_immediatep(x))
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);
+ else if (C_block_header(x) == C_FLONUM_TAG)
+ return C_mk_bool(C_flonum_magnitude(x) > 0.0);
+ else if (C_header_bits(x) == C_BIGNUM_TYPE)
+ return C_mk_nbool(C_bignum_negativep(x));
+ else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_ratnum_type_tag))
+ return C_i_integer_positivep(C_block_item(x, 1));
+ else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_cplxnum_type_tag))
+ barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x);
+ else
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);
}
+C_regparm C_word C_fcall C_i_integer_positivep(C_word x)
+{
+ if (x & C_FIXNUM_BIT) return C_i_fixnum_positivep(x);
+ else return C_mk_nbool(C_bignum_negativep(x));
+}
-/* I */
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_u_i_positivep(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
-
- return C_mk_bool(C_flonum_magnitude(x) > 0.0);
+ return C_i_positivep(x);
}
C_regparm C_word C_fcall C_i_negativep(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
-
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "negative?", x);
-
- return C_mk_bool(C_flonum_magnitude(x) < 0.0);
+ if (x & C_FIXNUM_BIT)
+ return C_i_fixnum_negativep(x);
+ else if (C_immediatep(x))
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);
+ else if (C_block_header(x) == C_FLONUM_TAG)
+ return C_mk_bool(C_flonum_magnitude(x) < 0.0);
+ else if (C_header_bits(x) == C_BIGNUM_TYPE)
+ return C_mk_bool(C_bignum_negativep(x));
+ else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_ratnum_type_tag))
+ return C_i_integer_negativep(C_block_item(x, 1));
+ else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_cplxnum_type_tag))
+ barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "negative?", x);
+ else
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);
}
-/* I */
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_u_i_negativep(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
+ return C_i_negativep(x);
+}
- return C_mk_bool(C_flonum_magnitude(x) < 0.0);
+C_regparm C_word C_fcall C_i_integer_negativep(C_word x)
+{
+ if (x & C_FIXNUM_BIT) return C_i_fixnum_negativep(x);
+ else return C_mk_bool(C_bignum_negativep(x));
}
C_regparm C_word C_fcall C_i_evenp(C_word x)
{
- double val, dummy;
- if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
-
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "even?", x);
-
- val = C_flonum_magnitude(x);
- if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
+ if(x & C_FIXNUM_BIT) {
+ return C_i_fixnumevenp(x);
+ } else if(C_immediatep(x)) {
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
-
- return C_mk_bool(fmod(val, 2.0) == 0.0);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ double val, dummy;
+ val = C_flonum_magnitude(x);
+ if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
+ else
+ return C_mk_bool(fmod(val, 2.0) == 0.0);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_mk_nbool(C_bignum_digits(x)[0] & 1);
+ } else { /* No need to try extended number */
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
+ }
}
-
-/* I */
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_u_i_evenp(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
+ return C_i_evenp(x);
+}
- return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
+C_regparm C_word C_fcall C_i_integer_evenp(C_word x)
+{
+ if (x & C_FIXNUM_BIT) return C_i_fixnumevenp(x);
+ return C_mk_nbool(C_bignum_digits(x)[0] & 1);
}
C_regparm C_word C_fcall C_i_oddp(C_word x)
{
- double val, dummy;
- if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
-
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "odd?", x);
-
- val = C_flonum_magnitude(x);
- if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
+ if(x & C_FIXNUM_BIT) {
+ return C_i_fixnumoddp(x);
+ } else if(C_immediatep(x)) {
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
-
- return C_mk_bool(fmod(val, 2.0) != 0.0);
+ } else if(C_block_header(x) == C_FLONUM_TAG) {
+ double val, dummy;
+ val = C_flonum_magnitude(x);
+ if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
+ else
+ return C_mk_bool(fmod(val, 2.0) != 0.0);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_mk_bool(C_bignum_digits(x)[0] & 1);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
+ }
}
-/* I */
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_u_i_oddp(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
+ return C_i_oddp(x);
+}
- return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
+C_regparm C_word C_fcall C_i_integer_oddp(C_word x)
+{
+ if (x & C_FIXNUM_BIT) return C_i_fixnumoddp(x);
+ return C_mk_bool(C_bignum_digits(x)[0] & 1);
}
@@ -5559,9 +5718,9 @@ C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)
C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
{
- if((x & C_FIXNUM_BIT) == 0) {
+ if(C_u_i_exactp(x) == C_SCHEME_FALSE) {
error_location = loc;
- barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR, NULL, x);
}
return C_SCHEME_UNDEFINED;
@@ -5572,7 +5731,7 @@ C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)
{
if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {
error_location = loc;
- barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
+ barf(C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR, NULL, x);
}
return C_SCHEME_UNDEFINED;
@@ -5592,7 +5751,7 @@ C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
{
- if((x & C_FIXNUM_BIT) == 0 && (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)) {
+ if (C_i_numberp(x) == C_SCHEME_FALSE) {
error_location = loc;
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);
}
diff --git a/types.db b/types.db
index e192f488..8a1d30ce 100644
--- a/types.db
+++ b/types.db
@@ -233,36 +233,56 @@
;;XXX predicate?
(integer? (#(procedure #:pure #:foldable) integer? (*) boolean)
- ((fixnum) (let ((#(tmp) #(1))) '#t))
- ((float) (##core#inline "C_u_i_fpintegerp" #(1))))
-
-(real? (#(procedure #:pure #:predicate number) real? (*) boolean))
+ ((integer) (let ((#(tmp) #(1))) '#t))
+ ((float) (##core#inline "C_u_i_fpintegerp" #(1)))
+ ((*) (##core#inline "C_i_integerp" #(1))))
+(exact-integer? (#(procedure #:pure #:foldable) exact-integer? (*) boolean)
+ ((integer) (let ((#(tmp) #(1))) '#t))
+ (((not integer)) (let ((#(tmp) #(1))) '#f))
+ ((*) (##core#inline "C_i_exact_integerp" #(1))))
+
+(real? (#(procedure #:pure #:foldable) real? (*) boolean)
+ (((or fixnum float bignum ratnum)) (let ((#(tmp) #(1))) '#t))
+ ((cplxnum) (let ((#(tmp) #(1))) '#f))
+ ((*) (##core#inline "C_i_realp" #(1))))
(complex? (#(procedure #:pure #:predicate number) complex? (*) boolean))
(exact? (#(procedure #:clean #:enforce #:foldable) exact? (number) boolean)
- ((fixnum) (let ((#(tmp) #(1))) '#t))
+ (((or integer ratnum)) (let ((#(tmp) #(1))) '#t))
((float) (let ((#(tmp) #(1))) '#f)))
(inexact? (#(procedure #:clean #:enforce #:foldable) inexact? (number) boolean)
- ((fixnum) (let ((#(tmp) #(1))) '#f))
+ (((or integer ratnum)) (let ((#(tmp) #(1))) '#f))
((float) (let ((#(tmp) #(1))) '#t)))
;;XXX predicate?
(rational? (#(procedure #:pure #:foldable) rational? (*) boolean)
- ((fixnum) (let ((#(tmp) #(1))) '#t)))
+ (((or fixnum bignum ratnum)) (let ((#(tmp) #(1))) '#t))
+ ((cplxnum) (let ((#(tmp) #(1))) '#f))
+ ((float) (##core#inline "C_u_i_flonum_finitep" #(1)))
+ ((*) (##core#inline "C_i_rationalp" #(1))))
(zero? (#(procedure #:clean #:enforce #:foldable) zero? (number) boolean)
- ((fixnum) (eq? #(1) '0))
+ ((integer) (eq? #(1) '0))
+ (((or cplxnum ratnum)) '#f)
((number) (##core#inline "C_u_i_zerop" #(1))))
-(odd? (#(procedure #:clean #:enforce #:foldable) odd? (number) boolean) ((fixnum) (fxodd? #(1))))
-(even? (#(procedure #:clean #:enforce #:foldable) even? (number) boolean) ((fixnum) (fxeven? #(1))))
+(odd? (#(procedure #:clean #:enforce #:foldable) odd? (number) boolean)
+ ((fixnum) (##core#inline "C_i_fixnumoddp" #(1)))
+ ((integer) (##core#inline "C_i_integer_oddp" #(1)))
+ ((*) (##core#inline "C_i_oddp" #(1))))
+(even? (#(procedure #:clean #:enforce #:foldable) even? (number) boolean)
+ ((fixnum) (##core#inline "C_i_fixnumevenp" #(1)))
+ ((integer) (##core#inline "C_i_integer_evenp" #(1)))
+ ((*) (##core#inline "C_i_evenp" #(1))))
(positive? (#(procedure #:clean #:enforce #:foldable) positive? (number) boolean)
- ((fixnum) (##core#inline "C_fixnum_greaterp" #(1) '0))
- ((number) (##core#inline "C_u_i_positivep" #(1))))
+ ((fixnum) (##core#inline "C_i_fixnum_positivep" #(1)))
+ ((integer) (##core#inline "C_i_integer_positivep" #(1)))
+ ((*) (##core#inline "C_i_positivep" #(1))))
(negative? (#(procedure #:clean #:enforce #:foldable) negative? (number) boolean)
- ((fixnum) (##core#inline "C_fixnum_lessp" #(1) '0))
- ((number) (##core#inline "C_u_i_negativep" #(1))))
+ ((fixnum) (##core#inline "C_i_fixnum_negativep" #(1)))
+ ((integer) (##core#inline "C_i_integer_negativep" #(1)))
+ ((*) (##core#inline "C_i_negativep" #(1))))
(max (#(procedure #:clean #:enforce #:foldable) max (#!rest number) number)
((fixnum fixnum) (fxmax #(1) #(2)))
@@ -704,11 +724,14 @@
(eval (procedure eval (* #!optional (struct environment)) . *))
(char-ready? (#(procedure #:enforce) char-ready? (#!optional input-port) boolean))
-(imag-part (#(procedure #:clean #:enforce #:foldable) imag-part (number) number)
- (((or fixnum float number)) (let ((#(tmp) #(1))) '0)))
+(real-part (#(procedure #:clean #:enforce #:foldable) real-part (number) (or integer float ratnum))
+ (((or fixnum float bignum ratnum)) #(1))
+ ((cplxnum) (##sys#slot #(1) '1)))
-(real-part (#(procedure #:clean #:enforce #:foldable) real-part (number) number)
- (((or fixnum float number)) #(1)))
+(imag-part (#(procedure #:clean #:enforce #:foldable) imag-part (number) (or integer float ratnum))
+ (((or fixnum bignum ratnum)) (let ((#(tmp) #(1))) '0))
+ ((float) (let ((#(tmp) #(1))) '0.0))
+ ((cplxnum) (##sys#slot #(1) '2)))
(magnitude (#(procedure #:clean #:enforce) magnitude (number) number)
((fixnum) (fixnum)
@@ -854,9 +877,20 @@
(file-exists? (#(procedure #:clean #:enforce) file-exists? (string) (or false string)))
(directory-exists? (#(procedure #:clean #:enforce) directory-exists? (string) (or false string)))
+(nan? (#(procedure #:clean #:enforce #:foldable) nan? (number) boolean)
+ (((or integer ratnum)) (let ((#(tmp) #(1))) '#f))
+ ((float) (##core#inline "C_u_i_flonum_nanp" #(1)))
+ ((*) (##core#inline "C_i_nanp" #(1))))
+
+(infinite? (#(procedure #:clean #:enforce #:foldable) infinite? (number) boolean)
+ (((or integer ratnum)) (let ((#(tmp) #(1))) '#f))
+ ((float) (##core#inline "C_u_i_flonum_infinitep" #(1)))
+ ((*) (##core#inline "C_i_infinitep" #(1))))
+
(finite? (#(procedure #:clean #:enforce #:foldable) finite? (number) boolean)
- ((fixnum) (let ((#(tmp) #(1))) '#t))
- (((or float number)) (##core#inline "C_i_finitep" #(1))))
+ (((or integer ratnum)) (let ((#(tmp) #(1))) '#t))
+ ((float) (##core#inline "C_u_i_flonum_finitep" #(1)))
+ ((*) (##core#inline "C_i_finitep" #(1))))
(fixnum-bits fixnum)
(fixnum-precision fixnum)
Trap